]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Automaton/Eval.hs
rename {Label => LetName}
[haskell/symantic-parser.git] / src / Symantic / Parser / Automaton / Eval.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp)
3 {-# LANGUAGE TemplateHaskell #-}
4 {-# LANGUAGE UnboxedTuples #-} -- For nextInput
5 {-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp)
6 module Symantic.Parser.Automaton.Eval where
7
8 import Control.Monad (Monad(..))
9 import Data.Bool (Bool)
10 import Data.Char (Char)
11 import Data.Either (Either(..))
12 import Data.Eq (Eq(..))
13 import Data.Function (($))
14 -- import Data.Functor ((<$>))
15 import Data.Int (Int)
16 import Data.Maybe (Maybe(..))
17 import Data.Monoid (Monoid(..))
18 import Data.Ord (Ord, Ordering(..))
19 import Data.Semigroup (Semigroup(..))
20 import Data.Set (Set)
21 import Language.Haskell.TH (CodeQ, Code(..))
22 import Prelude (($!))
23 import Text.Show (Show(..))
24 import qualified Data.Eq as Eq
25 import qualified Data.Set as Set
26 import qualified Language.Haskell.TH.Syntax as TH
27
28 import Symantic.Univariant.Trans
29 import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
30 import Symantic.Parser.Automaton.Input
31 import Symantic.Parser.Automaton.Instructions
32 import qualified Symantic.Parser.Staging as H
33
34 -- * Type 'Eval'
35 -- | Generate the 'CodeQ' parsing the input.
36 newtype Eval inp vs es a = Eval { unEval ::
37 EvalCtx inp vs es a ->
38 CodeQ (Either (ParsingError inp) a)
39 }
40
41 -- ** Type 'ParsingError'
42 data ParsingError inp
43 = ParsingErrorStandard
44 { parsingErrorOffset :: Offset
45 , parsingErrorUnexpected :: Maybe (InputToken inp)
46 , parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
47 }
48 deriving instance Show (InputToken inp) => Show (ParsingError inp)
49
50 -- ** Type 'Hints'
51 newtype Hints inp = Hints [Set (ErrorItem (InputToken inp))]
52 instance Semigroup (Hints t) where
53 Hints xs <> Hints ys = Hints $ xs <> ys
54 instance Monoid (Hints t) where
55 mempty = Hints mempty
56
57 {-
58 accHints ::
59 -- | 'Hints' to add
60 Hints t ->
61 -- | An “OK” continuation to alter
62 (a -> State s e -> Hints t -> m b) ->
63 -- | Altered “OK” continuation
64 (a -> State s e -> Hints t -> m b)
65 accHints hs1 c x s hs2 = c x s (hs1 <> hs2)
66 -}
67
68 toHints :: Offset -> ParsingError inp -> Hints inp
69 toHints curOff = \case
70 ParsingErrorStandard errOff _ es ->
71 if curOff == errOff
72 then Hints (if Set.null es then [] else [es])
73 else mempty
74
75 {-
76 withHints ::
77 Stream s =>
78 -- | Hints to use
79 Hints (Token s) ->
80 -- | Continuation to influence
81 (ParseError s e -> State s e -> m b) ->
82 -- | First argument of resulting continuation
83 ParseError s e ->
84 -- | Second argument of resulting continuation
85 State s e ->
86 m b
87 withHints (Hints hs) c e =
88 case e of
89 ParsingErrorStandard pos us es -> c (ParsingErrorStandard pos us (Set.unions (es : hs)))
90 {-# INLINE withHints #-}
91 -}
92
93 -- ** Type 'Offset'
94 type Offset = Int
95
96 -- ** Type 'Cont'
97 type Cont inp v a =
98 {-farthestInput-}Cursor inp ->
99 {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
100 v ->
101 Cursor inp ->
102 Either (ParsingError inp) a
103
104 -- ** Type 'SubRoutine'
105 type SubRoutine inp v a =
106 {-ok-}Cont inp v a ->
107 Cursor inp ->
108 {-ko-}FailHandler inp a ->
109 Either (ParsingError inp) a
110
111 -- ** Type 'FailHandler'
112 type FailHandler inp a =
113 {-failureInput-}Cursor inp ->
114 {-farthestInput-}Cursor inp ->
115 {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
116 Either (ParsingError inp) a
117
118 {-
119 -- *** Type 'FarthestError'
120 data FarthestError inp = FarthestError
121 { farthestInput :: Cursor inp
122 , farthestExpecting :: [ErrorItem (InputToken inp)]
123 }
124 -}
125
126 eval ::
127 forall inp ret.
128 Ord (InputToken inp) =>
129 Show (InputToken inp) =>
130 TH.Lift (InputToken inp) =>
131 -- InputToken inp ~ Char =>
132 Input inp =>
133 CodeQ inp ->
134 Show (Cursor inp) =>
135 Eval inp '[] ('Succ 'Zero) ret ->
136 CodeQ (Either (ParsingError inp) ret)
137 eval input (Eval k) = [||
138 let _ = "eval" in
139 -- Pattern bindings containing unlifted types
140 -- should use an outermost bang pattern.
141 let !(# init, readMore, readNext #) = $$(cursorOf input) in
142 let evalRet = \_farInp _farExp v _inp -> Right v in
143 let evalFail _failInp !farInp !farExp =
144 Left ParsingErrorStandard
145 { parsingErrorOffset = offset farInp
146 , parsingErrorUnexpected =
147 if readMore farInp
148 then Just (let (# c, _ #) = readNext farInp in c)
149 else Nothing
150 , parsingErrorExpecting = Set.fromList farExp
151 } in
152 $$(k EvalCtx
153 { valueStack = ValueStackEmpty
154 , failStack = FailStackCons [||evalFail||] FailStackEmpty
155 , retCode = [||evalRet||]
156 , input = [||init||]
157 , nextInput = [||readNext||]
158 , moreInput = [||readMore||]
159 -- , farthestError = [||Nothing||]
160 , farthestInput = [||init||]
161 , farthestExpecting = [|| [] ||]
162 })
163 ||]
164
165 -- ** Type 'EvalCtx'
166 -- | This is a context only present at compile-time.
167 data EvalCtx inp vs (es::Peano) a =
168 ( TH.Lift (InputToken inp)
169 , Cursorable (Cursor inp)
170 , Show (InputToken inp)
171 -- , InputToken inp ~ Char
172 ) => EvalCtx
173 { valueStack :: ValueStack vs
174 , failStack :: FailStack inp es a
175 , retCode :: CodeQ (Cont inp a a)
176 , input :: CodeQ (Cursor inp)
177 , moreInput :: CodeQ (Cursor inp -> Bool)
178 , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
179 , farthestInput :: CodeQ (Cursor inp)
180 , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
181 }
182
183 -- ** Type 'ValueStack'
184 data ValueStack vs where
185 ValueStackEmpty :: ValueStack '[]
186 ValueStackCons :: CodeQ v -> ValueStack vs -> ValueStack (v ': vs)
187 -- TODO: maybe use H.Haskell instead of CodeQ ?
188 -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46
189
190 -- ** Type 'FailStack'
191 data FailStack inp es a where
192 FailStackEmpty :: FailStack inp 'Zero a
193 FailStackCons ::
194 CodeQ (FailHandler inp a) ->
195 FailStack inp es a ->
196 FailStack inp ('Succ es) a
197
198 instance Stackable Eval where
199 push x k = Eval $ \inh -> unEval k inh
200 { valueStack = ValueStackCons (liftCode x) (valueStack inh) }
201 pop k = Eval $ \inh -> unEval k inh
202 { valueStack = let ValueStackCons _ xs = valueStack inh in xs }
203 liftI2 f k = Eval $ \inh -> unEval k inh
204 { valueStack =
205 let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
206 ValueStackCons (liftCode2 f x y) xs
207 }
208 swap k = Eval $ \inh -> unEval k inh
209 { valueStack =
210 let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
211 ValueStackCons x (ValueStackCons y xs)
212 }
213 instance Branchable Eval where
214 case_ kx ky = Eval $ \inh ->
215 let ValueStackCons v vs = valueStack inh in
216 [||
217 case $$v of
218 Left x -> $$(unEval kx inh{ valueStack = ValueStackCons [||x||] vs })
219 Right y -> $$(unEval ky inh{ valueStack = ValueStackCons [||y||] vs })
220 ||]
221 choices fs ks kd = Eval $ \inh ->
222 let ValueStackCons v vs = valueStack inh in
223 go inh{valueStack = vs} v fs ks
224 where
225 go inh x (f:fs') (Eval k:ks') = [||
226 if $$(liftCode1 f x) then $$(k inh)
227 else $$(go inh x fs' ks')
228 ||]
229 go inh _ _ _ = unEval kd inh
230 instance Failable Eval where
231 fail failExp = Eval $ \inh@EvalCtx{} ->
232 let FailStackCons e _es = failStack inh in
233 [||
234 let (# farInp, farExp #) =
235 case $$compareOffset $$(farthestInput inh) $$(input inh) of
236 LT -> (# $$(input inh), failExp #)
237 EQ -> (# $$(farthestInput inh), ($$(farthestExpecting inh) <> failExp) #)
238 GT -> (# $$(farthestInput inh), $$(farthestExpecting inh) #) in
239 {-
240 trace ("fail: "
241 <>" failExp="<>show @[ErrorItem Char] failExp
242 <>" farthestExpecting="<>show @[ErrorItem Char] ($$(farthestExpecting inh))
243 <>" farExp="<>show @[ErrorItem Char] farExp) $
244 -}
245 $$e $$(input inh) farInp farExp
246 ||]
247 popFail k = Eval $ \inh ->
248 let FailStackCons _e es = failStack inh in
249 unEval k inh{failStack = es}
250 catchFail ok ko = Eval $ \inh@EvalCtx{} -> [||
251 let _ = "catchFail" in $$(unEval ok inh
252 { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
253 -- trace ("catchFail: " <> "farExp="<>show farExp) $
254 $$(unEval ko inh
255 -- Push the input as it was when entering the catchFail.
256 { valueStack = ValueStackCons (input inh) (valueStack inh)
257 -- Move the input to the failing position.
258 , input = [||failInp||]
259 -- Set the farthestInput to the farthest computed by 'fail'
260 , farthestInput = [||farInp||]
261 , farthestExpecting = [||farExp||]
262 })
263 ||] (failStack inh)
264 })
265 ||]
266 instance Inputable Eval where
267 loadInput k = Eval $ \inh ->
268 let ValueStackCons input vs = valueStack inh in
269 unEval k inh{valueStack = vs, input}
270 pushInput k = Eval $ \inh ->
271 unEval k inh{valueStack = ValueStackCons (input inh) (valueStack inh)}
272 instance Routinable Eval where
273 call (LetName n) k = Eval $ \inh ->
274 callWithContinuation
275 {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
276 {-ok-}(suspend k inh)
277 (input inh)
278 {-ko-}(failStack inh)
279 jump (LetName n) = Eval $ \inh ->
280 callWithContinuation
281 {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
282 {-ok-}(retCode inh)
283 (input inh)
284 {-ko-}(failStack inh)
285 ret = Eval $ \inh -> unEval (resume (retCode inh)) inh
286 subroutine (LetName n) sub k = Eval $ \inh -> Code $ TH.unsafeTExpCoerce $ do
287 val <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
288 \(!ok) (!inp) ko ->
289 $$(unEval sub inh
290 { valueStack = ValueStackEmpty
291 , failStack = FailStackCons [||ko||] FailStackEmpty
292 , input = [||inp||]
293 , retCode = [||ok||]
294 })
295 ||]
296 let decl = TH.FunD n [TH.Clause [] (TH.NormalB val) []]
297 exp <- TH.unTypeQ (TH.examineCode (unEval k inh))
298 return (TH.LetE [decl] exp)
299
300 callWithContinuation ::
301 {-sub-}CodeQ (SubRoutine inp v a) ->
302 {-ok-}CodeQ (Cont inp v a) ->
303 CodeQ (Cursor inp) ->
304 FailStack inp ('Succ es) a ->
305 CodeQ (Either (ParsingError inp) a)
306 callWithContinuation sub ok inp (FailStackCons ko _) =
307 [|| let _ = "callWithContinuation" in $$sub $$ok $$inp $! $$ko ||]
308
309 suspend ::
310 {-k-}Eval inp (v ': vs) es a ->
311 EvalCtx inp vs es a ->
312 CodeQ (Cont inp v a)
313 suspend k inh = [|| let _ = "suspend" in \farInp farExp v !inp ->
314 $$(unEval k inh
315 { valueStack = ValueStackCons [||v||] (valueStack inh)
316 , input = [||inp||]
317 , farthestInput = [||farInp||]
318 , farthestExpecting = [||farExp||]
319 }
320 )||]
321
322 resume :: CodeQ (Cont inp v a) -> Eval inp (v ': vs) es a
323 resume k = Eval $ \inh ->
324 let ValueStackCons v _ = valueStack inh in
325 [|| let _ = "resume" in $$k $$(farthestInput inh) $$(farthestExpecting inh) $$v $$(input inh) ||]
326
327 instance Readable Eval Char where
328 read farExp p k =
329 -- TODO: piggy bank
330 maybeEmitCheck (Just 1) k
331 where
332 maybeEmitCheck Nothing ok = sat (liftCode p) ok (fail farExp)
333 maybeEmitCheck (Just n) ok = Eval $ \inh ->
334 let FailStackCons e es = failStack inh in
335 [||
336 let readFail = $$(e) in -- Factorize failure code
337 $$((`unEval` inh{failStack = FailStackCons [||readFail||] es}) $ emitLengthCheck n
338 {-ok-}(sat (liftCode p) ok
339 {-ko-}(fail farExp))
340 {-ko-}(fail farExp))
341 ||]
342
343 sat ::
344 forall inp vs es a.
345 -- Cursorable (Cursor inp) =>
346 -- InputToken inp ~ Char =>
347 Ord (InputToken inp) =>
348 TH.Lift (InputToken inp) =>
349 {-predicate-}CodeQ (InputToken inp -> Bool) ->
350 {-ok-}Eval inp (InputToken inp ': vs) ('Succ es) a ->
351 {-ko-}Eval inp vs ('Succ es) a ->
352 Eval inp vs ('Succ es) a
353 sat p ok ko = Eval $ \inh -> [||
354 let !(# c, cs #) = $$(nextInput inh) $$(input inh) in
355 if $$p c
356 then $$(unEval ok inh
357 { valueStack = ValueStackCons [||c||] (valueStack inh)
358 , input = [||cs||]
359 })
360 else let _ = "sat.else" in $$(unEval ko inh)
361 ||]
362
363 {-
364 evalSat ::
365 -- Cursorable inp =>
366 -- HandlerOps inp =>
367 InstrPure (Char -> Bool) ->
368 Eval inp (Char ': vs) ('Succ es) a ->
369 Eval inp vs ('Succ es) a
370 evalSat p k = do
371 bankrupt <- asks isBankrupt
372 hasChange <- asks hasCoin
373 if | bankrupt -> maybeEmitCheck (Just 1) <$> k
374 | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
375 | otherwise -> local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
376 where
377 maybeEmitCheck Nothing mk inh = sat (genDefunc p) mk (raise inh) inh
378 maybeEmitCheck (Just n) mk inh =
379 [|| let bad = $$(raise inh) in $$(emitLengthCheck n (sat (genDefunc p) mk [||bad||]) [||bad||] inh)||]
380 -}
381
382 emitLengthCheck ::
383 TH.Lift (InputToken inp) =>
384 Int -> Eval inp vs es a -> Eval inp vs es a -> Eval inp vs es a
385 emitLengthCheck 0 ok _ko = ok
386 emitLengthCheck 1 ok ko = Eval $ \inh -> [||
387 if $$(moreInput inh) $$(input inh)
388 then $$(unEval ok inh)
389 else let _ = "sat.length-check.else" in $$(unEval ko inh)
390 ||]
391 {-
392 emitLengthCheck n ok ko inh = Eval $ \inh -> [||
393 if $$moreInput ($$shiftRight $$(input inh) (n - 1))
394 then $$(unEval ok inh)
395 else $$(unEval ko inh {farthestExpecting = [||farExp||]})
396 ||]
397 -}
398
399
400 liftCode :: InstrPure a -> CodeQ a
401 liftCode = trans
402 {-# INLINE liftCode #-}
403
404 liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
405 liftCode1 p a = case p of
406 InstrPureSameOffset -> [|| $$sameOffset $$a ||]
407 InstrPureHaskell h -> go a h
408 where
409 go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
410 go qa = \case
411 (H.:$) -> [|| \x -> $$qa x ||]
412 (H.:.) -> [|| \g x -> $$qa (g x) ||]
413 H.Flip -> [|| \x y -> $$qa y x ||]
414 (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]
415 H.Const -> [|| \_ -> $$qa ||]
416 H.Flip H.:@ H.Const -> H.id
417 h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
418 H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]
419 H.Id -> qa
420 h -> [|| $$(trans h) $$qa ||]
421
422 liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
423 liftCode2 p a b = case p of
424 InstrPureSameOffset -> [|| $$sameOffset $$a $$b ||]
425 InstrPureHaskell h -> go a b h
426 where
427 go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
428 go qa qb = \case
429 (H.:$) -> [|| $$qa $$qb ||]
430 (H.:.) -> [|| \x -> $$qa ($$qb x) ||]
431 H.Flip -> [|| \x -> $$qa x $$qb ||]
432 H.Flip H.:@ H.Const -> [|| $$qb ||]
433 H.Flip H.:@ f -> go qb qa f
434 H.Const -> [|| $$qa ||]
435 H.Cons -> [|| $$qa : $$qb ||]
436 h -> [|| $$(trans h) $$qa $$qb ||]