{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.DTC.Write.HTML5 where
--- import Control.Monad.Trans.Class (MonadTrans(..))
--- import Data.Functor.Identity (Identity(..))
--- 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.Category as Cat
import Control.Monad
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
-import Data.Foldable (Foldable(..))
+import Data.Foldable (Foldable(..), concat, any)
import Data.Function (($), const, flip, on)
import Data.Functor (Functor(..), (<$>))
import Data.Functor.Compose (Compose(..))
import Data.Int (Int)
import Data.Map.Strict (Map)
-import Data.Maybe (Maybe(..), mapMaybe, fromJust)
+import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
-import Data.String (String)
+import Data.String (String, IsString(..))
import Data.Text (Text)
-import Data.TreeSeq.Strict (Tree(..), Trees)
+import Data.TreeSeq.Strict (Tree(..), tree0)
import Data.Tuple (snd)
-import Prelude (Num(..))
import System.FilePath (FilePath)
import Text.Blaze ((!))
import Text.Blaze.Html (Html)
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 Text.Blaze.Utils
-import Data.Locale hiding (localize, Index)
+import Data.Locale hiding (Index)
import qualified Data.Locale as Locale
-import Language.DTC.Document (Document)
+import Language.DTC.Document as DTC
+import Language.DTC.Write.Plain (Plainify(..))
import Language.DTC.Write.XML ()
-import Language.XML (XmlName(..), XmlPos(..))
-import qualified Language.DTC.Document as DTC
-import qualified Language.DTC.Index as Index
--- import Debug.Trace (trace)
+import qualified Language.DTC.Anchor as Anchor
+import qualified Language.DTC.Write.Plain as Plain
+
+document ::
+ Localize locales Plain.Plain Plain.L10n =>
+ Localize locales Html5 L10n =>
+ Locales locales =>
+ LocaleIn locales -> DTC.Document -> Html
+document 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, endState) =
+ runStateMarkup def
+ { state_indexs
+ , state_rrefs
+ , state_notes
+ , state_figures = keys_figure
+ , state_references = keys_reference
+ , state_plainify
+ , state_localize = Locale.localize locale
+ } $ do
+ html5DocumentHead head
+ html5ify body'
+ H.docType
+ H.html ! HA.lang (attrify $ countryCode locale) $ do
+ html5Head endState head body
+ H.body $ html5Body
+
+html5Head :: State -> Head -> Body -> Html
+html5Head 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)
+ H.meta ! HA.name "generator"
+ ! HA.content "https://hackage.haskell.org/package/hdoc"
+ 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
+ H.link ! HA.rel "stylesheet"
+ ! HA.type_ "text/css"
+ ! HA.href "style/dtc-html5.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
+ 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 $ html5ify L10n_Header_Date
+ headerValue $ html5ify d
+ forM_ url $ \href ->
+ header $ do
+ headerName $ html5ify L10n_Header_Address
+ 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
+ html5ify Plain.L10n_Colon
+ headerValue :: Html5 -> Html5
+ headerValue h =
+ H.td ! HA.class_ "header-value" $$ do
+ h
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip (<$>)
-- * Type 'Html5'
type Html5 = StateMarkup State ()
+instance IsString Html5 where
+ fromString = html5ify
--- ** Type 'State'
+-- * Type 'State'
data State
= State
- { styles :: Map FilePath CSS
- , scripts :: Map FilePath Script
- , localize :: MsgHtml5 -> Html5
- , indexs :: Map XmlPos (DTC.Terms, Index.Refs)
- }
-state :: State
-state = State
- { styles = mempty
- , scripts = mempty
- , localize = html5ify . show
- , indexs = mempty
+ { state_styles :: Map FilePath CSS
+ , state_scripts :: Map FilePath Script
+ , 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_localize :: 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_localize = html5ify . show
+ }
type CSS = Text
type Script = Text
--- ** Type 'Keys'
+-- * Type 'Keys'
data Keys
= Keys
- { keys_index :: Map XmlPos DTC.Terms
+ { 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
-keys :: Trees DTC.BodyKey DTC.BodyValue -> Keys
-keys body = foldl' flt (Keys mempty) (Compose body)
- where
- flt acc = \case
- DTC.Index{..} -> acc{keys_index =
- Map.insert pos terms $ keys_index acc}
- _ -> acc
+-- ** 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'
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 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
-
-html5Document ::
- Localize ls Html5 MsgHtml5 =>
- Locales ls =>
- LocaleIn ls -> Document -> Html
-html5Document locale DTC.Document{..} = do
- let Keys{..} = keys body
- let (body',indexs) =
- case foldMap Index.refsOfTerms keys_index of
- refs | null refs -> (body, mempty)
- | otherwise ->
- (<$> S.runState
- (Index.indexify body)
- Index.state
- { Index.state_refs = refs
- }) $ \Index.State{state_refs} ->
- (<$> keys_index) $ \terms ->
- (terms,) $
- TreeMap.intersection const state_refs $
- Index.refsOfTerms terms
- let (html5Body, State{styles,scripts}) =
- runStateMarkup state{indexs} $ do
- liftStateMarkup $ S.modify $ \s -> s{localize = Locale.localize locale}
- html5ify body'
-
- H.docType
- 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 ->
- H.title $
- H.toMarkup $ plainify $ List.head ts
- forM_ (DTC.links $ DTC.about (head :: DTC.Head)) $ \DTC.Link{rel, href} ->
- H.link ! HA.rel (attrValue rel)
- ! HA.href (attrValue 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 (attrValue $ plainify title)
- ! HA.href ("#"<>attrValue pos)
- H.link ! HA.rel "stylesheet"
- ! HA.type_ "text/css"
- ! HA.href "style/dtc-html5.css"
- 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
- html5Body
+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 'DTC.Body' according to many axis (like in XSLT).
-type BodyCursor = Tree.Zipper DTC.BodyKey DTC.BodyValue
-instance Html5ify DTC.Body where
+-- | 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 =
- case Tree.current z of
- TreeN k _ts -> html5BodyKey z k
- Tree0 v -> html5BodyValue z v
-
-html5BodyKey :: BodyCursor -> DTC.BodyKey -> Html5
-html5BodyKey z = \case
- DTC.Section{..} ->
+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) $$
+ html5ify Plain.L10n_Table_of_Contents
+ 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 (attrValue pos) $$ do
- html5CommonAttrs attrs $
- H.table ! HA.class_ "section-header" $$
+ ! 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 $
- xmlPosAncestors pos
+ html5SectionNumber $ DTC.posAncestors pos
H.td ! HA.class_ "section-title" $$ do
- (case List.length $ xmlPosAncestors pos of
+ (case List.length $ DTC.posAncestors pos of
0 -> H.h1
1 -> H.h2
2 -> H.h3
html5ify title
forM_ (Tree.axis_child `Tree.runAxis` z) $
html5ify
-html5BodyValue :: BodyCursor -> DTC.BodyValue -> Html5
-html5BodyValue z = \case
- DTC.Block b -> html5ify b
- 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) $$
- html5ify MsgHTML5_Table_of_Contents
- H.ul $$
- forM_ (Tree.axis_following_sibling `Tree.runAxis` z) $
- html5ToC d
- where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
- DTC.ToF{..} -> do
+ 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 (attrValue pos) $$
+ ! HA.id (attrify pos) $$
H.table ! HA.class_ "tof" $$
H.tbody $$
- forM_ (Tree.axis_preceding `Tree.runAxis` 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
+ 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
- H.td ! HA.class_ "figure-number" $$ do
- H.a ! HA.href ("#"<>attrValue pos) $$
- html5ify type_
- ": "
- H.td ! HA.class_ "figure-name" $$
- html5ify title
+ 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 pos) $$ do
+ html5ify type_
+ html5ify $ DTC.posAncestors pos
+ forM_ mayTitle $ \title ->
+ H.td ! HA.class_ "figure-title" $$ do
+ unless (TL.null type_) $
+ html5ify $ Plain.L10n_Colon
+ html5ify title
H.div ! HA.class_ "figure-content" $$ do
- html5ify blocks
- DTC.Index{pos} -> do
- (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . indexs
- let chars = Index.termsByChar allTerms
+ 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 (attrValue pos) $$ do
- H.nav ! HA.class_ "index-nav-chars" $$ do
+ ! HA.id (attrify pos) $$ do
+ H.nav ! HA.class_ "index-nav" $$ do
forM_ (Map.keys chars) $ \char ->
- H.a ! HA.href ("#"<>(attrValue pos <> "." <> attrValue char)) $$
+ H.a ! HA.href ("#"<>(attrify pos <> "." <> attrify char)) $$
html5ify char
- H.dl $$
+ H.dl ! HA.class_ "index-chars" $$
forM_ (Map.toList chars) $ \(char,terms) -> do
H.dt $$
- let i = attrValue pos <> "." <> attrValue char in
+ let i = attrify pos <> "." <> attrify char in
H.a ! HA.id i
! HA.href ("#"<>i) $$
html5ify char
H.dd $$
- H.dl ! HA.class_ "index-char-refs" $$ do
+ H.dl ! HA.class_ "index-term" $$ do
forM_ terms $ \aliases -> do
H.dt $$
- forM_ aliases $ \term ->
- H.ul $$
- H.li ! HA.id (attrValue Index.Ref{term, count=0, section=def}) $$
+ H.ul ! HA.class_ "index-aliases" $$
+ forM_ (List.take 1 aliases) $ \term ->
+ H.li ! HA.id (attrifyIref term) $$
html5ify term
- H.dd $$ do
- let refs =
- List.sortBy
- (compare `on` Index.section) $
- (`foldMap` aliases) $ \words -> fromJust $ do
- path <- Index.pathFromWords words
- Strict.maybe Nothing Just $
- TreeMap.lookup path refsByTerm
- sequence_ $
- List.intersperse ", " $
- (<$> refs) $ \ref@Index.Ref{..} ->
- H.a ! HA.href ("#"<>attrValue ref) $$
- html5ify $
- List.intercalate "." $
- List.reverse $
- (<$> xmlPosAncestors section) $ \(_n,c) -> show c
-
-instance Html5ify DTC.Words where
- html5ify = html5ify . Index.plainifyWords
+ 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
-html5ToC :: Int -> BodyCursor -> Html5
-html5ToC depth z =
- case Tree.current z of
- TreeN DTC.Section{..} _ts -> do
+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 $ xmlPosAncestors pos
+ html5SectionRef $ DTC.posAncestors pos
H.td ! HA.class_ "section-title" $$
- html5ify $
- DTC.unTitle title >>= \ts -> Tree.bindTrees ts $ \case
- TreeN DTC.Iref{} ls -> ls
- TreeN DTC.Note{} _ -> mempty
- h -> pure h
- let sections =
- (`Tree.runAxis` z) $
- Tree.axis_child
- `Tree.axis_filter_current` \case
- TreeN DTC.Section{} _ -> True
- _ -> False
- when (depth > 0 && not (null sections)) $
+ html5ify $ cleanPlain $ unTitle title
+ when (maybe True (> Nat 1) depth && not (null sections)) $
H.ul $$
forM_ sections $
- html5ToC (depth - 1)
+ html5ifyToC (depth >>= predNat)
_ -> pure ()
+ where
+ sections =
+ (`Tree.runAxis` z) $
+ Tree.axis_child
+ `Tree.axis_filter_current` \case
+ Tree BodySection{} _ -> True
+ _ -> False
-html5ToF :: Int -> BodyCursor -> Html5
-html5ToF depth z =
- case Tree.current z of
- Tree0 v ->
- case v of
- DTC.Figure{..} ->
- 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 ()
+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
-instance Html5ify [DTC.Block] where
- html5ify = mapM_ html5ify
-instance Html5ify DTC.Block where
+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
- DTC.Para{..} ->
- html5CommonAttrs attrs $
- H.p ! HA.class_ "para"
- ! HA.id (attrValue pos) $$ do
- html5ify lines
- DTC.OL{..} ->
- html5CommonAttrs attrs $
- H.ol ! HA.class_ "ol"
- ! HA.id (attrValue pos) $$ do
- forM_ items $ \item ->
- H.li $$ html5ify item
- DTC.UL{..} ->
- html5CommonAttrs attrs $
- H.ul ! HA.class_ "ul"
- ! HA.id (attrValue pos) $$ do
+ 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 ->
- H.li $$ html5ify item
- DTC.RL{..} ->
- html5CommonAttrs attrs $
- H.div ! HA.class_ "rl"
- ! HA.id (attrValue pos) $$ do
- H.table $$
- forM_ refs html5ify
- DTC.Comment t ->
- html5ify $ H.Comment (H.Text t) ()
-instance Html5ify DTC.Lines where
- html5ify = mapM_ $ \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 -> H.i $$ html5ify ls
- 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 -> ""
- DTC.Q ->
- H.span ! HA.class_ "q" $$ do
- "« "::Html5
- H.i $$ html5ify ls
- " »"
- DTC.Eref{..} ->
- H.a ! HA.class_ "eref"
- ! HA.href (attrValue href) $$
- html5ify ls
- DTC.Iref{..} ->
- H.span ! HA.class_ "iref"
- ! HA.id (attrValue Index.Ref{term, count, section=def}) $$
- html5ify ls
- DTC.Ref{..} ->
- H.a ! HA.class_ "ref"
- ! HA.href ("#"<>attrValue to) $$
+ 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
+ depth <- liftStateMarkup $ do
+ depth <- S.gets $ Plain.state_quote . state_plainify
+ S.modify $ \s -> s{state_plainify=
+ (state_plainify s){Plain.state_quote=
+ succNat depth}}
+ return depth
+ H.span ! HA.class_ "q" $$ do
+ html5ify $ Plain.L10n_QuoteOpen depth
+ html5ify $ Tree PlainI ls
+ html5ify $ Plain.L10n_QuoteClose depth
+ liftStateMarkup $
+ S.modify $ \s ->
+ s{state_plainify=
+ (state_plainify s){Plain.state_quote = depth}}
+ PlainEref{..} ->
+ H.a ! HA.class_ "eref"
+ ! HA.href (attrify href) $$
if null ls
- then html5ify to
+ then html5ify $ unURL href
else html5ify ls
- DTC.Rref{..} ->
- H.a ! HA.class_ "rref"
- ! HA.href (attrValue to) $$
+ PlainIref{..} ->
+ case anchor of
+ Nothing -> html5ify ls
+ Just Anchor{..} ->
+ H.span ! HA.class_ "iref"
+ ! HA.id (attrifyIrefCount term count) $$
html5ify ls
-instance AttrValue Index.Ref where
- attrValue Index.Ref{..} =
- "iref" <> "." <> attrValue (Index.plainifyWords term) <>
- if count > 0
- then "." <> attrValue count
- else ""
-instance Html5ify DTC.About where
- html5ify DTC.About{..} =
- forM_ titles $ \(DTC.Title title) ->
- html5ify $ Seq.singleton $ TreeN DTC.Q title
-instance Html5ify DTC.Reference where
- html5ify DTC.Reference{id=id_, ..} =
+ 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
+ case urlSerie s of
+ Nothing -> do
+ html5ify name
+ html5ify Plain.L10n_Colon
+ html5ify id_
+ Just href -> do
+ sp <- liftStateMarkup $ S.gets state_plainify
+ html5ify $
+ Tree PlainEref{href} $
+ Seq.fromList
+ [ tree0 $ PlainText $ name
+ , tree0 $ PlainText $ Plain.text sp Plain.L10n_Colon
+ , 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 = html5ify . Plain.L10n_Date
+instance Html5ify Reference where
+ html5ify Reference{id=id_, ..} =
H.tr $$ do
H.td ! HA.class_ "reference-key" $$
- html5ify id_
- H.td ! HA.class_ "reference-content" $$
+ html5ify $ Tree PlainRref{anchor=Nothing, to=id_} Seq.empty
+ H.td ! HA.class_ "reference-content" $$ do
html5ify about
-
-html5CommonAttrs :: DTC.CommonAttrs -> Html5 -> Html5
-html5CommonAttrs DTC.CommonAttrs{id=id_, ..} =
- 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)
-
-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
+ 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
-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)
- )
- )
- ("","")
+html5CommonAttrs :: CommonAttrs -> Html5 -> Html5
+html5CommonAttrs CommonAttrs{id=id_, ..} =
+ html5AttrClass classes .
+ maybe Cat.id html5AttrId id_
--- * Class 'Plainify'
-class Plainify a where
- plainify :: a -> TL.Text
-instance Plainify TL.Text where
- plainify = id
-instance Plainify Text where
- plainify = TL.fromStrict
-instance Plainify DTC.Lines where
- plainify = foldMap $ \case
- Tree0 v ->
- case v of
- DTC.BR -> "\n"
- DTC.Plain p -> plainify p
- TreeN k ls ->
- case k of
- DTC.B -> "*"<>plainify ls<>"*"
- DTC.Code -> "`"<>plainify ls<>"`"
- DTC.Del -> "-"<>plainify ls<>"-"
- DTC.I -> "/"<>plainify ls<>"/"
- DTC.Note -> ""
- DTC.Q -> "« "<>plainify ls<>" »"
- DTC.SC -> plainify ls
- DTC.Sub -> plainify ls
- DTC.Sup -> plainify ls
- DTC.U -> "_"<>plainify ls<>"_"
- DTC.Eref{..} -> plainify ls
- DTC.Iref{..} -> plainify ls
- DTC.Ref{..} -> plainify ls
- DTC.Rref{..} -> plainify ls
-instance Plainify DTC.Title where
- plainify (DTC.Title t) = plainify t
+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
-instance AttrValue XmlPos where
- attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors
+-- * '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
--- * Type 'MsgHtml5'
-data MsgHtml5
- = MsgHTML5_Table_of_Contents
+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
+
+-- * Type 'L10n'
+data L10n
+ = L10n_Header_Address
+ | L10n_Header_Date
+ | L10n_Header_Version
+ | L10n_Header_Origin
+ | L10n_Header_Source
deriving (Show)
-instance Html5ify MsgHtml5 where
+instance Html5ify L10n where
html5ify msg = do
- loc <- liftStateMarkup $ S.gets localize
+ loc <- liftStateMarkup $ S.gets state_localize
loc msg
-instance LocalizeIn FR Html5 MsgHtml5 where
+instance LocalizeIn EN Html5 L10n where
localizeIn _ = \case
- MsgHTML5_Table_of_Contents -> "Sommaire"
-instance LocalizeIn EN Html5 MsgHtml5 where
+ L10n_Header_Address -> "Address"
+ L10n_Header_Date -> "Date"
+ L10n_Header_Origin -> "Origin"
+ L10n_Header_Source -> "Source"
+ L10n_Header_Version -> "Version"
+instance LocalizeIn FR Html5 L10n where
localizeIn _ = \case
- MsgHTML5_Table_of_Contents -> "Summary"
+ L10n_Header_Address -> "Adresse"
+ L10n_Header_Date -> "Date"
+ L10n_Header_Origin -> "Origine"
+ L10n_Header_Source -> "Source"
+ L10n_Header_Version -> "Version"
+
+instance Html5ify Plain.L10n where
+ html5ify = html5ify . plainify
+instance Localize ls Plain.Plain Plain.L10n => Localize ls Html5 Plain.L10n where
+ localize loc a = html5ify (Locale.localize loc a::Plain.Plain)
+instance LocalizeIn FR Html5 Plain.L10n where
+ localizeIn loc = html5ify @Plain.Plain . localizeIn loc
+instance LocalizeIn EN Html5 Plain.L10n where
+ localizeIn loc = html5ify @Plain.Plain . localizeIn loc
sourcephile / git / doclang.git / blobdiff