{-# OPTIONS_GHC -Wno-monomorphism-restriction #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE AllowAmbiguousTypes,
ConstrainedClassMethods,
ConstraintKinds,
ImplicitParams,
MagicHash,
NamedFieldPuns,
PatternSynonyms,
RecordWildCards,
TypeApplications,
UnboxedTuples #-}
module Parsley.Internal.Backend.Machine.Ops (
dup, returnST,
sat, emitLengthCheck, fetch,
newΣ, writeΣ, readΣ,
fatal, raise,
buildHandler, buildYesHandler, buildIterYesHandler,
bindAlwaysHandler, bindSameHandler,
halt, noreturn,
resume, callWithContinuation, callCC,
suspend,
setupJoinPoint,
bindIterAlways,
bindIterSame,
buildRec,
dynHandler, dynCont,
logHandler, preludeString,
Ops, LogHandler, StaHandlerBuilder, StaYesHandler,
HandlerOps, JoinBuilder, RecBuilder, PositionOps, MarshalOps, LogOps
) where
import Control.Monad (liftM2)
import Control.Monad.Reader (ask, local)
import Control.Monad.ST (ST)
import Data.STRef (writeSTRef, readSTRef, newSTRef)
import Data.Void (Void)
import Debug.Trace (trace)
import GHC.Exts (Int(..), (-#))
import Language.Haskell.TH.Syntax (liftTyped)
import Parsley.Internal.Backend.Machine.BindingOps
import Parsley.Internal.Backend.Machine.Defunc (Defunc(INPUT), genDefunc, _if, pattern FREEVAR)
import Parsley.Internal.Backend.Machine.Identifiers (MVar, ΦVar, ΣVar)
import Parsley.Internal.Backend.Machine.InputOps (PositionOps(..), LogOps(..), InputOps, next, more)
import Parsley.Internal.Backend.Machine.InputRep (Rep)
import Parsley.Internal.Backend.Machine.Instructions (Access(..))
import Parsley.Internal.Backend.Machine.LetBindings (Regs(..), Metadata(failureInputCharacteristic, successInputCharacteristic))
import Parsley.Internal.Backend.Machine.THUtils (eta)
import Parsley.Internal.Backend.Machine.Types (MachineMonad, Machine(..), run)
import Parsley.Internal.Backend.Machine.Types.Context
import Parsley.Internal.Backend.Machine.Types.Dynamics (DynFunc, DynCont, DynHandler)
import Parsley.Internal.Backend.Machine.Types.Input (Input(..), Input#(..), toInput, fromInput, consume, chooseInput)
import Parsley.Internal.Backend.Machine.Types.InputCharacteristic (InputCharacteristic)
import Parsley.Internal.Backend.Machine.Types.State (Γ(..), OpStack(..))
import Parsley.Internal.Backend.Machine.Types.Statics
import Parsley.Internal.Common (One, Code, Vec(..), Nat(..))
import System.Console.Pretty (color, Color(Green, White, Red, Blue))
import Parsley.Internal.Backend.Machine.Types.Input.Offset as Offset (Offset(..))
dup :: Defunc x -> (Defunc x -> Code r) -> Code r
dup :: Defunc x -> (Defunc x -> Code r) -> Code r
dup (FREEVAR Code x
x) Defunc x -> Code r
k = Defunc x -> Code r
k (Code x -> Defunc x
forall a. Code a -> Defunc a
FREEVAR Code x
x)
dup (INPUT Input x
o) Defunc x -> Code r
k = Defunc x -> Code r
k (Input x -> Defunc x
forall o. Input o -> Defunc o
INPUT Input x
o)
dup Defunc x
x Defunc x -> Code r
k = [|| let !dupx = $$(genDefunc x) in $$(k (FREEVAR [||dupx||])) ||]
{-# INLINE returnST #-}
returnST :: forall s a. a -> ST s a
returnST :: a -> ST s a
returnST = forall a. Monad (ST s) => a -> ST s a
forall (m :: Type -> Type) a. Monad m => a -> m a
return @(ST s)
sat :: (Defunc Char -> Defunc Bool)
-> Code Char
-> (Defunc Char -> Code b)
-> Code b
-> Code b
sat :: (Defunc Char -> Defunc Bool)
-> Code Char -> (Defunc Char -> Code b) -> Code b -> Code b
sat Defunc Char -> Defunc Bool
p Code Char
c Defunc Char -> Code b
good Code b
bad = let v :: Defunc Char
v = Code Char -> Defunc Char
forall a. Code a -> Defunc a
FREEVAR Code Char
c in Defunc Bool -> Code b -> Code b -> Code b
forall a. Defunc Bool -> Code a -> Code a -> Code a
_if (Defunc Char -> Defunc Bool
p Defunc Char
v) (Defunc Char -> Code b
good Defunc Char
v) Code b
bad
fetch :: (?ops :: InputOps (Rep o))
=> Input o -> (Code Char -> Input o -> Code b) -> Code b
fetch :: Input o -> (Code Char -> Input o -> Code b) -> Code b
fetch Input o
input Code Char -> Input o -> Code b
k = Code (Rep o) -> (Code Char -> Code (Rep o) -> Code b) -> Code b
forall rep a.
(?ops::InputOps rep) =>
Code rep -> (Code Char -> Code rep -> Code a) -> Code a
next (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset (Input o -> Offset o
forall o. Input o -> Offset o
off Input o
input)) ((Code Char -> Code (Rep o) -> Code b) -> Code b)
-> (Code Char -> Code (Rep o) -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code Char
c Code (Rep o)
offset' -> Code Char -> Input o -> Code b
k Code Char
c (Code (Rep o) -> Input o -> Input o
forall o. Code (Rep o) -> Input o -> Input o
consume Code (Rep o)
offset' Input o
input)
emitLengthCheck :: (?ops :: InputOps (Rep o), PositionOps (Rep o))
=> Int
-> Code a
-> Code a
-> Offset o
-> Code a
emitLengthCheck :: Int -> Code a -> Code a -> Offset o -> Code a
emitLengthCheck Int
0 Code a
good Code a
_ Offset o
_ = Code a
good
emitLengthCheck Int
1 Code a
good Code a
bad Offset o
input = [|| if $$(more (offset input)) then $$good else $$bad ||]
emitLengthCheck (I# Int#
n) Code a
good Code a
bad Offset o
input = [||
if $$(more (shiftRight (offset input) (liftTyped (n -# 1#)))) then $$good
else $$bad ||]
newΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s r)) -> Ctx s o a -> Code (ST s r)
newΣ :: ΣVar x
-> Access
-> Defunc x
-> (Ctx s o a -> Code (ST s r))
-> Ctx s o a
-> Code (ST s r)
newΣ ΣVar x
σ Access
Soft Defunc x
x Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = Defunc x -> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s r)) -> Code (ST s r))
-> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> Ctx s o a -> Code (ST s r)
k (ΣVar x
-> Maybe (Code (STRef s x)) -> Defunc x -> Ctx s o a -> Ctx s o a
forall x s o a.
ΣVar x
-> Maybe (Code (STRef s x)) -> Defunc x -> Ctx s o a -> Ctx s o a
insertNewΣ ΣVar x
σ Maybe (Code (STRef s x))
forall a. Maybe a
Nothing Defunc x
dupx Ctx s o a
ctx)
newΣ ΣVar x
σ Access
Hard Defunc x
x Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = Defunc x -> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s r)) -> Code (ST s r))
-> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> [||
do ref <- newSTRef $$(genDefunc dupx)
$$(k (insertNewΣ σ (Just [||ref||]) dupx ctx))
||]
writeΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s r)) -> Ctx s o a -> Code (ST s r)
writeΣ :: ΣVar x
-> Access
-> Defunc x
-> (Ctx s o a -> Code (ST s r))
-> Ctx s o a
-> Code (ST s r)
writeΣ ΣVar x
σ Access
Soft Defunc x
x Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = Defunc x -> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s r)) -> Code (ST s r))
-> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> Ctx s o a -> Code (ST s r)
k (ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a
forall x s o a. ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a
cacheΣ ΣVar x
σ Defunc x
dupx Ctx s o a
ctx)
writeΣ ΣVar x
σ Access
Hard Defunc x
x Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = let ref :: Code (STRef s x)
ref = ΣVar x -> Ctx s o a -> Code (STRef s x)
forall x s o a. ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ ΣVar x
σ Ctx s o a
ctx in Defunc x -> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s r)) -> Code (ST s r))
-> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> [||
do writeSTRef $$ref $$(genDefunc dupx)
$$(k (cacheΣ σ dupx ctx))
||]
readΣ :: ΣVar x -> Access -> (Defunc x -> Ctx s o a -> Code (ST s r)) -> Ctx s o a -> Code (ST s r)
readΣ :: ΣVar x
-> Access
-> (Defunc x -> Ctx s o a -> Code (ST s r))
-> Ctx s o a
-> Code (ST s r)
readΣ ΣVar x
σ Access
Soft Defunc x -> Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = Defunc x -> Ctx s o a -> Code (ST s r)
k (ΣVar x -> Ctx s o a -> Defunc x
forall x s o a. ΣVar x -> Ctx s o a -> Defunc x
cachedΣ ΣVar x
σ Ctx s o a
ctx) Ctx s o a
ctx
readΣ ΣVar x
σ Access
Hard Defunc x -> Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = let ref :: Code (STRef s x)
ref = ΣVar x -> Ctx s o a -> Code (STRef s x)
forall x s o a. ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ ΣVar x
σ Ctx s o a
ctx in [||
do x <- readSTRef $$ref
$$(let fv = FREEVAR [||x||] in k fv (cacheΣ σ fv ctx))
||]
fatal :: AugmentedStaHandler s o a
fatal :: AugmentedStaHandler s o a
fatal = Maybe (Input o) -> StaHandler# s o a -> AugmentedStaHandler s o a
forall o s a.
Maybe (Input o) -> StaHandler# s o a -> AugmentedStaHandler s o a
augmentHandlerSta Maybe (Input o)
forall a. Maybe a
Nothing (Q (TExp (ST s (Maybe a))) -> StaHandler# s o a
forall a b. a -> b -> a
const [|| returnST Nothing ||])
raise :: Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))
raise :: Γ s o xs ('Succ n) r a -> Code (ST s (Maybe a))
raise Γ s o xs ('Succ n) r a
γ = let VCons AugmentedStaHandler s o a
h Vec n (AugmentedStaHandler s o a)
_ = Γ s o xs ('Succ n) r a -> Vec ('Succ n) (AugmentedStaHandler s o a)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs ('Succ n) r a
γ in AugmentedStaHandler s o a -> Input o -> Code (ST s (Maybe a))
forall s o a.
AugmentedStaHandler s o a -> Input o -> Code (ST s (Maybe a))
staHandlerEval AugmentedStaHandler s o a
h (Γ s o xs ('Succ n) r a -> Input o
forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs ('Succ n) r a
γ)
buildHandler :: Γ s o xs n r a
-> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))
-> Word
-> StaHandlerBuilder s o a
buildHandler :: Γ s o xs n r a
-> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))
-> Word
-> StaHandlerBuilder s o a
buildHandler Γ s o xs n r a
γ Γ s o (o : xs) n r a -> Code (ST s (Maybe a))
h Word
u Input o
c = StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (StaHandler# s o a -> StaHandler s o a)
-> StaHandler# s o a -> StaHandler s o a
forall a b. (a -> b) -> a -> b
$ \Input# o
inp -> Γ s o (o : xs) n r a -> Code (ST s (Maybe a))
h (Γ s o xs n r a
γ {operands :: OpStack (o : xs)
operands = Defunc o -> OpStack xs -> OpStack (o : xs)
forall x (xs :: [Type]). Defunc x -> OpStack xs -> OpStack (x : xs)
Op (Input o -> Defunc o
forall o. Input o -> Defunc o
INPUT Input o
c) (Γ s o xs n r a -> OpStack xs
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
operands Γ s o xs n r a
γ), input :: Input o
input = Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u Input# o
inp})
buildYesHandler :: Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a)))
-> StaYesHandler s o a
buildYesHandler :: Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a))) -> StaYesHandler s o a
buildYesHandler Γ s o xs n r a
γ Γ s o xs n r a -> Code (ST s (Maybe a))
h Input o
inp = Γ s o xs n r a -> Code (ST s (Maybe a))
h (Γ s o xs n r a
γ {input :: Input o
input = Input o
inp})
buildIterYesHandler :: Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a)))
-> Word
-> StaHandler s o a
buildIterYesHandler :: Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a)))
-> Word
-> StaHandler s o a
buildIterYesHandler Γ s o xs n r a
γ Γ s o xs n r a -> Code (ST s (Maybe a))
h Word
u = StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a))) -> StaYesHandler s o a
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a))) -> StaYesHandler s o a
buildYesHandler Γ s o xs n r a
γ Γ s o xs n r a -> Code (ST s (Maybe a))
h StaYesHandler s o a -> (Input# o -> Input o) -> StaHandler# s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u)
bindAlwaysHandler :: forall s o xs n r a b. HandlerOps o
=> Γ s o xs n r a
-> Bool
-> StaHandlerBuilder s o a
-> (Γ s o xs (Succ n) r a -> Code b)
-> Code b
bindAlwaysHandler :: Γ s o xs n r a
-> Bool
-> StaHandlerBuilder s o a
-> (Γ s o xs ('Succ n) r a -> Code b)
-> Code b
bindAlwaysHandler Γ s o xs n r a
γ Bool
needed StaHandlerBuilder s o a
h Γ s o xs ('Succ n) r a -> Code b
k = Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# Bool
needed (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandlerBuilder s o a
h (Γ s o xs n r a -> Input o
forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ))) ((StaHandler s o a -> Code b) -> Code b)
-> (StaHandler s o a -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qh ->
Γ s o xs ('Succ n) r a -> Code b
k (Γ s o xs n r a
γ {handlers :: Vec ('Succ n) (AugmentedStaHandler s o a)
handlers = AugmentedStaHandler s o a
-> Vec n (AugmentedStaHandler s o a)
-> Vec ('Succ n) (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Maybe (Input o) -> StaHandler s o a -> AugmentedStaHandler s o a
forall o s a.
Maybe (Input o) -> StaHandler s o a -> AugmentedStaHandler s o a
augmentHandler (Input o -> Maybe (Input o)
forall a. a -> Maybe a
Just (Γ s o xs n r a -> Input o
forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ)) StaHandler s o a
qh) (Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs n r a
γ)})
bindSameHandler :: forall s o xs n r a b. (HandlerOps o, PositionOps (Rep o))
=> Γ s o xs n r a
-> Bool
-> StaYesHandler s o a
-> Bool
-> StaHandlerBuilder s o a
-> (Γ s o xs (Succ n) r a -> Code b)
-> Code b
bindSameHandler :: Γ s o xs n r a
-> Bool
-> StaYesHandler s o a
-> Bool
-> StaHandlerBuilder s o a
-> (Γ s o xs ('Succ n) r a -> Code b)
-> Code b
bindSameHandler Γ s o xs n r a
γ Bool
yesNeeded StaYesHandler s o a
yes Bool
noNeeded StaHandlerBuilder s o a
no Γ s o xs ('Succ n) r a -> Code b
k =
Bool
-> Code (ST s (Maybe a))
-> (Code (ST s (Maybe a)) -> Code b)
-> Code b
forall a b. Bool -> Code a -> (Code a -> Code b) -> Code b
bindYesInline# Bool
yesNeeded (StaYesHandler s o a
yes (Γ s o xs n r a -> Input o
forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ)) ((Code (ST s (Maybe a)) -> Code b) -> Code b)
-> (Code (ST s (Maybe a)) -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code (ST s (Maybe a))
qyes ->
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# Bool
noNeeded (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandlerBuilder s o a
no (Γ s o xs n r a -> Input o
forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ))) ((StaHandler s o a -> Code b) -> Code b)
-> (StaHandler s o a -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qno ->
let handler :: StaHandler# s o a
handler Input# o
inp = [||if $$(same (offset (off (input γ))) (off# inp)) then $$qyes else $$(staHandler# qno inp)||]
in Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# @o Bool
True StaHandler# s o a
handler ((StaHandler s o a -> Code b) -> Code b)
-> (StaHandler s o a -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qhandler ->
Γ s o xs ('Succ n) r a -> Code b
k (Γ s o xs n r a
γ {handlers :: Vec ('Succ n) (AugmentedStaHandler s o a)
handlers = AugmentedStaHandler s o a
-> Vec n (AugmentedStaHandler s o a)
-> Vec ('Succ n) (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Input o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
forall o s a.
Input o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
augmentHandlerFull (Γ s o xs n r a -> Input o
forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ) StaHandler s o a
qhandler Code (ST s (Maybe a))
qyes StaHandler s o a
qno) (Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs n r a
γ)})
halt :: StaCont s o a a
halt :: StaCont s o a a
halt = StaCont# s o a a -> StaCont s o a a
forall s o a x. StaCont# s o a x -> StaCont s o a x
mkStaCont (StaCont# s o a a -> StaCont s o a a)
-> StaCont# s o a a -> StaCont s o a a
forall a b. (a -> b) -> a -> b
$ \Code a
x Input# o
_ -> [||returnST (Just $$x)||]
noreturn :: StaCont s o a Void
noreturn :: StaCont s o a Void
noreturn = StaCont# s o a Void -> StaCont s o a Void
forall s o a x. StaCont# s o a x -> StaCont s o a x
mkStaCont (StaCont# s o a Void -> StaCont s o a Void)
-> StaCont# s o a Void -> StaCont s o a Void
forall a b. (a -> b) -> a -> b
$ \Code Void
_ Input# o
_ -> [||error "Return is not permitted here"||]
resume :: StaCont s o a x -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
resume :: StaCont s o a x -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
resume StaCont s o a x
k Γ s o (x : xs) n r a
γ = let Op Defunc x
x OpStack xs
_ = Γ s o (x : xs) n r a -> OpStack (x : xs)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
operands Γ s o (x : xs) n r a
γ in StaCont s o a x -> StaCont# s o a x
forall s o a x. StaCont s o a x -> StaCont# s o a x
staCont# StaCont s o a x
k (Defunc x -> Code x
forall a. Defunc a -> Code a
genDefunc Defunc x
x) (Input o -> Input# o
forall o. Input o -> Input# o
fromInput (Γ s o (x : xs) n r a -> Input o
forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o (x : xs) n r a
γ))
callWithContinuation :: MarshalOps o
=> StaSubroutine s o a x
-> StaCont s o a x
-> Input o
-> Vec (Succ n) (AugmentedStaHandler s o a)
-> Code (ST s (Maybe a))
callWithContinuation :: StaSubroutine s o a x
-> StaCont s o a x
-> Input o
-> Vec ('Succ n) (AugmentedStaHandler s o a)
-> Code (ST s (Maybe a))
callWithContinuation StaSubroutine s o a x
sub StaCont s o a x
ret Input o
input (VCons AugmentedStaHandler s o a
h Vec n (AugmentedStaHandler s o a)
_) = StaSubroutine s o a x -> StaSubroutine# s o a x
forall s o a x. StaSubroutine s o a x -> StaSubroutine# s o a x
staSubroutine# StaSubroutine s o a x
sub (StaCont s o a x -> DynCont s o a x
forall s o a x. MarshalOps o => StaCont s o a x -> DynCont s o a x
dynCont StaCont s o a x
ret) (AugmentedStaHandler s o a
-> InputCharacteristic -> DynHandler s o a
forall s o a.
MarshalOps o =>
AugmentedStaHandler s o a
-> InputCharacteristic -> DynHandler s o a
dynHandler AugmentedStaHandler s o a
h (Metadata -> InputCharacteristic
failureInputCharacteristic (StaSubroutine s o a x -> Metadata
forall s o a x. StaSubroutine s o a x -> Metadata
meta StaSubroutine s o a x
sub))) (Input o -> Input# o
forall o. Input o -> Input# o
fromInput Input o
input)
suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a)))
-> Γ s o xs n r a
-> (Input# o -> Input o)
-> StaCont s o a x
suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a)))
-> Γ s o xs n r a -> (Input# o -> Input o) -> StaCont s o a x
suspend Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
m Γ s o xs n r a
γ Input# o -> Input o
off = StaCont# s o a x -> StaCont s o a x
forall s o a x. StaCont# s o a x -> StaCont s o a x
mkStaCont (StaCont# s o a x -> StaCont s o a x)
-> StaCont# s o a x -> StaCont s o a x
forall a b. (a -> b) -> a -> b
$ \Code x
x Input# o
o# -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
m (Γ s o xs n r a
γ {operands :: OpStack (x : xs)
operands = Defunc x -> OpStack xs -> OpStack (x : xs)
forall x (xs :: [Type]). Defunc x -> OpStack xs -> OpStack (x : xs)
Op (Code x -> Defunc x
forall a. Code a -> Defunc a
FREEVAR Code x
x) (Γ s o xs n r a -> OpStack xs
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
operands Γ s o xs n r a
γ), input :: Input o
input = Input# o -> Input o
off Input# o
o#})
callCC :: forall s o xs n r a x. MarshalOps o
=> Word
-> StaSubroutine s o a x
-> (Γ s o (x : xs) (Succ n) r a -> Code (ST s (Maybe a)))
-> Γ s o xs (Succ n) r a
-> Code (ST s (Maybe a))
callCC :: Word
-> StaSubroutine s o a x
-> (Γ s o (x : xs) ('Succ n) r a -> Code (ST s (Maybe a)))
-> Γ s o xs ('Succ n) r a
-> Code (ST s (Maybe a))
callCC Word
u StaSubroutine s o a x
sub Γ s o (x : xs) ('Succ n) r a -> Code (ST s (Maybe a))
k Γ s o xs ('Succ n) r a
γ = StaSubroutine s o a x
-> StaCont s o a x
-> Input o
-> Vec ('Succ n) (AugmentedStaHandler s o a)
-> Code (ST s (Maybe a))
forall o s a x (n :: Nat).
MarshalOps o =>
StaSubroutine s o a x
-> StaCont s o a x
-> Input o
-> Vec ('Succ n) (AugmentedStaHandler s o a)
-> Code (ST s (Maybe a))
callWithContinuation StaSubroutine s o a x
sub ((Γ s o (x : xs) ('Succ n) r a -> Code (ST s (Maybe a)))
-> Γ s o xs ('Succ n) r a
-> (Input# o -> Input o)
-> StaCont s o a x
forall s o x (xs :: [Type]) (n :: Nat) r a.
(Γ s o (x : xs) n r a -> Code (ST s (Maybe a)))
-> Γ s o xs n r a -> (Input# o -> Input o) -> StaCont s o a x
suspend Γ s o (x : xs) ('Succ n) r a -> Code (ST s (Maybe a))
k Γ s o xs ('Succ n) r a
γ (InputCharacteristic -> Word -> Input o -> Input# o -> Input o
forall o.
InputCharacteristic -> Word -> Input o -> Input# o -> Input o
chooseInput (Metadata -> InputCharacteristic
successInputCharacteristic (StaSubroutine s o a x -> Metadata
forall s o a x. StaSubroutine s o a x -> Metadata
meta StaSubroutine s o a x
sub)) Word
u Input o
inp)) Input o
inp (Γ s o xs ('Succ n) r a -> Vec ('Succ n) (AugmentedStaHandler s o a)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs ('Succ n) r a
γ)
where
inp :: Input o
inp :: Input o
inp = Γ s o xs ('Succ n) r a -> Input o
forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs ('Succ n) r a
γ
setupJoinPoint :: forall s o xs n r a x. JoinBuilder o
=> ΦVar x
-> Machine s o (x : xs) n r a
-> Machine s o xs n r a
-> MachineMonad s o xs n r a
setupJoinPoint :: ΦVar x
-> Machine s o (x : xs) n r a
-> Machine s o xs n r a
-> MachineMonad s o xs n r a
setupJoinPoint ΦVar x
φ (Machine MachineMonad s o (x : xs) n r a
k) Machine s o xs n r a
mx = (Word -> MachineMonad s o xs n r a) -> MachineMonad s o xs n r a
forall s o a (m :: Type -> Type) b.
MonadReader (Ctx s o a) m =>
(Word -> m b) -> m b
freshUnique ((Word -> MachineMonad s o xs n r a) -> MachineMonad s o xs n r a)
-> (Word -> MachineMonad s o xs n r a) -> MachineMonad s o xs n r a
forall a b. (a -> b) -> a -> b
$ \Word
u ->
((Γ s o (x : xs) n r a -> Code (ST s (Maybe a)))
-> Ctx s o a -> Γ s o xs n r a -> Code (ST s (Maybe a)))
-> MachineMonad s o (x : xs) n r a
-> ReaderT (Ctx s o a) Identity (Ctx s o a)
-> MachineMonad s o xs n r a
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (\Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
mk Ctx s o a
ctx Γ s o xs n r a
γ ->
StaCont# s o a x
-> (DynCont s o a x -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a x b.
JoinBuilder o =>
StaCont# s o a x -> (DynCont s o a x -> Code b) -> Code b
setupJoinPoint# @o
(\Code x
qx Input# o
inp -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
mk (Γ s o xs n r a
γ {operands :: OpStack (x : xs)
operands = Defunc x -> OpStack xs -> OpStack (x : xs)
forall x (xs :: [Type]). Defunc x -> OpStack xs -> OpStack (x : xs)
Op (Code x -> Defunc x
forall a. Code a -> Defunc a
FREEVAR Code x
qx) (Γ s o xs n r a -> OpStack xs
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
operands Γ s o xs n r a
γ), input :: Input o
input = Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u Input# o
inp}))
(\DynCont s o a x
qjoin -> Machine s o xs n r a
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
forall s o (xs :: [Type]) (n :: Nat) r a.
Machine s o xs n r a
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
run Machine s o xs n r a
mx Γ s o xs n r a
γ (ΦVar x -> StaCont s o a x -> Ctx s o a -> Ctx s o a
forall x s o a. ΦVar x -> StaCont s o a x -> Ctx s o a -> Ctx s o a
insertΦ ΦVar x
φ (DynCont s o a x -> StaCont s o a x
forall s o a x. DynCont s o a x -> StaCont s o a x
mkStaContDyn DynCont s o a x
qjoin) Ctx s o a
ctx)))
((Ctx s o a -> Ctx s o a)
-> MachineMonad s o (x : xs) n r a
-> MachineMonad s o (x : xs) n r a
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
local Ctx s o a -> Ctx s o a
forall s o a. Ctx s o a -> Ctx s o a
voidCoins MachineMonad s o (x : xs) n r a
k) ReaderT (Ctx s o a) Identity (Ctx s o a)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
bindIterAlways :: forall s o a. RecBuilder o
=> Ctx s o a
-> MVar Void
-> Machine s o '[] One Void a
-> Bool
-> StaHandlerBuilder s o a
-> Input o
-> Word
-> Code (ST s (Maybe a))
bindIterAlways :: Ctx s o a
-> MVar Void
-> Machine s o '[] One Void a
-> Bool
-> StaHandlerBuilder s o a
-> Input o
-> Word
-> Code (ST s (Maybe a))
bindIterAlways Ctx s o a
ctx MVar Void
μ Machine s o '[] One Void a
l Bool
needed StaHandlerBuilder s o a
h Input o
inp Word
u =
Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a b.
RecBuilder o =>
Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# @o Bool
needed (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandler s o a -> StaHandler# s o a)
-> (Input# o -> StaHandler s o a) -> Input# o -> StaHandler# s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaHandlerBuilder s o a
h StaHandlerBuilder s o a
-> (Input# o -> Input o) -> Input# o -> StaHandler s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u) (((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a)))
-> ((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Input# o -> StaHandler s o a
qhandler ->
Input# o
-> (Code (Pos -> Rep o -> ST s (Maybe a)) -> StaHandler# s o a)
-> Code (ST s (Maybe a))
forall o s a.
RecBuilder o =>
Input# o
-> (Code (Pos -> Rep o -> ST s (Maybe a))
-> Input# o -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
bindIter# @o (Input o -> Input# o
forall o. Input o -> Input# o
fromInput Input o
inp) ((Code (Pos -> Rep o -> ST s (Maybe a)) -> StaHandler# s o a)
-> Code (ST s (Maybe a)))
-> (Code (Pos -> Rep o -> ST s (Maybe a)) -> StaHandler# s o a)
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Code (Pos -> Rep o -> ST s (Maybe a))
qloop Input# o
inp# ->
let inp :: Input o
inp = Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u Input# o
inp#
in Machine s o '[] One Void a
-> Γ s o '[] One Void a -> Ctx s o a -> Code (ST s (Maybe a))
forall s o (xs :: [Type]) (n :: Nat) r a.
Machine s o xs n r a
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
run Machine s o '[] One Void a
l (OpStack '[]
-> StaCont s o a Void
-> Input o
-> Vec One (AugmentedStaHandler s o a)
-> Γ s o '[] One Void a
forall s o (xs :: [Type]) (n :: Nat) r a.
OpStack xs
-> StaCont s o a r
-> Input o
-> Vec n (AugmentedStaHandler s o a)
-> Γ s o xs n r a
Γ OpStack '[]
Empty StaCont s o a Void
forall s o a. StaCont s o a Void
noreturn Input o
inp (AugmentedStaHandler s o a
-> Vec 'Zero (AugmentedStaHandler s o a)
-> Vec One (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Maybe (Input o) -> StaHandler s o a -> AugmentedStaHandler s o a
forall o s a.
Maybe (Input o) -> StaHandler s o a -> AugmentedStaHandler s o a
augmentHandler (Input o -> Maybe (Input o)
forall a. a -> Maybe a
Just Input o
inp) (Input# o -> StaHandler s o a
qhandler Input# o
inp#)) Vec 'Zero (AugmentedStaHandler s o a)
forall a. Vec 'Zero a
VNil))
(Ctx s o a -> Ctx s o a
forall s o a. Ctx s o a -> Ctx s o a
voidCoins (MVar Void -> StaSubroutine s o a Void -> Ctx s o a -> Ctx s o a
forall x s o a.
MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar Void
μ (StaSubroutine# s o a Void -> StaSubroutine s o a Void
forall s o a x. StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutine (StaSubroutine# s o a Void -> StaSubroutine s o a Void)
-> StaSubroutine# s o a Void -> StaSubroutine s o a Void
forall a b. (a -> b) -> a -> b
$ \DynCont s o a Void
_ Code (Pos -> Rep o -> ST s (Maybe a))
_ Input# o
inp -> [|| $$qloop $$(pos# inp) $$(off# inp) ||]) Ctx s o a
ctx))
bindIterSame :: forall s o a. (RecBuilder o, HandlerOps o, PositionOps (Rep o))
=> Ctx s o a
-> MVar Void
-> Machine s o '[] One Void a
-> Bool
-> StaHandler s o a
-> Bool
-> StaHandlerBuilder s o a
-> Input o
-> Word
-> Code (ST s (Maybe a))
bindIterSame :: Ctx s o a
-> MVar Void
-> Machine s o '[] One Void a
-> Bool
-> StaHandler s o a
-> Bool
-> StaHandlerBuilder s o a
-> Input o
-> Word
-> Code (ST s (Maybe a))
bindIterSame Ctx s o a
ctx MVar Void
μ Machine s o '[] One Void a
l Bool
neededYes StaHandler s o a
yes Bool
neededNo StaHandlerBuilder s o a
no Input o
inp Word
u =
Bool
-> StaHandler# s o a
-> (StaHandler s o a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# @o Bool
neededYes (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# StaHandler s o a
yes) ((StaHandler s o a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a)))
-> (StaHandler s o a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qyes ->
Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a b.
RecBuilder o =>
Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# Bool
neededNo (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandler s o a -> StaHandler# s o a)
-> (Input# o -> StaHandler s o a) -> Input# o -> StaHandler# s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaHandlerBuilder s o a
no StaHandlerBuilder s o a
-> (Input# o -> Input o) -> Input# o -> StaHandler s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u) (((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a)))
-> ((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Input# o -> StaHandler s o a
qno ->
let handler :: Input# o -> StaHandler# s o a
handler Input# o
inpc Input# o
inpo = [||if $$(same (off# inpc) (off# inpo)) then $$(staHandler# qyes inpc) else $$(staHandler# (qno inpc) inpo)||]
in Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a b.
RecBuilder o =>
Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# @o Bool
True Input# o -> StaHandler# s o a
handler (((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a)))
-> ((Input# o -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Input# o -> StaHandler s o a
qhandler ->
Input# o
-> (Code (Pos -> Rep o -> ST s (Maybe a)) -> StaHandler# s o a)
-> Code (ST s (Maybe a))
forall o s a.
RecBuilder o =>
Input# o
-> (Code (Pos -> Rep o -> ST s (Maybe a))
-> Input# o -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
bindIter# @o (Input o -> Input# o
forall o. Input o -> Input# o
fromInput Input o
inp) ((Code (Pos -> Rep o -> ST s (Maybe a)) -> StaHandler# s o a)
-> Code (ST s (Maybe a)))
-> (Code (Pos -> Rep o -> ST s (Maybe a)) -> StaHandler# s o a)
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Code (Pos -> Rep o -> ST s (Maybe a))
qloop Input# o
inp# ->
let off :: Input o
off = Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u Input# o
inp#
in Machine s o '[] One Void a
-> Γ s o '[] One Void a -> Ctx s o a -> Code (ST s (Maybe a))
forall s o (xs :: [Type]) (n :: Nat) r a.
Machine s o xs n r a
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
run Machine s o '[] One Void a
l (OpStack '[]
-> StaCont s o a Void
-> Input o
-> Vec One (AugmentedStaHandler s o a)
-> Γ s o '[] One Void a
forall s o (xs :: [Type]) (n :: Nat) r a.
OpStack xs
-> StaCont s o a r
-> Input o
-> Vec n (AugmentedStaHandler s o a)
-> Γ s o xs n r a
Γ OpStack '[]
Empty StaCont s o a Void
forall s o a. StaCont s o a Void
noreturn Input o
off (AugmentedStaHandler s o a
-> Vec 'Zero (AugmentedStaHandler s o a)
-> Vec One (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Input o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
forall o s a.
Input o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
augmentHandlerFull Input o
off (Input# o -> StaHandler s o a
qhandler Input# o
inp#) (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# StaHandler s o a
qyes Input# o
inp#) (Input# o -> StaHandler s o a
qno Input# o
inp#)) Vec 'Zero (AugmentedStaHandler s o a)
forall a. Vec 'Zero a
VNil))
(Ctx s o a -> Ctx s o a
forall s o a. Ctx s o a -> Ctx s o a
voidCoins (MVar Void -> StaSubroutine s o a Void -> Ctx s o a -> Ctx s o a
forall x s o a.
MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar Void
μ (StaSubroutine# s o a Void -> StaSubroutine s o a Void
forall s o a x. StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutine (StaSubroutine# s o a Void -> StaSubroutine s o a Void)
-> StaSubroutine# s o a Void -> StaSubroutine s o a Void
forall a b. (a -> b) -> a -> b
$ \DynCont s o a Void
_ Code (Pos -> Rep o -> ST s (Maybe a))
_ Input# o
inp -> [|| $$qloop $$(pos# inp) $$(off# inp) ||]) Ctx s o a
ctx))
buildRec :: forall rs s o a r. RecBuilder o
=> MVar r
-> Regs rs
-> Ctx s o a
-> Machine s o '[] One r a
-> Metadata
-> DynFunc rs s o a r
buildRec :: MVar r
-> Regs rs
-> Ctx s o a
-> Machine s o '[] One r a
-> Metadata
-> DynFunc rs s o a r
buildRec MVar r
μ Regs rs
rs Ctx s o a
ctx Machine s o '[] One r a
k Metadata
meta =
Regs rs
-> Ctx s o a
-> (Ctx s o a -> DynSubroutine s o a r)
-> DynFunc rs s o a r
forall (rs :: [Type]) s o a x.
Regs rs
-> Ctx s o a
-> (Ctx s o a -> DynSubroutine s o a x)
-> DynFunc rs s o a x
takeFreeRegisters Regs rs
rs Ctx s o a
ctx ((Ctx s o a -> DynSubroutine s o a r) -> DynFunc rs s o a r)
-> (Ctx s o a -> DynSubroutine s o a r) -> DynFunc rs s o a r
forall a b. (a -> b) -> a -> b
$ \Ctx s o a
ctx ->
forall s a x.
RecBuilder o =>
(DynSubroutine s o a x -> StaSubroutine# s o a x)
-> DynSubroutine s o a x
forall o s a x.
RecBuilder o =>
(DynSubroutine s o a x -> StaSubroutine# s o a x)
-> DynSubroutine s o a x
bindRec# @o ((DynSubroutine s o a r -> StaSubroutine# s o a r)
-> DynSubroutine s o a r)
-> (DynSubroutine s o a r -> StaSubroutine# s o a r)
-> DynSubroutine s o a r
forall a b. (a -> b) -> a -> b
$ \DynSubroutine s o a r
qself DynCont s o a r
qret DynHandler s o a
qh Input# o
inp ->
Machine s o '[] One r a
-> Γ s o '[] One r a -> Ctx s o a -> Code (ST s (Maybe a))
forall s o (xs :: [Type]) (n :: Nat) r a.
Machine s o xs n r a
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
run Machine s o '[] One r a
k (OpStack '[]
-> StaCont s o a r
-> Input o
-> Vec One (AugmentedStaHandler s o a)
-> Γ s o '[] One r a
forall s o (xs :: [Type]) (n :: Nat) r a.
OpStack xs
-> StaCont s o a r
-> Input o
-> Vec n (AugmentedStaHandler s o a)
-> Γ s o xs n r a
Γ OpStack '[]
Empty (DynCont s o a r -> StaCont s o a r
forall s o a x. DynCont s o a x -> StaCont s o a x
mkStaContDyn DynCont s o a r
qret) (Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
0 Input# o
inp) (AugmentedStaHandler s o a
-> Vec 'Zero (AugmentedStaHandler s o a)
-> Vec One (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Maybe (Input o) -> DynHandler s o a -> AugmentedStaHandler s o a
forall s o a.
Maybe (Input o) -> DynHandler s o a -> AugmentedStaHandler s o a
augmentHandlerDyn Maybe (Input o)
forall a. Maybe a
Nothing DynHandler s o a
qh) Vec 'Zero (AugmentedStaHandler s o a)
forall a. Vec 'Zero a
VNil))
(MVar r -> StaSubroutine s o a r -> Ctx s o a -> Ctx s o a
forall x s o a.
MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar r
μ (Metadata -> StaSubroutine# s o a r -> StaSubroutine s o a r
forall s o a x.
Metadata -> StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutineMeta Metadata
meta (StaSubroutine# s o a r -> StaSubroutine s o a r)
-> StaSubroutine# s o a r -> StaSubroutine s o a r
forall a b. (a -> b) -> a -> b
$ \DynCont s o a r
k DynHandler s o a
h Input# o
inp -> [|| $$qself $$k $$h $$(pos# inp) $$(off# inp) ||]) (Ctx s o a -> Ctx s o a
forall s o a. Ctx s o a -> Ctx s o a
nextUnique Ctx s o a
ctx))
bindHandlerInline# :: forall o s a b. HandlerOps o
=> Bool
-> StaHandler# s o a
-> (StaHandler s o a -> Code b)
-> Code b
bindHandlerInline# :: Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# Bool
True StaHandler# s o a
h StaHandler s o a -> Code b
k = StaHandler# s o a -> (DynHandler s o a -> Code b) -> Code b
forall o s a b.
HandlerOps o =>
StaHandler# s o a -> (DynHandler s o a -> Code b) -> Code b
bindHandler# @o StaHandler# s o a
h (StaHandler s o a -> Code b
k (StaHandler s o a -> Code b)
-> (DynHandler s o a -> StaHandler s o a)
-> DynHandler s o a
-> Code b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynHandler s o a -> StaHandler s o a
forall s o a. DynHandler s o a -> StaHandler s o a
fromDynHandler)
bindHandlerInline# Bool
False StaHandler# s o a
h StaHandler s o a -> Code b
k = StaHandler s o a -> Code b
k (StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# StaHandler# s o a
h)
bindYesInline# :: Bool -> Code a -> (Code a -> Code b) -> Code b
bindYesInline# :: Bool -> Code a -> (Code a -> Code b) -> Code b
bindYesInline# Bool
True Code a
v Code a -> Code b
k = [|| let yesSame = $$v in $$(k [||yesSame||]) ||]
bindYesInline# Bool
False Code a
v Code a -> Code b
k = Code a -> Code b
k Code a
v
bindIterHandlerInline# :: forall o s a b. RecBuilder o
=> Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# :: Bool
-> (Input# o -> StaHandler# s o a)
-> ((Input# o -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# Bool
True Input# o -> StaHandler# s o a
h (Input# o -> StaHandler s o a) -> Code b
k = (Input# o -> StaHandler# s o a)
-> (Code (Pos -> Rep o -> Handler# s o a) -> Code b) -> Code b
forall o s a b.
RecBuilder o =>
(Input# o -> StaHandler# s o a)
-> (Code (Pos -> Rep o -> Handler# s o a) -> Code b) -> Code b
bindIterHandler# @o Input# o -> StaHandler# s o a
h ((Code (Pos -> Rep o -> Handler# s o a) -> Code b) -> Code b)
-> (Code (Pos -> Rep o -> Handler# s o a) -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code (Pos -> Rep o -> Handler# s o a)
qh -> (Input# o -> StaHandler s o a) -> Code b
k (\Input# o
inp -> DynHandler s o a -> StaHandler s o a
forall s o a. DynHandler s o a -> StaHandler s o a
fromDynHandler [||$$qh $$(pos# inp) $$(off# inp)||])
bindIterHandlerInline# Bool
False Input# o -> StaHandler# s o a
h (Input# o -> StaHandler s o a) -> Code b
k = (Input# o -> StaHandler s o a) -> Code b
k (StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (StaHandler# s o a -> StaHandler s o a)
-> (Input# o -> StaHandler# s o a) -> Input# o -> StaHandler s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input# o -> StaHandler# s o a
h)
dynHandler :: forall s o a. MarshalOps o => AugmentedStaHandler s o a -> InputCharacteristic -> DynHandler s o a
dynHandler :: AugmentedStaHandler s o a
-> InputCharacteristic -> DynHandler s o a
dynHandler AugmentedStaHandler s o a
h = AugmentedStaHandler s o a
-> (StaHandler# s o a -> DynHandler s o a)
-> InputCharacteristic
-> DynHandler s o a
forall s o a.
AugmentedStaHandler s o a
-> (StaHandler# s o a -> DynHandler s o a)
-> InputCharacteristic
-> DynHandler s o a
staHandlerCharacteristicDyn AugmentedStaHandler s o a
h (DynHandler s o a -> DynHandler s o a
forall a b. Code (a -> b) -> Code (a -> b)
eta (DynHandler s o a -> DynHandler s o a)
-> (StaHandler# s o a -> DynHandler s o a)
-> StaHandler# s o a
-> DynHandler s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. MarshalOps o => StaHandler# s o a -> DynHandler s o a
forall o s a. MarshalOps o => StaHandler# s o a -> DynHandler s o a
dynHandler# @o)
dynCont :: forall s o a x. MarshalOps o => StaCont s o a x -> DynCont s o a x
dynCont :: StaCont s o a x -> DynCont s o a x
dynCont (StaCont StaCont# s o a x
sk Maybe (DynCont s o a x)
Nothing) = DynCont s o a x -> DynCont s o a x
forall a b. Code (a -> b) -> Code (a -> b)
eta (StaCont# s o a x -> DynCont s o a x
forall o s a x. MarshalOps o => StaCont# s o a x -> DynCont s o a x
dynCont# @o StaCont# s o a x
sk)
dynCont (StaCont StaCont# s o a x
_ (Just DynCont s o a x
dk)) = DynCont s o a x
dk
logHandler :: (?ops :: InputOps (Rep o), LogHandler o) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Word -> StaHandlerBuilder s o a
logHandler :: String
-> Ctx s o a
-> Γ s o xs ('Succ n) ks a
-> Word
-> StaHandlerBuilder s o a
logHandler String
name Ctx s o a
ctx Γ s o xs ('Succ n) ks a
γ Word
u Input o
_ = let VCons AugmentedStaHandler s o a
h Vec n (AugmentedStaHandler s o a)
_ = Γ s o xs ('Succ n) ks a
-> Vec ('Succ n) (AugmentedStaHandler s o a)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs ('Succ n) ks a
γ in StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (StaHandler# s o a -> StaHandler s o a)
-> StaHandler# s o a -> StaHandler s o a
forall a b. (a -> b) -> a -> b
$ \Input# o
inp# -> let inp :: Input o
inp = Word -> Input# o -> Input o
forall o. Word -> Input# o -> Input o
toInput Word
u Input# o
inp# in [||
trace $$(preludeString name '<' (γ {input = inp}) ctx (color Red " Fail")) $$(staHandlerEval h inp)
||]
preludeString :: forall s o xs n r a. (?ops :: InputOps (Rep o), LogHandler o)
=> String
-> Char
-> Γ s o xs n r a
-> Ctx s o a
-> String
-> Code String
preludeString :: String
-> Char -> Γ s o xs n r a -> Ctx s o a -> String -> Code String
preludeString String
name Char
dir Γ s o xs n r a
γ Ctx s o a
ctx String
ends = [|| concat [$$prelude, $$eof, ends, '\n' : $$caretSpace, color Blue "^"] ||]
where
offset :: Code (Rep o)
offset = Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
Offset.offset (Input o -> Offset o
forall o. Input o -> Offset o
off (Γ s o xs n r a -> Input o
forall s o (xs :: [Type]) (n :: Nat) r a. Γ s o xs n r a -> Input o
input Γ s o xs n r a
γ))
indent :: String
indent = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Ctx s o a -> Int
forall s o a. Ctx s o a -> Int
debugLevel Ctx s o a
ctx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Char
' '
start :: Code (Rep o)
start = Code (Rep o) -> Code Int# -> Code (Rep o)
forall rep. LogOps rep => Code rep -> Code Int# -> Code rep
shiftLeft Code (Rep o)
offset [||5#||]
end :: Code (Rep o)
end = Code (Rep o) -> Code Int# -> Code (Rep o)
forall rep. PositionOps rep => Code rep -> Code Int# -> Code rep
shiftRight Code (Rep o)
offset [||5#||]
inputTrace :: Code String
inputTrace = [|| let replace '\n' = color Green "↙"
replace ' ' = color White "·"
replace c = return c
go i#
| $$(same [||i#||] end) || not $$(more [||i#||]) = []
| otherwise = $$(next [||i#||] (\qc qi' -> [||replace $$qc ++ go $$qi'||]))
in go $$start ||]
eof :: Code String
eof = [|| if $$(more end) then $$inputTrace else $$inputTrace ++ color Red "•" ||]
prelude :: Code String
prelude = [|| concat [indent, dir : name, dir : " (", show $$(offToInt offset), "): "] ||]
caretSpace :: Code String
caretSpace = [|| replicate (length $$prelude + $$(offToInt offset) - $$(offToInt start)) ' ' ||]
type Ops o =
( HandlerOps o
, JoinBuilder o
, RecBuilder o
, PositionOps (Rep o)
, MarshalOps o
, LogOps (Rep o)
)
type LogHandler o = (PositionOps (Rep o), LogOps (Rep o))
type StaHandlerBuilder s o a = Input o -> StaHandler s o a
type StaYesHandler s o a = Input o -> Code (ST s (Maybe a))