-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Render a DTC source file in HTML5.
module Language.DTC.Write.HTML5 where
-- import Control.Monad.Trans.Class (MonadTrans(..))
--- import Data.Bool
--- import Data.Functor.Compose (Compose(..))
-- import Data.Functor.Identity (Identity(..))
--- import Data.Map.Strict (Map)
--- import Data.String (IsString(..))
--- import Prelude (Num(..), undefined)
--- import qualified Control.Monad.Trans.State as S
--- import qualified Data.Map.Strict as Map
-import Control.Monad (forM_, mapM_, when, (>=>))
-import Data.Eq (Eq(..))
-import Data.Ord (Ord(..))
-import Data.Foldable (Foldable(..))
-import Data.Function (($), (.))
-import Data.Functor ((<$>))
+-- import Data.Sequence (Seq)
+-- import Data.Set (Set)
+-- import Data.Traversable (Traversable(..))
+-- import qualified Data.Sequence as Seq
+-- import qualified Data.TreeSeq.Strict as Tree
+import Control.Applicative (Applicative(..))
+import Control.Category
+import Control.Monad
+import Data.Bool
+import Data.Char (Char)
+import Data.Default.Class (Default(..))
+import Data.Foldable (Foldable(..), concat)
+import Data.Function (($), const, flip, on)
+import Data.Functor (Functor(..), (<$>))
+import Data.Functor.Compose (Compose(..))
import Data.Int (Int)
-import Data.Maybe (Maybe(..))
+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.Sequence (Seq)
+import Data.String (String)
import Data.Text (Text)
+import Data.TreeSeq.Strict (Tree(..), Trees)
import Data.Tuple (snd)
-import Prelude (Num(..))
+import System.FilePath (FilePath)
import Text.Blaze ((!))
import Text.Blaze.Html (Html)
import Text.Show (Show(..))
-import Data.TreeSeq.Strict (Tree(..))
+import qualified Control.Monad.Trans.State as S
+import qualified Data.Char as Char
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 as Tree
+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 qualified Data.TreeSeq.Strict as Tree
-import qualified Data.TreeSeq.Strict.Zipper as Tree
import Text.Blaze.Utils
+import Data.Locale hiding (localize, Index)
+import qualified Data.Locale as Locale
-import Data.Locale
-import Language.DTC.Document (Document)
import Language.DTC.Write.XML ()
-import Language.XML (XmlName(..), XmlPos(..))
+import Language.DTC.Write.Plain (Plain, Plainify(..))
+import qualified Language.DTC.Write.Plain as Plain
import qualified Language.DTC.Document as DTC
+import qualified Language.DTC.Anchor as Anchor
--- import Debug.Trace (trace)
+(<&>) :: Functor f => f a -> (a -> b) -> f b
+(<&>) = flip (<$>)
+infixl 4 <&>
-instance H.ToMarkup DTC.Ident where
- toMarkup (DTC.Ident i) = H.toMarkup i
-instance H.ToMarkup DTC.Title where
- toMarkup (DTC.Title t) = html5Horizontals t
-instance AttrValue XmlPos where
- attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors
+-- * Type 'Html5'
+type Html5 = StateMarkup State ()
--- * Type 'InhHtml5'
-data InhHtml5
- = InhHtml5
- { inhHtml5_localize :: MsgHtml5 -> Html
- }
-inhHtml5 :: InhHtml5
-inhHtml5 = InhHtml5
- { inhHtml5_localize = localizeIn @EN EN_US
+-- * Type 'State'
+data State
+ = State
+ { state_styles :: Map FilePath CSS
+ , state_scripts :: Map FilePath Script
+ , state_indexs :: Map DTC.Pos (DTC.Terms, Anchor.Irefs)
+ , state_rrefs :: Anchor.Rrefs
+ , state_figures :: Map Text (Map DTC.Pos (Maybe DTC.Title))
+ , state_references :: Map DTC.Ident DTC.About
+ , state_notes :: Anchor.Notes
+ , state_plainify :: Plain.State
}
+instance Default State where
+ def = State
+ { state_styles = mempty
+ , state_scripts = mempty
+ , state_indexs = mempty
+ , state_rrefs = mempty
+ , state_figures = mempty
+ , state_references = mempty
+ , state_notes = mempty
+ , state_plainify = def
+ }
+type CSS = Text
+type Script = Text
--- * Type 'MsgHtml5'
-data MsgHtml5
- = MsgHTML5_Table_of_Contents
-instance LocalizeIn FR Html MsgHtml5 where
- localizeIn _ MsgHTML5_Table_of_Contents = "Sommaire"
-instance LocalizeIn EN Html MsgHtml5 where
- localizeIn _ MsgHTML5_Table_of_Contents = "Table of Contents"
-
-{- NOTE: composing state and markups
-type HtmlM st = Compose (S.State st) H.MarkupM
-instance Monad (HtmlM st) where
- return = pure
- Compose sma >>= a2csmb =
- Compose $ sma >>= \ma ->
- case ma >>= H.Empty . a2csmb of
- H.Append _ma (H.Empty csmb) ->
- H.Append ma <$> getCompose csmb
- _ -> undefined
-
-($$) :: (Html -> Html) -> HTML -> HTML
-($$) f m = Compose $ f <$> getCompose m
-infixr 0 $$
--}
+-- * Type 'Keys'
+data Keys
+ = Keys
+ { keys_index :: Map DTC.Pos DTC.Terms
+ , keys_figure :: Map Text (Map DTC.Pos (Maybe DTC.Title))
+ , keys_reference :: Map DTC.Ident DTC.About
+ } deriving (Show)
+instance Default Keys where
+ def = Keys mempty mempty mempty
-unMarkupValue :: H.MarkupM a -> b -> H.MarkupM b
-unMarkupValue = \case
- H.Parent x0 x1 x2 m -> H.Parent x0 x1 x2 . unMarkupValue m
- H.CustomParent x0 m -> H.CustomParent x0 . unMarkupValue m
- H.Leaf x0 x1 x2 _ -> H.Leaf x0 x1 x2
- H.CustomLeaf x0 x1 _ -> H.CustomLeaf x0 x1
- H.Content x0 _ -> H.Content x0
- H.Comment x0 _ -> H.Comment x0
- H.Append x0 m -> H.Append x0 . unMarkupValue m
- H.AddAttribute x0 x1 x2 m -> H.AddAttribute x0 x1 x2 . unMarkupValue m
- H.AddCustomAttribute x0 x1 m -> H.AddCustomAttribute x0 x1 . unMarkupValue m
- H.Empty _ -> H.Empty
+-- ** Class 'KeysOf'
+class KeysOf a where
+ keys :: a -> S.State Keys ()
+instance KeysOf (Trees DTC.BodyKey DTC.BodyValue) where
+ keys = mapM_ keys
+instance KeysOf (Tree DTC.BodyKey DTC.BodyValue) where
+ keys = \case
+ TreeN k ts ->
+ case k of
+ DTC.Section{..} ->
+ keys ts
+ Tree0 v ->
+ case v of
+ DTC.Index{..} ->
+ S.modify $ \s -> s{keys_index=
+ Map.insert pos terms $ keys_index s}
+ DTC.Figure{..} ->
+ S.modify $ \s -> s{keys_figure=
+ Map.insertWith (<>)
+ type_ (Map.singleton pos title) $
+ keys_figure s}
+ DTC.References{..} ->
+ S.modify $ \s -> s{keys_reference=
+ foldr
+ (\r -> Map.insert
+ (DTC.id (r::DTC.Reference))
+ (DTC.about (r::DTC.Reference)))
+ (keys_reference s)
+ refs}
+ DTC.ToC{} -> return ()
+ DTC.ToF{} -> return ()
+ DTC.Block{} -> return ()
-markupValue :: H.MarkupM a -> a
-markupValue m0 = case m0 of
- H.Parent _ _ _ m1 -> markupValue m1
- H.CustomParent _ m1 -> markupValue m1
- H.Leaf _ _ _ x -> x
- H.CustomLeaf _ _ x -> x
- H.Content _ x -> x
- H.Comment _ x -> x
- H.Append _ m1 -> markupValue m1
- H.AddAttribute _ _ _ m1 -> markupValue m1
- H.AddCustomAttribute _ _ m1 -> markupValue m1
- H.Empty x -> x
+-- * Class 'Html5ify'
+class Html5ify a where
+ html5ify :: a -> Html5
+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 H.Markup where
+ html5ify = Compose . return
+instance Html5ify DTC.Title where
+ html5ify (DTC.Title t) = html5ify t
+instance Html5ify DTC.Para where
+ html5ify = mapM_ html5ify
+instance Html5ify DTC.Ident where
+ html5ify (DTC.Ident i) = html5ify i
+instance Html5ify Int where
+ html5ify = html5ify . show
+instance Html5ify DTC.Nat where
+ html5ify (DTC.Nat n) = html5ify n
+instance Html5ify DTC.Nat1 where
+ html5ify (DTC.Nat1 n) = html5ify n
html5Document ::
- Localize ls Html MsgHtml5 =>
- LocaleIn ls -> Document -> Html
-html5Document loc DTC.Document{..} = do
- let inh = InhHtml5
- { inhHtml5_localize = localize loc
- }
+ Localize ls Plain Plain.L10n =>
+ Locales ls =>
+ LocaleIn ls -> DTC.Document -> Html
+html5Document locale 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_localize = Locale.localize locale }
+ let (html5Body, State{state_styles,state_scripts}) =
+ runStateMarkup def
+ { state_indexs
+ , state_rrefs
+ , state_notes
+ , state_figures = keys_figure
+ , state_references = keys_reference
+ , state_plainify
+ } $ html5ify body'
+
H.docType
- H.html $ do
+ H.html ! HA.lang (attrify $ countryCode locale) $ do
H.head $ do
H.meta ! HA.httpEquiv "Content-Type"
! HA.content "text/html; charset=UTF-8"
whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts ->
- let t = H.toMarkup $ List.head $ ts <> [DTC.Title [DTC.Plain ""]] in
- H.title $ H.toMarkup t
- -- link ! rel "Chapter" ! title "SomeTitle">
+ H.title $
+ H.toMarkup $ Plain.text state_plainify $ List.head ts
+ forM_ (DTC.links $ DTC.about (head :: DTC.Head)) $ \DTC.Link{rel, href} ->
+ H.link ! HA.rel (attrify rel)
+ ! HA.href (attrify href)
+ H.meta ! HA.name "generator"
+ ! HA.content "tct"
+ let chapters =
+ (`mapMaybe` toList body) $ \case
+ TreeN k@DTC.Section{} _ -> Just k
+ _ -> Nothing
+ forM_ chapters $ \DTC.Section{..} ->
+ H.link ! HA.rel "Chapter"
+ ! HA.title (attrify $ plainify title)
+ ! HA.href ("#"<>attrify pos)
H.link ! HA.rel "stylesheet"
! HA.type_ "text/css"
! HA.href "style/dtc-html5.css"
- H.body $
- html5Body inh body
-
--- * Type 'BodyZip'
-type BodyZip = Tree.Zipper DTC.BodyKey (Seq DTC.BodyValue)
+ forM_ state_styles $ \style ->
+ H.style ! HA.type_ "text/css" $
+ H.toMarkup style
+ forM_ state_scripts $ \script ->
+ H.script ! HA.type_ "application/javascript" $
+ H.toMarkup script
+ H.body
+ html5Body
-html5Body :: InhHtml5 -> DTC.Body -> Html
-html5Body inh body =
- forM_ (Tree.zippers body) $
- html5BodyZipper inh
-
-html5BodyZipper :: InhHtml5 -> BodyZip -> Html
-html5BodyZipper inh z =
+-- * Type 'BodyCursor'
+-- | Cursor to navigate within a 'DTC.Body' according to many axis (like in XSLT).
+type BodyCursor = Tree.Zipper DTC.BodyKey DTC.BodyValue
+instance Html5ify DTC.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 =
case Tree.current z of
- TreeN k _ts -> html5BodyKey inh z k
- Tree0 vs -> forM_ vs $ html5BodyValue inh z
-
-html5BodyKey :: InhHtml5 -> BodyZip -> DTC.BodyKey -> Html
-html5BodyKey inh z = \case
- DTC.Section{..} ->
- H.section
- ! HA.class_ "section"
- ! HA.id (attrValue pos) $ do
+ TreeN k _ts ->
+ case k of
+ DTC.Section{..} ->
+ H.section ! HA.class_ "section"
+ ! HA.id (attrify pos) $$ do
+ html5CommonAttrs attrs $
+ H.table ! HA.class_ "section-header" $$
+ 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
+ case Map.lookup pos notes of
+ Nothing -> return ()
+ Just ns ->
+ H.aside ! HA.class_ "notes" $$ do
+ Compose $ pure H.hr
+ H.table $$
+ H.tbody $$
+ forM_ ns $ \(num,para) ->
+ H.tr $$ do
+ H.td ! HA.class_ "note-ref" $$ do
+ H.a ! HA.class_ "note-number"
+ ! HA.id ("note."<>attrify num)
+ ! HA.href ("#note."<>attrify num) $$ do
+ html5ify num
+ ". "::Html5
+ H.a ! HA.href ("#note-ref."<>attrify num) $$ do
+ "↑"
+ H.td $$
+ html5ify para
+ Tree0 v ->
+ case v of
+ DTC.Block b -> html5ify b
+ DTC.ToC{..} -> do
+ H.nav ! HA.class_ "toc"
+ ! HA.id (attrify pos) $$ do
+ H.span ! HA.class_ "toc-name" $$
+ H.a ! HA.href (attrify pos) $$
+ html5ify Plain.L10n_Table_of_Contents
+ H.ul $$
+ forM_ (Tree.axis_following_sibling `Tree.runAxis` z) $
+ html5ifyToC depth
+ DTC.ToF{..} -> do
+ H.nav ! HA.class_ "tof"
+ ! HA.id (attrify pos) $$
+ H.table ! HA.class_ "tof" $$
+ H.tbody $$
+ html5ifyToF types
+ DTC.Figure{..} ->
+ html5CommonAttrs attrs $
+ H.div ! HA.class_ ("figure " <> attrify ("figure-"<>type_))
+ ! HA.id (attrify pos) $$ do
+ H.table ! HA.class_ "figure-caption" $$
+ H.tbody $$
+ H.tr $$ do
+ H.td ! HA.class_ "figure-number" $$ do
+ H.a ! HA.href ("#"<>attrify pos) $$ do
+ html5ify type_
+ html5ify $ DTC.posAncestors pos
+ forM_ title $ \ti -> do
+ html5ify $ Plain.L10n_Colon
+ H.td ! HA.class_ "figure-title" $$
+ html5ify ti
+ H.div ! HA.class_ "figure-content" $$ do
+ html5ify blocks
+ DTC.Index{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
+ DTC.References{..} ->
html5CommonAttrs attrs $
- H.table ! HA.class_ "section-header" $
- H.tbody $
- H.tr $ do
- H.td ! HA.class_ "section-number" $ do
- html5SectionNumber $ xmlPosAncestors pos
- H.td ! HA.class_ "section-title" $ do
- H.toMarkup title
- forM_ (Tree.axis_child z) $
- html5BodyZipper inh
+ H.div ! HA.class_ "references"
+ ! HA.id (attrify pos) $$ do
+ H.table $$
+ forM_ refs html5ify
+instance Html5ify DTC.Words where
+ html5ify = html5ify . Anchor.plainifyWords
-html5BodyValue :: InhHtml5 -> BodyZip -> DTC.BodyValue -> Html
-html5BodyValue InhHtml5{..} z = \ case
- DTC.Vertical v -> do
- html5Vertical v
- DTC.ToC{..} -> do
- H.nav ! HA.class_ "toc"
- ! HA.id (attrValue pos) $ do
- H.span ! HA.class_ "toc-name" $
- H.a ! HA.href (attrValue pos) $
- inhHtml5_localize MsgHTML5_Table_of_Contents
- H.ul $
- forM_ (Tree.axis_following_sibling z) $
- html5ToC d
- where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
- DTC.ToF{..} -> do
- H.nav ! HA.class_ "tof"
- ! HA.id (attrValue pos) $
- H.table ! HA.class_ "tof" $
- H.tbody $
- forM_ (Tree.axis_preceding z) $
- html5ToF d
- where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
- DTC.Figure{..} ->
- html5CommonAttrs attrs $
- H.div ! HA.class_ (attrValue $ "figure-"<>type_)
- ! HA.id (attrValue pos) $ do
- H.table ! HA.class_ "figure-caption" $
- H.tbody $
- H.tr $ do
- H.td ! HA.class_ "figure-number" $ do
- H.a ! HA.href "" $ H.toMarkup type_
- ": "
- H.td ! HA.class_ "figure-name" $
- H.toMarkup title
- H.div ! HA.class_ "figure-content" $ do
- html5Verticals verts
+cleanPara :: DTC.Para -> DTC.Para
+cleanPara p =
+ p >>= (`Tree.bindTrees` \case
+ TreeN DTC.Iref{} ls -> ls
+ TreeN DTC.Note{} _ -> mempty
+ h -> pure h)
-html5ToC :: Int -> BodyZip -> Html
-html5ToC depth z =
+html5ifyToC :: Maybe DTC.Nat -> BodyCursor -> Html5
+html5ifyToC depth z =
case Tree.current z of
TreeN DTC.Section{..} _ts -> do
- H.li $ do
- H.table ! HA.class_ "toc-entry" $
- H.tbody $
- H.tr $ do
- H.td $
- html5SectionRef $ xmlPosAncestors pos
- H.td $
- H.toMarkup title
- when (depth > 0) $
- H.ul $
- forM_ (Tree.axis_child z) $
- html5ToC (depth - 1)
- _ -> mempty
-
-html5ToF :: Int -> BodyZip -> Html
-html5ToF depth z =
- case Tree.current z of
- Tree0 bs ->
- forM_ bs $ \case
- DTC.Figure{..} ->
- H.tr $ do
- H.td ! HA.class_ "figure-number" $
- H.a ! HA.href (attrValue pos) $
- H.toMarkup type_
- H.td ! HA.class_ "figure-name" $
- H.toMarkup title
- _ -> mempty
- _ -> mempty
-
-textXmlPosAncestors :: [(XmlName,Int)] -> Text
-textXmlPosAncestors =
- snd . foldr (\(n,c) (nParent,acc) ->
- (n,
- (if Text.null acc
- then acc
- else acc <> ".") <>
- Text.pack
- (if n == nParent
- then show c
- else show n<>show c)
- )
- ) ("","")
-
-html5SectionNumber :: [(XmlName,Int)] -> Html
-html5SectionNumber = go [] . List.reverse
+ 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 $ cleanPara $ DTC.unTitle title
+ when (maybe True (> DTC.Nat 1) depth && not (null sections)) $
+ H.ul $$
+ forM_ sections $
+ html5ifyToC (depth >>= DTC.predNat)
+ _ -> pure ()
where
- go :: [(XmlName,Int)] -> [(XmlName,Int)] -> Html
- go _rs [] = mempty
- go rs (a@(_n,cnt):as) = do
- H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors (a:rs)) $
- H.toMarkup $ show cnt
- H.toMarkup '.'
- go (a:rs) as
-
-html5SectionRef :: [(XmlName,Int)] -> Html
-html5SectionRef as =
- H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors as) $
- case as of
- [(_n,c)] -> do
- H.toMarkup $ show c
- H.toMarkup '.'
- _ ->
- H.toMarkup $
- Text.intercalate "." $
- Text.pack . show . snd <$> as
+ sections =
+ (`Tree.runAxis` z) $
+ Tree.axis_child
+ `Tree.axis_filter_current` \case
+ TreeN DTC.Section{} _ -> True
+ _ -> False
-html5Verticals :: [DTC.Vertical] -> Html
-html5Verticals = foldMap html5Vertical
+html5ifyToF :: [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 $ cleanPara $ DTC.unTitle ti
-html5Vertical :: DTC.Vertical -> Html
-html5Vertical = \case
+instance Html5ify [DTC.Block] where
+ html5ify = mapM_ html5ify
+instance Html5ify DTC.Block where
+ html5ify = \case
DTC.Para{..} ->
html5CommonAttrs attrs $
- H.div ! HA.class_ "para"
- ! HA.id (attrValue pos) $ do
- html5Horizontals horis
+ H.p ! HA.class_ "para"
+ ! HA.id (attrify pos) $$ do
+ html5ify para
DTC.OL{..} ->
html5CommonAttrs attrs $
H.ol ! HA.class_ "ol"
- ! HA.id (attrValue pos) $ do
+ ! HA.id (attrify pos) $$ do
forM_ items $ \item ->
- H.li $ html5Verticals item
+ H.li $$ html5ify item
DTC.UL{..} ->
html5CommonAttrs attrs $
H.ul ! HA.class_ "ul"
- ! HA.id (attrValue pos) $ do
+ ! HA.id (attrify pos) $$ do
forM_ items $ \item ->
- H.li $ html5Verticals item
- DTC.RL{..} ->
- html5CommonAttrs attrs $
- H.div ! HA.class_ "rl"
- ! HA.id (attrValue pos) $ do
- H.table $
- forM_ refs html5Reference
+ H.li $$ html5ify item
DTC.Comment t ->
- H.Comment (H.Text t) ()
- {-
- Index{..} ->
- Artwork{..} ->
- -}
+ html5ify $ H.Comment (H.Text t) ()
+instance Html5ify DTC.Lines where
+ html5ify = \case
+ Tree0 v ->
+ case v of
+ DTC.BR -> html5ify H.br
+ DTC.Plain t -> html5ify t
+ TreeN k ls ->
+ case k of
+ DTC.B -> H.strong $$ html5ify ls
+ DTC.Code -> H.code $$ html5ify ls
+ DTC.Del -> H.del $$ html5ify ls
+ DTC.I -> 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}}
+ DTC.Sub -> H.sub $$ html5ify ls
+ DTC.Sup -> H.sup $$ html5ify ls
+ DTC.SC -> H.span ! HA.class_ "smallcaps" $$ html5ify ls
+ DTC.U -> H.span ! HA.class_ "underline" $$ html5ify ls
+ DTC.Note{..} ->
+ case number of
+ Nothing -> ""
+ Just num ->
+ H.sup ! HA.class_ "note-number" $$
+ H.a ! HA.class_ "note-ref"
+ ! HA.id ("note-ref."<>attrify num)
+ ! HA.href ("#note."<>attrify num) $$
+ html5ify num
+ DTC.Q -> do
+ depth <- liftStateMarkup $ do
+ depth <- S.gets $ Plain.state_quote . state_plainify
+ S.modify $ \s -> s{state_plainify=
+ (state_plainify s){Plain.state_quote=
+ DTC.succNat depth}}
+ return depth
+ H.span ! HA.class_ "q" $$ do
+ html5ify $ Plain.L10n_QuoteOpen depth
+ html5ify $ TreeN DTC.I ls
+ html5ify $ Plain.L10n_QuoteClose depth
+ liftStateMarkup $
+ S.modify $ \s ->
+ s{state_plainify=
+ (state_plainify s){Plain.state_quote = depth}}
+ DTC.Eref{..} ->
+ H.a ! HA.class_ "eref"
+ ! HA.href (attrify href) $$
+ if null ls
+ then html5ify $ DTC.unURL href
+ else html5ify ls
+ DTC.Iref{..} ->
+ case anchor of
+ Nothing -> html5ify ls
+ Just DTC.Anchor{..} ->
+ H.span ! HA.class_ "iref"
+ ! HA.id (attrifyIrefCount term count) $$
+ html5ify ls
+ DTC.Ref{..} ->
+ H.a ! HA.class_ "ref"
+ ! HA.href ("#"<>attrify to) $$
+ if null ls
+ then html5ify to
+ else html5ify ls
+ DTC.Rref{..} -> 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 DTC.About{..} -> do
+ when (not $ null ls) $
+ forM_ (List.take 1 titles) $ \(DTC.Title title) -> do
+ html5ify $ TreeN DTC.Q $
+ case url of
+ Nothing -> title
+ Just u -> pure $ TreeN (DTC.Eref u) title
+ " "::Html5
+ "["::Html5
+ H.a ! HA.class_ "rref"
+ ! HA.href ("#rref."<>attrify to)
+ ! HA.id ("rref."<>attrify to<>maybe "" (\DTC.Anchor{..} -> "."<>attrify count) anchor) $$
+ html5ify to
+ "]"
+instance Html5ify DTC.URL where
+ html5ify (DTC.URL url) =
+ H.a ! HA.class_ "eref"
+ ! HA.href (attrify url) $$
+ html5ify url
+instance Html5ify DTC.Date where
+ html5ify = html5ify . Plain.L10n_Date
+instance Html5ify DTC.About where
+ html5ify DTC.About{..} =
+ html5CommasDot $ concat $
+ [ html5Titles titles
+ , html5Entity <$> authors
+ , html5ify <$> maybeToList date
+ , html5Entity <$> maybeToList editor
+ , html5Serie <$> series
+ ]
+ where
+ html5Titles :: [DTC.Title] -> [Html5]
+ html5Titles ts | null ts = []
+ html5Titles ts = [html5Title $ fold $ List.intersperse t $ toList ts]
+ where t = DTC.Title $ Seq.singleton $ Tree0 $ DTC.Plain " — "
+ html5Title (DTC.Title title) =
+ html5ify $ TreeN DTC.Q $
+ case url of
+ Nothing -> title
+ Just u -> pure $ TreeN (DTC.Eref u) title
+ html5SerieHref href DTC.Serie{..} = do
+ sp <- liftStateMarkup $ S.gets state_plainify
+ html5ify $
+ TreeN DTC.Eref{href} $
+ Seq.fromList
+ [ Tree0 $ DTC.Plain $ name
+ , Tree0 $ DTC.Plain $ TL.toStrict $ Plain.text sp Plain.L10n_Colon
+ , Tree0 $ DTC.Plain key
+ ]
+ html5Serie s@DTC.Serie{name="RFC", key} | Text.all Char.isDigit key =
+ html5SerieHref (DTC.URL $ "https://tools.ietf.org/html/rfc"<>key) s
+ html5Serie s@DTC.Serie{name="DOI", key} =
+ html5SerieHref (DTC.URL $ "https://dx.doi.org/"<>key) s
+ html5Serie DTC.Serie{..} = do
+ html5ify name
+ html5ify Plain.L10n_Colon
+ html5ify key
+ html5Entity DTC.Entity{url=mu, ..} = do
+ html5ify @DTC.Lines $
+ case () of
+ _ | not (Text.null email) ->
+ TreeN (DTC.Eref $ DTC.URL $ "mailto:"<>email) $
+ pure $ Tree0 $ DTC.Plain name
+ _ | Just u <- mu ->
+ TreeN (DTC.Eref u) $
+ pure $ Tree0 $ DTC.Plain name
+ _ -> Tree0 $ DTC.Plain name
+ forM_ org $ \o -> do
+ " ("::Html5
+ html5Entity o
+ ")"::Html5
+instance Html5ify DTC.Reference where
+ html5ify DTC.Reference{id=id_, ..} =
+ H.tr $$ do
+ H.td ! HA.class_ "reference-key" $$
+ html5ify @DTC.Lines $ TreeN DTC.Rref{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) $ \DTC.Anchor{..} ->
+ H.a ! HA.class_ "reference-rref"
+ ! HA.href ("#rref."<>attrify id_<>"."<>attrify count) $$
+ html5ify $ DTC.posAncestors section
+instance Html5ify DTC.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 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'}
-html5Reference :: DTC.Reference -> Html
-html5Reference DTC.Reference{..} =
- H.tr $ do
- H.td ! HA.class_ "reference-key" $
- H.toMarkup id
- H.td ! HA.class_ "reference-content" $
- html5About about
+html5CommasDot :: [Html5] -> Html5
+html5CommasDot [] = pure ()
+html5CommasDot hs = do
+ sequence_ $ List.intersperse ", " hs
+ "."
-html5About :: DTC.About -> Html
-html5About DTC.About{..} =
- forM_ titles $ \(DTC.Title title) -> do
- html5Horizontal $ DTC.Q title
- {-
- authors
- editor
- date
- version
- keywords
- links
- series
- includes
- -}
+html5CommonAttrs :: DTC.CommonAttrs -> Html5 -> Html5
+html5CommonAttrs DTC.CommonAttrs{id=id_, ..} =
+ Compose . (addClass . addId <$>) . getCompose
+ where
+ addClass =
+ case classes of
+ [] -> id
+ _ -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)
+ addId = maybe id (\(DTC.Ident i) ->
+ H.AddCustomAttribute "id" (H.Text i)) id_
+
+html5SectionNumber :: DTC.PosPath -> Html5
+html5SectionNumber = go mempty
+ where
+ go :: DTC.PosPath -> DTC.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
-html5CommonAttrs :: DTC.CommonAttrs -> Html -> Html
-html5CommonAttrs DTC.CommonAttrs{..} =
- (case classes of
- [] -> \x -> x
- _ -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)) .
- case id of
- Nothing -> \x -> x
- Just (DTC.Ident i) ->
- H.AddCustomAttribute "id" (H.Text i)
+html5SectionRef :: DTC.PosPath -> Html5
+html5SectionRef as =
+ H.a ! HA.href ("#"<>attrify as) $$
+ html5ify as
-html5Horizontal :: DTC.Horizontal -> Html
-html5Horizontal = \case
- DTC.BR -> H.br
- DTC.B hs -> H.strong $ html5Horizontals hs
- DTC.Code hs -> H.code $ html5Horizontals hs
- DTC.Del hs -> H.del $ html5Horizontals hs
- DTC.I hs -> H.i $ html5Horizontals hs
- DTC.Note _ -> ""
- DTC.Q hs -> "« "<>H.i (html5Horizontals hs)<>" »"
- DTC.SC hs -> html5Horizontals hs
- DTC.Sub hs -> H.sub $ html5Horizontals hs
- DTC.Sup hs -> H.sup $ html5Horizontals hs
- DTC.U hs -> H.span ! HA.class_ "underline" $ html5Horizontals hs
- DTC.Eref{..} -> H.a ! HA.class_ "eref" ! HA.href (attrValue href) $ html5Horizontals text
- DTC.Iref{..} -> H.a ! HA.class_ "iref" ! HA.href (attrValue to) $ html5Horizontals text
- DTC.Ref{..} ->
- H.a ! HA.class_ "ref"
- ! HA.href ("#"<>attrValue to) $
- if null text
- then H.toMarkup to
- else html5Horizontals text
- DTC.Rref{..} -> H.a ! HA.class_ "rref" ! HA.href (attrValue to) $ html5Horizontals text
- DTC.Plain t -> H.toMarkup t
-html5Horizontals :: [DTC.Horizontal] -> Html
-html5Horizontals = mapM_ html5Horizontal
+-- * 'Attrify'
+instance Attrify DTC.Anchor where
+ attrify DTC.Anchor{..} =
+ attrify section
+ <> "." <> attrify count
+instance Attrify Plain where
+ attrify p =
+ let (t,_) = Plain.runPlain p def in
+ attrify t
+instance Attrify DTC.PosPath where
+ attrify = attrify . plainify
+instance Attrify DTC.Pos where
+ attrify = attrify . DTC.posAncestors
-textHorizontal :: DTC.Horizontal -> TL.Text
-textHorizontal = \case
- DTC.BR -> "\n"
- DTC.B hs -> "*"<>textHorizontals hs<>"*"
- DTC.Code hs -> "`"<>textHorizontals hs<>"`"
- DTC.Del hs -> "-"<>textHorizontals hs<>"-"
- DTC.I hs -> "/"<>textHorizontals hs<>"/"
- DTC.Note _ -> ""
- DTC.Q hs -> "« "<>textHorizontals hs<>" »"
- DTC.SC hs -> textHorizontals hs
- DTC.Sub hs -> textHorizontals hs
- DTC.Sup hs -> textHorizontals hs
- DTC.U hs -> "_"<>textHorizontals hs<>"_"
- DTC.Eref{..} -> textHorizontals text
- DTC.Iref{..} -> textHorizontals text
- DTC.Ref{..} -> textHorizontals text
- DTC.Rref{..} -> textHorizontals text
- DTC.Plain t -> TL.fromStrict t
+attrifyIref :: DTC.Words -> H.AttributeValue
+attrifyIref term =
+ "iref" <> "." <> attrify (Anchor.plainifyWords term)
+attrifyIrefCount :: DTC.Words -> DTC.Nat1 -> H.AttributeValue
+attrifyIrefCount term count =
+ "iref"
+ <> "." <> attrify (Anchor.plainifyWords term)
+ <> "." <> attrify count
-textHorizontals :: [DTC.Horizontal] -> TL.Text
-textHorizontals = foldMap textHorizontal
+-- * Type 'L10n'
+instance Html5ify Plain.L10n where
+ html5ify = html5ify . plainify
+instance Localize ls Plain Plain.L10n => Localize ls Html5 Plain.L10n where
+ localize loc a = html5ify (Locale.localize loc a::Plain)
+instance LocalizeIn FR Html5 Plain.L10n where
+ localizeIn loc = html5ify @Plain . localizeIn loc
+instance LocalizeIn EN Html5 Plain.L10n where
+ localizeIn loc = html5ify @Plain . localizeIn loc
sourcephile / git / doclang.git / blobdiff