{-# 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(..))
-import Data.Function (($), (.))
-import Data.Functor ((<$>))
+import Data.Either (Either(..), either)
+import Data.Foldable (foldMap', toList, null)
+import Data.Function (($), (.), id, const, on)
+import Data.Functor (Functor, (<$>), (<$))
import Data.Int (Int)
-import Data.List (minimum)
+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 Language.Haskell.TH (CodeQ, Code(..))
-import Prelude (($!), (+), (-))
-import Text.Show (Show(..))
+import Data.String (String)
+import Data.Traversable (Traversable(..))
+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(..), 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 qualified Control.Monad.Trans.Writer as Writer
-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
-genCode :: TermInstr a -> CodeQ a
-genCode = trans
+--import Debug.Trace
+
+-- | 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.
-data Gen inp vs es a = Gen
- { minHorizon :: Map TH.Name Horizon -> Horizon
+data Gen inp vs a = Gen
+ { genAnalysisByLet :: LetMapFix (CallTrace -> GenAnalysis)
+ -- ^ 'genAnalysis' for each 'defLet' and 'defJoin' of the 'Machine'.
+ , genAnalysis :: LetMapTo (CallTrace -> GenAnalysis)
+ -- ^ Synthetized (bottom-up) static genAnalysis of the 'Machine'.
, unGen ::
- GenCtx inp vs es a ->
+ GenCtx inp vs a ->
CodeQ (Either (ParsingError inp) a)
}
+-- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
+-- parsing the given 'input' according to the given 'Machine'.
+generateCode ::
+ {-
+ Eq (InputToken inp) =>
+ NFData (InputToken inp) =>
+ Show (InputToken inp) =>
+ Typeable (InputToken inp) =>
+ TH.Lift (InputToken inp) =>
+ -}
+ -- InputToken inp ~ Char =>
+ 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||])
+ 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 Exception Horizon
+ , mayRaise :: Map Exception ()
+ } deriving (Show)
+
+-- | Tie the knot between mutually recursive 'TH.Name's
+-- introduced by 'defLet' and 'defJoin'.
+-- and provide the empty initial 'CallTrace' stack
+runGenAnalysis ::
+ LetMapFix (CallTrace -> GenAnalysis) ->
+ LetMap GenAnalysis
+runGenAnalysis ga = (($ []) <$>) $ polyfix ga
+
+-- | Poly-variadic fixpoint combinator.
+-- 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
+
+fix :: (a -> a) -> a
+fix f = final where final = f final
+
+type LetMap = HM.HashMap TH.Name
+type LetMapTo a = LetMap a -> a
+type LetMapFix a = LetMap (LetMap a -> a)
+
+-- | Call trace stack updated by 'call' and 'refJoin'.
+-- Used to avoid infinite loops when tying the knot with 'polyfix'.
+type CallTrace = [TH.Name]
-- ** 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'.
+-- | Minimal input length required for a successful parsing.
type Horizon = Offset
--- ** Type 'Cont'
-type Cont inp v a =
- {-farthestInput-}Cursor inp ->
- {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
- v ->
- 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
+-- 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
+ , mayRaise = sconcat (mayRaise <$> aas)
+ }
+-- | Merge given 'GenAnalysis' as alternatives.
+altGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
+altGenAnalysis aas@(a:|as) = GenAnalysis
+ { minReads = List.foldl' (\acc x ->
+ either
+ (\l -> either (const (Left l)) Right)
+ (\r -> either (const (Right r)) (Right . min r))
+ acc (minReads x)
+ ) (minReads a) as
+ , mayRaise = sconcat (mayRaise <$> aas)
+ }
--- ** 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
{ farthestInput :: Cursor inp
- , farthestExpecting :: [ErrorItem (InputToken inp)]
+ , farthestExpecting :: [Failure (InputToken inp)]
}
-}
--- | @('generate' input mach)@ generates @TemplateHaskell@ code
--- parsing given 'input' according to given 'mach'ine.
-generate ::
- forall inp ret.
- 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 = [||
- -- 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 finalFail _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
- , failStack = FailStackCons [||finalFail||] FailStackEmpty
- , retCode = [||finalRet||]
- , input = [||init||]
- , nextInput = [||readNext||]
- , moreInput = [||readMore||]
- -- , farthestError = [||Nothing||]
- , farthestInput = [||init||]
- , farthestExpecting = [|| [] ||]
- , horizon = 0
- , horizonByName = Map.empty
- })
- ||]
-
-- ** Type 'GenCtx'
--- | This is a context only present at compile-time.
-data GenCtx inp vs (es::Peano) a =
- ( TH.Lift (InputToken inp)
- , Cursorable (Cursor inp)
+-- | This is an inherited (top-down) context
+-- only present at compile-time, to build TemplateHaskell splices.
+data GenCtx inp vs a =
+ ( Cursorable (Cursor inp)
+ {-
+ , TH.Lift (InputToken inp)
, Show (InputToken inp)
- -- , InputToken inp ~ Char
+ , Eq (InputToken inp)
+ , Typeable (InputToken inp)
+ , NFData (InputToken inp)
+ -}
) => GenCtx
{ valueStack :: ValueStack vs
- , failStack :: FailStack inp es 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)
+ -- | Used by 'checkToken' to get 'GenAnalysis' from 'genAnalysis'.
+ , callStack :: [TH.Name]
, 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
+ , farthestExpecting :: CodeQ (Set SomeFailure)
+ -- | Remaining horizon already checked.
+ -- Use to factorize 'input' length checks,
+ -- instead of checking the 'input' length
+ -- one 'InputToken' at a time at each 'read'.
+ -- 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 'runGenAnalysis'.
+ , finalGenAnalysisByLet :: LetMap GenAnalysis
}
-- ** Type 'ValueStack'
data ValueStack vs where
ValueStackEmpty :: ValueStack '[]
ValueStackCons ::
- { valueStackHead :: TermInstr v
+ { valueStackHead :: Splice v
, valueStackTail :: ValueStack vs
} -> ValueStack (v ': vs)
--- ** Type 'FailStack'
-data FailStack inp es a where
- FailStackEmpty :: FailStack inp 'Zero a
- FailStackCons ::
- { failStackHead :: CodeQ (FailHandler inp a)
- , failStackTail :: FailStack inp es a
- } ->
- FailStack inp ('Succ es) a
-
-instance Stackable Gen where
- push x k = k
- { unGen = \ctx -> unGen k ctx
+instance InstrValuable Gen where
+ pushValue x k = k
+ { unGen = \ctx -> {-trace "unGen.pushValue" $-} unGen k ctx
{ valueStack = ValueStackCons x (valueStack ctx) }
}
- pop k = k
- { unGen = \ctx -> unGen k ctx
+ popValue k = k
+ { unGen = \ctx -> {-trace "unGen.popValue" $-} unGen k ctx
{ valueStack = valueStackTail (valueStack ctx) }
}
- liftI2 f k = k
- { unGen = \ctx -> unGen k ctx
+ lift2Value f k = k
+ { unGen = \ctx -> {-trace "unGen.lift2Value" $-} unGen k ctx
{ valueStack =
- let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
- ValueStackCons (f H.:@ x H.:@ y) xs
+ let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
+ ValueStackCons (f Prod..@ x Prod..@ y) vs
}
}
- swap k = k
- { unGen = \ctx -> unGen k ctx
+ swapValue k = k
+ { unGen = \ctx -> {-trace "unGen.swapValue" $-} unGen k ctx
{ valueStack =
- let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
- ValueStackCons x (ValueStackCons y xs)
+ let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
+ ValueStackCons x (ValueStackCons y vs)
}
}
-instance Branchable Gen where
- case_ kx ky = Gen
- { minHorizon = \ls ->
- minHorizon kx ls `min` minHorizon ky ls
- , unGen = \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]
+ , 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 })
||]
}
- choices fs ks kd = Gen
- { minHorizon = \ls -> minimum $
- minHorizon kd ls :
- (($ ls) . minHorizon <$> ks)
- , unGen = \ctx ->
+ 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" $-}
let ValueStackCons v vs = valueStack ctx in
go ctx{valueStack = vs} v fs ks
}
where
go ctx x (f:fs') (k:ks') = [||
- if $$(genCode (f H.:@ x))
- then $$(unGen k ctx)
- else $$(go ctx x fs' ks')
+ if $$(genCode (f Prod..@ x))
+ then
+ let _ = "choicesBranch.then" in
+ $$({-trace "unGen.choicesBranch.k" $-} unGen k ctx)
+ else
+ let _ = "choicesBranch.else" in
+ $$(go ctx x fs' ks')
||]
go ctx _ _ _ = unGen kd ctx
-instance Failable Gen where
- 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
+instance InstrExceptionable Gen where
+ raise exn = Gen
+ { genAnalysisByLet = HM.empty
+ , genAnalysis = \_final _ct -> GenAnalysis
+ { minReads = Left (ExceptionLabel exn)
+ , mayRaise = Map.singleton (ExceptionLabel exn) ()
+ }
+ , unGen = \ctx@GenCtx{} -> {-trace ("unGen.raise: "<>show exn) $-} [||
+ $$(raiseException ctx (ExceptionLabel exn))
+ (ExceptionLabel $$(TH.liftTyped exn))
+ {-failInp-}$$(input ctx)
+ {-farInp-}$$(input ctx)
+ $$(farthestExpecting ctx)
||]
}
- popFail k = k
- { unGen = \ctx ->
- let FailStackCons _e es = failStack ctx in
- unGen k ctx{failStack = es}
+ 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||]
}
- catchFail ok ko = Gen
- { minHorizon = \ls -> minHorizon ok ls `min` minHorizon ko ls
- , unGen = \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 (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)
- })
- ||]
+ 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)
+ }
}
-instance Inputable Gen where
- loadInput k = k
- { unGen = \ctx ->
- let ValueStackCons input vs = valueStack ctx in
- unGen k ctx
- { valueStack = vs
- , input = genCode input
- , horizon = 0
+ catch exn ok ko = Gen
+ { genAnalysisByLet = genAnalysisByLet ok <> genAnalysisByLet ko
+ , genAnalysis = \final ct ->
+ 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 '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 =
+ Map.insertWith (<>) exn
+ (NE.singleton [||catchHandler||])
+ (catchStackByLabel ctx)
}
+ ) ||]
}
+instance InstrInputable Gen where
pushInput k = k
{ unGen = \ctx ->
- unGen k ctx{valueStack = ValueStackCons (H.Term (input ctx)) (valueStack ctx)}
+ {-trace "unGen.pushInput" $-}
+ unGen k ctx
+ { valueStack = splice (input ctx) `ValueStackCons` valueStack ctx
+ , horizonStack = checkedHorizon ctx : horizonStack ctx
+ }
}
-instance Routinable Gen where
- call (LetName n) k = k
- { minHorizon = \hs -> hs Map.! n
- , unGen = \ctx -> [||
- let _ = "call" in
- $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
- {-ok-}$$(generateSuspend k ctx)
- $$(input ctx)
- $! $$(failStackHead (failStack ctx))
- ||]
- }
- jump (LetName n) = Gen
- { minHorizon = \hs -> hs Map.! n
- , unGen = \ctx -> [||
- let _ = "jump" in
- $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
- {-ok-}$$(retCode ctx)
- $$(input ctx)
- $! $$(failStackHead (failStack ctx))
- ||]
+ loadInput k = k
+ { unGen = \ctx ->
+ {-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
+ { 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)
+ }
}
- ret = Gen
- { minHorizon = \_hs -> 0
- , unGen = \ctx -> unGen (generateResume (retCode ctx)) ctx
+instance InstrCallable Gen where
+ defLet defs k = k
+ { unGen = \ctx@GenCtx{} ->
+ {-trace ("unGen.defLet: defs="<>show (HM.keys defs)) $-}
+ TH.unsafeCodeCoerce $ do
+ 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) <>
+ genAnalysisByLet k
}
- 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
+ where
+ makeDecl ctx (n, SomeLet sub) = 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
+ -- Called by 'call' or 'jump'.
+ \ !ok{-from generateSuspend or retCode-}
+ !inp
+ !koByLabel{- 'catchStackByLabel' from the 'call'-site -} ->
+ $$({-trace ("unGen.defLet.sub: "<>show n) $-} unGen sub ctx
{ valueStack = ValueStackEmpty
- , failStack = FailStackCons [||ko||] FailStackEmpty
+ -- 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) $-}
+ mayRaise (finalGenAnalysisByLet ctx HM.! n))
, input = [||inp||]
- , retCode = [||ok||]
- -- , farthestInput = [|inp|]
- -- , farthestExpecting = [|| [] ||]
- , horizon = 0
- , horizonByName = Map.insert n 0 (horizonByName ctx)
+ , retCode = {-trace ("unGen.defLet.sub.retCode: "<>show n) $-} [||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
})
||]
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)
+ return decl
+ jump (LetName n) = Gen
+ { genAnalysisByLet = HM.empty
+ , genAnalysis = \final ct ->
+ if n`List.elem`ct
+ then GenAnalysis
+ { minReads = Right 0
+ , mayRaise = Map.empty
+ }
+ else (final HM.! n) (n:ct)
+ , unGen = \ctx -> {-trace ("unGen.jump: "<>show n) $-} [||
+ let _ = "jump" in
+ $$(TH.unsafeCodeCoerce (return (TH.VarE n)))
+ {-ok-}$$(retCode ctx)
+ $$(input ctx)
+ $$(liftTypedRaiseByLabel $
+ catchStackByLabel ctx
+ -- Pass only the labels raised by the 'defLet'.
+ `Map.intersection`
+ (mayRaise $ finalGenAnalysisByLet ctx HM.! n)
+ )
+ ||]
+ }
+ call (LetName n) k = k
+ { genAnalysis = \final ct ->
+ if n`List.elem`ct
+ then GenAnalysis
+ { minReads = Right 0
+ , mayRaise = Map.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
+ [||
+ -- 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{callStack = n : callStack ctx})
+ $$(input ctx)
+ $$(liftTypedRaiseByLabel $
+ catchStackByLabel ctx
+ -- Pass only the labels raised by the 'defLet'.
+ `Map.intersection`
+ (mayRaise $ finalGenAnalysisByLet ctx HM.! n)
+ )
+ ||]
}
+ ret = Gen
+ { genAnalysisByLet = HM.empty
+ , genAnalysis = \_final _ct -> GenAnalysis
+ { minReads = Right 0
+ , mayRaise = Map.empty
+ }
+ , 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'.
+-- 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'
+-- 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) ||]
+
+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) ||]
--- | Generate a continuation to be called with 'generateResume',
--- used when 'call' 'ret'urns.
+-- ** 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-}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 _ = $$(liftTypedString $ "suspend") in
\farInp farExp v !inp ->
- $$(unGen k ctx
- { valueStack = ValueStackCons (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||]
- , 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
- , unGen = \ctx -> [||
+ { genAnalysisByLet = HM.empty
+ , genAnalysis = \_final _ct -> GenAnalysis
+ { minReads = Right 0
+ , mayRaise = Map.empty
+ }
+ , unGen = \ctx -> {-trace "unGen.generateResume" $-} [||
let _ = "resume" in
$$k
$$(farthestInput ctx)
$$(farthestExpecting ctx)
- (let _ = "resume.genCode" in $$(genCode (valueStackHead (valueStack ctx))))
+ (let _ = "resume.genCode" in $$({-trace "unGen.generateResume.genCode" $-}
+ genCode $ valueStackHead $ valueStack ctx))
$$(input ctx)
||]
}
-instance Joinable Gen where
+-- ** 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
- { 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)
+ { unGen =
+ \ctx ->
+ {-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 (splice [||v||]) (valueStack ctx)
+ , input = [||inp||]
+ , farthestInput = [||farInp||]
+ , farthestExpecting = [||farExp||]
+ , checkedHorizon = 0
+ {- FIXME:
+ , catchStackByLabel = Map.mapWithKey
+ (\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
+ (mayRaise sub raiseLabelsByLetButSub)
+ -}
+ })
+ ||]
+ let decl = TH.FunD n [TH.Clause [] (TH.NormalB next) []]
+ expr <- TH.unTypeQ (TH.examineCode ({-trace ("unGen.defJoin.expr: "<>show n) $-} unGen k ctx))
+ return (TH.LetE [decl] expr)
+ , genAnalysisByLet =
+ (genAnalysisByLet sub <>) $
+ HM.insert n (genAnalysis sub) $
+ genAnalysisByLet k
+ }
+ refJoin (LetName n) = Gen
+ { unGen = \ctx ->
+ {-trace ("unGen.refJoin: "<>show n) $-}
+ unGen (generateResume
+ (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)
}
- refJoin (LetName n) =
- generateResume (Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
-instance Readable Gen Char where
- read farExp p = checkHorizon . checkToken farExp p
+instance InstrReadable Char Gen where
+ 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) =>
- {-ok-}Gen inp vs ('Succ es) a ->
- Gen inp vs ('Succ es) a
+ NFData (InputToken inp) =>
+ Typeable (InputToken inp) =>
+ {-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} -> [||
- -- Factorize failure code
- let readFail = $$(e) in
+ { genAnalysis = \final ct -> seqGenAnalysis $
+ GenAnalysis { minReads = Right 1
+ , mayRaise = Map.singleton ExceptionFailure ()
+ } :|
+ [ genAnalysis ok final ct ]
+ , 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{ 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)
+ 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 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 (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")) $
+ (\f -> f (callStack ctx)) $
+ genAnalysis k $
+ ((\f _ct -> f) <$>) $
+ finalGenAnalysisByLet 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
-checkToken farExp p ok = ok
- { unGen = \ctx -> [||
+ Set SomeFailure ->
+ {-predicate-}Splice (InputToken inp -> Bool) ->
+ {-ok-}Gen inp (InputToken inp ': vs) a ->
+ Gen inp vs a
+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