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