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