go _k (TreeN k ts) = TreeN (fk k) $ go (Just k) <$> ts
go k (Tree0 a) = Tree0 (fv k a)
-traverseWithKey :: Applicative f => (Maybe k -> a -> f b) -> Tree k a -> f (Tree k b)
-traverseWithKey = go Nothing
+traverseWithNode :: Applicative f => (Maybe k -> a -> f b) -> Tree k a -> f (Tree k b)
+traverseWithNode = go Nothing
where
go _p f (TreeN k ts) = TreeN k <$> traverse (go (Just k) f) ts
go p f (Tree0 a) = Tree0 <$> f p a
import Data.Monoid (Monoid(..))
import Data.Ord (Ord)
import Data.Semigroup (Semigroup(..))
+import Data.Sequence (Seq)
import Data.Text (Text)
-import Data.TreeSeq.Strict (Trees)
+import Data.TreeSeq.Strict (Tree, Trees)
import Text.Show (Show)
import Language.XML
data Block
= Para { pos :: XmlPos
, attrs :: CommonAttrs
- , lines :: Lines
+ , para :: Para
}
| OL { pos :: XmlPos
, attrs :: CommonAttrs
= Raw Text
deriving (Eq,Show)
+-- * Type 'Para'
+type Para = Seq Lines
+
-- * Type 'Lines'
-type Lines = Trees LineKey LineValue
+type Lines = Tree LineKey LineValue
-- ** Type 'LineKey'
data LineKey
deriving (Eq,Show)
-- * Type 'Title'
-newtype Title = Title { unTitle :: Lines }
+newtype Title = Title { unTitle :: Para }
deriving (Eq,Show,Default)
-- ** Type 'Address'
-- * Type 'Link'
data Link
= Link
- { name :: Text
- , href :: URL
- , rel :: Text
- , lines :: Lines
+ { name :: Text
+ , href :: URL
+ , rel :: Text
+ , para :: Para
} deriving (Eq,Show)
instance Default Link where
def = Link
- { name = def
- , href = def
- , rel = def
- , lines = def
+ { name = def
+ , href = def
+ , rel = def
+ , para = def
}
-- * Type 'Alias'
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Compute an Index for a DTC.
module Language.DTC.Index where
import Control.Applicative (Applicative(..))
import Control.Category
-import Control.Monad (Monad(..), mapM)
+import Control.Monad (Monad(..), mapM, join)
import Data.Bool
import Data.Char (Char)
import Data.Default.Class (Default(..))
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 (Count,Words,Terms, Word, WordOrSpace(..), Words)
import Language.XML (XmlPos(..))
import qualified Language.DTC.Document as DTC
--- import Debug.Trace (trace)
-
termsByChar :: Terms -> Map Char Terms
termsByChar =
foldr (\aliases acc ->
return t
instance Indexify (Trees DTC.BodyKey DTC.BodyValue) where
indexify = mapM indexify
-{-
-instance Indexify a => Indexify (Seq a) where
- indexify = mapM indexify
--}
instance Indexify DTC.BodyKey where
indexify = \case
DTC.Section{..} ->
indexify (DTC.Title t) = DTC.Title <$> indexify t
instance Indexify DTC.Block where
indexify = \case
- DTC.Para{..} -> DTC.Para pos attrs <$> indexify lines
+ DTC.Para{..} -> DTC.Para pos attrs <$> indexify para
DTC.OL{..} -> DTC.OL pos attrs <$> indexify items
DTC.UL{..} -> DTC.UL pos attrs <$> indexify items
DTC.RL{..} -> DTC.RL pos attrs <$> indexify refs
DTC.Artwork{..} -> DTC.Artwork pos attrs <$> indexify art
d@DTC.Comment{} -> pure d
-
-instance Indexify DTC.Lines where
- indexify ls =
- Tree.joinTrees <$> traverse (traverse go) ls
- where
- go = \case
- DTC.BR -> pure $ Seq.singleton $ Tree0 DTC.BR
- DTC.Plain p -> do
- State{..} <- S.get
- let (refs,ret) = indexifyWords state_section state_refs (wordify p)
- S.modify $ \s -> s{state_refs=refs}
- return ret
+instance Indexify DTC.Para where
+ indexify ls = join <$> traverse indexifyLines ls
instance Indexify DTC.Reference where
indexify = return
instance Indexify DTC.Artwork where
indexify = return
-wordify :: Text -> Words
-wordify = List.reverse . go []
- where
- go :: Words -> Text -> Words
- go acc t =
- case Text.span Char.isAlphaNum t of
- ("",_) ->
- case Text.span Char.isSpace t of
- ("",_) ->
- case Text.uncons t of
- Nothing -> acc
- Just (c,r) -> go (Word (Text.singleton c) : acc) r
- (_s,r) -> go (Space : acc) r
- (w,r) -> go (Word w : acc) r
-
-plainifyWord :: WordOrSpace -> Text
-plainifyWord = \case
- Word w -> w
- Space -> " "
-
-plainifyWords :: Words -> Text
-plainifyWords = Text.concat . (plainifyWord <$>)
-
-indexifyWords :: XmlPos -> Refs -> Words -> (Refs, DTC.Lines)
+indexifyLines :: DTC.Lines -> S.State State DTC.Para
+indexifyLines = \case
+ Tree0 a -> indexifyPlain a
+ TreeN k@DTC.Iref{term} ts
+ | Just words <- pathFromWords term -> do
+ State{state_refs, state_section} <- S.get
+ case TreeMap.lookup words state_refs of
+ Strict.Nothing ->
+ Seq.singleton . TreeN k . join
+ <$> traverse indexifyLines ts
+ Strict.Just refs -> do
+ let count = case refs of [] -> 1; Ref{count=c}:_ -> c + 1
+ let ref = Ref{term, count, section=state_section}
+ S.modify $ \s -> s{state_refs=
+ TreeMap.insert const words (ref:refs) state_refs}
+ Seq.singleton . TreeN DTC.Iref{DTC.term, DTC.count} . join
+ <$> traverse indexifyLines ts
+ TreeN k ts ->
+ Seq.singleton . TreeN k . join
+ <$> traverse indexifyLines ts
+
+indexifyPlain :: DTC.LineValue -> S.State State DTC.Para
+indexifyPlain = \case
+ DTC.BR -> pure $ Seq.singleton $ Tree0 DTC.BR
+ DTC.Plain p -> do
+ State{..} <- S.get
+ let (refs,ts) = indexifyWords state_section state_refs (wordify p)
+ S.modify $ \s -> s{state_refs=refs}
+ return ts
+
+indexifyWords :: XmlPos -> Refs -> Words -> (Refs, DTC.Para)
indexifyWords section = go mempty
where
- go :: DTC.Lines -> Refs -> Words -> (Refs, DTC.Lines)
+ go :: DTC.Para -> Refs -> Words -> (Refs, DTC.Para)
go acc refs inp =
case inp of
[] -> (refs, acc)
Nothing -> Nothing
Just nod@TreeMap.Node{..} ->
case node_value of
- Strict.Nothing ->
- if null node_descendants
- then Nothing
- else case goWords words node_descendants (curr:prev) next of
- Nothing -> Nothing
- Just (ref, ls, ns, rs) ->
- Just (ref, ls, ns, TreeMap $ Map.insert w nod{TreeMap.node_descendants = rs} refsByWord)
+ Strict.Nothing
+ | null node_descendants -> Nothing
+ | otherwise ->
+ (<$> goWords words node_descendants (curr:prev) next) $ \(ref, ls, ns, rs) ->
+ (ref, ls, ns, TreeMap $
+ Map.insert w nod{TreeMap.node_descendants = rs} refsByWord)
Strict.Just refs ->
case goWords words node_descendants (curr:prev) next of
Nothing ->
let term = List.reverse words in
let count = case refs of [] -> 1; Ref{count=c}:_ -> c + 1 in
let ref = Ref{term, count, section} in
- Just (ref, curr:prev, next, TreeMap $ Map.insert w nod{TreeMap.node_value = Strict.Just $ ref:refs} refsByWord)
+ Just (ref, curr:prev, next, TreeMap $
+ Map.insert w nod{TreeMap.node_value = Strict.Just $ ref:refs} refsByWord)
Just (ref, ls, ns, rs) ->
- Just (ref, ls, ns, TreeMap $ Map.insert w nod{TreeMap.node_descendants = rs} refsByWord)
+ Just (ref, ls, ns, TreeMap $
+ Map.insert w nod{TreeMap.node_descendants = rs} refsByWord)
+
+wordify :: Text -> Words
+wordify = List.reverse . go []
+ where
+ go :: Words -> Text -> Words
+ go acc t =
+ case Text.span Char.isAlphaNum t of
+ ("",_) ->
+ case Text.span Char.isSpace t of
+ ("",_) ->
+ case Text.uncons t of
+ Nothing -> acc
+ Just (c,r) -> go (Word (Text.singleton c) : acc) r
+ (_s,r) -> go (Space : acc) r
+ (w,r) -> go (Word w : acc) r
+
+plainifyWord :: WordOrSpace -> Text
+plainifyWord = \case
+ Word w -> w
+ Space -> " "
+
+plainifyWords :: Words -> Text
+plainifyWords = Text.concat . (plainifyWord <$>)
include :: repr DTC.Include
block :: repr DTC.Block
- lines :: repr DTC.Lines
- line :: repr (Tree DTC.LineKey DTC.LineValue)
+ para :: repr DTC.Para
+ lines :: repr (Tree DTC.LineKey DTC.LineValue)
commonAttrs :: repr DTC.CommonAttrs
ident :: repr Ident
, figure
, DTC.Block <$> block
]
- title = rule "title" $ DTC.Title <$> element "title" lines
+ title = rule "title" $ DTC.Title <$> element "title" para
name = rule "name" $ attribute "name" text
url = rule "url" $ URL <$> text
path = rule "path" $ Path <$> text
DTC.Para
<$> position
<*> commonAttrs
- <*> lines
+ <*> para
, element "ol" $
DTC.OL
<$> position
<*> attribute "type" text
<*> title
<*> many block
- lines = rule "lines" $ (Seq.fromList <$>) $ many line
- line =
+ para = rule "para" $ (Seq.fromList <$>) $ many lines
+ lines =
choice
- [ element "b" $ TreeN DTC.B <$> lines
- , element "code" $ TreeN DTC.Code <$> lines
- , element "del" $ TreeN DTC.Del <$> lines
- , element "i" $ TreeN DTC.I <$> lines
- , element "note" $ TreeN DTC.Note <$> lines
- , element "q" $ TreeN DTC.Q <$> lines
- , element "sc" $ TreeN DTC.SC <$> lines
- , element "sub" $ TreeN DTC.Sub <$> lines
- , element "sup" $ TreeN DTC.Sup <$> lines
- , element "u" $ TreeN DTC.U <$> lines
- , element "eref" $ TreeN <$> (DTC.Eref <$> attribute "to" url) <*> lines
- , element "iref" $ TreeN <$> (DTC.Iref 0 . wordify <$> text) <*> lines
- , element "ref" $ TreeN <$> (DTC.Ref <$> to) <*> lines
- , element "rref" $ TreeN <$> (DTC.Rref <$> to) <*> lines
+ [ element "b" $ TreeN DTC.B <$> para
+ , element "code" $ TreeN DTC.Code <$> para
+ , element "del" $ TreeN DTC.Del <$> para
+ , element "i" $ TreeN DTC.I <$> para
+ , element "note" $ TreeN DTC.Note <$> para
+ , element "q" $ TreeN DTC.Q <$> para
+ , element "sc" $ TreeN DTC.SC <$> para
+ , element "sub" $ TreeN DTC.Sub <$> para
+ , element "sup" $ TreeN DTC.Sup <$> para
+ , element "u" $ TreeN DTC.U <$> para
+ , element "eref" $ TreeN . DTC.Eref <$> attribute "to" url <*> para
+ , element "iref" $ TreeN . DTC.Iref (-1) . wordify <$> attribute "to" text <*> para
+ , element "ref" $ TreeN . DTC.Ref <$> to <*> para
+ , element "rref" $ TreeN . DTC.Rref <$> to <*> para
, element "br" $ Tree0 DTC.BR <$ none
, Tree0 . DTC.Plain <$> text
]
<$?> (def, attribute "name" text)
<|?> (def, attribute "href" url)
<|?> (def, attribute "rel" text)
- <|*> line
+ <|*> lines
alias = rule "alias" $
element "alias" $
interleaved $
, void $ include
, void $ block
+ , void $ para
, void $ lines
, void $ commonAttrs
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, listToMaybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
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
H.tbody $$
H.tr $$ do
H.td ! HA.class_ "section-number" $$ do
- html5SectionNumber $
- xmlPosAncestors pos
+ html5SectionNumber $ xmlPosAncestors pos
H.td ! HA.class_ "section-title" $$ do
(case List.length $ xmlPosAncestors pos of
0 -> H.h1
where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
DTC.Figure{..} ->
html5CommonAttrs attrs $
- H.div ! HA.class_ (attrValue $ "figure-"<>type_)
+ H.div ! HA.class_ ("figure " <> attrValue ("figure-"<>type_))
! HA.id (attrValue pos) $$ do
H.table ! HA.class_ "figure-caption" $$
H.tbody $$
H.td ! HA.class_ "figure-number" $$ do
H.a ! HA.href ("#"<>attrValue pos) $$
html5ify type_
- ": "
+ html5ify $ MsgHTML5_Colon
+ " "
H.td ! HA.class_ "figure-name" $$
html5ify title
H.div ! HA.class_ "figure-content" $$ do
let chars = Index.termsByChar allTerms
H.div ! HA.class_ "index"
! HA.id (attrValue pos) $$ do
- H.nav ! HA.class_ "index-nav-chars" $$ do
+ H.nav ! HA.class_ "index-nav" $$ do
forM_ (Map.keys chars) $ \char ->
H.a ! HA.href ("#"<>(attrValue pos <> "." <> attrValue 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
! 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.ul ! HA.class_ "index-aliases" $$
+ forM_ (listToMaybe aliases) $ \term ->
H.li ! HA.id (attrValue Index.Ref{term, count=0, section=def}) $$
html5ify term
H.dd $$ do
let refs =
- List.sortBy
- (compare `on` Index.section) $
+ List.sortBy (compare `on` Index.section) $
(`foldMap` aliases) $ \words -> fromJust $ do
path <- Index.pathFromWords words
- Strict.maybe Nothing Just $
+ Strict.maybe Nothing (Just . List.reverse) $
TreeMap.lookup path refsByTerm
sequence_ $
List.intersperse ", " $
html5CommonAttrs attrs $
H.p ! HA.class_ "para"
! HA.id (attrValue pos) $$ do
- html5ify lines
+ html5ify para
DTC.OL{..} ->
html5CommonAttrs attrs $
H.ol ! HA.class_ "ol"
DTC.Comment t ->
html5ify $ H.Comment (H.Text t) ()
instance Html5ify DTC.Lines where
- html5ify = mapM_ $ \case
+ html5ify = \case
Tree0 v ->
case v of
DTC.BR -> html5ify H.br
DTC.Note -> ""
DTC.Q ->
H.span ! HA.class_ "q" $$ do
- "« "::Html5
+ html5ify MsgHTML5_QuoteOpen
H.i $$ html5ify ls
- " »"
+ html5ify MsgHTML5_QuoteClose
DTC.Eref{..} ->
H.a ! HA.class_ "eref"
! HA.href (attrValue href) $$
where
addClass =
case classes of
- [] -> \x -> x
+ [] -> id
_ -> 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)
+ addId = maybe id (\(DTC.Ident i) ->
+ H.AddCustomAttribute "id" (H.Text i)) id_
html5SectionNumber :: [(XmlName,Int)] -> Html5
html5SectionNumber = go [] . List.reverse
go rs (a@(_n,cnt):as) = do
H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors (a:rs)) $$
html5ify $ show cnt
- html5ify '.'
- go (a:rs) as
+ when (not (null as) || null rs) $ do
+ html5ify '.'
+ go (a:rs) as
html5SectionRef :: [(XmlName,Int)] -> Html5
html5SectionRef as =
plainify = id
instance Plainify Text where
plainify = TL.fromStrict
+instance Plainify DTC.Para where
+ plainify = foldMap plainify
instance Plainify DTC.Lines where
- plainify = foldMap $ \case
+ plainify = \case
Tree0 v ->
case v of
DTC.BR -> "\n"
-- * Type 'MsgHtml5'
data MsgHtml5
= MsgHTML5_Table_of_Contents
+ | MsgHTML5_Colon
+ | MsgHTML5_QuoteOpen
+ | MsgHTML5_QuoteClose
deriving (Show)
instance Html5ify MsgHtml5 where
html5ify msg = do
instance LocalizeIn FR Html5 MsgHtml5 where
localizeIn _ = \case
MsgHTML5_Table_of_Contents -> "Sommaire"
+ MsgHTML5_Colon -> " :"
+ MsgHTML5_QuoteOpen -> "« "
+ MsgHTML5_QuoteClose -> " »"
instance LocalizeIn EN Html5 MsgHtml5 where
localizeIn _ = \case
MsgHTML5_Table_of_Contents -> "Summary"
+ MsgHTML5_Colon -> ":"
+ MsgHTML5_QuoteOpen -> "“"
+ MsgHTML5_QuoteClose -> "”"
!?? mayAttr XA.name name
!?? mayAttr XA.rel rel
!?? mayAttr XA.href href
- $ xmlLines lines
+ $ xmlPara para
xmlAddress :: DTC.Address -> XML
xmlAddress DTC.Address{..} =
$ xmlAddress address
xmlTitle :: DTC.Title -> XML
-xmlTitle (DTC.Title t) = XML.title $ xmlLines t
+xmlTitle (DTC.Title t) = XML.title $ xmlPara t
xmlAlias :: DTC.Alias -> XML
xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id
xmlBlock = \case
DTC.Para{..} ->
xmlCommonAttrs attrs $
- XML.para $ xmlLines lines
+ XML.para $ xmlPara para
DTC.OL{..} ->
xmlCommonAttrs attrs $
XML.ol $ forM_ items $ XML.li . xmlBlocks
xmlCommonAttrs attrs $
XML.artwork mempty
-xmlLines :: DTC.Lines -> XML
-xmlLines = (`forM_` xmlLine)
+xmlPara :: DTC.Para -> XML
+xmlPara = (`forM_` xmlLine)
xmlLine :: Tree DTC.LineKey DTC.LineValue -> XML
xmlLine = \case
DTC.BR -> XML.br
TreeN k ls ->
case k of
- DTC.B -> XML.b $ xmlLines ls
- DTC.Code -> XML.code $ xmlLines ls
- DTC.Del -> XML.del $ xmlLines ls
- DTC.I -> XML.i $ xmlLines ls
- DTC.Note -> XML.note $ xmlLines ls
- DTC.Q -> XML.q $ xmlLines ls
- DTC.SC -> XML.sc $ xmlLines ls
- DTC.Sub -> XML.sub $ xmlLines ls
- DTC.Sup -> XML.sup $ xmlLines ls
- DTC.Eref to -> XML.eref ! XA.to (attrValue to) $ xmlLines ls
- DTC.Iref{..} -> XML.iref ! XA.term (attrValue $ plainifyWords term) $ xmlLines ls
- DTC.Ref to -> XML.ref ! XA.to (attrValue to) $ xmlLines ls
- DTC.Rref to -> XML.rref ! XA.to (attrValue to) $ xmlLines ls
+ DTC.B -> XML.b $ xmlPara ls
+ DTC.Code -> XML.code $ xmlPara ls
+ DTC.Del -> XML.del $ xmlPara ls
+ DTC.I -> XML.i $ xmlPara ls
+ DTC.Note -> XML.note $ xmlPara ls
+ DTC.Q -> XML.q $ xmlPara ls
+ DTC.SC -> XML.sc $ xmlPara ls
+ DTC.Sub -> XML.sub $ xmlPara ls
+ DTC.Sup -> XML.sup $ xmlPara ls
+ 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
xmlReference :: DTC.Reference -> XML
xmlReference DTC.Reference{..} =
sourcephile / git / doclang.git / commitdiff