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