]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/Combinators.hs
Polish code and dumps
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / Combinators.hs
1 -- The default type signature of type class methods are changed
2 -- to introduce a Liftable constraint and the same type class but on the 'Output' repr,
3 -- this setup avoids to define the method with boilerplate code when its default
4 -- definition with lift* and 'trans' does what is expected by an instance
5 -- of the type class. This is almost as explained in:
6 -- https://ro-che.info/articles/2016-02-03-finally-tagless-boilerplate
7 {-# LANGUAGE DefaultSignatures #-}
8 {-# LANGUAGE TemplateHaskell #-}
9 module Symantic.Parser.Grammar.Combinators where
10
11 import Data.Bool (Bool(..), not, (||))
12 import Data.Char (Char)
13 import Data.Either (Either(..))
14 import Data.Eq (Eq(..))
15 import Data.Function ((.), flip, const)
16 import Data.Int (Int)
17 import Data.Maybe (Maybe(..))
18 import Data.String (String)
19 import Language.Haskell.TH (TExpQ)
20 import qualified Data.Functor as Functor
21 import qualified Data.List as List
22
23 import qualified Symantic.Univariant.Trans as Sym
24 import qualified Symantic.Parser.Staging as Hask
25
26 -- * Class 'Applicable'
27 -- | This is like the usual 'Functor' and 'Applicative' type classes
28 -- from the @base@ package, but using @('Hask.Haskell' a)@ instead of just @(a)@
29 -- to be able to use and pattern match on some usual terms of type @(a)@ (like
30 -- 'Hask.id') and thus apply some optimizations.
31 -- @(repr)@ , for "representation", is the usual tagless-final abstraction
32 -- over the many semantics that this syntax (formed by the methods
33 -- of type class like this one) will be interpreted.
34 class Applicable repr where
35 -- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
36 (<$>) :: Hask.Haskell (a -> b) -> repr a -> repr b
37 (<$>) f = (pure f <*>)
38
39 -- | Like '<$>' but with its arguments 'flip'-ped.
40 (<&>) :: repr a -> Hask.Haskell (a -> b) -> repr b
41 (<&>) = flip (<$>)
42
43 -- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
44 (<$) :: Hask.Haskell a -> repr b -> repr a
45 (<$) x = (pure x <*)
46
47 -- | @(ra '$>' b)@ parses like @(ra)@ but discards its returned value by replacing it with @(b)@.
48 ($>) :: repr a -> Hask.Haskell b -> repr b
49 ($>) = flip (<$)
50
51 -- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
52 pure :: Hask.Haskell a -> repr a
53 default pure ::
54 Sym.Liftable repr => Applicable (Sym.Output repr) =>
55 Hask.Haskell a -> repr a
56 pure = Sym.lift . pure
57
58 -- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
59 -- and returns the application of the function returned by @(ra2b)@
60 -- to the value returned by @(ra)@.
61 (<*>) :: repr (a -> b) -> repr a -> repr b
62 default (<*>) ::
63 Sym.Liftable2 repr => Applicable (Sym.Output repr) =>
64 repr (a -> b) -> repr a -> repr b
65 (<*>) = Sym.lift2 (<*>)
66
67 -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,
68 -- and returns the application of @(a2b2c)@ to the values returned by those parsers.
69 liftA2 :: Hask.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
70 liftA2 f x = (<*>) (f <$> x)
71
72 -- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@,
73 -- and returns like @(ra)@, discarding the return value of @(rb)@.
74 (<*) :: repr a -> repr b -> repr a
75 (<*) = liftA2 Hask.const
76
77 -- | @(ra '*>' rb)@ parses sequentially @(ra)@ and then @(rb)@,
78 -- and returns like @(rb)@, discarding the return value of @(ra)@.
79 (*>) :: repr a -> repr b -> repr b
80 x *> y = (Hask.id <$ x) <*> y
81
82 -- | Like '<*>' but with its arguments 'flip'-ped.
83 (<**>) :: repr a -> repr (a -> b) -> repr b
84 (<**>) = liftA2 (Hask.flip Hask..@ (Hask.$))
85 {-
86 (<**>) :: repr a -> repr (a -> b) -> repr b
87 (<**>) = liftA2 (\a f -> f a)
88 -}
89 infixl 4 <$>, <&>, <$, $>, <*>, <*, *>, <**>
90
91 -- * Class 'Alternable'
92 class Alternable repr where
93 -- | @(rl '<|>' rr)@ parses @(rl)@ and return its return value or,
94 -- if it fails, parses @(rr)@ from where @(rl)@ has left the input stream,
95 -- and returns its return value.
96 (<|>) :: repr a -> repr a -> repr a
97 -- | @(empty)@ parses nothing, always failing to return a value.
98 empty :: repr a
99 -- | @('try' ra)@ records the input stream position,
100 -- then parses like @(ra)@ and either returns its value it it succeeds or fails
101 -- if it fails but with a reset of the input stream to the recorded position.
102 -- Generally used on the first alternative: @('try' rl '<|>' rr)@.
103 try :: repr a -> repr a
104 default (<|>) ::
105 Sym.Liftable2 repr => Alternable (Sym.Output repr) =>
106 repr a -> repr a -> repr a
107 default empty ::
108 Sym.Liftable repr => Alternable (Sym.Output repr) =>
109 repr a
110 default try ::
111 Sym.Liftable1 repr => Alternable (Sym.Output repr) =>
112 repr a -> repr a
113 (<|>) = Sym.lift2 (<|>)
114 empty = Sym.lift empty
115 try = Sym.lift1 try
116 -- | Like @('<|>')@ but with different returning types for the alternatives,
117 -- and a return value wrapped in an 'Either' accordingly.
118 (<+>) :: Applicable repr => Alternable repr => repr a -> repr b -> repr (Either a b)
119 p <+> q = Hask.left <$> p <|> Hask.right <$> q
120 infixl 3 <|>, <+>
121
122 optionally :: Applicable repr => Alternable repr => repr a -> Hask.Haskell b -> repr b
123 optionally p x = p $> x <|> pure x
124
125 optional :: Applicable repr => Alternable repr => repr a -> repr ()
126 optional = flip optionally Hask.unit
127
128 option :: Applicable repr => Alternable repr => Hask.Haskell a -> repr a -> repr a
129 option x p = p <|> pure x
130
131 choice :: Alternable repr => [repr a] -> repr a
132 choice = List.foldr (<|>) empty
133 -- FIXME: Here hlint suggests to use Data.Foldable.asum,
134 -- but at this point there is no asum for our own (<|>)
135
136 maybeP :: Applicable repr => Alternable repr => repr a -> repr (Maybe a)
137 maybeP p = option Hask.nothing (Hask.just <$> p)
138
139 manyTill :: Applicable repr => Alternable repr => repr a -> repr b -> repr [a]
140 manyTill p end = let go = end $> Hask.nil <|> p <:> go in go
141
142 -- * Class 'Selectable'
143 class Selectable repr where
144 branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
145 default branch ::
146 Sym.Liftable3 repr => Selectable (Sym.Output repr) =>
147 repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
148 branch = Sym.lift3 branch
149
150 -- * Class 'Matchable'
151 class Matchable repr where
152 conditional ::
153 Eq a => [Hask.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
154 default conditional ::
155 Sym.Unliftable repr => Sym.Liftable2 repr => Matchable (Sym.Output repr) =>
156 Eq a => [Hask.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
157 conditional cs bs = Sym.lift2 (conditional cs (Sym.trans Functor.<$> bs))
158
159 match :: Eq a => [Hask.Haskell a] -> repr a -> (Hask.Haskell a -> repr b) -> repr b -> repr b
160 match as a a2b = conditional (Hask.eq Functor.<$> as) (a2b Functor.<$> as) a
161
162 -- * Class 'Foldable'
163 class Foldable repr where
164 chainPre :: repr (a -> a) -> repr a -> repr a
165 chainPost :: repr a -> repr (a -> a) -> repr a
166 default chainPre ::
167 Sym.Liftable2 repr => Foldable (Sym.Output repr) =>
168 repr (a -> a) -> repr a -> repr a
169 default chainPost ::
170 Sym.Liftable2 repr => Foldable (Sym.Output repr) =>
171 repr a -> repr (a -> a) -> repr a
172 chainPre = Sym.lift2 chainPre
173 chainPost = Sym.lift2 chainPost
174
175 {-
176 conditional :: Selectable repr => [(Hask.Haskell (a -> Bool), repr b)] -> repr a -> repr b -> repr b
177 conditional cs p def = match p fs qs def
178 where (fs, qs) = List.unzip cs
179 -}
180
181 -- * Class 'Charable'
182 class Charable repr where
183 satisfy :: Hask.Haskell (Char -> Bool) -> repr Char
184 default satisfy ::
185 Sym.Liftable repr => Charable (Sym.Output repr) =>
186 Hask.Haskell (Char -> Bool) -> repr Char
187 satisfy = Sym.lift . satisfy
188
189 -- * Class 'Lookable'
190 class Lookable repr where
191 look :: repr a -> repr a
192 negLook :: repr a -> repr ()
193 default look :: Sym.Liftable1 repr => Lookable (Sym.Output repr) => repr a -> repr a
194 default negLook :: Sym.Liftable1 repr => Lookable (Sym.Output repr) => repr a -> repr ()
195 look = Sym.lift1 look
196 negLook = Sym.lift1 negLook
197
198 {-# INLINE (<:>) #-}
199 infixl 4 <:>
200 (<:>) :: Applicable repr => repr a -> repr [a] -> repr [a]
201 (<:>) = liftA2 Hask.cons
202
203 sequence :: Applicable repr => [repr a] -> repr [a]
204 sequence = List.foldr (<:>) (pure Hask.nil)
205
206 traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
207 traverse f = sequence . List.map f
208 -- FIXME: Here hlint suggests to use Control.Monad.mapM,
209 -- but at this point there is no mapM for our own sequence
210
211 repeat :: Applicable repr => Int -> repr a -> repr [a]
212 repeat n p = traverse (const p) [1..n]
213
214 between :: Applicable repr => repr o -> repr c -> repr a -> repr a
215 between open close p = open *> p <* close
216
217 string :: Applicable repr => Charable repr => String -> repr String
218 string = traverse char
219
220 -- oneOf :: [Char] -> repr Char
221 -- oneOf cs = satisfy (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])
222
223 noneOf :: Charable repr => String -> repr Char
224 noneOf cs = satisfy (Hask.Haskell Hask.ValueCode{..})
225 where
226 value = Hask.Value (not . flip List.elem cs)
227 code = Hask.Code [||\c -> not $$(ofChars cs [||c||])||]
228
229 ofChars :: String -> TExpQ Char -> TExpQ Bool
230 ofChars = List.foldr (\c rest qc -> [|| c == $$qc || $$(rest qc) ||]) (const [||False||])
231
232 token :: Applicable repr => Alternable repr => Charable repr => String -> repr String
233 token = try . string
234
235 eof :: Charable repr => Lookable repr => repr ()
236 eof = negLook item
237
238 more :: Applicable repr => Charable repr => Lookable repr => repr ()
239 more = look (void item)
240
241 char :: Applicable repr => Charable repr => Char -> repr Char
242 char c = satisfy (Hask.eq (Hask.char c)) $> Hask.char c
243
244 item :: Charable repr => repr Char
245 item = satisfy (Hask.const Hask..@ Hask.bool True)
246
247 -- Composite Combinators
248 -- someTill :: repr a -> repr b -> repr [a]
249 -- someTill p end = negLook end *> (p <:> manyTill p end)
250
251 void :: Applicable repr => repr a -> repr ()
252 void p = p *> unit
253
254 unit :: Applicable repr => repr ()
255 unit = pure Hask.unit
256
257 {-
258
259 constp :: Applicable repr => repr a -> repr (b -> a)
260 constp = (Hask.const <$>)
261
262
263 -- Alias Operations
264 infixl 1 >>
265 (>>) :: Applicable repr => repr a -> repr b -> repr b
266 (>>) = (*>)
267
268 -- Monoidal Operations
269
270 infixl 4 <~>
271 (<~>) :: Applicable repr => repr a -> repr b -> repr (a, b)
272 (<~>) = liftA2 (Hask.runtime (,))
273
274 infixl 4 <~
275 (<~) :: Applicable repr => repr a -> repr b -> repr a
276 (<~) = (<*)
277
278 infixl 4 ~>
279 (~>) :: Applicable repr => repr a -> repr b -> repr b
280 (~>) = (*>)
281
282 -- Lift Operations
283 liftA2 ::
284 Applicable repr =>
285 Hask.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
286 liftA2 f x = (<*>) (fmap f x)
287
288 liftA3 ::
289 Applicable repr =>
290 Hask.Haskell (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
291 liftA3 f a b c = liftA2 f a b <*> c
292
293 -}
294
295 -- Parser Folds
296 pfoldr ::
297 Applicable repr => Foldable repr =>
298 Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
299 pfoldr f k p = chainPre (f <$> p) (pure k)
300
301 pfoldr1 ::
302 Applicable repr => Foldable repr =>
303 Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
304 pfoldr1 f k p = f <$> p <*> pfoldr f k p
305
306 pfoldl ::
307 Applicable repr => Foldable repr =>
308 Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
309 pfoldl f k p = chainPost (pure k) ((Hask.flip <$> pure f) <*> p)
310
311 pfoldl1 ::
312 Applicable repr => Foldable repr =>
313 Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
314 pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Hask.flip <$> pure f) <*> p)
315
316 -- Chain Combinators
317 chainl1' ::
318 Applicable repr => Foldable repr =>
319 Hask.Haskell (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
320 chainl1' f p op = chainPost (f <$> p) (Hask.flip <$> op <*> p)
321
322 chainl1 ::
323 Applicable repr => Foldable repr =>
324 repr a -> repr (a -> a -> a) -> repr a
325 chainl1 = chainl1' Hask.id
326
327 {-
328 chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
329 chainr1' f p op = newRegister_ Hask.id $ \acc ->
330 let go = bind p $ \x ->
331 modify acc (Hask.flip (Hask..@) <$> (op <*> x)) *> go
332 <|> f <$> x
333 in go <**> get acc
334
335 chainr1 :: repr a -> repr (a -> a -> a) -> repr a
336 chainr1 = chainr1' Hask.id
337
338 chainr :: repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
339 chainr p op x = option x (chainr1 p op)
340 -}
341
342 chainl ::
343 Applicable repr => Alternable repr => Foldable repr =>
344 repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
345 chainl p op x = option x (chainl1 p op)
346
347 -- Derived Combinators
348 many ::
349 Applicable repr => Foldable repr =>
350 repr a -> repr [a]
351 many = pfoldr Hask.cons Hask.nil
352
353 manyN ::
354 Applicable repr => Foldable repr =>
355 Int -> repr a -> repr [a]
356 manyN n p = List.foldr (const (p <:>)) (many p) [1..n]
357
358 some ::
359 Applicable repr => Foldable repr =>
360 repr a -> repr [a]
361 some = manyN 1
362
363 skipMany ::
364 Applicable repr => Foldable repr =>
365 repr a -> repr ()
366 --skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
367 skipMany = void . pfoldl Hask.const Hask.unit -- the void here will encourage the optimiser to recognise that the register is unused
368
369 skipManyN ::
370 Applicable repr => Foldable repr =>
371 Int -> repr a -> repr ()
372 skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]
373
374 skipSome ::
375 Applicable repr => Foldable repr =>
376 repr a -> repr ()
377 skipSome = skipManyN 1
378
379 sepBy ::
380 Applicable repr => Alternable repr => Foldable repr =>
381 repr a -> repr b -> repr [a]
382 sepBy p sep = option Hask.nil (sepBy1 p sep)
383
384 sepBy1 ::
385 Applicable repr => Alternable repr => Foldable repr =>
386 repr a -> repr b -> repr [a]
387 sepBy1 p sep = p <:> many (sep *> p)
388
389 endBy ::
390 Applicable repr => Alternable repr => Foldable repr =>
391 repr a -> repr b -> repr [a]
392 endBy p sep = many (p <* sep)
393
394 endBy1 ::
395 Applicable repr => Alternable repr => Foldable repr =>
396 repr a -> repr b -> repr [a]
397 endBy1 p sep = some (p <* sep)
398
399 sepEndBy ::
400 Applicable repr => Alternable repr => Foldable repr =>
401 repr a -> repr b -> repr [a]
402 sepEndBy p sep = option Hask.nil (sepEndBy1 p sep)
403
404 sepEndBy1 ::
405 Applicable repr => Alternable repr => Foldable repr =>
406 repr a -> repr b -> repr [a]
407 sepEndBy1 p sep =
408 let seb1 = p <**> (sep *> (Hask.flip Hask..@ Hask.cons <$> option Hask.nil seb1)
409 <|> pure (Hask.flip Hask..@ Hask.cons Hask..@ Hask.nil))
410 in seb1
411
412 {-
413 sepEndBy1 :: repr a -> repr b -> repr [a]
414 sepEndBy1 p sep = newRegister_ Hask.id $ \acc ->
415 let go = modify acc ((Hask.flip (Hask..)) Hask..@ Hask.cons <$> p)
416 *> (sep *> (go <|> get acc) <|> get acc)
417 in go <*> pure Hask.nil
418 -}
419
420 -- Combinators interpreters for 'Sym.Any'.
421 instance Applicable repr => Applicable (Sym.Any repr)
422 instance Charable repr => Charable (Sym.Any repr)
423 instance Alternable repr => Alternable (Sym.Any repr)
424 instance Selectable repr => Selectable (Sym.Any repr)
425 instance Matchable repr => Matchable (Sym.Any repr)
426 instance Lookable repr => Lookable (Sym.Any repr)
427 instance Foldable repr => Foldable (Sym.Any repr)