From da9751720c16f9120250a15e83a98d69913e7982 Mon Sep 17 00:00:00 2001
From: Julien Moutinho <julm+tct@autogeree.net>
Date: Mon, 11 Dec 2017 02:22:06 +0100
Subject: [PATCH] Study StateMarkup.
---
Data/TreeSeq/Strict/Zipper.hs | 14 +-
Language/DTC/Write/HTML5.hs | 547 +++++++++++++++++-----------------
Text/Blaze/Utils.hs | 37 ++-
3 files changed, 317 insertions(+), 281 deletions(-)
diff --git a/Data/TreeSeq/Strict/Zipper.hs b/Data/TreeSeq/Strict/Zipper.hs
index 1df689b..c77073a 100644
--- a/Data/TreeSeq/Strict/Zipper.hs
+++ b/Data/TreeSeq/Strict/Zipper.hs
@@ -87,7 +87,7 @@ type Axis k a = Zipper k a -> [Zipper k a]
-- | Like 'Axis', but generalized with 'Alternative'.
--
-- Useful to return a 'Maybe' instead of a list.
-type AxisAlt f k a = Alternative f => Zipper k a -> f (Zipper k a)
+type AxisAlt f k a = Zipper k a -> f (Zipper k a)
-- | Collect all 'Zipper's along a given axis,
-- including the first 'Zipper'.
@@ -109,7 +109,7 @@ axis_child n =
axis_child_first n >>=
axis_collect axis_following_first
-axis_child_lookup_first :: (k -> Bool) -> AxisAlt f k a
+axis_child_lookup_first :: Alternative f => (k -> Bool) -> AxisAlt f k a
axis_child_lookup_first fk n = safeHead $ axis_child_lookup fk n
axis_child_lookup :: (k -> Bool) -> Axis k a
@@ -124,13 +124,13 @@ axis_child_lookup fk ns@(Node _ps t _fs :| _) =
flt (TreeN k _) = fk k
flt Tree0{} = False
-axis_child_first :: AxisAlt f k a
+axis_child_first :: Alternative f => AxisAlt f k a
axis_child_first ns@(Node _ps t _fs :| _) =
case Seq.viewl $ nodesTree t of
EmptyL -> empty
l :< ls -> pure $ Node mempty l ls :| NonEmpty.toList ns
-axis_child_last :: AxisAlt f k a
+axis_child_last :: Alternative f => AxisAlt f k a
axis_child_last ns@(Node _ps t _fs :| _) =
case Seq.viewr $ nodesTree t of
EmptyR -> empty
@@ -170,7 +170,7 @@ axis_descendant :: Axis k a
axis_descendant = List.tail . axis_descendant_or_self
-- ** Axis preceding
-axis_preceding_first :: AxisAlt f k a
+axis_preceding_first :: Alternative f => AxisAlt f k a
axis_preceding_first (Node ps t fs :| ns) =
case Seq.viewr ps of
EmptyR -> empty
@@ -186,7 +186,7 @@ axis_preceding =
axis_descendant_or_self_reverse
-- ** Axis following
-axis_following_first :: AxisAlt f k a
+axis_following_first :: Alternative f => AxisAlt f k a
axis_following_first (Node ps t fs :| ns) =
case Seq.viewl fs of
EmptyL -> empty
@@ -202,7 +202,7 @@ axis_following =
axis_descendant_or_self
-- ** Axis parent
-axis_parent :: AxisAlt f k a
+axis_parent :: Alternative f => AxisAlt f k a
axis_parent (Node ps t fs :| ns) =
case ns of
Node ps' (TreeN k _) fs' : ns' ->
diff --git a/Language/DTC/Write/HTML5.hs b/Language/DTC/Write/HTML5.hs
index 9cf2108..49d759e 100644
--- a/Language/DTC/Write/HTML5.hs
+++ b/Language/DTC/Write/HTML5.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
@@ -17,390 +18,390 @@ 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 qualified Data.TreeSeq.Strict as Tree
+import Control.Applicative (Applicative(..))
+import Control.Monad (Monad(..), forM_, mapM_, when{-, (>=>)-})
+import Data.Char (Char)
import Data.Eq (Eq(..))
-import Data.Ord (Ord(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
+import Data.Functor.Compose (Compose(..))
import Data.Int (Int)
+import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..))
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(..))
import Data.Tuple (snd)
import Prelude (Num(..))
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.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
+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)
+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 qualified Language.DTC.Document as DTC
-
-- import Debug.Trace (trace)
-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 StateHtml5 ()
--- * Type 'InhHtml5'
-data InhHtml5
- = InhHtml5
- { inhHtml5_localize :: MsgHtml5 -> Html
+-- ** Type 'StateHtml5'
+data StateHtml5
+ = StateHtml5
+ { styles :: Map Text CSS
+ , scripts :: Map Text Script
+ , localize :: MsgHtml5 -> Html5
}
-inhHtml5 :: InhHtml5
-inhHtml5 = InhHtml5
- { inhHtml5_localize = localizeIn @EN EN_US
+stateHtml5 :: StateHtml5
+stateHtml5 = StateHtml5
+ { styles = mempty
+ , scripts = mempty
+ , localize = html5ify . show
}
+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 $$
--}
+-- ** 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 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.Ident where
+ html5ify (DTC.Ident i) = html5ify i
-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
-
-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
html5Document ::
- Localize ls Html MsgHtml5 =>
+ Localize ls Html5 MsgHtml5 =>
+ Locales ls =>
LocaleIn ls -> Document -> Html
-html5Document loc DTC.Document{..} = do
- let inh = InhHtml5
- { inhHtml5_localize = localize loc
- }
+html5Document locale DTC.Document{..} = do
+ let (h, StateHtml5{..}) =
+ runStateMarkup stateHtml5 $ do
+ liftStateMarkup $ S.modify $ \s -> s{localize = Locale.localize locale}
+ html5ify body
H.docType
- H.html $ do
+ H.html ! HA.lang (attrValue $ 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
+ H.title $
+ H.toMarkup $
+ plainify $
+ List.head $
+ (DTC.unTitle <$> ts) <> [[DTC.Plain ""]]
-- link ! rel "Chapter" ! title "SomeTitle">
+ H.meta ! HA.name "generator"
+ ! HA.content "tct"
H.link ! HA.rel "stylesheet"
! HA.type_ "text/css"
! HA.href "style/dtc-html5.css"
- H.body $
- html5Body inh body
+ forM_ styles $ \style ->
+ H.style ! HA.type_ "text/css" $
+ H.toMarkup style
+ forM_ scripts $ \script ->
+ H.script ! HA.type_ "application/javascript" $
+ H.toMarkup script
+ H.body h
-- * Type 'BodyZip'
+-- | Cursor to navigate within a 'DTC.Body' according to many axis (like in XSLT).
type BodyZip = Tree.Zipper DTC.BodyKey (Seq DTC.BodyValue)
+instance Html5ify DTC.Body where
+ html5ify body =
+ forM_ (Tree.zippers body) $
+ html5ify
-html5Body :: InhHtml5 -> DTC.Body -> Html
-html5Body inh body =
- forM_ (Tree.zippers body) $
- html5BodyZipper inh
-
-html5BodyZipper :: InhHtml5 -> BodyZip -> Html
-html5BodyZipper inh z =
- case Tree.current z of
- TreeN k _ts -> html5BodyKey inh z k
- Tree0 vs -> forM_ vs $ html5BodyValue inh z
+instance Html5ify BodyZip where
+ html5ify z =
+ case Tree.current z of
+ TreeN k _ts -> html5BodyKey z k
+ Tree0 vs -> forM_ vs $ html5BodyValue z
-html5BodyKey :: InhHtml5 -> BodyZip -> DTC.BodyKey -> Html
-html5BodyKey inh z = \case
+html5BodyKey :: BodyZip -> DTC.BodyKey -> Html5
+html5BodyKey z = \case
DTC.Section{..} ->
- H.section
- ! HA.class_ "section"
- ! HA.id (attrValue pos) $ do
+ H.section ! HA.class_ "section"
+ ! HA.id (attrValue pos) $$ do
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
+ 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
+ html5ify title
forM_ (Tree.axis_child z) $
- html5BodyZipper inh
-
-html5BodyValue :: InhHtml5 -> BodyZip -> DTC.BodyValue -> Html
-html5BodyValue InhHtml5{..} z = \ case
+ html5ify
+html5BodyValue :: BodyZip -> DTC.BodyValue -> Html5
+html5BodyValue z = \case
DTC.Vertical v -> do
- html5Vertical v
+ html5ify 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 $
+ ! HA.id (attrValue pos) $$ do
+ H.span ! HA.class_ "toc-name" $$
+ H.a ! HA.href (attrValue pos) $$
+ html5ify 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 $
+ ! 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_
+ ! 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 ("#"<>attrValue pos) $$
+ html5ify type_
": "
- H.td ! HA.class_ "figure-name" $
- H.toMarkup title
- H.div ! HA.class_ "figure-content" $ do
- html5Verticals verts
-
-html5ToC :: Int -> BodyZip -> Html
+ H.td ! HA.class_ "figure-name" $$
+ html5ify title
+ H.div ! HA.class_ "figure-content" $$ do
+ html5ify verts
+html5ToC :: Int -> BodyZip -> Html5
html5ToC 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 $
+ H.li $$ do
+ H.table ! HA.class_ "toc-entry" $$
+ H.tbody $$
+ H.tr $$ do
+ H.td $$
html5SectionRef $ xmlPosAncestors pos
- H.td $
- H.toMarkup title
+ H.td $$
+ html5ify title
when (depth > 0) $
- H.ul $
+ H.ul $$
forM_ (Tree.axis_child z) $
html5ToC (depth - 1)
- _ -> mempty
-
-html5ToF :: Int -> BodyZip -> Html
+ _ -> pure ()
+html5ToF :: Int -> BodyZip -> Html5
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
+ H.tr $$ do
+ H.td ! HA.class_ "figure-number" $$
+ H.a ! HA.href ("#"<>attrValue pos) $$
+ html5ify type_
+ H.td ! HA.class_ "figure-name" $$
+ html5ify title
+ _ -> pure ()
+ _ -> pure ()
-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
- 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
-
-html5Verticals :: [DTC.Vertical] -> Html
-html5Verticals = foldMap html5Vertical
-
-html5Vertical :: DTC.Vertical -> Html
-html5Vertical = \case
+instance Html5ify [DTC.Vertical] where
+ html5ify = mapM_ html5ify
+instance Html5ify DTC.Vertical where
+ html5ify = \case
DTC.Para{..} ->
html5CommonAttrs attrs $
H.div ! HA.class_ "para"
- ! HA.id (attrValue pos) $ do
- html5Horizontals horis
+ ! HA.id (attrValue pos) $$ do
+ html5ify horis
DTC.OL{..} ->
html5CommonAttrs attrs $
H.ol ! HA.class_ "ol"
- ! HA.id (attrValue pos) $ do
+ ! HA.id (attrValue 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 (attrValue pos) $$ do
forM_ items $ \item ->
- H.li $ html5Verticals item
+ H.li $$ html5ify item
DTC.RL{..} ->
html5CommonAttrs attrs $
H.div ! HA.class_ "rl"
- ! HA.id (attrValue pos) $ do
- H.table $
- forM_ refs html5Reference
+ ! HA.id (attrValue pos) $$ do
+ H.table $$
+ forM_ refs html5ify
DTC.Comment t ->
- H.Comment (H.Text t) ()
+ html5ify $ H.Comment (H.Text t) ()
{-
Index{..} ->
Artwork{..} ->
-}
+instance Html5ify DTC.Horizontal where
+ html5ify = \case
+ DTC.BR -> html5ify H.br
+ DTC.B hs -> H.strong $$ html5ify hs
+ DTC.Code hs -> H.code $$ html5ify hs
+ DTC.Del hs -> H.del $$ html5ify hs
+ DTC.I hs -> H.i $$ html5ify hs
+ DTC.Note _ -> ""
+ DTC.Q hs -> do
+ "« "::Html5
+ H.i $$ html5ify hs
+ " »"
+ DTC.SC hs -> html5ify hs
+ DTC.Sub hs -> H.sub $$ html5ify hs
+ DTC.Sup hs -> H.sup $$ html5ify hs
+ DTC.U hs -> H.span ! HA.class_ "underline" $$ html5ify hs
+ DTC.Eref{..} ->
+ H.a ! HA.class_ "eref"
+ ! HA.href (attrValue href) $$
+ html5ify text
+ DTC.Iref{..} ->
+ H.a ! HA.class_ "iref"
+ ! HA.href (attrValue to) $$
+ html5ify text
+ DTC.Ref{..} ->
+ H.a ! HA.class_ "ref"
+ ! HA.href ("#"<>attrValue to) $$
+ if null text
+ then html5ify to
+ else html5ify text
+ DTC.Rref{..} ->
+ H.a ! HA.class_ "rref"
+ ! HA.href (attrValue to) $$
+ html5ify text
+ DTC.Plain t -> Compose $ return $ H.toMarkup t
+instance Html5ify [DTC.Horizontal] where
+ html5ify = mapM_ html5ify
+instance Html5ify DTC.About where
+ html5ify DTC.About{..} =
+ forM_ titles $ \(DTC.Title title) ->
+ html5ify $ DTC.Q title
+instance Html5ify DTC.Reference where
+ html5ify DTC.Reference{..} =
+ H.tr $$ do
+ H.td ! HA.class_ "reference-key" $$
+ html5ify id
+ H.td ! HA.class_ "reference-content" $$
+ html5ify about
-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
-
-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 -> Html -> Html
+html5CommonAttrs :: DTC.CommonAttrs -> Html5 -> Html5
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) ->
+ Compose . (addClass . addId <$>) . getCompose
+ where
+ addClass =
+ case classes of
+ [] -> \x -> x
+ _ -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)
+ addId =
+ case id of
+ Nothing -> \x -> x
+ Just (DTC.Ident i) ->
H.AddCustomAttribute "id" (H.Text i)
-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
+html5SectionNumber :: [(XmlName,Int)] -> Html5
+html5SectionNumber = go [] . List.reverse
+ where
+ go :: [(XmlName,Int)] -> [(XmlName,Int)] -> Html5
+ go _rs [] = pure ()
+ go rs (a@(_n,cnt):as) = do
+ H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors (a:rs)) $$
+ html5ify $ show cnt
+ html5ify '.'
+ go (a:rs) as
+
+html5SectionRef :: [(XmlName,Int)] -> Html5
+html5SectionRef as =
+ H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors as) $$
+ case as of
+ [(_n,c)] -> do
+ html5ify $ show c
+ html5ify '.'
+ _ ->
+ html5ify $
+ Text.intercalate "." $
+ Text.pack . show . snd <$> as
-html5Horizontals :: [DTC.Horizontal] -> Html
-html5Horizontals = mapM_ html5Horizontal
+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)
+ )
+ )
+ ("","")
-textHorizontal :: DTC.Horizontal -> TL.Text
-textHorizontal = \case
+-- * Class 'Plainify'
+class Plainify a where
+ plainify :: a -> TL.Text
+instance Plainify DTC.Horizontal where
+ plainify = \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.B hs -> "*"<>plainify hs<>"*"
+ DTC.Code hs -> "`"<>plainify hs<>"`"
+ DTC.Del hs -> "-"<>plainify hs<>"-"
+ DTC.I hs -> "/"<>plainify 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.Q hs -> "« "<>plainify hs<>" »"
+ DTC.SC hs -> plainify hs
+ DTC.Sub hs -> plainify hs
+ DTC.Sup hs -> plainify hs
+ DTC.U hs -> "_"<>plainify hs<>"_"
+ DTC.Eref{..} -> plainify text
+ DTC.Iref{..} -> plainify text
+ DTC.Ref{..} -> plainify text
+ DTC.Rref{..} -> plainify text
DTC.Plain t -> TL.fromStrict t
+instance Plainify [DTC.Horizontal] where
+ plainify = foldMap plainify
+
+instance AttrValue XmlPos where
+ attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors
-textHorizontals :: [DTC.Horizontal] -> TL.Text
-textHorizontals = foldMap textHorizontal
+-- * Type 'MsgHtml5'
+data MsgHtml5
+ = MsgHTML5_Table_of_Contents
+ deriving (Show)
+instance Html5ify MsgHtml5 where
+ html5ify msg = do
+ loc <- liftStateMarkup $ S.gets localize
+ loc msg
+instance LocalizeIn FR Html5 MsgHtml5 where
+ localizeIn _ MsgHTML5_Table_of_Contents = "Sommaire"
+instance LocalizeIn EN Html5 MsgHtml5 where
+ localizeIn _ MsgHTML5_Table_of_Contents = "Summary"
diff --git a/Text/Blaze/Utils.hs b/Text/Blaze/Utils.hs
index e4635f1..6e45782 100644
--- a/Text/Blaze/Utils.hs
+++ b/Text/Blaze/Utils.hs
@@ -12,19 +12,21 @@ import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function ((.), ($))
import Data.Functor ((<$>))
+import Data.Functor.Compose (Compose(..))
import Data.Int (Int)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Data.Text (Text)
-import Prelude (Num(..))
+import Prelude (Num(..), undefined)
import System.IO (IO)
import Text.Blaze as B
import Text.Blaze.Internal as B hiding (null)
import Text.Show (Show(..))
import qualified Blaze.ByteString.Builder as BS
import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
+import qualified Control.Monad.Trans.State as S
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
@@ -81,6 +83,39 @@ instance MayAttr [Char] where
mayAttr _ "" = Nothing
mayAttr a t = Just (a $ fromString t)
+-- * Type 'StateMarkup'
+-- | Composing state and markups.
+type StateMarkup st = Compose (S.State st) B.MarkupM
+instance Monad (StateMarkup st) where
+ return = pure
+ Compose sma >>= a2csmb =
+ Compose $ sma >>= \ma ->
+ case ma >>= B.Empty . a2csmb of
+ B.Append _ma (B.Empty csmb) ->
+ B.Append ma <$> getCompose csmb
+ _ -> undefined
+instance IsString (StateMarkup st ()) where
+ fromString = Compose . return . fromString
+
+-- | Lift a 'B.MarkupM' constructor to a 'StateMarkup' one.
+($$) :: (B.MarkupM a -> B.MarkupM a) -> StateMarkup st a -> StateMarkup st a
+($$) f m = Compose $ f <$> getCompose m
+infixr 0 $$
+
+liftStateMarkup :: S.State st a -> StateMarkup st a
+liftStateMarkup = Compose . (return <$>)
+
+runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
+runStateMarkup st = (`S.runState` st) . getCompose
+
+local :: Monad m => (s -> s) -> S.StateT s m b -> S.StateT s m b
+local f a = do
+ s <- S.get
+ S.put (f s)
+ r <- a
+ S.put s
+ return r
+
-- * Type 'IndentTag'
data IndentTag
= IndentTagChildren
--
2.47.2