{-# 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 = 
    Rewrite Rewritten -> MSOS Rewritten
forall a. Rewrite a -> MSOS a
liftRewrite (Funcons -> Rewrite Rewritten
rewriteFuncons Funcons
f) MSOS Rewritten -> (Rewritten -> MSOS StepRes) -> MSOS StepRes
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case 
        ValTerm [Values
v] -> Name -> Values -> MSOS ()
putMut Name
nm Values
v MSOS () -> MSOS StepRes -> MSOS StepRes
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EntityDefaults -> MSOS StepRes -> MSOS StepRes
setEntityDefaults EntityDefaults
rest MSOS StepRes
msos
        ValTerm [Values]
vs  -> Rewrite StepRes -> MSOS StepRes
forall a. Rewrite a -> MSOS a
liftRewrite (Rewrite StepRes -> MSOS StepRes)
-> Rewrite StepRes -> MSOS StepRes
forall a b. (a -> b) -> a -> b
$ Funcons -> String -> Rewrite StepRes
forall a. Funcons -> String -> Rewrite a
exception Funcons
f String
"default value evaluates to a sequence"
        Rewritten
_           -> Rewrite StepRes -> MSOS StepRes
forall a. Rewrite a -> MSOS a
liftRewrite (Rewrite StepRes -> MSOS StepRes)
-> Rewrite StepRes -> MSOS StepRes
forall a b. (a -> b) -> a -> b
$ Funcons -> String -> Rewrite StepRes
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 = 
    Rewrite Rewritten -> MSOS Rewritten
forall a. Rewrite a -> MSOS a
liftRewrite (Funcons -> Rewrite Rewritten
rewriteFuncons Funcons
f) MSOS Rewritten -> (Rewritten -> MSOS StepRes) -> MSOS StepRes
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ValTerm [Values]
vs  -> Name -> [Values] -> MSOS StepRes -> MSOS StepRes
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
_           -> Rewrite StepRes -> MSOS StepRes
forall a. Rewrite a -> MSOS a
liftRewrite (Rewrite StepRes -> MSOS StepRes)
-> Rewrite StepRes -> MSOS StepRes
forall a b. (a -> b) -> a -> b
$ Funcons -> String -> Rewrite StepRes
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 = 
    Name -> Maybe Values -> MSOS StepRes -> MSOS StepRes
forall a. Name -> Maybe Values -> MSOS a -> MSOS a
withControl Name
nm Maybe Values
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 = Mutable
forall k a. Map k a
M.empty

giveMUT :: MSOS Mutable
giveMUT :: MSOS Mutable
giveMUT = (forall (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m
 -> m (Either IException Mutable, MSOSState m, MSOSWriter))
-> MSOS Mutable
forall a.
(forall (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS ((forall (m :: * -> *).
  Interactive m =>
  MSOSReader m
  -> MSOSState m
  -> m (Either IException Mutable, MSOSState m, MSOSWriter))
 -> MSOS Mutable)
-> (forall (m :: * -> *).
    Interactive m =>
    MSOSReader m
    -> MSOSState m
    -> m (Either IException Mutable, MSOSState m, MSOSWriter))
-> MSOS Mutable
forall a b. (a -> b) -> a -> b
$ \MSOSReader m
ctxt MSOSState m
mut -> (Either IException Mutable, MSOSState m, MSOSWriter)
-> m (Either IException Mutable, MSOSState m, MSOSWriter)
forall (m :: * -> *) a. Monad m => a -> m a
return (Mutable -> Either IException Mutable
forall a b. b -> Either a b
Right (MSOSState m -> Mutable
forall (m :: * -> *). MSOSState m -> Mutable
mut_entities MSOSState m
mut), MSOSState m
mut, MSOSWriter
forall a. Monoid a => a
mempty)

-- | Get the value of some mutable entity.
getMut :: Name -> MSOS Values
getMut :: Name -> MSOS Values
getMut Name
key = do  Mutable
rw <- MSOS Mutable
giveMUT
                 case Name -> Mutable -> Maybe Values
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
key Mutable
rw of
                    Maybe Values
Nothing -> Values -> MSOS Values
forall (m :: * -> *) a. Monad m => a -> m a
return Values
forall t. Values t
null__ 
                    Just Values
v  -> Values -> MSOS Values
forall (m :: * -> *) a. Monad m => a -> m a
return Values
v

-- | Variant of 'getMut' that performs pattern-matching.
getMutPatt :: Name -> VPattern -> Env -> MSOS Env
getMutPatt :: Name -> VPattern -> Env -> MSOS Env
getMutPatt Name
nm VPattern
pat Env
env = do
    Values
val <- Name -> MSOS Values
getMut Name
nm
    Rewrite Env -> MSOS Env
forall a. Rewrite a -> MSOS a
liftRewrite (Values -> VPattern -> Env -> Rewrite Env
vMatch Values
val VPattern
pat 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 ((Maybe Values -> Maybe Values) -> Name -> Mutable -> Mutable
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  = Values -> Maybe Values
forall a. a -> Maybe a
Just (Values -> Values
f Values
forall t. Values t
null__) 
        up (Just Values
x) = Values -> Maybe Values
forall a. a -> Maybe a
Just (Values -> Values
f Values
x)

-- | 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 (Name -> Values -> Mutable -> Mutable
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 = Rewrite Values -> MSOS Values
forall a. Rewrite a -> MSOS a
liftRewrite (FTerm -> Env -> Rewrite Values
subsAndRewritesToValue FTerm
term Env
env) MSOS Values -> (Values -> MSOS ()) -> MSOS ()
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 (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m
 -> m (Either IException (), MSOSState m, MSOSWriter))
-> MSOS ()
forall a.
(forall (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS ((forall (m :: * -> *).
  Interactive m =>
  MSOSReader m
  -> MSOSState m
  -> m (Either IException (), MSOSState m, MSOSWriter))
 -> MSOS ())
-> (forall (m :: * -> *).
    Interactive m =>
    MSOSReader m
    -> MSOSState m
    -> m (Either IException (), MSOSState m, MSOSWriter))
-> MSOS ()
forall a b. (a -> b) -> a -> b
$ \MSOSReader m
ctxt MSOSState m
mut-> (Either IException (), MSOSState m, MSOSWriter)
-> m (Either IException (), MSOSState m, MSOSWriter)
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either IException ()
forall a b. b -> Either a b
Right(), MSOSState m
mut {mut_entities :: Mutable
mut_entities = Mutable
rw}, MSOSWriter
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 (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m
 -> m (Either IException Funcons, MSOSState m, MSOSWriter))
-> MSOS Funcons
forall a.
(forall (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS ((forall (m :: * -> *).
  Interactive m =>
  MSOSReader m
  -> MSOSState m
  -> m (Either IException Funcons, MSOSState m, MSOSWriter))
 -> MSOS Funcons)
-> (forall (m :: * -> *).
    Interactive m =>
    MSOSReader m
    -> MSOSState m
    -> m (Either IException Funcons, MSOSState m, MSOSWriter))
-> MSOS Funcons
forall a b. (a -> b) -> a -> b
$ \MSOSReader m
ctxt MSOSState m
mut ->
    case Name
-> Map Name ([[Values]], Maybe (m Funcons))
-> Maybe ([[Values]], Maybe (m Funcons))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
nm (MSOSState m -> Map Name ([[Values]], Maybe (m Funcons))
forall (m :: * -> *). MSOSState m -> Input m
inp_es MSOSState m
mut) of
      Just ([[Values]]
vss, Maybe (m Funcons)
mreadM) -> MSOSReader m
-> MSOSState m
-> [[Values]]
-> Maybe (m Funcons)
-> m (Either IException Funcons, MSOSState m, MSOSWriter)
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            -> MSOSReader m
-> MSOSState m
-> [[Values]]
-> Maybe (m Funcons)
-> m (Either IException Funcons, MSOSState m, MSOSWriter)
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 [] (m Funcons -> Maybe (m Funcons)
forall a. a -> Maybe a
Just (MSOSReader m -> Name -> m Funcons
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 [[Values]] -> Maybe (Values, [[Values]])
forall a. [[a]] -> Maybe (a, [[a]])
attemptConsume [[Values]]
vss of
      Just (Values
v,[[Values]]
vss') -> (Either IException Funcons, MSOSState m, c)
-> m (Either IException Funcons, MSOSState m, c)
forall (m :: * -> *) a. Monad m => a -> m a
return 
        (Funcons -> Either IException Funcons
forall a b. b -> Either a b
Right (Values -> Funcons
FValue Values
v), MSOSState m
mut {inp_es :: Input m
inp_es = Name -> ([[Values]], Maybe (m Funcons)) -> Input m -> Input m
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
nm ([[Values]]
vss',Maybe (m Funcons)
mreadM) (MSOSState m -> Input m
forall (m :: * -> *). MSOSState m -> Input m
inp_es MSOSState m
mut)},c
forall a. Monoid a => a
mempty)
      Maybe (Values, [[Values]])
Nothing       -> case Maybe (m Funcons)
mreadM of
        Maybe (m Funcons)
Nothing -> (Either IException Funcons, MSOSState m, c)
-> m (Either IException Funcons, MSOSState m, c)
forall (m :: * -> *) a. Monad m => a -> m a
return 
          (IException -> Either IException Funcons
forall a b. a -> Either a b
Left (IE -> MSOSReader m -> IException
forall (m :: * -> *). IE -> MSOSReader m -> IException
ctxt2exception (Name -> IE
InsufficientInput Name
nm) MSOSReader m
ctxt), MSOSState m
mut, c
forall a. Monoid a => a
mempty)
        Just m Funcons
readM -> do    Funcons
v <- m Funcons
readM
                            (Either IException Funcons, MSOSState m, c)
-> m (Either IException Funcons, MSOSState m, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Funcons -> Either IException Funcons
forall a b. b -> Either a b
Right Funcons
v, MSOSState m
mut, c
forall a. Monoid a => a
mempty)

    attemptConsume :: [[a]] -> Maybe (a,[[a]])
    attemptConsume :: [[a]] -> Maybe (a, [[a]])
attemptConsume []           = Maybe (a, [[a]])
forall a. Maybe a
Nothing
    attemptConsume ((a
v:[a]
vs):[[a]]
vss) = (a, [[a]]) -> Maybe (a, [[a]])
forall a. a -> Maybe a
Just (a
v,[a]
vs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
vss)
    attemptConsume ([]:[[a]]
vss)     = ([[a]] -> [[a]]) -> (a, [[a]]) -> (a, [[a]])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ([][a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:) ((a, [[a]]) -> (a, [[a]])) -> Maybe (a, [[a]]) -> Maybe (a, [[a]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[a]] -> Maybe (a, [[a]])
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 :: Name -> [Values] -> MSOS a -> MSOS a
withExtraInput = Bool -> Name -> [Values] -> MSOS a -> MSOS a
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 :: Name -> [Values] -> MSOS a -> MSOS a
withExactInput = Bool -> Name -> [Values] -> MSOS a -> MSOS a
forall a. Bool -> Name -> [Values] -> MSOS a -> MSOS a
withInput Bool
True

withInput :: Bool -> Name -> [Values] -> MSOS a -> MSOS a
withInput :: 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 (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
forall a.
(forall (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS ((forall (m :: * -> *).
  Interactive m =>
  MSOSReader m
  -> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
 -> MSOS a)
-> (forall (m :: * -> *).
    Interactive m =>
    MSOSReader m
    -> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
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') <- MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
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 = Name -> ([[Values]], Maybe (m Funcons)) -> Input m -> Input m
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
nm ([[Values]], Maybe (m Funcons))
newInp (MSOSState m -> Input m
forall (m :: * -> *). MSOSState m -> Input m
inp_es MSOSState m
mut)}
        let (Either IException a
res,[[Values]]
vss'') = case (MSOSState m -> Input m
forall (m :: * -> *). MSOSState m -> Input m
inp_es MSOSState m
mut') Input m -> Name -> ([[Values]], Maybe (m Funcons))
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))
_           -> (IException -> Either IException a
forall a b. a -> Either a b
Left(IE -> MSOSReader m -> IException
forall (m :: * -> *). IE -> MSOSReader m -> IException
ctxt2exception(Name -> IE
InsufficientInputConsumed Name
nm) MSOSReader m
ctxt), [[Values]]
vss'')
        (Either IException a, MSOSState m, MSOSWriter)
-> m (Either IException a, MSOSState m, MSOSWriter)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IException a
res, MSOSState m
mut' {inp_es :: Input m
inp_es = Name -> ([[Values]], Maybe (m Funcons)) -> Input m -> Input m
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
nm ([[Values]]
vss'',Maybe (m Funcons)
mreadM) (MSOSState m -> Input m
forall (m :: * -> *). MSOSState m -> Input m
inp_es MSOSState m
mut')}, MSOSWriter
wr')
  case Name -> Input m -> Maybe ([[Values]], Maybe (m Funcons))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
nm (MSOSState m -> Input m
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]
vs[Values] -> [[Values]] -> [[Values]]
forall a. a -> [a] -> [a]
:[[Values]]
vss, if Bool
isExactInput then Maybe (m Funcons)
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], Maybe (m Funcons)
forall a. Maybe a
Nothing) Maybe (m Funcons)
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 <- Rewrite [Values] -> MSOS [Values]
forall a. Rewrite a -> MSOS a
liftRewrite (Funcons -> Rewrite [Values]
rewritesToValues Funcons
fs)
    Rewrite Env -> MSOS Env
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 = Bool -> Name -> [FTerm] -> Env -> MSOS a -> MSOS a
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 = Bool -> Name -> [FTerm] -> Env -> MSOS a -> MSOS a
forall a. Bool -> Name -> [FTerm] -> Env -> MSOS a -> MSOS a
withInputTerms Bool
True

withInputTerms :: Bool -> Name -> [FTerm] -> Env -> MSOS a -> MSOS a
withInputTerms :: Bool -> Name -> [FTerm] -> Env -> MSOS a -> MSOS a
withInputTerms Bool
b Name
nm [FTerm]
fs Env
env MSOS a
msos = do
    [Values]
vs <- Rewrite [Values] -> MSOS [Values]
forall a. Rewrite a -> MSOS a
liftRewrite ((FTerm -> Rewrite Values) -> [FTerm] -> Rewrite [Values]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((FTerm -> Env -> Rewrite Values) -> Env -> FTerm -> Rewrite Values
forall a b c. (a -> b -> c) -> b -> a -> c
flip FTerm -> Env -> Rewrite Values
subsAndRewritesToValue Env
env) [FTerm]
fs)
    Bool -> Name -> [Values] -> MSOS a -> MSOS a
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 :: [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 (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m
 -> m (Either IException (a, [Maybe Values]), MSOSState m,
       MSOSWriter))
-> MSOS (a, [Maybe Values])
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) <- MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
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 -> (Either IException (a, [Maybe Values]), MSOSState m, MSOSWriter)
-> m (Either IException (a, [Maybe Values]), MSOSState m,
      MSOSWriter)
forall (m :: * -> *) a. Monad m => a -> m a
return (IException -> Either IException (a, [Maybe Values])
forall a b. a -> Either a b
Left IException
err, MSOSState m
mut1, MSOSWriter
wr1)
        Right a
a  -> (Either IException (a, [Maybe Values]), MSOSState m, MSOSWriter)
-> m (Either IException (a, [Maybe Values]), MSOSState m,
      MSOSWriter)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Either IException (a, [Maybe Values]), MSOSState m, MSOSWriter)
 -> m (Either IException (a, [Maybe Values]), MSOSState m,
       MSOSWriter))
-> (Either IException (a, [Maybe Values]), MSOSState m, MSOSWriter)
-> m (Either IException (a, [Maybe Values]), MSOSState m,
      MSOSWriter)
forall a b. (a -> b) -> a -> b
$ 
          ((a, [Maybe Values]) -> Either IException (a, [Maybe Values])
forall a b. b -> Either a b
Right (a
a, (Name -> Maybe Values) -> [Name] -> [Maybe Values]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (Map Name (Maybe Values) -> Name -> Maybe Values
forall k a. Ord k => Map k (Maybe a) -> k -> Maybe a
find (MSOSWriter -> Map Name (Maybe Values)
ctrl_entities MSOSWriter
wr1)) [Name]
keys)
                 , MSOSState m
mut1, MSOSWriter
wr1 {ctrl_entities :: Map Name (Maybe Values)
ctrl_entities = (Name -> Map Name (Maybe Values) -> Map Name (Maybe Values))
-> Map Name (Maybe Values) -> [Name] -> Map Name (Maybe Values)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Prelude.foldr Name -> Map Name (Maybe Values) -> Map Name (Maybe Values)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete (MSOSWriter -> Map Name (Maybe Values)
ctrl_entities MSOSWriter
wr1) [Name]
keys}))
  where find :: Map k (Maybe a) -> k -> Maybe a
find Map k (Maybe a)
m k
key = Maybe a -> (Maybe a -> Maybe a) -> Maybe (Maybe a) -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe a
forall a. Maybe a
Nothing Maybe a -> Maybe a
forall a. a -> a
id (Maybe (Maybe a) -> Maybe a) -> Maybe (Maybe a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ k -> Map k (Maybe a) -> Maybe (Maybe a)
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 = Rewrite Env -> MSOS 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 (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m
 -> m (Either IException (), MSOSState m, MSOSWriter))
-> MSOS ()
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 -> (Either IException (), MSOSState m, MSOSWriter)
-> m (Either IException (), MSOSState m, MSOSWriter)
forall (m :: * -> *) a. Monad m => a -> m a
return 
                        (() -> Either IException ()
forall a b. b -> Either a b
Right (), MSOSState m
mut, MSOSWriter
forall a. Monoid a => a
mempty { ctrl_entities :: Map Name (Maybe Values)
ctrl_entities = Name -> Values -> Map Name (Maybe Values)
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 = Rewrite Values -> MSOS Values
forall a. Rewrite a -> MSOS a
liftRewrite (FTerm -> Env -> Rewrite Values
subsAndRewritesToValue FTerm
term Env
env) MSOS Values -> (Values -> MSOS ()) -> MSOS ()
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 :: 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 (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
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 :: Map Name (Maybe Values)
dctrl_entities = Name
-> Maybe Values
-> Map Name (Maybe Values)
-> Map Name (Maybe Values)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
key Maybe Values
mfct (MSOSReader m -> Map Name (Maybe Values)
forall (m :: * -> *). MSOSReader m -> Map Name (Maybe Values)
dctrl_entities MSOSReader m
ctxt) } 
    in MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
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 :: 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   -> Maybe Values -> MSOS (Maybe Values)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Values
forall a. Maybe a
Nothing
              Just FTerm
term -> Values -> Maybe Values
forall a. a -> Maybe a
Just (Values -> Maybe Values) -> MSOS Values -> MSOS (Maybe Values)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rewrite Values -> MSOS Values
forall a. Rewrite a -> MSOS a
liftRewrite (FTerm -> Env -> Rewrite Values
substitute_signal FTerm
term Env
env)
    Name -> Maybe Values -> MSOS a -> MSOS a
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  
  Map Name (Maybe Values)
ro <- MSOS (Map Name (Maybe Values))
giveCTRL
  case Name -> Map Name (Maybe Values) -> Maybe (Maybe Values)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
key Map Name (Maybe Values)
ro of
    Maybe (Maybe Values)
Nothing   -> Maybe Values -> MSOS (Maybe Values)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Values
forall a. Maybe a
Nothing
    Just Maybe Values
mv   -> Maybe Values -> MSOS (Maybe Values)
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' <- Rewrite (Maybe VPattern) -> MSOS (Maybe VPattern)
forall a. Rewrite a -> MSOS a
liftRewrite (Rewrite (Maybe VPattern) -> MSOS (Maybe VPattern))
-> Rewrite (Maybe VPattern) -> MSOS (Maybe VPattern)
forall a b. (a -> b) -> a -> b
$ Rewrite (Maybe VPattern)
-> (VPattern -> Rewrite (Maybe VPattern))
-> Maybe VPattern
-> Rewrite (Maybe VPattern)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe VPattern -> Rewrite (Maybe VPattern)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe VPattern
forall a. Maybe a
Nothing) ((VPattern -> Maybe VPattern)
-> Rewrite VPattern -> Rewrite (Maybe VPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VPattern -> Maybe VPattern
forall a. a -> Maybe a
Just (Rewrite VPattern -> Rewrite (Maybe VPattern))
-> (VPattern -> Rewrite VPattern)
-> VPattern
-> Rewrite (Maybe VPattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VPattern -> Env -> Rewrite VPattern)
-> Env -> VPattern -> Rewrite VPattern
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
    Rewrite Env -> MSOS Env
forall a. Rewrite a -> MSOS a
liftRewrite (Rewrite Env -> Rewrite (Either IException Env)
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) Rewrite (Either IException Env)
-> (Either IException Env -> Rewrite Env) -> Rewrite Env
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left (Funcons
_,Funcons
_,PatternMismatch String
_)  -> Env -> Rewrite Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
env --TODO suboptimal 
      Left IException
exc                      -> IException -> Rewrite Env
forall a. IException -> Rewrite a
rewrite_rethrow IException
exc
      Right Env
env'                    -> Env -> Rewrite 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  Inherited
ro <- MSOS Inherited
giveINH
                 case Name -> Inherited -> Maybe [Values]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
key Inherited
ro of
                    Maybe [Values]
Nothing -> [Values] -> MSOS [Values]
forall (m :: * -> *) a. Monad m => a -> m a
return [Values
forall t. Values t
null__] 
                    Just [Values]
vs -> [Values] -> MSOS [Values]
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
    Rewrite Env -> MSOS Env
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 :: 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 (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
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 :: Inherited
inh_entities = Name -> [Values] -> Inherited -> Inherited
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
key [Values]
v (MSOSReader m -> Inherited
forall (m :: * -> *). MSOSReader m -> Inherited
inh_entities MSOSReader m
ctxt) } 
        in MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
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 :: Name -> FTerm -> Env -> MSOS a -> MSOS a
withInhTerm Name
nm FTerm
term Env
env MSOS a
msos = do
    [Values]
v <- Rewrite [Values] -> MSOS [Values]
forall a. Rewrite a -> MSOS a
liftRewrite (Rewrite [Values] -> MSOS [Values])
-> Rewrite [Values] -> MSOS [Values]
forall a b. (a -> b) -> a -> b
$ (FTerm -> Env -> Rewrite [Values]
subsAndRewritesToValues FTerm
term Env
env)
    Name -> [Values] -> MSOS a -> MSOS a
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 (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m
 -> m (Either IException (), MSOSState m, MSOSWriter))
-> MSOS ()
forall a.
(forall (m :: * -> *).
 Interactive m =>
 MSOSReader m
 -> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter))
-> MSOS a
MSOS ((forall (m :: * -> *).
  Interactive m =>
  MSOSReader m
  -> MSOSState m
  -> m (Either IException (), MSOSState m, MSOSWriter))
 -> MSOS ())
-> (forall (m :: * -> *).
    Interactive m =>
    MSOSReader m
    -> MSOSState m
    -> m (Either IException (), MSOSState m, MSOSWriter))
-> MSOS ()
forall a b. (a -> b) -> a -> b
$ \MSOSReader m
ctxt MSOSState m
mut -> (Either IException (), MSOSState m, MSOSWriter)
-> m (Either IException (), MSOSState m, MSOSWriter)
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either IException ()
forall a b. b -> Either a b
Right (), MSOSState m
mut
                            ,MSOSWriter
forall a. Monoid a => a
mempty { out_entities :: Inherited
out_entities = Name -> [Values] -> Inherited
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 = 
  Rewrite [Values] -> MSOS [Values]
forall a. Rewrite a -> MSOS a
liftRewrite (FTerm -> Env -> Rewrite [Values]
subsAndRewritesToValues FTerm
term Env
env) MSOS [Values] -> ([Values] -> MSOS ()) -> MSOS ()
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 :: Name -> MSOS a -> MSOS (a, [Values])
readOut Name
key MSOS a
msos = MSOS a -> MSOS (a, Inherited)
forall a. MSOS a -> MSOS (a, Inherited)
readOuts MSOS a
msos MSOS (a, Inherited)
-> ((a, Inherited) -> MSOS (a, [Values])) -> MSOS (a, [Values])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 
                        (a, [Values]) -> MSOS (a, [Values])
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, [Values]) -> MSOS (a, [Values]))
-> ((a, Inherited) -> (a, [Values]))
-> (a, Inherited)
-> MSOS (a, [Values])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inherited -> [Values]) -> (a, Inherited) -> (a, [Values])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Values] -> ([Values] -> [Values]) -> Maybe [Values] -> [Values]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Values] -> [Values]
forall a. a -> a
id (Maybe [Values] -> [Values])
-> (Inherited -> Maybe [Values]) -> Inherited -> [Values]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Inherited -> Maybe [Values]
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) <- Name -> MSOS Env -> MSOS (Env, [Values])
forall a. Name -> MSOS a -> MSOS (a, [Values])
readOut Name
key MSOS Env
msos
    Rewrite Env -> MSOS Env
forall a. Rewrite a -> MSOS a
liftRewrite (Values -> VPattern -> Env -> Rewrite Env
vMatch (Name -> [Funcons] -> Values
forall t. Name -> [t] -> Values t
ADTVal Name
"list" ((Values -> Funcons) -> [Values] -> [Funcons]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map Values -> Funcons
FValue [Values]
vals)) VPattern
pat Env
env)