{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Funcons.Entities (
getMut, putMut, getMutPatt, putMutTerm,
getInh, withInh, getInhPatt, withInhTerm,
raiseSignal, receiveSignals, raiseTerm, receiveSignalPatt,
withControlTerm, getControlPatt,
writeOut, readOut, writeOutTerm, readOutPatt,
matchInput, withExtraInput,withExactInput,
withExtraInputTerms, withExactInputTerms,
EntityDefaults, EntityDefault(..), setEntityDefaults
)where
import Funcons.Types
import Funcons.MSOS
import Funcons.Substitution
import Funcons.Exceptions
import Funcons.Patterns
import Control.Applicative
import Control.Arrow
import qualified Data.Map as M
import Data.Text
type EntityDefaults = [EntityDefault]
data EntityDefault = DefMutable Name Funcons
| DefInherited Name Funcons
| DefOutput Name
| DefControl Name
| DefInput Name
setEntityDefaults :: EntityDefaults -> MSOS StepRes -> MSOS StepRes
setEntityDefaults :: EntityDefaults -> MSOS StepRes -> MSOS StepRes
setEntityDefaults [] MSOS StepRes
msos = MSOS StepRes
msos
setEntityDefaults ((DefMutable Name
nm Funcons
f):EntityDefaults
rest) MSOS StepRes
msos =
forall a. Rewrite a -> MSOS a
liftRewrite (Funcons -> Rewrite Rewritten
rewriteFuncons Funcons
f) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ValTerm [Values]
vs -> Name -> [Values] -> MSOS ()
putMut Name
nm [Values]
vs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EntityDefaults -> MSOS StepRes -> MSOS StepRes
setEntityDefaults EntityDefaults
rest MSOS StepRes
msos
Rewritten
_ -> forall a. Rewrite a -> MSOS a
liftRewrite forall a b. (a -> b) -> a -> b
$ forall a. Funcons -> String -> Rewrite a
exception Funcons
f String
"default value requires steps to evaluate"
setEntityDefaults ((DefInherited Name
nm Funcons
f):EntityDefaults
rest) MSOS StepRes
msos =
forall a. Rewrite a -> MSOS a
liftRewrite (Funcons -> Rewrite Rewritten
rewriteFuncons Funcons
f) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ValTerm [Values]
vs -> forall a. Name -> [Values] -> MSOS a -> MSOS a
withInh Name
nm [Values]
vs (EntityDefaults -> MSOS StepRes -> MSOS StepRes
setEntityDefaults EntityDefaults
rest MSOS StepRes
msos)
Rewritten
_ -> forall a. Rewrite a -> MSOS a
liftRewrite forall a b. (a -> b) -> a -> b
$ forall a. Funcons -> String -> Rewrite a
exception Funcons
f String
"default value requires steps to evaluate"
setEntityDefaults ((DefControl Name
nm):EntityDefaults
rest) MSOS StepRes
msos =
forall a. Name -> Maybe Values -> MSOS a -> MSOS a
withControl Name
nm forall a. Maybe a
Nothing (EntityDefaults -> MSOS StepRes -> MSOS StepRes
setEntityDefaults EntityDefaults
rest MSOS StepRes
msos)
setEntityDefaults (EntityDefault
_:EntityDefaults
rest) MSOS StepRes
msos = EntityDefaults -> MSOS StepRes -> MSOS StepRes
setEntityDefaults EntityDefaults
rest MSOS StepRes
msos
emptyMUT :: Mutable
emptyMUT :: Mutable
emptyMUT = forall k a. Map k a
M.empty
giveMUT :: MSOS Mutable
giveMUT :: MSOS Mutable
giveMUT = forall a.
(forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS forall a b. (a -> b) -> a -> b
$ \MSOSReader m
ctxt MSOSState m
mut -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (forall (m :: * -> *). MSOSState m -> Mutable
mut_entities MSOSState m
mut), MSOSState m
mut, forall a. Monoid a => a
mempty)
getMut :: Name -> MSOS [Values]
getMut :: Name -> MSOS [Values]
getMut Name
key = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [forall t. Values t
null__] forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
key forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MSOS Mutable
giveMUT
getMutPatt :: Name -> [VPattern] -> Env -> MSOS Env
getMutPatt :: Name -> [VPattern] -> Env -> MSOS Env
getMutPatt Name
nm [VPattern]
pats Env
env = do
[Values]
vals <- Name -> MSOS [Values]
getMut Name
nm
forall a. Rewrite a -> MSOS a
liftRewrite ([Values] -> [VPattern] -> Env -> Rewrite Env
vsMatch [Values]
vals [VPattern]
pats Env
env)
modifyMUT :: Name -> ([Values] -> [Values]) -> MSOS ()
modifyMUT :: Name -> ([Values] -> [Values]) -> MSOS ()
modifyMUT Name
key [Values] -> [Values]
f = do Mutable
rw <- MSOS Mutable
giveMUT
Mutable -> MSOS ()
newMUT (forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter Maybe [Values] -> Maybe [Values]
up Name
key Mutable
rw)
where up :: Maybe [Values] -> Maybe [Values]
up Maybe [Values]
Nothing = forall a. a -> Maybe a
Just ([Values] -> [Values]
f [forall t. Values t
null__])
up (Just [Values]
xs) = forall a. a -> Maybe a
Just ([Values] -> [Values]
f [Values]
xs)
putMut :: Name -> [Values] -> MSOS ()
putMut :: Name -> [Values] -> MSOS ()
putMut Name
key [Values]
v = do Mutable
rw <- MSOS Mutable
giveMUT
Mutable -> MSOS ()
newMUT (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
key [Values]
v Mutable
rw)
putMutTerm :: Name -> FTerm -> Env -> MSOS ()
putMutTerm :: Name -> FTerm -> Env -> MSOS ()
putMutTerm Name
nm FTerm
term Env
env = forall a. Rewrite a -> MSOS a
liftRewrite (FTerm -> Env -> Rewrite [Values]
subsAndRewritesToValues FTerm
term Env
env) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> [Values] -> MSOS ()
putMut Name
nm
newMUT :: Mutable -> MSOS ()
newMUT :: Mutable -> MSOS ()
newMUT Mutable
rw = forall a.
(forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS forall a b. (a -> b) -> a -> b
$ \MSOSReader m
ctxt MSOSState m
mut-> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right(), MSOSState m
mut {mut_entities :: Mutable
mut_entities = Mutable
rw}, forall a. Monoid a => a
mempty)
consumeInput :: Name -> MSOS Funcons
consumeInput :: Name -> MSOS Funcons
consumeInput Name
nm = forall a.
(forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS forall a b. (a -> b) -> a -> b
$ \MSOSReader m
ctxt MSOSState m
mut ->
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
nm (forall (m :: * -> *). MSOSState m -> Input m
inp_es MSOSState m
mut) of
Just ([[Values]]
vss, Maybe (m Funcons)
mreadM) -> forall {m :: * -> *} {c} {m :: * -> *}.
(Monad m, Monoid c) =>
MSOSReader m
-> MSOSState m
-> [[Values]]
-> Maybe (m Funcons)
-> m (Either IException Funcons, MSOSState m, c)
wrapAttempt MSOSReader m
ctxt MSOSState m
mut [[Values]]
vss Maybe (m Funcons)
mreadM
Maybe ([[Values]], Maybe (m Funcons))
Nothing -> forall {m :: * -> *} {c} {m :: * -> *}.
(Monad m, Monoid c) =>
MSOSReader m
-> MSOSState m
-> [[Values]]
-> Maybe (m Funcons)
-> m (Either IException Funcons, MSOSState m, c)
wrapAttempt MSOSReader m
ctxt MSOSState m
mut [] (forall a. a -> Maybe a
Just (forall (m :: * -> *). MSOSReader m -> Name -> m Funcons
def_fread MSOSReader m
ctxt Name
nm))
where
wrapAttempt :: MSOSReader m
-> MSOSState m
-> [[Values]]
-> Maybe (m Funcons)
-> m (Either IException Funcons, MSOSState m, c)
wrapAttempt MSOSReader m
ctxt MSOSState m
mut [[Values]]
vss Maybe (m Funcons)
mreadM = case forall a. [[a]] -> Maybe (a, [[a]])
attemptConsume [[Values]]
vss of
Just (Values
v,[[Values]]
vss') -> forall (m :: * -> *) a. Monad m => a -> m a
return
(forall a b. b -> Either a b
Right (Values -> Funcons
FValue Values
v), MSOSState m
mut {inp_es :: Input m
inp_es = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
nm ([[Values]]
vss',Maybe (m Funcons)
mreadM) (forall (m :: * -> *). MSOSState m -> Input m
inp_es MSOSState m
mut)},forall a. Monoid a => a
mempty)
Maybe (Values, [[Values]])
Nothing -> case Maybe (m Funcons)
mreadM of
Maybe (m Funcons)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return
(forall a b. a -> Either a b
Left (forall (m :: * -> *). IE -> MSOSReader m -> IException
ctxt2exception (Name -> IE
InsufficientInput Name
nm) MSOSReader m
ctxt), MSOSState m
mut, forall a. Monoid a => a
mempty)
Just m Funcons
readM -> do Funcons
v <- m Funcons
readM
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Funcons
v, MSOSState m
mut, forall a. Monoid a => a
mempty)
attemptConsume :: [[a]] -> Maybe (a,[[a]])
attemptConsume :: forall a. [[a]] -> Maybe (a, [[a]])
attemptConsume [] = forall a. Maybe a
Nothing
attemptConsume ((a
v:[a]
vs):[[a]]
vss) = forall a. a -> Maybe a
Just (a
v,[a]
vsforall a. a -> [a] -> [a]
:[[a]]
vss)
attemptConsume ([]:[[a]]
vss) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ([]forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [[a]] -> Maybe (a, [[a]])
attemptConsume [[a]]
vss
withExtraInput :: Name -> [Values] -> MSOS a -> MSOS a
= forall a. Bool -> Name -> [Values] -> MSOS a -> MSOS a
withInput Bool
False
withExactInput :: Name -> [Values] -> MSOS a -> MSOS a
withExactInput :: forall a. Name -> [Values] -> MSOS a -> MSOS a
withExactInput = forall a. Bool -> Name -> [Values] -> MSOS a -> MSOS a
withInput Bool
True
withInput :: Bool -> Name -> [Values] -> MSOS a -> MSOS a
withInput :: forall a. Bool -> Name -> [Values] -> MSOS a -> MSOS a
withInput Bool
isExactInput Name
nm [Values]
vs (MSOS forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
f) = forall a.
(forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS forall a b. (a -> b) -> a -> b
$ \MSOSReader m
ctxt MSOSState m
mut -> do
let provideInput :: ([[Values]], Maybe (m Funcons))
-> Maybe (m Funcons)
-> m (Either IException a, MSOSState m, MSOSWriter)
provideInput ([[Values]], Maybe (m Funcons))
newInp Maybe (m Funcons)
mreadM = do
(Either IException a
a,MSOSState m
mut',MSOSWriter
wr') <- forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
f MSOSReader m
ctxt MSOSState m
mut{ inp_es :: Input m
inp_es = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
nm ([[Values]], Maybe (m Funcons))
newInp (forall (m :: * -> *). MSOSState m -> Input m
inp_es MSOSState m
mut)}
let (Either IException a
res,[[Values]]
vss'') = case (forall (m :: * -> *). MSOSState m -> Input m
inp_es MSOSState m
mut') forall k a. Ord k => Map k a -> k -> a
M.! Name
nm of
([]:[[Values]]
vss',Maybe (m Funcons)
_) -> (Either IException a
a, [[Values]]
vss')
([[Values]], Maybe (m Funcons))
_ -> (forall a b. a -> Either a b
Left(forall (m :: * -> *). IE -> MSOSReader m -> IException
ctxt2exception(Name -> IE
InsufficientInputConsumed Name
nm) MSOSReader m
ctxt), [[Values]]
vss'')
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IException a
res, MSOSState m
mut' {inp_es :: Input m
inp_es = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
nm ([[Values]]
vss'',Maybe (m Funcons)
mreadM) (forall (m :: * -> *). MSOSState m -> Input m
inp_es MSOSState m
mut')}, MSOSWriter
wr')
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
nm (forall (m :: * -> *). MSOSState m -> Input m
inp_es MSOSState m
mut) of
Just ([[Values]]
vss, Maybe (m Funcons)
mreadM) ->
([[Values]], Maybe (m Funcons))
-> Maybe (m Funcons)
-> m (Either IException a, MSOSState m, MSOSWriter)
provideInput ([Values]
vsforall a. a -> [a] -> [a]
:[[Values]]
vss, if Bool
isExactInput then forall a. Maybe a
Nothing else Maybe (m Funcons)
mreadM) Maybe (m Funcons)
mreadM
Maybe ([[Values]], Maybe (m Funcons))
Nothing -> ([[Values]], Maybe (m Funcons))
-> Maybe (m Funcons)
-> m (Either IException a, MSOSState m, MSOSWriter)
provideInput ([[Values]
vs], forall a. Maybe a
Nothing) forall a. Maybe a
Nothing
matchInput :: Name -> VPattern -> Env -> MSOS Env
matchInput :: Name -> VPattern -> Env -> MSOS Env
matchInput Name
nm VPattern
pat Env
env = do
Funcons
fs <- Name -> MSOS Funcons
consumeInput Name
nm
[Values]
vs <- forall a. Rewrite a -> MSOS a
liftRewrite (Funcons -> Rewrite [Values]
rewritesToValues Funcons
fs)
forall a. Rewrite a -> MSOS a
liftRewrite ([Values] -> [VPattern] -> Env -> Rewrite Env
vsMatch [Values]
vs [VPattern
pat] Env
env)
= forall a. Bool -> Name -> [FTerm] -> Env -> MSOS a -> MSOS a
withInputTerms Bool
False
withExactInputTerms :: Name -> [FTerm] -> Env -> MSOS a -> MSOS a
withExactInputTerms = forall a. Bool -> Name -> [FTerm] -> Env -> MSOS a -> MSOS a
withInputTerms Bool
True
withInputTerms :: Bool -> Name -> [FTerm] -> Env -> MSOS a -> MSOS a
withInputTerms :: forall a. Bool -> Name -> [FTerm] -> Env -> MSOS a -> MSOS a
withInputTerms Bool
b Name
nm [FTerm]
fs Env
env MSOS a
msos = do
[Values]
vs <- forall a. Rewrite a -> MSOS a
liftRewrite (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> b -> a -> c
flip FTerm -> Env -> Rewrite Values
subsAndRewritesToValue Env
env) [FTerm]
fs)
forall a. Bool -> Name -> [Values] -> MSOS a -> MSOS a
withInput Bool
b Name
nm [Values]
vs MSOS a
msos
receiveSignals :: [Name] -> MSOS a -> MSOS (a, [Maybe Values])
receiveSignals :: forall a. [Name] -> MSOS a -> MSOS (a, [Maybe Values])
receiveSignals [Name]
keys (MSOS forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
f) = forall a.
(forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS (\MSOSReader m
ctxt MSOSState m
mut -> do
(Either IException a
e_a, MSOSState m
mut1, MSOSWriter
wr1) <- forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
f MSOSReader m
ctxt MSOSState m
mut
case Either IException a
e_a of
Left IException
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left IException
err, MSOSState m
mut1, MSOSWriter
wr1)
Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
(forall a b. b -> Either a b
Right (a
a, forall a b. (a -> b) -> [a] -> [b]
Prelude.map (forall {k} {a}. Ord k => Map k (Maybe a) -> k -> Maybe a
find (MSOSWriter -> Control
ctrl_entities MSOSWriter
wr1)) [Name]
keys)
, MSOSState m
mut1, MSOSWriter
wr1 {ctrl_entities :: Control
ctrl_entities = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Prelude.foldr forall k a. Ord k => k -> Map k a -> Map k a
M.delete (MSOSWriter -> Control
ctrl_entities MSOSWriter
wr1) [Name]
keys}))
where find :: Map k (Maybe a) -> k -> Maybe a
find Map k (Maybe a)
m k
key = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
key Map k (Maybe a)
m
receiveSignalPatt :: Maybe Values -> Maybe VPattern -> Env -> MSOS Env
receiveSignalPatt :: Maybe Values -> Maybe VPattern -> Env -> MSOS Env
receiveSignalPatt Maybe Values
mval Maybe VPattern
mpat Env
env = forall a. Rewrite a -> MSOS a
liftRewrite (Maybe Values -> Maybe VPattern -> Env -> Rewrite Env
vMaybeMatch Maybe Values
mval Maybe VPattern
mpat Env
env)
raiseSignal :: Name -> Values -> MSOS ()
raiseSignal :: Name -> Values -> MSOS ()
raiseSignal Name
nm Values
v = forall a.
(forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS (\MSOSReader m
ctxt MSOSState m
mut -> forall (m :: * -> *) a. Monad m => a -> m a
return
(forall a b. b -> Either a b
Right (), MSOSState m
mut, forall a. Monoid a => a
mempty { ctrl_entities :: Control
ctrl_entities = Name -> Values -> Control
singleCTRL Name
nm Values
v}))
raiseTerm :: Name -> FTerm -> Env -> MSOS ()
raiseTerm :: Name -> FTerm -> Env -> MSOS ()
raiseTerm Name
nm FTerm
term Env
env = forall a. Rewrite a -> MSOS a
liftRewrite (FTerm -> Env -> Rewrite Values
subsAndRewritesToValue FTerm
term Env
env) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Values -> MSOS ()
raiseSignal Name
nm
withControl :: Name -> Maybe Values -> MSOS a -> MSOS a
withControl :: forall a. Name -> Maybe Values -> MSOS a -> MSOS a
withControl Name
key Maybe Values
mfct (MSOS forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
f) = forall a.
(forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS (\MSOSReader m
ctxt MSOSState m
mut ->
let ctxt' :: MSOSReader m
ctxt' = MSOSReader m
ctxt { dctrl_entities :: Control
dctrl_entities = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
key Maybe Values
mfct (forall (m :: * -> *). MSOSReader m -> Control
dctrl_entities MSOSReader m
ctxt) }
in forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
f MSOSReader m
ctxt' MSOSState m
mut)
withControlTerm :: Name -> Maybe FTerm -> Env -> MSOS a -> MSOS a
withControlTerm :: forall a. Name -> Maybe FTerm -> Env -> MSOS a -> MSOS a
withControlTerm Name
nm Maybe FTerm
mterm Env
env MSOS a
msos = do
Maybe Values
mfct <- case Maybe FTerm
mterm of
Maybe FTerm
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just FTerm
term -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Rewrite a -> MSOS a
liftRewrite (FTerm -> Env -> Rewrite Values
substitute_signal FTerm
term Env
env)
forall a. Name -> Maybe Values -> MSOS a -> MSOS a
withControl Name
nm Maybe Values
mfct MSOS a
msos
getControl :: Name -> MSOS (Maybe Values)
getControl :: Name -> MSOS (Maybe Values)
getControl Name
key = do
Control
ro <- MSOS Control
giveCTRL
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
key Control
ro of
Maybe (Maybe Values)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Maybe Values
mv -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Values
mv
getControlPatt :: Name -> Maybe VPattern -> Env -> MSOS Env
getControlPatt :: Name -> Maybe VPattern -> Env -> MSOS Env
getControlPatt Name
nm Maybe VPattern
mpat Env
env = do
Maybe VPattern
mpat' <- forall a. Rewrite a -> MSOS a
liftRewrite forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip VPattern -> Env -> Rewrite VPattern
substitute_patt_signal Env
env) Maybe VPattern
mpat
Maybe Values
mfct <- Name -> MSOS (Maybe Values)
getControl Name
nm
forall a. Rewrite a -> MSOS a
liftRewrite (forall a. Rewrite a -> Rewrite (Either IException a)
eval_catch (Maybe Values -> Maybe VPattern -> Env -> Rewrite Env
vMaybeMatch Maybe Values
mfct Maybe VPattern
mpat' Env
env) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (Funcons
_,Funcons
_,PatternMismatch String
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Env
env
Left IException
exc -> forall a. IException -> Rewrite a
rewrite_rethrow IException
exc
Right Env
env' -> forall (m :: * -> *) a. Monad m => a -> m a
return Env
env')
getInh :: Name -> MSOS [Values]
getInh :: Name -> MSOS [Values]
getInh Name
key = do Mutable
ro <- MSOS Mutable
giveINH
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
key Mutable
ro of
Maybe [Values]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return [forall t. Values t
null__]
Just [Values]
vs -> forall (m :: * -> *) a. Monad m => a -> m a
return [Values]
vs
getInhPatt :: Name -> [VPattern] -> Env -> MSOS Env
getInhPatt :: Name -> [VPattern] -> Env -> MSOS Env
getInhPatt Name
nm [VPattern]
pats Env
env = do
[Values]
vals <- Name -> MSOS [Values]
getInh Name
nm
forall a. Rewrite a -> MSOS a
liftRewrite ([Values] -> [VPattern] -> Env -> Rewrite Env
vsMatch [Values]
vals [VPattern]
pats Env
env)
withInh :: Name -> [Values] -> MSOS a -> MSOS a
withInh :: forall a. Name -> [Values] -> MSOS a -> MSOS a
withInh Name
key [Values]
v (MSOS forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
f) = forall a.
(forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS (\MSOSReader m
ctxt MSOSState m
mut ->
let ctxt' :: MSOSReader m
ctxt' = MSOSReader m
ctxt { inh_entities :: Mutable
inh_entities = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
key [Values]
v (forall (m :: * -> *). MSOSReader m -> Mutable
inh_entities MSOSReader m
ctxt) }
in forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
f MSOSReader m
ctxt' MSOSState m
mut)
withInhTerm :: Name -> FTerm -> Env -> MSOS a -> MSOS a
withInhTerm :: forall a. Name -> FTerm -> Env -> MSOS a -> MSOS a
withInhTerm Name
nm FTerm
term Env
env MSOS a
msos = do
[Values]
v <- forall a. Rewrite a -> MSOS a
liftRewrite forall a b. (a -> b) -> a -> b
$ (FTerm -> Env -> Rewrite [Values]
subsAndRewritesToValues FTerm
term Env
env)
forall a. Name -> [Values] -> MSOS a -> MSOS a
withInh Name
nm [Values]
v MSOS a
msos
writeOut :: Name -> [Values] -> MSOS ()
writeOut :: Name -> [Values] -> MSOS ()
writeOut Name
key [Values]
vs = forall a.
(forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS forall a b. (a -> b) -> a -> b
$ \MSOSReader m
ctxt MSOSState m
mut -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (), MSOSState m
mut
,forall a. Monoid a => a
mempty { out_entities :: Mutable
out_entities = forall k a. k -> a -> Map k a
M.singleton Name
key [Values]
vs })
writeOutTerm :: Name -> FTerm -> Env -> MSOS ()
writeOutTerm :: Name -> FTerm -> Env -> MSOS ()
writeOutTerm Name
nm FTerm
term Env
env =
forall a. Rewrite a -> MSOS a
liftRewrite (FTerm -> Env -> Rewrite [Values]
subsAndRewritesToValues FTerm
term Env
env) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> [Values] -> MSOS ()
writeOut Name
nm
readOut :: Name -> MSOS a -> MSOS (a,[Values])
readOut :: forall a. Name -> MSOS a -> MSOS (a, [Values])
readOut Name
key MSOS a
msos = forall a. MSOS a -> MSOS (a, Mutable)
readOuts MSOS a
msos forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
key)
readOutPatt :: Name -> VPattern -> MSOS Env -> MSOS Env
readOutPatt :: Name -> VPattern -> MSOS Env -> MSOS Env
readOutPatt Name
key VPattern
pat MSOS Env
msos = do
(Env
env, [Values]
vals) <- forall a. Name -> MSOS a -> MSOS (a, [Values])
readOut Name
key MSOS Env
msos
forall a. Rewrite a -> MSOS a
liftRewrite (Values -> VPattern -> Env -> Rewrite Env
vMatch (forall t. Name -> [t] -> Values t
ADTVal Name
"list" (forall a b. (a -> b) -> [a] -> [b]
Prelude.map Values -> Funcons
FValue [Values]
vals)) VPattern
pat Env
env)