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