{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Funcons.Entities (
    -- * Accessing entities
        -- ** mutables
        getMut, putMut, getMutPatt, putMutTerm,
        -- ** inherited
        getInh, withInh, getInhPatt, withInhTerm,
        -- ** control
        raiseSignal, receiveSignals, raiseTerm, receiveSignalPatt,
        withControlTerm, getControlPatt,
        -- ** output
        writeOut, readOut, writeOutTerm, readOutPatt,
        -- ** input
        matchInput, withExtraInput,withExactInput,
            withExtraInputTerms, withExactInputTerms,
    -- * Default entity values
        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

-- defaults
-- | A list of 'EntityDefault's is used to declare (and possibly initialise)
-- entities.
type EntityDefaults = [EntityDefault]
-- | Default values of entities can be specified for /inherited/ 
-- and /mutable/ entities. 
data EntityDefault  = DefMutable Name Funcons   
                    | DefInherited Name Funcons 
                    -- | For the purpose of unit-testing it is advised to notify an interpreter of the existence of control, output and input entities as well.
                    | 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

----------------------------------------------------
--- accessing entities

-- mutables

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)

-- | Get the value of some mutable entity.
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 

-- | Variant of 'getMut' that performs pattern-matching.
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)

-- | Set the value of some mutable entity.
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)

-- | Variant of 'putMut' that applies substitution.
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)


-- input
-- | Consume a single value from the input stream.
-- | Throws an 'unsufficient input' exception, if not enough input is available.
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

-- | Provides /extra/ values to a certain input entity, available
-- to be consumed by the given 'MSOS' computation argument.
withExtraInput :: Name -> [Values] -> MSOS a -> MSOS a 
withExtraInput :: forall a. Name -> [Values] -> MSOS a -> MSOS a
withExtraInput = forall a. Bool -> Name -> [Values] -> MSOS a -> MSOS a
withInput Bool
False

-- | Provides an /exact/ amount of input for some input entity, 
-- that is to be /completely/ consumed by the given 'MSOS' computation.
-- If less output is consumed a 'insufficient input consumed' exception
-- is thrown.
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

-- | Variant of 'consumeInput' that matches the given `VPattern` to the consumed
-- value in the given 'Env'. 
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)

-- | Variant of 'withExtraInput' that performs substitution.
withExtraInputTerms :: Name -> [FTerm] -> Env -> MSOS a -> MSOS a
withExtraInputTerms = forall a. Bool -> Name -> [FTerm] -> Env -> MSOS a -> MSOS a
withInputTerms Bool
False
-- | Variant of 'withExactInput' that performs substitution.
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

-- control
-- | Receive the value of a control entity from a given 'MSOS' computation.
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

-- | Variant of 'receiveSignal' that performs pattern-matching.
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)

-- | Signal a value of some control entity.
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}))

-- | Variant of 'raiseSignal' that applies substitution.
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 

-- downwards control
-- | Set the value of an downwards control entity. 
-- The new value is /only/ set for 'MSOS' computation given as a third argument.
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

-- | Get the value of an down control entity.
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

-- | Version of 'getControl' that applies pattern-matching.
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 --TODO suboptimal 
      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')


-- inherited

-- | Get the value of an inherited entity.
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

-- | Version of 'getInh' that applies pattern-matching.
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)

-- | Set the value of an inherited entity. 
-- The new value is /only/ set for 'MSOS' computation given as a third argument.
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)

-- | Variant of 'withInh' that performs substitution.
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

-- output
-- | Add new values to a certain output entity.
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 })

-- | Variant of 'writeOut' that applies substitution.
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

-- | Read the values of a certain output entity. The output is obtained
-- from the 'MSOS' computation given as a second argument.
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)

-- | Variant of 'readOut' that performs pattern-matching.
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)