1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# OPTIONS_GHC -fno-warn-orphans #-}
6 module Language.DTC.Anchor where
8 import Control.Applicative (Applicative(..))
9 import Control.Category
10 import Control.Monad (Monad(..))
12 import Data.Char (Char)
13 import Data.Default.Class (Default(..))
14 import Data.Foldable (Foldable(..), concat)
15 import Data.Function (($), const)
16 import Data.Functor ((<$>))
17 import Data.Map.Strict (Map)
18 import Data.Maybe (Maybe(..), maybe)
19 import Data.Monoid (Monoid(..))
20 import Data.Semigroup (Semigroup(..))
21 import Data.Sequence ((|>))
22 import Data.Traversable (Traversable(..))
23 import Data.TreeMap.Strict (TreeMap(..))
24 import Data.TreeSeq.Strict (Tree(..), tree0)
25 import qualified Control.Monad.Trans.State as S
26 import qualified Data.Char as Char
27 import qualified Data.List as List
28 import qualified Data.Map.Strict as Map
29 import qualified Data.Sequence as Seq
30 import qualified Data.Strict.Maybe as Strict
31 import qualified Data.Text.Lazy as TL
32 import qualified Data.TreeMap.Strict as TreeMap
33 -- import qualified Data.TreeSeq.Strict as TreeSeq
35 import Language.DTC.Document
38 type PathWord = TreeMap.Path Word
40 pathFromWords :: Words -> Maybe PathWord
42 case ws >>= unSpace of
43 p:ps | not (TL.null p) -> Just (TreeMap.path p ps)
51 type Irefs = TreeMap Word [Anchor]
53 irefsOfTerms :: Terms -> Irefs
54 irefsOfTerms = TreeMap.fromList const . (>>= f) . concat
57 f ws = maybe [] (\p -> [(p,[])]) $ pathFromWords ws
60 type Rrefs = Map Ident [Anchor]
63 type Notes = Map PosPath [Note]
67 , note_content :: [Para]
68 } -- deriving (Eq,Show)
73 { state_section :: Pos
74 , state_irefs :: Irefs
75 , state_rrefs :: Rrefs
76 , state_notes :: Notes
79 instance Default State where
82 , state_irefs = mempty
88 -- * Class 'Anchorify'
89 class Anchorify a where
90 anchorify :: a -> S.State State a
91 instance Anchorify a => Anchorify (Maybe a) where
92 anchorify = traverse anchorify
94 instance Anchorify Body where
95 anchorify = traverse anchorify
96 instance Anchorify (Tree BodyNode) where
100 BodySection{..} -> do
101 before@State{state_section} <- S.get
102 S.put before{state_section = pos}
103 t <- Tree <$> anchorify n <*> anchorify ts
105 S.put after{state_section}
107 BodyBlock{} -> tree0 <$> anchorify n
108 instance Anchorify BodyNode where
111 BodySection pos attrs
114 BodyBlock b -> BodyBlock <$> anchorify b
116 instance Anchorify Block where
118 BlockPara p -> BlockPara <$> anchorify p
119 b@BlockBreak{} -> return b
120 b@BlockToC{} -> return b
121 b@BlockToF{} -> return b
122 b@BlockIndex{} -> return b
124 BlockFigure pos attrs type_
125 <$> anchorify mayTitle
127 BlockReferences{..} ->
128 BlockReferences pos attrs
130 instance Anchorify [Block] where
131 anchorify = traverse anchorify
132 instance Anchorify [[Block]] where
133 anchorify = traverse anchorify
135 instance Anchorify Para where
137 ParaItem{..} -> ParaItem <$> anchorify item
138 ParaItems{..} -> ParaItems pos attrs <$> anchorify items
139 instance Anchorify ParaItem where
141 ParaPlain plain -> ParaPlain <$> anchorify plain
142 ParaOL items -> ParaOL <$> anchorify items
143 ParaUL items -> ParaUL <$> anchorify items
144 ParaQuote{..} -> ParaQuote type_ <$> anchorify paras
145 p@ParaArtwork{} -> return p
146 p@ParaComment{} -> return p
147 instance Anchorify [ParaItem] where
148 anchorify = traverse anchorify
150 instance Anchorify Plain where
156 else traverse anchorify p
157 traverse (traverse collect) indexed
159 -- TODO: maybe move to Anchorify (Tree PlainNode)
160 collect :: PlainNode -> S.State State PlainNode
164 let notes = Map.findWithDefault [] (posAncestors state_section) state_notes
166 { state_notes = Map.insert (posAncestors state_section) (Note state_note note:notes) state_notes
167 , state_note = succNat1 state_note }
168 return PlainNote{number=Just state_note, note}
171 let anchs = Map.findWithDefault [] to state_rrefs
172 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
173 let anch = Anchor{count, section=state_section}
174 S.modify $ \s -> s{state_rrefs=
175 Map.insert to (anch:anchs) state_rrefs}
176 return PlainRref{anchor=Just anch, to}
178 instance Anchorify [Para] where
179 anchorify = traverse anchorify
180 instance Anchorify [[Para]] where
181 anchorify = traverse anchorify
182 instance Anchorify ListItem where
183 anchorify ListItem{..} = ListItem name <$> anchorify paras
184 instance Anchorify [ListItem] where
185 anchorify = traverse anchorify
186 instance Anchorify (Tree PlainNode) where
187 anchorify t@(Tree n ts) =
189 PlainIref{term} | Just words <- pathFromWords term -> do
190 State{state_irefs, state_section} <- S.get
191 case TreeMap.lookup words state_irefs of
193 Tree n <$> traverse anchorify ts
194 Strict.Just anchs -> do
195 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
196 let anch = Anchor{count, section=state_section}
197 S.modify $ \s -> s{state_irefs=
198 TreeMap.insert const words (anch:anchs) state_irefs}
199 Tree PlainIref{term, anchor=Just anch}
200 <$> traverse anchorify ts
203 let (irefs,para) = indexifyWords state_section state_irefs (wordify txt)
204 S.modify $ \s -> s{state_irefs=irefs}
205 return $ Tree PlainGroup para
206 PlainBreak -> return t
207 _ -> Tree n <$> traverse anchorify ts
209 instance Anchorify Title where
210 anchorify (Title p) = Title <$> anchorify p
211 instance Anchorify Reference where
213 instance Anchorify [Reference] where
214 anchorify = traverse anchorify
216 indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Plain)
217 indexifyWords section = go mempty
219 go :: Plain -> Irefs -> Words -> (Irefs, Plain)
224 go (acc |> tree0 (PlainText " ")) irefs next
226 case goWords irefs [] inp of
227 Nothing -> go (acc |> tree0 (PlainText w)) irefs next
228 Just (anch, ls, ns, rs) ->
229 let term = List.reverse ls in
230 let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> term in
231 go (acc |> Tree PlainIref{term, anchor=Just anch} lines) rs ns
235 Maybe (Anchor, Words, Words, Irefs)
236 goWords m@(TreeMap irefsByWord) prev inp =
239 curr@Space : next -> goWords m (curr:prev) next
240 curr@(Word w) : next ->
241 case Map.lookup w irefsByWord of
243 Just nod@TreeMap.Node{..} ->
244 let prev' = curr:prev in
247 | null node_descendants -> Nothing
249 (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
250 (anch, ls, ns, TreeMap $
251 Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
253 case goWords node_descendants prev' next of
255 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
256 let anch = Anchor{count, section} in
257 Just (anch, prev', next, TreeMap $
258 Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
259 Just (anch, ls, ns, rs) ->
260 Just (anch, ls, ns, TreeMap $
261 Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
263 wordify :: TL.Text -> Words
264 wordify = List.reverse . go []
266 go :: Words -> TL.Text -> Words
268 case TL.span Char.isAlphaNum t of
270 case TL.span Char.isSpace t of
274 Just (c,r) -> go (Word (TL.singleton c) : acc) r
275 (_s,r) -> go (Space : acc) r
276 (w,r) -> go (Word w : acc) r
278 plainifyWord :: WordOrSpace -> TL.Text
283 plainifyWords :: Words -> TL.Text
284 plainifyWords = TL.concat . (plainifyWord <$>)
286 termsByChar :: Terms -> Map Char Terms
288 foldr (\aliases acc ->
290 (Word w:_):_ | not (TL.null w) ->
292 (Char.toUpper $ TL.index w 0)