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          BlockBreak{} -> return ()
 282          BlockToC{}   -> return ()
 283          BlockToF{}   -> return ()
 284          BlockIndex{..} ->
 285                 S.modify $ \s -> s{keys_index=
 286                         Map.insert pos terms $ keys_index s}
 287          BlockFigure{..} ->
 288                 S.modify $ \s -> s{keys_figure=
 289                         Map.insertWith (<>)
 290                          type_ (Map.singleton pos mayTitle) $
 291                         keys_figure s}
 292          BlockReferences{..} ->
 293                 S.modify $ \s -> s{keys_reference=
 294                         foldr
 295                          (\r -> Map.insert
 296                                  (DTC.id    (r::DTC.Reference))
 297                                  (DTC.about (r::DTC.Reference)))
 298                          (keys_reference s)
 299                          refs}
 300
 301 -- * Class 'Html5ify'
 302 class Html5ify a where
 303         html5ify :: a -> Html5
 304 instance Html5ify H.Markup where
 305         html5ify = Compose . return
 306 instance Html5ify Char where
 307         html5ify = html5ify . H.toMarkup
 308 instance Html5ify Text where
 309         html5ify = html5ify . H.toMarkup
 310 instance Html5ify TL.Text where
 311         html5ify = html5ify . H.toMarkup
 312 instance Html5ify String where
 313         html5ify = html5ify . H.toMarkup
 314 instance Html5ify Title where
 315         html5ify (Title t) = html5ify t
 316 instance Html5ify Ident where
 317         html5ify (Ident i) = html5ify i
 318 instance Html5ify Int where
 319         html5ify = html5ify . show
 320 instance Html5ify Nat where
 321         html5ify (Nat n) = html5ify n
 322 instance Html5ify Nat1 where
 323         html5ify (Nat1 n) = html5ify n
 324 instance Html5ify a => Html5ify (Maybe a) where
 325         html5ify = foldMap html5ify
 326
 327 -- * Type 'BodyCursor'
 328 -- | Cursor to navigate within a 'Body' according to many axis (like in XSLT).
 329 type BodyCursor = Tree.Zipper BodyNode
 330 instance Html5ify Body where
 331         html5ify body =
 332                 forM_ (Tree.zippers body) $ \z ->
 333                         forM_ (Tree.axis_repeat Tree.axis_following_sibling_nearest `Tree.runAxis` z) $
 334                                 html5ify
 335 instance Html5ify BodyCursor
 336  where html5ify z =
 337         let Tree n _ts = Tree.current z in
 338         case n of
 339          BodyBlock BlockToC{..} -> do
 340                 H.nav ! HA.class_ "toc"
 341                       ! HA.id (attrify pos) $$ do
 342                         H.span ! HA.class_ "toc-name" $$
 343                                 H.a ! HA.href ("#"<>attrify pos) $$ do
 344                                         Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 345                                         Plain.l10n_Table_of_Contents loc
 346                         H.ul $$
 347                                 forM_ (Tree.axis_following_sibling `Tree.runAxis` z) $
 348                                         html5ifyToC depth
 349          BodyBlock b -> html5ify b
 350          BodySection{..} -> do
 351                 do
 352                         notes <- liftStateMarkup $ S.gets state_notes
 353                         let mayNotes = do
 354                                 p <- posParent $ posAncestors pos
 355                                 let (ns, as) = Map.updateLookupWithKey (\_ _ -> Nothing) p notes
 356                                 (,as) <$> ns
 357                         case mayNotes of
 358                          Nothing -> mempty
 359                          Just (secNotes, state_notes) -> do
 360                                 liftStateMarkup $ S.modify' $ \s -> s{state_notes}
 361                                 html5ify secNotes
 362                 html5CommonAttrs attrs{classes="section":classes attrs} $
 363                         H.section ! HA.id (attrify pos) $$ do
 364                                 forM_ aliases html5ify
 365                                 H.table ! HA.class_ "section-header" $$
 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          BlockBreak{..} ->
 406                 html5CommonAttrs attrs
 407                  { classes = "page-break":"print-only":classes attrs } $
 408                 H.div $$
 409                         H.p $$ " " -- NOTE: force page break
 410          BlockToC{..} -> mempty -- NOTE: done in Html5ify BodyCursor
 411          BlockToF{..} -> do
 412                 H.nav ! HA.class_ "tof"
 413                       ! HA.id (attrify pos) $$
 414                         H.table ! HA.class_ "tof" $$
 415                                 H.tbody $$
 416                                         html5ifyToF types
 417          BlockFigure{..} ->
 418                 html5CommonAttrs attrs
 419                  { classes = "figure":("figure-"<>type_):classes attrs
 420                  , DTC.id  = Just $ Ident $ Plain.text def $ DTC.posAncestors pos
 421                  } $
 422                 H.div $$ do
 423                         H.table ! HA.class_ "figure-caption" $$
 424                                 H.tbody $$
 425                                         H.tr $$ do
 426                                                 if TL.null type_
 427                                                  then H.a ! HA.href ("#"<>attrify pos) $$ mempty
 428                                                  else
 429                                                         H.td ! HA.class_ "figure-number" $$ do
 430                                                                 H.a ! HA.href ("#"<>attrify (DTC.posAncestorsWithFigureNames pos)) $$ do
 431                                                                         html5ify type_
 432                                                                         html5ify $ DTC.posAncestorsWithFigureNames pos
 433                                                 forM_ mayTitle $ \title -> do
 434                                                         H.td ! HA.class_ "figure-colon" $$ do
 435                                                                 unless (TL.null type_) $ do
 436                                                                         Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 437                                                                         Plain.l10n_Colon loc
 438                                                         H.td ! HA.class_ "figure-title" $$ do
 439                                                                 html5ify title
 440                         H.div ! HA.class_ "figure-content" $$ do
 441                                 html5ify paras
 442          BlockIndex{pos} -> do
 443                 (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . state_indexs
 444                 let chars = Anchor.termsByChar allTerms
 445                 H.div ! HA.class_ "index"
 446                       ! HA.id (attrify pos) $$ do
 447                         H.nav ! HA.class_ "index-nav" $$ do
 448                                 forM_ (Map.keys chars) $ \char ->
 449                                         H.a ! HA.href ("#"<>(attrify pos <> "." <> attrify char)) $$
 450                                                 html5ify char
 451                         H.dl ! HA.class_ "index-chars" $$
 452                                 forM_ (Map.toList chars) $ \(char,terms) -> do
 453                                         H.dt $$
 454                                                 let i = attrify pos <> "." <> attrify char in
 455                                                 H.a ! HA.id i
 456                                                     ! HA.href ("#"<>i) $$
 457                                                         html5ify char
 458                                         H.dd $$
 459                                                 H.dl ! HA.class_ "index-term" $$ do
 460                                                 forM_ terms $ \aliases -> do
 461                                                         H.dt $$
 462                                                                 H.ul ! HA.class_ "index-aliases" $$
 463                                                                         forM_ (List.take 1 aliases) $ \term ->
 464                                                                                 H.li ! HA.id (attrifyIref term) $$
 465                                                                                         html5ify term
 466                                                         H.dd $$
 467                                                                 let anchs =
 468                                                                         List.sortBy (compare `on` DTC.section . snd) $
 469                                                                         (`foldMap` aliases) $ \words ->
 470                                                                                 fromJust $ do
 471                                                                                         path <- Anchor.pathFromWords words
 472                                                                                         Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $
 473                                                                                                 TreeMap.lookup path refsByTerm in
 474                                                                 html5CommasDot $
 475                                                                 (<$> anchs) $ \(term,DTC.Anchor{..}) ->
 476                                                                         H.a ! HA.class_ "index-iref"
 477                                                                             ! HA.href ("#"<>attrifyIrefCount term count) $$
 478                                                                                 html5ify $ DTC.posAncestors section
 479          BlockReferences{..} ->
 480                 html5CommonAttrs attrs
 481                  { classes = "references":classes attrs
 482                  , DTC.id  = Just $ Ident $ Plain.text def $ DTC.posAncestors pos
 483                  } $
 484                 H.div $$ do
 485                         H.table $$
 486                                 forM_ refs html5ify
 487
 488 html5ifyToC :: Maybe DTC.Nat -> BodyCursor -> Html5
 489 html5ifyToC depth z =
 490         let Tree n _ts = Tree.current z in
 491         case n of
 492          BodySection{..} -> do
 493                 H.li $$ do
 494                         H.table ! HA.class_ "toc-entry" $$
 495                                 H.tbody $$
 496                                         H.tr $$ do
 497                                                 H.td ! HA.class_ "section-number" $$
 498                                                         html5SectionRef $ DTC.posAncestors pos
 499                                                 H.td ! HA.class_ "section-title" $$
 500                                                         html5ify $ cleanPlain $ unTitle title
 501                         when (maybe True (> Nat 1) depth && not (null sections)) $
 502                                 H.ul $$
 503                                         forM_ sections $
 504                                                 html5ifyToC (depth >>= predNat)
 505          _ -> pure ()
 506         where
 507         sections =
 508                 (`Tree.runAxis` z) $
 509                 Tree.axis_child
 510                 `Tree.axis_filter_current` \case
 511                  Tree BodySection{} _ -> True
 512                  _ -> False
 513
 514 html5ifyToF :: [TL.Text] -> Html5
 515 html5ifyToF types = do
 516         figsByType <- liftStateMarkup $ S.gets state_figures
 517         let figs =
 518                 Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
 519                 if null types
 520                 then figsByType
 521                 else
 522                         Map.intersection figsByType $
 523                         Map.fromList [(ty,()) | ty <- types]
 524         forM_ (Map.toList figs) $ \(pos, (type_, title)) ->
 525                 H.tr $$ do
 526                         H.td ! HA.class_ "figure-number" $$
 527                                 H.a ! HA.href ("#"<>attrify pos) $$ do
 528                                         html5ify type_
 529                                         html5ify $ DTC.posAncestors pos
 530                         forM_ title $ \ti ->
 531                                 H.td ! HA.class_ "figure-title" $$
 532                                         html5ify $ cleanPlain $ unTitle ti
 533
 534 cleanPlain :: Plain -> Plain
 535 cleanPlain ps =
 536         ps >>= \case
 537          Tree PlainIref{} ls -> cleanPlain ls
 538          Tree PlainNote{} _  -> mempty
 539          Tree n ts -> pure $ Tree n $ cleanPlain ts
 540
 541 instance Html5ify Para where
 542         html5ify = \case
 543          ParaItem{..} ->
 544                 html5CommonAttrs def
 545                  { classes="para":cls item
 546                  } $
 547                         html5ify item
 548          ParaItems{..} ->
 549                 html5CommonAttrs attrs
 550                  { classes = "para":classes attrs
 551                  , DTC.id  = id_ pos
 552                  } $
 553                 H.div $$
 554                         forM_ items $ \item ->
 555                                 html5AttrClass (cls item) $
 556                                 html5ify item
 557          where
 558                 id_ = Just . Ident . Plain.text def . DTC.posAncestors
 559                 cls = \case
 560                  ParaPlain{}     -> []
 561                  ParaArtwork{..} -> ["artwork", "artwork-"<>type_]
 562                  ParaQuote{..}   -> ["quote", "quote-"<>type_]
 563                  ParaComment{}   -> []
 564                  ParaOL{}        -> ["ol"]
 565                  ParaUL{}        -> ["ul"]
 566 instance Html5ify ParaItem where
 567         html5ify = \case
 568          ParaPlain p -> H.p $$ html5ify p
 569          ParaArtwork{..} -> H.pre $$ do html5ify text
 570          ParaQuote{..} -> H.div $$ do html5ify paras
 571          ParaComment t -> html5ify $ H.Comment (H.String $ TL.unpack t) ()
 572          ParaOL items ->
 573                 H.table $$ do
 574                         H.tbody $$
 575                                 forM_ items $ \ListItem{..} -> do
 576                                         H.tr $$ do
 577                                                 H.td ! HA.class_ "name" $$ do
 578                                                         html5ify name
 579                                                         "."::Html5
 580                                                 H.td ! HA.class_ "value" $$
 581                                                         html5ify paras
 582          ParaUL items ->
 583                 H.dl $$ do
 584                         forM_ items $ \item -> do
 585                                 H.dt $$ "—"
 586                                 H.dd $$ html5ify item
 587 instance Html5ify [Para] where
 588         html5ify = mapM_ html5ify
 589
 590 instance Html5ify Plain where
 591         html5ify ps =
 592                 case Seq.viewl ps of
 593                  Seq.EmptyL -> mempty
 594                  curr Seq.:< next ->
 595                         case curr of
 596                         -- NOTE: gather adjacent PlainNotes
 597                          Tree PlainNote{} _
 598                           | (notes, rest) <- Seq.spanl (\case {Tree PlainNote{} _ -> True; _ -> False}) next -> do
 599                                 H.sup ! HA.class_ "note-numbers" $$ do
 600                                         html5ify curr
 601                                         forM_ notes $ \note -> do
 602                                                 ", "::Html5
 603                                                 html5ify note
 604                                 " "::Html5
 605                                 html5ify rest
 606                         --
 607                          _ -> do
 608                                 html5ify curr
 609                                 html5ify next
 610 instance Html5ify (Tree PlainNode)
 611  where html5ify (Tree n ls) =
 612         case n of
 613          PlainBreak  -> html5ify H.br
 614          PlainText t -> html5ify t
 615          PlainGroup  -> html5ify ls
 616          PlainB      -> H.strong $$ html5ify ls
 617          PlainCode   -> H.code   $$ html5ify ls
 618          PlainDel    -> H.del    $$ html5ify ls
 619          PlainI -> do
 620                 i <- liftStateMarkup $ do
 621                         i <- S.gets $ Plain.state_italic . state_plainify
 622                         S.modify $ \s ->
 623                                 s{state_plainify=
 624                                         (state_plainify s){Plain.state_italic=
 625                                                 not i}}
 626                         return i
 627                 H.em ! HA.class_ (if i then "even" else "odd") $$
 628                         html5ify ls
 629                 liftStateMarkup $
 630                         S.modify $ \s ->
 631                                 s{state_plainify=
 632                                         (state_plainify s){Plain.state_italic=i}}
 633          PlainSub  -> H.sub    $$ html5ify ls
 634          PlainSup  -> H.sup    $$ html5ify ls
 635          PlainSC   -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
 636          PlainU    -> H.span ! HA.class_ "underline" $$ html5ify ls
 637          PlainNote{..} ->
 638                 case number of
 639                  Nothing -> mempty
 640                  Just num ->
 641                         H.a ! HA.class_ "note-ref"
 642                             ! HA.id ("note-ref."<>attrify num)
 643                             ! HA.href ("#note."<>attrify num) $$
 644                                 html5ify num
 645          PlainQ -> do
 646                 H.span ! HA.class_ "q" $$ do
 647                         Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 648                         Plain.l10n_Quote (html5ify $ Tree PlainI ls) loc
 649          PlainEref{..} ->
 650                 H.a ! HA.class_ "eref"
 651                     ! HA.href (attrify href) $$
 652                         if null ls
 653                         then html5ify $ unURL href
 654                         else html5ify ls
 655          PlainIref{..} ->
 656                 case anchor of
 657                  Nothing -> html5ify ls
 658                  Just Anchor{..} ->
 659                         H.span ! HA.class_ "iref"
 660                                ! HA.id (attrifyIrefCount term count) $$
 661                                 html5ify ls
 662          PlainRef{..} ->
 663                 H.a ! HA.class_ "ref"
 664                     ! HA.href ("#"<>attrify to) $$
 665                 if null ls
 666                 then html5ify to
 667                 else html5ify ls
 668          PlainRref{..} -> do
 669                 refs <- liftStateMarkup $ S.gets state_references
 670                 case Map.lookup to refs of
 671                  Nothing -> do
 672                         "["::Html5
 673                         H.span ! HA.class_ "rref-broken" $$
 674                                 html5ify to
 675                         "]"
 676                  Just About{..} -> do
 677                         unless (null ls) $
 678                                 forM_ (List.take 1 titles) $ \(Title title) -> do
 679                                         html5ify $ Tree PlainQ $
 680                                                 case url of
 681                                                  Nothing -> title
 682                                                  Just u -> pure $ Tree (PlainEref u) title
 683                                         " "::Html5
 684                         "["::Html5
 685                         H.a ! HA.class_ "rref"
 686                             ! HA.href ("#rref."<>attrify to)
 687                             ! HA.id ("rref."<>attrify to<>maybe "" (\Anchor{..} -> "."<>attrify count) anchor) $$
 688                                 html5ify to
 689                         "]"
 690
 691 instance Html5ify [Title] where
 692         html5ify =
 693                 html5ify . fold . List.intersperse sep . toList
 694                 where sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
 695 instance Html5ify About where
 696         html5ify About{..} =
 697                 html5CommasDot $ concat $
 698                  [ html5Titles titles
 699                  , html5ify <$> authors
 700                  , html5ify <$> maybeToList date
 701                  , html5ify <$> maybeToList editor
 702                  , html5ify <$> series
 703                  ]
 704                 where
 705                 html5Titles :: [Title] -> [Html5]
 706                 html5Titles ts | null ts = []
 707                 html5Titles ts = [html5Title $ joinTitles ts]
 708                         where
 709                         joinTitles = fold . List.intersperse sep . toList
 710                         sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
 711                 html5Title (Title title) =
 712                         html5ify $ Tree PlainQ $
 713                                 case url of
 714                                  Nothing -> title
 715                                  Just u -> pure $ Tree (PlainEref u) title
 716 instance Html5ify Serie where
 717         html5ify s@Serie{id=id_, name} = do
 718                 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 719                 case urlSerie s of
 720                  Nothing -> do
 721                         html5ify name
 722                         Plain.l10n_Colon loc :: Html5
 723                         html5ify id_
 724                  Just href -> do
 725                         html5ify $
 726                                 Tree PlainEref{href} $
 727                                 Seq.fromList
 728                                  [ tree0 $ PlainText $ name
 729                                  , tree0 $ PlainText $ Plain.l10n_Colon loc
 730                                  , tree0 $ PlainText id_
 731                                  ]
 732 instance Html5ify Entity where
 733         html5ify Entity{..} = do
 734                 html5ify $
 735                         case () of
 736                          _ | not (TL.null email) ->
 737                                 Tree (PlainEref $ URL $ "mailto:"<>email) $
 738                                         pure $ tree0 $ PlainText name
 739                          _ | Just u <- url ->
 740                                 Tree (PlainEref u) $
 741                                         pure $ tree0 $ PlainText name
 742                          _ -> tree0 $ PlainText name
 743                 forM_ org $ \o -> do
 744                         " ("::Html5
 745                         html5ify o
 746                         ")"::Html5
 747 instance Html5ify Words where
 748         html5ify = html5ify . Anchor.plainifyWords
 749 instance Html5ify Alias where
 750         html5ify Alias{id=id_, ..} = do
 751                 H.a ! HA.class_ "alias"
 752                     ! HA.id (attrify id_) $$
 753                         mempty
 754 instance Html5ify URL where
 755         html5ify (URL url) =
 756                 H.a ! HA.class_ "eref"
 757                     ! HA.href (attrify url) $$
 758                         html5ify url
 759 instance Html5ify Date where
 760         html5ify date = do
 761                 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 762                 Plain.l10n_Date date loc
 763 instance Html5ify Reference where
 764         html5ify Reference{id=id_, ..} =
 765                 H.tr $$ do
 766                         H.td ! HA.class_ "reference-key" $$
 767                                 html5ify $ Tree PlainRref{anchor=Nothing, to=id_} Seq.empty
 768                         H.td ! HA.class_ "reference-content" $$ do
 769                                 html5ify about
 770                                 rrefs <- liftStateMarkup $ S.gets state_rrefs
 771                                 case Map.lookup id_ rrefs of
 772                                  Nothing -> pure ()
 773                                  Just anchs ->
 774                                         H.span ! HA.class_ "reference-rrefs" $$
 775                                                 html5CommasDot $
 776                                                 (<$> List.reverse anchs) $ \Anchor{..} ->
 777                                                         H.a ! HA.class_ "reference-rref"
 778                                                             ! HA.href ("#rref."<>attrify id_<>"."<>attrify count) $$
 779                                                                 html5ify $ DTC.posAncestors section
 780 instance Html5ify PosPath where
 781         html5ify ancs =
 782                 case toList ancs of
 783                  [(_n,c)] -> do
 784                         html5ify $ show c
 785                         html5ify '.'
 786                  as ->
 787                         html5ify $
 788                                 Text.intercalate "." $
 789                                 Text.pack . show . snd <$> as
 790 instance Html5ify Plain.Plain where
 791         html5ify p = do
 792                 sp <- liftStateMarkup $ S.gets state_plainify
 793                 let (t,sp') = Plain.runPlain p sp
 794                 html5ify t
 795                 liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'}
 796
 797 html5CommasDot :: [Html5] -> Html5
 798 html5CommasDot [] = pure ()
 799 html5CommasDot hs = do
 800         sequence_ $ List.intersperse ", " hs
 801         "."
 802
 803 html5AttrClass :: [TL.Text] -> Html5 -> Html5
 804 html5AttrClass = \case
 805  [] -> Cat.id
 806  cls  ->
 807         Compose .
 808         (H.AddCustomAttribute "class"
 809          (H.String $ TL.unpack $ TL.unwords cls) <$>) .
 810         getCompose
 811
 812 html5AttrId :: Ident -> Html5 -> Html5
 813 html5AttrId (Ident id_) =
 814         Compose .
 815         (H.AddCustomAttribute "id"
 816          (H.String $ TL.unpack id_) <$>) .
 817         getCompose
 818
 819 html5CommonAttrs :: CommonAttrs -> Html5 -> Html5
 820 html5CommonAttrs CommonAttrs{id=id_, ..} =
 821         html5AttrClass classes .
 822         maybe Cat.id html5AttrId id_
 823
 824 html5SectionNumber :: PosPath -> Html5
 825 html5SectionNumber = go mempty
 826         where
 827         go :: PosPath -> PosPath -> Html5
 828         go prev next =
 829                 case Seq.viewl next of
 830                  Seq.EmptyL -> pure ()
 831                  a@(_n,rank) Seq.:< as -> do
 832                         H.a ! HA.href ("#"<>attrify (prev Seq.|>a)) $$
 833                                 html5ify $ show rank
 834                         when (not (null as) || null prev) $ do
 835                                 html5ify '.'
 836                                 go (prev Seq.|>a) as
 837
 838 html5SectionRef :: PosPath -> Html5
 839 html5SectionRef as =
 840         H.a ! HA.href ("#"<>attrify as) $$
 841                 html5ify as
 842
 843 -- * 'Attrify'
 844 instance Attrify Anchor where
 845         attrify Anchor{..} = attrify section <> "." <> attrify count
 846 instance Attrify Plain.Plain where
 847         attrify p = attrify t
 848                 where (t,_) = Plain.runPlain p def
 849 instance Attrify PosPath where
 850         attrify = attrify . plainify
 851 instance Attrify DTC.Pos where
 852         attrify = attrify . DTC.posAncestors
 853
 854 attrifyIref :: Words -> H.AttributeValue
 855 attrifyIref term =
 856         "iref" <> "." <> attrify (Anchor.plainifyWords term)
 857 attrifyIrefCount :: Words -> Nat1 -> H.AttributeValue
 858 attrifyIrefCount term count =
 859         "iref"
 860          <> "." <> attrify (Anchor.plainifyWords term)
 861          <> "." <> attrify count
 862
 863 -- * Class 'L10n'
 864 class
 865  ( Plain.L10n msg lang
 866  , Plain.L10n TL.Text lang
 867  ) => L10n msg lang where
 868         l10n_Header_Address :: FullLocale lang -> msg
 869         l10n_Header_Date    :: FullLocale lang -> msg
 870         l10n_Header_Version :: FullLocale lang -> msg
 871         l10n_Header_Origin  :: FullLocale lang -> msg
 872         l10n_Header_Source  :: FullLocale lang -> msg
 873 instance L10n Html5 EN where
 874         l10n_Header_Address _loc = "Address"
 875         l10n_Header_Date    _loc = "Date"
 876         l10n_Header_Origin  _loc = "Origin"
 877         l10n_Header_Source  _loc = "Source"
 878         l10n_Header_Version _loc = "Version"
 879 instance L10n Html5 FR where
 880         l10n_Header_Address _loc = "Adresse"
 881         l10n_Header_Date    _loc = "Date"
 882         l10n_Header_Origin  _loc = "Origine"
 883         l10n_Header_Source  _loc = "Source"
 884         l10n_Header_Version _loc = "Version"
 885
 886 instance Plain.L10n Html5 EN where
 887         l10n_Colon             loc = html5ify (Plain.l10n_Colon loc :: TL.Text)
 888         l10n_Table_of_Contents loc = html5ify (Plain.l10n_Table_of_Contents loc :: TL.Text)
 889         l10n_Date date         loc = html5ify (Plain.l10n_Date date loc :: TL.Text)
 890         l10n_Quote msg _loc = do
 891                 depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
 892                 let (o,c) :: (Html5, Html5) =
 893                         case unNat depth `mod` 3 of
 894                          0 -> ("“","”")
 895                          1 -> ("« "," »")
 896                          _ -> ("‟","„")
 897                 o
 898                 setDepth $ succNat depth
 899                 msg
 900                 setDepth $ depth
 901                 c
 902                 where
 903                 setDepth d =
 904                         liftStateMarkup $ S.modify' $ \s ->
 905                                 s{state_plainify=(state_plainify s){Plain.state_quote=d}}
 906 instance Plain.L10n Html5 FR where
 907         l10n_Colon             loc = html5ify (Plain.l10n_Colon loc :: TL.Text)
 908         l10n_Table_of_Contents loc = html5ify (Plain.l10n_Table_of_Contents loc :: TL.Text)
 909         l10n_Date date         loc = html5ify (Plain.l10n_Date date loc :: TL.Text)
 910         l10n_Quote msg _loc = do
 911                 depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
 912                 let (o,c) :: (Html5, Html5) =
 913                         case unNat depth `mod` 3 of
 914                          0 -> ("« "," »")
 915                          1 -> ("“","”")
 916                          _ -> ("‟","„")
 917                 o
 918                 setDepth $ succNat depth
 919                 msg
 920                 setDepth $ depth
 921                 c
 922                 where
 923                 setDepth d =
 924                         liftStateMarkup $ S.modify' $ \s ->
 925                                 s{state_plainify=(state_plainify s){Plain.state_quote=d}}