]> Git — Sourcephile - doclang.git/blob - Hdoc/DTC/Anchor.hs
Rename Language -> Hdoc.
[doclang.git] / Hdoc / DTC / Anchor.hs
1 {-# LANGUAGE DuplicateRecordFields #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# OPTIONS_GHC -fno-warn-orphans #-}
6 module Hdoc.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 Hdoc.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@BlockBreak{} -> return b
120 b@BlockToC{} -> return b
121 b@BlockToF{} -> return b
122 b@BlockIndex{} -> return b
123 BlockFigure{..} ->
124 BlockFigure pos attrs type_
125 <$> anchorify mayTitle
126 <*> anchorify paras
127 BlockReferences{..} ->
128 BlockReferences pos attrs
129 <$> anchorify refs
130 instance Anchorify [Block] where
131 anchorify = traverse anchorify
132 instance Anchorify [[Block]] where
133 anchorify = traverse anchorify
134
135 instance Anchorify Para where
136 anchorify = \case
137 ParaItem{..} -> ParaItem <$> anchorify item
138 ParaItems{..} -> ParaItems pos attrs <$> anchorify items
139 instance Anchorify ParaItem where
140 anchorify = \case
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
149
150 instance Anchorify Plain where
151 anchorify p = do
152 State{..} <- S.get
153 indexed <-
154 if null state_irefs
155 then return p
156 else traverse anchorify p
157 traverse (traverse collect) indexed
158 where
159 -- TODO: maybe move to Anchorify (Tree PlainNode)
160 collect :: PlainNode -> S.State State PlainNode
161 collect = \case
162 PlainNote{..} -> do
163 State{..} <- S.get
164 let notes = Map.findWithDefault [] (posAncestors state_section) state_notes
165 S.modify $ \s -> s
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}
169 PlainRref{..} -> do
170 State{..} <- S.get
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}
177 n -> return n
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) =
188 case n of
189 PlainIref{term} | Just words <- pathFromWords term -> do
190 State{state_irefs, state_section} <- S.get
191 case TreeMap.lookup words state_irefs of
192 Strict.Nothing ->
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
201 PlainText txt -> do
202 State{..} <- S.get
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
208
209 instance Anchorify Title where
210 anchorify (Title p) = Title <$> anchorify p
211 instance Anchorify Reference where
212 anchorify = return
213 instance Anchorify [Reference] where
214 anchorify = traverse anchorify
215
216 indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Plain)
217 indexifyWords section = go mempty
218 where
219 go :: Plain -> Irefs -> Words -> (Irefs, Plain)
220 go acc irefs inp =
221 case inp of
222 [] -> (irefs, acc)
223 Space : next ->
224 go (acc |> tree0 (PlainText " ")) irefs next
225 Word w : 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
232 goWords ::
233 Irefs ->
234 Words -> Words ->
235 Maybe (Anchor, Words, Words, Irefs)
236 goWords m@(TreeMap irefsByWord) prev inp =
237 case inp of
238 [] -> Nothing
239 curr@Space : next -> goWords m (curr:prev) next
240 curr@(Word w) : next ->
241 case Map.lookup w irefsByWord of
242 Nothing -> Nothing
243 Just nod@TreeMap.Node{..} ->
244 let prev' = curr:prev in
245 case node_value of
246 Strict.Nothing
247 | null node_descendants -> Nothing
248 | otherwise ->
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)
252 Strict.Just anchs ->
253 case goWords node_descendants prev' next of
254 Nothing ->
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)
262
263 wordify :: TL.Text -> Words
264 wordify = List.reverse . go []
265 where
266 go :: Words -> TL.Text -> Words
267 go acc t =
268 case TL.span Char.isAlphaNum t of
269 ("",_) ->
270 case TL.span Char.isSpace t of
271 ("",_) ->
272 case TL.uncons t of
273 Nothing -> acc
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
277
278 plainifyWord :: WordOrSpace -> TL.Text
279 plainifyWord = \case
280 Word w -> w
281 Space -> " "
282
283 plainifyWords :: Words -> TL.Text
284 plainifyWords = TL.concat . (plainifyWord <$>)
285
286 termsByChar :: Terms -> Map Char Terms
287 termsByChar =
288 foldr (\aliases acc ->
289 case aliases of
290 (Word w:_):_ | not (TL.null w) ->
291 Map.insertWith (<>)
292 (Char.toUpper $ TL.index w 0)
293 [aliases] acc
294 _ -> acc
295 ) Map.empty