]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/Eval.hs
remove Hints draft
[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / 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.Machine.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.Machine.Input
31 import Symantic.Parser.Machine.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 'Offset'
51 type Offset = Int
52
53 -- ** Type 'Cont'
54 type Cont inp v a =
55 {-farthestInput-}Cursor inp ->
56 {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
57 v ->
58 Cursor inp ->
59 Either (ParsingError inp) a
60
61 -- ** Type 'SubRoutine'
62 type SubRoutine inp v a =
63 {-ok-}Cont inp v a ->
64 Cursor inp ->
65 {-ko-}FailHandler inp a ->
66 Either (ParsingError inp) a
67
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
74
75 {-
76 -- *** Type 'FarthestError'
77 data FarthestError inp = FarthestError
78 { farthestInput :: Cursor inp
79 , farthestExpecting :: [ErrorItem (InputToken inp)]
80 }
81 -}
82
83 eval ::
84 forall inp ret.
85 Ord (InputToken inp) =>
86 Show (InputToken inp) =>
87 TH.Lift (InputToken inp) =>
88 -- InputToken inp ~ Char =>
89 Input inp =>
90 CodeQ inp ->
91 Show (Cursor inp) =>
92 Eval inp '[] ('Succ 'Zero) ret ->
93 CodeQ (Either (ParsingError inp) ret)
94 eval input (Eval k) = [||
95 let _ = "eval" in
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 =
104 if readMore farInp
105 then Just (let (# c, _ #) = readNext farInp in c)
106 else Nothing
107 , parsingErrorExpecting = Set.fromList farExp
108 } in
109 $$(k EvalCtx
110 { valueStack = ValueStackEmpty
111 , failStack = FailStackCons [||evalFail||] FailStackEmpty
112 , retCode = [||evalRet||]
113 , input = [||init||]
114 , nextInput = [||readNext||]
115 , moreInput = [||readMore||]
116 -- , farthestError = [||Nothing||]
117 , farthestInput = [||init||]
118 , farthestExpecting = [|| [] ||]
119 })
120 ||]
121
122 -- ** Type 'EvalCtx'
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
129 ) => EvalCtx
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)]
138 }
139
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
146
147 -- ** Type 'FailStack'
148 data FailStack inp es a where
149 FailStackEmpty :: FailStack inp 'Zero a
150 FailStackCons ::
151 CodeQ (FailHandler inp a) ->
152 FailStack inp es a ->
153 FailStack inp ('Succ es) a
154
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
161 { valueStack =
162 let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
163 ValueStackCons (liftCode2 f x y) xs
164 }
165 swap k = Eval $ \inh -> unEval k inh
166 { valueStack =
167 let ValueStackCons y (ValueStackCons x xs) = valueStack inh in
168 ValueStackCons x (ValueStackCons y xs)
169 }
170 instance Branchable Eval where
171 case_ kx ky = Eval $ \inh ->
172 let ValueStackCons v vs = valueStack inh in
173 [||
174 case $$v of
175 Left x -> $$(unEval kx inh{ valueStack = ValueStackCons [||x||] vs })
176 Right y -> $$(unEval ky inh{ valueStack = ValueStackCons [||y||] vs })
177 ||]
178 choices fs ks kd = Eval $ \inh ->
179 let ValueStackCons v vs = valueStack inh in
180 go inh{valueStack = vs} v fs ks
181 where
182 go inh x (f:fs') (Eval k:ks') = [||
183 if $$(liftCode1 f x) then $$(k inh)
184 else $$(go inh x fs' ks')
185 ||]
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
190 [||
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
196 {-
197 trace ("fail: "
198 <>" failExp="<>show @[ErrorItem Char] failExp
199 <>" farthestExpecting="<>show @[ErrorItem Char] ($$(farthestExpecting inh))
200 <>" farExp="<>show @[ErrorItem Char] farExp) $
201 -}
202 $$e $$(input inh) farInp farExp
203 ||]
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) $
211 $$(unEval ko inh
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||]
219 })
220 ||] (failStack inh)
221 })
222 ||]
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 ->
231 callWithContinuation
232 {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
233 {-ok-}(suspend k inh)
234 (input inh)
235 {-ko-}(failStack inh)
236 jump (LetName n) = Eval $ \inh ->
237 callWithContinuation
238 {-sub-}(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
239 {-ok-}(retCode inh)
240 (input inh)
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
245 \(!ok) (!inp) ko ->
246 $$(unEval sub inh
247 { valueStack = ValueStackEmpty
248 , failStack = FailStackCons [||ko||] FailStackEmpty
249 , input = [||inp||]
250 , retCode = [||ok||]
251 })
252 ||]
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)
256
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 ||]
265
266 suspend ::
267 {-k-}Eval inp (v ': vs) es a ->
268 EvalCtx inp vs es a ->
269 CodeQ (Cont inp v a)
270 suspend k inh = [|| let _ = "suspend" in \farInp farExp v !inp ->
271 $$(unEval k inh
272 { valueStack = ValueStackCons [||v||] (valueStack inh)
273 , input = [||inp||]
274 , farthestInput = [||farInp||]
275 , farthestExpecting = [||farExp||]
276 }
277 )||]
278
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) ||]
283
284 instance Readable Eval Char where
285 read farExp p k =
286 -- TODO: piggy bank
287 maybeEmitCheck (Just 1) k
288 where
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
292 [||
293 let readFail = $$(e) in -- Factorize failure code
294 $$((`unEval` inh{failStack = FailStackCons [||readFail||] es}) $ emitLengthCheck n
295 {-ok-}(sat (liftCode p) ok
296 {-ko-}(fail farExp))
297 {-ko-}(fail farExp))
298 ||]
299
300 sat ::
301 forall inp vs es a.
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
312 if $$p c
313 then $$(unEval ok inh
314 { valueStack = ValueStackCons [||c||] (valueStack inh)
315 , input = [||cs||]
316 })
317 else let _ = "sat.else" in $$(unEval ko inh)
318 ||]
319
320 {-
321 evalSat ::
322 -- Cursorable inp =>
323 -- HandlerOps inp =>
324 InstrPure (Char -> Bool) ->
325 Eval inp (Char ': vs) ('Succ es) a ->
326 Eval inp vs ('Succ es) a
327 evalSat p k = do
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)
333 where
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)||]
337 -}
338
339 emitLengthCheck ::
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)
347 ||]
348 {-
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||]})
353 ||]
354 -}
355
356
357 liftCode :: InstrPure a -> CodeQ a
358 liftCode = trans
359 {-# INLINE liftCode #-}
360
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
365 where
366 go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
367 go qa = \case
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 ||]
376 H.Id -> qa
377 h -> [|| $$(trans h) $$qa ||]
378
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
383 where
384 go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
385 go qa qb = \case
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 ||]