{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DeriveAnyClass #-} -- For NFData instances
+{-# LANGUAGE DeriveGeneric #-} -- For NFData instances
{-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp)
+{-# LANGUAGE ConstraintKinds #-} -- For Dict
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UnboxedTuples #-} -- For nextInput
{-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp)
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Machine.Generate where
+import Control.DeepSeq (NFData(..))
import Control.Monad (Monad(..))
import Data.Bool (Bool)
import Data.Char (Char)
import Data.Either (Either(..), either)
+import Data.Foldable (foldMap', toList, null)
import Data.Function (($), (.), id, const, on)
import Data.Functor (Functor, (<$>), (<$))
-import Data.Foldable (foldMap')
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map (Map)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..), Ordering(..))
+import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Data.String (String)
import Data.Traversable (Traversable(..))
-import Data.Tuple (fst)
-import GHC.TypeLits (symbolVal)
+import Data.Typeable (Typeable)
+import Data.Word (Word8)
+import GHC.Generics (Generic)
+import GHC.Show (showCommaSpace)
import Language.Haskell.TH (CodeQ)
import Prelude ((+), (-), error)
-import Text.Show (Show(..))
--- import qualified Control.Monad.Trans.State.Strict as MT
+import Text.Show (Show(..), showParen, showString)
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
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 Data.Set.Internal as Set_
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-import Symantic.Univariant.Letable
-import Symantic.Univariant.Trans
-import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
+import Symantic.Typed.Derive
+import Symantic.Typed.ObserveSharing
+import Symantic.Parser.Grammar.Combinators (Exception(..), Failure(..), SomeFailure(..), inputTokenProxy)
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
-import qualified Symantic.Parser.Haskell as H
+import qualified Language.Haskell.TH.HideName as TH
+import qualified Symantic.Typed.Lang as Prod
+import qualified Symantic.Typed.Optimize as Prod
--import Debug.Trace
-trace = const id
-genCode :: TermInstr a -> CodeQ a
-genCode = trans
+-- | Convenient utility to generate some final 'TH.CodeQ'.
+genCode :: Splice a -> CodeQ a
+genCode = derive . Prod.normalOrderReduction
-- * Type 'Gen'
-- | Generate the 'CodeQ' parsing the input.
-- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
-- parsing the given 'input' according to the given 'Machine'.
generateCode ::
- Ord (InputToken inp) =>
+ {-
+ Eq (InputToken inp) =>
+ NFData (InputToken inp) =>
Show (InputToken inp) =>
+ Typeable (InputToken inp) =>
TH.Lift (InputToken inp) =>
+ -}
-- InputToken inp ~ Char =>
- Input inp =>
+ Inputable inp =>
Show (Cursor inp) =>
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 finalRet = \_farInp _farExp v _inp -> Right v in
- let finalRaise :: forall b. (Catcher inp b)
- = \_failInp !farInp !farExp ->
- Left ParsingErrorStandard
- { parsingErrorOffset = offset farInp
- , parsingErrorUnexpected =
- if readMore farInp
- then Just (let (# c, _ #) = readNext farInp in c)
- else Nothing
- , parsingErrorExpecting = Set.fromList farExp
- } in
- $$(unGen k GenCtx
- { valueStack = ValueStackEmpty
- , catchStackByLabel = Map.empty
- , defaultCatch = [||finalRaise||]
- , callStack = []
- , retCode = [||finalRet||]
- , input = [||init||]
- , nextInput = [||readNext||]
- , moreInput = [||readMore||]
- -- , farthestError = [||Nothing||]
- , farthestInput = [||init||]
- , farthestExpecting = [|| [] ||]
- , checkedHorizon = 0
- , horizonStack = []
- , finalGenAnalysisByLet = runGenAnalysis (genAnalysisByLet k)
- })
- ||]
+ -- Pattern bindings containing unlifted types
+ -- should use an outermost bang pattern.
+ let !(# init, readMore, readNext #) = $$(cursorOf [||input||])
+ finalRet = \_farInp _farExp v _inp -> Right v
+ finalRaise :: forall b. (Catcher inp b)
+ = \ !exn _failInp !farInp !farExp ->
+ Left ParsingError
+ { parsingErrorOffset = offset farInp
+ , parsingErrorException = exn
+ , parsingErrorUnexpected =
+ if readMore farInp
+ then Just (let (# c, _ #) = readNext farInp in c)
+ else Nothing
+ , parsingErrorExpecting = farExp
+ }
+ in
+ $$(
+ let defInputTokenProxy exprCode =
+ TH.unsafeCodeCoerce $ do
+ value <- TH.unTypeQ $ TH.examineCode [||Proxy :: Proxy (InputToken inp)||]
+ expr <- TH.unTypeQ (TH.examineCode exprCode)
+ return $ TH.LetE [
+ TH.FunD inputTokenProxy [TH.Clause [] (TH.NormalB value) []]
+ ] expr
+ in defInputTokenProxy $
+ unGen k GenCtx
+ { valueStack = ValueStackEmpty
+ , catchStackByLabel = Map.empty
+ , defaultCatch = [||finalRaise||]
+ , callStack = []
+ , retCode = [||finalRet||]
+ , input = [||init||]
+ , nextInput = [||readNext||]
+ , moreInput = [||readMore||]
+ -- , farthestError = [||Nothing||]
+ , farthestInput = [||init||]
+ , farthestExpecting = [||Set.empty||]
+ , checkedHorizon = 0
+ , horizonStack = []
+ , finalGenAnalysisByLet = runGenAnalysis (genAnalysisByLet k)
+ }
+ )
+ ||]
-- ** Type 'ParsingError'
data ParsingError inp
- = ParsingErrorStandard
+ = ParsingError
{ 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'.
+ , parsingErrorException :: Exception
+ -- | Note: if a 'FailureHorizon' greater than 1
+ -- is amongst the 'parsingErrorExpecting'
+ -- then 'parsingErrorUnexpected' is only the 'InputToken'
+ -- at the begining of the expected 'Horizon'.
, parsingErrorUnexpected :: Maybe (InputToken inp)
- , parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
- }
-deriving instance Show (InputToken inp) => Show (ParsingError inp)
+ , parsingErrorExpecting :: Set SomeFailure
+ } deriving (Generic)
+deriving instance NFData (InputToken inp) => NFData (ParsingError inp)
+--deriving instance Show (InputToken inp) => Show (ParsingError inp)
+instance Show (InputToken inp) => Show (ParsingError inp) where
+ showsPrec p ParsingError{..} =
+ showParen (p >= 11) $
+ showString "ParsingErrorStandard {" .
+ showString "parsingErrorOffset = " .
+ showsPrec 0 parsingErrorOffset .
+ showCommaSpace .
+ showString "parsingErrorException = " .
+ showsPrec 0 parsingErrorException .
+ showCommaSpace .
+ showString "parsingErrorUnexpected = " .
+ showsPrec 0 parsingErrorUnexpected .
+ showCommaSpace .
+ showString "parsingErrorExpecting = fromList " .
+ showsPrec 0 (
+ -- Sort on the string representation
+ -- because the 'Ord' of the 'SomeFailure'
+ -- is based upon hashes ('typeRepFingerprint')
+ -- depending on packages' ABI and whether
+ -- cabal-install's setup is --inplace or not,
+ -- and that would be too unstable for golden tests.
+ List.sortBy (compare `on` show) $
+ Set.toList parsingErrorExpecting
+ ) .
+ showString "}"
-- ** Type 'ErrorLabel'
type ErrorLabel = String
-- * Type 'GenAnalysis'
data GenAnalysis = GenAnalysis
- { minReads :: Either ErrorLabel Horizon
- , mayRaise :: Map ErrorLabel ()
+ { minReads :: Either Exception Horizon
+ , mayRaise :: Map Exception ()
} deriving (Show)
-- | Tie the knot between mutually recursive 'TH.Name's
runGenAnalysis ga = (($ []) <$>) $ polyfix ga
-- | Poly-variadic fixpoint combinator.
--- Used to express mutual recursion and to transparently introduce memoization.
--- Used to "tie the knot" between observed sharing ('defLet', 'call', 'jump')
--- and join points ('defJoin', 'refJoin').
--- All mutually dependent functions are restricted to the same polymorphic type @(a)@.
+-- Used to express mutual recursion and to transparently introduce memoization,
+-- more precisely to "tie the knot"
+-- between observed sharing ('defLet', 'call', 'jump')
+-- and also between join points ('defJoin', 'refJoin').
+-- Because it's enough for its usage here,
+-- all mutually dependent functions are restricted to the same polymorphic type @(a)@.
-- See http://okmij.org/ftp/Computation/fixed-point-combinators.html#Poly-variadic
polyfix :: Functor f => f (f a -> a) -> f a
polyfix fs = fix $ \finals -> ($ finals) <$> fs
-- | Minimal input length required for a successful parsing.
type Horizon = Offset
--- seqGenAnalysis =
-- 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 ->
) (minReads a) as
, mayRaise = sconcat (mayRaise <$> aas)
}
+-- | Merge given 'GenAnalysis' as alternatives.
altGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
altGenAnalysis aas@(a:|as) = GenAnalysis
{ minReads = List.foldl' (\acc x ->
}
--- ** Type 'Cont'
-type Cont inp v a =
- {-farthestInput-}Cursor inp ->
- {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
- v ->
- Cursor inp ->
- Either (ParsingError inp) a
-
{-
-- *** Type 'FarthestError'
data FarthestError inp = FarthestError
{ farthestInput :: Cursor inp
- , farthestExpecting :: [ErrorItem (InputToken inp)]
+ , farthestExpecting :: [Failure (InputToken inp)]
}
-}
-- | 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)
+ ( Cursorable (Cursor inp)
+ {-
+ , TH.Lift (InputToken inp)
, Show (InputToken inp)
+ , Eq (InputToken inp)
+ , Typeable (InputToken inp)
+ , NFData (InputToken inp)
+ -}
) => GenCtx
{ valueStack :: ValueStack vs
- , catchStackByLabel :: Map ErrorLabel (NonEmpty (CodeQ (Catcher inp a)))
+ , catchStackByLabel :: Map Exception (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)
, moreInput :: CodeQ (Cursor inp -> Bool)
, nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
, farthestInput :: CodeQ (Cursor inp)
- , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
+ , farthestExpecting :: CodeQ (Set SomeFailure)
-- | Remaining horizon already checked.
-- Use to factorize 'input' length checks,
-- instead of checking the 'input' length
data ValueStack vs where
ValueStackEmpty :: ValueStack '[]
ValueStackCons ::
- { valueStackHead :: TermInstr v
+ { valueStackHead :: Splice v
, valueStackTail :: ValueStack vs
} -> ValueStack (v ': vs)
instance InstrValuable Gen where
pushValue x k = k
- { unGen = \ctx -> trace "unGen.pushValue" $ unGen k ctx
+ { unGen = \ctx -> {-trace "unGen.pushValue" $-} unGen k ctx
{ valueStack = ValueStackCons x (valueStack ctx) }
}
popValue k = k
- { unGen = \ctx -> trace "unGen.popValue" $ unGen k ctx
+ { unGen = \ctx -> {-trace "unGen.popValue" $-} unGen k ctx
{ valueStack = valueStackTail (valueStack ctx) }
}
lift2Value f k = k
- { unGen = \ctx -> trace "unGen.lift2Value" $ unGen k ctx
+ { unGen = \ctx -> {-trace "unGen.lift2Value" $-} unGen k ctx
{ valueStack =
let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
- ValueStackCons (f H.:@ x H.:@ y) vs
+ ValueStackCons (f Prod..@ x Prod..@ y) vs
}
}
swapValue k = k
- { unGen = \ctx -> trace "unGen.swapValue" $ unGen k ctx
+ { unGen = \ctx -> {-trace "unGen.swapValue" $-} unGen k ctx
{ valueStack =
let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
ValueStackCons x (ValueStackCons y vs)
caseBranch kx ky = Gen
{ genAnalysisByLet = genAnalysisByLet kx <> genAnalysisByLet ky
, genAnalysis = \final ct -> altGenAnalysis $ genAnalysis kx final ct :| [genAnalysis ky final ct]
- , unGen = \ctx -> trace "unGen.caseBranch" $
+ , unGen = \ctx -> {-trace "unGen.caseBranch" $-}
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 })
+ Left x -> $$(unGen kx ctx{ valueStack = ValueStackCons (splice [||x||]) vs })
+ Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (splice [||y||]) vs })
||]
}
choicesBranch fs ks kd = Gen
{ genAnalysisByLet = sconcat $ genAnalysisByLet kd :| (genAnalysisByLet <$> ks)
, genAnalysis = \final ct -> altGenAnalysis $ (\k -> genAnalysis k final ct) <$> (kd:|ks)
- , unGen = \ctx -> trace "unGen.choicesBranch" $
+ , unGen = \ctx -> {-trace "unGen.choicesBranch" $-}
let ValueStackCons v vs = valueStack ctx in
go ctx{valueStack = vs} v fs ks
}
where
go ctx x (f:fs') (k:ks') = [||
- if $$(genCode (H.optimizeTerm (f H.:@ x)))
+ if $$(genCode (f Prod..@ x))
then
let _ = "choicesBranch.then" in
- $$(trace "unGen.choicesBranch.k" $ unGen k ctx)
+ $$({-trace "unGen.choicesBranch.k" $-} unGen k ctx)
else
let _ = "choicesBranch.else" in
$$(go ctx x fs' ks')
||]
go ctx _ _ _ = unGen kd ctx
instance InstrExceptionable Gen where
- raiseException lbl failExp = Gen
+ raise exn = Gen
{ genAnalysisByLet = HM.empty
, genAnalysis = \_final _ct -> GenAnalysis
- { minReads = Left (symbolVal lbl)
- , mayRaise = Map.singleton (symbolVal lbl) ()
+ { minReads = Left (ExceptionLabel exn)
+ , mayRaise = Map.singleton (ExceptionLabel exn) ()
}
- , unGen = \ctx@GenCtx{} -> trace ("unGen.raiseException: "<>symbolVal lbl) $ [||
- 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
- $$(NE.head $ Map.findWithDefault
- (NE.singleton (defaultCatch ctx))
- (symbolVal lbl)
- (catchStackByLabel ctx))
- $$(input ctx) farInp farExp
+ , unGen = \ctx@GenCtx{} -> {-trace ("unGen.raise: "<>show exn) $-} [||
+ $$(raiseException ctx (ExceptionLabel exn))
+ (ExceptionLabel $$(TH.liftTyped exn))
+ {-failInp-}$$(input ctx)
+ {-farInp-}$$(input ctx)
+ $$(farthestExpecting ctx)
||]
}
- popException lbl k = k
- { unGen = \ctx -> trace ("unGen.popException: "<>symbolVal lbl) $
- unGen k ctx{catchStackByLabel = Map.update (\case
- _r0:|(r1:rs) -> Just (r1:|rs)
- _ -> Nothing
- ) (symbolVal lbl) (catchStackByLabel ctx)
+ fail fs = Gen
+ { genAnalysisByLet = HM.empty
+ , genAnalysis = \_final _ct -> GenAnalysis
+ { minReads = Left ExceptionFailure
+ , mayRaise = Map.singleton ExceptionFailure ()
+ }
+ , unGen = \ctx@GenCtx{} -> {-trace ("unGen.fail: "<>show exn) $-}
+ if null fs
+ then [|| -- Raise without updating the farthest error.
+ $$(raiseException ctx ExceptionFailure)
+ ExceptionFailure
+ {-failInp-}$$(input ctx)
+ $$(farthestInput ctx)
+ $$(farthestExpecting ctx)
+ ||]
+ else raiseFailure ctx [||fs||]
+ }
+ commit exn k = k
+ { unGen = \ctx -> {-trace ("unGen.commit: "<>show exn) $-}
+ unGen k ctx{catchStackByLabel =
+ Map.update (\case
+ _r0:|(r1:rs) -> Just (r1:|rs)
+ _ -> Nothing
+ )
+ exn (catchStackByLabel ctx)
}
}
- catchException lbl ok ko = Gen
+ catch exn ok ko = Gen
{ genAnalysisByLet = genAnalysisByLet ok <> genAnalysisByLet ko
, genAnalysis = \final ct ->
- let ga = altGenAnalysis $ genAnalysis ok final ct :| [ genAnalysis ko final ct ] in
- ga { mayRaise = Map.delete (symbolVal lbl) (mayRaise ga) }
- , unGen = \ctx@GenCtx{} -> trace ("unGen.catchException: "<>symbolVal lbl) $ [||
- let _ = $$(liftTypedString ("catchException lbl="<>symbolVal lbl)) in
- let catchHandler !failInp !farInp !farExp =
- let _ = $$(liftTypedString ("catchException.ko lbl="<>symbolVal lbl)) in
- $$(trace ("unGen.catchException.ko: "<>symbolVal lbl) $ unGen ko ctx
+ let okGA = genAnalysis ok final ct in
+ altGenAnalysis $
+ okGA{ mayRaise = Map.delete exn (mayRaise okGA) } :|
+ [ genAnalysis ko final ct ]
+ , 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 'catchException'.
+ -- as they were when entering 'catch',
+ -- they will be available to 'loadInput', if any.
{ valueStack =
- ValueStackCons (H.Term (input ctx)) $
+ 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 'raiseException's
- -- are not known here.
- -- Nor whether 'failInp' is after
- -- 'checkedHorizon' 'ctx' or not.
+ -- 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 by 'fail'
+ -- Set the farthestInput to the farthest computed in 'fail'.
, farthestInput = [||farInp||]
, farthestExpecting = [||farExp||]
})
in
- $$(trace ("unGen.catchException.ok: "<>symbolVal lbl) $ unGen ok ctx
- { catchStackByLabel = Map.insertWith (<>) (symbolVal lbl)
- (NE.singleton [||catchHandler||]) (catchStackByLabel ctx)
+ $$({-trace ("unGen.catch.ok: "<>show es) $-} unGen ok ctx
+ { catchStackByLabel =
+ Map.insertWith (<>) exn
+ (NE.singleton [||catchHandler||])
+ (catchStackByLabel ctx)
}
) ||]
}
-
--- ** Type 'Catcher'
-type Catcher inp a =
- {-failureInput-}Cursor inp ->
- {-farthestInput-}Cursor inp ->
- {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
- Either (ParsingError inp) a
instance InstrInputable Gen where
pushInput k = k
{ unGen = \ctx ->
- trace "unGen.pushInput" $
+ {-trace "unGen.pushInput" $-}
unGen k ctx
- { valueStack = H.Term (input ctx) `ValueStackCons` valueStack ctx
+ { valueStack = splice (input ctx) `ValueStackCons` valueStack ctx
, horizonStack = checkedHorizon ctx : horizonStack ctx
}
}
loadInput k = k
{ unGen = \ctx ->
- trace "unGen.loadInput" $
+ {-trace "unGen.loadInput" $-}
let ValueStackCons input vs = valueStack ctx in
let (h, hs) = case horizonStack ctx of
[] -> (0, [])
instance InstrCallable Gen where
defLet defs k = k
{ unGen = \ctx@GenCtx{} ->
- trace ("unGen.defLet: defs="<>show (HM.keys defs)) $
+ {-trace ("unGen.defLet: defs="<>show (HM.keys defs)) $-}
TH.unsafeCodeCoerce $ do
- decls <- traverse (makeDecl ctx) $
- List.sortBy (compare `on` fst) $
- HM.toList defs
- body <- TH.unTypeQ (TH.examineCode (trace "unGen.defLet.body" $ unGen k ctx))
- return (TH.LetE decls body)
+ decls <- traverse (makeDecl ctx) (HM.toList defs)
+ body <- TH.unTypeQ $ TH.examineCode $
+ {-trace "unGen.defLet.body" $-}
+ unGen k ctx
+ return $ TH.LetE (
+ -- | Try to output more deterministic code to be able to golden test it,
+ -- at the cost of more computations (at compile-time only though).
+ List.sortBy (compare `on` TH.hideName) $
+ toList decls
+ ) body
, genAnalysisByLet =
foldMap' (\(SomeLet sub) -> genAnalysisByLet sub) defs <>
((\(SomeLet sub) -> genAnalysis sub) <$> defs) <>
\ !ok{-from generateSuspend or retCode-}
!inp
!koByLabel{- 'catchStackByLabel' from the 'call'-site -} ->
- $$(trace ("unGen.defLet.sub: "<>show n) $ unGen sub ctx
+ $$({-trace ("unGen.defLet.sub: "<>show n) $-} unGen sub ctx
{ valueStack = ValueStackEmpty
-- Build a 'catchStackByLabel' from the one available at the 'call'-site.
-- Note that all the 'mayRaise' 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||])
- (trace ("mayRaise: "<>show n) $
+ ({-trace ("mayRaise: "<>show n) $-}
mayRaise (finalGenAnalysisByLet ctx HM.! n))
, input = [||inp||]
- , retCode = trace ("unGen.defLet.sub.retCode: "<>show n) [||ok||]
+ , retCode = {-trace ("unGen.defLet.sub.retCode: "<>show n) $-} [||ok||]
-- These are passed by the caller via 'ok' or 'ko'
-- , farthestInput =
, mayRaise = Map.empty
}
else (final HM.! n) (n:ct)
- , unGen = \ctx -> trace ("unGen.jump: "<>show n) $ [||
+ , unGen = \ctx -> {-trace ("unGen.jump: "<>show n) $-} [||
let _ = "jump" in
$$(TH.unsafeCodeCoerce (return (TH.VarE n)))
{-ok-}$$(retCode ctx)
else seqGenAnalysis $
(final HM.! n) (n:ct) :|
[ genAnalysis k final ct ]
- , unGen = trace ("unGen.call: "<>show n) $ \ctx ->
+ , unGen = {-trace ("unGen.call: "<>show n) $-} \ctx ->
-- let ks = (Map.keys (catchStackByLabel ctx)) in
[||
-- let _ = $$(liftTypedString $ "call exceptByLet("<>show n<>")="<>show (Map.keys (Map.findWithDefault Map.empty n (exceptByLet ctx))) <> " catchStackByLabel(ctx)="<> show ks) in
{ minReads = Right 0
, mayRaise = Map.empty
}
- , unGen = \ctx -> trace "unGen.ret" $ unGen (trace "unGen.ret.generateResume" $ generateResume (trace "unGen.ret.retCode" $ retCode ctx)) ctx
+ , unGen = \ctx -> {-trace "unGen.ret" $-} unGen ({-trace "unGen.ret.generateResume" $-} generateResume ({-trace "unGen.ret.retCode" $-} retCode ctx)) ctx
}
-- | Like 'TH.liftString' but on 'TH.Code'.
liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) =
[|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||]
+instance TH.Lift a => TH.Lift (Set a) where
+ 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 'Cont'
+type Cont inp v a =
+ {-farthestInput-}Cursor inp ->
+ {-farthestExpecting-}(Set SomeFailure) ->
+ v ->
+ Cursor inp ->
+ Either (ParsingError inp) a
+
-- | 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 ctx = [||
let _ = $$(liftTypedString $ "suspend") in
\farInp farExp v !inp ->
- $$(trace "unGen.generateSuspend" $ unGen k ctx
- { valueStack = ValueStackCons (trace "unGen.generateSuspend.value" $ H.Term [||v||]) (valueStack ctx)
+ $$({-trace "unGen.generateSuspend" $-} unGen k ctx
+ { valueStack = ValueStackCons ({-trace "unGen.generateSuspend.value" $-} splice [||v||]) (valueStack ctx)
, input = [||inp||]
, farthestInput = [||farInp||]
, farthestExpecting = [||farExp||]
{ minReads = Right 0
, mayRaise = Map.empty
}
- , unGen = \ctx -> trace "unGen.generateResume" $ [||
+ , unGen = \ctx -> {-trace "unGen.generateResume" $-} [||
let _ = "resume" in
$$k
$$(farthestInput ctx)
$$(farthestExpecting ctx)
- (let _ = "resume.genCode" in $$(trace "unGen.generateResume.genCode" $ genCode $ H.optimizeTerm $
- valueStackHead $ valueStack ctx))
+ (let _ = "resume.genCode" in $$({-trace "unGen.generateResume.genCode" $-}
+ genCode $ valueStackHead $ valueStack ctx))
$$(input ctx)
||]
}
+-- ** Type 'Catcher'
+type Catcher inp a =
+ Exception ->
+ {-failInp-}Cursor inp ->
+ {-farInp-}Cursor inp ->
+ {-farExp-}(Set SomeFailure) ->
+ Either (ParsingError inp) a
+
instance InstrJoinable Gen where
defJoin (LetName n) sub k = k
{ unGen =
\ctx ->
- trace ("unGen.defJoin: "<>show n) $
+ {-trace ("unGen.defJoin: "<>show n) $-}
TH.unsafeCodeCoerce $ do
next <- TH.unTypeQ $ TH.examineCode $ [||
-- Called by 'generateResume'.
\farInp farExp v !inp ->
- $$(trace ("unGen.defJoin.next: "<>show n) $ unGen sub ctx
- { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
+ $$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
+ { valueStack = ValueStackCons (splice [||v||]) (valueStack ctx)
, input = [||inp||]
, farthestInput = [||farInp||]
, farthestExpecting = [||farExp||]
})
||]
let decl = TH.FunD n [TH.Clause [] (TH.NormalB next) []]
- expr <- TH.unTypeQ (TH.examineCode (trace ("unGen.defJoin.expr: "<>show n) $ unGen k ctx))
+ expr <- TH.unTypeQ (TH.examineCode ({-trace ("unGen.defJoin.expr: "<>show n) $-} unGen k ctx))
return (TH.LetE [decl] expr)
, genAnalysisByLet =
(genAnalysisByLet sub <>) $
}
refJoin (LetName n) = Gen
{ unGen = \ctx ->
- trace ("unGen.refJoin: "<>show n) $
+ {-trace ("unGen.refJoin: "<>show n) $-}
unGen (generateResume
(TH.unsafeCodeCoerce (return (TH.VarE n)))) ctx
, genAnalysisByLet = HM.empty
n final (n:ct)
}
instance InstrReadable Char Gen where
- read farExp p = checkHorizon . checkToken farExp p
+ read fs p = checkHorizon . checkToken fs p
+instance InstrReadable Word8 Gen where
+ read fs p = checkHorizon . checkToken fs p
checkHorizon ::
+ forall inp vs a.
+ -- Those constraints are not used anyway
+ -- because (TH.Lift SomeFailure) uses 'inputTokenProxy'.
+ Ord (InputToken inp) =>
+ Show (InputToken inp) =>
TH.Lift (InputToken inp) =>
+ NFData (InputToken inp) =>
+ Typeable (InputToken inp) =>
{-ok-}Gen inp vs a ->
Gen inp vs a
checkHorizon ok = ok
{ genAnalysis = \final ct -> seqGenAnalysis $
GenAnalysis { minReads = Right 1
- , mayRaise = Map.singleton "fail" ()
+ , mayRaise = Map.singleton ExceptionFailure ()
} :|
[ genAnalysis ok final ct ]
, unGen = \ctx0@GenCtx{} ->
- trace "unGen.checkHorizon" $
- let raiseFail =
- NE.head (Map.findWithDefault
- (NE.singleton (defaultCatch ctx0))
- "fail" (catchStackByLabel ctx0)) in
+ {-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)
- "fail" (catchStackByLabel ctx0)} in
+ ExceptionFailure (catchStackByLabel ctx0)} in
if checkedHorizon ctx >= 1
then unGen ok ctx0{checkedHorizon = checkedHorizon ctx - 1}
else let minHoriz =
- either (\err -> 0) id $
+ either (\_err -> 0) id $
minReads $ finalGenAnalysis ctx ok in
[||
if $$(moreInput ctx)
then $$(unGen ok ctx{checkedHorizon = minHoriz})
else let _ = "checkHorizon.else" in
-- TODO: return a resuming continuation (eg. Partial)
- $$(unGen (fail [ErrorItemHorizon (minHoriz + 1)]) ctx)
+ $$(unGen (fail (Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) (minHoriz + 1))) ctx)
||]
)
||]
}
+-- | @('raiseFailure' ctx fs)@ raises 'ExceptionFailure'
+-- with farthest parameters set to or updated with @(fs)@
+-- according to the relative position of 'input' wrt. 'farthestInput'.
+raiseFailure ::
+ Cursorable (Cursor inp) =>
+ GenCtx inp cs a ->
+ TH.CodeQ (Set SomeFailure) ->
+ TH.CodeQ (Either (ParsingError inp) a)
+raiseFailure ctx fs = [||
+ let failExp = $$fs in
+ let (# farInp, farExp #) =
+ case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
+ LT -> (# $$(input ctx), failExp #)
+ EQ -> (# $$(farthestInput ctx), failExp <> $$(farthestExpecting ctx) #)
+ GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #)
+ in $$(raiseException ctx ExceptionFailure)
+ ExceptionFailure
+ {-failInp-}$$(input ctx) farInp farExp
+ ||]
+-- | @('raiseException' ctx exn)@ raises exception @(exn)@
+-- using any entry in 'catchStackByLabel', or 'defaultCatch' if none.
+raiseException ::
+ GenCtx inp vs a -> Exception ->
+ CodeQ (Exception -> Cursor inp -> Cursor inp -> Set SomeFailure -> Either (ParsingError inp) a)
+raiseException ctx exn =
+ NE.head $ Map.findWithDefault
+ (NE.singleton (defaultCatch ctx))
+ exn (catchStackByLabel ctx)
+
finalGenAnalysis :: GenCtx inp vs a -> Gen inp cs a -> GenAnalysis
finalGenAnalysis ctx k =
--(\f -> f (error "callTrace")) $
finalGenAnalysisByLet ctx
checkToken ::
- Ord (InputToken inp) =>
- TH.Lift (InputToken inp) =>
- [ErrorItem (InputToken inp)] ->
- {-predicate-}TermInstr (InputToken inp -> Bool) ->
+ Set SomeFailure ->
+ {-predicate-}Splice (InputToken inp -> Bool) ->
{-ok-}Gen inp (InputToken inp ': vs) a ->
Gen inp vs a
-checkToken farExp p ok = ok
- { unGen = \ctx -> trace "unGen.read" $ [||
+checkToken fs p ok = ok
+ { unGen = \ctx -> {-trace "unGen.read" $-} [||
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)
- ||]
+ $$(genCode $
+ Prod.ifThenElse
+ (p Prod..@ splice [||c||])
+ (splice $ unGen ok ctx
+ { valueStack = ValueStackCons (splice [||c||]) (valueStack ctx)
+ , input = [||cs||]
+ })
+ (splice [||
+ let _ = "checkToken.else" in
+ $$(unGen (fail fs) ctx)
+ ||])
+ )||]
}
sourcephile / git / haskell / symantic-parser.git / blobdiff