import Control.DeepSeq (NFData(..))
import Control.Monad (Monad(..))
import Control.Monad.ST (ST, runST)
-import Data.Bool (Bool)
+import Data.Bool (Bool(..), otherwise)
import Data.Char (Char)
-import Data.Either (Either(..), either)
-import Data.Foldable (toList, null)
-import Data.Function (($), (.), id, on)
-import Data.Functor (Functor, (<$>), (<$))
+import Data.Either (Either(..))
+import Data.Eq (Eq(..))
+import Data.Foldable (foldr, toList, null)
+import Data.Function (($), (.), on)
+import Data.Functor ((<$>))
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map (Map)
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
+import qualified Symantic.Data as Sym
import Symantic.Derive
import Symantic.ObserveSharing
-import Symantic.Parser.Grammar.ObserveSharing
+import qualified Symantic.Parser.Grammar as Gram
import Symantic.Parser.Grammar.Combinators
( UnscopedRegister(..)
, Exception(..)
, Failure(..)
, SomeFailure(..)
+ , unSomeFailure
, inputTokenProxy
)
import Symantic.Parser.Machine.Input
-- * Type 'Gen'
-- | Generate the 'CodeQ' parsing the input.
data Gen inp vs a = Gen
- { genAnalysisByLet :: OpenRecs TH.Name (CallTrace -> GenAnalysis)
+ { genAnalysisByLet :: OpenRecs TH.Name GenAnalysis
-- ^ 'genAnalysis' for each 'defLet' and 'defJoin' of the 'Machine'.
- , genAnalysis :: OpenRec TH.Name (CallTrace -> GenAnalysis)
+ , genAnalysis :: OpenRec TH.Name GenAnalysis
-- ^ Synthetized (bottom-up) static genAnalysis of the 'Machine'.
, unGen :: forall st.
GenCtx st inp vs a ->
-- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
-- parsing the given 'input' according to the given 'Machine'.
generateCode ::
- {-
- Eq (InputToken inp) =>
- NFData (InputToken inp) =>
+ -- Not really used constraints,
+ -- just to please 'checkHorizon'.
+ Ord (InputToken inp) =>
Show (InputToken inp) =>
- Typeable (InputToken inp) =>
TH.Lift (InputToken inp) =>
- -}
- -- InputToken inp ~ Char =>
- --forall inp a.
+ NFData (InputToken inp) =>
+ Typeable (InputToken inp) =>
Inputable inp =>
Show (Cursor inp) =>
Gen inp '[] a ->
CodeQ (inp -> Either (ParsingError inp) a)
-generateCode Gen{unGen=k, ..} = [|| \(input :: inp) ->
+generateCode gen =
+ let Gen{unGen=k, ..} = checkHorizon gen in
+ [|| \(input :: inp) ->
-- Pattern bindings containing unlifted types
-- should use an outermost bang pattern.
let !(# init, readMore, readNext #) = $$(cursorOf [||input||])
finalRet = \_farInp _farExp v _inp -> returnST $ Right v
- finalRaise :: forall st b. (Catcher st inp b)
+ finalRaise :: forall st b. (OnException st inp b)
= \ !exn _failInp !farInp !farExp ->
returnST $ Left ParsingError
{ parsingErrorOffset = offset farInp
if readMore farInp
then Just (let (# c, _ #) = readNext farInp in c)
else Nothing
- , parsingErrorExpecting = farExp
+ , parsingErrorExpecting =
+ let (minHoriz, res) =
+ Set.foldr (\f (minH, acc) ->
+ case unSomeFailure f of
+ Just (FailureHorizon h :: Failure (Gram.CombSatisfiable (InputToken inp)))
+ | Just old <- minH -> (Just (min old h), acc)
+ | otherwise -> (Just h, acc)
+ _ -> (minH, f:acc)
+ ) (Nothing, []) farExp in
+ Set.fromList $ case minHoriz of
+ Just h -> SomeFailure (FailureHorizon @(InputToken inp) h) : res
+ Nothing -> res
}
in runST $$(
let
defInputTokenProxy $
k GenCtx
{ valueStack = ValueStackEmpty
- , catchStackByLabel = Map.empty :: Map Exception (NonEmpty (TH.CodeQ (Catcher s inp a)))
+ , onExceptionStackByLabel = Map.empty :: Map Exception (NonEmpty (TH.CodeQ (OnException s inp a)))
, defaultCatch = [||finalRaise||]
- , analysisCallStack = []
- , returnCall = [||finalRet||] :: CodeQ (Return s inp a a)
+ , onReturn = [||finalRet||] :: CodeQ (OnReturn s inp a a)
, input = [||init||]
, nextInput = [||readNext||]
, moreInput = [||readMore||]
, farthestInput = [||init||]
, farthestExpecting = [||Set.empty||]
, checkedHorizon = 0
- , horizonStack = []
- , finalGenAnalysisByLet = runOpenRecs genAnalysisByLet
+ , analysisByLet = mutualFix genAnalysisByLet
}
)
||]
-- * Type 'GenAnalysis'
data GenAnalysis = GenAnalysis
- { minReads :: Either Exception Horizon
+ { minReads :: Horizon
+ -- ^ The minimun number of input tokens to read
+ -- on the current 'input' to reach a success.
, mayRaise :: Map Exception ()
+ -- ^ The 'Exception's that may be raised depending on the 'input'.
+ , alwaysRaise :: Set Exception
+ -- ^ The 'Exception's raised whatever is or happen to the 'input'.
+ , freeRegs :: Set TH.Name
+ -- ^ The free registers that are used.
} deriving (Show)
-- ** Type 'Offset'
-- | Minimal input length required for a successful parsing.
type Horizon = Offset
--- altGenAnalysis = List.foldl' (\acc x -> either Left (\h -> Right (either (const h) (min h) acc)) x)
-- | Merge given 'GenAnalysis' as sequences.
seqGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
seqGenAnalysis aas@(a:|as) = GenAnalysis
- { minReads = List.foldl' (\acc x ->
- acc >>= \r -> (r +) <$> minReads x
- ) (minReads a) as
+ { minReads = List.foldl' (\acc -> (acc +) . minReads) (minReads a) as
, mayRaise = sconcat (mayRaise <$> aas)
+ , alwaysRaise = sconcat (alwaysRaise <$> aas)
+ , freeRegs = sconcat (freeRegs <$> aas)
}
-- | Merge given 'GenAnalysis' as alternatives.
altGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
-altGenAnalysis aas@(a:|as) = GenAnalysis
- { minReads = List.foldl' (\acc x ->
- case acc of
- Left l ->
- case minReads x of
- Left{} -> Left l
- Right r -> Right r
- Right r ->
- case minReads x of
- Left{} -> Right r
- Right r' -> Right (min r r')
- ) (minReads a) as
+altGenAnalysis aas = GenAnalysis
+ { minReads =
+ case
+ (`NE.filter` aas) $ \a ->
+ -- If an alternative 'alwaysRaise's 'ExceptionFailure' whatever its 'input' is,
+ -- it __should__ remain semantically the same (up to the exact 'Failure's)
+ -- to raise an 'ExceptionFailure' even before knowing
+ -- whether that alternative branch will be taken or not,
+ -- hence an upstream 'checkHorizon' is allowed to raise an 'ExceptionFailure'
+ -- based only upon the 'minReads' of such alternatives:
+ Set.toList (alwaysRaise a) /= [ExceptionFailure]
+ of
+ [] -> 0
+ a:as -> List.foldl' (\acc -> min acc . minReads) (minReads a) as
, mayRaise = sconcat (mayRaise <$> aas)
+ , alwaysRaise = foldr Set.intersection Set.empty (alwaysRaise <$> aas)
+ , freeRegs = sconcat (freeRegs <$> aas)
}
+
{-
-- *** Type 'FarthestError'
data FarthestError inp = FarthestError
-- only present at compile-time, to build TemplateHaskell splices.
data GenCtx st inp vs a =
( Cursorable (Cursor inp)
- {-
+ -- For checkHorizon
, TH.Lift (InputToken inp)
, Show (InputToken inp)
, Eq (InputToken inp)
+ , Ord (InputToken inp)
, Typeable (InputToken inp)
, NFData (InputToken inp)
- -}
) => GenCtx
{ valueStack :: ValueStack vs
- , catchStackByLabel :: Map Exception (NonEmpty (CodeQ (Catcher st inp a)))
- -- | Default 'Catcher' defined at the begining of the generated 'CodeQ',
+ , onExceptionStackByLabel :: Map Exception (NonEmpty (CodeQ (OnException st inp a)))
+ -- | Default 'OnException' defined at the begining of the generated 'CodeQ',
-- hence a constant within the 'Gen'eration.
- , defaultCatch :: forall b. CodeQ (Catcher st inp b)
- -- | Used by 'checkToken' to get 'GenAnalysis' from 'genAnalysis'.
- , analysisCallStack :: [TH.Name]
- , returnCall :: CodeQ (Return st inp a a)
+ , defaultCatch :: forall b. CodeQ (OnException st inp b)
+ , onReturn :: CodeQ (OnReturn st inp a a)
, input :: CodeQ (Cursor inp)
, moreInput :: CodeQ (Cursor inp -> Bool)
, nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
-- Updated by 'checkHorizon'
-- and reset elsewhere when needed.
, checkedHorizon :: Horizon
- -- | Used by 'pushInput' and 'loadInput'
- -- to restore the 'Horizon' at the restored 'input'.
- , horizonStack :: [Horizon]
- -- | Output of 'runOpenRecs'.
- , finalGenAnalysisByLet :: LetRecs TH.Name GenAnalysis
+ -- | Output of 'mutualFix'.
+ , analysisByLet :: LetRecs TH.Name GenAnalysis
}
-- ** Type 'ValueStack'
, valueStackTail :: ValueStack vs
} -> ValueStack (v ': vs)
+instance InstrComment Gen where
+ comment msg k = k
+ { unGen = \ctx -> {-trace "unGen.comment" $-}
+ [||
+ let _ = $$(liftTypedString $ "comment: "<>msg) in
+ $$(unGen k ctx)
+ ||]
+ }
instance InstrValuable Gen where
pushValue x k = k
- { unGen = \ctx -> {-trace "unGen.pushValue" $-} unGen k ctx
- { valueStack = ValueStackCons x (valueStack ctx) }
+ { unGen = \ctx -> {-trace "unGen.pushValue" $-}
+ [||
+ let _ = "pushValue" in
+ $$(unGen k ctx
+ { valueStack = ValueStackCons x (valueStack ctx) })
+ ||]
}
popValue k = k
- { unGen = \ctx -> {-trace "unGen.popValue" $-} unGen k ctx
- { valueStack = valueStackTail (valueStack ctx) }
+ { unGen = \ctx -> {-trace "unGen.popValue" $-}
+ [||
+ let _ = "popValue" in
+ $$(unGen k ctx
+ { valueStack = valueStackTail (valueStack ctx) })
+ ||]
}
lift2Value f k = k
- { unGen = \ctx -> {-trace "unGen.lift2Value" $-} unGen k ctx
- { valueStack =
- let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
- ValueStackCons (f Prod..@ x Prod..@ y) vs
- }
+ { unGen = \ctx -> {-trace "unGen.lift2Value" $-}
+ [||
+ let _ = $$(liftTypedString ("lift2Value checkedHorizon="<>show (checkedHorizon ctx))) in
+ $$(unGen k ctx
+ { valueStack =
+ let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
+ ValueStackCons (f Prod..@ x Prod..@ y) vs
+ })
+ ||]
}
swapValue k = k
{ unGen = \ctx -> {-trace "unGen.swapValue" $-} unGen k ctx
instance InstrBranchable Gen where
caseBranch kx ky = Gen
{ genAnalysisByLet = genAnalysisByLet kx <> genAnalysisByLet ky
- , genAnalysis = \final ct -> altGenAnalysis $ genAnalysis kx final ct :| [genAnalysis ky final ct]
+ , genAnalysis = \final -> altGenAnalysis $
+ genAnalysis kx final :|
+ [genAnalysis ky final]
, unGen = \ctx -> {-trace "unGen.caseBranch" $-}
let ValueStackCons v vs = valueStack ctx in
[||
}
choicesBranch bs default_ = Gen
{ genAnalysisByLet = sconcat $ genAnalysisByLet default_ :| (genAnalysisByLet . snd <$> bs)
- , genAnalysis = \final ct -> altGenAnalysis $
- (\k -> genAnalysis k final ct)
+ , genAnalysis = \final -> altGenAnalysis $
+ (\k -> genAnalysis k final)
<$> (default_:|(snd <$> bs))
, unGen = \ctx0 -> {-trace "unGen.choicesBranch" $-}
let ValueStackCons v vs = valueStack ctx0 in
go x ((p,b):bs') = [||
if $$(genCode (p Prod..@ x))
then
- let _ = "choicesBranch.then" in
+ let _ = $$(liftTypedString ("choicesBranch checkedHorizon="<>show (checkedHorizon ctx))) in
$$({-trace "unGen.choicesBranch.b" $-} unGen b ctx)
else
let _ = "choicesBranch.else" in
instance InstrExceptionable Gen where
raise exn = Gen
{ genAnalysisByLet = HM.empty
- , genAnalysis = \_final _ct -> GenAnalysis
- { minReads = Left (ExceptionLabel exn)
+ , genAnalysis = \_final -> GenAnalysis
+ { minReads = 0
, mayRaise = Map.singleton (ExceptionLabel exn) ()
+ , alwaysRaise = Set.singleton (ExceptionLabel exn)
+ , freeRegs = Set.empty
}
, unGen = \ctx@GenCtx{} -> {-trace ("unGen.raise: "<>show exn) $-} [||
$$(raiseException ctx (ExceptionLabel exn))
}
fail fs = Gen
{ genAnalysisByLet = HM.empty
- , genAnalysis = \_final _ct -> GenAnalysis
- { minReads = Left ExceptionFailure
+ , genAnalysis = \_final -> GenAnalysis
+ { minReads = 0
, mayRaise = Map.singleton ExceptionFailure ()
+ , alwaysRaise = Set.singleton ExceptionFailure
+ , freeRegs = Set.empty
}
, unGen = \ctx@GenCtx{} -> {-trace ("unGen.fail: "<>show exn) $-}
if null fs
}
commit exn k = k
{ unGen = \ctx -> {-trace ("unGen.commit: "<>show exn) $-}
- unGen k ctx{catchStackByLabel =
+ [||
+ let _ = "commit" in
+ $$(unGen k ctx{onExceptionStackByLabel =
Map.update (\case
_r0:|(r1:rs) -> Just (r1:|rs)
_ -> Nothing
)
- exn (catchStackByLabel ctx)
- }
+ exn (onExceptionStackByLabel ctx)
+ })
+ ||]
}
- catch exn ok ko = Gen
- { genAnalysisByLet = genAnalysisByLet ok <> genAnalysisByLet ko
- , genAnalysis = \final ct ->
- let okGA = genAnalysis ok final ct in
+ catch exn k onExn = Gen
+ { genAnalysisByLet = genAnalysisByLet k <> genAnalysisByLet onExn
+ , genAnalysis = \final ->
+ let kAnalysis = genAnalysis k final in
+ let onExnAnalysis = genAnalysis onExn final in
altGenAnalysis $
- okGA{ mayRaise = Map.delete exn (mayRaise okGA) } :|
- [ genAnalysis ko final ct ]
+ kAnalysis
+ { mayRaise = Map.delete exn (mayRaise kAnalysis)
+ , alwaysRaise = Set.delete exn (alwaysRaise kAnalysis)
+ } :|
+ [ onExnAnalysis ]
, unGen = \ctx@GenCtx{} -> {-trace ("unGen.catch: "<>show exn) $-} [||
- let _ = $$(liftTypedString ("catch "<>show exn)) in
- let catchHandler !_exn !failInp !farInp !farExp =
- let _ = $$(liftTypedString ("catch.ko "<>show exn)) in
- $$({-trace ("unGen.catch.ko: "<>show exn) $-} unGen ko ctx
- -- Push 'input' and 'checkedHorizon'
- -- as they were when entering 'catch',
- -- they will be available to 'loadInput', if any.
- { valueStack =
- ValueStackCons (splice (input ctx)) $
- --ValueStackCons (Prod.var [||exn||]) $
- valueStack ctx
- , horizonStack =
- checkedHorizon ctx : horizonStack ctx
- -- Note that 'catchStackByLabel' is reset.
- -- Move the input to the failing position.
- , input = [||failInp||]
- -- The 'checkedHorizon' at the 'raise's are not known here.
- -- Nor whether 'failInp' is after 'checkedHorizon' or not.
- -- Hence fallback to a safe value.
- , checkedHorizon = 0
- -- Set the farthestInput to the farthest computed in 'fail'.
- , farthestInput = [||farInp||]
- , farthestExpecting = [||farExp||]
- })
- in
- $$({-trace ("unGen.catch.ok: "<>show es) $-} unGen ok ctx
- { catchStackByLabel =
+ let _ = $$(liftTypedString ("catch "<>show exn<>" checkedHorizon="<>show (checkedHorizon ctx))) in
+ let onException = $$(onExceptionCode (input ctx) (checkedHorizon ctx) onExn ctx) in
+ $$(unGen k ctx
+ { onExceptionStackByLabel =
Map.insertWith (<>) exn
- (NE.singleton [||catchHandler||])
- (catchStackByLabel ctx)
+ (NE.singleton [||onException||])
+ (onExceptionStackByLabel ctx)
}
) ||]
}
+-- ** Class 'SpliceInputable'
+-- | Record an 'input' and a 'checkedHorizon' together
+-- to be able to put both of them on the 'valueStack',
+-- and having them moved together by operations
+-- on the 'valueStack' (eg. 'lift2Value').
+-- Used by 'saveInput' and 'loadInput'.
+class SpliceInputable repr where
+ inputSave :: CodeQ inp -> Horizon -> repr inp
+data instance Sym.Data SpliceInputable repr a where
+ InputSave :: CodeQ inp -> Horizon -> Sym.Data SpliceInputable repr inp
+instance SpliceInputable (Sym.Data SpliceInputable repr) where
+ inputSave = InputSave
+instance SpliceInputable repr => SpliceInputable (Sym.SomeData repr) where
+ inputSave inp = Sym.SomeData . InputSave inp
+instance SpliceInputable TH.CodeQ where
+ inputSave inp _hor = inp
+instance SpliceInputable repr => Derivable (Sym.Data SpliceInputable repr) where
+ derive = \case
+ InputSave inp hor -> inputSave inp hor
instance InstrInputable Gen where
- pushInput k = k
+ saveInput k = k
{ unGen = \ctx ->
- {-trace "unGen.pushInput" $-}
- unGen k ctx
- { valueStack = splice (input ctx) `ValueStackCons` valueStack ctx
- , horizonStack = checkedHorizon ctx : horizonStack ctx
- }
+ {-trace "unGen.saveInput" $-}
+ [||
+ let _ = $$(liftTypedString $ "saveInput checkedHorizon="<>show (checkedHorizon ctx)) in
+ $$(unGen k ctx
+ { valueStack = inputSave (input ctx) (checkedHorizon ctx) `ValueStackCons` valueStack ctx
+ })
+ ||]
}
loadInput k = k
- { unGen = \ctx ->
+ { unGen = \ctx@GenCtx{} ->
{-trace "unGen.loadInput" $-}
- let ValueStackCons input vs = valueStack ctx in
- let (h, hs) = case horizonStack ctx of
- [] -> (0, [])
- x:xs -> (x, xs) in
- unGen k ctx
+ let ValueStackCons v vs = valueStack ctx in
+ let (input, checkedHorizon) = case v of
+ Sym.Data (InputSave i h) -> (i, h)
+ -- This case should never happen if 'saveInput' is used.
+ i -> (genCode i, 0) in
+ [||
+ let _ = $$(liftTypedString $ "loadInput checkedHorizon="<>show checkedHorizon) in
+ $$(unGen (checkHorizon k) ctx
{ valueStack = vs
- , horizonStack = hs
- , input = genCode input
- , checkedHorizon = h
- }
- , genAnalysis = \final ct -> GenAnalysis
- { minReads = 0 <$ minReads (genAnalysis k final ct)
- , mayRaise = mayRaise (genAnalysis k final ct)
- }
+ , input
+ , checkedHorizon
+ })
+ ||]
+ , genAnalysis = \final ->
+ let analysis = genAnalysis k final in
+ -- The input is reset and thus any previous 'checkHorizon'
+ -- cannot check after this 'loadInput'.
+ analysis{minReads = 0}
}
instance InstrCallable Gen where
defLet defs k = k
}
where
makeDecl ctx (subName, SomeLet sub) = do
- body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
- -- TODO: takeFreeRegisters
+ let subAnalysis = analysisByLet ctx HM.! subName
+ body <- takeFreeRegs (freeRegs subAnalysis) $
+ TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
-- Called by 'call' or 'jump'.
- \ !callReturn{-from generateSuspend or returnCall-}
- !callInput
- !callCatchStackByLabel{- 'catchStackByLabel' from the 'call'-site -} ->
+ \ !callerOnReturn{-from onReturnCode-}
+ !callerInput
+ !callerOnExceptionStackByLabel{- 'onExceptionStackByLabel' from the 'call'-site -} ->
$$({-trace ("unGen.defLet.sub: "<>show subName) $-} unGen sub ctx
{ valueStack = ValueStackEmpty
- -- Build a 'catchStackByLabel' for the 'mayRaise' of the subroutine,
- -- where each 'Catcher' calls the one passed by the 'call'-site (in 'callCatchStackByLabel').
- -- Note that currently the 'call'-site can supply in 'callCatchStackByLabel'
+ -- Build a 'onExceptionStackByLabel' for the 'mayRaise' of the subroutine,
+ -- where each 'OnException' calls the one passed by the 'call'-site (in 'callerOnExceptionStackByLabel').
+ -- Note that currently the 'call'-site can supply in 'callerOnExceptionStackByLabel'
-- a subset of the 'mayRaise' needed by this subroutine,
-- because 'Map.findWithDefault' is used instead of 'Map.!'.
- , catchStackByLabel = Map.mapWithKey
- (\lbl () -> NE.singleton [||Map.findWithDefault $$(defaultCatch ctx) lbl callCatchStackByLabel||])
+ , onExceptionStackByLabel = Map.mapWithKey
+ (\lbl () -> NE.singleton [||Map.findWithDefault $$(defaultCatch ctx) lbl callerOnExceptionStackByLabel||])
({-trace ("mayRaise: "<>show subName) $-}
- mayRaise (finalGenAnalysisByLet ctx HM.! subName))
- , input = [||callInput||]
- , returnCall = {-trace ("unGen.defLet.sub.returnCall: "<>show subName) $-} [||callReturn||]
+ mayRaise subAnalysis)
+ , input = [||callerInput||]
+ , onReturn = {-trace ("unGen.defLet.sub.onReturn: "<>show subName) $-} [||callerOnReturn||]
- -- These are passed by the caller via 'callReturn' or 'ko'
+ -- These are passed by the caller via 'callerOnReturn' or 'ko'
-- , farthestInput =
-- , farthestExpecting =
- -- Some callers can call this 'defLet'
+ -- Some callers can call this declaration
-- 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'.
+ -- before all the 'call's and 'jump's to this declaration.
, checkedHorizon = 0
})
||]
let decl = TH.FunD subName [TH.Clause [] (TH.NormalB body) []]
return decl
- jump (LetName n) = Gen
+ jump isRec (LetName subName) = Gen
{ genAnalysisByLet = HM.empty
- , genAnalysis = \final ct ->
- if n`List.elem`ct
+ , genAnalysis = \final ->
+ if isRec
then GenAnalysis
- { minReads = Right 0
+ { minReads = 0
, mayRaise = Map.empty
+ , alwaysRaise = Set.empty
+ , freeRegs = Set.empty
}
- else (final HM.! n) (n:ct)
- , unGen = \ctx -> {-trace ("unGen.jump: "<>show n) $-} [||
+ else final HM.! subName
+ , unGen = \ctx -> {-trace ("unGen.jump: "<>show subName) $-}
+ let subAnalysis = analysisByLet ctx HM.! subName in
+ [||
let _ = "jump" in
- $$(TH.unsafeCodeCoerce (return (TH.VarE n)))
- {-ok-}$$(returnCall ctx)
+ $$(TH.unsafeCodeCoerce $
+ giveFreeRegs (freeRegs subAnalysis) $
+ return (TH.VarE subName))
+ {-ok-}$$(onReturn ctx)
$$(input ctx)
$$(liftTypedRaiseByLabel $
- catchStackByLabel ctx
+ onExceptionStackByLabel ctx
-- Pass only the labels raised by the 'defLet'.
`Map.intersection`
- (mayRaise $ finalGenAnalysisByLet ctx HM.! n)
+ (mayRaise subAnalysis)
)
||]
}
- call (LetName n) k = k
- { genAnalysis = \final ct ->
- if n`List.elem`ct
+ call isRec (LetName subName) k = k
+ { genAnalysis = \final ->
+ if isRec
then GenAnalysis
- { minReads = Right 0
+ { minReads = 0
, mayRaise = Map.empty
+ , alwaysRaise = Set.empty
+ , freeRegs = Set.empty
}
- else seqGenAnalysis $
- (final HM.! n) (n:ct) :|
- [ genAnalysis k final ct ]
- , unGen = {-trace ("unGen.call: "<>show n) $-} \ctx ->
- -- let ks = (Map.keys (catchStackByLabel ctx)) in
+ else seqGenAnalysis $ (final HM.! subName) :| [ genAnalysis k final ]
+ , unGen = {-trace ("unGen.call: "<>show subName) $-} \ctx ->
+ -- let ks = (Map.keys (onExceptionStackByLabel ctx)) in
+ let subAnalysis = analysisByLet ctx HM.! subName in
[||
- -- let _ = $$(liftTypedString $ "call exceptByLet("<>show n<>")="<>show (Map.keys (Map.findWithDefault Map.empty n (exceptByLet ctx))) <> " catchStackByLabel(ctx)="<> show ks) in
- $$(TH.unsafeCodeCoerce (return (TH.VarE n)))
- {-ok-}$$(generateSuspend k ctx{analysisCallStack = n : analysisCallStack ctx})
+ -- let _ = $$(liftTypedString $ "call exceptByLet("<>show subName<>")="<>show (Map.keys (Map.findWithDefault Map.empty subName (exceptByLet ctx))) <> " onExceptionStackByLabel(ctx)="<> show ks) in
+ $$(TH.unsafeCodeCoerce $
+ giveFreeRegs (freeRegs subAnalysis) $
+ return (TH.VarE subName))
+ {-ok-}$$(onReturnCode k ctx)
$$(input ctx)
$$(liftTypedRaiseByLabel $
- -- FIXME: maybe it should rather pass all the 'mayRaise' of 'n'
- -- and 'defaultCatch' be removed from 'makeDecl''s 'catchStackByLabel'.
- catchStackByLabel ctx
+ -- FIXME: maybe it should rather pass all the 'mayRaise' of 'subName'
+ -- and 'defaultCatch' be removed from 'makeDecl''s 'onExceptionStackByLabel'.
+ onExceptionStackByLabel ctx
-- Pass only the labels raised by the 'defLet'.
`Map.intersection`
- (mayRaise $ finalGenAnalysisByLet ctx HM.! n)
+ (mayRaise subAnalysis)
)
||]
}
ret = Gen
{ genAnalysisByLet = HM.empty
- , genAnalysis = \_final _ct -> GenAnalysis
- { minReads = Right 0
+ , genAnalysis = \_final -> GenAnalysis
+ { minReads = 0
, mayRaise = Map.empty
+ , alwaysRaise = Set.empty
+ , freeRegs = Set.empty
}
, unGen = \ctx -> {-trace "unGen.ret" $-}
- {-trace "unGen.ret.generateResume" $-}
- generateResume ({-trace "unGen.ret.returnCall" $-} returnCall ctx) ctx
+ {-trace "unGen.ret.returnCode" $-}
+ returnCode ({-trace "unGen.ret.onReturn" $-} onReturn ctx) ctx
}
+takeFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp
+takeFreeRegs frs k = go (Set.toList frs)
+ where
+ go [] = k
+ go (r:rs) = [| \ $(return (TH.VarP r)) -> $(go rs) |]
+
+giveFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp
+giveFreeRegs frs k = go (Set.toList frs)
+ where
+ go [] = k
+ go (r:rs) = [| $(go rs) $(return (TH.VarE r)) |]
+
-- | Like 'TH.liftString' but on 'TH.Code'.
-- Useful to get a 'TH.StringL' instead of a 'TH.ListE'.
liftTypedString :: String -> TH.Code TH.Q a
liftTypedString = TH.unsafeCodeCoerce . TH.liftString
--- | Like 'TH.liftTyped' but adjusted to work on 'catchStackByLabel'
+-- | Like 'TH.liftTyped' but adjusted to work on 'onExceptionStackByLabel'
-- which already contains 'CodeQ' terms.
--- Moreover, only the 'Catcher' at the top of the stack
+-- Moreover, only the 'OnException' at the top of the stack
-- is needed and thus generated in the resulting 'CodeQ'.
--
-- TODO: Use an 'Array' instead of a 'Map'?
liftTyped Set_.Tip = [|| Set_.Tip ||]
liftTyped (Set_.Bin s a l r) = [|| Set_.Bin $$(TH.liftTyped s) $$(TH.liftTyped a) $$(TH.liftTyped l) $$(TH.liftTyped r) ||]
--- ** Type 'Return'
-type Return st inp v a =
+-- ** Type 'OnReturn'
+-- | A continuation generated by 'onReturnCode' and later called by 'returnCode'.
+type OnReturn st inp v a =
{-farthestInput-}Cursor inp ->
- {-farthestExpecting-}(Set SomeFailure) ->
+ {-farthestExpecting-}Set SomeFailure ->
v ->
Cursor inp ->
ST st (Either (ParsingError inp) a)
--- | Generate a 'returnCall' 'Return'inuation to be called with 'generateResume'.
+-- | Generate an 'OnReturn' continuation to be called with 'returnCode'.
-- Used when 'call' 'ret'urns.
-- The return 'v'alue is 'pushValue'-ed on the 'valueStack'.
-generateSuspend ::
+onReturnCode ::
{-k-}Gen inp (v ': vs) a ->
GenCtx st inp vs a ->
- CodeQ (Return st inp v a)
-generateSuspend k ctx = [||
- let _ = $$(liftTypedString $ "suspend") in
+ CodeQ (OnReturn st inp v a)
+onReturnCode k ctx = [||
+ let _ = $$(liftTypedString $ "onReturn") in
\farInp farExp v !inp ->
- $$({-trace "unGen.generateSuspend" $-} unGen k ctx
- { valueStack = ValueStackCons ({-trace "unGen.generateSuspend.value" $-} splice [||v||]) (valueStack ctx)
+ $$({-trace "unGen.onReturnCode" $-} unGen k ctx
+ { valueStack = ValueStackCons ({-trace "unGen.onReturnCode.value" $-} splice [||v||]) (valueStack ctx)
, input = [||inp||]
, farthestInput = [||farInp||]
, farthestExpecting = [||farExp||]
)
||]
--- | Generate a call to the 'generateSuspend' continuation.
+-- | Generate a call to the 'onReturnCode' continuation.
-- Used when 'call' 'ret'urns.
-generateResume ::
- CodeQ (Return st inp v a) ->
+returnCode ::
+ CodeQ (OnReturn st inp v a) ->
GenCtx st inp (v ': vs) a ->
CodeQ (ST st (Either (ParsingError inp) a))
-generateResume k = \ctx -> {-trace "generateResume" $-} [||
+returnCode k = \ctx -> {-trace "returnCode" $-} [||
let _ = "resume" in
$$k
$$(farthestInput ctx)
$$(farthestExpecting ctx)
- (let _ = "resume.genCode" in $$({-trace "generateResume.genCode" $-}
+ (let _ = "resume.genCode" in $$({-trace "returnCode.genCode" $-}
genCode $ valueStackHead $ valueStack ctx))
$$(input ctx)
||]
--- ** Type 'Catcher'
-type Catcher st inp a =
+-- ** Type 'OnException'
+-- | A continuation generated by 'catch' and later called by 'raise' or 'fail'.
+type OnException st inp a =
Exception ->
{-failInp-}Cursor inp ->
{-farInp-}Cursor inp ->
- {-farExp-}(Set SomeFailure) ->
+ {-farExp-}Set SomeFailure ->
ST st (Either (ParsingError inp) a)
+-- TODO: some static infos should be attached to 'OnException'
+-- to avoid comparing inputs when they're the same
+-- and to improve 'checkedHorizon'.
+onExceptionCode ::
+ CodeQ (Cursor inp) -> Horizon ->
+ Gen inp (Cursor inp : vs) a ->
+ GenCtx st inp vs a -> TH.CodeQ (OnException st inp a)
+onExceptionCode resetInput resetCheckedHorizon k ctx = [||
+ let _ = $$(liftTypedString $ "onException") in
+ \ !_exn !failInp !farInp !farExp ->
+ $$(unGen k ctx
+ -- Push 'input' and 'checkedHorizon'
+ -- as they were when entering the 'catch' or 'iter',
+ -- they will be available to 'loadInput', if any.
+ { valueStack = inputSave resetInput resetCheckedHorizon
+ `ValueStackCons` valueStack ctx
+ -- Note that 'onExceptionStackByLabel' is reset.
+ -- Move the input to the failing position.
+ , input = [||failInp||]
+ -- The 'checkedHorizon' at the 'raise's are not known here.
+ -- Nor whether 'failInp' is after 'checkedHorizon' or not.
+ -- Hence fallback to a safe value.
+ , checkedHorizon = 0
+ -- Set those to the farthest error computed in 'raiseFailure'.
+ , farthestInput = [||farInp||]
+ , farthestExpecting = [||farExp||]
+ })
+ ||]
+
instance InstrJoinable Gen where
defJoin (LetName n) sub k = k
{ unGen = \ctx ->
{-trace ("unGen.defJoin: "<>show n) $-}
TH.unsafeCodeCoerce [|
let $(return (TH.VarP n)) = $(TH.unTypeQ $ TH.examineCode [||
- -- Called by 'generateResume'.
+ -- Called by 'returnCode'.
\farInp farExp v !inp ->
$$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
{ valueStack = ValueStackCons (splice [||v||]) (valueStack ctx)
, farthestExpecting = [||farExp||]
, checkedHorizon = 0
{- FIXME:
- , catchStackByLabel = Map.mapWithKey
+ , onExceptionStackByLabel = Map.mapWithKey
(\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
(mayRaise sub raiseLabelsByLetButSub)
-}
refJoin (LetName n) = Gen
{ unGen = \ctx ->
{-trace ("unGen.refJoin: "<>show n) $-}
- generateResume
+ returnCode
(TH.unsafeCodeCoerce (return (TH.VarE n))) ctx
, genAnalysisByLet = HM.empty
- , genAnalysis = \final ct ->
- if n`List.elem`ct -- FIXME: useless
- then GenAnalysis
- { minReads = Right 0
- , mayRaise = Map.empty
- }
- else HM.findWithDefault
- (error (show (n,ct,HM.keys final)))
- n final (n:ct)
+ , genAnalysis = \final ->
+ HM.findWithDefault
+ (error (show (n,HM.keys final)))
+ n final
}
instance InstrReadable Char Gen where
read fs p = checkHorizon . checkToken fs p
instance InstrReadable Word8 Gen where
read fs p = checkHorizon . checkToken fs p
instance InstrIterable Gen where
- iter (LetName jumpName) loop done = Gen
- { genAnalysisByLet =
- HM.insert jumpName (genAnalysis loop) $
- genAnalysisByLet loop <>
- genAnalysisByLet done
- , genAnalysis = \final ct ->
+ iter (LetName loopJump) loop done = Gen
+ { genAnalysisByLet = HM.unions
+ [ -- No need to give 'freeRegs' when 'call'ing 'loopJump'
+ -- because they're passed when 'call'ing 'iter'.
+ -- This avoids to passing those registers around.
+ HM.singleton loopJump (\final -> (genAnalysis loop final){freeRegs = Set.empty})
+ , genAnalysisByLet loop
+ , genAnalysisByLet done
+ ]
+ , genAnalysis = \final ->
+ let loopAnalysis = genAnalysis loop final in
+ let doneAnalysis = genAnalysis done final in
GenAnalysis
- { minReads = minReads (genAnalysis done final ct)
+ { minReads = minReads doneAnalysis
, mayRaise =
- Map.delete ExceptionFailure
- (mayRaise (genAnalysis loop final ct)) <>
- mayRaise (genAnalysis done final ct)
+ Map.delete ExceptionFailure (mayRaise loopAnalysis) <>
+ mayRaise doneAnalysis
+ , alwaysRaise =
+ Set.delete ExceptionFailure (alwaysRaise loopAnalysis) <>
+ alwaysRaise doneAnalysis
+ , freeRegs = freeRegs loopAnalysis <> freeRegs doneAnalysis
}
, unGen = \ctx -> TH.unsafeCodeCoerce [|
let _ = "iter" in
let
- {-
- Exception ->
- {-failInp-}Cursor inp ->
- {-farInp-}Cursor inp ->
- {-farExp-}(Set SomeFailure) ->
- ST st (Either (ParsingError inp) a)
- -}
- catchHandler loopInput !_exn !failInp !farInp !farExp =
- $(TH.unTypeCode $ {-trace ("unGen.catch.ko: "<>show exn) $-} unGen done ctx
- -- Push 'input' and 'checkedHorizon'
- -- as they were when entering 'catch',
- -- they will be available to 'loadInput', if any.
- { valueStack = ValueStackCons (splice (TH.unsafeCodeCoerce [|loopInput|])) (valueStack ctx)
- , horizonStack = checkedHorizon ctx : horizonStack ctx
- -- Note that 'catchStackByLabel' is reset.
- -- Move the input to the failing position.
- , input = TH.unsafeCodeCoerce [|failInp|]
- -- The 'checkedHorizon' at the 'raise's are not known here.
- -- Nor whether 'failInp' is after 'checkedHorizon' or not.
- -- Hence fallback to a safe value.
- , checkedHorizon = 0
- -- Set the farthestInput to the farthest computed in 'fail'.
- , farthestInput = TH.unsafeCodeCoerce [|farInp|]
- , farthestExpecting = TH.unsafeCodeCoerce [|farExp|]
- })
- $(return $ TH.VarP jumpName) = \_callReturn callInput callCatchStackByLabel ->
+ onException loopInput = $(TH.unTypeCode $ onExceptionCode
+ (TH.unsafeCodeCoerce [|loopInput|]) 0 done ctx)
+ $(return $ TH.VarP loopJump) = \_callerOnReturn callerInput callerOnExceptionStackByLabel ->
$(TH.unTypeCode $ unGen loop ctx
{ valueStack = ValueStackEmpty
- , catchStackByLabel =
- {-
- Map.mapWithKey
- (\lbl () -> NE.singleton $ TH.unsafeCodeCoerce [|
- Map.findWithDefault $(TH.unTypeCode $ defaultCatch ctx) lbl koByLabel
- |])
- (mayRaise (finalGenAnalysisByLet ctx HM.! jumpName))
- -}
- Map.insertWith (<>) ExceptionFailure
- (NE.singleton $ TH.unsafeCodeCoerce [|catchHandler callInput|])
- (catchStackByLabel ctx)
- , input = TH.unsafeCodeCoerce [|callInput|]
+ , onExceptionStackByLabel =
+ Map.insertWith (<>) ExceptionFailure
+ (NE.singleton $ TH.unsafeCodeCoerce [|onException callerInput|])
+ (onExceptionStackByLabel ctx)
+ , input = TH.unsafeCodeCoerce [|callerInput|]
-- FIXME: promote to compile time error?
- , returnCall = TH.unsafeCodeCoerce [|error "invalid return"|]
+ , onReturn = TH.unsafeCodeCoerce [|error "invalid onReturn"|]
, checkedHorizon = 0
})
- in $(TH.unTypeCode $ unGen (jump (LetName jumpName)) ctx{valueStack=ValueStackEmpty})
+ in $(TH.unTypeCode $ unGen (jump True (LetName loopJump)) ctx{valueStack=ValueStackEmpty})
|]
}
instance InstrRegisterable Gen where
newRegister (UnscopedRegister r) k = k
- { unGen = \ctx ->
+ { genAnalysis = \final ->
+ let analysis = genAnalysis k final in
+ analysis{freeRegs = Set.delete r $ freeRegs analysis}
+ , unGen = \ctx ->
let ValueStackCons v vs = valueStack ctx in
TH.unsafeCodeCoerce [|
do
|]
}
readRegister (UnscopedRegister r) k = k
- { unGen = \ctx -> [|| do
+ { genAnalysis = \final ->
+ let analysis = genAnalysis k final in
+ analysis{freeRegs = Set.insert r $ freeRegs analysis}
+ , unGen = \ctx -> [|| do
sr <- ST.readSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r)))
$$(unGen k ctx{valueStack=ValueStackCons (splice [||sr||]) (valueStack ctx)})
||]
}
writeRegister (UnscopedRegister r) k = k
- { unGen = \ctx ->
+ { genAnalysis = \final ->
+ let analysis = genAnalysis k final in
+ analysis{freeRegs = Set.insert r $ freeRegs analysis}
+ , unGen = \ctx ->
let ValueStackCons v vs = valueStack ctx in
[|| do
let dupv = $$(genCode v)
{-ok-}Gen inp vs a ->
Gen inp vs a
checkHorizon ok = ok
- { genAnalysis = \final ct -> seqGenAnalysis $
- GenAnalysis { minReads = Right 1
+ { genAnalysis = \final -> seqGenAnalysis $
+ GenAnalysis { minReads = 0
, mayRaise = Map.singleton ExceptionFailure ()
+ , alwaysRaise = Set.empty
+ , freeRegs = Set.empty
} :|
- [ genAnalysis ok final ct ]
+ [ genAnalysis ok final ]
, unGen = \ctx0@GenCtx{} ->
- {-trace "unGen.checkHorizon" $-}
- let raiseFail = raiseException ctx0 ExceptionFailure in
- [||
- -- Factorize generated code for raising the "fail".
- let readFail = $$(raiseFail) in
- $$(
- let ctx = ctx0{catchStackByLabel =
- Map.adjust (\(_r:|rs) -> [||readFail||] :| rs)
- ExceptionFailure (catchStackByLabel ctx0)} in
- if checkedHorizon ctx >= 1
- then unGen ok ctx0{checkedHorizon = checkedHorizon ctx - 1}
- else let minHoriz =
- either (\_err -> 0) id $
- minReads $ finalGenAnalysis ctx ok in
- [||
- if $$(moreInput ctx)
- $$(if minHoriz > 0
- then [||$$shiftRight minHoriz $$(input ctx)||]
- else input ctx)
- then $$(unGen ok ctx{checkedHorizon = minHoriz})
- else let _ = "checkHorizon.else" in
- -- TODO: return a resuming continuation (eg. Partial)
- $$(unGen (fail (Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) (minHoriz + 1))) ctx)
- ||]
- )
- ||]
+ if checkedHorizon ctx0 >= 1
+ then
+ [||
+ let _ = $$(liftTypedString $ "checkHorizon.oldCheck: checkedHorizon="<>show (checkedHorizon ctx0)) in
+ $$(unGen ok ctx0{checkedHorizon = checkedHorizon ctx0 - 1})
+ ||]
+ else
+ let minHoriz = minReads $ genAnalysis ok $ analysisByLet ctx0 in
+ if minHoriz == 0
+ then
+ [||
+ let _ = "checkHorizon.noCheck" in
+ $$(unGen ok ctx0)
+ ||]
+ else
+ [||
+ let inp = $$(input ctx0) in
+ --let partialCont inp =
+ -- Factorize generated code for raising the "fail".
+ let readFail = $$(raiseException ctx0{input=[||inp||]} ExceptionFailure) in
+ $$(
+ let ctx = ctx0
+ { onExceptionStackByLabel =
+ Map.adjust (\(_r:|rs) -> [||readFail||] :| rs)
+ ExceptionFailure (onExceptionStackByLabel ctx0)
+ , input = [||inp||]
+ } in
+ [||
+ let _ = $$(liftTypedString $ "checkHorizon.newCheck: checkedHorizon="<>show (checkedHorizon ctx)<>" minHoriz="<>show minHoriz) in
+ if $$(moreInput ctx)
+ $$(if minHoriz > 1
+ then [||$$shiftRight $$(TH.liftTyped (minHoriz - 1)) inp||]
+ else [||inp||])
+ then $$(unGen ok ctx{checkedHorizon = minHoriz})
+ else
+ let _ = $$(liftTypedString $ "checkHorizon.newCheck.fail") in
+ -- TODO: return a resuming continuation (like attoparsec's Partial)
+ -- This could be done with a Buffer for efficient backtracking:
+ -- http://www.serpentine.com/blog/2014/05/31/attoparsec/
+ $$(unGen (fail (Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) minHoriz)) ctx)
+ ||]
+ )
+ --in partialCont $$(input ctx0)
+ ||]
}
-- | @('raiseFailure' ctx fs)@ raises 'ExceptionFailure'
{-failInp-}$$(input ctx) farInp farExp
||]
-- | @('raiseException' ctx exn)@ raises exception @(exn)@
--- using any entry in 'catchStackByLabel', or 'defaultCatch' if none.
+-- using any entry in 'onExceptionStackByLabel', or 'defaultCatch' if none.
raiseException ::
GenCtx st inp vs a -> Exception ->
CodeQ (Exception -> Cursor inp -> Cursor inp -> Set SomeFailure -> ST st (Either (ParsingError inp) a))
raiseException ctx exn =
NE.head $ Map.findWithDefault
(NE.singleton (defaultCatch ctx))
- exn (catchStackByLabel ctx)
-
-finalGenAnalysis :: GenCtx st inp vs a -> Gen inp cs a -> GenAnalysis
-finalGenAnalysis ctx k =
- --(\f -> f (error "callTrace")) $
- (\f -> f (analysisCallStack ctx)) $
- genAnalysis k $
- ((\f _ct -> f) <$>) $
- finalGenAnalysisByLet ctx
+ exn (onExceptionStackByLabel ctx)
checkToken ::
Set SomeFailure ->
{-ok-}Gen inp (InputToken inp ': vs) a ->
Gen inp vs a
checkToken fs p ok = ok
- { unGen = \ctx -> {-trace "unGen.read" $-} [||
+ { genAnalysis = \final -> seqGenAnalysis $
+ GenAnalysis { minReads = 1
+ , mayRaise = Map.singleton ExceptionFailure ()
+ , alwaysRaise = Set.empty
+ , freeRegs = Set.empty
+ } :|
+ [ genAnalysis ok final ]
+ , unGen = \ctx -> {-trace "unGen.read" $-} [||
+ let _ = "checkToken" in
let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
$$(genCode $
Prod.ifThenElse
, input = [||cs||]
})
(splice [||
- let _ = "checkToken.else" in
+ let _ = "checkToken.fail" in
$$(unGen (fail fs) ctx)
||])
)||]
sourcephile / git / haskell / symantic-parser.git / blobdiff