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