unTree (TreeN k _) = k
unTree (Tree0 a) = a
-mapWithKey :: (Maybe k -> a -> b) -> Tree k a -> Tree k b
-mapWithKey = go Nothing
+mapWithNode :: (Maybe k -> a -> b) -> Tree k a -> Tree k b
+mapWithNode = go Nothing
where
go _k f (TreeN k ts) = TreeN k (go (Just k) f <$> ts)
go k f (Tree0 a) = Tree0 (f k a)
-mapAlsoKey :: (k -> l) -> (Maybe k -> a -> b) -> Tree k a -> Tree l b
-mapAlsoKey fk fv = go Nothing
+mapAlsoNode :: (k -> l) -> (Maybe k -> a -> b) -> Tree k a -> Tree l b
+mapAlsoNode fk fv = go Nothing
where
go _k (TreeN k ts) = TreeN (fk k) $ go (Just k) <$> ts
go k (Tree0 a) = Tree0 (fv k a)
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Compute an Index for a DTC.
module Language.DTC.Anchor where
import Control.Applicative (Applicative(..))
import qualified Data.Strict.Maybe as Strict
import qualified Data.Text as Text
import qualified Data.TreeMap.Strict as TreeMap
+-- import qualified Data.TreeSeq.Strict as Tree
import Language.DTC.Document
f [] = []
f ws = maybe [] (\p -> [(p,[])]) $ pathFromWords ws
+-- ** Type 'Rrefs'
+type Rrefs = Map Ident [Anchor]
+
-- * Type 'State'
data State
= State
{ state_irefs :: Irefs
+ , state_rrefs :: Rrefs
, state_section :: Pos
}
state :: State
state = State
{ state_irefs = mempty
+ , state_rrefs = mempty
, state_section = def
}
S.put after{state_section}
return t
instance Anchorify Body where
- anchorify b = do
- State{..} <- S.get
- case () of
- () | null state_irefs -> return b
- _ -> mapM anchorify b
+ anchorify = mapM anchorify
instance Anchorify BodyKey where
anchorify = \case
Section{..} ->
Figure pos attrs type_
<$> anchorify title
<*> anchorify blocks
+ References{..} ->
+ References pos attrs
+ <$> anchorify refs
Block v ->
Block <$> anchorify v
instance Anchorify [Reference] where
Para{..} -> Para pos attrs <$> anchorify para
OL{..} -> OL pos attrs <$> anchorify items
UL{..} -> UL pos attrs <$> anchorify items
- RL{..} -> RL pos attrs <$> anchorify refs
Artwork{..} -> Artwork pos attrs <$> anchorify art
d@Comment{} -> pure d
instance Anchorify Para where
anchorify ls = do
- join <$> traverse indexifyLines ls
+ State{..} <- S.get
+ indexed <-
+ if null state_irefs
+ then return ls
+ else join <$> traverse indexifyLines ls
+ traverse referencifyLines indexed
instance Anchorify Reference where
anchorify = return
instance Anchorify Artwork where
anchorify = return
+referencifyLines :: Lines -> S.State State Lines
+referencifyLines t =
+ case t of
+ Tree0{} -> return t
+ TreeN k ts -> do
+ k' <-
+ case k of
+ Rref{..} -> do
+ State{..} <- S.get
+ let anchs = Map.findWithDefault [] to state_rrefs
+ let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
+ let anch = Anchor{count, section=state_section}
+ S.modify $ \s -> s{state_rrefs=
+ Map.insert to (anch:anchs) state_rrefs}
+ return Rref{anchor=Just anch, to}
+ _ -> return k
+ TreeN k'
+ <$> traverse referencifyLines ts
+
indexifyLines :: Lines -> S.State State Para
indexifyLines = \case
Tree0 a -> indexifyPlain a
Strict.Nothing ->
Seq.singleton . TreeN k . join
<$> traverse indexifyLines ts
- Strict.Just irefs -> do
- let count = case irefs of [] -> def; Anchor{count=c}:_ -> succNat1 c
+ Strict.Just anchs -> do
+ let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
let anch = Anchor{count, section=state_section}
S.modify $ \s -> s{state_irefs=
- TreeMap.insert const words (anch:irefs) state_irefs}
+ TreeMap.insert const words (anch:anchs) state_irefs}
Seq.singleton . TreeN Iref{term, anchor=Just anch} . join
<$> traverse indexifyLines ts
TreeN k ts ->
(<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
(anch, ls, ns, TreeMap $
Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
- Strict.Just irefs ->
+ Strict.Just anchs ->
case goWords node_descendants prev' next of
Nothing ->
- let count = case irefs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
+ let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
let anch = Anchor{count, section} in
Just (anch, prev', next, TreeMap $
- Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:irefs} irefsByWord)
+ Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
Just (anch, ls, ns, rs) ->
Just (anch, ls, ns, TreeMap $
Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
instance Semigroup About where
x <> y = About
{ titles = titles x <> titles y
- , url = url x <> url y
+ , url = url (x::About) <> url (y::About)
, authors = authors x <> authors y
, editor = editor x <> editor y
, date = date x <> date y
-- ** Type 'BodyValue'
data BodyValue
- = ToC { pos :: Pos
- , attrs :: CommonAttrs
- , depth :: Maybe Nat
- }
- | ToF { pos :: Pos
- , attrs :: CommonAttrs
- , types :: [Text]
- }
- | Figure { pos :: Pos
- , attrs :: CommonAttrs
- , type_ :: Text
- , title :: Title
- , blocks :: Blocks
- }
- | Index { pos :: Pos
- , attrs :: CommonAttrs
- , terms :: Terms
- }
+ = ToC { pos :: Pos
+ , attrs :: CommonAttrs
+ , depth :: Maybe Nat
+ }
+ | ToF { pos :: Pos
+ , attrs :: CommonAttrs
+ , types :: [Text]
+ }
+ | Figure { pos :: Pos
+ , attrs :: CommonAttrs
+ , type_ :: Text
+ , title :: Title
+ , blocks :: Blocks
+ }
+ | Index { pos :: Pos
+ , attrs :: CommonAttrs
+ , terms :: Terms
+ }
+ | References { pos :: Pos
+ , attrs :: CommonAttrs
+ , refs :: [Reference]
+ }
| Block Block
deriving (Eq,Show)
, attrs :: CommonAttrs
, items :: [Blocks]
}
- | RL { pos :: Pos
- , attrs :: CommonAttrs
- , refs :: [Reference]
- }
| Artwork { pos :: Pos
, attrs :: CommonAttrs
, art :: Artwork
, classes :: [Text]
} deriving (Eq,Show)
--- * Type 'Auto'
-data Auto
- = Auto
- { auto_id :: Ident
- } deriving (Eq,Show)
-
-- * Type 'Blocks'
type Blocks = [Block]
| Eref {href :: URL}
| Iref {anchor :: Maybe Anchor, term :: Words}
| Ref {to :: Ident}
- | Rref {to :: Ident}
+ | Rref {anchor :: Maybe Anchor, to :: Ident}
deriving (Eq,Show)
-- ** Type 'Anchor'
newtype Title = Title { unTitle :: Para }
deriving (Eq,Show,Default)
--- ** Type 'Address'
-data Address
- = Address
- { street :: Text
+-- ** Type 'Entity'
+data Entity
+ = Entity
+ { name :: Text
+ , street :: Text
, zipcode :: Text
, city :: Text
, region :: Text
, email :: Text
, tel :: Text
, fax :: Text
+ , url :: Maybe URL
} deriving (Eq,Show)
-instance Default Address where
- def = Address
- { street = def
+instance Default Entity where
+ def = Entity
+ { name = def
+ , street = def
, zipcode = def
, city = def
, region = def
, email = def
, tel = def
, fax = def
+ , url = def
}
+instance Semigroup Entity where
+ _x <> y = y
-- * Type 'Include'
data Include
instance Default Reference where
def = reference def
--- * Type 'Entity'
-data Entity
- = Entity
- { name :: Text
- , address :: Address
- } deriving (Eq,Show)
-instance Default Entity where
- def = Entity
- { name = def
- , address = def
- }
-instance Semigroup Entity where
- _x <> y = y
-
-- * Type 'Date'
data Date
= Date
editor :: repr DTC.Entity
date :: repr DTC.Date
entity :: repr DTC.Entity
- address :: repr DTC.Address
link :: repr DTC.Link
serie :: repr DTC.Serie
alias :: repr DTC.Alias
tof :: repr DTC.BodyValue
index :: repr DTC.BodyValue
figure :: repr DTC.BodyValue
+ references :: repr DTC.BodyValue
reference :: repr DTC.Reference
include :: repr DTC.Include
, tof
, index
, figure
+ , references
, DTC.Block <$> block
]
title = rule "title" $ DTC.Title <$> element "title" para
<$> position
<*> commonAttrs
<*> many (element "li" $ many block)
- , element "rl" $
- DTC.RL
- <$> position
- <*> commonAttrs
- <*> many reference
{-
, anyElem $ \n@XmlName{..} ->
case xmlNameSpace of
<*> attribute "type" text
<*> title
<*> many block
+ references =
+ element "references" $
+ DTC.References
+ <$> position
+ <*> commonAttrs
+ <*> many reference
para = rule "para" $ (Seq.fromList <$>) $ many lines
lines =
choice
, element "eref" $ TreeN . DTC.Eref <$> attribute "to" url <*> para
, element "iref" $ TreeN . DTC.Iref Nothing . wordify <$> attribute "to" text <*> para
, element "ref" $ TreeN . DTC.Ref <$> to <*> para
- , element "rref" $ TreeN . DTC.Rref <$> to <*> para
+ , element "rref" $ TreeN . DTC.Rref Nothing <$> to <*> para
, element "br" $ Tree0 DTC.BR <$ none
, Tree0 . DTC.Plain <$> text
]
author = rule "author" $ element "author" entity
editor = rule "editor" $ element "editor" entity
entity = rule "entity" $
- DTC.Entity
- <$> name
- <*> address
- address = rule "address" $
- element "address" $
interleaved $
- DTC.Address
- <$?> (def, attribute "street" text)
+ DTC.Entity
+ <$?> (def, attribute "name" text)
+ <|?> (def, attribute "street" text)
<|?> (def, attribute "zipcode" text)
<|?> (def, attribute "city" text)
<|?> (def, attribute "region" text)
<|?> (def, attribute "email" text)
<|?> (def, attribute "tel" text)
<|?> (def, attribute "fax" text)
+ <|?> (def, Just <$> attribute "url" url)
serie = rule "serie" $
element "serie" $
interleaved $
, void $ editor
, void $ date
, void $ entity
- , void $ address
, void $ link
, void $ serie
, void $ alias
, void $ tof
, void $ index
, void $ figure
+ , void $ references
, void $ reference
, void $ include
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
-import Data.Foldable (Foldable(..))
+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.Map.Strict (Map)
-import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, listToMaybe)
+import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
-- ** Type 'State'
data State
= State
- { state_styles :: Map FilePath CSS
- , state_scripts :: Map FilePath Script
- , state_localize :: MsgHtml5 -> Html5
- , state_indexs :: Map DTC.Pos (DTC.Terms, Anchor.Irefs)
- , state_figures :: Map Text (Map DTC.Pos DTC.Title)
+ { state_styles :: Map FilePath CSS
+ , state_scripts :: Map FilePath Script
+ , state_localize :: MsgHtml5 -> Html5
+ , state_indexs :: Map DTC.Pos (DTC.Terms, Anchor.Irefs)
+ , state_rrefs :: Anchor.Rrefs
+ , state_figures :: Map Text (Map DTC.Pos DTC.Title)
+ , state_references :: Map DTC.Ident DTC.About
}
state :: State
state = State
- { state_styles = mempty
- , state_scripts = mempty
- , state_localize = html5ify . show
- , state_indexs = mempty
- , state_figures = mempty
+ { state_styles = mempty
+ , state_scripts = mempty
+ , state_localize = html5ify . show
+ , state_indexs = mempty
+ , state_rrefs = mempty
+ , state_figures = mempty
+ , state_references = mempty
}
type CSS = Text
type Script = Text
-- ** Type 'Keys'
data Keys
= Keys
- { keys_index :: Map DTC.Pos DTC.Terms
- , keys_figure :: Map Text (Map DTC.Pos DTC.Title)
+ { keys_index :: Map DTC.Pos DTC.Terms
+ , keys_figure :: Map Text (Map DTC.Pos DTC.Title)
+ , keys_reference :: Map DTC.Ident DTC.About
} deriving (Show)
keys :: Trees DTC.BodyKey DTC.BodyValue -> Keys
-keys body = foldl' flt (Keys mempty mempty) (Compose body)
+keys body = foldl' flt (Keys mempty mempty mempty) (Compose body)
where
flt acc = \case
DTC.Index{..} -> acc{keys_index =
Map.insertWith (<>)
type_ (Map.singleton pos title) $
keys_figure acc}
+ DTC.References{..} -> acc{keys_reference =
+ foldr
+ (\r -> Map.insert
+ (DTC.id (r::DTC.Reference))
+ (DTC.about (r::DTC.Reference)))
+ (keys_reference acc)
+ refs}
_ -> acc
-- ** Class 'Html5ify'
LocaleIn ls -> Document -> Html
html5Document locale DTC.Document{..} = do
let Keys{..} = keys body
- let (body',state_indexs) =
+ let (body',state_rrefs,state_indexs) =
let irefs = foldMap Anchor.irefsOfTerms keys_index in
- (<$> S.runState (Anchor.anchorify body) Anchor.state
- { Anchor.state_irefs = irefs }) $ \Anchor.State{state_irefs} ->
- (<$> keys_index) $ \terms ->
- (terms,) $
- TreeMap.intersection const state_irefs $
- Anchor.irefsOfTerms terms
+ let (body0, Anchor.State{state_irefs, state_rrefs=rrefs}) =
+ Anchor.anchorify body `S.runState`
+ Anchor.state{Anchor.state_irefs=irefs} in
+ (body0,rrefs,) $
+ (<$> keys_index) $ \terms ->
+ (terms,) $
+ TreeMap.intersection const state_irefs $
+ Anchor.irefsOfTerms terms
let (html5Body, State{state_styles,state_scripts}) =
- runStateMarkup state{state_indexs, state_figures=keys_figure} $ do
+ runStateMarkup state
+ { state_indexs
+ , state_rrefs
+ , state_figures = keys_figure
+ , state_references = keys_reference
+ } $ do
liftStateMarkup $ S.modify $ \s -> s{state_localize = Locale.localize locale}
html5ify body'
forM_ terms $ \aliases -> do
H.dt $$
H.ul ! HA.class_ "index-aliases" $$
- forM_ (listToMaybe aliases) $ \term ->
+ forM_ (List.take 1 aliases) $ \term ->
H.li ! HA.id (attrValue term) $$
html5ify term
- H.dd $$ do
+ 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
- sequence_ $
- List.intersperse ", " $
- (<$> anchs) $ \(term,DTC.Anchor{..}) ->
- H.a ! HA.href ("#"<>attrValue (term,count)) $$
- html5ify $
- List.intercalate "." $
- toList $
- (<$> DTC.posAncestors section) $ \(_n,c) -> show c
+ TreeMap.lookup path refsByTerm in
+ html5CommasDot $
+ (<$> anchs) $ \(term,DTC.Anchor{..}) ->
+ H.a ! HA.class_ "index-iref"
+ ! HA.href ("#"<>attrValue (term,count)) $$
+ html5ify $ DTC.posAncestors section
+ DTC.References{..} ->
+ html5CommonAttrs attrs $
+ H.div ! HA.class_ "references"
+ ! HA.id (attrValue pos) $$ do
+ H.table $$
+ forM_ refs html5ify
instance Html5ify DTC.Words where
html5ify = html5ify . Anchor.plainifyWords
! HA.id (attrValue pos) $$ do
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
DTC.Eref{..} ->
H.a ! HA.class_ "eref"
! HA.href (attrValue href) $$
- html5ify ls
+ if null ls
+ then html5ify $ DTC.unURL href
+ else html5ify ls
DTC.Iref{..} ->
case anchor of
Nothing -> html5ify ls
if null ls
then html5ify to
else html5ify ls
- DTC.Rref{..} ->
+ DTC.Rref{..} -> do
+ when (not $ null ls) $ do
+ refs <- liftStateMarkup $ S.gets state_references
+ case Map.lookup to refs of
+ Nothing -> pure ()
+ Just DTC.About{..} ->
+ 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
+ Nothing -> html5ify ls
+ "["::Html5
H.a ! HA.class_ "rref"
- ! HA.href (attrValue to) $$
- html5ify ls
+ ! HA.href ("#rref."<>attrValue to)
+ ! HA.id ("rref."<>attrValue to<>maybe "" (\DTC.Anchor{..} -> "."<>attrValue count) anchor) $$
+ html5ify to
+ "]"
+instance Html5ify DTC.URL where
+ html5ify (DTC.URL url) =
+ H.a ! HA.class_ "eref"
+ ! HA.href (attrValue url) $$
+ html5ify url
+
instance AttrValue DTC.Words where
attrValue term =
"iref" <> "." <> attrValue (Anchor.plainifyWords term)
"iref"
<> "." <> attrValue (Anchor.plainifyWords term)
<> "." <> attrValue count
+instance Html5ify DTC.Date where
+ html5ify = html5ify . MsgHTML5_Date
instance Html5ify DTC.About where
html5ify DTC.About{..} =
- forM_ titles $ \(DTC.Title title) ->
- html5ify $ Seq.singleton $ TreeN DTC.Q title
+ html5CommasDot $ concat $
+ [ (<$> List.take 1 titles) $ \(DTC.Title title) ->
+ html5ify $ TreeN DTC.Q $
+ case url of
+ Nothing -> title
+ Just u -> pure $ TreeN (DTC.Eref u) title
+ , html5Entity <$> authors
+ , html5ify <$> maybeToList date
+ , html5Entity <$> maybeToList editor
+ , html5Serie <$> series
+ ]
+ where
+ html5Serie DTC.Serie{..} = do
+ html5ify key
+ html5ify MsgHTML5_Colon
+ html5ify name
+ html5Entity DTC.Entity{url=mu, ..} =
+ 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
instance Html5ify DTC.Reference where
- html5ify ref@DTC.Reference{about} =
+ html5ify DTC.Reference{id=id_, ..} =
H.tr $$ do
H.td ! HA.class_ "reference-key" $$
- html5ifyReference ref
- H.td ! HA.class_ "reference-content" $$
+ 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."<>attrValue id_<>"."<>attrValue count) $$
+ html5ify $ DTC.posAncestors section
-html5ifyReference :: DTC.Reference -> Html5
-html5ifyReference DTC.Reference{id=id_, ..} = do
- let i = "reference."<>attrValue id_
- "["::Html5
- H.a ! HA.id i ! HA.href ("#"<>i) $$
- html5ify id_
- "]"
+html5CommasDot :: [Html5] -> Html5
+html5CommasDot [] = pure ()
+html5CommasDot hs = do
+ sequence_ $ List.intersperse ", " hs
+ "."
html5CommonAttrs :: DTC.CommonAttrs -> Html5 -> Html5
html5CommonAttrs DTC.CommonAttrs{id=id_, ..} =
)
)
("","")
+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
-- * Type 'MsgHtml5'
data MsgHtml5
| MsgHTML5_Colon
| MsgHTML5_QuoteOpen
| MsgHTML5_QuoteClose
+ | MsgHTML5_Date DTC.Date
deriving (Show)
instance Html5ify MsgHtml5 where
html5ify msg = do
MsgHTML5_Colon -> " :"
MsgHTML5_QuoteOpen -> "« "
MsgHTML5_QuoteClose -> " »"
+ MsgHTML5_Date DTC.Date{..} ->
+ sequence_ $
+ List.intersperse " " $
+ concat
+ [ maybe [] (pure . html5ify) day
+ , case month of
+ Nothing -> []
+ Just (DTC.Nat1 m) ->
+ case m of
+ 1 -> pure "janvier"
+ 2 -> pure "février"
+ 3 -> pure "mars"
+ 4 -> pure "avril"
+ 5 -> pure "mai"
+ 6 -> pure "juin"
+ 7 -> pure "juillet"
+ 8 -> pure "août"
+ 9 -> pure "septembre"
+ 10 -> pure "octobre"
+ 11 -> pure "novembre"
+ 12 -> pure "décembre"
+ _ -> []
+ , [html5ify year]
+ ]
instance LocalizeIn EN Html5 MsgHtml5 where
localizeIn _ = \case
MsgHTML5_Table_of_Contents -> "Summary"
MsgHTML5_Colon -> ":"
MsgHTML5_QuoteOpen -> "“"
MsgHTML5_QuoteClose -> "”"
+ MsgHTML5_Date DTC.Date{..} ->
+ sequence_ $
+ List.intersperse " " $
+ concat
+ [ maybe [] (pure . html5ify) day
+ , case month of
+ Nothing -> []
+ Just (DTC.Nat1 m) ->
+ case m of
+ 1 -> pure "January"
+ 2 -> pure "February"
+ 3 -> pure "March"
+ 4 -> pure "April"
+ 5 -> pure "May"
+ 6 -> pure "June"
+ 7 -> pure "July"
+ 8 -> pure "August"
+ 9 -> pure "September"
+ 10 -> pure "October"
+ 11 -> pure "November"
+ 12 -> pure "December"
+ _ -> []
+ , [html5ify year]
+ ]
XML.ul $
forM_ types $
XML.li . xmlText
- DTC.Figure{..} ->
- xmlCommonAttrs attrs $
- XML.figure
- ! XA.type_ (attrValue type_) $ do
- xmlTitle title
- xmlBlocks blocks
DTC.Index{..} ->
xmlCommonAttrs attrs $
XML.index $ do
xmlText $
Text.unlines $
plainifyWords <$> aliases
+ DTC.Figure{..} ->
+ xmlCommonAttrs attrs $
+ XML.figure
+ ! XA.type_ (attrValue type_) $ do
+ xmlTitle title
+ xmlBlocks blocks
+ DTC.References{..} ->
+ xmlCommonAttrs attrs $
+ XML.references $ forM_ refs $ xmlReference
DTC.Block v -> xmlBlock v
xmlAbout :: DTC.About -> XML
xmlAbout DTC.About{..} = do
forM_ titles $ xmlTitle
- forM_ authors $ xmlAuthor
- forM_ editor $ xmlEditor
+ forM_ authors $ xmlEntity
+ forM_ editor $ xmlEntity
forM_ date $ xmlDate
whenMayText version xmlVersion
forM_ keywords $ xmlKeyword
!?? mayAttr XA.href href
$ xmlPara para
-xmlAddress :: DTC.Address -> XML
-xmlAddress DTC.Address{..} =
- XML.address
- !?? mayAttr XA.street street
+xmlEntity :: DTC.Entity -> XML
+xmlEntity DTC.Entity{..} =
+ XML.entity
+ !?? mayAttr XA.name name
+ !?? mayAttr XA.street street
!?? mayAttr XA.zipcode zipcode
!?? mayAttr XA.city city
!?? mayAttr XA.region region
!?? mayAttr XA.tel tel
!?? mayAttr XA.fax fax
-xmlAuthor :: DTC.Entity -> XML
-xmlAuthor DTC.Entity{..} =
- XML.author
- !?? mayAttr XA.name name
- $ xmlAddress address
-
-xmlEditor :: DTC.Entity -> XML
-xmlEditor DTC.Entity{..} =
- XML.editor
- !?? mayAttr XA.name name
- $ xmlAddress address
-
xmlTitle :: DTC.Title -> XML
xmlTitle (DTC.Title t) = XML.title $ xmlPara t
DTC.UL{..} ->
xmlCommonAttrs attrs $
XML.ul $ forM_ items $ XML.li . xmlBlocks
- DTC.RL{..} ->
- xmlCommonAttrs attrs $
- XML.rl $ forM_ refs $ xmlReference
- -- DTC.Index -> XML.index
DTC.Comment c ->
XML.comment c
DTC.Artwork{..} ->
DTC.Eref to -> XML.eref ! XA.to (attrValue to) $ xmlPara ls
DTC.Iref{..} -> XML.iref ! XA.term (attrValue $ plainifyWords term) $ xmlPara ls
DTC.Ref to -> XML.ref ! XA.to (attrValue to) $ xmlPara ls
- DTC.Rref to -> XML.rref ! XA.to (attrValue to) $ xmlPara ls
+ DTC.Rref{..} -> XML.rref ! XA.to (attrValue to) $ xmlPara ls
xmlReference :: DTC.Reference -> XML
xmlReference DTC.Reference{..} =
readTCTs inp txt = do
tct <- P.runParser (p_Trees <* P.eof) inp txt
(`traverse` tct) $ \tr ->
- sequence $ (`TreeSeq.mapWithKey`tr) $ \key c@(Cell pos _posEnd t) ->
+ sequence $ (`TreeSeq.mapWithNode`tr) $ \key c@(Cell pos _posEnd t) ->
case key of
-- Verbatim Keys
Just (unCell -> KeyBar{}) -> Right $ tokens [TokenPlain <$> c]
p_Link :: Parser e s Text
p_Link =
- (\scheme addr -> Text.pack $ scheme <> "//" <> addr)
- <$> P.option "" (P.try p_scheme)
- <* P.string "//"
- <*> p_addr
+ P.try (P.char '<' *> p <* P.char '>') <|>
+ p
where
+ p =
+ (\scheme addr -> Text.pack $ scheme <> "//" <> addr)
+ <$> P.option "" (P.try p_scheme)
+ <* P.string "//"
+ <*> p_addr
p_scheme =
(<> ":")
<$> P.some (P.satisfy $ \c ->
| (rl,ts) <- spanlBrackets trees
, not (null rl) ->
(<| go inh ts) $
- TreeN (Cell bp ep "rl") $
+ TreeN (Cell bp ep "references") $
rl >>= xmlTCT inh_orig
_ | (ul,ts) <- spanlItems (==KeyDash) trees
"about" -> xmlTitle : xmlTitle : List.repeat xmlPara
"reference" -> xmlTitle : xmlTitle : List.repeat xmlPara
"author" -> List.repeat xmlName
+ "editor" -> List.repeat xmlName
_ -> []
} in
case () of
com :: TL.Text
com =
Write.text Write.config_text $
- TreeSeq.mapAlsoKey
+ TreeSeq.mapAlsoNode
(cell1 . unCell)
(\_path -> fmap $ cell1 . unCell) <$> ts
KeyLower n as -> TreeN (cell "artwork") $ xmlTCTs inh ts
TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ Text.singleton c
TokenLink lnk -> Seq.singleton $
TreeN (cell "eref") $
- xmlAttrs [cell ("to",lnk)] |>
- Tree0 (cell $ XmlText lnk)
+ xmlAttrs [cell ("to",lnk)]
TokenPair PairBracket ts | to <- Write.textTokens ts
, TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to ->
Seq.singleton $
where
v = TL.toStrict $
Write.text Write.config_text{Write.config_text_escape = False} $
- TreeSeq.mapAlsoKey (cell1 . unCell) (\_path -> fmap $ cell1 . unCell) <$> a
+ TreeSeq.mapAlsoNode (cell1 . unCell) (\_path -> fmap $ cell1 . unCell) <$> a
_ -> undefined
elems :: Set Text
, "q"
, "ref"
, "reference"
+ , "references"
, "region"
- , "rl"
, "rref"
, "sc"
, "section"
-- * Type 'Ident'
newtype Ident = Ident { unIdent :: Text }
- deriving (Eq,Show,Default,IsString)
+ deriving (Eq,Ord,Show,Default,IsString)
instance Default Text where
def = ""
-- * Type 'URL'
-newtype URL = URL Text
- deriving (Eq,Show,Default)
+newtype URL = URL { unURL :: Text }
+ deriving (Eq,Ord,Show,Default)
instance Semigroup URL where
_x <> y = y
about = Parent "about" "<about" "</about>"
alias :: DTC
alias = Leaf "alias" "<alias" "/>" ()
-address :: DTC
-address = Leaf "address" "<address" "/>" ()
artwork :: DTC -> DTC
artwork = Parent "artwork" "<artwork" "</artwork>"
author :: DTC -> DTC
editor = Parent "editor" "<editor" "</editor>"
email :: DTC -> DTC
email = Parent "email" "<email" "</email>"
+entity :: DTC
+entity = Leaf "entity" "<entity" "/>" ()
eref :: DTC -> DTC
eref (Empty a) = Leaf "eref" "<eref" "/>" a
eref x = Parent "eref" "<eref" "</eref>" x
ref x = Parent "ref" "<ref" "</ref>" x
reference :: DTC -> DTC
reference = Parent "reference" "<reference" "</reference>"
-rl :: DTC -> DTC
-rl = Parent "rl" "<rl" "</rl>"
+references :: DTC -> DTC
+references = Parent "references" "<references" "</references>"
rref :: DTC -> DTC
rref (Empty a) = Leaf "rref" "<rref" "/>" a
rref x = Parent "rref" "<rref" "</rref>" x
instance MayAttr [Char] where
mayAttr _ "" = Nothing
mayAttr a t = Just (a $ fromString t)
+instance MayAttr AttributeValue where
+ mayAttr a = Just . a
-- * Type 'StateMarkup'
-- | Composing state and markups.
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE OverloadedLists #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
-import Control.Monad (forM_)
+import Control.Monad (forM_, when)
import Data.Bool
-import Data.Eq (Eq(..))
+import Data.Default.Class (Default(..))
import Data.Either (Either(..))
+import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
-import Data.Maybe (fromMaybe)
+import Data.Map.Strict (Map)
+import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
+import Data.String (String)
+import GHC.Exts (IsList(..))
import Options.Applicative as Opt
import Prelude (error)
import System.IO (IO, FilePath, hPrint, hPutStrLn, stderr, stdout)
import qualified Data.ByteString as BS
import qualified Data.Char as Char
-import qualified Data.Text.IO as Text
-import qualified Data.Text as Text
import qualified Data.List as List
-import qualified Text.Blaze.Renderer.Utf8 as Blaze
-import qualified Text.Blaze.Utils as Blaze
import qualified Data.Map.Strict as Map
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
import qualified System.Environment as Env
+import qualified Text.Blaze.Renderer.Utf8 as Blaze
+import qualified Text.Blaze.Utils as Blaze
import Data.Locale
(locales @Langs)) .
fromMaybe ""
<$> Env.lookupEnv "LANG"
- cmd <- execParser $ p_Argv lang
+ cmd <- execParser $ pArgv lang
mainWithCommand cmd
where
- p_Argv lang =
- info (p_Command lang <**> helper) $ mconcat $
+ pArgv lang =
+ info (pCommand lang <**> helper) $ mconcat
[ fullDesc
, progDesc "document tool"
, header "hdoc - TCT and DTC command line tool"
case TCT.readTCTs input txt of
Left err -> error $ P.parseErrorPretty err
Right tct -> do
- hPutStrLn stderr "### TCT ###"
- hPrint stderr $ Tree.Pretty tct
+ when (trace_TCT trace) $ do
+ hPutStrLn stderr "### TCT ###"
+ hPrint stderr $ Tree.Pretty tct
let xml = TCT.Write.XML.xmlDocument tct
- hPutStrLn stderr "### XML ###"
- hPrint stderr $ Tree.Pretty xml
+ when (trace_XML trace) $ do
+ hPutStrLn stderr "### XML ###"
+ hPrint stderr $ Tree.Pretty xml
case DTC.Read.TCT.readDTC xml of
Left err -> error $ P.parseErrorPretty err
Right dtc -> do
- hPutStrLn stderr "### DTC ###"
- hPrint stderr dtc
+ when (trace_DTC trace) $ do
+ hPutStrLn stderr "### DTC ###"
+ hPrint stderr dtc
case format of
DtcFormatXML ->
Blaze.prettyMarkupIO Blaze.DTC.indentTag BS.putStr $
forM_ DTC.dtcRNC $ \w ->
Text.hPutStrLn stdout $ RNC.renderWriter w
+-- * Options utils
+
+instance IsList (Opt.Mod f a) where
+ type Item (Opt.Mod f a) = Opt.Mod f a
+ fromList = mconcat
+ toList = pure
+
+readMap :: Map String a -> ReadM a
+readMap m =
+ eitherReader $ \s ->
+ case Map.lookup s m of
+ Nothing -> Left $ "cannot parse value \"" <> s
+ <> "\"\nexpecting one of: "
+ <> (List.intercalate ", " $ Map.keys m)
+ Just a -> Right a
+
-- * Type 'Command'
data Command
= CommandTCT ArgsTCT
| CommandDTC ArgsDTC
| CommandRNC ArgsRNC
-p_Command :: Lang -> Parser Command
-p_Command lang =
- subparser (
- command "tct" $
- info (CommandTCT <$> p_ArgsTCT <**> helper) $
- progDesc "TCT (Texte Convivial Technique) rendition.") <|>
- subparser (
- command "dtc" $
- info (CommandDTC <$> p_ArgsDTC lang <**> helper) $
- progDesc "DTC (Document Technique Convivial) rendition.") <|>
- subparser (
- command "rnc" $
- info (CommandRNC <$> p_ArgsRNC <**> helper) $
- progDesc "RNC (RelaxNG Compact) schema.")
+pCommand :: Lang -> Parser Command
+pCommand lang =
+ hsubparser
+ [ metavar "tct"
+ , command "tct" $
+ info (CommandTCT <$> pArgsTCT) $
+ progDesc "TCT (Texte Convivial Technique) rendition."
+ ] <|>
+ hsubparser
+ [ metavar "dtc"
+ , command "dtc" $
+ info (CommandDTC <$> pArgsDTC lang) $
+ progDesc "DTC (Document Technique Convivial) rendition."
+ ] <|>
+ hsubparser
+ [ metavar "rnc"
+ , command "rnc" $
+ info (CommandRNC <$> pArgsRNC) $
+ progDesc "RNC (RelaxNG Compact) schema."
+ ]
+
+-- * Type 'Trace'
+data Trace
+ = Trace
+ { trace_TCT :: Bool
+ , trace_XML :: Bool
+ , trace_DTC :: Bool
+ }
+instance Default Trace where
+ def = Trace
+ { trace_TCT = False
+ , trace_XML = False
+ , trace_DTC = False
+ }
+instance Semigroup Trace where
+ x <> y =
+ Trace
+ { trace_TCT = trace_TCT x || trace_TCT y
+ , trace_XML = trace_XML x || trace_XML y
+ , trace_DTC = trace_DTC x || trace_DTC y
+ }
+instance Monoid Trace where
+ mempty = def
+ mappend = (<>)
+
+pTrace :: Parser Trace
+pTrace =
+ (mconcat <$>) $
+ many $
+ option
+ (readMap m)
+ [ long "trace"
+ , help $ "Print trace. (choices: "
+ <> (List.intercalate ", " $ Map.keys m) <> ")"
+ ]
+ where
+ m = Map.fromList
+ [ ("tct", def{trace_TCT=True})
+ , ("xml", def{trace_XML=True})
+ , ("dtc", def{trace_DTC=True})
+ ]
-- ** Type 'ArgsTCT'
data ArgsTCT
, format :: TctFormat
}
-p_ArgsTCT :: Parser ArgsTCT
-p_ArgsTCT =
+pArgsTCT :: Parser ArgsTCT
+pArgsTCT =
ArgsTCT
<$> argument str (metavar "FILE")
- <*> p_TctFormat
+ <*> pTctFormat
-- *** Type 'TctFormat'
data TctFormat
= TctFormatHTML5
-p_TctFormat :: Parser TctFormat
-p_TctFormat =
+pTctFormat :: Parser TctFormat
+pTctFormat =
flag TctFormatHTML5 TctFormatHTML5
- (long "html5" <> help "Render as HTML5.")
+ [ long "html5"
+ , help "Render as HTML5."
+ ]
-- ** Type 'ArgsDTC'
data ArgsDTC
{ input :: FilePath
, format :: DtcFormat
, locale :: Lang
- -- , argsDTC_locale :: LocaleIn Langs
+ , trace :: Trace
}
-p_ArgsDTC :: Lang -> Parser ArgsDTC
-p_ArgsDTC lang =
+pArgsDTC :: Lang -> Parser ArgsDTC
+pArgsDTC lang =
ArgsDTC
<$> argument str (metavar "FILE")
- <*> p_DtcFormat
- <*> p_Locale lang
+ <*> pDtcFormat
+ <*> pLocale lang
+ <*> pTrace
-p_Locale :: Lang -> Parser (LocaleIn Langs)
-p_Locale lang =
+pLocale :: Lang -> Parser (LocaleIn Langs)
+pLocale lang =
option
(maybeReader $ \s -> Map.lookup (Text.pack s) $ locales @Langs)
- ( long "lang"
- <> help "Language."
- <> showDefault
- <> value lang
- <> metavar "LOCALE")
+ [ long "lang"
+ , help "Language."
+ , showDefault
+ , value lang
+ , metavar "LOCALE"
+ ]
-- *** Type 'DtcFormat'
data DtcFormat
= DtcFormatHTML5
| DtcFormatXML
-p_DtcFormat :: Parser DtcFormat
-p_DtcFormat =
+pDtcFormat :: Parser DtcFormat
+pDtcFormat =
flag DtcFormatHTML5 DtcFormatHTML5
- (long "html5" <> help "Render as HTML5.") <|>
+ [ long "html5"
+ , help "Render as HTML5."
+ ] <|>
flag DtcFormatHTML5 DtcFormatXML
- (long "xml" <> help "Render as XML.")
+ [ long "xml"
+ , help "Render as XML."
+ ]
-- ** Type 'ArgsRNC'
data ArgsRNC
= ArgsRNC
-p_ArgsRNC :: Parser ArgsRNC
-p_ArgsRNC = pure ArgsRNC
+pArgsRNC :: Parser ArgsRNC
+pArgsRNC = pure ArgsRNC
{-
, bytestring
, containers >= 0.5 && < 0.6
, Decimal
+ , data-default-class
, deepseq
-- , directory
, optparse-applicative
sourcephile / git / doclang.git / commitdiff