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 {-# LANGUAGE TypeApplications #-}
  10 {-# LANGUAGE ViewPatterns #-}
  11 {-# OPTIONS_GHC -fno-warn-orphans #-}
  12 module Hdoc.DTC.Write.HTML5 where
  13
  14 import Control.Applicative (Applicative(..))
  15 import Control.Monad (Monad(..), join, (=<<), forM, forM_, mapM_, sequence_)
  16 import Data.Bool
  17 import Data.Char (Char)
  18 import Data.Default.Class (Default(..))
  19 import Data.Either (Either(..))
  20 import Data.Eq (Eq(..))
  21 import Data.Foldable (Foldable(..), concat, any)
  22 import Data.Function (($), (.), const, on)
  23 import Data.Functor ((<$>))
  24 import Data.Functor.Compose (Compose(..))
  25 import Data.Int (Int)
  26 import Data.IntMap.Strict (IntMap)
  27 import Data.List.NonEmpty (NonEmpty(..))
  28 import Data.Locale hiding (Index)
  29 import Data.Map.Strict (Map)
  30 import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList, listToMaybe, fromMaybe, isJust)
  31 import Data.Monoid (Monoid(..))
  32 import Data.Ord (Ord(..))
  33 import Data.Semigroup (Semigroup(..))
  34 import Data.Sequence (Seq(..))
  35 import Data.String (String, IsString(..))
  36 import Data.Text (Text)
  37 import Data.TreeSeq.Strict (Tree(..), tree0)
  38 import Data.Tuple (fst, snd)
  39 import Prelude (mod, (*), Fractional(..), Double, toRational, RealFrac(..))
  40 import System.FilePath (FilePath, (</>))
  41 import System.IO (IO)
  42 import Text.Blaze ((!))
  43 import Text.Blaze.Html (Html)
  44 import Text.Show (Show(..))
  45 import qualified Control.Category as Cat
  46 import qualified Control.Monad.Trans.State as S
  47 import qualified Data.Char as Char
  48 import qualified Data.HashMap.Strict as HM
  49 import qualified Data.HashSet as HS
  50 import qualified Data.IntMap.Strict as IntMap
  51 import qualified Data.List as List
  52 import qualified Data.Map.Strict as Map
  53 import qualified Data.Sequence as Seq
  54 import qualified Data.Set as Set
  55 import qualified Data.Strict.Maybe as Strict
  56 import qualified Data.Text as Text
  57 import qualified Data.Text.Lazy as TL
  58 import qualified Data.Tree as Tree
  59 import qualified Data.TreeMap.Strict as TreeMap
  60 import qualified Data.TreeSeq.Strict as TreeSeq
  61 import qualified Hjugement as MJ
  62 import qualified Prelude (error)
  63 import qualified Text.Blaze.Html5 as H
  64 import qualified Text.Blaze.Html5.Attributes  as HA
  65 import qualified Text.Blaze.Internal as H
  66
  67 import Hdoc.DTC.Document as DTC
  68 import Hdoc.DTC.Write.HTML5.Ident
  69 import Hdoc.DTC.Write.Plain (Plainify(..))
  70 import Hdoc.DTC.Write.XML ()
  71 import Hdoc.Utils
  72 import Text.Blaze.Utils
  73 import qualified Hdoc.DTC.Check as Check
  74 import qualified Hdoc.DTC.Collect as Collect
  75 import qualified Hdoc.DTC.Index as Index
  76 import qualified Hdoc.DTC.Write.Plain as Plain
  77 import qualified Hdoc.TCT.Cell as TCT
  78 import qualified Hdoc.Utils as FS
  79 import qualified Hdoc.XML as XML
  80 import qualified Paths_hdoc as Hdoc
  81 import Debug.Trace
  82
  83 debug :: Show a => String -> a -> a
  84 debug msg a = trace (msg<>": "<>show a) a
  85 debugOn :: Show b => String -> (a -> b) -> a -> a
  86 debugOn msg get a = trace (msg<>": "<>show (get a)) a
  87 debugWith :: String -> (a -> String) -> a -> a
  88 debugWith msg get a = trace (msg<>": "<>get a) a
  89
  90 showJudgments :: HM.HashMap (Ident,Ident,Maybe Title) [Tree.Tree [Choice]] -> String
  91 showJudgments js =
  92         Tree.drawForest $
  93         ((show <$>) <$>) $
  94         -- Tree.Node (Left ("","",Nothing)) $
  95         (<$> HM.toList js) $ \((j,g,q),ts) ->
  96                 Tree.Node
  97                  (Left (unIdent j,unIdent g,Plain.text def <$> q))
  98                  ((Right <$>) <$> ts)
  99
 100 -- * Type 'HTML5'
 101 type HTML5 = StateMarkup State ()
 102 instance IsString HTML5 where
 103         fromString = html5ify
 104
 105 -- ** Type 'Config'
 106 data Config =
 107  forall locales.
 108  ( Locales   locales
 109  , Loqualize locales (L10n HTML5)
 110  , Loqualize locales (Plain.L10n Plain.Plain)
 111  ) =>
 112  Config
 113  { config_css       :: Either FilePath TL.Text
 114  , config_js        :: Either FilePath TL.Text
 115  , config_locale    :: LocaleIn locales
 116  , config_generator :: TL.Text
 117  }
 118 instance Default Config where
 119         def = Config
 120          { config_css       = Right "style/dtc-html5.css"
 121          , config_js        = Right "style/dtc-html5.js"
 122          , config_locale    = LocaleIn @'[EN] en_US
 123          , config_generator = "https://hackage.haskell.org/package/hdoc"
 124          }
 125
 126 -- ** Type 'State'
 127 data State = State
 128  -- RW
 129  { state_styles    :: HS.HashSet (Either FilePath TL.Text)
 130  , state_scripts   :: HS.HashSet FilePath
 131  , state_notes     :: Check.NotesBySection
 132  , state_judgments :: HS.HashSet Judgment
 133  , state_opinions  :: HM.HashMap Judgment [MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade)]
 134  -- RO
 135  , state_section   :: TreeSeq.Trees BodyNode
 136  , state_collect   :: Collect.All
 137  , state_indexs    :: Map XML.Pos (Terms, Index.Irefs) -- TODO: could be a list
 138  , state_rrefs     :: HM.HashMap Ident [(Maybe Section,Nat1)]
 139  , state_plainify  :: Plain.State
 140  , state_l10n      :: Loqualization (L10n HTML5)
 141  }
 142 instance Default State where
 143         def = State
 144          { state_styles    = HS.fromList [Left "dtc-html5.css"]
 145          , state_scripts   = def
 146          , state_section   = def
 147          , state_collect   = def
 148          , state_indexs    = def
 149          , state_rrefs     = def
 150          , state_notes     = def
 151          , state_plainify  = def
 152          , state_l10n      = Loqualization EN_US
 153          , state_judgments = HS.empty
 154          , state_opinions  = def
 155          }
 156
 157 writeHTML5 :: Config -> DTC.Document -> IO Html
 158 writeHTML5 conf@Config{..} doc@DTC.Document{..} = do
 159         let collect@Collect.All{..} = Collect.collect doc
 160         let (checkedBody,checkState) =
 161                 Check.check body `S.runState` def
 162                  { Check.state_irefs   = foldMap Index.irefsOfTerms all_index
 163                  , Check.state_collect = collect
 164                  }
 165         let (html5Body, endState) =
 166                 let Check.State{..} = checkState in
 167                 runStateMarkup def
 168                  { state_collect
 169                  , state_indexs =
 170                         (<$> all_index) $ \terms ->
 171                                 (terms,) $
 172                                 TreeMap.intersection const state_irefs $
 173                                 Index.irefsOfTerms terms
 174                  , state_rrefs
 175                  , state_notes
 176                  , state_section  = body
 177                  , state_l10n     = loqualize config_locale
 178                  , state_plainify = def{Plain.state_l10n = loqualize config_locale}
 179                  } $ do
 180                         html5Judgments
 181                         html5ify state_errors
 182                         html5DocumentHead head
 183                         html5ify checkedBody
 184         html5Head <- writeHTML5Head conf endState head
 185         return $ do
 186                 let State{..} = endState
 187                 H.docType
 188                 H.html ! HA.lang (attrify $ countryCode config_locale) $ do
 189                         html5Head
 190                         H.body $ do
 191                                 {-
 192                                 unless (null state_scripts) $ do
 193                                         -- NOTE: indicate that JavaScript is active.
 194                                         H.script ! HA.type_ "application/javascript" $
 195                                                 "document.body.className = \"script\";"
 196                                 -}
 197                                 html5Body
 198
 199 writeHTML5Head :: Config -> State -> Head -> IO Html
 200 writeHTML5Head Config{..} State{..} Head{DTC.about=About{..}} = do
 201         csss :: Html <-
 202                 -- unless (any (\DTC.Link{..} -> rel == "stylesheet" && href /= URL "") links) $ do
 203                 (`foldMap` state_styles) $ \case
 204                  Left css -> do
 205                         content <- FS.readFile =<< Hdoc.getDataFileName ("style"</>css)
 206                         return $ H.style ! HA.type_ "text/css" $
 207                                 H.toMarkup content
 208                  Right content ->
 209                         return $ H.style ! HA.type_ "text/css" $
 210                                 -- NOTE: as a special case, H.style wraps its content into an External,
 211                                 -- so it does not HTML-escape its content.
 212                                 H.toMarkup content
 213                         {-
 214                         case config_css of
 215                          Left "" -> mempty
 216                          Left css ->
 217                                 H.link ! HA.rel "stylesheet"
 218                                        ! HA.type_ "text/css"
 219                                        ! HA.href (attrify css)
 220                          Right css ->
 221                                 H.style ! HA.type_ "text/css" $
 222                                         H.toMarkup css
 223                         -}
 224         scripts :: Html <-
 225                 (`foldMap` state_scripts) $ \script -> do
 226                         content <- FS.readFile =<< Hdoc.getDataFileName ("style"</>script)
 227                         return $ H.script ! HA.type_ "application/javascript" $
 228                                 H.toMarkup content
 229                         {-
 230                 if not (any (\DTC.Link{rel} -> rel == "script") links)
 231                  then do
 232                  else
 233                         mempty
 234                         case config_js of
 235                          Left "" -> mempty
 236                          Left  js -> H.script ! HA.src (attrify js)
 237                                               ! HA.type_ "application/javascript"
 238                                               $ mempty
 239                          Right js -> H.script ! HA.type_ "application/javascript"
 240                                               $ H.toMarkup js
 241                         -}
 242         return $
 243                 H.head $ do
 244                         H.meta ! HA.httpEquiv "Content-Type"
 245                                ! HA.content "text/html; charset=UTF-8"
 246                         unless (null titles) $ do
 247                                 H.title $
 248                                         H.toMarkup $ Plain.text state_plainify $ List.head titles
 249                         forM_ links $ \Link{..} ->
 250                                 case rel of
 251                                  "stylesheet" | URL "" <- href ->
 252                                         H.style ! HA.type_ "text/css" $
 253                                                 H.toMarkup $ Plain.text def plain
 254                                  _ ->
 255                                         H.link ! HA.rel (attrify rel)
 256                                                ! HA.href (attrify href)
 257                         forM_ url $ \href ->
 258                                 H.link ! HA.rel "self"
 259                                        ! HA.href (attrify href)
 260                         unless (TL.null config_generator) $ do
 261                                 H.meta ! HA.name "generator"
 262                                        ! HA.content (attrify config_generator)
 263                         unless (null tags) $
 264                                 H.meta ! HA.name "keywords"
 265                                        ! HA.content (attrify $ TL.intercalate ", " tags)
 266                         let chapters =
 267                                 (`mapMaybe` toList state_section) $ \case
 268                                  Tree (BodySection s) _ -> Just s
 269                                  _ -> Nothing
 270                         forM_ chapters $ \Section{..} ->
 271                                 H.link ! HA.rel "Chapter"
 272                                        ! HA.title (attrify $ plainify title)
 273                                        ! HA.href (refIdent $ identify xmlPos)
 274                         csss
 275                         scripts
 276
 277 html5DocumentHead :: Head -> HTML5
 278 html5DocumentHead Head{DTC.about=About{..}, judgments} = do
 279         st <- liftStateMarkup S.get
 280         unless (null authors) $ do
 281                 H.div ! HA.class_ "document-head" $$
 282                         H.table $$ do
 283                                 H.tbody $$ do
 284                                         H.tr $$ do
 285                                                 H.td ! HA.class_ "left"  $$ docHeaders
 286                                                 H.td ! HA.class_ "right" $$ docAuthors
 287         unless (null titles) $ do
 288                 H.div ! HA.class_ "title"
 289                       ! HA.id "document-title." $$ do
 290                         forM_ titles $ \title ->
 291                                 H.h1 ! HA.id (attrify $ identifyTitle (Plain.state_l10n $ state_plainify st) title) $$
 292                                         html5ify title
 293         do -- judgments
 294                 let sectionJudgments = HS.fromList judgments
 295                 let opinsBySectionByJudgment = state_opinions st `HM.intersection` HS.toMap sectionJudgments
 296                 liftStateMarkup $ S.modify' $ \s ->
 297                         s{ state_judgments = sectionJudgments
 298                          , state_opinions  =
 299                                 -- NOTE: drop current opinions of the judgments of this section
 300                                 HM.unionWith (const List.tail)
 301                                  (state_opinions s)
 302                                  opinsBySectionByJudgment
 303                          }
 304                 unless (null opinsBySectionByJudgment) $ do
 305                         let choicesJ = Collect.choicesByJudgment judgments
 306                         forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{question},opinsBySection) -> do
 307                                 H.div ! HA.class_ "judgment section-judgment document-judgment" $$ do
 308                                         let choices = maybe [] snd $ HM.lookup judgment choicesJ
 309                                         let opins   = List.head opinsBySection
 310                                         html5Judgment question choices opins
 311         where
 312         docHeaders =
 313                 H.table ! HA.class_ "document-headers" $$
 314                         H.tbody $$ do
 315                                 Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
 316                                 forM_ series $ \s@Serie{id=id_, name} ->
 317                                         header $
 318                                                 case urlSerie s of
 319                                                  Nothing -> do
 320                                                         headerName  $ html5ify name
 321                                                         headerValue $ html5ify id_
 322                                                  Just href -> do
 323                                                         headerName  $ html5ify name
 324                                                         headerValue $
 325                                                                 H.a ! HA.href (attrify href) $$
 326                                                                         html5ify id_
 327                                 forM_ links $ \Link{..} ->
 328                                         unless (TL.null $ unName name) $
 329                                                 header $ do
 330                                                         headerName  $ html5ify name
 331                                                         headerValue $ html5ify $ Tree PlainEref{href} plain
 332                                 forM_ date $ \d ->
 333                                         header $ do
 334                                                 headerName  $ l10n_Header_Date l10n
 335                                                 headerValue $ html5ify d
 336                                 forM_ url $ \href ->
 337                                         header $ do
 338                                                 headerName  $ l10n_Header_Address l10n
 339                                                 headerValue $ html5ify $ tree0 $ PlainEref{href}
 340                                 forM_ headers $ \Header{..} ->
 341                                         header $ do
 342                                                 headerName  $ html5ify name
 343                                                 headerValue $ html5ify value
 344         docAuthors =
 345                 H.table ! HA.class_ "document-authors" $$
 346                         H.tbody $$ do
 347                                 forM_ authors $ \a ->
 348                                         H.tr $$
 349                                                 H.td ! HA.class_ "author" $$
 350                                                         html5ify a
 351         header :: HTML5 -> HTML5
 352         header hdr = H.tr ! HA.class_ "header" $$ hdr
 353         headerName :: HTML5 -> HTML5
 354         headerName hdr =
 355                 H.td ! HA.class_ "header-name" $$ do
 356                         hdr
 357                         Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
 358                         Plain.l10n_Colon l10n
 359         headerValue :: HTML5 -> HTML5
 360         headerValue hdr =
 361                 H.td ! HA.class_ "header-value" $$ do
 362                         hdr
 363
 364 -- * Class 'Html5ify'
 365 class Html5ify a where
 366         html5ify :: a -> HTML5
 367 instance Html5ify H.Markup where
 368         html5ify = Compose . return
 369 instance Html5ify Char where
 370         html5ify = html5ify . H.toMarkup
 371 instance Html5ify Text where
 372         html5ify = html5ify . H.toMarkup
 373 instance Html5ify TL.Text where
 374         html5ify = html5ify . H.toMarkup
 375 instance Html5ify String where
 376         html5ify = html5ify . H.toMarkup
 377 instance Html5ify Title where
 378         html5ify (Title t) = html5ify t
 379 instance Html5ify Ident where
 380         html5ify (Ident i) = html5ify i
 381 instance Html5ify Int where
 382         html5ify = html5ify . show
 383 instance Html5ify Name where
 384         html5ify (Name i) = html5ify i
 385 instance Html5ify Nat where
 386         html5ify (Nat n) = html5ify n
 387 instance Html5ify Nat1 where
 388         html5ify (Nat1 n) = html5ify n
 389 instance Html5ify a => Html5ify (Maybe a) where
 390         html5ify = foldMap html5ify
 391 instance Html5ify TCT.Location where
 392         html5ify = \case
 393          s:|[] ->
 394                 H.span ! HA.class_ "tct-location" $$
 395                         html5ify $ show s
 396          ss -> do
 397                 H.ul ! HA.class_ "tct-location" $$
 398                         forM_ ss $ \s ->
 399                                 H.li $$
 400                                         html5ify $ show s
 401 instance Html5ify Check.Errors where
 402         html5ify Check.Errors{..} = do
 403                 st@State
 404                  { state_collect = Collect.All{..}
 405                  , state_l10n    = Loqualization (l10n::FullLocale lang)
 406                  , ..
 407                  } <- liftStateMarkup S.get
 408                 let errors :: [ ( Int{-errKind-}
 409                                 , HTML5{-errKindDescr-}
 410                                 , [(Plain{-errTypeKey-}, [(TCT.Location{-errPos-}, Ident{-errId-})])]
 411                                 ) ] =
 412                         List.zipWith
 413                          (\errKind (errKindDescr, errByPosByKey) ->
 414                                 (errKind, errKindDescr l10n, errByPosByKey))
 415                          [1::Int ..]
 416                          [ (l10n_Error_Tag_unknown        , errorTag st "-unknown"      errors_tag_unknown)
 417                          , (l10n_Error_Tag_ambiguous      , errorTag st "-ambiguous"    errors_tag_ambiguous)
 418                          , (l10n_Error_Rref_unknown       , errorReference "-unknown"   errors_rref_unknown)
 419                          , (l10n_Error_Reference_ambiguous, errorReference "-ambiguous" errors_reference_ambiguous)
 420                          ]
 421                 let numErrors = Nat $ sum $ (<$> errors) $ \(_typ, _descr, errByPosByKey) ->
 422                         sum $ length . snd <$> errByPosByKey
 423                 when (numErrors > Nat 0) $ do
 424                         liftStateMarkup $ S.put st
 425                          { state_styles  =
 426                                 HS.insert (Left "dtc-errors.css") $
 427                                 HS.insert (Right $
 428                                         -- NOTE: Implement a CSS-powered show/hide logic, using :target
 429                                         "\n@media screen {" <>
 430                                         "\n\t.error-filter:target .errors-list > li {display:none;}" <>
 431                                         (`foldMap` errors) (\(num, _description, errs) ->
 432                                                 if null errs then "" else
 433                                                         let err = "error-type"<>TL.pack (show num)<>"\\." in
 434                                                         "\n\t.error-filter#"<>err<>":target .errors-list > li."<>err
 435                                                          <>" {display:list-item}" <>
 436                                                         "\n\t.error-filter#"<>err<>":target .errors-nav > ul > li."<>err
 437                                                          <>" {list-style-type:disc;}"
 438                                          ) <>
 439                                         "\n}"
 440                                  )
 441                                 state_styles
 442                          }
 443                         filterIds errors $ H.div ! HA.class_ "document-errors" ! HA.id "document-errors." $$ do
 444                                 H.nav ! HA.class_ "errors-nav" $$ do
 445                                         H.p ! HA.class_ "errors-all" $$
 446                                                 H.a ! HA.href (refIdent "document-errors.") $$ do
 447                                                         l10n_Errors_All l10n numErrors :: HTML5
 448                                         H.ul $$
 449                                                 forM_ errors $
 450                                                  \(errKind, errKindDescr, errs) -> do
 451                                                         unless (null errs) $ do
 452                                                                 H.li ! HA.class_ (attrify $ errorType errKind) $$ do
 453                                                                         H.a ! HA.href (refIdent $ errorType errKind) $$ do
 454                                                                                 errKindDescr
 455                                                                                 " ("::HTML5
 456                                                                                 html5ify $ sum $ length . snd <$> errs
 457                                                                                 ")"
 458                                 H.ol ! HA.class_ "errors-list" $$ do
 459                                         let errByPosByKey :: Map TCT.Location{-errPos-} ( Int{-errKind-}
 460                                                                                  , HTML5{-errKindDescr-}
 461                                                                                  , Plain{-errKey-}
 462                                                                                  , [(TCT.Location{-errPos-}, Ident{-errId-})] ) =
 463                                                 (`foldMap`errors) $ \(errKind, errKindDescr, errByKey) ->
 464                                                         (`foldMap`errByKey) $ \(errKey, errByPos) ->
 465                                                                 Map.singleton
 466                                                                  (fst $ List.head errByPos)
 467                                                                  -- NOTE: sort using the first position of this errKind with this errKey.
 468                                                                  (errKind, errKindDescr, errKey, errByPos)
 469                                         forM_ errByPosByKey $
 470                                          \(errKind, errKindDescr, errKey, errByPos) -> do
 471                                                 H.li ! HA.class_ (attrify $ errorType errKind) $$ do
 472                                                         H.span ! HA.class_ "error-message" $$ do
 473                                                                 H.span ! HA.class_ "error-kind" $$ do
 474                                                                         errKindDescr
 475                                                                         Plain.l10n_Colon l10n :: HTML5
 476                                                                 html5ify errKey
 477                                                         H.ol ! HA.class_ "error-position" $$
 478                                                                 forM_ errByPos $ \(errPos, errId) ->
 479                                                                         H.li $$
 480                                                                                 H.a ! HA.href (refIdent errId) $$
 481                                                                                         html5ify errPos
 482                 where
 483                 errorType num = identify $ "error-type"<>show num<>"."
 484                 -- | Nest error id= to enable showing/hidding errors using :target pseudo-class.
 485                 filterIds [] h = h
 486                 filterIds ((num, _description, errs):es) h =
 487                         if null errs
 488                          then filterIds es h
 489                          else do
 490                                 H.div ! HA.class_ "error-filter"
 491                                       ! HA.id (attrify $ errorType num) $$
 492                                         filterIds es h
 493                 errorTag :: State -> Ident -> HM.HashMap Title (Seq TCT.Location) -> [(Plain, [(TCT.Location,Ident)])]
 494                 errorTag State{state_plainify=Plain.State{state_l10n}} suffix errs =
 495                         (<$> HM.toList errs) $ \(Title tag, errPositions) ->
 496                                 ( tag
 497                                 , List.zipWith
 498                                  (\num -> (,identifyTag suffix state_l10n tag (Just $ Nat1 num)))
 499                                  [1::Int ..] (toList errPositions)
 500                                 )
 501                 errorReference :: Ident -> HM.HashMap Ident (Seq TCT.Location) -> [(Plain, [(TCT.Location,Ident)])]
 502                 errorReference suffix errs =
 503                         (<$> HM.toList errs) $ \(id, errPositions) ->
 504                                 ( pure $ tree0 $ PlainText $ unIdent id
 505                                 , List.zipWith
 506                                  (\num -> (,identifyReference suffix id (Just $ Nat1 num)))
 507                                  [1::Int ..] (toList errPositions)
 508                                 )
 509 instance Html5ify Body where
 510         html5ify body = do
 511                 liftStateMarkup $ S.modify' $ \s -> s{state_section = body}
 512                 mapM_ html5ify body
 513                 case Seq.viewr body of
 514                  _ Seq.:> Tree BodyBlock{} _ -> do
 515                         notes <- liftStateMarkup $ S.gets state_notes
 516                         maybe mempty html5Notes $
 517                                 Map.lookup mempty notes
 518                  _ -> mempty
 519 instance Html5ify (Tree BodyNode) where
 520         html5ify (Tree b bs) =
 521                 case b of
 522                  BodyBlock blk -> html5ify blk
 523                  BodySection Section{..} -> do
 524                         st@State{state_collect=Collect.All{..}} <- liftStateMarkup S.get
 525                         liftStateMarkup $ S.modify' $ \s -> s{state_section = bs}
 526                         do -- notes
 527                                 let mayNotes = do
 528                                         sectionPosPath <- XML.ancestors $ XML.pos_ancestors xmlPos
 529                                         let (sectionNotes, notes) = Map.updateLookupWithKey (\_ _ -> Nothing) sectionPosPath $ state_notes st
 530                                         (,notes) <$> sectionNotes
 531                                 case mayNotes of
 532                                  Nothing -> mempty
 533                                  Just (sectionNotes, state_notes) -> do
 534                                         liftStateMarkup $ S.modify' $ \s -> s{state_notes}
 535                                         html5Notes sectionNotes
 536                         html5CommonAttrs attrs{classes="section":classes attrs, id=Nothing} $
 537                                 H.section ! HA.id (attrify $ identify xmlPos) $$ do
 538                                         forM_ aliases html5ify
 539                                         do -- judgments
 540                                                 let sectionJudgments = state_judgments st `HS.union` HS.fromList judgments
 541                                                 let opinsBySectionByJudgment = state_opinions st `HM.intersection` HS.toMap sectionJudgments
 542                                                 let dropChildrenBlocksJudgments =
 543                                                         -- NOTE: drop the "phantom" judgments concerning the 'BodyBlock's
 544                                                         -- directly children of this 'BodySection'.
 545                                                         if (`any`bs) $ \case
 546                                                                  Tree BodyBlock{} _ -> True
 547                                                                  _ -> False
 548                                                         then List.tail
 549                                                         else Cat.id
 550                                                 liftStateMarkup $ S.modify' $ \s ->
 551                                                         s{ state_judgments = sectionJudgments
 552                                                          , state_opinions  =
 553                                                                 -- NOTE: drop current opinions of the judgments of this section
 554                                                                 HM.unionWith (const $ List.tail . dropChildrenBlocksJudgments)
 555                                                                  (state_opinions s)
 556                                                                  opinsBySectionByJudgment
 557                                                          }
 558                                                 unless (null opinsBySectionByJudgment) $ do
 559                                                         liftStateMarkup $ S.modify' $ \s -> s
 560                                                          { state_styles = HS.insert (Left "dtc-judgment.css") $ state_styles s }
 561                                                         H.aside ! HA.class_ "aside" $$ do
 562                                                                 let choicesJ = Collect.choicesByJudgment judgments
 563                                                                 forM_ (HM.toList opinsBySectionByJudgment) $ \(judgment@Judgment{question},opinsBySection) -> do
 564                                                                         H.div ! HA.class_ "judgment section-judgment" $$ do
 565                                                                                 let choices = maybe [] snd $ HM.lookup judgment choicesJ
 566                                                                                 let opins   = List.head opinsBySection
 567                                                                                 html5Judgment question choices opins
 568                                         let mayId =
 569                                                 case toList <$> HM.lookup title all_section of
 570                                                  Just [_] -> Just $ identifyTitle (Plain.state_l10n $ state_plainify st) title
 571                                                  _ -> Nothing
 572                                         H.table
 573                                          ! HA.class_ "section-header"
 574                                          !?? mayAttr HA.id mayId $$
 575                                                 H.tbody $$
 576                                                         H.tr $$ do
 577                                                                 H.td ! HA.class_ "section-number" $$ do
 578                                                                         html5SectionNumber $ XML.pos_ancestors xmlPos
 579                                                                 H.td ! HA.class_ "section-title" $$ do
 580                                                                         (case List.length $ XML.pos_ancestors xmlPos of
 581                                                                          0 -> H.h1
 582                                                                          1 -> H.h2
 583                                                                          2 -> H.h3
 584                                                                          3 -> H.h4
 585                                                                          4 -> H.h5
 586                                                                          5 -> H.h6
 587                                                                          _ -> H.h6) $$
 588                                                                                 html5ify title
 589                                         forM_ bs html5ify
 590                                         do -- judgments
 591                                                 liftStateMarkup $ S.modify' $ \s ->
 592                                                         s{ state_judgments = state_judgments st }
 593                                         do -- notes
 594                                                 notes <- liftStateMarkup $ S.gets state_notes
 595                                                 maybe mempty html5Notes $
 596                                                         Map.lookup (XML.pos_ancestors xmlPos) notes
 597                         liftStateMarkup $ S.modify' $ \s -> s{state_section = state_section st}
 598 instance Html5ify Block where
 599         html5ify = \case
 600          BlockPara para -> html5ify para
 601          BlockBreak{..} ->
 602                 html5CommonAttrs attrs
 603                  { classes = "page-break":"print-only":classes attrs } $
 604                 H.div $$
 605                         H.p $$ " " -- NOTE: force page break
 606          BlockToC{..} ->
 607                 H.nav ! HA.class_ "toc"
 608                       ! HA.id (attrify $ identify xmlPos) $$ do
 609                         H.span ! HA.class_ "toc-name" $$
 610                                 H.a ! HA.href (refIdent $ identify xmlPos) $$ do
 611                                         Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
 612                                         Plain.l10n_Table_of_Contents l10n
 613                         H.ul $$ do
 614                                 State{state_section} <- liftStateMarkup S.get
 615                                 forM_ state_section $ html5ifyToC depth
 616          BlockToF{..} -> do
 617                 H.nav ! HA.class_ "tof"
 618                       ! HA.id (attrify $ identify xmlPos) $$
 619                         H.table ! HA.class_ "tof" $$
 620                                 H.tbody $$
 621                                         html5ifyToF types
 622          BlockAside{..} ->
 623                 html5CommonAttrs attrs $
 624                 H.aside ! HA.class_ "aside" $$ do
 625                         forM_ blocks html5ify
 626          BlockFigure{..} ->
 627                 html5CommonAttrs attrs
 628                  { classes = "figure":("figure-"<>type_):classes attrs
 629                  , DTC.id  = Just $ Ident $ Plain.text def $ XML.pos_ancestorsWithFigureNames xmlPos
 630                  } $
 631                 H.div $$ do
 632                         H.table ! HA.class_ "figure-caption" $$
 633                                 H.tbody $$
 634                                         H.tr $$ do
 635                                                 if TL.null type_
 636                                                  then H.a ! HA.href (refIdent $ identify xmlPos) $$ mempty
 637                                                  else
 638                                                         H.td ! HA.class_ "figure-number" $$ do
 639                                                                 H.a ! HA.href (refIdent $ identify $ XML.pos_ancestorsWithFigureNames xmlPos) $$ do
 640                                                                         html5ify type_
 641                                                                         html5ify $ XML.pos_ancestorsWithFigureNames xmlPos
 642                                                 forM_ mayTitle $ \title -> do
 643                                                         H.td ! HA.class_ "figure-colon" $$ do
 644                                                                 unless (TL.null type_) $ do
 645                                                                         Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
 646                                                                         Plain.l10n_Colon l10n
 647                                                         H.td ! HA.class_ "figure-title" $$ do
 648                                                                 html5ify title
 649                         H.div ! HA.class_ "figure-content" $$ do
 650                                 html5ify paras
 651          BlockIndex{xmlPos} -> do
 652                 st@State{..} <- liftStateMarkup S.get
 653                 liftStateMarkup $ S.put st
 654                  { state_styles = HS.insert (Left "dtc-index.css") state_styles }
 655                 let (allTerms,refsByTerm) = state_indexs Map.!xmlPos
 656                 let chars = Index.termsByChar allTerms
 657                 H.div ! HA.class_ "index"
 658                       ! HA.id (attrify $ identify xmlPos) $$ do
 659                         H.nav ! HA.class_ "index-nav" $$ do
 660                                 forM_ (Map.keys chars) $ \char ->
 661                                         H.a ! HA.href (refIdent (identify xmlPos <> "." <> identify char)) $$
 662                                                 html5ify char
 663                         H.dl ! HA.class_ "index-chars" $$
 664                                 forM_ (Map.toList chars) $ \(char,terms) -> do
 665                                         H.dt $$ do
 666                                                 let i = identify xmlPos <> "." <> identify char
 667                                                 H.a ! HA.id (attrify i)
 668                                                     ! HA.href (refIdent i) $$
 669                                                         html5ify char
 670                                         H.dd $$
 671                                                 H.dl ! HA.class_ "index-term" $$ do
 672                                                 forM_ terms $ \aliases -> do
 673                                                         H.dt $$
 674                                                                 H.ul ! HA.class_ "index-aliases" $$
 675                                                                         forM_ (List.take 1 aliases) $ \term -> do
 676                                                                                 H.li ! HA.id (attrify $ identifyIref term) $$
 677                                                                                         html5ify term
 678                                                         H.dd $$
 679                                                                 let anchs =
 680                                                                         List.sortBy (compare `on` DTC.section . snd) $
 681                                                                         (`foldMap` aliases) $ \words ->
 682                                                                                 fromJust $ do
 683                                                                                         path <- Index.pathFromWords words
 684                                                                                         Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $
 685                                                                                                 TreeMap.lookup path refsByTerm in
 686                                                                 html5CommasDot $
 687                                                                 (<$> anchs) $ \(term,Anchor{..}) ->
 688                                                                         H.a ! HA.class_ "index-iref"
 689                                                                             ! HA.href (refIdent $ identifyIrefCount term count) $$
 690                                                                                 html5ify $ XML.pos_ancestors section
 691          BlockReferences{..} ->
 692                 html5CommonAttrs attrs
 693                  { classes = "references":classes attrs
 694                  , DTC.id  = Just $ Ident $ Plain.text def $ XML.pos_ancestors xmlPos
 695                  } $
 696                 H.div $$ do
 697                         H.table $$
 698                                 forM_ refs html5ify
 699          BlockGrades{..} ->
 700                 html5CommonAttrs attrs
 701                  { classes = "grades":classes attrs
 702                  , DTC.id  = Just $ Ident $ Plain.text def $ XML.pos_ancestors xmlPos
 703                  } $
 704                 H.div $$ do
 705                         -- let dg = List.head $ List.filter default_ scale
 706                         -- let sc = MJ.Scale (Set.fromList scale) dg
 707                         -- o  :: Map choice grade
 708                         -- os :: Opinions (Map judge (Opinion choice grade))
 709                         mempty
 710                         -- html5ify $ show b
 711          BlockJudges{..} ->
 712                 html5CommonAttrs attrs
 713                  { classes = "judges":classes attrs
 714                  , DTC.id  = Just $ Ident $ Plain.text def $ XML.pos_ancestors xmlPos
 715                  } $
 716                 H.div $$ do
 717                         mempty
 718 instance Html5ify Para where
 719         html5ify = \case
 720          ParaItem{..} ->
 721                 html5CommonAttrs def
 722                  { classes="para":cls item
 723                  } $
 724                         html5ify item
 725          ParaItems{..} ->
 726                 html5CommonAttrs attrs
 727                  { classes = "para":classes attrs
 728                  , DTC.id  = id_ xmlPos
 729                  } $
 730                 H.div $$
 731                         forM_ items $ \item ->
 732                                 html5AttrClass (cls item) $
 733                                 html5ify item
 734          where
 735                 id_ = Just . Ident . Plain.text def . XML.pos_ancestors
 736                 cls = \case
 737                  ParaPlain{}     -> []
 738                  ParaArtwork{..} -> ["artwork", "artwork-"<>type_]
 739                  ParaQuote{..}   -> ["quote", "quote-"<>type_]
 740                  ParaComment{}   -> []
 741                  ParaOL{}        -> ["ol"]
 742                  ParaUL{}        -> ["ul"]
 743                  ParaJudgment{}  -> ["judgment"]
 744 instance Html5ify ParaItem where
 745         html5ify = \case
 746          ParaPlain p -> H.p $$ html5ify p
 747          ParaArtwork{..} -> H.pre $$ do html5ify text
 748          ParaQuote{..} -> H.div $$ do html5ify paras
 749          ParaComment t -> html5ify $ H.Comment (H.String $ TL.unpack t) ()
 750          ParaOL items ->
 751                 H.table $$ do
 752                         H.tbody $$
 753                                 forM_ items $ \ListItem{..} -> do
 754                                         H.tr $$ do
 755                                                 H.td ! HA.class_ "name" $$ do
 756                                                         html5ify name
 757                                                         "."::HTML5
 758                                                 H.td ! HA.class_ "value" $$
 759                                                         html5ify paras
 760          ParaUL items ->
 761                 H.dl $$ do
 762                         forM_ items $ \item -> do
 763                                 H.dt $$ "—"
 764                                 H.dd $$ html5ify item
 765          ParaJudgment j -> html5ify j
 766 instance Html5ify Judgment where
 767  html5ify Judgment{..} = do
 768         st <- liftStateMarkup S.get
 769         H.div $$ do
 770                 let judgmentGrades =
 771                         maybe (Prelude.error $ show grades) MJ.grades $ -- unknown grades
 772                         HM.lookup grades (Collect.all_grades $ state_collect st)
 773                 let judgmentJudges =
 774                         fromMaybe (Prelude.error $ show judges) $ -- unknown judges
 775                         HM.lookup judges (Collect.all_judges $ state_collect st)
 776                 let defaultGradeByJudge =
 777                         let defaultGrade =
 778                                 List.head
 779                                  [ g | g <- Set.toList judgmentGrades
 780                                  , isDefault $ MJ.unRank g
 781                                  ] in
 782                         HM.fromList
 783                          [ (name, defaultGrade`fromMaybe`judgeDefaultGrade)
 784                          | DTC.Judge{name,defaultGrades} <- judgmentJudges
 785                          , let judgeDefaultGrade = do
 786                                 jdg <- listToMaybe [g | (n,g) <- defaultGrades, n == grades]
 787                                 listToMaybe
 788                                  [ g | g <- Set.toList judgmentGrades
 789                                  , let DTC.Grade{name=n} = MJ.unRank g
 790                                  , n == jdg
 791                                  ]
 792                          ]
 793                 judgmentChoices <- forM choices $ \c@DTC.Choice{opinions} -> do
 794                         gradeByJudge <- forM opinions $ \DTC.Opinion{judge,grade} -> do
 795                                 let grd =
 796                                         fromMaybe (Prelude.error $ show grade) $ -- unknown grade
 797                                         listToMaybe
 798                                          [ MJ.singleGrade g | g <- Set.toList judgmentGrades
 799                                          , let Grade{name} = MJ.unRank g
 800                                          , name == grade
 801                                          ]
 802                                 return (judge, grd)
 803                         case MJ.opinions defaultGradeByJudge $ HM.fromList gradeByJudge of
 804                          (ok,ko) | null ko   -> return (c, ok)
 805                                  | otherwise -> Prelude.error $ show ko -- unknown judge
 806                         -- TODO: handle ko
 807                 html5Judgment question choices $ HM.fromList judgmentChoices
 808 instance Html5ify [Para] where
 809         html5ify = mapM_ html5ify
 810 instance Html5ify Plain where
 811         html5ify ps =
 812                 case Seq.viewl ps of
 813                  Seq.EmptyL -> mempty
 814                  curr Seq.:< next ->
 815                         case curr of
 816                         -- NOTE: gather adjacent PlainNotes
 817                          Tree PlainNote{} _
 818                           | (notes, rest) <- Seq.spanl (\case {Tree PlainNote{} _ -> True; _ -> False}) next -> do
 819                                 H.sup ! HA.class_ "note-numbers" $$ do
 820                                         html5ify curr
 821                                         forM_ notes $ \note -> do
 822                                                 ", "::HTML5
 823                                                 html5ify note
 824                                 " "::HTML5
 825                                 html5ify rest
 826                         --
 827                          _ -> do
 828                                 html5ify curr
 829                                 html5ify next
 830 instance Html5ify (Tree PlainNode)
 831  where html5ify (Tree n ls) =
 832         case n of
 833          PlainBreak  -> html5ify H.br
 834          PlainText t -> html5ify t
 835          PlainGroup  -> html5ify ls
 836          PlainB      -> H.strong $$ html5ify ls
 837          PlainCode   -> H.code   $$ html5ify ls
 838          PlainDel    -> H.del    $$ html5ify ls
 839          PlainI -> do
 840                 i <- liftStateMarkup $ do
 841                         i <- S.gets $ Plain.state_italic . state_plainify
 842                         S.modify $ \s ->
 843                                 s{state_plainify=
 844                                         (state_plainify s){Plain.state_italic=
 845                                                 not i}}
 846                         return i
 847                 H.em ! HA.class_ (if i then "even" else "odd") $$
 848                         html5ify ls
 849                 liftStateMarkup $
 850                         S.modify $ \s ->
 851                                 s{state_plainify=
 852                                         (state_plainify s){Plain.state_italic=i}}
 853          PlainSpan{..} ->
 854                 html5CommonAttrs attrs $
 855                 H.span $$ html5ify ls
 856          PlainSub  -> H.sub    $$ html5ify ls
 857          PlainSup  -> H.sup    $$ html5ify ls
 858          PlainSC   -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
 859          PlainU    -> H.span ! HA.class_ "underline" $$ html5ify ls
 860          PlainNote{..} ->
 861                 case number of
 862                  Nothing -> Prelude.error "[BUG] PlainNote has no number."
 863                  Just num ->
 864                         H.a ! HA.class_ "note-ref"
 865                             ! HA.id ("note-ref."<>attrify num)
 866                             ! HA.href ("#note."<>attrify num) $$
 867                                 html5ify num
 868          PlainQ -> do
 869                 H.span ! HA.class_ "q" $$ do
 870                         Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
 871                         Plain.l10n_Quote (html5ify $ Tree PlainI ls) l10n
 872          PlainEref{..} ->
 873                 H.a ! HA.class_ "eref"
 874                     ! HA.href (attrify href) $$
 875                         if null ls
 876                         then html5ify $ unURL href
 877                         else html5ify ls
 878          PlainIref{..} ->
 879                 case anchor of
 880                  Nothing -> html5ify ls
 881                  Just Anchor{count} ->
 882                         H.span ! HA.class_ "iref"
 883                                ! HA.id (attrify $ identifyIrefCount term count) $$
 884                                 html5ify ls
 885          PlainTag{error} -> do
 886                 st <- liftStateMarkup S.get
 887                 let l10n = Plain.state_l10n $ state_plainify st
 888                 case error of
 889                  Nothing ->
 890                         H.a ! HA.class_ "tag"
 891                             ! HA.href (refIdent $ identifyTitle l10n $ Title ls) $$
 892                                 html5ify ls
 893                  Just (ErrorTarget_Unknown num) ->
 894                         H.span ! HA.class_ "tag tag-unknown"
 895                                ! HA.id (attrify $ identifyTag "-unknown" l10n ls (Just num)) $$
 896                                 html5ify ls
 897                  Just (ErrorTarget_Ambiguous num) ->
 898                         H.span ! HA.class_ "tag tag-ambiguous"
 899                                ! HA.id (attrify $ identifyTag "-ambiguous" l10n ls num) $$
 900                                 html5ify ls
 901          PlainRref{..} -> do
 902                 case error of
 903                  Nothing ->
 904                         let ref = do
 905                                 "["::HTML5
 906                                 H.a ! HA.class_ "reference"
 907                                     ! HA.href (refIdent $ identifyReference "" to Nothing)
 908                                     ! HA.id (attrify $ identifyReference "" to number) $$
 909                                         html5ify to
 910                                 "]" in
 911                         case toList ls of
 912                          [] -> ref
 913                          [Tree (PlainText "") _] -> do
 914                                 refs <- liftStateMarkup $ S.gets $ Collect.all_reference . state_collect
 915                                 case toList <$> HM.lookup to refs of
 916                                  Just [Reference{about=About{..}}] -> do
 917                                         forM_ (List.take 1 titles) $ \(Title title) -> do
 918                                                 html5ify $ Tree PlainQ $
 919                                                         case url of
 920                                                          Nothing -> title
 921                                                          Just u -> pure $ Tree (PlainEref u) title
 922                                                 " "::HTML5
 923                                                 ref
 924                                  _ -> mempty
 925                          _ -> do
 926                                 H.a ! HA.class_ "reference"
 927                                     ! HA.href (refIdent $ identifyReference "" to Nothing)
 928                                     ! HA.id (attrify $ identifyReference "" to number) $$
 929                                         html5ify ls
 930                                 H.span ! HA.class_ "print-only" $$ do
 931                                         " "::HTML5
 932                                         ref
 933                  Just (ErrorTarget_Unknown num) -> do
 934                         "["::HTML5
 935                         H.span ! HA.class_ "reference reference-unknown"
 936                                ! HA.id (attrify $ identifyReference "-unknown" to $ Just num) $$
 937                                 html5ify to
 938                         "]"
 939                  Just (ErrorTarget_Ambiguous num) -> do
 940                         case toList ls of
 941                          [] -> mempty
 942                          [Tree (PlainText "") _] -> mempty
 943                          _ -> do
 944                                 html5ify ls
 945                                 " "::HTML5
 946                         "["::HTML5
 947                         H.span ! HA.class_ "reference reference-ambiguous"
 948                                !?? mayAttr HA.id (attrify . identifyReference "-ambiguous" to . Just <$> num) $$
 949                                 html5ify to
 950                         "]"
 951 instance Html5ify [Title] where
 952         html5ify =
 953                 html5ify . fold . List.intersperse sep . toList
 954                 where sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
 955 instance Html5ify About where
 956         html5ify About{..} = do
 957                 html5Lines
 958                  [ html5CommasDot $ concat $
 959                          [ html5Titles titles
 960                          , html5ify <$> authors
 961                          , html5ify <$> maybeToList date
 962                          , html5ify <$> maybeToList editor
 963                          , html5ify <$> series
 964                          ]
 965                  , forM_ url $ \u ->
 966                                 H.span ! HA.class_ "print-only" $$ do
 967                                         "<"::HTML5
 968                                         html5ify u
 969                                         ">"
 970                  ]
 971                 where
 972                 html5Titles :: [Title] -> [HTML5]
 973                 html5Titles ts | null ts = []
 974                 html5Titles ts = [html5Title $ joinTitles ts]
 975                         where
 976                         joinTitles = fold . List.intersperse sep . toList
 977                         sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
 978                 html5Title (Title title) =
 979                         html5ify $ Tree PlainQ $
 980                                 case url of
 981                                  Nothing -> title
 982                                  Just u -> pure $ Tree (PlainEref u) title
 983 instance Html5ify Serie where
 984         html5ify s@Serie{id=id_, name} = do
 985                 Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
 986                 case urlSerie s of
 987                  Nothing -> do
 988                         html5ify name
 989                         Plain.l10n_Colon l10n :: HTML5
 990                         html5ify id_
 991                  Just href -> do
 992                         html5ify $
 993                                 Tree PlainEref{href} $
 994                                 Seq.fromList
 995                                  [ tree0 $ PlainText $ unName name
 996                                  , tree0 $ PlainText $ Plain.l10n_Colon l10n
 997                                  , tree0 $ PlainText id_
 998                                  ]
 999 instance Html5ify Entity where
