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{..} -> do
 653                 H.a ! HA.class_ "eref no-print"
 654                     ! HA.href (attrify eref_href) $$
 655                         if null ps
 656                         then html5ify $ unURL eref_href
 657                         else html5ify ps
 658                 H.span ! HA.class_ "eref print-only" $$ do
 659                         unless (null ps) $ do
 660                                 html5ify ps
 661                                 " "::HTML5
 662                         "<"::HTML5
 663                         html5ify eref_href
 664                         ">"
 665          PlainIref{..} ->
 666                 mempty
 667                 {- FIXME
 668                 case iref_anchor of
 669                  Nothing -> html5ify ps
 670                  Just Anchor{..} ->
 671                         H.span ! HA.class_ "iref"
 672                                ! HA.id (attrify $ identifyIrefCount iref_term anchor_count) $$
 673                                 html5ify ps
 674                 -}
 675          PlainTag{..} -> do
 676                 Reader{..} <- composeLift RWS.ask
 677                 State{state_errors=errs@Analyze.Errors{..}} <- composeLift RWS.get
 678                 let l10n = Plain.reader_l10n reader_plainify
 679                 let tag = Title ps
 680                 case () of
 681                  _ | Just num <- HM.lookup tag errors_tag_unknown -> do
 682                         composeLift $ RWS.modify $ \s -> s
 683                          { state_errors = errs
 684                                  { Analyze.errors_tag_unknown =
 685                                         HM.adjust succNat1 tag errors_tag_unknown } }
 686                         H.span ! HA.class_ "tag tag-unknown"
 687                                ! HA.id (attrify $ identifyTag "-unknown" l10n tag (Just num)) $$
 688                                 html5ify tag
 689                    | Just num <- HM.lookup tag errors_tag_ambiguous -> do
 690                         composeLift $ RWS.modify $ \s -> s
 691                          { state_errors = errs
 692                                  { Analyze.errors_tag_ambiguous =
 693                                         HM.adjust succNat1 tag errors_tag_ambiguous } }
 694                         H.span ! HA.class_ "tag tag-ambiguous"
 695                                ! HA.id (attrify $ identifyTag "-ambiguous" l10n tag (Just num)) $$
 696                                 html5ify tag
 697                    | otherwise -> do
 698                         H.a ! HA.class_ "tag"
 699                             ! HA.href (refIdent $ identifyTitle l10n tag) $$
 700                                 html5ify tag
 701          PlainRref{..} -> do
 702                 Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
 703                 State{state_errors=errs@Analyze.Errors{..}, ..} <- composeLift RWS.get
 704                 case toList $ HM.lookupDefault def rref_to all_reference of
 705                  [] -> do
 706                         let num = HM.lookup rref_to errors_rref_unknown
 707                         composeLift $ RWS.modify $ \s -> s
 708                          { state_errors = errs
 709                                  { Analyze.errors_rref_unknown =
 710                                         HM.adjust succNat1 rref_to errors_rref_unknown } }
 711                         "["::HTML5
 712                         H.span ! HA.class_ "reference reference-unknown"
 713                                ! HA.id (attrify $ identifyReference "-unknown" rref_to num) $$
 714                                 html5ify rref_to
 715                         "]"
 716                  [Reference{..}] -> do
 717                         let num = HM.lookupDefault (Nat1 1) rref_to state_rrefs
 718                         composeLift $ RWS.modify $ \s -> s
 719                          { state_rrefs = HM.insert rref_to (succNat1 num) state_rrefs }
 720                         let a =
 721                                 H.a ! HA.class_ "reference"
 722                                     ! HA.href (refIdent $ identifyReference "" rref_to Nothing)
 723                                     ! HA.id   (attrify  $ identifyReference "" rref_to $ Just num)
 724                         let ref = do
 725                                 "["::HTML5
 726                                 a $$ html5ify rref_to
 727                                 "]"
 728                         case toList ps of
 729                          [] -> ref
 730                          [Tree (PlainText "") _] -> do
 731                                 refs <- composeLift $ RWS.asks $ Analyze.all_reference . reader_all
 732                                 case toList <$> HM.lookup rref_to refs of
 733                                  Just [Reference{reference_about=About{..}}] -> do
 734                                         forM_ (List.take 1 about_titles) $ \(Title title) -> do
 735                                                 html5ify $ Tree PlainQ $
 736                                                         case about_url of
 737                                                          Nothing -> title
 738                                                          Just u -> pure $ Tree (PlainEref u) title
 739                                                 " "::HTML5
 740                                                 ref
 741                                  _ -> mempty
 742                          _ -> do
 743                                 a $$ html5ify ps
 744                                 H.span ! HA.class_ "print-only" $$ do
 745                                         " "::HTML5
 746                                         ref
 747                  _ -> do
 748                         case toList ps of
 749                          [] -> mempty
 750                          [Tree (PlainText "") _] -> mempty
 751                          _ -> do
 752                                 html5ify ps
 753                                 " "::HTML5
 754                         "["::HTML5
 755                         H.span ! HA.class_ "reference reference-ambiguous" $$
 756                                 html5ify rref_to
 757                         "]"
 758 instance Html5ify [Title] where
 759         html5ify =
 760                 html5ify . fold . List.intersperse sep . toList
 761                 where sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
 762 instance Html5ify Title where
 763         html5ify (Title t) = html5ify t
 764 instance Html5ify About where
 765         html5ify About{..} = do
 766                 html5CommasDot $ concat $
 767                          [ html5Titles about_titles
 768                          , html5ify <$> about_authors
 769                          , html5ify <$> maybeToList about_date
 770                          , html5ify <$> maybeToList about_editor
 771                          , html5ify <$> about_series
 772                          ]
 773                 forM_ about_url $ \u -> do
 774                         H.span ! HA.class_ "reference-url print-only" $$ do
 775                                 H.span ! HA.class_ "para" $$ do
 776                                         "<"::HTML5
 777                                         html5ify u
 778                                         ">"
 779                 forM_ about_description $ \description -> do
 780                         H.span ! HA.class_ "reference-description" $$ do
 781                                 html5ify description
 782                 where
 783                 html5Titles :: [Title] -> [HTML5]
 784                 html5Titles ts | null ts = []
 785                 html5Titles ts = [html5Title $ joinTitles ts]
 786                         where
 787                         joinTitles = fold . List.intersperse sep . toList
 788                         sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
 789                 html5Title (Title title) = do
 790                         H.span ! HA.class_ "no-print" $$
 791                                 html5ify $ Tree PlainQ $
 792                                         case about_url of
 793                                          Nothing -> title
 794                                          Just u -> pure $ Tree (PlainEref u) title
 795                         H.span ! HA.class_ "print-only" $$
 796                                 html5ify $ Tree PlainQ title
 797 instance Html5ify Serie where
 798         html5ify s@Serie{id=id_, name} = do
 799                 Loqualization l10n <- composeLift $ RWS.asks reader_l10n
 800                 case urlSerie s of
 801                  Nothing -> do
 802                         html5ify name
 803                         Plain.l10n_Colon l10n :: HTML5
 804                         html5ify id_
 805                  Just href -> do
 806                         html5ify $
 807                                 Tree PlainEref{eref_href=href} $
 808                                 Seq.fromList
 809                                  [ tree0 $ PlainText $ unName name
 810                                  , tree0 $ PlainText $ Plain.l10n_Colon l10n
 811                                  , tree0 $ PlainText id_
 812                                  ]
 813 instance Html5ify Entity where
 814         html5ify Entity{..} = do
 815                 case () of
 816                  _ | not (TL.null entity_email) -> do
 817                         H.span ! HA.class_ "no-print" $$
 818                                 html5ify $
 819                                         Tree (PlainEref $ URL $ "mailto:"<>entity_email) $
 820                                                 pure $ tree0 $ PlainText entity_name
 821                         H.span ! HA.class_ "print-only" $$
 822                                 html5ify $
 823                                         Tree (PlainEref $ URL entity_email) $
 824                                                 pure $ tree0 $ PlainText $
 825                                                 entity_name <> orgs entity_org
 826                         where
 827                         orgs = maybe "" $ \Entity{entity_name=name, entity_org=org} -> " ("<>name<>orgs org<>")"
 828                  _ | Just u <- entity_url ->
 829                         html5ify $
 830                                 Tree (PlainEref u) $
 831                                         pure $ tree0 $ PlainText entity_name
 832                  _ ->
 833                         html5ify $
 834                                 tree0 $ PlainText entity_name
 835 instance Html5ify Words where
 836         html5ify = html5ify . Index.plainifyWords
 837 instance Html5ify Alias where
 838         html5ify Alias{..} = do
 839                 ro@Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
 840                 let l10n = Plain.reader_l10n $ reader_plainify ro
 841                 case toList <$> HM.lookup title all_section of
 842                  Just [_] ->
 843                         H.a ! HA.class_ "alias"
 844                             ! HA.id (attrify $ identifyTitle l10n title) $$
 845                                 mempty
 846                  _ -> mempty
 847 instance Html5ify URL where
 848         html5ify (URL url) =
 849                 H.a ! HA.class_ "url"
 850                     ! HA.href (attrify url) $$
 851                         html5ify url
 852 instance Html5ify Date where
 853         html5ify date = do
 854                 Loqualization l10n <- composeLift $ RWS.asks reader_l10n
 855                 Plain.l10n_Date date l10n
 856 instance Html5ify Reference where
 857         html5ify Reference{..} = do
 858                 Reader{reader_all=Analyze.All{..}} <- composeLift RWS.ask
 859                 State{state_errors=errs@Analyze.Errors{..}, ..} <- composeLift RWS.get
 860                 H.tr $$ do
 861                         H.td ! HA.class_ "reference-key" $$ do
 862                                 "["::HTML5
 863                                 case HM.lookup reference_id errors_reference_ambiguous of
 864                                  Nothing ->
 865                                         H.a ! HA.class_ "reference"
 866                                             ! HA.href (refIdent $ identifyReference "" reference_id Nothing)
 867                                             ! HA.id   (attrify  $ identifyReference "" reference_id Nothing) $$
 868                                                 html5ify reference_id
 869                                  Just num -> do
 870                                         composeLift $ RWS.modify $ \s -> s
 871                                          { state_errors = errs
 872                                                  { Analyze.errors_reference_ambiguous =
 873                                                         HM.insert reference_id (succNat1 num) errors_reference_ambiguous } }
 874                                         H.span ! HA.class_ "reference reference-ambiguous"
 875                                                ! HA.id (attrify $ identifyReference "-ambiguous" reference_id $ Just num) $$
 876                                                 html5ify reference_id
 877                                 "]"
 878                         H.td ! HA.class_ "reference-content" $$ do
 879                                 html5ify reference_about
 880                                 case HM.lookup reference_id all_rrefs of
 881                                  Nothing -> pure ()
 882                                  Just anchs ->
 883                                         when (isNothing $ HM.lookup reference_id errors_reference_ambiguous) $ do
 884                                                 H.span ! HA.class_ "para reference-rrefs" $$
 885                                                         html5CommasDot $
 886                                                         (<$> List.zip (toList anchs) [1..]) $ \((_loc, maySection),num) ->
 887                                                                 H.a ! HA.class_ "reference-rref"
 888                                                                     ! HA.href (refIdent $ identifyReference "" reference_id $ Just $ Nat1 num) $$
 889                                                                         case maySection of
 890                                                                          Left{} -> "0"::HTML5
 891                                                                          Right Section{section_posXML=posSection} ->
 892                                                                                 html5ify $ XML.pos_ancestors posSection
 893 instance Html5ify XML.Ancestors where
 894         html5ify ancs =
 895                 case toList ancs of
 896                  [(_n,c)] -> do
 897                         html5ify $ show c
 898                         html5ify '.'
 899                  as ->
 900                         html5ify $
 901                                 Text.intercalate "." $
 902                                 Text.pack . show . snd <$> as
 903 instance Html5ify Plain.Plain where
 904         html5ify p = do
 905                 rp <- composeLift $ RWS.asks reader_plainify
 906                 html5ify $ Plain.runPlain p rp
 907 {-
 908 instance Html5ify SVG.Element where
 909         html5ify svg =
 910                 html5ify $
 911                 B.preEscapedLazyText $
 912                 SVG.renderText svg
 913 instance Semigroup SVG.Element where
 914         (<>) = mappend
 915 -}
 916
 917 html5CommasDot :: [HTML5] -> HTML5
 918 html5CommasDot [] = pure ()
 919 html5CommasDot hs = do
 920         sequence_ $ List.intersperse ", " hs
 921         "."
 922
 923 html5Lines :: [HTML5] -> HTML5
 924 html5Lines hs = sequence_ $ List.intersperse (html5ify H.br) hs
 925
 926 html5Words :: [HTML5] -> HTML5
 927 html5Words hs = sequence_ $ List.intersperse " " hs
 928
 929 html5SectionNumber :: XML.Ancestors -> HTML5
 930 html5SectionNumber = go mempty
 931         where
 932         go :: XML.Ancestors -> XML.Ancestors -> HTML5
 933         go prev next =
 934                 case Seq.viewl next of
 935                  Seq.EmptyL -> pure ()
 936                  a@(_n,rank) Seq.:< as -> do
 937                         H.a ! HA.href (refIdent $ identify $ prev Seq.|> a) $$
 938                                 html5ify $ show rank
 939                         when (not (null as) || null prev) $ do
 940                                 html5ify '.'
 941                                 go (prev Seq.|>a) as
 942
 943 html5SectionRef :: XML.Ancestors -> HTML5
 944 html5SectionRef as =
 945         H.a ! HA.href (refIdent $ identify as) $$
 946                 html5ify as
 947
 948 popNotes :: ComposeRWS Reader Writer State H.MarkupM (Seq [Para])
 949 popNotes = do
 950         st <- composeLift RWS.get
 951         case {-debug "state_notes" $-} state_notes st of
 952          [] -> return mempty
 953          curr:next -> do
 954                 composeLift $ RWS.modify $ \s -> s{state_notes=next}
 955                 return curr
 956
 957 html5Notes :: Seq [Para] -> HTML5
 958 html5Notes notes = do
 959         unless (null notes) $ do
 960                 H.aside ! HA.class_ "notes" $$ do
 961                         Compose $ pure H.hr
 962                         H.table $$
 963                                 H.tbody $$
 964                                         forM_ notes $ \content -> do
 965                                                 num <- composeLift $ do
 966                                                         n <- RWS.gets state_note_num_content
 967                                                         RWS.modify $ \s -> s{state_note_num_content=succNat1 n}
 968                                                         return n
 969                                                 H.tr $$ do
 970                                                         H.td ! HA.class_ "note-ref" $$ do
 971                                                                 H.a ! HA.class_ "note-number"
 972                                                                     ! HA.id   ("note."<>attrify num)
 973                                                                     ! HA.href ("#note."<>attrify num) $$ do
 974                                                                         html5ify num
 975                                                                 ". "::HTML5
 976                                                                 H.a ! HA.href ("#note-ref."<>attrify num) $$ do
 977                                                                         "↑"
 978                                                         H.td $$
 979                                                                 html5ify content
 980
 981 html5ifyToC :: Maybe DTC.Nat -> Tree BodyNode -> HTML5
 982 html5ifyToC depth (Tree b bs) =
 983         case b of
 984          BodySection Section{..} -> do
 985                 H.li $$ do
 986                         H.table ! HA.class_ "toc-entry" $$
 987                                 H.tbody $$
 988                                         H.tr $$ do
 989                                                 H.td ! HA.class_ "section-number" $$
 990                                                         html5SectionRef $ XML.pos_ancestors section_posXML
 991                                                 H.td ! HA.class_ "section-title" $$
 992                                                         html5ify $ cleanPlain $ unTitle section_title
 993                         when (maybe True (> Nat 1) depth && not (null sections)) $
 994                                 H.ul $$
 995                                         forM_ sections $
 996                                                 html5ifyToC (depth >>= predNat)
 997          _ -> mempty
 998         where
 999         sections =
