]> Git — Sourcephile - doclang.git/blob - Language/DTC/Anchor.hs
Add better support for HeaderDotSlash including.
[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(..))
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 PosPath [Note]
64 data Note
65 = Note
66 { note_number :: Nat1
67 , note_content :: [Para]
68 } -- deriving (Eq,Show)
69
70 -- * Type 'State'
71 data State
72 = State
73 { state_section :: Pos
74 , state_irefs :: Irefs
75 , state_rrefs :: Rrefs
76 , state_notes :: Notes
77 , state_note :: Nat1
78 }
79 instance Default State where
80 def = State
81 { state_section = def
82 , state_irefs = mempty
83 , state_rrefs = def
84 , state_notes = def
85 , state_note = def
86 }
87
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
93
94 instance Anchorify Body where
95 anchorify = traverse anchorify
96 instance Anchorify (Tree BodyNode) where
97 anchorify = \case
98 Tree n ts ->
99 case n of
100 BodySection{..} -> do
101 before@State{state_section} <- S.get
102 S.put before{state_section = pos}
103 t <- Tree <$> anchorify n <*> anchorify ts
104 after <- S.get
105 S.put after{state_section}
106 return t
107 BodyBlock{} -> tree0 <$> anchorify n
108 instance Anchorify BodyNode where
109 anchorify = \case
110 BodySection{..} ->
111 BodySection pos attrs
112 <$> anchorify title
113 <*> pure aliases
114 BodyBlock b -> BodyBlock <$> anchorify b
115
116 instance Anchorify Block where
117 anchorify = \case
118 BlockPara p -> BlockPara <$> anchorify p
119 b@BlockToC{} -> return b
120 b@BlockToF{} -> return b
121 b@BlockIndex{} -> return b
122 BlockFigure{..} ->
123 BlockFigure pos attrs type_
124 <$> anchorify mayTitle
125 <*> anchorify paras
126 BlockReferences{..} ->
127 BlockReferences pos attrs
128 <$> anchorify refs
129 instance Anchorify [Block] where
130 anchorify = traverse anchorify
131 instance Anchorify [[Block]] where
132 anchorify = traverse anchorify
133
134 instance Anchorify Para where
135 anchorify = \case
136 ParaItem{..} -> ParaItem <$> anchorify item
137 ParaItems{..} -> ParaItems pos attrs <$> anchorify items
138 instance Anchorify ParaItem where
139 anchorify = \case
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
148
149 instance Anchorify Plain where
150 anchorify p = do
151 State{..} <- S.get
152 indexed <-
153 if null state_irefs
154 then return p
155 else traverse anchorify p
156 traverse (traverse collect) indexed
157 where
158 -- TODO: maybe move to Anchorify (Tree PlainNode)
159 collect :: PlainNode -> S.State State PlainNode
160 collect = \case
161 PlainNote{..} -> do
162 State{..} <- S.get
163 let notes = Map.findWithDefault [] (posAncestors state_section) state_notes
164 S.modify $ \s -> s
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}
168 PlainRref{..} -> do
169 State{..} <- S.get
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}
176 n -> return n
177 instance Anchorify [Para] where
178 anchorify = traverse anchorify
179 instance Anchorify [[Para]] where
180 anchorify = traverse anchorify
181 instance Anchorify ListItem where
182 anchorify ListItem{..} = ListItem name <$> anchorify paras
183 instance Anchorify [ListItem] where
184 anchorify = traverse anchorify
185 instance Anchorify (Tree PlainNode) where
186 anchorify t@(Tree n ts) =
187 case n of
188 PlainIref{term} | Just words <- pathFromWords term -> do
189 State{state_irefs, state_section} <- S.get
190 case TreeMap.lookup words state_irefs of
191 Strict.Nothing ->
192 Tree n <$> traverse anchorify ts
193 Strict.Just anchs -> do
194 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
195 let anch = Anchor{count, section=state_section}
196 S.modify $ \s -> s{state_irefs=
197 TreeMap.insert const words (anch:anchs) state_irefs}
198 Tree PlainIref{term, anchor=Just anch}
199 <$> traverse anchorify ts
200 PlainText txt -> do
201 State{..} <- S.get
202 let (irefs,para) = indexifyWords state_section state_irefs (wordify txt)
203 S.modify $ \s -> s{state_irefs=irefs}
204 return $ Tree PlainGroup para
205 PlainBR -> return t
206 _ -> Tree n <$> traverse anchorify ts
207
208 instance Anchorify Title where
209 anchorify (Title p) = Title <$> anchorify p
210 instance Anchorify Reference where
211 anchorify = return
212 instance Anchorify [Reference] where
213 anchorify = traverse anchorify
214
215 indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Plain)
216 indexifyWords section = go mempty
217 where
218 go :: Plain -> Irefs -> Words -> (Irefs, Plain)
219 go acc irefs inp =
220 case inp of
221 [] -> (irefs, acc)
222 Space : next ->
223 go (acc |> tree0 (PlainText " ")) irefs next
224 Word w : next ->
225 case goWords irefs [] inp of
226 Nothing -> go (acc |> tree0 (PlainText w)) irefs next
227 Just (anch, ls, ns, rs) ->
228 let term = List.reverse ls in
229 let lines = Seq.fromList $ tree0 . PlainText . plainifyWord <$> term in
230 go (acc |> Tree PlainIref{term, anchor=Just anch} lines) rs ns
231 goWords ::
232 Irefs ->
233 Words -> Words ->
234 Maybe (Anchor, Words, Words, Irefs)
235 goWords m@(TreeMap irefsByWord) prev inp =
236 case inp of
237 [] -> Nothing
238 curr@Space : next -> goWords m (curr:prev) next
239 curr@(Word w) : next ->
240 case Map.lookup w irefsByWord of
241 Nothing -> Nothing
242 Just nod@TreeMap.Node{..} ->
243 let prev' = curr:prev in
244 case node_value of
245 Strict.Nothing
246 | null node_descendants -> Nothing
247 | otherwise ->
248 (<$> goWords node_descendants prev' next) $ \(anch, ls, ns, rs) ->
249 (anch, ls, ns, TreeMap $
250 Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
251 Strict.Just anchs ->
252 case goWords node_descendants prev' next of
253 Nothing ->
254 let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c in
255 let anch = Anchor{count, section} in
256 Just (anch, prev', next, TreeMap $
257 Map.insert w nod{TreeMap.node_value = Strict.Just $ anch:anchs} irefsByWord)
258 Just (anch, ls, ns, rs) ->
259 Just (anch, ls, ns, TreeMap $
260 Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
261
262 wordify :: TL.Text -> Words
263 wordify = List.reverse . go []
264 where
265 go :: Words -> TL.Text -> Words
266 go acc t =
267 case TL.span Char.isAlphaNum t of
268 ("",_) ->
269 case TL.span Char.isSpace t of
270 ("",_) ->
271 case TL.uncons t of
272 Nothing -> acc
273 Just (c,r) -> go (Word (TL.singleton c) : acc) r
274 (_s,r) -> go (Space : acc) r
275 (w,r) -> go (Word w : acc) r
276
277 plainifyWord :: WordOrSpace -> TL.Text
278 plainifyWord = \case
279 Word w -> w
280 Space -> " "
281
282 plainifyWords :: Words -> TL.Text
283 plainifyWords = TL.concat . (plainifyWord <$>)
284
285 termsByChar :: Terms -> Map Char Terms
286 termsByChar =
287 foldr (\aliases acc ->
288 case aliases of
289 (Word w:_):_ | not (TL.null w) ->
290 Map.insertWith (<>)
291 (Char.toUpper $ TL.index w 0)
292 [aliases] acc
293 _ -> acc
294 ) Map.empty