]> Git — Sourcephile - doclang.git/blob - Language/DTC/Anchor.hs
Fix writing TCT to XML.
[doclang.git] / Language / DTC / Anchor.hs
1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# OPTIONS_GHC -fno-warn-orphans #-}
6 module Language.DTC.Anchor where
7
8 import Control.Applicative (Applicative(..))
9 import Control.Category
10 import Control.Monad (Monad(..), mapM, join)
11 import Data.Bool
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.Text (Text)
23 import Data.Traversable (Traversable(..))
24 import Data.TreeMap.Strict (TreeMap(..))
25 import Data.TreeSeq.Strict (Tree(..))
26 import qualified Control.Monad.Trans.State as S
27 import qualified Data.Char as Char
28 import qualified Data.List as List
29 import qualified Data.Map.Strict as Map
30 import qualified Data.Sequence as Seq
31 import qualified Data.Strict.Maybe as Strict
32 import qualified Data.Text as Text
33 import qualified Data.TreeMap.Strict as TreeMap
34 -- import qualified Data.TreeSeq.Strict as Tree
35
36 import Language.DTC.Document
37
38 -- * Type 'PathWord'
39 type PathWord = TreeMap.Path Word
40
41 pathFromWords :: Words -> Maybe PathWord
42 pathFromWords ws =
43 case ws >>= unSpace of
44 p:ps | not (Text.null p) -> Just (TreeMap.path p ps)
45 _ -> Nothing
46 where
47 unSpace = \case
48 Space -> []
49 Word w -> [w]
50
51 -- * Type 'Irefs'
52 type Irefs = TreeMap Word [Anchor]
53
54 irefsOfTerms :: Terms -> Irefs
55 irefsOfTerms = TreeMap.fromList const . (>>= f) . concat
56 where
57 f [] = []
58 f ws = maybe [] (\p -> [(p,[])]) $ pathFromWords ws
59
60 -- * Type 'Rrefs'
61 type Rrefs = Map Ident [Anchor]
62
63 -- * Type 'Notes'
64 type Notes = Map Pos [(Nat1,Para)]
65
66 -- * Type 'State'
67 data State
68 = State
69 { state_section :: Pos
70 , state_irefs :: Irefs
71 , state_rrefs :: Rrefs
72 , state_notes :: Notes
73 }
74 instance Default State where
75 def = State
76 { state_section = def
77 , state_irefs = mempty
78 , state_rrefs = mempty
79 , state_notes = mempty
80 }
81
82 -- * Class 'Anchorify'
83 class Anchorify a where
84 anchorify :: a -> S.State State a
85 instance Anchorify (Tree k a) => Anchorify [Tree k a] where
86 anchorify = mapM anchorify
87 instance Anchorify (Tree BodyKey BodyValue) where
88 anchorify = \case
89 Tree0 v -> Tree0 <$> anchorify v
90 TreeN k v ->
91 case k of
92 Section{..} -> do
93 before@State{state_section} <- S.get
94 S.put before{state_section = pos}
95 t <- TreeN <$> anchorify k <*> anchorify v
96 after <- S.get
97 S.put after{state_section}
98 return t
99 instance Anchorify Body where
100 anchorify = mapM anchorify
101 instance Anchorify BodyKey where
102 anchorify = \case
103 Section{..} ->
104 Section pos attrs
105 <$> anchorify title
106 <*> pure aliases
107 instance Anchorify BodyValue where
108 anchorify = \case
109 d@ToC{} -> pure d
110 d@ToF{} -> pure d
111 d@Index{} -> pure d
112 Figure{..} ->
113 Figure pos attrs type_
114 <$> anchorify title
115 <*> anchorify blocks
116 References{..} ->
117 References pos attrs
118 <$> anchorify refs
119 Block v ->
120 Block <$> anchorify v
121 instance Anchorify a => Anchorify (Maybe a) where
122 anchorify = mapM anchorify
123 instance Anchorify [Reference] where
124 anchorify = mapM anchorify
125 instance Anchorify [Block] where
126 anchorify = mapM anchorify
127 instance Anchorify [[Block]] where
128 anchorify = mapM (mapM anchorify)
129 instance Anchorify Title where
130 anchorify (Title t) = Title <$> anchorify t
131 instance Anchorify Block where
132 anchorify = \case
133 Para{..} -> Para pos attrs <$> anchorify para
134 OL{..} -> OL pos attrs <$> anchorify items
135 UL{..} -> UL pos attrs <$> anchorify items
136 Artwork{..} -> Artwork pos attrs <$> anchorify art
137 d@Comment{} -> pure d
138 instance Anchorify Para where
139 anchorify ls = do
140 State{..} <- S.get
141 indexed <-
142 if null state_irefs
143 then return ls
144 else join <$> traverse indexifyLines ls
145 traverse go indexed
146 where
147 go :: Lines -> S.State State Lines
148 go t =
149 case t of
150 Tree0{} -> return t
151 TreeN k ts ->
152 TreeN
153 <$> (case k of
154 Note{..} -> do
155 State{..} <- S.get
156 let notes = Map.findWithDefault [] state_section state_notes
157 let count | (cnt,_):_ <- notes = succNat1 cnt
158 | otherwise = Nat1 1
159 S.modify $ \s -> s{state_notes=
160 Map.insert state_section ((count,ts):notes) state_notes}
161 return Note{number=Just count}
162 Rref{..} -> do
163 State{..} <- S.get
164 let anchs = Map.findWithDefault [] to state_rrefs
165 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
166 let anch = Anchor{count, section=state_section}
167 S.modify $ \s -> s{state_rrefs=
168 Map.insert to (anch:anchs) state_rrefs}
169 return Rref{anchor=Just anch, to}
170 _ -> return k)
171 <*> traverse go ts
172 instance Anchorify Reference where
173 anchorify = return
174 instance Anchorify Artwork where
175 anchorify = return
176
177 indexifyLines :: Lines -> S.State State Para
178 indexifyLines = \case
179 Tree0 a -> indexifyPlain a
180 TreeN k@Iref{term} ts
181 | Just words <- pathFromWords term -> do
182 State{state_irefs, state_section} <- S.get
183 case TreeMap.lookup words state_irefs of
184 Strict.Nothing ->
185 Seq.singleton . TreeN k . join
186 <$> traverse indexifyLines ts
187 Strict.Just anchs -> do
188 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
189 let anch = Anchor{count, section=state_section}
190 S.modify $ \s -> s{state_irefs=
191 TreeMap.insert const words (anch:anchs) state_irefs}
192 Seq.singleton . TreeN Iref{term, anchor=Just anch} . join
193 <$> traverse indexifyLines ts
194 TreeN k ts ->
195 Seq.singleton . TreeN k . join
196 <$> traverse indexifyLines ts
197
198 indexifyPlain :: LineValue -> S.State State Para
199 indexifyPlain = \case
200 BR -> pure $ Seq.singleton $ Tree0 BR
201 Plain p -> do
202 State{..} <- S.get
203 let (irefs,ts) = indexifyWords state_section state_irefs (wordify p)
204 S.modify $ \s -> s{state_irefs=irefs}
205 return ts
206
207 indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Para)
208 indexifyWords section = go mempty
209 where
210 go :: Para -> Irefs -> Words -> (Irefs, Para)
211 go acc irefs inp =
212 case inp of
213 [] -> (irefs, acc)
214 Space : next ->
215 go (acc |> Tree0 (Plain " ")) irefs next
216 Word w : next ->
217 case goWords irefs [] inp of
218 Nothing -> go (acc |> Tree0 (Plain w)) irefs next
219 Just (anch, ls, ns, rs) ->
220 let term = List.reverse ls in
221 let lines = Seq.fromList $ Tree0 . Plain . plainifyWord <$> term in
222 go (acc |> TreeN Iref{term, anchor=Just anch} lines) rs ns
223 goWords ::
224 Irefs ->
225 Words -> Words ->
226 Maybe (Anchor, Words, Words, Irefs)
227 goWords m@(TreeMap irefsByWord) prev inp =
228 case inp of
229 [] -> Nothing
230 curr@Space : next -> goWords m (curr:prev) next
231 curr@(Word w) : next ->
232 case Map.lookup w irefsByWord of
233 Nothing -> Nothing
234 Just nod@TreeMap.Node{..} ->
235 let prev' = curr:prev in
236 case node_value of
237 Strict.Nothing
238 | null node_descendants -> Nothing
239 | otherwise ->
240 (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
241 (anch, ls, ns, TreeMap $
242 Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
243 Strict.Just anchs ->
244 case goWords node_descendants prev' next of
245 Nothing ->
246 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
247 let anch = Anchor{count, section} in
248 Just (anch, prev', next, TreeMap $
249 Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
250 Just (anch, ls, ns, rs) ->
251 Just (anch, ls, ns, TreeMap $
252 Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
253
254 wordify :: Text -> Words
255 wordify = List.reverse . go []
256 where
257 go :: Words -> Text -> Words
258 go acc t =
259 case Text.span Char.isAlphaNum t of
260 ("",_) ->
261 case Text.span Char.isSpace t of
262 ("",_) ->
263 case Text.uncons t of
264 Nothing -> acc
265 Just (c,r) -> go (Word (Text.singleton c) : acc) r
266 (_s,r) -> go (Space : acc) r
267 (w,r) -> go (Word w : acc) r
268
269 plainifyWord :: WordOrSpace -> Text
270 plainifyWord = \case
271 Word w -> w
272 Space -> " "
273
274 plainifyWords :: Words -> Text
275 plainifyWords = Text.concat . (plainifyWord <$>)
276
277 termsByChar :: Terms -> Map Char Terms
278 termsByChar =
279 foldr (\aliases acc ->
280 case aliases of
281 (Word w:_):_ | not (Text.null w) ->
282 Map.insertWith (<>)
283 (Char.toUpper $ Text.index w 0)
284 [aliases] acc
285 _ -> acc
286 ) Map.empty