Language/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 {-# OPTIONS_GHC -fno-warn-orphans #-}
  11 module Language.DTC.Write.HTML5 where
  12
  13 import Control.Applicative (Applicative(..))
  14 import Control.Category as Cat
  15 import Control.Monad
  16 import Data.Bool
  17 import Data.Char (Char)
  18 import Data.Default.Class (Default(..))
  19 import Data.Either (Either(..))
  20 import Data.Eq (Eq(..))
  21 import Data.Foldable (Foldable(..), concat, any)
  22 import Data.Function (($), const, on)
  23 import Data.Functor ((<$>))
  24 import Data.Functor.Compose (Compose(..))
  25 import Data.Int (Int)
  26 import Data.Map.Strict (Map)
  27 import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList)
  28 import Data.Monoid (Monoid(..))
  29 import Data.Ord (Ord(..))
  30 import Data.Semigroup (Semigroup(..))
  31 import Data.String (String, IsString(..))
  32 import Data.Text (Text)
  33 import Data.TreeSeq.Strict (Tree(..), tree0)
  34 import Data.Tuple (snd)
  35 import Prelude (mod)
  36 import System.FilePath (FilePath)
  37 import Text.Blaze ((!))
  38 import Text.Blaze.Html (Html)
  39 import Text.Show (Show(..))
  40 import qualified Control.Monad.Trans.State as S
  41 import qualified Data.List as List
  42 import qualified Data.Map.Strict as Map
  43 import qualified Data.Sequence as Seq
  44 import qualified Data.Strict.Maybe as Strict
  45 import qualified Data.Text as Text
  46 import qualified Data.Text.Lazy as TL
  47 import qualified Data.TreeMap.Strict as TreeMap
  48 import qualified Data.TreeSeq.Strict.Zipper as Tree
  49 import qualified Text.Blaze.Html5 as H
  50 import qualified Text.Blaze.Html5.Attributes  as HA
  51 import qualified Text.Blaze.Internal as H
  52
  53 import Text.Blaze.Utils
  54 import Data.Locale hiding (Index)
  55
  56 import Language.DTC.Document as DTC
  57 import Language.DTC.Write.Plain (Plainify(..))
  58 import Language.DTC.Write.XML ()
  59 import qualified Language.DTC.Anchor as Anchor
  60 import qualified Language.DTC.Write.Plain as Plain
  61
  62 writeHTML5 :: Config -> DTC.Document -> Html
  63 writeHTML5 conf@Config{..} DTC.Document{..} = do
  64         let Keys{..} = keys body `S.execState` def
  65         let (body',state_rrefs,state_notes,state_indexs) =
  66                 let irefs = foldMap Anchor.irefsOfTerms keys_index in
  67                 let (body0, Anchor.State{state_irefs, state_rrefs=rrefs, state_notes=notes}) =
  68                         Anchor.anchorify body `S.runState`
  69                         def{Anchor.state_irefs=irefs} in
  70                 (body0,rrefs,notes,) $
  71                 (<$> keys_index) $ \terms ->
  72                         (terms,) $
  73                         TreeMap.intersection const state_irefs $
  74                         Anchor.irefsOfTerms terms
  75         let state_plainify = def{ Plain.state_l10n = loqualize config_locale}
  76         let (html5Body, endState) =
  77                 runStateMarkup def
  78                  { state_indexs
  79                  , state_rrefs
  80                  , state_notes
  81                  , state_figures    = keys_figure
  82                  , state_references = keys_reference
  83                  , state_plainify
  84                  , state_l10n = loqualize config_locale
  85                  } $ do
  86                         html5DocumentHead head
  87                         html5ify body'
  88         H.docType
  89         H.html ! HA.lang (attrify $ countryCode config_locale) $ do
  90                 html5Head conf endState head body
  91                 H.body $ html5Body
  92
  93 html5Head :: Config -> State -> Head -> Body -> Html
  94 html5Head Config{..} State{..} Head{DTC.about=About{..}} body = do
  95         H.head $ do
  96                 H.meta ! HA.httpEquiv "Content-Type"
  97                        ! HA.content "text/html; charset=UTF-8"
  98                 unless (null titles) $ do
  99                         H.title $
 100                                 H.toMarkup $ Plain.text state_plainify $ List.head titles
 101                 forM_ links $ \Link{rel, href} ->
 102                         H.link ! HA.rel (attrify rel)
 103                                ! HA.href (attrify href)
 104                 forM_ url $ \href ->
 105                         H.link ! HA.rel "self"
 106                                ! HA.href (attrify href)
 107                 unless (TL.null config_generator) $ do
 108                         H.meta ! HA.name "generator"
 109                                ! HA.content (attrify config_generator)
 110                 unless (null tags) $
 111                         H.meta ! HA.name "keywords"
 112                                ! HA.content (attrify $ TL.intercalate ", " tags)
 113                 let chapters =
 114                         (`mapMaybe` toList body) $ \case
 115                          Tree k@BodySection{} _ -> Just k
 116                          _ -> Nothing
 117                 forM_ chapters $ \case
 118                  BodySection{..} ->
 119                         H.link ! HA.rel "Chapter"
 120                                ! HA.title (attrify $ plainify title)
 121                                ! HA.href ("#"<>attrify pos)
 122                  _ -> mempty
 123                 unless (any (\DTC.Link{rel} -> rel == "stylesheet") links) $ do
 124                         case config_css of
 125                          Left "" -> mempty
 126                          Left css ->
 127                                 H.link ! HA.rel "stylesheet"
 128                                        ! HA.type_ "text/css"
 129                                        ! HA.href (attrify css)
 130                          Right css ->
 131                                 H.style ! HA.type_ "text/css" $
 132                                         -- NOTE: as a special case, H.style wraps its content into an External,
 133                                         -- so it does not HTML-escape its content.
 134                                         H.toMarkup css
 135                         forM_ state_styles $ \style ->
 136                                 H.style ! HA.type_ "text/css" $
 137                                         H.toMarkup style
 138                 unless (any (\DTC.Link{rel} -> rel == "script") links) $ do
 139                         forM_ state_scripts $ \script ->
 140                                 H.script ! HA.type_ "application/javascript" $
 141                                         H.toMarkup script
 142
 143 html5DocumentHead :: Head -> Html5
 144 html5DocumentHead Head{DTC.about=About{..}} = do
 145         H.div ! HA.class_ "document-head" $$
 146                 H.table $$ do
 147                         H.tbody $$ do
 148                                 H.tr $$ do
 149                                         H.td ! HA.class_ "left"  $$ docHeaders
 150                                         H.td ! HA.class_ "right" $$ docAuthors
 151         unless (null titles) $
 152                 H.div ! HA.class_ "title" $$ do
 153                         forM_ titles $ \title ->
 154                                 H.h1 $$ html5ify title
 155         where
 156         docHeaders =
 157                 H.table ! HA.class_ "document-headers" $$
 158                         H.tbody $$ do
 159                                 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 160                                 forM_ series $ \s@Serie{id=id_, name} ->
 161                                         header $
 162                                                 case urlSerie s of
 163                                                  Nothing -> do
 164                                                         headerName  $ html5ify name
 165                                                         headerValue $ html5ify id_
 166                                                  Just href -> do
 167                                                         headerName  $ html5ify name
 168                                                         headerValue $
 169                                                                 H.a ! HA.href (attrify href) $$
 170                                                                         html5ify id_
 171                                 forM_ date $ \d ->
 172                                         header $ do
 173                                                 headerName  $ l10n_Header_Date loc
 174                                                 headerValue $ html5ify d
 175                                 forM_ url $ \href ->
 176                                         header $ do
 177                                                 headerName  $ l10n_Header_Address loc
 178                                                 headerValue $ html5ify $ tree0 $ PlainEref{href}
 179                                 forM_ links $ \Link{..} ->
 180                                         unless (TL.null name) $
 181                                                 header $ do
 182                                                         headerName  $ html5ify name
 183                                                         headerValue $ html5ify $ Tree PlainEref{href} plain
 184                                 forM_ headers $ \Header{..} ->
 185                                         header $ do
 186                                                 headerName  $ html5ify name
 187                                                 headerValue $ html5ify value
 188         docAuthors =
 189                 H.table ! HA.class_ "document-authors" $$
 190                         H.tbody $$ do
 191                                 forM_ authors $ \a ->
 192                                         H.tr $$
 193                                                 H.td ! HA.class_ "author" $$
 194                                                         html5ify a
 195         header :: Html5 -> Html5
 196         header h = H.tr ! HA.class_ "header" $$ h
 197         headerName :: Html5 -> Html5
 198         headerName h =
 199                 H.td ! HA.class_ "header-name" $$ do
 200                         h
 201                         Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 202                         Plain.l10n_Colon loc
 203         headerValue :: Html5 -> Html5
 204         headerValue h =
 205                 H.td ! HA.class_ "header-value" $$ do
 206                         h
 207
 208 -- * Type 'Config'
 209 data Config
 210  =   forall locales.
 211      ( Locales   locales
 212      , Loqualize locales (L10n Html5)
 213      , Loqualize locales (Plain.L10n Plain.Plain)
 214      ) =>
 215      Config
 216  {   config_css       :: Either FilePath TL.Text
 217  ,   config_locale    :: LocaleIn locales
 218  ,   config_generator :: TL.Text
 219  }
 220 instance Default Config where
 221         def = Config
 222          { config_css       = Right "style/dtc-html5.css"
 223          , config_locale    = LocaleIn @'[EN] en_US
 224          , config_generator = "https://hackage.haskell.org/package/hdoc"
 225          }
 226
 227 -- * Type 'Html5'
 228 type Html5 = StateMarkup State ()
 229 instance IsString Html5 where
 230         fromString = html5ify
 231
 232 -- * Type 'State'
 233 data State
 234  =   State
 235  {   state_styles     :: Map FilePath TL.Text
 236  ,   state_scripts    :: Map FilePath TL.Text
 237  ,   state_indexs     :: Map DTC.Pos (Terms, Anchor.Irefs)
 238  ,   state_rrefs      :: Anchor.Rrefs
 239  ,   state_figures    :: Map TL.Text (Map DTC.Pos (Maybe Title))
 240  ,   state_references :: Map Ident About
 241  ,   state_notes      :: Anchor.Notes
 242  ,   state_plainify   :: Plain.State
 243  ,   state_l10n       :: Loqualization (L10n Html5)
 244  }
 245 instance Default State where
 246         def = State
 247          { state_styles     = def
 248          , state_scripts    = def
 249          , state_indexs     = def
 250          , state_rrefs      = def
 251          , state_figures    = def
 252          , state_references = def
 253          , state_notes      = def
 254          , state_plainify   = def
 255          , state_l10n       = Loqualization EN_US
 256          }
 257
 258 -- * Type 'Keys'
 259 data Keys
 260  = Keys
 261  { keys_index     :: Map DTC.Pos Terms
 262  , keys_figure    :: Map TL.Text (Map DTC.Pos (Maybe Title))
 263  , keys_reference :: Map Ident About
 264  } deriving (Show)
 265 instance Default Keys where
 266         def = Keys mempty mempty mempty
 267
 268 -- ** Class 'KeysOf'
 269 class KeysOf a where
 270         keys :: a -> S.State Keys ()
 271 instance KeysOf Body where
 272         keys = mapM_ keys
 273 instance KeysOf (Tree BodyNode) where
 274         keys (Tree n ts) =
 275                 case n of
 276                  BodySection{..} -> keys ts
 277                  BodyBlock b -> keys b
 278 instance KeysOf DTC.Block where
 279         keys = \case
 280          BlockPara{} -> return ()
 281          BlockToC{}  -> return ()
 282          BlockToF{}  -> return ()
 283          BlockIndex{..} ->
 284                 S.modify $ \s -> s{keys_index=
 285                         Map.insert pos terms $ keys_index s}
 286          BlockFigure{..} ->
 287                 S.modify $ \s -> s{keys_figure=
 288                         Map.insertWith (<>)
 289                          type_ (Map.singleton pos mayTitle) $
 290                         keys_figure s}
 291          BlockReferences{..} ->
 292                 S.modify $ \s -> s{keys_reference=
 293                         foldr
 294                          (\r -> Map.insert
 295                                  (DTC.id    (r::DTC.Reference))
 296                                  (DTC.about (r::DTC.Reference)))
 297                          (keys_reference s)
 298                          refs}
 299
 300 -- * Class 'Html5ify'
 301 class Html5ify a where
 302         html5ify :: a -> Html5
 303 instance Html5ify H.Markup where
 304         html5ify = Compose . return
 305 instance Html5ify Char where
 306         html5ify = html5ify . H.toMarkup
 307 instance Html5ify Text where
 308         html5ify = html5ify . H.toMarkup
 309 instance Html5ify TL.Text where
 310         html5ify = html5ify . H.toMarkup
 311 instance Html5ify String where
 312         html5ify = html5ify . H.toMarkup
 313 instance Html5ify Title where
 314         html5ify (Title t) = html5ify t
 315 instance Html5ify Ident where
 316         html5ify (Ident i) = html5ify i
 317 instance Html5ify Int where
 318         html5ify = html5ify . show
 319 instance Html5ify Nat where
 320         html5ify (Nat n) = html5ify n
 321 instance Html5ify Nat1 where
 322         html5ify (Nat1 n) = html5ify n
 323 instance Html5ify a => Html5ify (Maybe a) where
 324         html5ify = foldMap html5ify
 325
 326 -- * Type 'BodyCursor'
 327 -- | Cursor to navigate within a 'Body' according to many axis (like in XSLT).
 328 type BodyCursor = Tree.Zipper BodyNode
 329 instance Html5ify Body where
 330         html5ify body =
 331                 forM_ (Tree.zippers body) $ \z ->
 332                         forM_ (Tree.axis_repeat Tree.axis_following_sibling_nearest `Tree.runAxis` z) $
 333                                 html5ify
 334 instance Html5ify BodyCursor
 335  where html5ify z =
 336         let Tree n _ts = Tree.current z in
 337         case n of
 338          BodyBlock BlockToC{..} -> do
 339                 H.nav ! HA.class_ "toc"
 340                       ! HA.id (attrify pos) $$ do
 341                         H.span ! HA.class_ "toc-name" $$
 342                                 H.a ! HA.href (attrify pos) $$ do
 343                                         Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 344                                         Plain.l10n_Table_of_Contents loc
 345                         H.ul $$
 346                                 forM_ (Tree.axis_following_sibling `Tree.runAxis` z) $
 347                                         html5ifyToC depth
 348          BodyBlock b -> html5ify b
 349          BodySection{..} -> do
 350                 do
 351                         notes <- liftStateMarkup $ S.gets state_notes
 352                         let mayNotes = do
 353                                 p <- posParent $ posAncestors pos
 354                                 let (ns, as) = Map.updateLookupWithKey (\_ _ -> Nothing) p notes
 355                                 (,as) <$> ns
 356                         case mayNotes of
 357                          Nothing -> mempty
 358                          Just (secNotes, state_notes) -> do
 359                                 liftStateMarkup $ S.modify' $ \s -> s{state_notes}
 360                                 html5ify secNotes
 361                 H.section ! HA.class_ "section"
 362                           ! HA.id (attrify pos) $$ do
 363                         forM_ aliases html5ify
 364                         html5CommonAttrs attrs{classes="section-header":classes attrs} $
 365                                 H.table $$
 366                                         H.tbody $$
 367                                                 H.tr $$ do
 368                                                         H.td ! HA.class_ "section-number" $$ do
 369                                                                 html5SectionNumber $ DTC.posAncestors pos
 370                                                         H.td ! HA.class_ "section-title" $$ do
 371                                                                 (case List.length $ DTC.posAncestors pos of
 372                                                                  0 -> H.h1
 373                                                                  1 -> H.h2
 374                                                                  2 -> H.h3
 375                                                                  3 -> H.h4
 376                                                                  4 -> H.h5
 377                                                                  5 -> H.h6
 378                                                                  _ -> H.h6) $$
 379                                                                         html5ify title
 380                         forM_ (Tree.axis_child `Tree.runAxis` z) $
 381                                 html5ify
 382                         notes <- liftStateMarkup $ S.gets state_notes
 383                         html5ify $ Map.lookup (posAncestors pos) notes
 384 instance Html5ify [Anchor.Note] where
 385         html5ify notes =
 386                 H.aside ! HA.class_ "notes" $$ do
 387                         Compose $ pure H.hr
 388                         H.table $$
 389                                 H.tbody $$
 390                                         forM_ (List.reverse notes) $ \Anchor.Note{..} ->
 391                                                 H.tr $$ do
 392                                                         H.td ! HA.class_ "note-ref" $$ do
 393                                                                 H.a ! HA.class_ "note-number"
 394                                                                     ! HA.id   ("note."<>attrify note_number)
 395                                                                     ! HA.href ("#note."<>attrify note_number) $$ do
 396                                                                         html5ify note_number
 397                                                                 ". "::Html5
 398                                                                 H.a ! HA.href ("#note-ref."<>attrify note_number) $$ do
 399                                                                         "↑"
 400                                                         H.td $$
 401                                                                 html5ify note_content
 402 instance Html5ify Block where
 403         html5ify = \case
 404          BlockPara para -> html5ify para
 405          BlockToC{..} -> mempty -- NOTE: done in Html5ify BodyCursor
 406          BlockToF{..} -> do
 407                 H.nav ! HA.class_ "tof"
 408                       ! HA.id (attrify pos) $$
 409                         H.table ! HA.class_ "tof" $$
 410                                 H.tbody $$
 411                                         html5ifyToF types
 412          BlockFigure{..} ->
 413                 html5CommonAttrs attrs
 414                  { classes = "figure":("figure-"<>type_):classes attrs
 415                  , DTC.id  = Just $ Ident $ Plain.text def $ DTC.posAncestors pos
 416                  } $
 417                 H.div $$ do
 418                         H.table ! HA.class_ "figure-caption" $$
 419                                 H.tbody $$
 420                                         H.tr $$ do
 421                                                 if TL.null type_
 422                                                  then H.a ! HA.href ("#"<>attrify pos) $$ mempty
 423                                                  else
 424                                                         H.td ! HA.class_ "figure-number" $$ do
 425                                                                 H.a ! HA.href ("#"<>attrify (DTC.posAncestorsWithFigureNames pos)) $$ do
 426                                                                         html5ify type_
 427                                                                         html5ify $ DTC.posAncestorsWithFigureNames pos
 428                                                 forM_ mayTitle $ \title -> do
 429                                                         H.td ! HA.class_ "figure-colon" $$ do
 430                                                                 unless (TL.null type_) $ do
 431                                                                         Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 432                                                                         Plain.l10n_Colon loc
 433                                                         H.td ! HA.class_ "figure-title" $$ do
 434                                                                 html5ify title
 435                         H.div ! HA.class_ "figure-content" $$ do
 436                                 html5ify paras
 437          BlockIndex{pos} -> do
 438                 (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . state_indexs
 439                 let chars = Anchor.termsByChar allTerms
 440                 H.div ! HA.class_ "index"
 441                       ! HA.id (attrify pos) $$ do
 442                         H.nav ! HA.class_ "index-nav" $$ do
 443                                 forM_ (Map.keys chars) $ \char ->
 444                                         H.a ! HA.href ("#"<>(attrify pos <> "." <> attrify char)) $$
 445                                                 html5ify char
 446                         H.dl ! HA.class_ "index-chars" $$
 447                                 forM_ (Map.toList chars) $ \(char,terms) -> do
 448                                         H.dt $$
 449                                                 let i = attrify pos <> "." <> attrify char in
 450                                                 H.a ! HA.id i
 451                                                     ! HA.href ("#"<>i) $$
 452                                                         html5ify char
 453                                         H.dd $$
 454                                                 H.dl ! HA.class_ "index-term" $$ do
 455                                                 forM_ terms $ \aliases -> do
 456                                                         H.dt $$
 457                                                                 H.ul ! HA.class_ "index-aliases" $$
 458                                                                         forM_ (List.take 1 aliases) $ \term ->
 459                                                                                 H.li ! HA.id (attrifyIref term) $$
 460                                                                                         html5ify term
 461                                                         H.dd $$
 462                                                                 let anchs =
 463                                                                         List.sortBy (compare `on` DTC.section . snd) $
 464                                                                         (`foldMap` aliases) $ \words ->
 465                                                                                 fromJust $ do
 466                                                                                         path <- Anchor.pathFromWords words
 467                                                                                         Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $
 468                                                                                                 TreeMap.lookup path refsByTerm in
 469                                                                 html5CommasDot $
 470                                                                 (<$> anchs) $ \(term,DTC.Anchor{..}) ->
 471                                                                         H.a ! HA.class_ "index-iref"
 472                                                                             ! HA.href ("#"<>attrifyIrefCount term count) $$
 473                                                                                 html5ify $ DTC.posAncestors section
 474          BlockReferences{..} ->
 475                 html5CommonAttrs attrs
 476                  { classes = "references":classes attrs
 477                  , DTC.id  = Just $ Ident $ Plain.text def $ DTC.posAncestors pos
 478                  } $
 479                 H.div $$ do
 480                         H.table $$
 481                                 forM_ refs html5ify
 482
 483 html5ifyToC :: Maybe DTC.Nat -> BodyCursor -> Html5
 484 html5ifyToC depth z =
 485         let Tree n _ts = Tree.current z in
 486         case n of
 487          BodySection{..} -> do
 488                 H.li $$ do
 489                         H.table ! HA.class_ "toc-entry" $$
 490                                 H.tbody $$
 491                                         H.tr $$ do
 492                                                 H.td ! HA.class_ "section-number" $$
 493                                                         html5SectionRef $ DTC.posAncestors pos
 494                                                 H.td ! HA.class_ "section-title" $$
 495                                                         html5ify $ cleanPlain $ unTitle title
 496                         when (maybe True (> Nat 1) depth && not (null sections)) $
 497                                 H.ul $$
 498                                         forM_ sections $
 499                                                 html5ifyToC (depth >>= predNat)
 500          _ -> pure ()
 501         where
 502         sections =
 503                 (`Tree.runAxis` z) $
 504                 Tree.axis_child
 505                 `Tree.axis_filter_current` \case
 506                  Tree BodySection{} _ -> True
 507                  _ -> False
 508
 509 html5ifyToF :: [TL.Text] -> Html5
 510 html5ifyToF types = do
 511         figsByType <- liftStateMarkup $ S.gets state_figures
 512         let figs =
 513                 Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
 514                 if null types
 515                 then figsByType
 516                 else
 517                         Map.intersection figsByType $
 518                         Map.fromList [(ty,()) | ty <- types]
 519         forM_ (Map.toList figs) $ \(pos, (type_, title)) ->
 520                 H.tr $$ do
 521                         H.td ! HA.class_ "figure-number" $$
 522                                 H.a ! HA.href ("#"<>attrify pos) $$ do
 523                                         html5ify type_
 524                                         html5ify $ DTC.posAncestors pos
 525                         forM_ title $ \ti ->
 526                                 H.td ! HA.class_ "figure-title" $$
 527                                         html5ify $ cleanPlain $ unTitle ti
 528
 529 cleanPlain :: Plain -> Plain
 530 cleanPlain ps =
 531         ps >>= \case
 532          Tree PlainIref{} ls -> cleanPlain ls
 533          Tree PlainNote{} _  -> mempty
 534          Tree n ts -> pure $ Tree n $ cleanPlain ts
 535
 536 instance Html5ify Para where
 537         html5ify = \case
 538          ParaItem{..} ->
 539                 html5CommonAttrs def
 540                  { classes="para":cls item
 541                  } $
 542                         html5ify item
 543          ParaItems{..} ->
 544                 html5CommonAttrs attrs
 545                  { classes = "para":classes attrs
 546                  , DTC.id  = id_ pos
 547                  } $
 548                 H.div $$
 549                         forM_ items $ \item ->
 550                                 html5AttrClass (cls item) $
 551                                 html5ify item
 552          where
 553                 id_ = Just . Ident . Plain.text def . DTC.posAncestors
 554                 cls = \case
 555                  ParaPlain{}     -> []
 556                  ParaArtwork{..} -> ["artwork", "artwork-"<>type_]
 557                  ParaQuote{..}   -> ["quote", "quote-"<>type_]
 558                  ParaComment{}   -> []
 559                  ParaOL{}        -> ["ol"]
 560                  ParaUL{}        -> ["ul"]
 561 instance Html5ify ParaItem where
 562         html5ify = \case
 563          ParaPlain p -> H.p $$ html5ify p
 564          ParaArtwork{..} -> H.pre $$ do html5ify text
 565          ParaQuote{..} -> H.div $$ do html5ify paras
 566          ParaComment t -> html5ify $ H.Comment (H.String $ TL.unpack t) ()
 567          ParaOL items ->
 568                 H.table $$ do
 569                         H.tbody $$
 570                                 forM_ items $ \ListItem{..} -> do
 571                                         H.tr $$ do
 572                                                 H.td ! HA.class_ "name" $$ do
 573                                                         html5ify name
 574                                                         "."::Html5
 575                                                 H.td ! HA.class_ "value" $$
 576                                                         html5ify paras
 577          ParaUL items ->
 578                 H.dl $$ do
 579                         forM_ items $ \item -> do
 580                                 H.dt $$ "—"
 581                                 H.dd $$ html5ify item
 582 instance Html5ify [Para] where
 583         html5ify = mapM_ html5ify
 584
 585 instance Html5ify Plain where
 586         html5ify ps =
 587                 case Seq.viewl ps of
 588                  Seq.EmptyL -> mempty
 589                  curr Seq.:< next ->
 590                         case curr of
 591                         -- NOTE: gather adjacent PlainNotes
 592                          Tree PlainNote{} _
 593                           | (notes, rest) <- Seq.spanl (\case {Tree PlainNote{} _ -> True; _ -> False}) next -> do
 594                                 H.sup ! HA.class_ "note-numbers" $$ do
 595                                         html5ify curr
 596                                         forM_ notes $ \note -> do
 597                                                 ", "::Html5
 598                                                 html5ify note
 599                                 " "::Html5
 600                                 html5ify rest
 601                         --
 602                          _ -> do
 603                                 html5ify curr
 604                                 html5ify next
 605 instance Html5ify (Tree PlainNode)
 606  where html5ify (Tree n ls) =
 607         case n of
 608          PlainBR     -> html5ify H.br
 609          PlainText t -> html5ify t
 610          PlainGroup  -> html5ify ls
 611          PlainB      -> H.strong $$ html5ify ls
 612          PlainCode   -> H.code   $$ html5ify ls
 613          PlainDel    -> H.del    $$ html5ify ls
 614          PlainI -> do
 615                 i <- liftStateMarkup $ do
 616                         i <- S.gets $ Plain.state_italic . state_plainify
 617                         S.modify $ \s ->
 618                                 s{state_plainify=
 619                                         (state_plainify s){Plain.state_italic=
 620                                                 not i}}
 621                         return i
 622                 H.em ! HA.class_ (if i then "even" else "odd") $$
 623                         html5ify ls
 624                 liftStateMarkup $
 625                         S.modify $ \s ->
 626                                 s{state_plainify=
 627                                         (state_plainify s){Plain.state_italic=i}}
 628          PlainSub  -> H.sub    $$ html5ify ls
 629          PlainSup  -> H.sup    $$ html5ify ls
 630          PlainSC   -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
 631          PlainU    -> H.span ! HA.class_ "underline" $$ html5ify ls
 632          PlainNote{..} ->
 633                 case number of
 634                  Nothing -> mempty
 635                  Just num ->
 636                         H.a ! HA.class_ "note-ref"
 637                             ! HA.id ("note-ref."<>attrify num)
 638                             ! HA.href ("#note."<>attrify num) $$
 639                                 html5ify num
 640          PlainQ -> do
 641                 H.span ! HA.class_ "q" $$ do
 642                         Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 643                         Plain.l10n_Quote (html5ify $ Tree PlainI ls) loc
 644          PlainEref{..} ->
 645                 H.a ! HA.class_ "eref"
 646                     ! HA.href (attrify href) $$
 647                         if null ls
 648                         then html5ify $ unURL href
 649                         else html5ify ls
 650          PlainIref{..} ->
 651                 case anchor of
 652                  Nothing -> html5ify ls
 653                  Just Anchor{..} ->
 654                         H.span ! HA.class_ "iref"
 655                                ! HA.id (attrifyIrefCount term count) $$
 656                                 html5ify ls
 657          PlainRef{..} ->
 658                 H.a ! HA.class_ "ref"
 659                     ! HA.href ("#"<>attrify to) $$
 660                 if null ls
 661                 then html5ify to
 662                 else html5ify ls
 663          PlainRref{..} -> do
 664                 refs <- liftStateMarkup $ S.gets state_references
 665                 case Map.lookup to refs of
 666                  Nothing -> do
 667                         "["::Html5
 668                         H.span ! HA.class_ "rref-broken" $$
 669                                 html5ify to
 670                         "]"
 671                  Just About{..} -> do
 672                         unless (null ls) $
 673                                 forM_ (List.take 1 titles) $ \(Title title) -> do
 674                                         html5ify $ Tree PlainQ $
 675                                                 case url of
 676                                                  Nothing -> title
 677                                                  Just u -> pure $ Tree (PlainEref u) title
 678                                         " "::Html5
 679                         "["::Html5
 680                         H.a ! HA.class_ "rref"
 681                             ! HA.href ("#rref."<>attrify to)
 682                             ! HA.id ("rref."<>attrify to<>maybe "" (\Anchor{..} -> "."<>attrify count) anchor) $$
 683                                 html5ify to
 684                         "]"
 685
 686 instance Html5ify [Title] where
 687         html5ify =
 688                 html5ify . fold . List.intersperse sep . toList
 689                 where sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
 690 instance Html5ify About where
 691         html5ify About{..} =
 692                 html5CommasDot $ concat $
 693                  [ html5Titles titles
 694                  , html5ify <$> authors
 695                  , html5ify <$> maybeToList date
 696                  , html5ify <$> maybeToList editor
 697                  , html5ify <$> series
 698                  ]
 699                 where
 700                 html5Titles :: [Title] -> [Html5]
 701                 html5Titles ts | null ts = []
 702                 html5Titles ts = [html5Title $ joinTitles ts]
 703                         where
 704                         joinTitles = fold . List.intersperse sep . toList
 705                         sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
 706                 html5Title (Title title) =
 707                         html5ify $ Tree PlainQ $
 708                                 case url of
 709                                  Nothing -> title
 710                                  Just u -> pure $ Tree (PlainEref u) title
 711 instance Html5ify Serie where
 712         html5ify s@Serie{id=id_, name} = do
 713                 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 714                 case urlSerie s of
 715                  Nothing -> do
 716                         html5ify name
 717                         Plain.l10n_Colon loc :: Html5
 718                         html5ify id_
 719                  Just href -> do
 720                         html5ify $
 721                                 Tree PlainEref{href} $
 722                                 Seq.fromList
 723                                  [ tree0 $ PlainText $ name
 724                                  , tree0 $ PlainText $ Plain.l10n_Colon loc
 725                                  , tree0 $ PlainText id_
 726                                  ]
 727 instance Html5ify Entity where
 728         html5ify Entity{..} = do
 729                 html5ify $
 730                         case () of
 731                          _ | not (TL.null email) ->
 732                                 Tree (PlainEref $ URL $ "mailto:"<>email) $
 733                                         pure $ tree0 $ PlainText name
 734                          _ | Just u <- url ->
 735                                 Tree (PlainEref u) $
 736                                         pure $ tree0 $ PlainText name
 737                          _ -> tree0 $ PlainText name
 738                 forM_ org $ \o -> do
 739                         " ("::Html5
 740                         html5ify o
 741                         ")"::Html5
 742 instance Html5ify Words where
 743         html5ify = html5ify . Anchor.plainifyWords
 744 instance Html5ify Alias where
 745         html5ify Alias{id=id_, ..} = do
 746                 H.a ! HA.class_ "alias"
 747                     ! HA.id (attrify id_) $$
 748                         mempty
 749 instance Html5ify URL where
 750         html5ify (URL url) =
 751                 H.a ! HA.class_ "eref"
 752                     ! HA.href (attrify url) $$
 753                         html5ify url
 754 instance Html5ify Date where
 755         html5ify date = do
 756                 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 757                 Plain.l10n_Date date loc
 758 instance Html5ify Reference where
 759         html5ify Reference{id=id_, ..} =
 760                 H.tr $$ do
 761                         H.td ! HA.class_ "reference-key" $$
 762                                 html5ify $ Tree PlainRref{anchor=Nothing, to=id_} Seq.empty
 763                         H.td ! HA.class_ "reference-content" $$ do
 764                                 html5ify about
 765                                 rrefs <- liftStateMarkup $ S.gets state_rrefs
 766                                 case Map.lookup id_ rrefs of
 767                                  Nothing -> pure ()
 768                                  Just anchs ->
 769                                         H.span ! HA.class_ "reference-rrefs" $$
 770                                                 html5CommasDot $
 771                                                 (<$> List.reverse anchs) $ \Anchor{..} ->
 772                                                         H.a ! HA.class_ "reference-rref"
 773                                                             ! HA.href ("#rref."<>attrify id_<>"."<>attrify count) $$
 774                                                                 html5ify $ DTC.posAncestors section
 775 instance Html5ify PosPath where
 776         html5ify ancs =
 777                 case toList ancs of
 778                  [(_n,c)] -> do
 779                         html5ify $ show c
 780                         html5ify '.'
 781                  as ->
 782                         html5ify $
 783                                 Text.intercalate "." $
 784                                 Text.pack . show . snd <$> as
 785 instance Html5ify Plain.Plain where
 786         html5ify p = do
 787                 sp <- liftStateMarkup $ S.gets state_plainify
 788                 let (t,sp') = Plain.runPlain p sp
 789                 html5ify t
 790                 liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'}
 791
 792 html5CommasDot :: [Html5] -> Html5
 793 html5CommasDot [] = pure ()
 794 html5CommasDot hs = do
 795         sequence_ $ List.intersperse ", " hs
 796         "."
 797
 798 html5AttrClass :: [TL.Text] -> Html5 -> Html5
 799 html5AttrClass = \case
 800  [] -> Cat.id
 801  cls  ->
 802         Compose .
 803         (H.AddCustomAttribute "class"
 804          (H.String $ TL.unpack $ TL.unwords cls) <$>) .
 805         getCompose
 806
 807 html5AttrId :: Ident -> Html5 -> Html5
 808 html5AttrId (Ident id_) =
 809         Compose .
 810         (H.AddCustomAttribute "id"
 811          (H.String $ TL.unpack id_) <$>) .
 812         getCompose
 813
 814 html5CommonAttrs :: CommonAttrs -> Html5 -> Html5
 815 html5CommonAttrs CommonAttrs{id=id_, ..} =
 816         html5AttrClass classes .
 817         maybe Cat.id html5AttrId id_
 818
 819 html5SectionNumber :: PosPath -> Html5
 820 html5SectionNumber = go mempty
 821         where
 822         go :: PosPath -> PosPath -> Html5
 823         go prev next =
 824                 case Seq.viewl next of
 825                  Seq.EmptyL -> pure ()
 826                  a@(_n,rank) Seq.:< as -> do
 827                         H.a ! HA.href ("#"<>attrify (prev Seq.|>a)) $$
 828                                 html5ify $ show rank
 829                         when (not (null as) || null prev) $ do
 830                                 html5ify '.'
 831                                 go (prev Seq.|>a) as
 832
 833 html5SectionRef :: PosPath -> Html5
 834 html5SectionRef as =
 835         H.a ! HA.href ("#"<>attrify as) $$
 836                 html5ify as
 837
 838 -- * 'Attrify'
 839 instance Attrify Anchor where
 840         attrify Anchor{..} = attrify section <> "." <> attrify count
 841 instance Attrify Plain.Plain where
 842         attrify p = attrify t
 843                 where (t,_) = Plain.runPlain p def
 844 instance Attrify PosPath where
 845         attrify = attrify . plainify
 846 instance Attrify DTC.Pos where
 847         attrify = attrify . DTC.posAncestors
 848
 849 attrifyIref :: Words -> H.AttributeValue
 850 attrifyIref term =
 851         "iref" <> "." <> attrify (Anchor.plainifyWords term)
 852 attrifyIrefCount :: Words -> Nat1 -> H.AttributeValue
 853 attrifyIrefCount term count =
 854         "iref"
 855          <> "." <> attrify (Anchor.plainifyWords term)
 856          <> "." <> attrify count
 857
 858 -- * Class 'L10n'
 859 class
 860  ( Plain.L10n msg lang
 861  , Plain.L10n TL.Text lang
 862  ) => L10n msg lang where
 863         l10n_Header_Address :: FullLocale lang -> msg
 864         l10n_Header_Date    :: FullLocale lang -> msg
 865         l10n_Header_Version :: FullLocale lang -> msg
 866         l10n_Header_Origin  :: FullLocale lang -> msg
 867         l10n_Header_Source  :: FullLocale lang -> msg
 868 instance L10n Html5 EN where
 869         l10n_Header_Address _loc = "Address"
 870         l10n_Header_Date    _loc = "Date"
 871         l10n_Header_Origin  _loc = "Origin"
 872         l10n_Header_Source  _loc = "Source"
 873         l10n_Header_Version _loc = "Version"
 874 instance L10n Html5 FR where
 875         l10n_Header_Address _loc = "Adresse"
 876         l10n_Header_Date    _loc = "Date"
 877         l10n_Header_Origin  _loc = "Origine"
 878         l10n_Header_Source  _loc = "Source"
 879         l10n_Header_Version _loc = "Version"
 880
 881 instance Plain.L10n Html5 EN where
 882         l10n_Colon             loc = html5ify (Plain.l10n_Colon loc :: TL.Text)
 883         l10n_Table_of_Contents loc = html5ify (Plain.l10n_Table_of_Contents loc :: TL.Text)
 884         l10n_Date date         loc = html5ify (Plain.l10n_Date date loc :: TL.Text)
 885         l10n_Quote msg _loc = do
 886                 depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
 887                 let (o,c) :: (Html5, Html5) =
 888                         case unNat depth `mod` 3 of
 889                          0 -> ("“","”")
 890                          1 -> ("« "," »")
 891                          _ -> ("‟","„")
 892                 o
 893                 setDepth $ succNat depth
 894                 msg
 895                 setDepth $ depth
 896                 c
 897                 where
 898                 setDepth d =
 899                         liftStateMarkup $ S.modify' $ \s ->
 900                                 s{state_plainify=(state_plainify s){Plain.state_quote=d}}
 901 instance Plain.L10n Html5 FR where
 902         l10n_Colon             loc = html5ify (Plain.l10n_Colon loc :: TL.Text)
 903         l10n_Table_of_Contents loc = html5ify (Plain.l10n_Table_of_Contents loc :: TL.Text)
 904         l10n_Date date         loc = html5ify (Plain.l10n_Date date loc :: TL.Text)
 905         l10n_Quote msg _loc = do
 906                 depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
 907                 let (o,c) :: (Html5, Html5) =
 908                         case unNat depth `mod` 3 of
 909                          0 -> ("« "," »")
 910                          1 -> ("“","”")
 911                          _ -> ("‟","„")
 912                 o
 913                 setDepth $ succNat depth
 914                 msg
 915                 setDepth $ depth
 916                 c
 917                 where
 918                 setDepth d =
 919                         liftStateMarkup $ S.modify' $ \s ->
 920                                 s{state_plainify=(state_plainify s){Plain.state_quote=d}}