{-# LANGUAGE TupleSections, FlexibleInstances, OverloadedStrings,TypeSynonymInstances #-}
module Funcons.Simulation where
import Funcons.Types
import Funcons.Exceptions
import Funcons.Printer
import Funcons.Parser (fvalue_parse_either)
import Funcons.RunOptions
import Control.Applicative
import Control.Monad.State
import System.Console.Haskeline
import qualified Data.Map as M
import Data.Text (unpack)
class Monad m => Interactive m where
fread :: Bool -> Name -> m Funcons
fprint :: Name -> Values -> m ()
fexec :: m a -> InputValues -> IO (a, InputValues)
instance Interactive IO where
fexec :: forall a. IO a -> InputValues -> IO (a, InputValues)
fexec IO a
ma InputValues
_ = (,forall k a. Map k a
M.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
ma
fread :: Bool -> Name -> IO Funcons
fread Bool
str_inp Name
nm = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT forall (m :: * -> *). MonadIO m => Settings m
defaultSettings forall a b. (a -> b) -> a -> b
$ do
Maybe String
mLine <- forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
prompt
case Maybe String
mLine of Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Funcons
string_ String
"")
Just String
s -> forall {t :: (* -> *) -> * -> *}.
(Monad (t IO), MonadTrans t) =>
String -> t IO Funcons
toFuncon String
s
where toFuncon :: String -> t IO Funcons
toFuncon String
str | Bool
str_inp = forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Funcons
string_ String
str)
| Bool
otherwise = case String -> Either String Funcons
fvalue_parse_either String
str of
Left String
err -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> IO ()
putStrLn String
err forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). Interactive m => Bool -> Name -> m Funcons
fread Bool
str_inp Name
nm)
Right Funcons
f -> forall (m :: * -> *) a. Monad m => a -> m a
return Funcons
f
prompt :: String
prompt | Name
nm forall a. Eq a => a -> a -> Bool
== Name
"standard-in" = String
"Please provide a literal value\n> "
| Bool
otherwise = String
"Please provide a literal value for " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
nm forall a. [a] -> [a] -> [a]
++ String
":"
fprint :: Name -> Values -> IO ()
fprint Name
_ Values
v | forall t. HasValues t => Values t -> Bool
isString_ Values
v = String -> IO ()
putStr (forall t. HasValues t => Values t -> String
unString Values
v)
| Bool
otherwise = String -> IO ()
putStr (Values -> String
showValues Values
v)
type SimIO = State InputValues
runSimIO :: SimIO a -> InputValues -> (a, InputValues)
runSimIO :: forall a. SimIO a -> InputValues -> (a, InputValues)
runSimIO = forall s a. State s a -> s -> (a, s)
runState
instance Interactive SimIO where
fexec :: forall a. SimIO a -> InputValues -> IO (a, InputValues)
fexec SimIO a
ma InputValues
defs = forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. State s a -> s -> (a, s)
runState SimIO a
ma InputValues
defs)
fread :: Bool -> Name -> SimIO Funcons
fread Bool
_ Name
nm = do Funcons
v <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets InputValues -> Funcons
mLookup
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust forall {a}. [a] -> [a]
mTail Name
nm)
forall (m :: * -> *) a. Monad m => a -> m a
return Funcons
v
where mLookup :: InputValues -> Funcons
mLookup InputValues
m = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
nm InputValues
m of
Just (Values
v:[Values]
_) -> Values -> Funcons
FValue Values
v
Maybe [Values]
_ -> Values -> Funcons
FValue forall t. Values t
null_value__
mTail :: [a] -> [a]
mTail [] = []
mTail (a
_:[a]
vs) = [a]
vs
fprint :: Name -> Values -> SimIO ()
fprint Name
nm Values
v = forall (m :: * -> *) a. Monad m => a -> m a
return ()