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