Language/DTC/Write/HTML5.hs

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