Language/DTC/Write/HTML5.hs

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