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