{-# 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 {- entity 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

    -- SimIO ignores prints as simulated Output is always done
    -- alternative is to use tell from Writer monad here and somehow remember
    -- whatever has been printed in Interactive instance for IO
    -- (necessary for observing printed output by funcon defs, using 'readOUT')
    fprint :: Name -> Values -> SimIO ()
fprint Name
nm Values
v = forall (m :: * -> *) a. Monad m => a -> m a
return ()
-----------