import Data.Functor ((<$>))
import Data.Int (Int)
import Data.List (minimum)
+import Data.List.NonEmpty (NonEmpty(..))
import Data.Map (Map)
import Data.Maybe (Maybe(..))
+import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
+import Data.String (String)
import Language.Haskell.TH (CodeQ, Code(..))
-import Prelude (($!), (+), (-))
+import Prelude ((+), (-))
import Text.Show (Show(..))
+import GHC.TypeLits (symbolVal)
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map.Internal as Map_
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
+import qualified Language.Haskell.TH as TH
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(..))
-- * Type 'Gen'
-- | Generate the 'CodeQ' parsing the input.
-data Gen inp vs es a = Gen
+data Gen inp vs 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
+ -- ^ Synthetized (bottom-up) minimal input length
+ -- required by the parser to not fail.
+ -- This requires a 'minHorizonByName'
+ -- containing the minimal 'Horizon's of all the 'TH.Name's
-- this parser 'call's, 'jump's or 'refJoin's to.
+ , exceptions :: Map TH.Name (Map ErrorLabel ()) -> Map ErrorLabel ()
, unGen ::
- GenCtx inp vs es a ->
+ GenCtx inp vs a ->
CodeQ (Either (ParsingError inp) a)
}
}
deriving instance Show (InputToken inp) => Show (ParsingError inp)
+-- ** Type 'ErrorLabel'
+type ErrorLabel = String
+
-- ** Type 'Offset'
type Offset = Int
-- ** Type 'Horizon'
-- | Synthetized minimal input length
-- required for a successful parsing.
--- Used with 'horizon' to factorize input length checks,
+-- Used with 'checkedHorizon' to factorize input length checks,
-- instead of checking the input length
--- one 'InputToken' by one 'InputToken' at each 'read'.
+-- one 'InputToken' at a time at each 'read'.
type Horizon = Offset
-- ** Type 'Cont'
Cursor inp ->
Either (ParsingError inp) a
--- ** Type 'SubRoutine'
-type SubRoutine inp v a =
- {-ok-}Cont inp v a ->
- Cursor inp ->
- {-ko-}FailHandler inp a ->
- Either (ParsingError inp) a
-
--- ** Type 'FailHandler'
-type FailHandler inp a =
- {-failureInput-}Cursor inp ->
- {-farthestInput-}Cursor inp ->
- {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
- Either (ParsingError inp) a
-
{-
-- *** Type 'FarthestError'
data FarthestError inp = FarthestError
}
-}
--- | @('generate' input mach)@ generates @TemplateHaskell@ code
--- parsing given 'input' according to given 'mach'ine.
-generate ::
- forall inp ret.
+-- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
+-- parsing the given 'input' according to the given 'Machine'.
+generateCode ::
Ord (InputToken inp) =>
Show (InputToken inp) =>
TH.Lift (InputToken inp) =>
-- InputToken inp ~ Char =>
Input inp =>
- CodeQ inp ->
Show (Cursor inp) =>
- Gen inp '[] ('Succ 'Zero) ret ->
- CodeQ (Either (ParsingError inp) ret)
-generate input k = [||
+ Gen inp '[] a ->
+ CodeQ (inp -> Either (ParsingError inp) a)
+generateCode k = [|| \(input :: inp) ->
-- Pattern bindings containing unlifted types
-- should use an outermost bang pattern.
- let !(# init, readMore, readNext #) = $$(cursorOf input) in
+ let !(# init, readMore, readNext #) = $$(cursorOf [||input||]) in
let finalRet = \_farInp _farExp v _inp -> Right v in
- let finalFail _failInp !farInp !farExp =
+ let finalRaise :: forall b. (Catcher inp b)
+ = \_failInp !farInp !farExp ->
Left ParsingErrorStandard
{ parsingErrorOffset = offset farInp
, parsingErrorUnexpected =
} in
$$(unGen k GenCtx
{ valueStack = ValueStackEmpty
- , failStack = FailStackCons [||finalFail||] FailStackEmpty
+ , catchStackByLabel = Map.empty
+ , defaultCatch = [||finalRaise||]
, retCode = [||finalRet||]
, input = [||init||]
, nextInput = [||readNext||]
-- , farthestError = [||Nothing||]
, farthestInput = [||init||]
, farthestExpecting = [|| [] ||]
- , horizon = 0
- , horizonByName = Map.empty
+ , checkedHorizon = 0
+ , minHorizonByName = Map.empty
+ , exceptionsByName = Map.empty
})
||]
-- ** Type 'GenCtx'
--- | This is a context only present at compile-time.
-data GenCtx inp vs (es::Peano) a =
+-- | This is an inherited (top-down) context
+-- only present at compile-time, to build TemplateHaskell splices.
+data GenCtx inp vs a =
( TH.Lift (InputToken inp)
, Cursorable (Cursor inp)
, Show (InputToken inp)
- -- , InputToken inp ~ Char
) => GenCtx
{ valueStack :: ValueStack vs
- , failStack :: FailStack inp a es
- --, failStacks :: FailStack inp es a
+ , catchStackByLabel :: Map ErrorLabel (NonEmpty (CodeQ (Catcher inp a)))
+ -- | Default 'Catcher' defined at the begining of the generated 'CodeQ',
+ -- hence a constant within the 'Gen'eration.
+ , defaultCatch :: forall b. CodeQ (Catcher inp b)
, 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
+ -- | Remaining horizon already checked.
+ -- Updated by 'checkHorizon'
+ -- and reset elsewhere when needed.
+ , checkedHorizon :: Horizon
+ -- | Minimal horizon for each 'defLet' or 'defJoin'.
+ -- This can be done as an inherited attribute because
+ -- 'OverserveSharing' introduces 'def' as an ancestor node
+ -- of all the 'ref's pointing to it.
+ -- Same for 'defJoin' and its 'refJoin's.
+ , minHorizonByName :: Map TH.Name Horizon
+ , exceptionsByName :: Map TH.Name (Map ErrorLabel ())
}
-- ** Type 'ValueStack'
, valueStackTail :: ValueStack vs
} -> ValueStack (v ': vs)
--- ** Type 'FailStack'
-data FailStack inp a es where
- FailStackEmpty :: FailStack inp a 'Zero
- FailStackCons ::
- { failStackHead :: CodeQ (FailHandler inp a)
- , failStackTail :: FailStack inp a es
- } ->
- FailStack inp a ('Succ es)
-
-instance Stackable Gen where
- push x k = k
+instance InstrValuable Gen where
+ pushValue x k = k
{ unGen = \ctx -> unGen k ctx
{ valueStack = ValueStackCons x (valueStack ctx) }
}
- pop k = k
+ popValue k = k
{ unGen = \ctx -> unGen k ctx
{ valueStack = valueStackTail (valueStack ctx) }
}
- liftI2 f k = k
+ lift2Value f k = k
{ unGen = \ctx -> unGen k ctx
{ valueStack =
let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
ValueStackCons (f H.:@ x H.:@ y) xs
}
}
- swap k = k
+ swapValue 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
- caseI kx ky = Gen
- { minHorizon = \ls ->
- minHorizon kx ls `min` minHorizon ky ls
+instance InstrBranchable Gen where
+ caseBranch kx ky = Gen
+ { minHorizon = \hs -> minHorizon kx hs `min` minHorizon ky hs
+ , exceptions = \hs -> exceptions kx hs <> exceptions ky hs
, unGen = \ctx ->
let ValueStackCons v vs = valueStack ctx in
[||
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)
+ choicesBranch fs ks kd = Gen
+ { minHorizon = \hs -> minimum $
+ minHorizon kd hs :
+ (($ hs) . minHorizon <$> ks)
+ , exceptions = \hs -> mconcat $
+ exceptions kd hs :
+ (($ hs) . exceptions <$> ks)
, unGen = \ctx ->
let ValueStackCons v vs = valueStack ctx in
go ctx{valueStack = vs} v fs ks
else $$(go ctx x fs' ks')
||]
go ctx _ _ _ = unGen kd ctx
-instance Failable Gen where
- fail failExp = Gen
+instance InstrExceptionable Gen where
+ raiseException lbl failExp = Gen
{ minHorizon = \_hs -> 0
+ , exceptions = \_hs -> Map.singleton (symbolVal lbl) ()
, unGen = \ctx@GenCtx{} -> [||
let (# farInp, farExp #) =
case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
LT -> (# $$(input ctx), failExp #)
- EQ -> (# $$(farthestInput ctx), ($$(farthestExpecting ctx) <> failExp) #)
+ EQ -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) <> failExp #)
GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) in
- $$(failStackHead (failStack ctx))
+ $$(NE.head (Map.findWithDefault (NE.singleton (defaultCatch ctx)) (symbolVal lbl) (catchStackByLabel ctx)))
$$(input ctx) farInp farExp
||]
}
- popFail k = k
+ popException lbl k = k
{ unGen = \ctx ->
- unGen k ctx{failStack = failStackTail (failStack ctx)}
+ unGen k ctx{catchStackByLabel = Map.update (\case
+ _r0:|(r1:rs) -> Just (r1:|rs)
+ _ -> Nothing
+ ) (symbolVal lbl) (catchStackByLabel 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)
+ catchException lbl ok ko = Gen
+ { minHorizon = \hs -> minHorizon ok hs `min` minHorizon ko hs
+ , exceptions = \hs -> exceptions ok hs <> exceptions ko hs
+ , unGen = \ctx@GenCtx{} -> [||
+ let _ = "catchException lbl="<> $$(TH.liftTyped (symbolVal lbl)) in
+ $$(unGen ok ctx
+ { catchStackByLabel = Map.insertWith (<>) (symbolVal lbl)
+ (NE.singleton ([|| \ !failInp !farInp !farExp ->
+ $$(unGen ko ctx
+ -- PushValue 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||]
+ })
+ ||])) (catchStackByLabel ctx)
}
+ ) ||]
}
-instance Inputable Gen where
+-- ** Type 'Catcher'
+type Catcher inp a =
+ {-failureInput-}Cursor inp ->
+ {-farthestInput-}Cursor inp ->
+ {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
+ Either (ParsingError inp) a
+instance InstrInputable Gen where
loadInput k = k
{ unGen = \ctx ->
let ValueStackCons input vs = valueStack ctx in
unGen k ctx
{ valueStack = vs
, input = genCode input
- , horizon = 0
+ , checkedHorizon = 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 = k
+instance InstrLetable Gen where
+ defLet (LetName n) sub k = k
+ { unGen = \ctx@GenCtx{} -> Code $ TH.unsafeTExpCoerce $ do
+ -- 'sub' is recursively 'call'able within 'sub',
+ -- but its maximal 'minHorizon' is not known yet.
+ let minHorizonByNameButSub = Map.insert n 0 (minHorizonByName ctx)
+ let raiseLabelsByNameButSub = Map.insert n Map.empty (exceptionsByName ctx)
+ body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
+ -- Called by 'call' or 'jump'.
+ \ !ok{-from generateSuspend or retCode-}
+ !inp
+ !koByLabel{- 'catchStackByLabel' from the 'call'-site -} ->
+ $$(unGen sub ctx
+ { valueStack = ValueStackEmpty
+ -- Build a 'catchStackByLabel' from the one available at the 'call'-site.
+ -- Note that all the 'exceptions' of the 'sub'routine may not be available,
+ -- hence 'Map.findWithDefault' is used instead of 'Map.!'.
+ , catchStackByLabel = Map.mapWithKey
+ (\lbl () -> NE.singleton [||Map.findWithDefault $$(defaultCatch ctx) lbl koByLabel||])
+ (exceptions sub raiseLabelsByNameButSub)
+ , input = [||inp||]
+ , retCode = [||ok||]
+
+ -- These are passed by the caller via 'ok' or 'ko'
+ -- , farthestInput =
+ -- , farthestExpecting =
+
+ -- Some callers can call this 'defLet'
+ -- with zero 'checkedHorizon', hence use this minimum.
+ -- TODO: maybe it could be improved a bit
+ -- by taking the minimum of the checked horizons
+ -- before all the 'call's and 'jump's to this 'defLet'.
+ , checkedHorizon = 0
+ , minHorizonByName = minHorizonByNameButSub
+ , exceptionsByName = raiseLabelsByNameButSub
+ })
+ ||]
+ let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
+ expr <- TH.unTypeQ (TH.examineCode (unGen k ctx
+ { minHorizonByName =
+ -- 'sub' is 'call'able within 'k'.
+ Map.insert n
+ (minHorizon sub minHorizonByNameButSub)
+ (minHorizonByName ctx)
+ , exceptionsByName =
+ Map.insert n
+ (exceptions sub raiseLabelsByNameButSub)
+ (exceptionsByName ctx)
+ }))
+ return (TH.LetE [decl] expr)
+ }
+ jump (LetName n) = Gen
{ minHorizon = (Map.! n)
+ , exceptions = (Map.! n)
, unGen = \ctx -> [||
- let _ = "call" in
+ let _ = "jump" in
$$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
- {-ok-}$$(generateSuspend k ctx)
+ {-ok-}$$(retCode ctx)
$$(input ctx)
- $! $$(failStackHead (failStack ctx))
+ $$(liftTypedRaiseByLabel $
+ catchStackByLabel ctx
+ -- Pass only the labels raised by the 'defLet'.
+ `Map.intersection`
+ (exceptionsByName ctx Map.! n)
+ )
||]
}
- jump (LetName n) = Gen
+ call (LetName n) k = k
{ minHorizon = (Map.! n)
- , unGen = \ctx -> [||
- let _ = "jump" in
+ , exceptions = (Map.! n)
+ , unGen = \ctx -> let ks = (Map.keys (catchStackByLabel ctx)) in [||
+ let _ = $$(TH.liftTyped $ "call exceptionsByName("<>show n<>")="<>show (Map.keys (exceptionsByName ctx Map.! n)) <> " catchStackByLabel(ctx)="<> show ks) in
$$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
- {-ok-}$$(retCode ctx)
+ {-ok-}$$(generateSuspend k ctx)
$$(input ctx)
- $! $$(failStackHead (failStack ctx))
+ $$(liftTypedRaiseByLabel $
+ catchStackByLabel ctx
+ -- Pass only the labels raised by the 'defLet'.
+ `Map.intersection`
+ (exceptionsByName ctx Map.! n)
+ )
||]
}
ret = Gen
{ minHorizon = \_hs -> 0
+ , exceptions = \_hs -> Map.empty
, 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)
- }
--- | Generate a continuation to be called with 'generateResume',
--- used when 'call' 'ret'urns.
+-- | Like 'TH.liftTyped' but adjusted to work on 'catchStackByLabel'
+-- which already contains 'CodeQ' terms.
+-- Moreover, only the 'Catcher' at the top of the stack
+-- is needed and thus generated in the resulting 'CodeQ'.
+--
+-- TODO: Use an 'Array' instead of a 'Map'?
+liftTypedRaiseByLabel :: TH.Lift k => Map k (NonEmpty (CodeQ a)) -> CodeQ (Map k a)
+liftTypedRaiseByLabel Map_.Tip = [|| Map_.Tip ||]
+liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) =
+ [|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||]
+
+-- | Generate a 'retCode' 'Cont'inuation to be called with 'generateResume'.
+-- Used when 'call' 'ret'urns.
+-- The return 'v'alue is 'pushValue'ed on the 'valueStack'.
generateSuspend ::
- {-k-}Gen inp (v ': vs) es a ->
- GenCtx inp vs es a ->
+ {-k-}Gen inp (v ': vs) a ->
+ GenCtx inp vs a ->
CodeQ (Cont inp v a)
generateSuspend k ctx = [||
- let _ = "suspend" in
+ let _ = $$(TH.liftTyped $ "suspend raiseException=" <> show (exceptionsByName ctx)) in
\farInp farExp v !inp ->
$$(unGen k ctx
{ valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
, input = [||inp||]
, farthestInput = [||farInp||]
, farthestExpecting = [||farExp||]
- , horizon = 0
+ , checkedHorizon = 0
}
)
||]
--- | Generate a call to the 'generateSuspend' continuation,
--- used when 'call' 'ret'urns.
+-- | Generate a call to the 'generateSuspend' continuation.
+-- Used when 'call' 'ret'urns.
generateResume ::
CodeQ (Cont inp v a) ->
- Gen inp (v ': vs) es a
+ Gen inp (v ': vs) a
generateResume k = Gen
{ minHorizon = \_hs -> 0
+ , exceptions = \_hs -> Map.empty
, unGen = \ctx -> [||
let _ = "resume" in
$$k
||]
}
-instance Joinable Gen where
- 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
+instance InstrJoinable Gen where
+ defJoin (LetName n) joined k = k
+ { unGen = \ctx -> Code $ TH.unsafeTExpCoerce $ do
body <- TH.unTypeQ $ TH.examineCode $ [||
+ -- Called by 'generateResume'.
\farInp farExp v !inp ->
- $$(unGen sub ctx
+ $$(unGen joined ctx
{ valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
, input = [||inp||]
, farthestInput = [||farInp||]
, farthestExpecting = [||farExp||]
- , horizon = 0
- , horizonByName = Map.insert n 0 (horizonByName ctx)
+ , checkedHorizon = 0
+ {- FIXME:
+ , catchStackByLabel = Map.mapWithKey
+ (\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
+ (exceptions joined raiseLabelsByNameButSub)
+ -}
})
||]
let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
expr <- TH.unTypeQ (TH.examineCode (unGen k ctx
- { horizonByName =
+ { minHorizonByName =
+ -- 'joined' is 'refJoin'able within 'k'.
Map.insert n
- (minHorizon sub
- (Map.insert n 0 (horizonByName ctx)))
- (horizonByName ctx)
+ -- By definition (in 'joinNext')
+ -- 'joined' is not recursively 'refJoin'able within 'joined',
+ -- hence no need to prevent against recursivity
+ -- as has to be done in 'defLet'.
+ (minHorizon joined (minHorizonByName ctx))
+ (minHorizonByName ctx)
+ , exceptionsByName =
+ Map.insert n
+ (exceptions joined (exceptionsByName ctx))
+ (exceptionsByName ctx)
}))
return (TH.LetE [decl] expr)
}
refJoin (LetName n) = (generateResume (Code (TH.unsafeTExpCoerce (return (TH.VarE n)))))
{ minHorizon = (Map.! n)
+ , exceptions = (Map.! n)
}
-instance Readable Char Gen where
+instance InstrReadable Char Gen where
read farExp p = checkHorizon . checkToken farExp p
checkHorizon ::
TH.Lift (InputToken inp) =>
- {-ok-}Gen inp vs ('Succ es) a ->
- Gen inp vs ('Succ es) a
+ {-ok-}Gen inp vs a ->
+ Gen inp vs a
checkHorizon ok = ok
{ minHorizon = \hs -> 1 + minHorizon ok hs
- , unGen = \ctx0@GenCtx{failStack = FailStackCons e es} -> [||
+ , exceptions = \hs -> Map.insert "fail" () $ exceptions ok hs
+ , unGen = \ctx0@GenCtx{} ->
+ let raiseByLbl =
+ NE.head (Map.findWithDefault (NE.singleton (defaultCatch ctx0)) "fail" (catchStackByLabel ctx0)) in
+ [||
-- Factorize failure code
- let readFail = $$(e) in
+ let readFail = $$(raiseByLbl) 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
+ let ctx = ctx0{catchStackByLabel = Map.adjust (\(_r:|rs) -> [||readFail||] :| rs) "fail" (catchStackByLabel ctx0)} in
+ if checkedHorizon ctx >= 1
+ then unGen ok ctx0{checkedHorizon = checkedHorizon ctx - 1}
+ else let minHoriz = minHorizon ok (minHorizonByName ctx) in
[||
if $$(moreInput ctx)
- $$(if minHoz > 0
- then [||$$shiftRight minHoz $$(input ctx)||]
+ $$(if minHoriz > 0
+ then [||$$shiftRight minHoriz $$(input ctx)||]
else input ctx)
- then $$(unGen ok ctx{horizon = minHoz})
+ then $$(unGen ok ctx{checkedHorizon = minHoriz})
else let _ = "checkHorizon.else" in
- $$(unGen (fail [ErrorItemHorizon (minHoz + 1)]) ctx)
+ -- TODO: return a resuming continuation (eg. Partial)
+ $$(unGen (fail [ErrorItemHorizon (minHoriz + 1)]) ctx)
||]
)
||]
}
checkToken ::
- forall inp vs es a.
Ord (InputToken inp) =>
TH.Lift (InputToken inp) =>
[ErrorItem (InputToken inp)] ->
{-predicate-}TermInstr (InputToken inp -> Bool) ->
- {-ok-}Gen inp (InputToken inp ': vs) ('Succ es) a ->
- Gen inp vs ('Succ es) a
+ {-ok-}Gen inp (InputToken inp ': vs) a ->
+ Gen inp vs a
checkToken farExp p ok = ok
- { unGen = \ctx -> [||
+ { exceptions = \hs -> Map.insert "fail" () $ exceptions ok hs
+ , unGen = \ctx -> [||
let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
if $$(genCode p) c
then $$(unGen ok ctx
else let _ = "checkToken.else" in $$(unGen (fail farExp) ctx)
||]
}
-
sourcephile / git / haskell / symantic-parser.git / blobdiff