1000         html5ify Entity{..} = do
1001                 case () of
1002                  _ | not (TL.null email) -> do
1003                         H.span ! HA.class_ "no-print" $$
1004                                 html5ify $
1005                                         Tree (PlainEref $ URL $ "mailto:"<>email) $
1006                                                 pure $ tree0 $ PlainText name
1007                         H.span ! HA.class_ "print-only" $$
1008                                 html5ify $
1009                                         Tree PlainGroup $ Seq.fromList
1010                                          [ tree0 $ PlainText name
1011                                          , tree0 $ PlainText " <"
1012                                          , Tree (PlainEref $ URL $ "mailto:"<>email) $
1013                                                 pure $ tree0 $ PlainText email
1014                                          , tree0 $ PlainText ">"
1015                                          ]
1016                  _ | Just u <- url ->
1017                         html5ify $
1018                                 Tree (PlainEref u) $
1019                                         pure $ tree0 $ PlainText name
1020                  _ ->
1021                         html5ify $
1022                                 tree0 $ PlainText name
1023                 forM_ org $ \o -> do
1024                         " ("::HTML5
1025                         html5ify o
1026                         ")"::HTML5
1027 instance Html5ify Words where
1028         html5ify = html5ify . Index.plainifyWords
1029 instance Html5ify Alias where
1030         html5ify Alias{..} = do
1031                 st@State{state_collect=Collect.All{..}} <- liftStateMarkup S.get
1032                 let l10n = Plain.state_l10n $ state_plainify st
1033                 case toList <$> HM.lookup title all_section of
1034                  Just [_] ->
1035                         H.a ! HA.class_ "alias"
1036                             ! HA.id (attrify $ identifyTitle l10n title) $$
1037                                 mempty
1038                  _ -> mempty
1039 instance Html5ify URL where
1040         html5ify (URL url) =
1041                 H.a ! HA.class_ "eref"
1042                     ! HA.href (attrify url) $$
1043                         html5ify url
1044 instance Html5ify Date where
1045         html5ify date = do
1046                 Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
1047                 Plain.l10n_Date date l10n
1048 instance Html5ify Reference where
1049         html5ify Reference{..} =
1050                 H.tr $$ do
1051                         H.td ! HA.class_ "reference-key" $$
1052                                 html5ify $ tree0 PlainRref
1053                                  { number = Nothing
1054                                  , locTCT = def
1055                                  , to     = id
1056                                  , error  = (<$> error) $ \case
1057                                          ErrorAnchor_Ambiguous num -> ErrorTarget_Ambiguous (Just num)
1058                                  }
1059                         H.td ! HA.class_ "reference-content" $$ do
1060                                 html5ify about
1061                                 rrefs <- liftStateMarkup $ S.gets state_rrefs
1062                                 case HM.lookup id rrefs of
1063                                  Nothing -> pure ()
1064                                  Just anchs ->
1065                                         H.span ! HA.class_ "reference-rrefs" $$
1066                                                 html5CommasDot $
1067                                                 (<$> List.reverse anchs) $ \(maySection,num) ->
1068                                                         H.a ! HA.class_ "reference-rref"
1069                                                             ! HA.href (refIdent $ identifyReference "" id $ Just num) $$
1070                                                                 case maySection of
1071                                                                  Nothing -> "0"::HTML5
1072                                                                  Just Section{xmlPos=posSection} -> html5ify $ XML.pos_ancestors posSection
1073 instance Html5ify XML.Ancestors where
1074         html5ify ancs =
1075                 case toList ancs of
1076                  [(_n,c)] -> do
1077                         html5ify $ show c
1078                         html5ify '.'
1079                  as ->
1080                         html5ify $
1081                                 Text.intercalate "." $
1082                                 Text.pack . show . snd <$> as
1083 instance Html5ify Plain.Plain where
1084         html5ify p = do
1085                 sp <- liftStateMarkup $ S.gets state_plainify
1086                 let (t,sp') = Plain.runPlain p sp
1087                 html5ify t
1088                 liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'}
1089 {-
1090 instance Html5ify SVG.Element where
1091         html5ify svg =
1092                 html5ify $
1093                 B.preEscapedLazyText $
1094                 SVG.renderText svg
1095 instance Semigroup SVG.Element where
1096         (<>) = mappend
1097 -}
1098
1099 html5CommasDot :: [HTML5] -> HTML5
1100 html5CommasDot [] = pure ()
1101 html5CommasDot hs = do
1102         sequence_ $ List.intersperse ", " hs
1103         "."
1104
1105 html5Lines :: [HTML5] -> HTML5
1106 html5Lines hs = sequence_ $ List.intersperse (html5ify H.br) hs
1107
1108 html5Words :: [HTML5] -> HTML5
1109 html5Words hs = sequence_ $ List.intersperse " " hs
1110
1111 html5AttrClass :: [TL.Text] -> HTML5 -> HTML5
1112 html5AttrClass = \case
1113  [] -> Cat.id
1114  cls  ->
1115         Compose .
1116         (H.AddCustomAttribute "class"
1117          (H.String $ TL.unpack $ TL.unwords cls) <$>) .
1118         getCompose
1119
1120 html5AttrId :: Ident -> HTML5 -> HTML5
1121 html5AttrId (Ident id_) =
1122         Compose .
1123         (H.AddCustomAttribute "id"
1124          (H.String $ TL.unpack id_) <$>) .
1125         getCompose
1126
1127 html5CommonAttrs :: CommonAttrs -> HTML5 -> HTML5
1128 html5CommonAttrs CommonAttrs{id=id_, ..} =
1129         html5AttrClass classes .
1130         maybe Cat.id html5AttrId id_
1131
1132 html5SectionNumber :: XML.Ancestors -> HTML5
1133 html5SectionNumber = go mempty
1134         where
1135         go :: XML.Ancestors -> XML.Ancestors -> HTML5
1136         go prev next =
1137                 case Seq.viewl next of
1138                  Seq.EmptyL -> pure ()
1139                  a@(_n,rank) Seq.:< as -> do
1140                         H.a ! HA.href (refIdent $ identify $ prev Seq.|> a) $$
1141                                 html5ify $ show rank
1142                         when (not (null as) || null prev) $ do
1143                                 html5ify '.'
1144                                 go (prev Seq.|>a) as
1145
1146 html5SectionRef :: XML.Ancestors -> HTML5
1147 html5SectionRef as =
1148         H.a ! HA.href (refIdent $ identify as) $$
1149                 html5ify as
1150
1151 html5Notes :: IntMap [Para] -> HTML5
1152 html5Notes notes =
1153         H.aside ! HA.class_ "notes" $$ do
1154                 Compose $ pure H.hr
1155                 H.table $$
1156                         H.tbody $$
1157                                 forM_ (IntMap.toList notes) $ \(number,content) ->
1158                                         H.tr $$ do
1159                                                 H.td ! HA.class_ "note-ref" $$ do
1160                                                         H.a ! HA.class_ "note-number"
1161                                                             ! HA.id   ("note."<>attrify number)
1162                                                             ! HA.href ("#note."<>attrify number) $$ do
1163                                                                 html5ify number
1164                                                         ". "::HTML5
1165                                                         H.a ! HA.href ("#note-ref."<>attrify number) $$ do
1166                                                                 "↑"
1167                                                 H.td $$
1168                                                         html5ify content
1169
1170 html5ifyToC :: Maybe DTC.Nat -> Tree BodyNode -> HTML5
1171 html5ifyToC depth (Tree b bs) =
1172         case b of
1173          BodySection Section{..} -> do
1174                 H.li $$ do
1175                         H.table ! HA.class_ "toc-entry" $$
1176                                 H.tbody $$
1177                                         H.tr $$ do
1178                                                 H.td ! HA.class_ "section-number" $$
1179                                                         html5SectionRef $ XML.pos_ancestors xmlPos
1180                                                 H.td ! HA.class_ "section-title" $$
1181                                                         html5ify $ cleanPlain $ unTitle title
1182                         when (maybe True (> Nat 1) depth && not (null sections)) $
1183                                 H.ul $$
1184                                         forM_ sections $
1185                                                 html5ifyToC (depth >>= predNat)
1186          _ -> mempty
1187         where
1188         sections =
1189                 (`Seq.filter` bs) $ \case
1190                  Tree BodySection{} _ -> True
1191                  _ -> False
1192
1193 html5ifyToF :: [TL.Text] -> HTML5
1194 html5ifyToF types = do
1195         figuresByType <- liftStateMarkup $ S.gets $ Collect.all_figure . state_collect
1196         let figures =
1197                 Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
1198                 if null types
1199                 then figuresByType
1200                 else
1201                         Map.intersection figuresByType $
1202                         Map.fromList [(ty,()) | ty <- types]
1203         forM_ (Map.toList figures) $ \(xmlPos, (type_, title)) ->
1204                 H.tr $$ do
1205                         H.td ! HA.class_ "figure-number" $$
1206                                 H.a ! HA.href (refIdent $ identify xmlPos) $$ do
1207                                         html5ify type_
1208                                         html5ify $ XML.pos_ancestors xmlPos
1209                         forM_ title $ \ti ->
1210                                 H.td ! HA.class_ "figure-title" $$
1211                                         html5ify $ cleanPlain $ unTitle ti
1212
1213 html5Judgment ::
1214  Maybe Title ->
1215  [Choice] ->
1216  MJ.OpinionsByChoice Choice Name (MJ.Ranked Grade) ->
1217  HTML5
1218 html5Judgment question choices distByJudgeByChoice = do
1219         let commentJGC = HM.fromList
1220                 [ (choice_, HM.fromListWith (<>)
1221                         [ (grade, HM.singleton judge comment)
1222                         | Opinion{..} <- opinions ])
1223                 | choice_@Choice{opinions} <- choices ]
1224         case question of
1225          Nothing -> mempty
1226          Just title -> H.div ! HA.class_ "question" $$ html5ify title
1227         H.dl ! HA.class_ "choices" $$ do
1228                 let meritByChoice@(MJ.MeritByChoice meritC) = MJ.meritByChoice distByJudgeByChoice
1229                 let ranking = MJ.majorityRanking meritByChoice
1230                 forM_ ranking $ \(choice_@DTC.Choice{title}, majorityValue) -> do
1231                         H.dt ! HA.class_ "choice-title" $$ do
1232                                 html5ify title
1233                         H.dd ! HA.class_ "choice-merit" $$ do
1234                                 let distByJudge = distByJudgeByChoice HM.!choice_
1235                                 let numJudges   = HM.size distByJudge
1236                                 html5MeritHistogram majorityValue numJudges
1237                                 let grades    = Map.keys $ MJ.unMerit $ meritC HM.!choice_
1238                                 let commentJG = HM.lookup choice_ commentJGC
1239                                 html5MeritComments distByJudge grades commentJG
1240
1241 html5MeritComments ::
1242  MJ.Opinions Name (MJ.Ranked Grade) ->
1243  [MJ.Ranked Grade] ->
1244  Maybe (HM.HashMap Name (HM.HashMap Name (Maybe Title))) ->
1245  HTML5
1246 html5MeritComments distJ grades commentJG = do
1247         Loqualization l10n <- liftStateMarkup $ S.gets state_l10n
1248         H.ul ! HA.class_ "merit-comments" $$ do
1249                 forM_ grades $ \grade@(MJ.unRank -> DTC.Grade{name=grade_name, color}) -> do
1250                         let commentJ = commentJG >>= HM.lookup grade_name
1251                         let judgesWithComment =
1252                                 -- FIXME: sort accents better: « e é f » not « e f é »
1253                                 List.sortOn (TL.map Char.toLower . unName . (\(j,_,_) -> j))
1254                                  [ (judge, importance, commentJ >>= HM.lookupDefault Nothing judge)
1255                                  | (judge, dist) <- HM.toList distJ
1256                                  , importance <- maybeToList $ Map.lookup grade dist ]
1257                         forM_ judgesWithComment $ \(judge, importance, comment) ->
1258                                 H.li ! HA.class_ ("merit-comment" <> if isJust comment then " judge-comment" else "") $$ do
1259                                         H.span
1260                                          ! HA.class_ ("judge" <> if judge`HM.member`fromMaybe HM.empty commentJ then "" else " inactive")
1261                                          ! HA.style ("color:"<>attrify color<>";") $$ do
1262                                                 unless (importance == 1) $ do
1263                                                         H.span ! HA.class_ "section-importance" $$ do
1264                                                                 let percent =
1265                                                                         (round::Double -> Int) $
1266                                                                         fromRational $ importance * 100
1267                                                                 html5ify $ show percent
1268                                                                 "%"::HTML5
1269                                                 html5ify judge
1270                                         case comment of
1271                                          Nothing -> mempty
1272                                          Just p -> do
1273                                                 Plain.l10n_Colon l10n :: HTML5
1274                                                 html5ify p
1275
1276 html5MeritHistogram :: MJ.MajorityValue (MJ.Ranked Grade) -> Int -> HTML5
1277 html5MeritHistogram (MJ.MajorityValue majVal) numJudges = do
1278         H.div ! HA.class_ "merit-histogram" $$ do
1279                 forM_ majVal $ \(MJ.unRank -> DTC.Grade{name=grade_name, title=grade_title, color},count) -> do
1280                         let percent :: Double =
1281                                 fromRational $ (toRational $ (ceiling::Double -> Int) $ fromRational $
1282                                 (count / toRational numJudges) * 100 * 1000) / 1000
1283                         let bcolor  = "background-color:"<>attrify color<>";"
1284                         let width   = "width:"<>attrify percent<>"%;"
1285                         let display = if percent == 0 then "display:none;" else ""
1286                         H.div
1287                          ! HA.class_ "merit-grade"
1288                          ! HA.alt (attrify grade_name) -- FIXME: do not work
1289                          ! HA.style (bcolor<>display<>width) $$ do
1290                                 H.div
1291                                  ! HA.class_ "grade-name" $$ do
1292                                         case grade_title of
1293                                          Nothing -> html5ify grade_name
1294                                          Just t  -> html5ify t
1295
1296 html5Judgments :: HTML5
1297 html5Judgments = do
1298         Collect.All{..} <- liftStateMarkup $ S.gets state_collect
1299         opinionsByChoiceByNodeBySectionByJudgment <-
1300                 forM (HM.toList all_judgments) $ \(judgment@Judgment{judges,grades}, choicesBySection) -> do
1301                         -- WARNING: only the fields of 'Judgment' used in its 'Hashable' instance
1302                         -- can safely be used here: 'judges' and 'grades' are ok
1303                         let judgmentGrades =
1304                                 maybe (Prelude.error $ show grades) MJ.grades $ -- unknown grades
1305                                 HM.lookup grades all_grades
1306                         let judgmentJudges =
1307                                 fromMaybe (Prelude.error $ show judges) $ -- unknown judges
1308                                 HM.lookup judges all_judges
1309                         let defaultGradeByJudge =
1310                                 let defaultGrade =
1311                                         List.head
1312                                          [ g | g <- Set.toList judgmentGrades
1313                                          , isDefault $ MJ.unRank g
1314                                          ] in
1315                                 HM.fromList
1316                                  [ (name, defaultGrade`fromMaybe`judgeDefaultGrade)
1317                                  | DTC.Judge{name,defaultGrades} <- judgmentJudges
1318                                  , let judgeDefaultGrade = do
1319                                         jdg <- listToMaybe [g | (n,g) <- defaultGrades, n == grades]
1320                                         listToMaybe
1321                                          [ g | g <- Set.toList judgmentGrades
1322                                          , let DTC.Grade{name=n} = MJ.unRank g
1323                                          , n == jdg
1324                                          ]
1325                                  ]
1326                         opinionsByChoiceByNodeBySection <-
1327                                 forM choicesBySection $ \choicesTree -> do
1328                                         judgmentTree <- forM choicesTree $ \(section_importance, choices) -> do
1329                                                 judgmentOpinions <- forM choices $ \choice_@DTC.Choice{opinions} -> do
1330                                                         gradeByJudge <- forM opinions $ \DTC.Opinion{judge,grade,importance} -> do
1331                                                                 case listToMaybe
1332                                                                          [ g | g <- Set.toList judgmentGrades
1333                                                                          , let Grade{name} = MJ.unRank g
1334                                                                          , name == grade
1335                                                                          ] of
1336                                                                  Just grd -> return (judge, MJ.Section importance (Just grd))
1337                                                                  Nothing -> Prelude.error $ show grade -- unknown grade
1338                                                         return (choice_, HM.fromList gradeByJudge)
1339                                                 return $ MJ.SectionNode section_importance $ HM.fromList judgmentOpinions
1340                                         let judgmentChoices = HS.fromList $ snd $ Tree.rootLabel choicesTree
1341                                           -- NOTE: choices are determined by those at the root Tree.Node.
1342                                         -- NOTE: core Majority Judgment calculus handled here by MJ
1343                                         case MJ.opinionsBySection judgmentChoices defaultGradeByJudge judgmentTree of
1344                                          Right opinionsByChoiceByNode -> return opinionsByChoiceByNode
1345                                          Left err -> Prelude.error $ show err -- unknown choice, unknown judge, invalid shares
1346                         -- NOTE: 'toList' returns a self-then-descending-then-following traversal of a 'Tree',
1347                         -- this will match perfectly withw the 'html5ify' traversal:
1348                         -- 'BodySection' by 'BodySection'.
1349                         return (judgment, join $ toList <$> opinionsByChoiceByNodeBySection)
1350         liftStateMarkup $ S.modify' $ \st ->
1351                 st{state_opinions = HM.fromList opinionsByChoiceByNodeBySectionByJudgment}
1352
1353 -- 'Attrify'
1354 instance Attrify Plain.Plain where
1355         attrify p = attrify t
1356                 where (t,_) = Plain.runPlain p def
1357
1358 -- * Class 'L10n'
1359 class
1360  ( Plain.L10n msg lang
1361  , Plain.L10n TL.Text lang
1362  ) => L10n msg lang where
1363         l10n_Header_Address :: FullLocale lang -> msg
1364         l10n_Header_Date    :: FullLocale lang -> msg
1365         l10n_Header_Version :: FullLocale lang -> msg
1366         l10n_Header_Origin  :: FullLocale lang -> msg
1367         l10n_Header_Source  :: FullLocale lang -> msg
1368         l10n_Errors_All                :: FullLocale lang -> Nat -> msg
1369         l10n_Error_Tag_unknown         :: FullLocale lang -> msg
1370         l10n_Error_Tag_ambiguous       :: FullLocale lang -> msg
1371         l10n_Error_Rref_unknown        :: FullLocale lang -> msg
1372         l10n_Error_Reference_ambiguous :: FullLocale lang -> msg
1373 instance L10n HTML5 EN where
1374         l10n_Header_Address _l10n = "Address"
1375         l10n_Header_Date    _l10n = "Date"
1376         l10n_Header_Origin  _l10n = "Origin"
1377         l10n_Header_Source  _l10n = "Source"
1378         l10n_Header_Version _l10n = "Version"
1379         l10n_Errors_All _l10n n = "All errors ("<>html5ify n<>")"
1380         l10n_Error_Tag_unknown         _l10n = "Unknown tag"
1381         l10n_Error_Tag_ambiguous       _l10n = "Ambiguous tag"
1382         l10n_Error_Rref_unknown        _l10n = "Unknown reference"
1383         l10n_Error_Reference_ambiguous _l10n = "Ambiguous reference"
1384 instance L10n HTML5 FR where
1385         l10n_Header_Address _l10n = "Adresse"
1386         l10n_Header_Date    _l10n = "Date"
1387         l10n_Header_Origin  _l10n = "Origine"
1388         l10n_Header_Source  _l10n = "Source"
1389         l10n_Header_Version _l10n = "Version"
1390         l10n_Errors_All _l10n n = "Toutes les erreurs ("<>html5ify n<>")"
1391         l10n_Error_Tag_unknown         _l10n = "Tag inconnu"
1392         l10n_Error_Tag_ambiguous       _l10n = "Tag ambigu"
1393         l10n_Error_Rref_unknown        _l10n = "Référence inconnue"
1394         l10n_Error_Reference_ambiguous _l10n = "Référence ambiguë"
1395
1396 instance Plain.L10n HTML5 EN where
1397         l10n_Colon             l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
1398         l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
1399         l10n_Date date         l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
1400         l10n_Quote msg _l10n = do
1401                 depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
1402                 let (o,c) :: (HTML5, HTML5) =
1403                         case unNat depth `mod` 3 of
1404                          0 -> ("“","”")
1405                          1 -> ("« "," »")
1406                          _ -> ("‟","„")
1407                 o
1408                 setDepth $ succNat depth
1409                 msg
1410                 setDepth $ depth
1411                 c
1412                 where
1413                 setDepth d =
1414                         liftStateMarkup $ S.modify' $ \s ->
1415                                 s{state_plainify=(state_plainify s){Plain.state_quote=d}}
1416 instance Plain.L10n HTML5 FR where
1417         l10n_Colon             l10n = html5ify (Plain.l10n_Colon l10n :: TL.Text)
1418         l10n_Table_of_Contents l10n = html5ify (Plain.l10n_Table_of_Contents l10n :: TL.Text)
1419         l10n_Date date         l10n = html5ify (Plain.l10n_Date date l10n :: TL.Text)
1420         l10n_Quote msg _l10n = do
1421                 depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
1422                 let (o,c) :: (HTML5, HTML5) =
1423                         case unNat depth `mod` 3 of
1424                          0 -> ("« "," »")
1425                          1 -> ("“","”")
1426                          _ -> ("‟","„")
1427                 o
1428                 setDepth $ succNat depth
1429                 msg
1430                 setDepth $ depth
1431                 c
1432                 where
1433                 setDepth d =
1434                         liftStateMarkup $ S.modify' $ \s ->
1435                                 s{state_plainify=(state_plainify s){Plain.state_quote=d}}