import Data.Bool (Bool)
import Data.Char (Char)
import Data.Either (Either(..))
-import Data.Function (($))
--- import Data.Functor ((<$>))
+import Data.Function (($), (.))
+import Data.Functor ((<$>))
import Data.Int (Int)
+import Data.List (minimum)
+import Data.Map (Map)
import Data.Maybe (Maybe(..))
-import Data.Ord (Ord, Ordering(..))
+import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Language.Haskell.TH (CodeQ, Code(..))
-import Prelude (($!))
+import Prelude (($!), (+), (-))
import Text.Show (Show(..))
-import qualified Data.Eq as Eq
+import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Language.Haskell.TH.Syntax as TH
+-- import qualified Control.Monad.Trans.Writer as Writer
import Symantic.Univariant.Trans
import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
import Symantic.Parser.Machine.Instructions
import qualified Symantic.Parser.Haskell as H
+genCode :: TermInstr a -> CodeQ a
+genCode = trans
+
-- * Type 'Gen'
-- | Generate the 'CodeQ' parsing the input.
-newtype Gen inp vs es a = Gen { unGen ::
- GenCtx inp vs es a ->
- CodeQ (Either (ParsingError inp) a)
-}
+data Gen inp vs es a = Gen
+ { minHorizon :: Map TH.Name Horizon -> Horizon
+ -- ^ Minimal input length required by the parser to not fail.
+ -- This requires to be given an 'horizonByName'
+ -- containing the 'Horizon's of all the 'TH.Name's
+ -- this parser 'call's, 'jump's or 'refJoin's to.
+ , unGen ::
+ GenCtx inp vs es a ->
+ CodeQ (Either (ParsingError inp) a)
+ }
-- ** Type 'ParsingError'
data ParsingError inp
= ParsingErrorStandard
{ parsingErrorOffset :: Offset
+ -- | Note that if an 'ErrorItemHorizon' greater than 1
+ -- is amongst the 'parsingErrorExpecting'
+ -- then this is only the 'InputToken'
+ -- at the begining of the expected 'Horizon'.
, parsingErrorUnexpected :: Maybe (InputToken inp)
, parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
}
-- ** Type 'Offset'
type Offset = Int
+-- ** Type 'Horizon'
+-- | Synthetized minimal input length
+-- required for a successful parsing.
+-- Used with 'horizon' to factorize input length checks,
+-- instead of checking the input length
+-- one 'InputToken' by one 'InputToken' at each 'read'.
+type Horizon = Offset
+
-- ** Type 'Cont'
type Cont inp v a =
{-farthestInput-}Cursor inp ->
}
-}
--- | @('generate' input mach)@ generates @TemplateHaskell@ code
--- parsing given 'input' according to given 'mach'ine.
-generate ::
+-- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
+-- parsing the given 'input' according to the given 'Machine'.
+generateCode ::
forall inp ret.
Ord (InputToken inp) =>
Show (InputToken inp) =>
Show (Cursor inp) =>
Gen inp '[] ('Succ 'Zero) ret ->
CodeQ (Either (ParsingError inp) ret)
-generate input (Gen k) = [||
+generateCode input k = [||
-- Pattern bindings containing unlifted types
-- should use an outermost bang pattern.
let !(# init, readMore, readNext #) = $$(cursorOf input) in
else Nothing
, parsingErrorExpecting = Set.fromList farExp
} in
- $$(k GenCtx
+ $$(unGen k GenCtx
{ valueStack = ValueStackEmpty
, failStack = FailStackCons [||finalFail||] FailStackEmpty
, retCode = [||finalRet||]
-- , farthestError = [||Nothing||]
, farthestInput = [||init||]
, farthestExpecting = [|| [] ||]
+ , horizon = 0
+ , horizonByName = Map.empty
})
||]
-- , InputToken inp ~ Char
) => GenCtx
{ valueStack :: ValueStack vs
- , failStack :: FailStack inp es a
+ , failStack :: FailStack inp a es
+ --, failStacks :: FailStack inp es a
, retCode :: CodeQ (Cont inp a a)
, input :: CodeQ (Cursor inp)
, moreInput :: CodeQ (Cursor inp -> Bool)
, nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
, farthestInput :: CodeQ (Cursor inp)
, farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
+ -- | Remaining horizon
+ , horizon :: Offset
+ -- | Horizon for each 'call' or 'jump'.
+ , horizonByName :: Map TH.Name Offset
}
-- ** Type 'ValueStack'
data ValueStack vs where
ValueStackEmpty :: ValueStack '[]
ValueStackCons ::
- -- TODO: maybe use H.Haskell instead of CodeQ ?
- -- as in https://github.com/j-mie6/ParsleyHaskell/popFail/3ec0986a5017866919a6404c14fe78678b7afb46
- { valueStackHead :: CodeQ v
+ { valueStackHead :: TermInstr v
, valueStackTail :: ValueStack vs
} -> ValueStack (v ': vs)
-- ** Type 'FailStack'
-data FailStack inp es a where
- FailStackEmpty :: FailStack inp 'Zero a
+data FailStack inp a es where
+ FailStackEmpty :: FailStack inp a 'Zero
FailStackCons ::
{ failStackHead :: CodeQ (FailHandler inp a)
- , failStackTail :: FailStack inp es a
+ , failStackTail :: FailStack inp a es
} ->
- FailStack inp ('Succ es) a
+ FailStack inp a ('Succ es)
instance Stackable Gen where
- push x k = Gen $ \ctx -> unGen k ctx
- { valueStack = ValueStackCons (liftCode x) (valueStack ctx) }
- pop k = Gen $ \ctx -> unGen k ctx
- { valueStack = valueStackTail (valueStack ctx) }
- liftI2 f k = Gen $ \ctx -> unGen k ctx
- { valueStack =
- let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
- ValueStackCons (liftCode2 f x y) xs
+ push x k = k
+ { unGen = \ctx -> unGen k ctx
+ { valueStack = ValueStackCons x (valueStack ctx) }
+ }
+ pop k = k
+ { unGen = \ctx -> unGen k ctx
+ { valueStack = valueStackTail (valueStack ctx) }
}
- swap k = Gen $ \ctx -> unGen k ctx
- { valueStack =
+ liftI2 f k = k
+ { unGen = \ctx -> unGen k ctx
+ { valueStack =
let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
- ValueStackCons x (ValueStackCons y xs)
+ ValueStackCons (f H.:@ x H.:@ y) xs
+ }
+ }
+ swap k = k
+ { unGen = \ctx -> unGen k ctx
+ { valueStack =
+ let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
+ ValueStackCons x (ValueStackCons y xs)
+ }
}
instance Branchable Gen where
- case_ kx ky = Gen $ \ctx ->
- let ValueStackCons v vs = valueStack ctx in
- [||
- case $$v of
- Left x -> $$(unGen kx ctx{ valueStack = ValueStackCons [||x||] vs })
- Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons [||y||] vs })
- ||]
- choices fs ks kd = Gen $ \ctx ->
- let ValueStackCons v vs = valueStack ctx in
- go ctx{valueStack = vs} v fs ks
+ caseI kx ky = Gen
+ { minHorizon = \ls ->
+ minHorizon kx ls `min` minHorizon ky ls
+ , unGen = \ctx ->
+ let ValueStackCons v vs = valueStack ctx in
+ [||
+ case $$(genCode v) of
+ Left x -> $$(unGen kx ctx{ valueStack = ValueStackCons (H.Term [||x||]) vs })
+ Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (H.Term [||y||]) vs })
+ ||]
+ }
+ choices fs ks kd = Gen
+ { minHorizon = \ls -> minimum $
+ minHorizon kd ls :
+ (($ ls) . minHorizon <$> ks)
+ , unGen = \ctx ->
+ let ValueStackCons v vs = valueStack ctx in
+ go ctx{valueStack = vs} v fs ks
+ }
where
- go ctx x (f:fs') (Gen k:ks') = [||
- if $$(liftCode1 f x) then $$(k ctx)
+ go ctx x (f:fs') (k:ks') = [||
+ if $$(genCode (f H.:@ x))
+ then $$(unGen k ctx)
else $$(go ctx x fs' ks')
||]
go ctx _ _ _ = unGen kd ctx
instance Failable Gen where
- fail failExp = Gen $ \ctx@GenCtx{} -> [||
- let (# farInp, farExp #) =
- case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
- LT -> (# $$(input ctx), failExp #)
- EQ -> (# $$(farthestInput ctx), ($$(farthestExpecting ctx) <> failExp) #)
- GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) in
- {-
- trace ("fail: "
- <>" failExp="<>show @[ErrorItem Char] failExp
- <>" farthestExpecting="<>show @[ErrorItem Char] ($$(farthestExpecting ctx))
- <>" farExp="<>show @[ErrorItem Char] farExp) $
- -}
- $$(failStackHead (failStack ctx))
- $$(input ctx) farInp farExp
- ||]
- popFail k = Gen $ \ctx ->
- let FailStackCons _e es = failStack ctx in
- unGen k ctx{failStack = es}
- catchFail ok ko = Gen $ \ctx@GenCtx{} -> [||
- let _ = "catchFail" in $$(unGen ok ctx
- { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
- -- trace ("catchFail: " <> "farExp="<>show farExp) $
- $$(unGen ko ctx
- -- Push the input as it was when entering the catchFail.
- { valueStack = ValueStackCons (input ctx) (valueStack ctx)
- -- Move the input to the failing position.
- , input = [||failInp||]
- -- Set the farthestInput to the farthest computed by 'fail'
- , farthestInput = [||farInp||]
- , farthestExpecting = [||farExp||]
- })
- ||] (failStack ctx)
- })
- ||]
+ fail failExp = Gen
+ { minHorizon = \_hs -> 0
+ , unGen = \ctx@GenCtx{} -> [||
+ let (# farInp, farExp #) =
+ case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
+ LT -> (# $$(input ctx), failExp #)
+ EQ -> (# $$(farthestInput ctx), ($$(farthestExpecting ctx) <> failExp) #)
+ GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) in
+ $$(failStackHead (failStack ctx))
+ $$(input ctx) farInp farExp
+ ||]
+ }
+ popFail k = k
+ { unGen = \ctx ->
+ unGen k ctx{failStack = failStackTail (failStack ctx)}
+ }
+ catchFail ok ko = Gen
+ { minHorizon = \ls -> minHorizon ok ls `min` minHorizon ko ls
+ , unGen = \ctx@GenCtx{} -> unGen ok ctx
+ { failStack = FailStackCons [|| \(!failInp) (!farInp) (!farExp) ->
+ -- trace ("catchFail: " <> "farExp="<>show farExp) $
+ $$(unGen ko ctx
+ -- Push the input as it was when entering the catchFail.
+ { valueStack = ValueStackCons (H.Term (input ctx)) (valueStack ctx)
+ -- Move the input to the failing position.
+ , input = [||failInp||]
+ -- Set the farthestInput to the farthest computed by 'fail'
+ , farthestInput = [||farInp||]
+ , farthestExpecting = [||farExp||]
+ })
+ ||] (failStack ctx)
+ }
+ }
instance Inputable Gen where
- loadInput k = Gen $ \ctx ->
- let ValueStackCons input vs = valueStack ctx in
- unGen k ctx{valueStack = vs, input}
- pushInput k = Gen $ \ctx ->
- unGen k ctx{valueStack = ValueStackCons (input ctx) (valueStack ctx)}
+ loadInput k = k
+ { unGen = \ctx ->
+ let ValueStackCons input vs = valueStack ctx in
+ unGen k ctx
+ { valueStack = vs
+ , input = genCode input
+ , horizon = 0
+ }
+ }
+ pushInput k = k
+ { unGen = \ctx ->
+ unGen k ctx{valueStack = ValueStackCons (H.Term (input ctx)) (valueStack ctx)}
+ }
instance Routinable Gen where
- call (LetName n) k = Gen $ \ctx -> [||
- let _ = "call" in
- $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
- $$(suspend k ctx)
- $$(input ctx)
- $! $$(failStackHead (failStack ctx))
- ||]
- jump (LetName n) = Gen $ \ctx -> [||
- let _ = "jump" in
- $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
- $$(retCode ctx)
- $$(input ctx)
- $! $$(failStackHead (failStack ctx))
- ||]
- ret = Gen $ \ctx -> unGen (resume (retCode ctx)) ctx
- subroutine (LetName n) sub k = Gen $ \ctx -> Code $ TH.unsafeTExpCoerce $ do
- body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
- -- SubRoutine
- -- Why using $! at call site and not ! here on ko?
- \ !ok !inp ko ->
- $$(unGen sub ctx
- { valueStack = ValueStackEmpty
- , failStack = FailStackCons [||ko||] FailStackEmpty
- , input = [||inp||]
- , retCode = [||ok||]
- -- , farthestInput = [|inp|]
- -- , farthestExpecting = [|| [] ||]
- })
+ call (LetName n) k = k
+ { minHorizon = (Map.! n)
+ , unGen = \ctx -> [||
+ let _ = "call" in
+ $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
+ {-ok-}$$(generateSuspend k ctx)
+ $$(input ctx)
+ $! $$(failStackHead (failStack ctx))
||]
- let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
- expr <- TH.unTypeQ (TH.examineCode (unGen k ctx))
- return (TH.LetE [decl] expr)
+ }
+ jump (LetName n) = Gen
+ { minHorizon = (Map.! n)
+ , unGen = \ctx -> [||
+ let _ = "jump" in
+ $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
+ {-ok-}$$(retCode ctx)
+ $$(input ctx)
+ $! $$(failStackHead (failStack ctx))
+ ||]
+ }
+ ret = Gen
+ { minHorizon = \_hs -> 0
+ , unGen = \ctx -> unGen (generateResume (retCode ctx)) ctx
+ }
+ subroutine (LetName n) sub k = Gen
+ { minHorizon = \hs ->
+ minHorizon k $
+ Map.insert n (minHorizon sub (Map.insert n 0 hs)) hs
+ , unGen = \ctx -> Code $ TH.unsafeTExpCoerce $ do
+ body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
+ -- SubRoutine
+ -- Why using $! at call site and not ! here on ko?
+ \ !ok !inp ko ->
+ $$(unGen sub ctx
+ { valueStack = ValueStackEmpty
+ , failStack = FailStackCons [||ko||] FailStackEmpty
+ , input = [||inp||]
+ , retCode = [||ok||]
+ -- , farthestInput = [|inp|]
+ -- , farthestExpecting = [|| [] ||]
+ , horizon = 0
+ , horizonByName = Map.insert n 0 (horizonByName ctx)
+ })
+ ||]
+ let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
+ expr <- TH.unTypeQ (TH.examineCode (unGen k ctx
+ { horizonByName =
+ Map.insert n
+ (minHorizon sub
+ (Map.insert n 0 (horizonByName ctx)))
+ (horizonByName ctx)
+ }))
+ return (TH.LetE [decl] expr)
+ }
-suspend ::
+-- | Generate a continuation to be called with 'generateResume',
+-- used when 'call' 'ret'urns.
+generateSuspend ::
{-k-}Gen inp (v ': vs) es a ->
GenCtx inp vs es a ->
CodeQ (Cont inp v a)
-suspend k ctx = [||
+generateSuspend k ctx = [||
let _ = "suspend" in
\farInp farExp v !inp ->
$$(unGen k ctx
- { valueStack = ValueStackCons [||v||] (valueStack ctx)
+ { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
, input = [||inp||]
, farthestInput = [||farInp||]
, farthestExpecting = [||farExp||]
+ , horizon = 0
}
)
||]
-resume :: CodeQ (Cont inp v a) -> Gen inp (v ': vs) es a
-resume k = Gen $ \ctx -> [||
- let _ = "resume" in
- $$k
- $$(farthestInput ctx)
- $$(farthestExpecting ctx)
- $$(valueStackHead (valueStack ctx))
- $$(input ctx)
- ||]
+-- | Generate a call to the 'generateSuspend' continuation,
+-- used when 'call' 'ret'urns.
+generateResume ::
+ CodeQ (Cont inp v a) ->
+ Gen inp (v ': vs) es a
+generateResume k = Gen
+ { minHorizon = \_hs -> 0
+ , unGen = \ctx -> [||
+ let _ = "resume" in
+ $$k
+ $$(farthestInput ctx)
+ $$(farthestExpecting ctx)
+ (let _ = "resume.genCode" in $$(genCode (valueStackHead (valueStack ctx))))
+ $$(input ctx)
+ ||]
+ }
instance Joinable Gen where
- defJoin (LetName n) sub k = Gen $ \ctx -> Code $ TH.unsafeTExpCoerce $ do
- body <- TH.unTypeQ $ TH.examineCode $ [||
- \farInp farExp v !inp ->
- $$(unGen sub ctx
- { valueStack = ValueStackCons [||v||] (valueStack ctx)
- , input = [||inp||]
- , farthestInput = [||farInp||]
- , farthestExpecting = [||farExp||]
- })
- ||]
- let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
- expr <- TH.unTypeQ (TH.examineCode (unGen k ctx))
- return (TH.LetE [decl] expr)
- refJoin (LetName n) =
- resume (Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
-instance Readable Gen Char where
- read farExp p k =
- -- TODO: piggy bank
- maybeEmitCheck (Just 1) k
- where
- maybeEmitCheck Nothing ok = sat (liftCode p) ok (fail farExp)
- maybeEmitCheck (Just n) ok = Gen $ \ctx ->
- let FailStackCons e es = failStack ctx in
- [||
- let readFail = $$(e) in -- Factorize failure code
- $$((`unGen` ctx{failStack = FailStackCons [||readFail||] es}) $ emitLengthCheck n
- {-ok-}(sat (liftCode p) ok
- {-ko-}(fail farExp))
- {-ko-}(fail farExp))
- ||]
+ defJoin (LetName n) sub k = k
+ { minHorizon = \hs ->
+ minHorizon k $
+ Map.insert n (minHorizon sub (Map.insert n 0 hs)) hs
+ , unGen = \ctx -> Code $ TH.unsafeTExpCoerce $ do
+ body <- TH.unTypeQ $ TH.examineCode $ [||
+ \farInp farExp v !inp ->
+ $$(unGen sub ctx
+ { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
+ , input = [||inp||]
+ , farthestInput = [||farInp||]
+ , farthestExpecting = [||farExp||]
+ , horizon = 0
+ , horizonByName = Map.insert n 0 (horizonByName ctx)
+ })
+ ||]
+ let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
+ expr <- TH.unTypeQ (TH.examineCode (unGen k ctx
+ { horizonByName =
+ Map.insert n
+ (minHorizon sub
+ (Map.insert n 0 (horizonByName ctx)))
+ (horizonByName ctx)
+ }))
+ return (TH.LetE [decl] expr)
+ }
+ refJoin (LetName n) = (generateResume (Code (TH.unsafeTExpCoerce (return (TH.VarE n)))))
+ { minHorizon = (Map.! n)
+ }
+instance Readable Char Gen where
+ read farExp p = checkHorizon . checkToken farExp p
-sat ::
+checkHorizon ::
+ TH.Lift (InputToken inp) =>
+ {-ok-}Gen inp vs ('Succ es) a ->
+ Gen inp vs ('Succ es) a
+checkHorizon ok = ok
+ { minHorizon = \hs -> 1 + minHorizon ok hs
+ , unGen = \ctx0@GenCtx{failStack = FailStackCons e es} -> [||
+ -- Factorize failure code
+ let readFail = $$(e) in
+ $$(
+ let ctx = ctx0{ failStack = FailStackCons [||readFail||] es } in
+ if horizon ctx >= 1
+ then unGen ok ctx0{horizon = horizon ctx - 1}
+ else let minHoz = minHorizon ok (horizonByName ctx) in
+ [||
+ if $$(moreInput ctx)
+ $$(if minHoz > 0
+ then [||$$shiftRight minHoz $$(input ctx)||]
+ else input ctx)
+ then $$(unGen ok ctx{horizon = minHoz})
+ else let _ = "checkHorizon.else" in
+ $$(unGen (fail [ErrorItemHorizon (minHoz + 1)]) ctx)
+ ||]
+ )
+ ||]
+ }
+
+checkToken ::
forall inp vs es a.
- -- Cursorable (Cursor inp) =>
- -- InputToken inp ~ Char =>
Ord (InputToken inp) =>
TH.Lift (InputToken inp) =>
- {-predicate-}CodeQ (InputToken inp -> Bool) ->
+ [ErrorItem (InputToken inp)] ->
+ {-predicate-}TermInstr (InputToken inp -> Bool) ->
{-ok-}Gen inp (InputToken inp ': vs) ('Succ es) a ->
- {-ko-}Gen inp vs ('Succ es) a ->
Gen inp vs ('Succ es) a
-sat p ok ko = Gen $ \ctx -> [||
- let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
- if $$p c
- then $$(unGen ok ctx
- { valueStack = ValueStackCons [||c||] (valueStack ctx)
- , input = [||cs||]
- })
- else let _ = "sat.else" in $$(unGen ko ctx)
- ||]
-
-{-
-evalSat ::
- -- Cursorable inp =>
- -- HandlerOps inp =>
- InstrPure (Char -> Bool) ->
- Gen inp (Char ': vs) ('Succ es) a ->
- Gen inp vs ('Succ es) a
-evalSat p k = do
- bankrupt <- asks isBankrupt
- hasChange <- asks hasCoin
- if | bankrupt -> maybeEmitCheck (Just 1) <$> k
- | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k
- | otherwise -> local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k)
- where
- maybeEmitCheck Nothing mk ctx = sat (genDefunc p) mk (raise ctx) ctx
- maybeEmitCheck (Just n) mk ctx =
- [|| let bad = $$(raise ctx) in $$(emitLengthCheck n (sat (genDefunc p) mk [||bad||]) [||bad||] ctx)||]
--}
-
-emitLengthCheck ::
- TH.Lift (InputToken inp) =>
- Int -> Gen inp vs es a -> Gen inp vs es a -> Gen inp vs es a
-emitLengthCheck 0 ok _ko = ok
-emitLengthCheck 1 ok ko = Gen $ \ctx -> [||
- if $$(moreInput ctx) $$(input ctx)
- then $$(unGen ok ctx)
- else let _ = "sat.length-check.else" in $$(unGen ko ctx)
- ||]
-{-
-emitLengthCheck n ok ko ctx = Gen $ \ctx -> [||
- if $$moreInput ($$shiftRight $$(input ctx) (n - 1))
- then $$(unGen ok ctx)
- else $$(unGen ko ctx {farthestExpecting = [||farExp||]})
- ||]
--}
-
-
-liftCode :: InstrPure a -> CodeQ a
-liftCode = trans
-{-# INLINE liftCode #-}
-
-liftCode1 :: InstrPure (a -> b) -> CodeQ a -> CodeQ b
-liftCode1 p a = case p of
- InstrPureSameOffset -> [|| $$sameOffset $$a ||]
- InstrPureHaskell h -> go a h
- where
- go :: CodeQ a -> H.Haskell (a -> b) -> CodeQ b
- go qa = \case
- (H.:$) -> [|| \x -> $$qa x ||]
- (H.:.) -> [|| \g x -> $$qa (g x) ||]
- H.Flip -> [|| \x y -> $$qa y x ||]
- (H.:.) H.:@ f H.:@ g -> [|| $$(go (go qa g) f) ||]
- H.Const -> [|| \_ -> $$qa ||]
- H.Flip H.:@ H.Const -> H.id
- h@(H.Flip H.:@ _f) -> [|| \x -> $$(liftCode2 (InstrPureHaskell h) qa [||x||]) ||]
- H.Eq x -> [|| $$(trans x) Eq.== $$qa ||]
- H.Id -> qa
- h -> [|| $$(trans h) $$qa ||]
+checkToken farExp p ok = ok
+ { unGen = \ctx -> [||
+ let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
+ if $$(genCode p) c
+ then $$(unGen ok ctx
+ { valueStack = ValueStackCons (H.Term [||c||]) (valueStack ctx)
+ , input = [||cs||]
+ })
+ else let _ = "checkToken.else" in $$(unGen (fail farExp) ctx)
+ ||]
+ }
-liftCode2 :: InstrPure (a -> b -> c) -> CodeQ a -> CodeQ b -> CodeQ c
-liftCode2 p a b = case p of
- InstrPureSameOffset -> [|| $$sameOffset $$a $$b ||]
- InstrPureHaskell h -> go a b h
- where
- go :: CodeQ a -> CodeQ b -> H.Haskell (a -> b -> c) -> CodeQ c
- go qa qb = \case
- (H.:$) -> [|| $$qa $$qb ||]
- (H.:.) -> [|| \x -> $$qa ($$qb x) ||]
- H.Flip -> [|| \x -> $$qa x $$qb ||]
- H.Flip H.:@ H.Const -> [|| $$qb ||]
- H.Flip H.:@ f -> go qb qa f
- H.Const -> [|| $$qa ||]
- H.Cons -> [|| $$qa : $$qb ||]
- h -> [|| $$(trans h) $$qa $$qb ||]
sourcephile / git / haskell / symantic-parser.git / blobdiff