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