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