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.Machine.Eval where
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 ((<$>))
16 import Data.Maybe (Maybe(..))
17 import Data.Monoid (Monoid(..))
18 import Data.Ord (Ord, Ordering(..))
19 import Data.Semigroup (Semigroup(..))
21 import Language.Haskell.TH (CodeQ, Code(..))
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
28 import Symantic.Univariant.Trans
29 import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
30 import Symantic.Parser.Machine.Input
31 import Symantic.Parser.Machine.Instructions
32 import qualified Symantic.Parser.Staging as H
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)
41 -- ** Type 'ParsingError'
43 = ParsingErrorStandard
44 { parsingErrorOffset :: Offset
45 , parsingErrorUnexpected :: Maybe (InputToken inp)
46 , parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
48 deriving instance Show (InputToken inp) => Show (ParsingError inp)
55 {-farthestInput-}Cursor inp ->
56 {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
59 Either (ParsingError inp) a
61 -- ** Type 'SubRoutine'
62 type SubRoutine inp v a =
65 {-ko-}FailHandler inp a ->
66 Either (ParsingError inp) a
68 -- ** Type 'FailHandler'
69 type FailHandler inp a =
70 {-failureInput-}Cursor inp ->
71 {-farthestInput-}Cursor inp ->
72 {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
73 Either (ParsingError inp) a
76 -- *** Type 'FarthestError'
77 data FarthestError inp = FarthestError
78 { farthestInput :: Cursor inp
79 , farthestExpecting :: [ErrorItem (InputToken inp)]
85 Ord (InputToken inp) =>
86 Show (InputToken inp) =>
87 TH.Lift (InputToken inp) =>
88 -- InputToken inp ~ Char =>
92 Eval inp '[] ('Succ 'Zero) ret ->
93 CodeQ (Either (ParsingError inp) ret)
94 eval input (Eval k) = [||
96 -- Pattern bindings containing unlifted types
97 -- should use an outermost bang pattern.
98 let !(# init, readMore, readNext #) = $$(cursorOf input) in
99 let evalRet = \_farInp _farExp v _inp -> Right v in
100 let evalFail _failInp !farInp !farExp =
101 Left ParsingErrorStandard
102 { parsingErrorOffset = offset farInp
103 , parsingErrorUnexpected =
105 then Just (let (# c, _ #) = readNext farInp in c)
107 , parsingErrorExpecting = Set.fromList farExp
110 { valueStack = ValueStackEmpty
111 , failStack = FailStackCons [||evalFail||] FailStackEmpty
112 , retCode = [||evalRet||]
114 , nextInput = [||readNext||]
115 , moreInput = [||readMore||]
116 -- , farthestError = [||Nothing||]
117 , farthestInput = [||init||]
118 , farthestExpecting = [|| [] ||]
123 -- | This is a context only present at compile-time.
124 data EvalCtx inp vs (es::Peano) a =
125 ( TH.Lift (InputToken inp)
126 , Cursorable (Cursor inp)
127 , Show (InputToken inp)
128 -- , InputToken inp ~ Char
130 { valueStack :: ValueStack vs
131 , failStack :: FailStack inp es a
132 , retCode :: CodeQ (Cont inp a a)
133 , input :: CodeQ (Cursor inp)
134 , moreInput :: CodeQ (Cursor inp -> Bool)
135 , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
136 , farthestInput :: CodeQ (Cursor inp)
137 , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
140 -- ** Type 'ValueStack'
141 data ValueStack vs where
142 ValueStackEmpty :: ValueStack '[]
143 ValueStackCons :: CodeQ v -> ValueStack vs -> ValueStack (v ': vs)
144 -- TODO: maybe use H.Haskell instead of CodeQ ?
145 -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46
147 -- ** Type 'FailStack'
148 data FailStack inp es a where
149 FailStackEmpty :: FailStack inp 'Zero a
151 CodeQ (FailHandler inp a) ->
152 FailStack inp es a ->
153 FailStack inp ('Succ es) a
155 instance Stackable Eval where
156 push x k = Eval $ \inh -> unEval k inh
157 { valueStack = ValueStackCons (liftCode x) (valueStack inh) }
158 pop k = Eval $ \inh -> unEval k inh
159 { valueStack = let ValueStackCons _ xs = valueStack inh in xs }
160 liftI2 f k = Eval $ \inh -> unEval k inh
162 let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
163 ValueStackCons (liftCode2 f x y) xs
165 swap k = Eval $ \inh -> unEval k inh
167 let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
168 ValueStackCons x (ValueStackCons y xs)
170 instance Branchable Eval where
171 case_ kx ky = Eval $ \inh ->
172 let ValueStackCons v vs = valueStack inh in
175 Left x -> $$(unEval kx inh{ valueStack = ValueStackCons [||x||] vs })
176 Right y -> $$(unEval ky inh{ valueStack = ValueStackCons [||y||] vs })
178 choices fs ks kd = Eval $ \inh ->
179 let ValueStackCons v vs = valueStack inh in
180 go inh{valueStack = vs} v fs ks
182 go inh x (f:fs') (Eval k:ks') = [||
183 if $$(liftCode1 f x) then $$(k inh)
184 else $$(go inh x fs' ks')
186 go inh _ _ _ = unEval kd inh
187 instance Failable Eval where
188 fail failExp = Eval $ \inh@EvalCtx{} ->
189 let FailStackCons e _es = failStack inh in
191 let (# farInp, farExp #) =
192 case $$compareOffset $$(farthestInput inh) $$(input inh) of
193 LT -> (# $$(input inh), failExp #)
194 EQ -> (# $$(farthestInput inh), ($$(farthestExpecting inh) <> failExp) #)
195 GT -> (# $$(farthestInput inh), $$(farthestExpecting inh) #) in
198 <>" failExp="<>show @[ErrorItem Char] failExp
199 <>" farthestExpecting="<>show @[ErrorItem Char] ($$(farthestExpecting inh))
200 <>" farExp="<>show @[ErrorItem Char] farExp) $
202 $$e $$(input inh) farInp farExp
204 popFail k = Eval $ \inh ->
205 let FailStackCons _e es = failStack inh in
206 unEval k inh{failStack = es}
207 catchFail ok ko = Eval $ \inh@EvalCtx{} -> [||
208 let _ = "catchFail" in $$(unEval ok inh
209 { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
210 -- trace ("catchFail: " <> "farExp="<>show farExp) $
212 -- Push the input as it was when entering the catchFail.
213 { valueStack = ValueStackCons (input inh) (valueStack inh)
214 -- Move the input to the failing position.
215 , input = [||failInp||]
216 -- Set the farthestInput to the farthest computed by 'fail'
217 , farthestInput = [||farInp||]
218 , farthestExpecting = [||farExp||]
223 instance Inputable Eval where
224 loadInput k = Eval $ \inh ->
225 let ValueStackCons input vs = valueStack inh in
226 unEval k inh{valueStack = vs, input}
227 pushInput k = Eval $ \inh ->
228 unEval k inh{valueStack = ValueStackCons (input inh) (valueStack inh)}
229 instance Routinable Eval where
230 call (LetName n) k = Eval $ \inh ->
232 {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
233 {-ok-}(suspend k inh)
235 {-ko-}(failStack inh)
236 jump (LetName n) = Eval $ \inh ->
238 {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
241 {-ko-}(failStack inh)
242 ret = Eval $ \inh -> unEval (resume (retCode inh)) inh
243 subroutine (LetName n) sub k = Eval $ \inh -> Code $ TH.unsafeTExpCoerce $ do
244 val <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
247 { valueStack = ValueStackEmpty
248 , failStack = FailStackCons [||ko||] FailStackEmpty
253 let decl = TH.FunD n [TH.Clause [] (TH.NormalB val) []]
254 exp <- TH.unTypeQ (TH.examineCode (unEval k inh))
255 return (TH.LetE [decl] exp)
257 callWithContinuation ::
258 {-sub-}CodeQ (SubRoutine inp v a) ->
259 {-ok-}CodeQ (Cont inp v a) ->
260 CodeQ (Cursor inp) ->
261 FailStack inp ('Succ es) a ->
262 CodeQ (Either (ParsingError inp) a)
263 callWithContinuation sub ok inp (FailStackCons ko _) =
264 [|| let _ = "callWithContinuation" in $$sub $$ok $$inp $! $$ko ||]
267 {-k-}Eval inp (v ': vs) es a ->
268 EvalCtx inp vs es a ->
270 suspend k inh = [|| let _ = "suspend" in \farInp farExp v !inp ->
272 { valueStack = ValueStackCons [||v||] (valueStack inh)
274 , farthestInput = [||farInp||]
275 , farthestExpecting = [||farExp||]
279 resume :: CodeQ (Cont inp v a) -> Eval inp (v ': vs) es a
280 resume k = Eval $ \inh ->
281 let ValueStackCons v _ = valueStack inh in
282 [|| let _ = "resume" in $$k $$(farthestInput inh) $$(farthestExpecting inh) $$v $$(input inh) ||]
284 instance Readable Eval Char where
287 maybeEmitCheck (Just 1) k
289 maybeEmitCheck Nothing ok = sat (liftCode p) ok (fail farExp)
290 maybeEmitCheck (Just n) ok = Eval $ \inh ->
291 let FailStackCons e es = failStack inh in
293 let readFail = $$(e) in -- Factorize failure code
294 $$((`unEval` inh{failStack = FailStackCons [||readFail||] es}) $ emitLengthCheck n
295 {-ok-}(sat (liftCode p) ok
302 -- Cursorable (Cursor inp) =>
303 -- InputToken inp ~ Char =>
304 Ord (InputToken inp) =>
305 TH.Lift (InputToken inp) =>
306 {-predicate-}CodeQ (InputToken inp -> Bool) ->
307 {-ok-}Eval inp (InputToken inp ': vs) ('Succ es) a ->
308 {-ko-}Eval inp vs ('Succ es) a ->
309 Eval inp vs ('Succ es) a
310 sat p ok ko = Eval $ \inh -> [||
311 let !(# c, cs #) = $$(nextInput inh) $$(input inh) in
313 then $$(unEval ok inh
314 { valueStack = ValueStackCons [||c||] (valueStack inh)
317 else let _ = "sat.else" in $$(unEval ko inh)
324 InstrPure (Char -> Bool) ->
325 Eval inp (Char ': vs) ('Succ es) a ->
326 Eval inp vs ('Succ es) a
328 bankrupt <- asks isBankrupt
329 hasChange <- asks hasCoin
330 if | bankrupt -> maybeEmitCheck (Just 1) <$> k
331 | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
332 | otherwise -> local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
334 maybeEmitCheck Nothing mk inh = sat (genDefunc p) mk (raise inh) inh
335 maybeEmitCheck (Just n) mk inh =
336 [|| let bad = $$(raise inh) in $$(emitLengthCheck n (sat (genDefunc p) mk [||bad||]) [||bad||] inh)||]
340 TH.Lift (InputToken inp) =>
341 Int -> Eval inp vs es a -> Eval inp vs es a -> Eval inp vs es a
342 emitLengthCheck 0 ok _ko = ok
343 emitLengthCheck 1 ok ko = Eval $ \inh -> [||
344 if $$(moreInput inh) $$(input inh)
345 then $$(unEval ok inh)
346 else let _ = "sat.length-check.else" in $$(unEval ko inh)
349 emitLengthCheck n ok ko inh = Eval $ \inh -> [||
350 if $$moreInput ($$shiftRight $$(input inh) (n - 1))
351 then $$(unEval ok inh)
352 else $$(unEval ko inh {farthestExpecting = [||farExp||]})
357 liftCode :: InstrPure a -> CodeQ a
359 {-# INLINE liftCode #-}
361 liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
362 liftCode1 p a = case p of
363 InstrPureSameOffset -> [|| $$sameOffset $$a ||]
364 InstrPureHaskell h -> go a h
366 go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
368 (H.:$) -> [|| \x -> $$qa x ||]
369 (H.:.) -> [|| \g x -> $$qa (g x) ||]
370 H.Flip -> [|| \x y -> $$qa y x ||]
371 (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]
372 H.Const -> [|| \_ -> $$qa ||]
373 H.Flip H.:@ H.Const -> H.id
374 h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
375 H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]
377 h -> [|| $$(trans h) $$qa ||]
379 liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
380 liftCode2 p a b = case p of
381 InstrPureSameOffset -> [|| $$sameOffset $$a $$b ||]
382 InstrPureHaskell h -> go a b h
384 go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
386 (H.:$) -> [|| $$qa $$qb ||]
387 (H.:.) -> [|| \x -> $$qa ($$qb x) ||]
388 H.Flip -> [|| \x -> $$qa x $$qb ||]
389 H.Flip H.:@ H.Const -> [|| $$qb ||]
390 H.Flip H.:@ f -> go qb qa f
391 H.Const -> [|| $$qa ||]
392 H.Cons -> [|| $$qa : $$qb ||]
393 h -> [|| $$(trans h) $$qa $$qb ||]