1000                 (`Seq.filter` bs) $ \case
1001                  Tree BodySection{} _ -> True
1002                  _ -> False
1003
1004 html5ifyToF :: [TL.Text] -> HTML5
1005 html5ifyToF types = do
1006         figuresByType <- composeLift $ RWS.asks $ Analyze.all_figure . reader_all
1007         let figures =
1008                 Map.unions $
1009                 ((\(ty,ts) -> (ty,) <$> ts) <$>) $
1010                 HM.toList $
1011                 if null types
1012                 then figuresByType
1013                 else
1014                         HM.intersection figuresByType $
1015                         HM.fromList [(ty,()) | ty <- types]
1016         forM_ (Map.toList figures) $ \(posXML, (type_, title)) ->
1017                 H.tr $$ do
1018                         H.td ! HA.class_ "figure-number" $$
1019                                 H.a ! HA.href (refIdent $ identify posXML) $$ do
1020                                         html5ify type_
1021                                         html5ify $ XML.pos_ancestors posXML
1022                         forM_ title $ \ti ->
1023                                 H.td ! HA.class_ "figure-title" $$
1024                                         html5ify $ cleanPlain $ unTitle ti
1025
1026 -- 'Attrify'
1027 instance Attrify Plain.Plain where
1028         attrify p = attrify $ Plain.runPlain p def