{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.DTC.Write.HTML5 where
import Control.Applicative (Applicative(..))
import Control.Category as Cat
import Control.Monad
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..), concat, any)
import Data.Function (($), const, on)
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Int (Int)
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..), tree0)
import Data.Tuple (snd)
import Prelude (mod)
import System.FilePath (FilePath)
import Text.Blaze ((!))
import Text.Blaze.Html (Html)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Strict.Maybe as Strict
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.TreeMap.Strict as TreeMap
import qualified Data.TreeSeq.Strict.Zipper as Tree
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import qualified Text.Blaze.Internal as H
import Text.Blaze.Utils
import Data.Locale hiding (Index)
import Language.DTC.Document as DTC
import Language.DTC.Write.Plain (Plainify(..))
import Language.DTC.Write.XML ()
import qualified Language.DTC.Anchor as Anchor
import qualified Language.DTC.Write.Plain as Plain
writeHTML5 :: Config -> DTC.Document -> Html
writeHTML5 conf@Config{..} DTC.Document{..} = do
let Keys{..} = keys body `S.execState` def
let (body',state_rrefs,state_notes,state_indexs) =
let irefs = foldMap Anchor.irefsOfTerms keys_index in
let (body0, Anchor.State{state_irefs, state_rrefs=rrefs, state_notes=notes}) =
Anchor.anchorify body `S.runState`
def{Anchor.state_irefs=irefs} in
(body0,rrefs,notes,) $
(<$> keys_index) $ \terms ->
(terms,) $
TreeMap.intersection const state_irefs $
Anchor.irefsOfTerms terms
let state_plainify = def{ Plain.state_l10n = loqualize config_locale}
let (html5Body, endState) =
runStateMarkup def
{ state_indexs
, state_rrefs
, state_notes
, state_figures = keys_figure
, state_references = keys_reference
, state_plainify
, state_l10n = loqualize config_locale
} $ do
html5DocumentHead head
html5ify body'
H.docType
H.html ! HA.lang (attrify $ countryCode config_locale) $ do
html5Head conf endState head body
H.body $ html5Body
html5Head :: Config -> State -> Head -> Body -> Html
html5Head Config{..} State{..} Head{DTC.about=About{..}} body = do
H.head $ do
H.meta ! HA.httpEquiv "Content-Type"
! HA.content "text/html; charset=UTF-8"
unless (null titles) $ do
H.title $
H.toMarkup $ Plain.text state_plainify $ List.head titles
forM_ links $ \Link{rel, href} ->
H.link ! HA.rel (attrify rel)
! HA.href (attrify href)
forM_ url $ \href ->
H.link ! HA.rel "self"
! HA.href (attrify href)
unless (TL.null config_generator) $ do
H.meta ! HA.name "generator"
! HA.content (attrify config_generator)
unless (null tags) $
H.meta ! HA.name "keywords"
! HA.content (attrify $ TL.intercalate ", " tags)
let chapters =
(`mapMaybe` toList body) $ \case
Tree k@BodySection{} _ -> Just k
_ -> Nothing
forM_ chapters $ \case
BodySection{..} ->
H.link ! HA.rel "Chapter"
! HA.title (attrify $ plainify title)
! HA.href ("#"<>attrify pos)
_ -> mempty
unless (any (\DTC.Link{rel} -> rel == "stylesheet") links) $ do
case config_css of
Left "" -> mempty
Left css ->
H.link ! HA.rel "stylesheet"
! HA.type_ "text/css"
! HA.href (attrify css)
Right css ->
H.style ! HA.type_ "text/css" $
-- NOTE: as a special case, H.style wraps its content into an External,
-- so it does not HTML-escape its content.
H.toMarkup css
forM_ state_styles $ \style ->
H.style ! HA.type_ "text/css" $
H.toMarkup style
unless (any (\DTC.Link{rel} -> rel == "script") links) $ do
forM_ state_scripts $ \script ->
H.script ! HA.type_ "application/javascript" $
H.toMarkup script
html5DocumentHead :: Head -> Html5
html5DocumentHead Head{DTC.about=About{..}} = do
H.div ! HA.class_ "document-head" $$
H.table $$ do
H.tbody $$ do
H.tr $$ do
H.td ! HA.class_ "left" $$ docHeaders
H.td ! HA.class_ "right" $$ docAuthors
unless (null titles) $
H.div ! HA.class_ "title" $$ do
forM_ titles $ \title ->
H.h1 $$ html5ify title
where
docHeaders =
H.table ! HA.class_ "document-headers" $$
H.tbody $$ do
Loqualization loc <- liftStateMarkup $ S.gets state_l10n
forM_ series $ \s@Serie{id=id_, name} ->
header $
case urlSerie s of
Nothing -> do
headerName $ html5ify name
headerValue $ html5ify id_
Just href -> do
headerName $ html5ify name
headerValue $
H.a ! HA.href (attrify href) $$
html5ify id_
forM_ date $ \d ->
header $ do
headerName $ l10n_Header_Date loc
headerValue $ html5ify d
forM_ url $ \href ->
header $ do
headerName $ l10n_Header_Address loc
headerValue $ html5ify $ tree0 $ PlainEref{href}
forM_ links $ \Link{..} ->
unless (TL.null name) $
header $ do
headerName $ html5ify name
headerValue $ html5ify $ Tree PlainEref{href} plain
forM_ headers $ \Header{..} ->
header $ do
headerName $ html5ify name
headerValue $ html5ify value
docAuthors =
H.table ! HA.class_ "document-authors" $$
H.tbody $$ do
forM_ authors $ \a ->
H.tr $$
H.td ! HA.class_ "author" $$
html5ify a
header :: Html5 -> Html5
header h = H.tr ! HA.class_ "header" $$ h
headerName :: Html5 -> Html5
headerName h =
H.td ! HA.class_ "header-name" $$ do
h
Loqualization loc <- liftStateMarkup $ S.gets state_l10n
Plain.l10n_Colon loc
headerValue :: Html5 -> Html5
headerValue h =
H.td ! HA.class_ "header-value" $$ do
h
-- * Type 'Config'
data Config
= forall locales.
( Locales locales
, Loqualize locales (L10n Html5)
, Loqualize locales (Plain.L10n Plain.Plain)
) =>
Config
{ config_css :: Either FilePath TL.Text
, config_locale :: LocaleIn locales
, config_generator :: TL.Text
}
instance Default Config where
def = Config
{ config_css = Right "style/dtc-html5.css"
, config_locale = LocaleIn @'[EN] en_US
, config_generator = "https://hackage.haskell.org/package/hdoc"
}
-- * Type 'Html5'
type Html5 = StateMarkup State ()
instance IsString Html5 where
fromString = html5ify
-- * Type 'State'
data State
= State
{ state_styles :: Map FilePath TL.Text
, state_scripts :: Map FilePath TL.Text
, state_indexs :: Map DTC.Pos (Terms, Anchor.Irefs)
, state_rrefs :: Anchor.Rrefs
, state_figures :: Map TL.Text (Map DTC.Pos (Maybe Title))
, state_references :: Map Ident About
, state_notes :: Anchor.Notes
, state_plainify :: Plain.State
, state_l10n :: Loqualization (L10n Html5)
}
instance Default State where
def = State
{ state_styles = def
, state_scripts = def
, state_indexs = def
, state_rrefs = def
, state_figures = def
, state_references = def
, state_notes = def
, state_plainify = def
, state_l10n = Loqualization EN_US
}
-- * Type 'Keys'
data Keys
= Keys
{ keys_index :: Map DTC.Pos Terms
, keys_figure :: Map TL.Text (Map DTC.Pos (Maybe Title))
, keys_reference :: Map Ident About
} deriving (Show)
instance Default Keys where
def = Keys mempty mempty mempty
-- ** Class 'KeysOf'
class KeysOf a where
keys :: a -> S.State Keys ()
instance KeysOf Body where
keys = mapM_ keys
instance KeysOf (Tree BodyNode) where
keys (Tree n ts) =
case n of
BodySection{..} -> keys ts
BodyBlock b -> keys b
instance KeysOf DTC.Block where
keys = \case
BlockPara{} -> return ()
BlockToC{} -> return ()
BlockToF{} -> return ()
BlockIndex{..} ->
S.modify $ \s -> s{keys_index=
Map.insert pos terms $ keys_index s}
BlockFigure{..} ->
S.modify $ \s -> s{keys_figure=
Map.insertWith (<>)
type_ (Map.singleton pos mayTitle) $
keys_figure s}
BlockReferences{..} ->
S.modify $ \s -> s{keys_reference=
foldr
(\r -> Map.insert
(DTC.id (r::DTC.Reference))
(DTC.about (r::DTC.Reference)))
(keys_reference s)
refs}
-- * Class 'Html5ify'
class Html5ify a where
html5ify :: a -> Html5
instance Html5ify H.Markup where
html5ify = Compose . return
instance Html5ify Char where
html5ify = html5ify . H.toMarkup
instance Html5ify Text where
html5ify = html5ify . H.toMarkup
instance Html5ify TL.Text where
html5ify = html5ify . H.toMarkup
instance Html5ify String where
html5ify = html5ify . H.toMarkup
instance Html5ify Title where
html5ify (Title t) = html5ify t
instance Html5ify Ident where
html5ify (Ident i) = html5ify i
instance Html5ify Int where
html5ify = html5ify . show
instance Html5ify Nat where
html5ify (Nat n) = html5ify n
instance Html5ify Nat1 where
html5ify (Nat1 n) = html5ify n
instance Html5ify a => Html5ify (Maybe a) where
html5ify = foldMap html5ify
-- * Type 'BodyCursor'
-- | Cursor to navigate within a 'Body' according to many axis (like in XSLT).
type BodyCursor = Tree.Zipper BodyNode
instance Html5ify Body where
html5ify body =
forM_ (Tree.zippers body) $ \z ->
forM_ (Tree.axis_repeat Tree.axis_following_sibling_nearest `Tree.runAxis` z) $
html5ify
instance Html5ify BodyCursor
where html5ify z =
let Tree n _ts = Tree.current z in
case n of
BodyBlock BlockToC{..} -> do
H.nav ! HA.class_ "toc"
! HA.id (attrify pos) $$ do
H.span ! HA.class_ "toc-name" $$
H.a ! HA.href (attrify pos) $$ do
Loqualization loc <- liftStateMarkup $ S.gets state_l10n
Plain.l10n_Table_of_Contents loc
H.ul $$
forM_ (Tree.axis_following_sibling `Tree.runAxis` z) $
html5ifyToC depth
BodyBlock b -> html5ify b
BodySection{..} -> do
do
notes <- liftStateMarkup $ S.gets state_notes
let mayNotes = do
p <- posParent $ posAncestors pos
let (ns, as) = Map.updateLookupWithKey (\_ _ -> Nothing) p notes
(,as) <$> ns
case mayNotes of
Nothing -> mempty
Just (secNotes, state_notes) -> do
liftStateMarkup $ S.modify' $ \s -> s{state_notes}
html5ify secNotes
H.section ! HA.class_ "section"
! HA.id (attrify pos) $$ do
forM_ aliases html5ify
html5CommonAttrs attrs{classes="section-header":classes attrs} $
H.table $$
H.tbody $$
H.tr $$ do
H.td ! HA.class_ "section-number" $$ do
html5SectionNumber $ DTC.posAncestors pos
H.td ! HA.class_ "section-title" $$ do
(case List.length $ DTC.posAncestors pos of
0 -> H.h1
1 -> H.h2
2 -> H.h3
3 -> H.h4
4 -> H.h5
5 -> H.h6
_ -> H.h6) $$
html5ify title
forM_ (Tree.axis_child `Tree.runAxis` z) $
html5ify
notes <- liftStateMarkup $ S.gets state_notes
html5ify $ Map.lookup (posAncestors pos) notes
instance Html5ify [Anchor.Note] where
html5ify notes =
H.aside ! HA.class_ "notes" $$ do
Compose $ pure H.hr
H.table $$
H.tbody $$
forM_ (List.reverse notes) $ \Anchor.Note{..} ->
H.tr $$ do
H.td ! HA.class_ "note-ref" $$ do
H.a ! HA.class_ "note-number"
! HA.id ("note."<>attrify note_number)
! HA.href ("#note."<>attrify note_number) $$ do
html5ify note_number
". "::Html5
H.a ! HA.href ("#note-ref."<>attrify note_number) $$ do
"↑"
H.td $$
html5ify note_content
instance Html5ify Block where
html5ify = \case
BlockPara para -> html5ify para
BlockToC{..} -> mempty -- NOTE: done in Html5ify BodyCursor
BlockToF{..} -> do
H.nav ! HA.class_ "tof"
! HA.id (attrify pos) $$
H.table ! HA.class_ "tof" $$
H.tbody $$
html5ifyToF types
BlockFigure{..} ->
html5CommonAttrs attrs
{ classes = "figure":("figure-"<>type_):classes attrs
, DTC.id = Just $ Ident $ Plain.text def $ DTC.posAncestors pos
} $
H.div $$ do
H.table ! HA.class_ "figure-caption" $$
H.tbody $$
H.tr $$ do
if TL.null type_
then H.a ! HA.href ("#"<>attrify pos) $$ mempty
else
H.td ! HA.class_ "figure-number" $$ do
H.a ! HA.href ("#"<>attrify (DTC.posAncestorsWithFigureNames pos)) $$ do
html5ify type_
html5ify $ DTC.posAncestorsWithFigureNames pos
forM_ mayTitle $ \title -> do
H.td ! HA.class_ "figure-colon" $$ do
unless (TL.null type_) $ do
Loqualization loc <- liftStateMarkup $ S.gets state_l10n
Plain.l10n_Colon loc
H.td ! HA.class_ "figure-title" $$ do
html5ify title
H.div ! HA.class_ "figure-content" $$ do
html5ify paras
BlockIndex{pos} -> do
(allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . state_indexs
let chars = Anchor.termsByChar allTerms
H.div ! HA.class_ "index"
! HA.id (attrify pos) $$ do
H.nav ! HA.class_ "index-nav" $$ do
forM_ (Map.keys chars) $ \char ->
H.a ! HA.href ("#"<>(attrify pos <> "." <> attrify char)) $$
html5ify char
H.dl ! HA.class_ "index-chars" $$
forM_ (Map.toList chars) $ \(char,terms) -> do
H.dt $$
let i = attrify pos <> "." <> attrify char in
H.a ! HA.id i
! HA.href ("#"<>i) $$
html5ify char
H.dd $$
H.dl ! HA.class_ "index-term" $$ do
forM_ terms $ \aliases -> do
H.dt $$
H.ul ! HA.class_ "index-aliases" $$
forM_ (List.take 1 aliases) $ \term ->
H.li ! HA.id (attrifyIref term) $$
html5ify term
H.dd $$
let anchs =
List.sortBy (compare `on` DTC.section . snd) $
(`foldMap` aliases) $ \words ->
fromJust $ do
path <- Anchor.pathFromWords words
Strict.maybe Nothing (Just . ((words,) <$>) . List.reverse) $
TreeMap.lookup path refsByTerm in
html5CommasDot $
(<$> anchs) $ \(term,DTC.Anchor{..}) ->
H.a ! HA.class_ "index-iref"
! HA.href ("#"<>attrifyIrefCount term count) $$
html5ify $ DTC.posAncestors section
BlockReferences{..} ->
html5CommonAttrs attrs
{ classes = "references":classes attrs
, DTC.id = Just $ Ident $ Plain.text def $ DTC.posAncestors pos
} $
H.div $$ do
H.table $$
forM_ refs html5ify
html5ifyToC :: Maybe DTC.Nat -> BodyCursor -> Html5
html5ifyToC depth z =
let Tree n _ts = Tree.current z in
case n of
BodySection{..} -> do
H.li $$ do
H.table ! HA.class_ "toc-entry" $$
H.tbody $$
H.tr $$ do
H.td ! HA.class_ "section-number" $$
html5SectionRef $ DTC.posAncestors pos
H.td ! HA.class_ "section-title" $$
html5ify $ cleanPlain $ unTitle title
when (maybe True (> Nat 1) depth && not (null sections)) $
H.ul $$
forM_ sections $
html5ifyToC (depth >>= predNat)
_ -> pure ()
where
sections =
(`Tree.runAxis` z) $
Tree.axis_child
`Tree.axis_filter_current` \case
Tree BodySection{} _ -> True
_ -> False
html5ifyToF :: [TL.Text] -> Html5
html5ifyToF types = do
figsByType <- liftStateMarkup $ S.gets state_figures
let figs =
Map.foldMapWithKey (\ty -> ((ty,) <$>)) $
if null types
then figsByType
else
Map.intersection figsByType $
Map.fromList [(ty,()) | ty <- types]
forM_ (Map.toList figs) $ \(pos, (type_, title)) ->
H.tr $$ do
H.td ! HA.class_ "figure-number" $$
H.a ! HA.href ("#"<>attrify pos) $$ do
html5ify type_
html5ify $ DTC.posAncestors pos
forM_ title $ \ti ->
H.td ! HA.class_ "figure-title" $$
html5ify $ cleanPlain $ unTitle ti
cleanPlain :: Plain -> Plain
cleanPlain ps =
ps >>= \case
Tree PlainIref{} ls -> cleanPlain ls
Tree PlainNote{} _ -> mempty
Tree n ts -> pure $ Tree n $ cleanPlain ts
instance Html5ify Para where
html5ify = \case
ParaItem{..} ->
html5CommonAttrs def
{ classes="para":cls item
} $
html5ify item
ParaItems{..} ->
html5CommonAttrs attrs
{ classes = "para":classes attrs
, DTC.id = id_ pos
} $
H.div $$
forM_ items $ \item ->
html5AttrClass (cls item) $
html5ify item
where
id_ = Just . Ident . Plain.text def . DTC.posAncestors
cls = \case
ParaPlain{} -> []
ParaArtwork{..} -> ["artwork", "artwork-"<>type_]
ParaQuote{..} -> ["quote", "quote-"<>type_]
ParaComment{} -> []
ParaOL{} -> ["ol"]
ParaUL{} -> ["ul"]
instance Html5ify ParaItem where
html5ify = \case
ParaPlain p -> H.p $$ html5ify p
ParaArtwork{..} -> H.pre $$ do html5ify text
ParaQuote{..} -> H.div $$ do html5ify paras
ParaComment t -> html5ify $ H.Comment (H.String $ TL.unpack t) ()
ParaOL items ->
H.table $$ do
H.tbody $$
forM_ items $ \ListItem{..} -> do
H.tr $$ do
H.td ! HA.class_ "name" $$ do
html5ify name
"."::Html5
H.td ! HA.class_ "value" $$
html5ify paras
ParaUL items ->
H.dl $$ do
forM_ items $ \item -> do
H.dt $$ "—"
H.dd $$ html5ify item
instance Html5ify [Para] where
html5ify = mapM_ html5ify
instance Html5ify Plain where
html5ify ps =
case Seq.viewl ps of
Seq.EmptyL -> mempty
curr Seq.:< next ->
case curr of
-- NOTE: gather adjacent PlainNotes
Tree PlainNote{} _
| (notes, rest) <- Seq.spanl (\case {Tree PlainNote{} _ -> True; _ -> False}) next -> do
H.sup ! HA.class_ "note-numbers" $$ do
html5ify curr
forM_ notes $ \note -> do
", "::Html5
html5ify note
" "::Html5
html5ify rest
--
_ -> do
html5ify curr
html5ify next
instance Html5ify (Tree PlainNode)
where html5ify (Tree n ls) =
case n of
PlainBR -> html5ify H.br
PlainText t -> html5ify t
PlainGroup -> html5ify ls
PlainB -> H.strong $$ html5ify ls
PlainCode -> H.code $$ html5ify ls
PlainDel -> H.del $$ html5ify ls
PlainI -> do
i <- liftStateMarkup $ do
i <- S.gets $ Plain.state_italic . state_plainify
S.modify $ \s ->
s{state_plainify=
(state_plainify s){Plain.state_italic=
not i}}
return i
H.em ! HA.class_ (if i then "even" else "odd") $$
html5ify ls
liftStateMarkup $
S.modify $ \s ->
s{state_plainify=
(state_plainify s){Plain.state_italic=i}}
PlainSub -> H.sub $$ html5ify ls
PlainSup -> H.sup $$ html5ify ls
PlainSC -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
PlainU -> H.span ! HA.class_ "underline" $$ html5ify ls
PlainNote{..} ->
case number of
Nothing -> mempty
Just num ->
H.a ! HA.class_ "note-ref"
! HA.id ("note-ref."<>attrify num)
! HA.href ("#note."<>attrify num) $$
html5ify num
PlainQ -> do
H.span ! HA.class_ "q" $$ do
Loqualization loc <- liftStateMarkup $ S.gets state_l10n
Plain.l10n_Quote (html5ify $ Tree PlainI ls) loc
PlainEref{..} ->
H.a ! HA.class_ "eref"
! HA.href (attrify href) $$
if null ls
then html5ify $ unURL href
else html5ify ls
PlainIref{..} ->
case anchor of
Nothing -> html5ify ls
Just Anchor{..} ->
H.span ! HA.class_ "iref"
! HA.id (attrifyIrefCount term count) $$
html5ify ls
PlainRef{..} ->
H.a ! HA.class_ "ref"
! HA.href ("#"<>attrify to) $$
if null ls
then html5ify to
else html5ify ls
PlainRref{..} -> do
refs <- liftStateMarkup $ S.gets state_references
case Map.lookup to refs of
Nothing -> do
"["::Html5
H.span ! HA.class_ "rref-broken" $$
html5ify to
"]"
Just About{..} -> do
unless (null ls) $
forM_ (List.take 1 titles) $ \(Title title) -> do
html5ify $ Tree PlainQ $
case url of
Nothing -> title
Just u -> pure $ Tree (PlainEref u) title
" "::Html5
"["::Html5
H.a ! HA.class_ "rref"
! HA.href ("#rref."<>attrify to)
! HA.id ("rref."<>attrify to<>maybe "" (\Anchor{..} -> "."<>attrify count) anchor) $$
html5ify to
"]"
instance Html5ify [Title] where
html5ify =
html5ify . fold . List.intersperse sep . toList
where sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
instance Html5ify About where
html5ify About{..} =
html5CommasDot $ concat $
[ html5Titles titles
, html5ify <$> authors
, html5ify <$> maybeToList date
, html5ify <$> maybeToList editor
, html5ify <$> series
]
where
html5Titles :: [Title] -> [Html5]
html5Titles ts | null ts = []
html5Titles ts = [html5Title $ joinTitles ts]
where
joinTitles = fold . List.intersperse sep . toList
sep = Title $ Seq.singleton $ tree0 $ PlainText " — "
html5Title (Title title) =
html5ify $ Tree PlainQ $
case url of
Nothing -> title
Just u -> pure $ Tree (PlainEref u) title
instance Html5ify Serie where
html5ify s@Serie{id=id_, name} = do
Loqualization loc <- liftStateMarkup $ S.gets state_l10n
case urlSerie s of
Nothing -> do
html5ify name
Plain.l10n_Colon loc :: Html5
html5ify id_
Just href -> do
html5ify $
Tree PlainEref{href} $
Seq.fromList
[ tree0 $ PlainText $ name
, tree0 $ PlainText $ Plain.l10n_Colon loc
, tree0 $ PlainText id_
]
instance Html5ify Entity where
html5ify Entity{..} = do
html5ify $
case () of
_ | not (TL.null email) ->
Tree (PlainEref $ URL $ "mailto:"<>email) $
pure $ tree0 $ PlainText name
_ | Just u <- url ->
Tree (PlainEref u) $
pure $ tree0 $ PlainText name
_ -> tree0 $ PlainText name
forM_ org $ \o -> do
" ("::Html5
html5ify o
")"::Html5
instance Html5ify Words where
html5ify = html5ify . Anchor.plainifyWords
instance Html5ify Alias where
html5ify Alias{id=id_, ..} = do
H.a ! HA.class_ "alias"
! HA.id (attrify id_) $$
mempty
instance Html5ify URL where
html5ify (URL url) =
H.a ! HA.class_ "eref"
! HA.href (attrify url) $$
html5ify url
instance Html5ify Date where
html5ify date = do
Loqualization loc <- liftStateMarkup $ S.gets state_l10n
Plain.l10n_Date date loc
instance Html5ify Reference where
html5ify Reference{id=id_, ..} =
H.tr $$ do
H.td ! HA.class_ "reference-key" $$
html5ify $ Tree PlainRref{anchor=Nothing, to=id_} Seq.empty
H.td ! HA.class_ "reference-content" $$ do
html5ify about
rrefs <- liftStateMarkup $ S.gets state_rrefs
case Map.lookup id_ rrefs of
Nothing -> pure ()
Just anchs ->
H.span ! HA.class_ "reference-rrefs" $$
html5CommasDot $
(<$> List.reverse anchs) $ \Anchor{..} ->
H.a ! HA.class_ "reference-rref"
! HA.href ("#rref."<>attrify id_<>"."<>attrify count) $$
html5ify $ DTC.posAncestors section
instance Html5ify PosPath where
html5ify ancs =
case toList ancs of
[(_n,c)] -> do
html5ify $ show c
html5ify '.'
as ->
html5ify $
Text.intercalate "." $
Text.pack . show . snd <$> as
instance Html5ify Plain.Plain where
html5ify p = do
sp <- liftStateMarkup $ S.gets state_plainify
let (t,sp') = Plain.runPlain p sp
html5ify t
liftStateMarkup $ S.modify $ \s -> s{state_plainify=sp'}
html5CommasDot :: [Html5] -> Html5
html5CommasDot [] = pure ()
html5CommasDot hs = do
sequence_ $ List.intersperse ", " hs
"."
html5AttrClass :: [TL.Text] -> Html5 -> Html5
html5AttrClass = \case
[] -> Cat.id
cls ->
Compose .
(H.AddCustomAttribute "class"
(H.String $ TL.unpack $ TL.unwords cls) <$>) .
getCompose
html5AttrId :: Ident -> Html5 -> Html5
html5AttrId (Ident id_) =
Compose .
(H.AddCustomAttribute "id"
(H.String $ TL.unpack id_) <$>) .
getCompose
html5CommonAttrs :: CommonAttrs -> Html5 -> Html5
html5CommonAttrs CommonAttrs{id=id_, ..} =
html5AttrClass classes .
maybe Cat.id html5AttrId id_
html5SectionNumber :: PosPath -> Html5
html5SectionNumber = go mempty
where
go :: PosPath -> PosPath -> Html5
go prev next =
case Seq.viewl next of
Seq.EmptyL -> pure ()
a@(_n,rank) Seq.:< as -> do
H.a ! HA.href ("#"<>attrify (prev Seq.|>a)) $$
html5ify $ show rank
when (not (null as) || null prev) $ do
html5ify '.'
go (prev Seq.|>a) as
html5SectionRef :: PosPath -> Html5
html5SectionRef as =
H.a ! HA.href ("#"<>attrify as) $$
html5ify as
-- * 'Attrify'
instance Attrify Anchor where
attrify Anchor{..} = attrify section <> "." <> attrify count
instance Attrify Plain.Plain where
attrify p = attrify t
where (t,_) = Plain.runPlain p def
instance Attrify PosPath where
attrify = attrify . plainify
instance Attrify DTC.Pos where
attrify = attrify . DTC.posAncestors
attrifyIref :: Words -> H.AttributeValue
attrifyIref term =
"iref" <> "." <> attrify (Anchor.plainifyWords term)
attrifyIrefCount :: Words -> Nat1 -> H.AttributeValue
attrifyIrefCount term count =
"iref"
<> "." <> attrify (Anchor.plainifyWords term)
<> "." <> attrify count
-- * Class 'L10n'
class
( Plain.L10n msg lang
, Plain.L10n TL.Text lang
) => L10n msg lang where
l10n_Header_Address :: FullLocale lang -> msg
l10n_Header_Date :: FullLocale lang -> msg
l10n_Header_Version :: FullLocale lang -> msg
l10n_Header_Origin :: FullLocale lang -> msg
l10n_Header_Source :: FullLocale lang -> msg
instance L10n Html5 EN where
l10n_Header_Address _loc = "Address"
l10n_Header_Date _loc = "Date"
l10n_Header_Origin _loc = "Origin"
l10n_Header_Source _loc = "Source"
l10n_Header_Version _loc = "Version"
instance L10n Html5 FR where
l10n_Header_Address _loc = "Adresse"
l10n_Header_Date _loc = "Date"
l10n_Header_Origin _loc = "Origine"
l10n_Header_Source _loc = "Source"
l10n_Header_Version _loc = "Version"
instance Plain.L10n Html5 EN where
l10n_Colon loc = html5ify (Plain.l10n_Colon loc :: TL.Text)
l10n_Table_of_Contents loc = html5ify (Plain.l10n_Table_of_Contents loc :: TL.Text)
l10n_Date date loc = html5ify (Plain.l10n_Date date loc :: TL.Text)
l10n_Quote msg _loc = do
depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
let (o,c) :: (Html5, Html5) =
case unNat depth `mod` 3 of
0 -> ("“","”")
1 -> ("« "," »")
_ -> ("‟","„")
o
setDepth $ succNat depth
msg
setDepth $ depth
c
where
setDepth d =
liftStateMarkup $ S.modify' $ \s ->
s{state_plainify=(state_plainify s){Plain.state_quote=d}}
instance Plain.L10n Html5 FR where
l10n_Colon loc = html5ify (Plain.l10n_Colon loc :: TL.Text)
l10n_Table_of_Contents loc = html5ify (Plain.l10n_Table_of_Contents loc :: TL.Text)
l10n_Date date loc = html5ify (Plain.l10n_Date date loc :: TL.Text)
l10n_Quote msg _loc = do
depth <- liftStateMarkup $ S.gets $ Plain.state_quote . state_plainify
let (o,c) :: (Html5, Html5) =
case unNat depth `mod` 3 of
0 -> ("« "," »")
1 -> ("“","”")
_ -> ("‟","„")
o
setDepth $ succNat depth
msg
setDepth $ depth
c
where
setDepth d =
liftStateMarkup $ S.modify' $ \s ->
s{state_plainify=(state_plainify s){Plain.state_quote=d}}