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