Language/DTC/Write/HTML5.hs

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