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