{-# LANGUAGE OverloadedStrings #-}
module Funcons.Core.Computations.Abnormal.Postponing.Postponing where
import Funcons.EDSL
import Funcons.Operations hiding (Values,libFromList)
entities :: [a]
entities = []
types :: TypeRelation
types = [(Name, DataTypeMembers)] -> TypeRelation
typeEnvFromList
[]
funcons :: FunconLibrary
funcons = [(Name, EvalFunction)] -> FunconLibrary
libFromList
[(Name
"postpone",NonStrictFuncon -> EvalFunction
NonStrictFuncon NonStrictFuncon
stepPostpone),(Name
"postpone-after-effect",NonStrictFuncon -> EvalFunction
NonStrictFuncon NonStrictFuncon
stepPostpone_after_effect),(Name
"after-effect",NonStrictFuncon -> EvalFunction
NonStrictFuncon NonStrictFuncon
stepAfter_effect)]
postpone_ :: [Funcons] -> Funcons
postpone_ [Funcons]
fargs = Name -> [Funcons] -> Funcons
FApp Name
"postpone" ([Funcons]
fargs)
stepPostpone :: NonStrictFuncon
stepPostpone [Funcons]
fargs =
[Rewrite Rewritten] -> [MSOS StepRes] -> Rewrite Rewritten
evalRules [] [MSOS StepRes
step1,MSOS StepRes
step2]
where step1 :: MSOS StepRes
step1 = do
let env :: Map k a
env = forall {k} {a}. Map k a
emptyEnv
Env
env <- [Funcons] -> [FPattern] -> Env -> MSOS Env
lifted_fsMatch [Funcons]
fargs [MetaVar -> FPattern
PMetaVar MetaVar
"X"] forall {k} {a}. Map k a
env
Env
env <- Name -> [VPattern] -> Env -> MSOS Env
getInhPatt Name
"given-value" [MetaVar -> VPattern
VPMetaVar MetaVar
"V"] Env
env
Env
env <- Name -> Maybe VPattern -> Env -> MSOS Env
getControlPatt Name
"postponing" (forall a. a -> Maybe a
Just (MetaVar -> VPattern
VPMetaVar MetaVar
"A")) Env
env
(Env
env,[Maybe Values
__varpostponing]) <- forall a. [Name] -> MSOS a -> MSOS (a, [Maybe Values])
receiveSignals [Name
"postponing"] (forall a. Name -> Maybe FTerm -> Env -> MSOS a -> MSOS a
withControlTerm Name
"postponing" (forall a. Maybe a
Nothing) Env
env (forall a. Name -> FTerm -> Env -> MSOS a -> MSOS a
withInhTerm Name
"given-value" (MetaVar -> FTerm
TVar MetaVar
"V") Env
env (FTerm -> [FPattern] -> Env -> MSOS Env
premise (Name -> [FTerm] -> FTerm
TApp Name
"closure" [Name -> [FTerm] -> FTerm
TApp Name
"give" [MetaVar -> FTerm
TVar MetaVar
"V",MetaVar -> FTerm
TVar MetaVar
"X"]]) [MetaVar -> FPattern
PMetaVar MetaVar
"A"] Env
env)))
Env
env <- Maybe Values -> Maybe VPattern -> Env -> MSOS Env
receiveSignalPatt Maybe Values
__varpostponing (forall a. Maybe a
Nothing) Env
env
Name -> FTerm -> Env -> MSOS ()
raiseTerm Name
"postponing" (MetaVar -> FTerm
TVar MetaVar
"A") Env
env
FTerm -> Env -> MSOS StepRes
stepTermTo (Name -> FTerm
TName Name
"null-value") Env
env
step2 :: MSOS StepRes
step2 = do
let env :: Map k a
env = forall {k} {a}. Map k a
emptyEnv
Env
env <- [Funcons] -> [FPattern] -> Env -> MSOS Env
lifted_fsMatch [Funcons]
fargs [MetaVar -> FPattern
PMetaVar MetaVar
"X"] forall {k} {a}. Map k a
env
Env
env <- Name -> [VPattern] -> Env -> MSOS Env
getInhPatt Name
"given-value" [] Env
env
Env
env <- Name -> Maybe VPattern -> Env -> MSOS Env
getControlPatt Name
"postponing" (forall a. a -> Maybe a
Just (MetaVar -> VPattern
VPMetaVar MetaVar
"A")) Env
env
(Env
env,[Maybe Values
__varpostponing]) <- forall a. [Name] -> MSOS a -> MSOS (a, [Maybe Values])
receiveSignals [Name
"postponing"] (forall a. Name -> Maybe FTerm -> Env -> MSOS a -> MSOS a
withControlTerm Name
"postponing" (forall a. Maybe a
Nothing) Env
env (forall a. Name -> FTerm -> Env -> MSOS a -> MSOS a
withInhTerm Name
"given-value" ([FTerm] -> FTerm
TSeq []) Env
env (FTerm -> [FPattern] -> Env -> MSOS Env
premise (Name -> [FTerm] -> FTerm
TApp Name
"closure" [Name -> [FTerm] -> FTerm
TApp Name
"no-given" [MetaVar -> FTerm
TVar MetaVar
"X"]]) [MetaVar -> FPattern
PMetaVar MetaVar
"A"] Env
env)))
Env
env <- Maybe Values -> Maybe VPattern -> Env -> MSOS Env
receiveSignalPatt Maybe Values
__varpostponing (forall a. Maybe a
Nothing) Env
env
Name -> FTerm -> Env -> MSOS ()
raiseTerm Name
"postponing" (MetaVar -> FTerm
TVar MetaVar
"A") Env
env
FTerm -> Env -> MSOS StepRes
stepTermTo (Name -> FTerm
TName Name
"null-value") Env
env
postpone_after_effect_ :: [Funcons] -> Funcons
postpone_after_effect_ [Funcons]
fargs = Name -> [Funcons] -> Funcons
FApp Name
"postpone-after-effect" ([Funcons]
fargs)
stepPostpone_after_effect :: NonStrictFuncon
stepPostpone_after_effect [Funcons]
fargs =
[Rewrite Rewritten] -> [MSOS StepRes] -> Rewrite Rewritten
evalRules [Rewrite Rewritten
rewrite1] [MSOS StepRes
step1,MSOS StepRes
step2]
where rewrite1 :: Rewrite Rewritten
rewrite1 = do
let env :: Map k a
env = forall {k} {a}. Map k a
emptyEnv
Env
env <- [Funcons] -> [FPattern] -> Env -> Rewrite Env
fsMatch [Funcons]
fargs [FPattern -> FTerm -> FPattern
PAnnotated (MetaVar -> FPattern
PMetaVar MetaVar
"V") (Name -> FTerm
TName Name
"values")] forall {k} {a}. Map k a
env
FTerm -> Env -> Rewrite Rewritten
rewriteTermTo (MetaVar -> FTerm
TVar MetaVar
"V") Env
env
step1 :: MSOS StepRes
step1 = do
let env :: Map k a
env = forall {k} {a}. Map k a
emptyEnv
Env
env <- [Funcons] -> [FPattern] -> Env -> MSOS Env
lifted_fsMatch [Funcons]
fargs [MetaVar -> FPattern
PMetaVar MetaVar
"X"] forall {k} {a}. Map k a
env
Env
env <- Name -> Maybe VPattern -> Env -> MSOS Env
getControlPatt Name
"postponing" (forall a. Maybe a
Nothing) Env
env
(Env
env,[Maybe Values
__varpostponing]) <- forall a. [Name] -> MSOS a -> MSOS (a, [Maybe Values])
receiveSignals [Name
"postponing"] (forall a. Name -> Maybe FTerm -> Env -> MSOS a -> MSOS a
withControlTerm Name
"postponing" (forall a. Maybe a
Nothing) Env
env (FTerm -> [FPattern] -> Env -> MSOS Env
premise (MetaVar -> FTerm
TVar MetaVar
"X") [MetaVar -> FPattern
PMetaVar MetaVar
"X'"] Env
env))
Env
env <- Maybe Values -> Maybe VPattern -> Env -> MSOS Env
receiveSignalPatt Maybe Values
__varpostponing (forall a. Maybe a
Nothing) Env
env
FTerm -> Env -> MSOS StepRes
stepTermTo (Name -> [FTerm] -> FTerm
TApp Name
"postpone-after-effect" [MetaVar -> FTerm
TVar MetaVar
"X'"]) Env
env
step2 :: MSOS StepRes
step2 = do
let env :: Map k a
env = forall {k} {a}. Map k a
emptyEnv
Env
env <- [Funcons] -> [FPattern] -> Env -> MSOS Env
lifted_fsMatch [Funcons]
fargs [MetaVar -> FPattern
PMetaVar MetaVar
"X"] forall {k} {a}. Map k a
env
Env
env <- Name -> Maybe VPattern -> Env -> MSOS Env
getControlPatt Name
"postponing" (forall a. Maybe a
Nothing) Env
env
(Env
env,[Maybe Values
__varpostponing]) <- forall a. [Name] -> MSOS a -> MSOS (a, [Maybe Values])
receiveSignals [Name
"postponing"] (forall a. Name -> Maybe FTerm -> Env -> MSOS a -> MSOS a
withControlTerm Name
"postponing" (forall a. a -> Maybe a
Just (MetaVar -> FTerm
TVar MetaVar
"A")) Env
env (FTerm -> [FPattern] -> Env -> MSOS Env
premise (MetaVar -> FTerm
TVar MetaVar
"X") [MetaVar -> FPattern
PMetaVar MetaVar
"X'"] Env
env))
Env
env <- Maybe Values -> Maybe VPattern -> Env -> MSOS Env
receiveSignalPatt Maybe Values
__varpostponing (forall a. a -> Maybe a
Just (MetaVar -> VPattern
VPMetaVar MetaVar
"A")) Env
env
Env
env <- SideCondition -> Env -> MSOS Env
lifted_sideCondition (FTerm -> [VPattern] -> SideCondition
SCPatternMatch (MetaVar -> FTerm
TVar MetaVar
"A") [Name -> [VPattern] -> VPattern
PADT Name
"abstraction" [MetaVar -> VPattern
VPMetaVar MetaVar
"Y"]]) Env
env
FTerm -> Env -> MSOS StepRes
stepTermTo (Name -> [FTerm] -> FTerm
TApp Name
"postpone-after-effect" [Name -> [FTerm] -> FTerm
TApp Name
"after-effect" [MetaVar -> FTerm
TVar MetaVar
"X'",MetaVar -> FTerm
TVar MetaVar
"Y"]]) Env
env
after_effect_ :: [Funcons] -> Funcons
after_effect_ [Funcons]
fargs = Name -> [Funcons] -> Funcons
FApp Name
"after-effect" ([Funcons]
fargs)
stepAfter_effect :: NonStrictFuncon
stepAfter_effect [Funcons]
fargs =
[Rewrite Rewritten] -> [MSOS StepRes] -> Rewrite Rewritten
evalRules [Rewrite Rewritten
rewrite1] []
where rewrite1 :: Rewrite Rewritten
rewrite1 = do
let env :: Map k a
env = forall {k} {a}. Map k a
emptyEnv
Env
env <- [Funcons] -> [FPattern] -> Env -> Rewrite Env
fsMatch [Funcons]
fargs [MetaVar -> FPattern
PMetaVar MetaVar
"X",MetaVar -> FPattern
PMetaVar MetaVar
"Y"] forall {k} {a}. Map k a
env
FTerm -> Env -> Rewrite Rewritten
rewriteTermTo (Name -> [FTerm] -> FTerm
TApp Name
"give" [MetaVar -> FTerm
TVar MetaVar
"X",Name -> [FTerm] -> FTerm
TApp Name
"sequential" [MetaVar -> FTerm
TVar MetaVar
"Y",Name -> FTerm
TName Name
"given"]]) Env
env