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
  13 import Control.Monad
  14 import Data.Bool
  15 import Data.Char (Char)
  16 import Data.Default.Class (Default(..))
  17 import Data.Foldable (Foldable(..), concat)
  18 import Data.Function (($), const, flip, on)
  19 import Data.Functor (Functor(..), (<$>))
  20 import Data.Functor.Compose (Compose(..))
  21 import Data.Int (Int)
  22 import Data.Map.Strict (Map)
  23 import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList)
  24 import Data.Monoid (Monoid(..))
  25 import Data.Ord (Ord(..))
  26 import Data.Semigroup (Semigroup(..))
  27 import Data.String (String, IsString(..))
  28 import Data.Text (Text)
  29 import Data.TreeSeq.Strict (Tree(..), tree0)
  30 import Data.Tuple (snd)
  31 import System.FilePath (FilePath)
  32 import Text.Blaze ((!))
  33 import Text.Blaze.Html (Html)
  34 import Text.Show (Show(..))
  35 import qualified Control.Monad.Trans.State as S
  36 import qualified Data.Char as Char
  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.Write.XML ()
  54 import Language.DTC.Write.Plain (Plain, Plainify(..))
  55 import qualified Language.DTC.Write.Plain as Plain
  56 import qualified Language.DTC.Document as DTC
  57 import qualified Language.DTC.Anchor as Anchor
  58
  59 (<&>) :: Functor f => f a -> (a -> b) -> f b
  60 (<&>) = flip (<$>)
  61 infixl 4 <&>
  62
  63 -- * Type 'Html5'
  64 type Html5 = StateMarkup State ()
  65 instance IsString Html5 where
  66         fromString = html5ify
  67
  68 -- * Type 'State'
  69 data State
  70  =   State
  71  {   state_styles     :: Map FilePath CSS
  72  ,   state_scripts    :: Map FilePath Script
  73  ,   state_indexs     :: Map DTC.Pos (DTC.Terms, Anchor.Irefs)
  74  ,   state_rrefs      :: Anchor.Rrefs
  75  ,   state_figures    :: Map TL.Text (Map DTC.Pos (Maybe DTC.Title))
  76  ,   state_references :: Map DTC.Ident DTC.About
  77  ,   state_notes      :: Anchor.Notes
  78  ,   state_plainify   :: Plain.State
  79  }
  80 instance Default State where
  81         def = State
  82          { state_styles     = mempty
  83          , state_scripts    = mempty
  84          , state_indexs     = mempty
  85          , state_rrefs      = mempty
  86          , state_figures    = mempty
  87          , state_references = mempty
  88          , state_notes      = mempty
  89          , state_plainify   = def
  90          }
  91 type CSS = Text
  92 type Script = Text
  93
  94 -- * Type 'Keys'
  95 data Keys
  96  = Keys
  97  { keys_index     :: Map DTC.Pos DTC.Terms
  98  , keys_figure    :: Map TL.Text (Map DTC.Pos (Maybe DTC.Title))
  99  , keys_reference :: Map DTC.Ident DTC.About
 100  } deriving (Show)
 101 instance Default Keys where
 102         def = Keys mempty mempty mempty
 103
 104 -- ** Class 'KeysOf'
 105 class KeysOf a where
 106         keys :: a -> S.State Keys ()
 107 instance KeysOf DTC.Body where
 108         keys = mapM_ keys
 109 instance KeysOf (Tree DTC.BodyNode) where
 110         keys (Tree n ts) =
 111                 case n of
 112                  DTC.Section{..} ->
 113                         keys ts
 114                  DTC.Index{..} ->
 115                         S.modify $ \s -> s{keys_index=
 116                                 Map.insert pos terms $ keys_index s}
 117                  DTC.Figure{..} ->
 118                         S.modify $ \s -> s{keys_figure=
 119                                 Map.insertWith (<>)
 120                                  type_ (Map.singleton pos mayTitle) $
 121                                 keys_figure s}
 122                  DTC.References{..} ->
 123                         S.modify $ \s -> s{keys_reference=
 124                                 foldr
 125                                  (\r -> Map.insert
 126                                          (DTC.id    (r::DTC.Reference))
 127                                          (DTC.about (r::DTC.Reference)))
 128                                  (keys_reference s)
 129                                  refs}
 130                  DTC.ToC{} -> return ()
 131                  DTC.ToF{} -> return ()
 132                  DTC.Block{} -> return ()
 133
 134 -- * Class 'Html5ify'
 135 class Html5ify a where
 136         html5ify :: a -> Html5
 137 instance Html5ify H.Markup where
 138         html5ify = Compose . return
 139 instance Html5ify Char where
 140         html5ify = html5ify . H.toMarkup
 141 instance Html5ify Text where
 142         html5ify = html5ify . H.toMarkup
 143 instance Html5ify TL.Text where
 144         html5ify = html5ify . H.toMarkup
 145 instance Html5ify String where
 146         html5ify = html5ify . H.toMarkup
 147 instance Html5ify DTC.Title where
 148         html5ify (DTC.Title t) = html5ify t
 149 instance Html5ify DTC.Para where
 150         html5ify = mapM_ html5ify
 151 instance Html5ify DTC.Ident where
 152         html5ify (DTC.Ident i) = html5ify i
 153 instance Html5ify Int where
 154         html5ify = html5ify . show
 155 instance Html5ify DTC.Nat where
 156         html5ify (DTC.Nat n) = html5ify n
 157 instance Html5ify DTC.Nat1 where
 158         html5ify (DTC.Nat1 n) = html5ify n
 159
 160 document ::
 161  Localize ls Plain Plain.L10n =>
 162  Locales ls =>
 163  LocaleIn ls -> DTC.Document -> Html
 164 document locale DTC.Document{..} = do
 165         let Keys{..} = keys body `S.execState` def
 166         let (body',state_rrefs,state_notes,state_indexs) =
 167                 let irefs = foldMap Anchor.irefsOfTerms keys_index in
 168                 let (body0, Anchor.State{state_irefs, state_rrefs=rrefs, state_notes=notes}) =
 169                         Anchor.anchorify body `S.runState`
 170                         def{Anchor.state_irefs=irefs} in
 171                 (body0,rrefs,notes,) $
 172                 (<$> keys_index) $ \terms ->
 173                         (terms,) $
 174                         TreeMap.intersection const state_irefs $
 175                         Anchor.irefsOfTerms terms
 176         let state_plainify = def
 177                 { Plain.state_localize = Locale.localize locale }
 178         let (html5Body, State{state_styles,state_scripts}) =
 179                 runStateMarkup def
 180                  { state_indexs
 181                  , state_rrefs
 182                  , state_notes
 183                  , state_figures    = keys_figure
 184                  , state_references = keys_reference
 185                  , state_plainify
 186                  } $ html5ify body'
 187
 188         H.docType
 189         H.html ! HA.lang (attrify $ countryCode locale) $ do
 190                 H.head $ do
 191                         H.meta ! HA.httpEquiv "Content-Type"
 192                                ! HA.content "text/html; charset=UTF-8"
 193                         whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts ->
 194                                 H.title $
 195                                         H.toMarkup $ Plain.text state_plainify $ List.head ts
 196                         forM_ (DTC.links $ DTC.about (head :: DTC.Head)) $ \DTC.Link{rel, href} ->
 197                                 H.link ! HA.rel (attrify rel)
 198                                        ! HA.href (attrify href)
 199                         H.meta ! HA.name "generator"
 200                                ! HA.content "https://hackage.haskell.org/package/hdoc"
 201                         let chapters =
 202                                 (`mapMaybe` toList body) $ \case
 203                                  Tree k@DTC.Section{} _ -> Just k
 204                                  _ -> Nothing
 205                         forM_ chapters $ \case
 206                          DTC.Section{..} ->
 207                                 H.link ! HA.rel "Chapter"
 208                                        ! HA.title (attrify $ plainify title)
 209                                        ! HA.href ("#"<>attrify pos)
 210                          _ -> mempty
 211                         H.link ! HA.rel "stylesheet"
 212                                ! HA.type_ "text/css"
 213                                ! HA.href "style/dtc-html5.css"
 214                         forM_ state_styles $ \style ->
 215                                 H.style ! HA.type_ "text/css" $
 216                                         H.toMarkup style
 217                         forM_ state_scripts $ \script ->
 218                                 H.script ! HA.type_ "application/javascript" $
 219                                         H.toMarkup script
 220                 H.body
 221                         html5Body
 222
 223 -- * Type 'BodyCursor'
 224 -- | Cursor to navigate within a 'DTC.Body' according to many axis (like in XSLT).
 225 type BodyCursor = Tree.Zipper DTC.BodyNode
 226 instance Html5ify DTC.Body where
 227         html5ify body =
 228                 forM_ (Tree.zippers body) $ \z ->
 229                         forM_ (Tree.axis_repeat Tree.axis_following_sibling_nearest `Tree.runAxis` z) $
 230                                 html5ify
 231 instance Html5ify BodyCursor
 232  where html5ify z =
 233         case Tree.current z of
 234          Tree k _ts ->
 235                 case k of
 236                  DTC.Section{..} ->
 237                         H.section ! HA.class_ "section"
 238                                   ! HA.id (attrify pos) $$ do
 239                                 forM_ aliases html5ify
 240                                 html5CommonAttrs attrs $
 241                                         H.table ! HA.class_ "section-header" $$
 242                                                 H.tbody $$
 243                                                         H.tr $$ do
 244                                                                 H.td ! HA.class_ "section-number" $$ do
 245                                                                         html5SectionNumber $ DTC.posAncestors pos
 246                                                                 H.td ! HA.class_ "section-title" $$ do
 247                                                                         (case List.length $ DTC.posAncestors pos of
 248                                                                          0 -> H.h1
 249                                                                          1 -> H.h2
 250                                                                          2 -> H.h3
 251                                                                          3 -> H.h4
 252                                                                          4 -> H.h5
 253                                                                          5 -> H.h6
 254                                                                          _ -> H.h6) $$
 255                                                                                 html5ify title
 256                                 forM_ (Tree.axis_child `Tree.runAxis` z) $
 257                                         html5ify
 258                                 notes <- liftStateMarkup $ S.gets state_notes
 259                                 case Map.lookup pos notes of
 260                                  Nothing -> return ()
 261                                  Just ns ->
 262                                         H.aside ! HA.class_ "notes" $$ do
 263                                                 Compose $ pure H.hr
 264                                                 H.table $$
 265                                                         H.tbody $$
 266                                                                 forM_ ns $ \(num,para) ->
 267                                                                         H.tr $$ do
 268                                                                                 H.td ! HA.class_ "note-ref" $$ do
 269                                                                                         H.a ! HA.class_ "note-number"
 270                                                                                             ! HA.id   ("note."<>attrify num)
 271                                                                                             ! HA.href ("#note."<>attrify num) $$ do
 272                                                                                                 html5ify num
 273                                                                                         ". "::Html5
 274                                                                                         H.a ! HA.href ("#note-ref."<>attrify num) $$ do
 275                                                                                                 "↑"
 276                                                                                 H.td $$
 277                                                                                         html5ify para
 278                  DTC.Block b -> html5ify b
 279                  DTC.ToC{..} -> do
 280                         H.nav ! HA.class_ "toc"
 281                               ! HA.id (attrify pos) $$ do
 282                                 H.span ! HA.class_ "toc-name" $$
 283                                         H.a ! HA.href (attrify pos) $$
 284                                                 html5ify Plain.L10n_Table_of_Contents
 285                                 H.ul $$
 286                                         forM_ (Tree.axis_following_sibling `Tree.runAxis` z) $
 287                                                 html5ifyToC depth
 288                  DTC.ToF{..} -> do
 289                         H.nav ! HA.class_ "tof"
 290                               ! HA.id (attrify pos) $$
 291                                 H.table ! HA.class_ "tof" $$
 292                                         H.tbody $$
 293                                                 html5ifyToF types
 294                  DTC.Figure{..} ->
 295                         html5CommonAttrs attrs $
 296                         H.div ! HA.class_ ("figure " <> attrify ("figure-"<>type_))
 297                               ! HA.id (attrify pos) $$ do
 298                                 H.table ! HA.class_ "figure-caption" $$
 299                                         H.tbody $$
 300                                                 H.tr $$ do
 301                                                         if TL.null type_
 302                                                          then H.a ! HA.href ("#"<>attrify pos) $$ mempty
 303                                                          else
 304                                                                 H.td ! HA.class_ "figure-number" $$ do
 305                                                                         H.a ! HA.href ("#"<>attrify pos) $$ do
 306                                                                                 html5ify type_
 307                                                                                 html5ify $ DTC.posAncestors pos
 308                                                         forM_ mayTitle $ \title ->
 309                                                                 H.td ! HA.class_ "figure-title" $$ do
 310                                                                         unless (TL.null type_) $
 311                                                                                 html5ify $ Plain.L10n_Colon
 312                                                                         html5ify title
 313                                 H.div ! HA.class_ "figure-content" $$ do
 314                                         html5ify blocks
 315                  DTC.Index{pos} -> do
 316                         (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . state_indexs
 317                         let chars = Anchor.termsByChar allTerms
 318                         H.div ! HA.class_ "index"
 319                               ! HA.id (attrify pos) $$ do
 320                                 H.nav ! HA.class_ "index-nav" $$ do
 321                                         forM_ (Map.keys chars) $ \char ->
 322                                                 H.a ! HA.href ("#"<>(attrify pos <> "." <> attrify char)) $$
 323                                                         html5ify char
 324                                 H.dl ! HA.class_ "index-chars" $$
 325                                         forM_ (Map.toList chars) $ \(char,terms) -> do
 326                                                 H.dt $$
 327                                                         let i = attrify pos <> "." <> attrify char in
 328                                                         H.a ! HA.id i
 329                                                             ! HA.href ("#"<>i) $$
 330                                                                 html5ify char
 331                                                 H.dd $$
 332                                                         H.dl ! HA.class_ "index-term" $$ do
 333                                                         forM_ terms $ \aliases -> do
 334                                                                 H.dt $$
 335                                                                         H.ul ! HA.class_ "index-aliases" $$
 336                                                                                 forM_ (List.take 1 aliases) $ \term ->
 337                                                                                         H.li ! HA.id (attrifyIref term) $$
 338                                                                                                 html5ify term
 339                                                                 H.dd $$
 340                                                                         let anchs =
 341                                                                                 List.sortBy (compare `on` DTC.section . snd) $
 342                                                                                 (`foldMap` aliases) $ \words ->
 343                                                                                         fromJust $ do
 344                                                                                                 path <- Anchor.pathFromWords words
 345                                                                                                 Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $
 346                                                                                                         TreeMap.lookup path refsByTerm in
 347                                                                         html5CommasDot $
 348                                                                         (<$> anchs) $ \(term,DTC.Anchor{..}) ->
 349                                                                                 H.a ! HA.class_ "index-iref"
 350                                                                                     ! HA.href ("#"<>attrifyIrefCount term count) $$
 351                                                                                         html5ify $ DTC.posAncestors section
 352                  DTC.References{..} ->
 353                         html5CommonAttrs attrs $
 354                         H.div ! HA.class_ "references"
 355                               ! HA.id (attrify pos) $$ do
 356                                 H.table $$
 357                                         forM_ refs html5ify
 358 instance Html5ify DTC.Words where
 359         html5ify = html5ify . Anchor.plainifyWords
 360 instance Html5ify DTC.Alias where
 361         html5ify DTC.Alias{id=id_, ..} = do
 362                 H.a ! HA.class_ "alias"
 363                     ! HA.id (attrify id_) $$
 364                         mempty
 365
 366 cleanPara :: DTC.Para -> DTC.Para
 367 cleanPara ps =
 368         ps >>= \case
 369          Tree DTC.Iref{} ls -> cleanPara ls
 370          Tree DTC.Note{} _  -> mempty
 371          Tree n ts  -> pure $ Tree n $ cleanPara ts
 372
 373 html5ifyToC :: Maybe DTC.Nat -> BodyCursor -> Html5
 374 html5ifyToC depth z =
 375         case Tree.current z of
 376          Tree DTC.Section{..} _ts -> do
 377                 H.li $$ do
 378                         H.table ! HA.class_ "toc-entry" $$
 379                                 H.tbody $$
 380                                         H.tr $$ do
 381                                                 H.td ! HA.class_ "section-number" $$
 382                                                         html5SectionRef $ DTC.posAncestors pos
 383                                                 H.td ! HA.class_ "section-title" $$
 384                                                         html5ify $ cleanPara $ DTC.unTitle title
 385                         when (maybe True (> DTC.Nat 1) depth && not (null sections)) $
 386                                 H.ul $$
 387                                         forM_ sections $
 388                                                 html5ifyToC (depth >>= DTC.predNat)
 389          _ -> pure ()
 390         where
 391         sections =
 392                 (`Tree.runAxis` z) $
 393                 Tree.axis_child
 394                 `Tree.axis_filter_current` \case
 395                  Tree DTC.Section{} _ -> True
 396                  _ -> False
 397
 398 html5ifyToF :: [TL.Text] -> Html5
 399 html5ifyToF types = do
 400         figsByType <- liftStateMarkup $ S.gets state_figures
 401         let figs =
 402                 Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
 403                 if null types
 404                 then figsByType
 405                 else
 406                         Map.intersection figsByType $
 407                         Map.fromList [(ty,()) | ty <- types]
 408         forM_ (Map.toList figs) $ \(pos, (type_, title)) ->
 409                 H.tr $$ do
 410                         H.td ! HA.class_ "figure-number" $$
 411                                 H.a ! HA.href ("#"<>attrify pos) $$ do
 412                                         html5ify type_
 413                                         html5ify $ DTC.posAncestors pos
 414                         forM_ title $ \ti ->
 415                                 H.td ! HA.class_ "figure-title" $$
 416                                         html5ify $ cleanPara $ DTC.unTitle ti
 417
 418 instance Html5ify [DTC.Block] where
 419         html5ify = mapM_ html5ify
 420 instance Html5ify DTC.Block where
 421         html5ify = \case
 422          DTC.Para{..} ->
 423                 html5CommonAttrs attrs $
 424                 H.p ! HA.class_ "para"
 425                     ! HA.id (attrify pos) $$ do
 426                         html5ify para
 427          DTC.OL{..} ->
 428                 html5CommonAttrs attrs $
 429                 H.ol ! HA.class_ "ol"
 430                      ! HA.id (attrify pos) $$ do
 431                         forM_ items $ \item ->
 432                                 H.li $$ html5ify item
 433          DTC.UL{..} ->
 434                 html5CommonAttrs attrs $
 435                 H.ul ! HA.class_ "ul"
 436                      ! HA.id (attrify pos) $$ do
 437                         forM_ items $ \item ->
 438                                 H.li $$ html5ify item
 439          DTC.Artwork{..} ->
 440                 html5CommonAttrs attrs $
 441                 H.pre ! HA.class_ ("artwork " <> attrify ("artwork-"<>type_))
 442                       ! HA.id (attrify pos) $$ do
 443                         html5ify text
 444          DTC.Quote{..} ->
 445                 html5CommonAttrs attrs $
 446                 H.div ! HA.class_ ("quote " <> attrify ("quote-"<>type_))
 447                       ! HA.id (attrify pos) $$ do
 448                         html5ify blocks
 449          DTC.Comment t ->
 450                 html5ify $ H.Comment (H.String $ TL.unpack t) ()
 451 instance Html5ify DTC.Lines where
 452         html5ify (Tree n ls) =
 453                 case n of
 454                  DTC.BR      -> html5ify H.br
 455                  DTC.Plain t -> html5ify t
 456                  DTC.B    -> H.strong $$ html5ify ls
 457                  DTC.Code -> H.code   $$ html5ify ls
 458                  DTC.Del  -> H.del    $$ html5ify ls
 459                  DTC.I    -> do
 460                         i <- liftStateMarkup $ do
 461                                 i <- S.gets $ Plain.state_italic . state_plainify
 462                                 S.modify $ \s ->
 463                                         s{state_plainify=
 464                                                 (state_plainify s){Plain.state_italic=
 465                                                         not i}}
 466                                 return i
 467                         H.em ! HA.class_ (if i then "even" else "odd") $$
 468                                 html5ify ls
 469                         liftStateMarkup $
 470                                 S.modify $ \s ->
 471                                         s{state_plainify=
 472                                                 (state_plainify s){Plain.state_italic=i}}
 473                  DTC.Sub  -> H.sub    $$ html5ify ls
 474                  DTC.Sup  -> H.sup    $$ html5ify ls
 475                  DTC.SC   -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
 476                  DTC.U    -> H.span ! HA.class_ "underline" $$ html5ify ls
 477                  DTC.Note{..} ->
 478                         case number of
 479                          Nothing -> ""
 480                          Just num ->
 481                                 H.sup ! HA.class_ "note-number" $$
 482                                         H.a ! HA.class_ "note-ref"
 483                                             ! HA.id ("note-ref."<>attrify num)
 484                                             ! HA.href ("#note."<>attrify num) $$
 485                                                 html5ify num
 486                  DTC.Q -> do
 487                         depth <- liftStateMarkup $ do
 488                                 depth <- S.gets $ Plain.state_quote . state_plainify
 489                                 S.modify $ \s -> s{state_plainify=
 490                                         (state_plainify s){Plain.state_quote=
 491                                                 DTC.succNat depth}}
 492                                 return depth
 493                         H.span ! HA.class_ "q" $$ do
 494                                 html5ify $ Plain.L10n_QuoteOpen depth
 495                                 html5ify $ Tree DTC.I ls
 496                                 html5ify $ Plain.L10n_QuoteClose depth
 497                         liftStateMarkup $
 498                                 S.modify $ \s ->
 499                                         s{state_plainify=
 500                                                 (state_plainify s){Plain.state_quote = depth}}
 501                  DTC.Eref{..} ->
 502                         H.a ! HA.class_ "eref"
 503                             ! HA.href (attrify href) $$
 504                                 if null ls
 505                                 then html5ify $ DTC.unURL href
 506                                 else html5ify ls
 507                  DTC.Iref{..} ->
 508                         case anchor of
 509                          Nothing -> html5ify ls
 510                          Just DTC.Anchor{..} ->
 511                                 H.span ! HA.class_ "iref"
 512                                        ! HA.id (attrifyIrefCount term count) $$
 513                                         html5ify ls
 514                  DTC.Ref{..} ->
 515                         H.a ! HA.class_ "ref"
 516                             ! HA.href ("#"<>attrify to) $$
 517                         if null ls
 518                         then html5ify to
 519                         else html5ify ls
 520                  DTC.Rref{..} -> do
 521                         refs <- liftStateMarkup $ S.gets state_references
 522                         case Map.lookup to refs of
 523                          Nothing -> do
 524                                 "["::Html5
 525                                 H.span ! HA.class_ "rref-broken" $$
 526                                         html5ify to
 527                                 "]"
 528                          Just DTC.About{..} -> do
 529                                 unless (null ls) $
 530                                         forM_ (List.take 1 titles) $ \(DTC.Title title) -> do
 531                                                 html5ify $ Tree DTC.Q $
 532                                                         case url of
 533                                                          Nothing -> title
 534                                                          Just u -> pure $ Tree (DTC.Eref u) title
 535                                                 " "::Html5
 536                                 "["::Html5
 537                                 H.a ! HA.class_ "rref"
 538                                     ! HA.href ("#rref."<>attrify to)
 539                                     ! HA.id ("rref."<>attrify to<>maybe "" (\DTC.Anchor{..} -> "."<>attrify count) anchor) $$
 540                                         html5ify to
 541                                 "]"
 542 instance Html5ify DTC.URL where
 543         html5ify (DTC.URL url) =
 544                 H.a ! HA.class_ "eref"
 545                     ! HA.href (attrify url) $$
 546                         html5ify url
 547 instance Html5ify DTC.Date where
 548         html5ify = html5ify . Plain.L10n_Date
 549 instance Html5ify DTC.About where
 550         html5ify DTC.About{..} =
 551                 html5CommasDot $ concat $
 552                  [ html5Titles titles
 553                  , html5Entity <$> authors
 554                  , html5ify    <$> maybeToList date
 555                  , html5Entity <$> maybeToList editor
 556                  , html5Serie  <$> series
 557                  ]
 558                 where
 559                 html5Titles :: [DTC.Title] -> [Html5]
 560                 html5Titles ts | null ts = []
 561                 html5Titles ts = [html5Title $ fold $ List.intersperse t $ toList ts]
 562                         where t = DTC.Title $ Seq.singleton $ tree0 $ DTC.Plain " — "
 563                 html5Title (DTC.Title title) =
 564                         html5ify $ Tree DTC.Q $
 565                                 case url of
 566                                  Nothing -> title
 567                                  Just u -> pure $ Tree (DTC.Eref u) title
 568                 html5SerieHref href DTC.Serie{..} = do
 569                         sp <- liftStateMarkup $ S.gets state_plainify
 570                         html5ify $
 571                                 Tree DTC.Eref{href} $
 572                                 Seq.fromList
 573                                  [ tree0 $ DTC.Plain $ name
 574                                  , tree0 $ DTC.Plain $ Plain.text sp Plain.L10n_Colon
 575                                  , tree0 $ DTC.Plain key
 576                                  ]
 577                 html5Serie s@DTC.Serie{name="RFC", key} | TL.all Char.isDigit key =
 578                         html5SerieHref (DTC.URL $ "https://tools.ietf.org/html/rfc"<>key) s
 579                 html5Serie s@DTC.Serie{name="DOI", key} =
 580                         html5SerieHref (DTC.URL $ "https://dx.doi.org/"<>key) s
 581                 html5Serie DTC.Serie{..} = do
 582                         html5ify name
 583                         html5ify Plain.L10n_Colon
 584                         html5ify key
 585                 html5Entity DTC.Entity{url=mu, ..} = do
 586                         html5ify @DTC.Lines $
 587                                 case () of
 588                                  _ | not (TL.null email) ->
 589                                         Tree (DTC.Eref $ DTC.URL $ "mailto:"<>email) $
 590                                                 pure $ tree0 $ DTC.Plain name
 591                                  _ | Just u <- mu  ->
 592                                         Tree (DTC.Eref u) $
 593                                                 pure $ tree0 $ DTC.Plain name
 594                                  _ -> tree0 $ DTC.Plain name
 595                         forM_ org $ \o -> do
 596                                 " ("::Html5
 597                                 html5Entity o
 598                                 ")"::Html5
 599 instance Html5ify DTC.Reference where
 600         html5ify DTC.Reference{id=id_, ..} =
 601                 H.tr $$ do
 602                         H.td ! HA.class_ "reference-key" $$
 603                                 html5ify @DTC.Lines $ Tree DTC.Rref{anchor=Nothing, to=id_} Seq.empty
 604                         H.td ! HA.class_ "reference-content" $$ do
 605                                 html5ify about
 606                                 rrefs <- liftStateMarkup $ S.gets state_rrefs
 607                                 case Map.lookup id_ rrefs of
 608                                  Nothing -> pure ()
 609                                  Just anchs ->
 610                                         H.span ! HA.class_ "reference-rrefs" $$
 611                                                 html5CommasDot $
 612                                                 (<$> List.reverse anchs) $ \DTC.Anchor{..} ->
 613                                                         H.a ! HA.class_ "reference-rref"
 614                                                             ! HA.href ("#rref."<>attrify id_<>"."<>attrify count) $$
 615                                                                 html5ify $ DTC.posAncestors section
 616 instance Html5ify DTC.PosPath where
 617         html5ify ancs =
 618                 case toList ancs of
 619                  [(_n,c)] -> do
 620                         html5ify $ show c
 621                         html5ify '.'
 622                  as ->
 623                         html5ify $
 624                                 Text.intercalate "." $
 625                                 Text.pack . show . snd <$> as
 626 instance Html5ify Plain where
 627         html5ify p = do
 628                 sp <- liftStateMarkup $ S.gets state_plainify
 629                 let (t,sp') = Plain.runPlain p sp
 630                 html5ify t
 631                 liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'}
 632
 633 html5CommasDot :: [Html5] -> Html5
 634 html5CommasDot [] = pure ()
 635 html5CommasDot hs = do
 636         sequence_ $ List.intersperse ", " hs
 637         "."
 638
 639 html5CommonAttrs :: DTC.CommonAttrs -> Html5 -> Html5
 640 html5CommonAttrs DTC.CommonAttrs{id=id_, ..} =
 641         Compose . (addClass . addId <$>) . getCompose
 642         where
 643         addClass =
 644                 case classes of
 645                  [] -> id
 646                  _  -> H.AddCustomAttribute "class" $
 647                         H.String $ TL.unpack $ TL.unwords classes
 648         addId = maybe id (\(DTC.Ident i) ->
 649                 H.AddCustomAttribute "id" (H.String $ TL.unpack i)) id_
 650
 651 html5SectionNumber :: DTC.PosPath -> Html5
 652 html5SectionNumber = go mempty
 653         where
 654         go :: DTC.PosPath -> DTC.PosPath -> Html5
 655         go prev next =
 656                 case Seq.viewl next of
 657                  Seq.EmptyL -> pure ()
 658                  a@(_n,rank) Seq.:< as -> do
 659                         H.a ! HA.href ("#"<>attrify (prev Seq.|>a)) $$
 660                                 html5ify $ show rank
 661                         when (not (null as) || null prev) $ do
 662                                 html5ify '.'
 663                                 go (prev Seq.|>a) as
 664
 665 html5SectionRef :: DTC.PosPath -> Html5
 666 html5SectionRef as =
 667         H.a ! HA.href ("#"<>attrify as) $$
 668                 html5ify as
 669
 670
 671 -- * 'Attrify'
 672 instance Attrify DTC.Anchor where
 673         attrify DTC.Anchor{..} =
 674                 attrify section
 675                  <> "." <> attrify count
 676 instance Attrify Plain where
 677         attrify p =
 678                 let (t,_) = Plain.runPlain p def in
 679                 attrify t
 680 instance Attrify DTC.PosPath where
 681         attrify = attrify . plainify
 682 instance Attrify DTC.Pos where
 683         attrify = attrify . DTC.posAncestors
 684
 685 attrifyIref :: DTC.Words -> H.AttributeValue
 686 attrifyIref term =
 687         "iref" <> "." <> attrify (Anchor.plainifyWords term)
 688 attrifyIrefCount :: DTC.Words -> DTC.Nat1 -> H.AttributeValue
 689 attrifyIrefCount term count =
 690         "iref"
 691          <> "." <> attrify (Anchor.plainifyWords term)
 692          <> "." <> attrify count
 693
 694 -- * Type 'L10n'
 695 instance Html5ify Plain.L10n where
 696         html5ify = html5ify . plainify
 697 instance Localize ls Plain Plain.L10n => Localize ls Html5 Plain.L10n where
 698         localize loc a = html5ify (Locale.localize loc a::Plain)
 699 instance LocalizeIn FR Html5 Plain.L10n where
 700         localizeIn loc = html5ify @Plain . localizeIn loc
 701 instance LocalizeIn EN Html5 Plain.L10n where
 702         localizeIn loc = html5ify @Plain . localizeIn loc