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@BlockToC{} -> return b
120 b@BlockToF{} -> return b
121 b@BlockIndex{} -> return b
123 BlockFigure pos attrs type_
124 <$> anchorify mayTitle
126 BlockReferences{..} ->
127 BlockReferences pos attrs
129 instance Anchorify [Block] where
130 anchorify = traverse anchorify
131 instance Anchorify [[Block]] where
132 anchorify = traverse anchorify
134 instance Anchorify Para where
136 ParaItem{..} -> ParaItem <$> anchorify item
137 ParaItems{..} -> ParaItems pos attrs <$> anchorify items
138 instance Anchorify ParaItem where
140 ParaPlain plain -> ParaPlain <$> anchorify plain
141 ParaOL items -> ParaOL <$> anchorify items
142 ParaUL items -> ParaUL <$> anchorify items
143 ParaQuote{..} -> ParaQuote type_ <$> anchorify paras
144 p@ParaArtwork{} -> return p
145 p@ParaComment{} -> return p
146 instance Anchorify [ParaItem] where
147 anchorify = traverse anchorify
149 instance Anchorify Plain where
155 else traverse anchorify p
156 traverse (traverse collect) indexed
158 -- TODO: maybe move to Anchorify (Tree PlainNode)
159 collect :: PlainNode -> S.State State PlainNode
163 let notes = Map.findWithDefault [] (posAncestors state_section) state_notes
165 { state_notes = Map.insert (posAncestors state_section) (Note state_note note:notes) state_notes
166 , state_note = succNat1 state_note }
167 return PlainNote{number=Just state_note, note}
170 let anchs = Map.findWithDefault [] to state_rrefs
171 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
172 let anch = Anchor{count, section=state_section}
173 S.modify $ \s -> s{state_rrefs=
174 Map.insert to (anch:anchs) state_rrefs}
175 return PlainRref{anchor=Just anch, to}
177 instance Anchorify [Para] where
178 anchorify = traverse anchorify
179 instance Anchorify [[Para]] where
180 anchorify = traverse anchorify
181 instance Anchorify (Tree PlainNode) where
182 anchorify t@(Tree n ts) =
184 PlainIref{term} | Just words <- pathFromWords term -> do
185 State{state_irefs, state_section} <- S.get
186 case TreeMap.lookup words state_irefs of
188 Tree n <$> traverse anchorify ts
189 Strict.Just anchs -> do
190 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
191 let anch = Anchor{count, section=state_section}
192 S.modify $ \s -> s{state_irefs=
193 TreeMap.insert const words (anch:anchs) state_irefs}
194 Tree PlainIref{term, anchor=Just anch}
195 <$> traverse anchorify ts
198 let (irefs,para) = indexifyWords state_section state_irefs (wordify txt)
199 S.modify $ \s -> s{state_irefs=irefs}
200 return $ Tree PlainGroup para
202 _ -> Tree n <$> traverse anchorify ts
204 instance Anchorify Title where
205 anchorify (Title p) = Title <$> anchorify p
206 instance Anchorify Reference where
208 instance Anchorify [Reference] where
209 anchorify = traverse anchorify
211 indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Plain)
212 indexifyWords section = go mempty
214 go :: Plain -> Irefs -> Words -> (Irefs, Plain)
219 go (acc |> tree0 (PlainText " ")) irefs next
221 case goWords irefs [] inp of
222 Nothing -> go (acc |> tree0 (PlainText w)) irefs next
223 Just (anch, ls, ns, rs) ->
224 let term = List.reverse ls in
225 let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> term in
226 go (acc |> Tree PlainIref{term, anchor=Just anch} lines) rs ns
230 Maybe (Anchor, Words, Words, Irefs)
231 goWords m@(TreeMap irefsByWord) prev inp =
234 curr@Space : next -> goWords m (curr:prev) next
235 curr@(Word w) : next ->
236 case Map.lookup w irefsByWord of
238 Just nod@TreeMap.Node{..} ->
239 let prev' = curr:prev in
242 | null node_descendants -> Nothing
244 (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
245 (anch, ls, ns, TreeMap $
246 Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
248 case goWords node_descendants prev' next of
250 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
251 let anch = Anchor{count, section} in
252 Just (anch, prev', next, TreeMap $
253 Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
254 Just (anch, ls, ns, rs) ->
255 Just (anch, ls, ns, TreeMap $
256 Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
258 wordify :: TL.Text -> Words
259 wordify = List.reverse . go []
261 go :: Words -> TL.Text -> Words
263 case TL.span Char.isAlphaNum t of
265 case TL.span Char.isSpace t of
269 Just (c,r) -> go (Word (TL.singleton c) : acc) r
270 (_s,r) -> go (Space : acc) r
271 (w,r) -> go (Word w : acc) r
273 plainifyWord :: WordOrSpace -> TL.Text
278 plainifyWords :: Words -> TL.Text
279 plainifyWords = TL.concat . (plainifyWord <$>)
281 termsByChar :: Terms -> Map Char Terms
283 foldr (\aliases acc ->
285 (Word w:_):_ | not (TL.null w) ->
287 (Char.toUpper $ TL.index w 0)