Hdoc/DTC/Write/HTML5.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DuplicateRecordFields #-}
   3 {-# LANGUAGE ExistentialQuantification #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE FlexibleContexts #-}
   6 {-# LANGUAGE MultiParamTypeClasses #-}
   7 {-# LANGUAGE OverloadedStrings #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# OPTIONS_GHC -fno-warn-orphans #-}
  10 module Hdoc.DTC.Write.HTML5
  11  ( module Hdoc.DTC.Write.HTML5
  12  , module Hdoc.DTC.Write.HTML5.Ident
  13  , module Hdoc.DTC.Write.HTML5.Base
  14  , module Hdoc.DTC.Write.HTML5.Judgment
  15  -- , module Hdoc.DTC.Write.HTML5.Error
  16  ) where
  17
  18 import Control.Applicative (Applicative(..))
  19 import Control.Monad (Monad(..), (=<<), forM_, mapM_, sequence_)
  20 import Data.Bool
  21 import Data.Default.Class (Default(..))
  22 import Data.Either (Either(..))
  23 import Data.Eq (Eq(..))
  24 import Data.Foldable (Foldable(..), any, concat, fold)
  25 import Data.Function (($), (.), const, on)
  26 import Data.Functor ((<$>), (<$))
  27 import Data.Functor.Compose (Compose(..))
  28 import Data.Hashable (hash)
  29 import Data.List.NonEmpty (NonEmpty(..))
  30 import Data.Locale hiding (Index)
  31 import Data.Maybe (Maybe(..), maybe, mapMaybe, maybeToList, listToMaybe, isNothing, fromMaybe)
  32 import Data.Monoid (Monoid(..))
  33 import Data.Ord (Ord(..))
  34 import Prelude (succ)
  35 import Data.Sequence (Seq)
  36 import Data.Semigroup (Semigroup(..))
  37 import Data.String (String)
  38 import Data.TreeSeq.Strict (Tree(..), tree0)
  39 import Data.Tuple (snd)
  40 import System.FilePath ((</>))
  41 import System.IO (IO)
  42 import Text.Blaze ((!))
  43 import Text.Blaze.Html (Html)
  44 import Text.Show (Show(..))
  45 import qualified Control.Category as Cat
  46 import qualified Control.Monad.Trans.RWS.Strict as RWS
  47 import qualified Control.Monad.Trans.Reader as R
  48 import qualified Data.HashMap.Strict as HM
  49 import qualified Data.HashSet as HS
  50 import qualified Data.List as List
  51 import qualified Data.Map.Strict as Map
  52 import qualified Data.Sequence as Seq
  53 import qualified Data.Strict.Maybe as Strict
  54 import qualified Data.Text as Text
  55 import qualified Data.Text.Lazy as TL
  56 import qualified Data.TreeMap.Strict as TM
  57 import qualified Text.Blaze.Html5 as H
  58 import qualified Text.Blaze.Html5.Attributes  as HA
  59 import qualified Text.Blaze.Internal as H
  60
  61 import Control.Monad.Utils
  62 import Hdoc.DTC.Document as DTC
  63 import Hdoc.DTC.Write.HTML5.Base
  64 import Hdoc.DTC.Write.HTML5.Error ()
  65 import Hdoc.DTC.Write.HTML5.Ident
  66 import Hdoc.DTC.Write.HTML5.Judgment
  67 import Hdoc.DTC.Write.Plain (Plainify(..))
  68 import Hdoc.DTC.Write.XML ()
  69 import Hdoc.Utils
  70 import Text.Blaze.Utils
  71 import qualified Hdoc.DTC.Analyze.Check as Analyze
  72 import qualified Hdoc.DTC.Analyze.Collect as Analyze
  73 import qualified Hdoc.DTC.Analyze.Index as Analyze
  74 import qualified Hdoc.DTC.Write.Plain as Plain
  75 import qualified Hdoc.TCT.Cell as TCT
  76 import qualified Hdoc.Utils as FS
  77 import qualified Hdoc.XML as XML
  78 import qualified Paths_hdoc as Hdoc
  79 import Debug.Trace
  80
  81 debug :: Show a => String -> a -> a
  82 debug msg a = trace (msg<>": "<>show a) a
  83 debugOn :: Show b => String -> (a -> b) -> a -> a
  84 debugOn msg get a = trace (msg<>": "<>show (get a)) a
  85 debugWith :: String -> (a -> String) -> a -> a
  86 debugWith msg get a = trace (msg<>": "<>get a) a
  87
  88 writeHTML5 :: Config -> DTC.Document -> IO Html
  89 writeHTML5 conf@Config{..} doc_init = do
  90         let all_index = Analyze.collectIndex doc_init
  91         let (doc@DTC.Document{..}, all_irefs) =
  92                 Analyze.indexifyDocument (fold all_index) doc_init
  93         let all = Analyze.collect doc `R.runReader` def
  94         let err = Analyze.errors all
  95         let ro = def
  96                  { reader_l10n     = loqualize config_locale
  97                  , reader_plainify = def{Plain.reader_l10n = loqualize config_locale}
  98                  , reader_all      = all
  99                  -- , reader_section  = body
 100                  }
 101         let st = def
 102                  { state_errors  = debug "errors" $ Nat1 1 <$ err
 103                  , state_notes   = fold $ toList <$> Analyze.all_notes all
 104                  , state_indices =
 105                         (<$> toList all_index) $ \terms ->
 106                                 (terms,) $
 107                                 TM.intersection const all_irefs $
 108                                 Analyze.indexOfTerms terms
 109                  }
 110         let (html5Body, _endState, endWriter) =
 111                 runComposeRWS ro st $ do
 112                         html5Judgments
 113                         html5ify err
 114                         html5DocumentHead head
 115                         html5ify body
 116         html5Head <- writeHTML5Head conf ro endWriter head body
 117         return $ do
 118                 H.docType
 119                 H.html ! HA.lang (attrify $ countryCode config_locale) $ do
 120                         html5Head
 121                         H.body $ do
 122                                 {- NOTE:
 123                                 unless (null state_scripts) $ do
 124                                         -- NOTE: indicate that JavaScript is active.
 125                                         H.script ! HA.type_ "application/javascript" $
 126                                                 "document.body.className = \"script\";"
 127                                 -}
 128                                 html5Body
 129         {-
 130         let (checkedBody,checkState) =
 131                 let state_collect = Analyze.collect doc in
 132                 Analyze.check body `S.runState` def
 133                  { Analyze.state_irefs = foldMap Analyze.irefsOfTerms $ Analyze.all_index state_collect
 134                  , Analyze.state_collect
 135                  }
 136         let (html5Body, endState) =
 137                 runComposeRWS def
 138                  { state_collect
 139                  {-
 140                  , state_indexs =
 141                         (<$> Analyze.all_index state_collect) $ \terms ->
 142                                 (terms,) $
 143                                 TM.intersection const state_irefs $
 144                                 Analyze.irefsOfTerms terms
 145                  , state_notes
 146                  -}
 147                  , state_ref
 148                  , state_section  = body
 149                  , state_l10n     = loqualize config_locale
 150                  , state_plainify = def{Plain.reader_l10n = loqualize config_locale}
 151                  } $ do
 152                         html5Judgments
 153                         html5ify state_errors
 154                         html5DocumentHead head
 155                         html5ify checkedBody
 156         html5Head <- writeHTML5Head conf endState head
 157         return $ do
 158                 let State{..} = endState
 159                 H.docType
 160                 H.html ! HA.lang (attrify $ countryCode config_locale) $ do
 161                         html5Head
 162                         H.body $ do
 163                                 {-
 164                                 unless (null state_scripts) $ do
 165                                         -- NOTE: indicate that JavaScript is active.
 166                                         H.script ! HA.type_ "application/javascript" $
 167                                                 "document.body.className = \"script\";"
 168                                 -}
 169                                 html5Body
 170         -}
 171 writeHTML5Head :: Config -> Reader -> Writer -> Head -> Body -> IO Html
 172 writeHTML5Head Config{..} Reader{..} Writer{..} Head{DTC.head_about=About{..}} body = do
 173         csss :: Html <- do
 174                 -- unless (any (\DTC.Link{..} -> rel == "stylesheet" && href /= URL "") links) $ do
 175                 (`foldMap` writer_styles) $ \case
 176                  Left css -> do
 177                         content <- FS.readFile =<< Hdoc.getDataFileName ("style"</>css)
 178                         return $ H.style ! HA.type_ "text/css" $
 179                                 H.toMarkup content
 180                  Right content -> return $ do
 181                         H.style ! HA.type_ "text/css" $
 182                                 -- NOTE: as a special case, H.style wraps its content into an External,
 183                                 -- so it does not HTML-escape its content.
 184                                 H.toMarkup content
 185         scripts :: Html <-
 186                 (`foldMap` writer_scripts) $ \script -> do
 187                         content <- FS.readFile =<< Hdoc.getDataFileName ("style"</>script)
 188                         return $ H.script ! HA.type_ "application/javascript" $
 189                                 H.toMarkup content
 190                 {-
 191                 if not (any (\DTC.Link{rel} -> rel == "script") links)
 192                  then do
 193                  else
 194                         mempty
 195                         case config_js of
 196                          Left "" -> mempty
 197                          Left  js -> H.script ! HA.src (attrify js)
 198                                               ! HA.type_ "application/javascript"
 199                                               $ mempty
 200                          Right js -> H.script ! HA.type_ "application/javascript"
 201                                               $ H.toMarkup js
 202                 -}
 203         return $
 204                 H.head $ do
 205                         H.meta ! HA.httpEquiv "Content-Type"
 206                                ! HA.content "text/html; charset=UTF-8"
 207                         unless (null about_titles) $ do
 208                                 H.title $
 209                                         H.toMarkup $ Plain.text reader_plainify $ List.head about_titles
 210                         forM_ about_links $ \Link{..} ->
 211                                 case rel of
 212                                  "stylesheet" | URL "" <- href ->
 213                                         H.style ! HA.type_ "text/css" $
 214                                                 H.toMarkup $ Plain.text def plain
 215                                  _ ->
 216                                         H.link ! HA.rel (attrify rel)
 217                                                ! HA.href (attrify href)
 218                         forM_ about_url $ \href ->
 219                                 H.link ! HA.rel "self"
 220                                        ! HA.href (attrify href)
 221                         unless (TL.null config_generator) $ do
 222                                 H.meta ! HA.name "generator"
 223                                        ! HA.content (attrify config_generator)
 224                         unless (null about_tags) $
 225                                 H.meta ! HA.name "keywords"
 226                                        ! HA.content (attrify $ TL.intercalate ", " about_tags)
 227                         let chapters =
 228                                 (`mapMaybe` toList body) $ \case
 229                                  Tree (BodySection s) _ -> Just s
 230                                  _ -> Nothing
 231                         forM_ chapters $ \Section{..} ->
 232                                 H.link ! HA.rel "Chapter"
 233                                        ! HA.title (attrify $ plainify section_title)
 234                                        ! HA.href (refIdent $ identify section_posXML)
 235                         case config_css of
 236                          Left "" -> mempty
 237                          Left css ->
 238                                 H.link ! HA.rel "stylesheet"
 239                                        ! HA.type_ "text/css"
 240                                        ! HA.href (attrify css)
 241                          Right css ->
 242                                 H.style ! HA.type_ "text/css" $
 243                                         H.toMarkup css
 244                         csss
 245                         scripts
 246
 247 html5DocumentHead :: Head -> HTML5
 248 html5DocumentHead Head{DTC.head_about=About{..}, head_judgments} = do
 249         ro <- composeLift RWS.ask
 250         unless (null about_authors) $ do
 251                 H.div ! HA.class_ "document-head" $$
 252                         H.table $$ do
 253                                 H.tbody $$ do
 254                                         H.tr $$ do
 255                                                 H.td ! HA.class_ "left"  $$ docHeaders
 256                                                 H.td ! HA.class_ "right" $$ docAuthors
 257         unless (null about_titles) $ do
 258                 H.div ! HA.class_ "title"
 259                       ! HA.id "document-title." $$ do
 260                         forM_ about_titles $ \title ->
 261                                 H.h1 ! HA.id (attrify $ identifyTitle (Plain.reader_l10n $ reader_plainify ro) title) $$
 262                                         html5ify title
 263         do -- judgments
 264                 st <- composeLift RWS.get
 265                 let sectionJudgments = {-debug "sectionJudgments" $-} HS.fromList head_judgments
 266                 let opinsBySectionByJudgment = {-debug "opinsBySectionByJudgment" $-} state_opinions st `HM.intersection` HS.toMap sectionJudgments
 267                 composeLift $ RWS.modify $ \s ->
 268                         s{ state_judgments = head_judgments
 269                          , state_opinions  =
 270                                 -- NOTE: drop current opinions of the judgments of this section
 271                                 HM.unionWith (const List.tail)
 272                                  (state_opinions s)
 273                                  opinsBySectionByJudgment
 274                          }
 275                 unless (null opinsBySectionByJudgment) $ do
 276                         let choicesJ = Analyze.choicesByJudgment head_judgments
 277                         forM_ head_judgments $ \judgment@Judgment{..} -> do
 278                                 -- NOTE: preserve the wanted order
 279                                 let opinsBySection = opinsBySectionByJudgment HM.!judgment
 280                                 H.div ! HA.class_ "judgment section-judgment document-judgment" $$ do
 281                                         html5ify judgment
 282                                          { judgment_opinionsByChoice = listToMaybe opinsBySection
 283                                          , judgment_choices = maybe [] snd $ HM.lookup judgment choicesJ
 284                                          }
 285         where
 286         docHeaders =
 287                 H.table ! HA.class_ "document-headers" $$
 288                         H.tbody $$ do
 289                                 Loqualization l10n <- composeLift $ RWS.asks reader_l10n
 290                                 forM_ about_series $ \s@Serie{..} ->
 291                                         header $
 292                                                 case urlSerie s of
 293                                                  Nothing -> do
 294                                                         headerName  $ html5ify serie_name
 295                                                         headerValue $ html5ify serie_id
 296                                                  Just href -> do
 297                                                         headerName  $ html5ify serie_name
 298                                                         headerValue $
 299                                                                 H.a ! HA.href (attrify href) $$
 300                                                                         html5ify serie_id
 301                                 forM_ about_links $ \Link{..} ->
 302                                         unless (TL.null $ unName name) $
 303                                                 header $ do
 304                                                         headerName  $ html5ify name
 305                                                         headerValue $ html5ify $ Tree PlainEref{eref_href=href} plain
 306                                 forM_ about_date $ \d ->
 307                                         header $ do
 308                                                 headerName  $ l10n_Header_Date l10n
 309                                                 headerValue $ html5ify d
 310                                 forM_ about_url $ \href ->
 311                                         header $ do
 312                                                 headerName  $ l10n_Header_Address l10n
 313                                                 headerValue $ html5ify $ tree0 $ PlainEref{eref_href=href}
 314                                 forM_ about_headers $ \Header{..} ->
 315                                         header $ do
 316                                                 headerName  $ html5ify header_name
 317                                                 headerValue $ html5ify header_value
 318         docAuthors =
 319                 H.table ! HA.class_ "document-authors" $$
 320                         H.tbody $$ do
 321                                 forM_ about_authors $ \a ->
 322                                         H.tr $$
 323                                                 H.td ! HA.class_ "author" $$
 324                                                         html5ify a
 325         header :: HTML5 -> HTML5
 326         header hdr = H.tr ! HA.class_ "header" $$ hdr
 327         headerName :: HTML5 -> HTML5
 328         headerName hdr =
 329                 H.td ! HA.class_ "header-name" $$ do
 330                         hdr
 331                         Loqualization l10n <- composeLift $ RWS.asks reader_l10n
 332                         Plain.l10n_Colon l10n
 333         headerValue :: HTML5 -> HTML5
 334         headerValue hdr =
 335                 H.td ! HA.class_ "header-value" $$ do
 336                         hdr
 337
 338 -- 'Html5ify' instances
 339 instance Html5ify TCT.Location where
 340         html5ify = \case
 341          s:|[] ->
 342                 H.span ! HA.class_ "tct-location" $$
 343                         html5ify $ show s
 344          ss -> do
 345                 H.ul ! HA.class_ "tct-location" $$
 346                         forM_ ss $ \s ->
 347                                 H.li $$
 348                                         html5ify $ show s
 349 instance Html5ify Body where
 350         html5ify body =
 351                 localComposeRWS (\ro -> ro{reader_section = body}) $ go body
 352                 where
 353                 go bs =
 354                         case Seq.viewl bs of
 355                          Seq.EmptyL ->
 356                                 popNotes >>= html5Notes
 357                          curr Seq.:< next -> do
 358                                 case curr of
 359                                  Tree BodySection{} _ -> popNotes >>= html5Notes
 360                                  _ -> mempty
 361                                 html5ify curr
 362                                 go next
 363 instance Html5ify (Tree BodyNode) where
 364         html5ify (Tree b bs) = do
 365                 case b of
 366                  BodyBlock blk -> html5ify blk
 367                  BodySection Section{..} -> do
 368                         localComposeRWS (\ro -> ro{reader_section = bs}) $ do
 369                                 Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
 370                                 notes <- popNotes
 371                                 html5CommonAttrs section_attrs
 372                                  { attrs_classes = "section":attrs_classes section_attrs
 373                                  , attrs_id      = Nothing
 374                                  } $ do
 375                                         H.section ! HA.id (attrify $ identify section_posXML) $$ do
 376                                                 forM_ section_aliases html5ify
 377                                                 st <- composeLift RWS.get
 378                                                 do -- judgments
 379                                                         let sectionJudgments =
 380                                                                 -- NOTE: merge inherited judgments with those of thie section,
 381                                                                 -- while preserving their appearing order.
 382                                                                 List.nubBy ((==) `on` hash) $
 383                                                                 state_judgments st <> section_judgments
 384                                                         let opinsBySectionByJudgment =
 385                                                                 -- NOTE: gather opinions of the judgments of this section.
 386                                                                 state_opinions st `HM.intersection`
 387                                                                 HS.toMap (HS.fromList sectionJudgments)
 388                                                         let dropChildrenBlocksJudgments =
 389                                                                 -- NOTE: drop the "phantom" judgments concerning the 'BodyBlock's
 390                                                                 -- directly children of this 'BodySection'.
 391                                                                 if (`any`bs) $ \case
 392                                                                          Tree BodyBlock{} _ -> True
 393                                                                          _ -> False
 394                                                                 then List.tail
 395                                                                 else Cat.id
 396                                                         composeLift $ RWS.modify $ \s ->
 397                                                                 s{ state_judgments = sectionJudgments
 398                                                                  , state_opinions  =
 399                                                                         -- NOTE: drop current opinions of the judgments of this section
 400                                                                         HM.unionWith (const $ List.tail . dropChildrenBlocksJudgments)
 401                                                                          (state_opinions s)
 402                                                                          opinsBySectionByJudgment
 403                                                                  }
 404                                                         unless (null opinsBySectionByJudgment) $ do
 405                                                                 composeLift $ RWS.tell def
 406                                                                  { writer_styles = HS.singleton $ Left "dtc-judgment.css" }
 407                                                                 H.aside ! HA.class_ "aside" $$ do
 408                                                                         let choicesJ = Analyze.choicesByJudgment section_judgments
 409                                                                         forM_ sectionJudgments $ \judgment@Judgment{..} -> do
 410                                                                                 let opinsBySection = opinsBySectionByJudgment HM.!judgment
 411                                                                                 H.div ! HA.class_ "judgment section-judgment" $$ do
 412                                                                                         html5ify judgment
 413                                                                                          { judgment_opinionsByChoice = listToMaybe opinsBySection
 414                                                                                          , judgment_choices = maybe [] snd $ HM.lookup judgment choicesJ
 415                                                                                          }
 416                                                 let mayId =
 417                                                         case attrs_id section_attrs of
 418                                                          Just ident | Just [_] <- toList <$> HM.lookup ident all_section ->
 419                                                                 Just $ identifyTag "" ident Nothing
 420                                                          _ -> Nothing
 421                                                 H.table
 422                                                  ! HA.class_ "section-header"
 423                                                  !?? mayAttr HA.id mayId $$
 424                                                         H.tbody $$
 425                                                                 H.tr $$ do
 426                                                                         H.td ! HA.class_ "section-number" $$ do
 427                                                                                 html5SectionNumber $ XML.pos_ancestors section_posXML
 428                                                                         H.td ! HA.class_ "section-title" $$ do
 429                                                                                 (case List.length $ XML.pos_ancestors section_posXML of
 430                                                                                  0 -> H.h1
 431                                                                                  1 -> H.h2
 432                                                                                  2 -> H.h3
 433                                                                                  3 -> H.h4
 434                                                                                  4 -> H.h5
 435                                                                                  5 -> H.h6
 436                                                                                  _ -> H.h6) $$
 437                                                                                         html5ify section_title
 438                                                 html5ify bs
 439                                                 do -- judgments
 440                                                         composeLift $ RWS.modify $ \s ->
 441                                                                 s{ state_judgments = state_judgments st }
 442                                         html5Notes notes
 443                                                 {- FIXME
 444                                                 do -- notes
 445                                                         notes <- composeLift $ S.gets state_notes
 446                                                         maybe mempty html5Notes $
 447                                                                 Map.lookup (XML.pos_ancestors section_posXML) notes
 448                                                 -}
 449 instance Html5ify Block where
 450         html5ify = \case
 451          BlockPara para -> html5ify para
 452          BlockBreak{..} ->
 453                 html5CommonAttrs attrs
 454                  { attrs_classes = "page-break":"print-only":attrs_classes attrs } $
 455                 H.div $$
 456                         H.p $$ " " -- NOTE: force page break
 457          BlockToC{..} ->
 458                 H.nav ! HA.class_ "toc"
 459                       ! HA.id (attrify $ identify posXML) $$ do
 460                         H.span ! HA.class_ "toc-name" $$
 461                                 H.a ! HA.href (refIdent $ identify posXML) $$ do
 462                                         Loqualization l10n <- composeLift $ RWS.asks reader_l10n
 463                                         Plain.l10n_Table_of_Contents l10n
 464                         H.ul $$ do
 465                                 Reader{reader_section} <- composeLift RWS.ask
 466                                 forM_ reader_section $ html5ifyToC depth
 467          BlockToF{..} -> do
 468                 H.nav ! HA.class_ "tof"
 469                       ! HA.id (attrify $ identify posXML) $$
 470                         H.table ! HA.class_ "tof" $$
 471                                 H.tbody $$
 472                                         html5ifyToF types
 473          BlockAside{..} ->
 474                 html5CommonAttrs attrs $
 475                 H.aside ! HA.class_ "aside" $$ do
 476                         forM_ blocks html5ify
 477          BlockFigure{..} ->
 478                 html5CommonAttrs attrs
 479                  { attrs_classes = "figure":("figure-"<>type_):attrs_classes attrs
 480                  , attrs_id      = Just $ identify $ XML.pos_ancestorsWithFigureNames posXML
 481                  } $
 482                 H.div $$ do
 483                         H.table ! HA.class_ "figure-caption" $$
 484                                 H.tbody $$
 485                                         H.tr $$ do
 486                                                 if TL.null type_
 487                                                  then H.a ! HA.href (refIdent $ identify posXML) $$ mempty
 488                                                  else
 489                                                         H.td ! HA.class_ "figure-number" $$ do
 490                                                                 H.a ! HA.href (refIdent $ identify $ XML.pos_ancestorsWithFigureNames posXML) $$ do
 491                                                                         html5ify type_
 492                                                                         html5ify $ XML.pos_ancestorsWithFigureNames posXML
 493                                                 forM_ mayTitle $ \title -> do
 494                                                         H.td ! HA.class_ "figure-colon" $$ do
 495                                                                 unless (TL.null type_) $ do
 496                                                                         Loqualization l10n <- composeLift $ RWS.asks reader_l10n
 497                                                                         Plain.l10n_Colon l10n
 498                                                         H.td ! HA.class_ "figure-title" $$ do
 499                                                                 html5ify title
 500                         H.div ! HA.class_ "figure-content" $$ do
 501                                 html5ify paras
 502          BlockIndex{posXML} -> do
 503                 State{..} <- composeLift RWS.get
 504                 composeLift $ do
 505                         RWS.tell def
 506                          { writer_styles = HS.singleton $ Left "dtc-index.css" }
 507                         RWS.modify $ \s -> s{state_indices=List.tail state_indices}
 508                 let (allTerms,refsByTerm) = List.head state_indices
 509                 let chars = Analyze.termsByChar allTerms
 510                 H.div ! HA.class_ "index"
 511                       ! HA.id (attrify $ identify posXML) $$ do
 512                         H.nav ! HA.class_ "index-nav" $$ do
 513                                 forM_ (Map.keys chars) $ \char ->
 514                                         H.a ! HA.href (refIdent (identify posXML <> "." <> identify char)) $$
 515                                                 html5ify char
 516                         H.dl ! HA.class_ "index-chars" $$
 517                                 forM_ (Map.toList chars) $ \(char,terms) -> do
 518                                         H.dt $$ do
 519                                                 let i = identify posXML <> "." <> identify char
 520                                                 H.a ! HA.id (attrify i)
 521                                                     ! HA.href (refIdent i) $$
 522                                                         html5ify char
 523                                         H.dd $$
 524                                                 H.dl ! HA.class_ "index-term" $$ do
 525                                                 forM_ terms $ \aliases -> do
 526                                                         H.dt $$
 527                                                                 H.ul ! HA.class_ "index-aliases" $$
 528                                                                         forM_ (List.take 1 aliases) $ \term -> do
 529                                                                                 H.li ! HA.id (attrify $ identifyIref term Nothing) $$
 530                                                                                         html5ify term
 531                                                         H.dd $$ do
 532                                                                 let sortedRefs =
 533                                                                         List.sortBy (compare `on` snd) $
 534                                                                         (`foldMap` aliases) $ \term ->
 535                                                                                 fromMaybe def $ do
 536                                                                                         path <- DTC.pathFromWords term
 537                                                                                         refs <- Strict.maybe Nothing Just $ TM.lookup path refsByTerm
 538                                                                                         return $
 539                                                                                                 Seq.foldrWithIndex (\num ref acc -> ((term, succ num), ref):acc) [] $
 540                                                                                                 Seq.reverse refs
 541                                                                 html5CommasDot $
 542                                                                         (<$> sortedRefs) $ \((term, num), ref) ->
 543                                                                                 H.a ! HA.class_ "index-iref"
 544                                                                                     ! HA.href (refIdent $ identifyIref term $ Just $ Nat1 num) $$
 545                                                                                         case ref of
 546                                                                                          Left{} -> "0"::HTML5
 547                                                                                          Right Section{section_posXML=posSection} ->
 548                                                                                                 html5ify $ XML.pos_ancestors posSection
 549          BlockReferences{..} ->
 550                 html5CommonAttrs attrs
 551                  { attrs_classes = "references":attrs_classes attrs
 552                  , attrs_id      = Just $ Ident $ Plain.text def $ XML.pos_ancestors posXML
 553                  } $
 554                 H.div $$ do
 555                         H.table $$
 556                                 forM_ refs html5ify
 557          BlockGrades{..} ->
 558                 html5CommonAttrs attrs
 559                  { attrs_classes = "grades":attrs_classes attrs
 560                  , attrs_id      = Just $ Ident $ Plain.text def $ XML.pos_ancestors posXML
 561                  } $
 562                 H.div $$ do
 563                         -- let dg = List.head $ List.filter default_ scale
 564                         -- let sc = MJ.Scale (Set.fromList scale) dg
 565                         -- o  :: Map choice grade
 566                         -- os :: Opinions (Map judge (Opinion choice grade))
 567                         mempty
 568                         -- html5ify $ show b
 569          BlockJudges js -> html5ify js
 570 instance Html5ify Para where
 571         html5ify = \case
 572          ParaItem{..} ->
 573                 html5CommonAttrs def
 574                  { attrs_classes = "para":cls item
 575                  } $
 576                         html5ify item
 577          ParaItems{..} ->
 578                 html5CommonAttrs attrs
 579                  { attrs_classes = "para":attrs_classes attrs
 580                  , attrs_id      = id_ posXML
 581                  } $
 582                 H.div $$
 583                         forM_ items $ \item ->
 584                                 html5AttrClass (cls item) $
 585                                 html5ify item
 586          where
 587                 id_ = Just . Ident . Plain.text def . XML.pos_ancestors
 588                 cls = \case
 589                  ParaPlain{}      -> []
 590                  ParaArtwork{..}  -> ["artwork", "artwork-"<>type_]
 591                  ParaQuote{..}    -> ["quote", "quote-"<>type_]
 592                  ParaComment{}    -> []
 593                  ParaOL{}         -> ["ol"]
 594                  ParaUL{}         -> ["ul"]
 595                  ParaJudgment Judgment{..} -> ["judgment"] <> when (null judgment_opinionsByChoice) ["judgment-error"]
 596 instance Html5ify ParaItem where
 597         html5ify = \case
 598          ParaPlain p -> H.p $$ html5ify p
 599          ParaArtwork{..} -> H.pre $$ do html5ify text
 600          ParaQuote{..} -> H.div $$ do html5ify paras
 601          ParaComment t -> html5ify $ H.Comment (H.String $ TL.unpack t) ()
 602          ParaOL items ->
 603                 H.dl $$ do
 604                         forM_ items $ \ListItem{..} -> do
 605                                 H.dt ! HA.class_ "name" $$ do
 606                                         html5ify name
 607                                         "."::HTML5
 608                                 H.dd ! HA.class_ "value" $$
 609                                         html5ify paras
 610          ParaUL items ->
 611                 H.dl $$ do
 612                         forM_ items $ \item -> do
 613                                 H.dt $$ "—"
 614                                 H.dd $$ html5ify item
 615          ParaJudgment j -> html5ify j
 616 instance Html5ify [Para] where
 617         html5ify = mapM_ html5ify
 618 instance Html5ify Plain where
 619         html5ify ps =
 620                 case Seq.viewl ps of
 621                  Seq.EmptyL -> mempty
 622                  curr Seq.:< next ->
 623                         case curr of
 624                         -- NOTE: gather adjacent PlainNotes
 625                          Tree PlainNote{} _
 626                           | (notes, rest) <- Seq.spanl (\case {Tree PlainNote{} _ -> True; _ -> False}) next -> do
 627                                 H.sup ! HA.class_ "note-numbers" $$ do
 628                                         html5ify curr
 629                                         forM_ notes $ \note -> do
 630                                                 ", "::HTML5
 631                                                 html5ify note
 632                                 " "::HTML5
 633                                 html5ify rest
 634                         --
 635                          _ -> do
 636                                 html5ify curr
 637                                 html5ify next
 638 instance Html5ify (Tree PlainNode)
 639  where html5ify (Tree n ps) =
 640         case n of
 641          PlainBreak  -> html5ify H.br
 642          PlainText t -> html5ify t
 643          PlainGroup  -> html5ify ps
 644          PlainB      -> H.strong $$ html5ify ps
 645          PlainCode   -> H.code   $$ html5ify ps
 646          PlainDel    -> H.del    $$ html5ify ps
 647          PlainI -> do
 648                 i <- composeLift $ RWS.asks reader_italic
 649                 H.em ! HA.class_ (if i then "even" else "odd") $$
 650                         localComposeRWS (\ro -> ro{reader_italic=not i}) $
 651                                 html5ify ps
 652          PlainSpan{..} ->
 653                 html5CommonAttrs attrs $
 654                 H.span $$ html5ify ps
 655          PlainSub  -> H.sub    $$ html5ify ps
 656          PlainSup  -> H.sup    $$ html5ify ps
 657          PlainSC   -> H.span ! HA.class_ "smallcaps" $$ html5ify ps
 658          PlainU    -> H.span ! HA.class_ "underline" $$ html5ify ps
 659          PlainNote{..} -> do
 660                 num <- composeLift $ do
 661                         num <- RWS.gets state_note_num_ref
 662                         RWS.modify $ \s -> s{state_note_num_ref=succNat1 num}
 663                         return num
 664                 H.a ! HA.class_ "note-ref"
 665                     ! HA.id ("note-ref."<>attrify num)
 666                     ! HA.href ("#note."<>attrify num) $$
 667                         html5ify num
 668          PlainQ -> do
 669                 H.span ! HA.class_ "q" $$ do
 670                         Loqualization l10n <- composeLift $ RWS.asks reader_l10n
 671                         Plain.l10n_Quote (html5ify $ Tree PlainI ps) l10n
 672          PlainEref{..} -> do
 673                 H.a ! HA.class_ "eref no-print"
 674                     ! HA.href (attrify eref_href) $$
 675                         if null ps
 676                         then html5ify $ unURL eref_href
 677                         else html5ify ps
 678                 H.span ! HA.class_ "eref print-only" $$ do
 679                         unless (null ps) $ do
 680                                 html5ify ps
 681                                 " "::HTML5
 682                         "<"::HTML5
 683                         html5ify eref_href
 684                         ">"
 685          PlainTag{..}
 686           | tag_back -> do
 687                 Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
 688                 State{state_errors=Analyze.Errors{..}} <- composeLift RWS.get
 689                 case HM.lookup tag_ident all_tag of
 690                  Nothing -> pure ()
 691                  Just anchs ->
 692                         H.span ! HA.class_ "tag-backs" $$
 693                                 html5Commas $
 694                                 (<$> List.zip (toList anchs) [1..]) $ \((_loc, maySection),num) ->
 695                                         H.a ! HA.class_ "tag-back"
 696                                             ! HA.href (refIdent $ identifyTag "-back" tag_ident $ Just $ Nat1 num) $$
 697                                                 html5ify maySection
 698           | otherwise -> do
 699                 State{state_tag} <- composeLift RWS.get
 700                 let num = HM.lookupDefault (Nat1 1) tag_ident state_tag
 701                 composeLift $ RWS.modify $ \s -> s
 702                  { state_tag = HM.insert tag_ident (succNat1 num) state_tag }
 703                 H.span ! HA.class_ "tag"
 704                        ! HA.id (attrify $ identifyTag "-back" tag_ident $ Just num) $$
 705                         html5ify tag_ident
 706          PlainAt{..}
 707           | at_back -> do
 708                 Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
 709                 State{state_errors=Analyze.Errors{..}} <- composeLift RWS.get
 710                 case HM.lookup at_ident all_at of
 711                  Nothing -> pure ()
 712                  Just anchs ->
 713                         H.span ! HA.class_ "at-backs" $$
 714                                 html5Commas $
 715                                 (<$> List.zip (toList anchs) [1..]) $ \((_loc, maySection),num) ->
 716                                         H.a ! HA.class_ "at-back"
 717                                             ! HA.href (refIdent $ identifyAt "-back" at_ident $ Just $ Nat1 num) $$
 718                                                 html5ify maySection
 719           | otherwise -> do
 720                 Reader{..} <- composeLift RWS.ask
 721                 State{state_errors=errs@Analyze.Errors{..}, ..} <- composeLift RWS.get
 722                 case () of
 723                  _ | Just num <- HM.lookup at_ident errors_at_unknown -> do
 724                         composeLift $ RWS.modify $ \s -> s
 725                          { state_errors = errs
 726                                  { Analyze.errors_at_unknown =
 727                                         HM.adjust succNat1 at_ident errors_at_unknown } }
 728                         H.span ! HA.class_ "at at-unknown"
 729                                ! HA.id (attrify $ identifyAt "-unknown" at_ident (Just num)) $$
 730                                 html5ify at_ident
 731                    | Just num <- HM.lookup at_ident errors_at_ambiguous -> do
 732                         composeLift $ RWS.modify $ \s -> s
 733                          { state_errors = errs
 734                                  { Analyze.errors_at_ambiguous =
 735                                         HM.adjust succNat1 at_ident errors_at_ambiguous } }
 736                         H.span ! HA.class_ "at at-ambiguous"
 737                                ! HA.id (attrify $ identifyAt "-ambiguous" at_ident (Just num)) $$
 738                                 html5ify at_ident
 739                    | otherwise -> do
 740                         let num = HM.lookupDefault (Nat1 1) at_ident state_at
 741                         composeLift $ RWS.modify $ \s -> s
 742                          { state_at = HM.insert at_ident (succNat1 num) state_at }
 743                         H.a ! HA.class_ "at"
 744                             ! HA.href (refIdent $ identifyAt "" at_ident Nothing)
 745                             ! HA.id (attrify $ identifyAt "-back" at_ident $ Just num) $$
 746                                 html5ify at_ident
 747          PlainRef{..} -> do
 748                 Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
 749                 State{state_errors=errs@Analyze.Errors{..}, ..} <- composeLift RWS.get
 750                 case toList $ HM.lookupDefault def ref_ident all_reference of
 751                  [] -> do
 752                         let num = HM.lookup ref_ident errors_ref_unknown
 753                         composeLift $ RWS.modify $ \s -> s
 754                          { state_errors = errs
 755                                  { Analyze.errors_ref_unknown =
 756                                         HM.adjust succNat1 ref_ident errors_ref_unknown } }
 757                         H.span ! HA.class_ "reference reference-unknown"
 758                                ! HA.id (attrify $ identifyReference "-unknown" ref_ident num) $$ do
 759                                 "["::HTML5
 760                                 html5ify ref_ident
 761                                 "]"
 762                  [Reference{..}] -> do
 763                         let num = HM.lookupDefault (Nat1 1) ref_ident state_ref
 764                         composeLift $ RWS.modify $ \s -> s
 765                          { state_ref = HM.insert ref_ident (succNat1 num) state_ref }
 766                         let a = H.a ! HA.href (refIdent $ identifyReference "" ref_ident Nothing)
 767                         let ref = do
 768                                 H.span ! HA.class_ "reference"
 769                                        ! HA.id (attrify  $ identifyReference "" ref_ident $ Just num) $$ do
 770                                         "["::HTML5
 771                                         a $$ html5ify ref_ident
 772                                         "]"
 773                         case toList ps of
 774                          [] -> ref
 775                          [Tree (PlainText "") _] -> do
 776                                 refs <- composeLift $ RWS.asks $ Analyze.all_reference . reader_all
 777                                 case toList <$> HM.lookup ref_ident refs of
 778                                  Just [Reference{reference_about=About{..}}] -> do
 779                                         forM_ (List.take 1 about_titles) $ \(Title title) -> do
 780                                                 html5ify $ Tree PlainQ $
 781                                                         case about_url of
 782                                                          Nothing -> title
 783                                                          Just u -> pure $ Tree (PlainEref u) title
 784                                                 " "::HTML5
 785                                                 ref
 786                                  _ -> mempty
 787                          _ -> do
 788                                 a $$ html5ify ps
 789                                 H.span ! HA.class_ "print-only" $$ do
 790                                         " "::HTML5
 791                                         ref
 792                  _ -> do
 793                         case toList ps of
 794                          [] -> mempty
 795                          [Tree (PlainText "") _] -> mempty
 796                          _ -> do
 797                                 html5ify ps
 798                                 " "::HTML5
 799                         H.span ! HA.class_ "reference reference-ambiguous" $$ do
 800                                 "["::HTML5
 801                                 html5ify ref_ident
 802                                 "]"
 803          PlainIref{..} ->
 804                 case pathFromWords iref_term of
 805                  Nothing -> html5ify ps
 806                  Just path -> do
 807                         Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
 808                         State{state_irefs} <- composeLift RWS.get
 809                         let num = Strict.fromMaybe (Nat1 1) $ TM.lookup path state_irefs
 810                         composeLift $ RWS.modify $ \s -> s
 811                          { state_irefs = TM.insert const path (succNat1 num) state_irefs }
 812                         H.span ! HA.class_ "iref"
 813                                ! HA.id (attrify $ identifyIref iref_term $ Just num) $$
 814                                 html5ify ps
 815 instance Html5ify [Title] where
 816         html5ify =
 817                 html5ify . fold . List.intersperse sep . toList
 818                 where sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
 819 instance Html5ify Title where
 820         html5ify (Title t) = html5ify t
 821 instance Html5ify About where
 822         html5ify About{..} = do
 823                 H.p $$
 824                         html5CommasDot $ concat $
 825                                  [ html5Titles about_titles
 826                                  , html5ify <$> about_authors
 827                                  , html5ify <$> maybeToList about_date
 828                                  , html5ify <$> maybeToList about_editor
 829                                  , html5ify <$> about_series
 830                                  ]
 831                 forM_ about_url $ \u -> do
 832                         H.p ! HA.class_ "reference-url print-only" $$ do
 833                                 "<"::HTML5
 834                                 html5ify u
 835                                 ">"
 836                 forM_ about_description $ \description -> do
 837                         H.div ! HA.class_ "reference-description" $$ do
 838                                 html5ify description
 839                 where
 840                 html5Titles :: [Title] -> [HTML5]
 841                 html5Titles ts | null ts = []
 842                 html5Titles ts = [html5Title $ joinTitles ts]
 843                         where
 844                         joinTitles = fold . List.intersperse sep . toList
 845                         sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
 846                 html5Title (Title title) = do
 847                         H.span ! HA.class_ "no-print" $$
 848                                 html5ify $ Tree PlainQ $
 849                                         case about_url of
 850                                          Nothing -> title
 851                                          Just u -> pure $ Tree (PlainEref u) title
 852                         H.span ! HA.class_ "print-only" $$
 853                                 html5ify $ Tree PlainQ title
 854 instance Html5ify Serie where
 855         html5ify s@Serie{..} = do
 856                 Loqualization l10n <- composeLift $ RWS.asks reader_l10n
 857                 case urlSerie s of
 858                  Nothing -> do
 859                         html5ify serie_name
 860                         Plain.l10n_Colon l10n :: HTML5
 861                         html5ify serie_id
 862                  Just href -> do
 863                         html5ify $
 864                                 Tree PlainEref{eref_href=href} $
 865                                 Seq.fromList
 866                                  [ tree0 $ PlainText $ unName serie_name
 867                                  , tree0 $ PlainText $ Plain.l10n_Colon l10n
 868                                  , tree0 $ PlainText serie_id
 869                                  ]
 870 instance Html5ify Entity where
 871         html5ify Entity{..} = do
 872                 case () of
 873                  _ | not (TL.null entity_email) -> do
 874                         H.span ! HA.class_ "no-print" $$ do
 875                                 html5ify $
 876                                         Tree (PlainEref $ URL $ "mailto:"<>entity_email) $
 877                                                 pure $ tree0 $ PlainText entity_name
 878                                 html5ify $ orgs entity_org
 879                         H.span ! HA.class_ "print-only" $$
 880                                 html5ify $
 881                                         Tree (PlainEref $ URL entity_email) $
 882                                                 pure $ tree0 $ PlainText $
 883                                                         entity_name <> orgs entity_org
 884                         where
 885                         orgs = maybe "" $ \Entity{entity_name=name, entity_org=org} -> " ("<>name<>orgs org<>")"
 886                  _ | Just u <- entity_url ->
 887                         html5ify $
 888                                 Tree (PlainEref u) $
 889                                         pure $ tree0 $ PlainText entity_name
 890                  _ ->
 891                         html5ify $
 892                                 tree0 $ PlainText entity_name
 893 instance Html5ify Words where
 894         html5ify = html5ify . Analyze.plainifyWords
 895 instance Html5ify Alias where
 896         html5ify Alias{..} = do
 897                 Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
 898                 let mayId =
 899                         case attrs_id alias_attrs of
 900                          Just ident | Just [_] <- toList <$> HM.lookup ident all_section ->
 901                                 Just $ identifyTag "" ident Nothing
 902                          _ -> Nothing
 903                 H.a ! HA.class_ "alias"
 904                     !?? mayAttr HA.id mayId $$
 905                         mempty
 906 instance Html5ify URL where
 907         html5ify (URL url) =
 908                 H.a ! HA.class_ "url"
 909                     ! HA.href (attrify url) $$
 910                         html5ify url
 911 instance Html5ify Date where
 912         html5ify date = do
 913                 Loqualization l10n <- composeLift $ RWS.asks reader_l10n
 914                 Plain.l10n_Date date l10n
 915 instance Html5ify Reference where
 916         html5ify Reference{..} = do
 917                 Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
 918                 State{state_errors=errs@Analyze.Errors{..}, ..} <- composeLift RWS.get
 919                 H.tr $$ do
 920                         H.td ! HA.class_ "reference-key" $$ do
 921                                 "["::HTML5
 922                                 case HM.lookup reference_id errors_reference_ambiguous of
 923                                  Nothing ->
 924                                         H.a ! HA.class_ "reference"
 925                                             ! HA.href (refIdent $ identifyReference "" reference_id Nothing)
 926                                             ! HA.id   (attrify  $ identifyReference "" reference_id Nothing) $$
 927                                                 html5ify reference_id
 928                                  Just num -> do
 929                                         composeLift $ RWS.modify $ \s -> s
 930                                          { state_errors = errs
 931                                                  { Analyze.errors_reference_ambiguous =
 932                                                         HM.insert reference_id (succNat1 num) errors_reference_ambiguous } }
 933                                         H.span ! HA.class_ "reference reference-ambiguous"
 934                                                ! HA.id (attrify $ identifyReference "-ambiguous" reference_id $ Just num) $$
 935                                                 html5ify reference_id
 936                                 "]"
 937                         H.td ! HA.class_ "reference-content" $$ do
 938                                 html5ify reference_about
 939                                 case HM.lookup reference_id all_ref of
 940                                  Nothing -> pure ()
 941                                  Just anchs ->
 942                                         when (isNothing $ HM.lookup reference_id errors_reference_ambiguous) $ do
 943                                                 H.p ! HA.class_ "ref-backs" $$
 944                                                         html5CommasDot $
 945                                                         (<$> List.zip (toList anchs) [1..]) $ \((_loc, maySection),num) ->
 946                                                                 H.a ! HA.class_ "ref-back"
 947                                                                     ! HA.href (refIdent $ identifyReference "" reference_id $ Just $ Nat1 num) $$
 948                                                                         html5ify maySection
 949 instance Html5ify (Either Head Section) where
 950         html5ify = \case
 951          Left{} -> "0"::HTML5
 952          Right Section{section_posXML=posSection} ->
 953                 html5ify $ XML.pos_ancestors posSection
 954 instance Html5ify XML.Ancestors where
 955         html5ify ancs =
 956                 case toList ancs of
 957                  [(_n,c)] -> do
 958                         html5ify $ show c
 959                         html5ify '.'
 960                  as ->
 961                         html5ify $
 962                                 Text.intercalate "." $
 963                                 Text.pack . show . snd <$> as
 964 instance Html5ify Plain.Plain where
 965         html5ify p = do
 966                 rp <- composeLift $ RWS.asks reader_plainify
 967                 html5ify $ Plain.runPlain p rp
 968 {-
 969 instance Html5ify SVG.Element where
 970         html5ify svg =
 971                 html5ify $
 972                 B.preEscapedLazyText $
 973                 SVG.renderText svg
 974 instance Semigroup SVG.Element where
 975         (<>) = mappend
 976 -}
 977
 978 html5Commas :: [HTML5] -> HTML5
 979 html5Commas [] = pure ()
 980 html5Commas hs = do
 981         sequence_ $ List.intersperse ", " hs
 982
 983 html5CommasDot :: [HTML5] -> HTML5
 984 html5CommasDot [] = pure ()
 985 html5CommasDot hs = do
 986         html5Commas hs
 987         "."
 988
 989 html5Lines :: [HTML5] -> HTML5
 990 html5Lines hs = sequence_ $ List.intersperse (html5ify H.br) hs
 991
 992 html5Words :: [HTML5] -> HTML5
 993 html5Words hs = sequence_ $ List.intersperse " " hs
 994
 995 html5SectionNumber :: XML.Ancestors -> HTML5
 996 html5SectionNumber = go mempty
 997         where
 998         go :: XML.Ancestors -> XML.Ancestors -> HTML5
 999         go prev next =
1000                 case Seq.viewl next of
1001                  Seq.EmptyL -> pure ()
1002                  a@(_n,rank) Seq.:< as -> do
1003                         H.a ! HA.href (refIdent $ identify $ prev Seq.|> a) $$
1004                                 html5ify $ show rank
1005                         when (not (null as) || null prev) $ do
1006                                 html5ify '.'
1007                                 go (prev Seq.|>a) as
1008
1009 html5SectionRef :: XML.Ancestors -> HTML5
1010 html5SectionRef as =
1011         H.a ! HA.href (refIdent $ identify as) $$
1012                 html5ify as
1013
1014 popNotes :: ComposeRWS Reader Writer State H.MarkupM (Seq [Para])
1015 popNotes = do
1016         st <- composeLift RWS.get
1017         case {-debug "state_notes" $-} state_notes st of
1018          [] -> return mempty
1019          curr:next -> do
1020                 composeLift $ RWS.modify $ \s -> s{state_notes=next}
1021                 return curr
1022
1023 html5Notes :: Seq [Para] -> HTML5
1024 html5Notes notes = do
1025         unless (null notes) $ do
1026                 H.aside ! HA.class_ "notes" $$ do
1027                         Compose $ pure H.hr
1028                         H.table $$
1029                                 H.tbody $$
1030                                         forM_ notes $ \content -> do
1031                                                 num <- composeLift $ do
1032                                                         n <- RWS.gets state_note_num_content
1033                                                         RWS.modify $ \s -> s{state_note_num_content=succNat1 n}
1034                                                         return n
1035                                                 H.tr $$ do
1036                                                         H.td ! HA.class_ "note-ref" $$ do
1037                                                                 H.a ! HA.class_ "note-number"
1038                                                                     ! HA.id   ("note."<>attrify num)
1039                                                                     ! HA.href ("#note."<>attrify num) $$ do
1040                                                                         html5ify num
1041                                                                 ". "::HTML5
1042                                                                 H.a ! HA.href ("#note-ref."<>attrify num) $$ do
1043                                                                         "↑"
1044                                                         H.td $$
1045                                                                 html5ify content
1046
1047 html5ifyToC :: Maybe DTC.Nat -> Tree BodyNode -> HTML5
1048 html5ifyToC depth (Tree b bs) =
1049         case b of
1050          BodySection Section{..} -> do
1051                 H.li $$ do
1052                         H.table ! HA.class_ "toc-entry" $$
1053                                 H.tbody $$
1054                                         H.tr $$ do
1055                                                 H.td ! HA.class_ "section-number" $$
1056                                                         html5SectionRef $ XML.pos_ancestors section_posXML
1057                                                 H.td ! HA.class_ "section-title" $$
1058                                                         html5ify $ cleanPlain $ unTitle section_title
1059                         when (maybe True (> Nat 1) depth && not (null sections)) $
1060                                 H.ul $$
1061                                         forM_ sections $
1062                                                 html5ifyToC (depth >>= predNat)
1063          _ -> mempty
1064         where
1065         sections =
1066                 (`Seq.filter` bs) $ \case
1067                  Tree BodySection{} _ -> True
1068                  _ -> False
1069
1070 html5ifyToF :: [TL.Text] -> HTML5
1071 html5ifyToF types = do
1072         figuresByType <- composeLift $ RWS.asks $ Analyze.all_figure . reader_all
1073         let figures =
1074                 Map.unions $
1075                 ((\(ty,ts) -> (ty,) <$> ts) <$>) $
1076                 HM.toList $
1077                 if null types
1078                 then figuresByType
1079                 else
1080                         HM.intersection figuresByType $
1081                         HM.fromList [(ty,()) | ty <- types]
1082         forM_ (Map.toList figures) $ \(posXML, (type_, title)) ->
1083                 H.tr $$ do
1084                         H.td ! HA.class_ "figure-number" $$
1085                                 H.a ! HA.href (refIdent $ identify posXML) $$ do
1086                                         html5ify type_
1087                                         html5ify $ XML.pos_ancestors posXML
1088                         forM_ title $ \ti ->
1089                                 H.td ! HA.class_ "figure-title" $$
1090                                         html5ify $ cleanPlain $ unTitle ti
1091
1092 -- 'Attrify'
1093 instance Attrify Plain.Plain where
1094         attrify p = attrify $ Plain.runPlain p def