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          PlainSub  -> H.sub    $$ html5ify ls
 639          PlainSup  -> H.sup    $$ html5ify ls
 640          PlainSC   -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
 641          PlainU    -> H.span ! HA.class_ "underline" $$ html5ify ls
 642          PlainNote{..} ->
 643                 case number of
 644                  Nothing -> mempty
 645                  Just num ->
 646                         H.a ! HA.class_ "note-ref"
 647                             ! HA.id ("note-ref."<>attrify num)
 648                             ! HA.href ("#note."<>attrify num) $$
 649                                 html5ify num
 650          PlainQ -> do
 651                 H.span ! HA.class_ "q" $$ do
 652                         Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 653                         Plain.l10n_Quote (html5ify $ Tree PlainI ls) loc
 654          PlainEref{..} ->
 655                 H.a ! HA.class_ "eref"
 656                     ! HA.href (attrify href) $$
 657                         if null ls
 658                         then html5ify $ unURL href
 659                         else html5ify ls
 660          PlainIref{..} ->
 661                 case anchor of
 662                  Nothing -> html5ify ls
 663                  Just Anchor{..} ->
 664                         H.span ! HA.class_ "iref"
 665                                ! HA.id (attrifyIrefCount term count) $$
 666                                 html5ify ls
 667          PlainRef{..} ->
 668                 H.a ! HA.class_ "ref"
 669                     ! HA.href ("#"<>attrify to) $$
 670                 if null ls
 671                 then html5ify to
 672                 else html5ify ls
 673          PlainRref{..} -> do
 674                 refs <- liftStateMarkup $ S.gets state_references
 675                 case Map.lookup to refs of
 676                  Nothing -> do
 677                         "["::Html5
 678                         H.span ! HA.class_ "rref-broken" $$
 679                                 html5ify to
 680                         "]"
 681                  Just About{..} -> do
 682                         unless (null ls) $
 683                                 forM_ (List.take 1 titles) $ \(Title title) -> do
 684                                         html5ify $ Tree PlainQ $
 685                                                 case url of
 686                                                  Nothing -> title
 687                                                  Just u -> pure $ Tree (PlainEref u) title
 688                                         " "::Html5
 689                         "["::Html5
 690                         H.a ! HA.class_ "rref"
 691                             ! HA.href ("#rref."<>attrify to)
 692                             ! HA.id ("rref."<>attrify to<>maybe "" (\Anchor{..} -> "."<>attrify count) anchor) $$
 693                                 html5ify to
 694                         "]"
 695
 696 instance Html5ify [Title] where
 697         html5ify =
 698                 html5ify . fold . List.intersperse sep . toList
 699                 where sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
 700 instance Html5ify About where
 701         html5ify About{..} =
 702                 html5CommasDot $ concat $
 703                  [ html5Titles titles
 704                  , html5ify <$> authors
 705                  , html5ify <$> maybeToList date
 706                  , html5ify <$> maybeToList editor
 707                  , html5ify <$> series
 708                  ]
 709                 where
 710                 html5Titles :: [Title] -> [Html5]
 711                 html5Titles ts | null ts = []
 712                 html5Titles ts = [html5Title $ joinTitles ts]
 713                         where
 714                         joinTitles = fold . List.intersperse sep . toList
 715                         sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
 716                 html5Title (Title title) =
 717                         html5ify $ Tree PlainQ $
 718                                 case url of
 719                                  Nothing -> title
 720                                  Just u -> pure $ Tree (PlainEref u) title
 721 instance Html5ify Serie where
 722         html5ify s@Serie{id=id_, name} = do
 723                 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 724                 case urlSerie s of
 725                  Nothing -> do
 726                         html5ify name
 727                         Plain.l10n_Colon loc :: Html5
 728                         html5ify id_
 729                  Just href -> do
 730                         html5ify $
 731                                 Tree PlainEref{href} $
 732                                 Seq.fromList
 733                                  [ tree0 $ PlainText $ name
 734                                  , tree0 $ PlainText $ Plain.l10n_Colon loc
 735                                  , tree0 $ PlainText id_
 736                                  ]
 737 instance Html5ify Entity where
 738         html5ify Entity{..} = do
 739                 html5ify $
 740                         case () of
 741                          _ | not (TL.null email) ->
 742                                 Tree (PlainEref $ URL $ "mailto:"<>email) $
 743                                         pure $ tree0 $ PlainText name
 744                          _ | Just u <- url ->
 745                                 Tree (PlainEref u) $
 746                                         pure $ tree0 $ PlainText name
 747                          _ -> tree0 $ PlainText name
 748                 forM_ org $ \o -> do
 749                         " ("::Html5
 750                         html5ify o
 751                         ")"::Html5
 752 instance Html5ify Words where
 753         html5ify = html5ify . Anchor.plainifyWords
 754 instance Html5ify Alias where
 755         html5ify Alias{id=id_, ..} = do
 756                 H.a ! HA.class_ "alias"
 757                     ! HA.id (attrify id_) $$
 758                         mempty
 759 instance Html5ify URL where
 760         html5ify (URL url) =
 761                 H.a ! HA.class_ "eref"
 762                     ! HA.href (attrify url) $$
 763                         html5ify url
 764 instance Html5ify Date where
 765         html5ify date = do
 766                 Loqualization loc <- liftStateMarkup $ S.gets state_l10n
 767                 Plain.l10n_Date date loc
 768 instance Html5ify Reference where
 769         html5ify Reference{id=id_, ..} =
 770                 H.tr $$ do
 771                         H.td ! HA.class_ "reference-key" $$
 772                                 html5ify $ Tree PlainRref{anchor=Nothing, to=id_} Seq.empty
 773                         H.td ! HA.class_ "reference-content" $$ do
 774                                 html5ify about
 775                                 rrefs <- liftStateMarkup $ S.gets state_rrefs
 776                                 case Map.lookup id_ rrefs of
 777                                  Nothing -> pure ()
 778                                  Just anchs ->
 779                                         H.span ! HA.class_ "reference-rrefs" $$
 780                                                 html5CommasDot $
 781                                                 (<$> List.reverse anchs) $ \Anchor{..} ->
 782                                                         H.a ! HA.class_ "reference-rref"
 783                                                             ! HA.href ("#rref."<>attrify id_<>"."<>attrify count) $$
 784                                                                 html5ify $ DTC.posAncestors section
 785 instance Html5ify PosPath where
 786         html5ify ancs =
 787                 case toList ancs of
 788                  [(_n,c)] -> do
 789                         html5ify $ show c
 790                         html5ify '.'
 791                  as ->
 792                         html5ify $
 793                                 Text.intercalate "." $
 794                                 Text.pack . show . snd <$> as
 795 instance Html5ify Plain.Plain where
 796         html5ify p = do
 797                 sp <- liftStateMarkup $ S.gets state_plainify
 798                 let (t,sp') = Plain.runPlain p sp
 799                 html5ify t
 800                 liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'}
 801
 802 html5CommasDot :: [Html5] -> Html5
 803 html5CommasDot [] = pure ()
 804 html5CommasDot hs = do
 805         sequence_ $ List.intersperse ", " hs
 806         "."
 807
 808 html5AttrClass :: [TL.Text] -> Html5 -> Html5
 809 html5AttrClass = \case
 810  [] -> Cat.id
 811  cls  ->
 812         Compose .
 813         (H.AddCustomAttribute "class"
 814          (H.String $ TL.unpack $ TL.unwords cls) <$>) .
 815         getCompose
 816
 817 html5AttrId :: Ident -> Html5 -> Html5
 818 html5AttrId (Ident id_) =
 819         Compose .
 820         (H.AddCustomAttribute "id"
 821          (H.String $ TL.unpack id_) <$>) .
 822         getCompose
 823
 824 html5CommonAttrs :: CommonAttrs -> Html5 -> Html5
 825 html5CommonAttrs CommonAttrs{id=id_, ..} =
 826         html5AttrClass classes .
 827         maybe Cat.id html5AttrId id_
 828
 829 html5SectionNumber :: PosPath -> Html5
 830 html5SectionNumber = go mempty
 831         where
 832         go :: PosPath -> PosPath -> Html5
 833         go prev next =
 834                 case Seq.viewl next of
 835                  Seq.EmptyL -> pure ()
 836                  a@(_n,rank) Seq.:< as -> do
 837                         H.a ! HA.href ("#"<>attrify (prev Seq.|>a)) $$
 838                                 html5ify $ show rank
 839                         when (not (null as) || null prev) $ do
 840                                 html5ify '.'
 841                                 go (prev Seq.|>a) as
 842
 843 html5SectionRef :: PosPath -> Html5
 844 html5SectionRef as =
 845         H.a ! HA.href ("#"<>attrify as) $$
 846                 html5ify as
 847
 848 -- * 'Attrify'
 849 instance Attrify Anchor where
 850         attrify Anchor{..} = attrify section <> "." <> attrify count
 851 instance Attrify Plain.Plain where
 852         attrify p = attrify t
 853                 where (t,_) = Plain.runPlain p def
 854 instance Attrify PosPath where
 855         attrify = attrify . plainify
 856 instance Attrify DTC.Pos where
 857         attrify = attrify . DTC.posAncestors
 858
 859 attrifyIref :: Words -> H.AttributeValue
 860 attrifyIref term =
 861         "iref" <> "." <> attrify (Anchor.plainifyWords term)
 862 attrifyIrefCount :: Words -> Nat1 -> H.AttributeValue
 863 attrifyIrefCount term count =
 864         "iref"
 865          <> "." <> attrify (Anchor.plainifyWords term)
 866          <> "." <> attrify count
 867
 868 -- * Class 'L10n'
 869 class
 870  ( Plain.L10n msg lang
 871  , Plain.L10n TL.Text lang
 872  ) => L10n msg lang where
 873         l10n_Header_Address :: FullLocale lang -> msg
 874         l10n_Header_Date    :: FullLocale lang -> msg
 875         l10n_Header_Version :: FullLocale lang -> msg
 876         l10n_Header_Origin  :: FullLocale lang -> msg
 877         l10n_Header_Source  :: FullLocale lang -> msg
 878 instance L10n Html5 EN where
 879         l10n_Header_Address _loc = "Address"
 880         l10n_Header_Date    _loc = "Date"
 881         l10n_Header_Origin  _loc = "Origin"
 882         l10n_Header_Source  _loc = "Source"
 883         l10n_Header_Version _loc = "Version"
 884 instance L10n Html5 FR where
 885         l10n_Header_Address _loc = "Adresse"
 886         l10n_Header_Date    _loc = "Date"
 887         l10n_Header_Origin  _loc = "Origine"
 888         l10n_Header_Source  _loc = "Source"
 889         l10n_Header_Version _loc = "Version"
 890
 891 instance Plain.L10n Html5 EN where
 892         l10n_Colon             loc = html5ify (Plain.l10n_Colon loc :: TL.Text)
 893         l10n_Table_of_Contents loc = html5ify (Plain.l10n_Table_of_Contents loc :: TL.Text)
 894         l10n_Date date         loc = html5ify (Plain.l10n_Date date loc :: TL.Text)
 895         l10n_Quote msg _loc = do
 896                 depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
 897                 let (o,c) :: (Html5, Html5) =
 898                         case unNat depth `mod` 3 of
 899                          0 -> ("“","”")
 900                          1 -> ("« "," »")
 901                          _ -> ("‟","„")
 902                 o
 903                 setDepth $ succNat depth
 904                 msg
 905                 setDepth $ depth
 906                 c
 907                 where
 908                 setDepth d =
 909                         liftStateMarkup $ S.modify' $ \s ->
 910                                 s{state_plainify=(state_plainify s){Plain.state_quote=d}}
 911 instance Plain.L10n Html5 FR where
 912         l10n_Colon             loc = html5ify (Plain.l10n_Colon loc :: TL.Text)
 913         l10n_Table_of_Contents loc = html5ify (Plain.l10n_Table_of_Contents loc :: TL.Text)
 914         l10n_Date date         loc = html5ify (Plain.l10n_Date date loc :: TL.Text)
 915         l10n_Quote msg _loc = do
 916                 depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
 917                 let (o,c) :: (Html5, Html5) =
 918                         case unNat depth `mod` 3 of
 919                          0 -> ("« "," »")
 920                          1 -> ("“","”")
 921                          _ -> ("‟","„")
 922                 o
 923                 setDepth $ succNat depth
 924                 msg
 925                 setDepth $ depth
 926                 c
 927                 where
 928                 setDepth d =
 929                         liftStateMarkup $ S.modify' $ \s ->
 930                                 s{state_plainify=(state_plainify s){Plain.state_quote=d}}