{-|
Module: CESKM
Description: A CESK(M) virtual machine implementation.
Author: gatlin@niltag.net

The evaluation algorithm is presented as a small-'step' transition relation
from a 'CESKM' to either

* another 'CESKM' if the computation is not finished; or
* a terminal 'Value' if it is.

This machine is written to be, as much as possible, an /executable semantics/
for psilo.
Its code should be useful as a reference for writing evaluators in general and
for clarifying the meaning of the language in a concrete way.

Hence there is a broad separation between the algorithm itself (principally
defined by 'step' and 'CESKM'); and the array of utilities and helpers
necessary to support that algorithm (starting with 'Runtime') so that the
language semantics are not obscured by implementation details.
-}

{-# LANGUAGE FlexibleContexts, LambdaCase #-}

module CESKM
  ( evaluate
  -- * Runtime Monad
  , Runtime
  , RuntimeState(..)
  , runtime
  , runtimeLog
  , gensym
  , op
  -- * CESK(M) evaluation
  , CESKM(..)
  , Kont(..)
  , Value(..)
  , step
  , drive
  , inject
  -- * Environment & Store
  , Address
  , Env
  , Store
  , emptyEnv
  , emptyStore
  , bindEnv
  , bindEnv'
  , bindStore
  , bindStore'
  , lookupEnv
  , lookupStore )
where

import Control.Monad (forM, mapAndUnzipM)

import Control.Comonad.Cofree (Cofree(..), unwrap)
import Control.Monad.Except (MonadError(..), Except, runExcept, throwError)
import Control.Monad.State (StateT, evalStateT, modify, gets)
import Control.Monad.Writer (WriterT, runWriterT, tell)

import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)

import qualified Data.IntMap.Strict as IntMap
import Data.IntMap.Strict (IntMap)

import Syntax (Symbol, Cbpv(..), CbpvExp, isPositive)

-- = Runtime monad

-- | State managed by 'Runtime'.
newtype RuntimeState = RuntimeState
  { RuntimeState -> Int
gensym_val :: Int -- ^ Incremented and returned to generate an 'Address'.
  }

-- | Runtime support for the CESK(M) algorithm.
-- @Runtime@ does the following:
--
-- * generates fresh, unique 'Address'es on demand (via 'gensym');
-- * provides a mechanism for throwing exceptions ('throwError'); and
-- * implements the operators ('op') that are assumed to exist.
--
-- The actual evaluation algorithm begins with 'evaluate'.
-- See also: 'CESKM'.
-- TODO
-- RuntimeT, Runtime = RuntimeT Identity
type Runtime = StateT RuntimeState (WriterT [String] (Except String))

runtime :: RuntimeState -> Runtime a -> Either String (a, [String])
runtime :: forall a. RuntimeState -> Runtime a -> Either String (a, [String])
runtime RuntimeState
st Runtime a
int = Except String (a, [String]) -> Either String (a, [String])
forall e a. Except e a -> Either e a
runExcept (Except String (a, [String]) -> Either String (a, [String]))
-> Except String (a, [String]) -> Either String (a, [String])
forall a b. (a -> b) -> a -> b
$ WriterT [String] (Except String) a -> Except String (a, [String])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [String] (Except String) a -> Except String (a, [String]))
-> WriterT [String] (Except String) a
-> Except String (a, [String])
forall a b. (a -> b) -> a -> b
$ Runtime a -> RuntimeState -> WriterT [String] (Except String) a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Runtime a
int RuntimeState
st

runtimeLog :: String -> Runtime ()
runtimeLog :: String -> Runtime ()
runtimeLog String
msg = [String] -> Runtime ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
msg]

-- * Environments, stores, and binders

-- | The 'Store' maps 'Address'es to 'Runtime' 'Value's.
type Address = Int

-- | Binds symbols to either 'Address'es or 'CbpvExp' definitions.
newtype Env = Env (Map Symbol (Either Address CbpvExp))

-- | Binds 'Address'es to 'Value's.
newtype Store = Store (IntMap Value)

emptyEnv :: Env
emptyEnv :: Env
emptyEnv = Map String (Either Int CbpvExp) -> Env
Env Map String (Either Int CbpvExp)
forall k a. Map k a
Map.empty

bindEnv :: Env -> Symbol -> Either Address CbpvExp -> Env
bindEnv :: Env -> String -> Either Int CbpvExp -> Env
bindEnv (Env Map String (Either Int CbpvExp)
eb) String
sym Either Int CbpvExp
val = Map String (Either Int CbpvExp) -> Env
Env (String
-> Either Int CbpvExp
-> Map String (Either Int CbpvExp)
-> Map String (Either Int CbpvExp)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
sym Either Int CbpvExp
val Map String (Either Int CbpvExp)
eb)

bindEnv' :: Env -> [Symbol] -> [Either Address CbpvExp] -> Env
bindEnv' :: Env -> [String] -> [Either Int CbpvExp] -> Env
bindEnv' (Env Map String (Either Int CbpvExp)
eb) [String]
syms [Either Int CbpvExp]
defns = Map String (Either Int CbpvExp) -> Env
Env (Map String (Either Int CbpvExp)
-> Map String (Either Int CbpvExp)
-> Map String (Either Int CbpvExp)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ([(String, Either Int CbpvExp)] -> Map String (Either Int CbpvExp)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([String] -> [Either Int CbpvExp] -> [(String, Either Int CbpvExp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
syms [Either Int CbpvExp]
defns)) Map String (Either Int CbpvExp)
eb)

lookupEnv :: MonadError String m => Env -> Symbol -> m (Either Address CbpvExp )
lookupEnv :: forall (m :: * -> *).
MonadError String m =>
Env -> String -> m (Either Int CbpvExp)
lookupEnv (Env Map String (Either Int CbpvExp)
eb) String
sym = case String
-> Map String (Either Int CbpvExp) -> Maybe (Either Int CbpvExp)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
sym Map String (Either Int CbpvExp)
eb of
  Maybe (Either Int CbpvExp)
Nothing -> String -> m (Either Int CbpvExp)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String
"undefined symbol: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sym)
  Just Either Int CbpvExp
res -> Either Int CbpvExp -> m (Either Int CbpvExp)
forall (m :: * -> *) a. Monad m => a -> m a
return Either Int CbpvExp
res

emptyStore :: Store
emptyStore :: Store
emptyStore = IntMap Value -> Store
Store IntMap Value
forall a. IntMap a
IntMap.empty

bindStore :: Store -> Address -> Value -> Store
bindStore :: Store -> Int -> Value -> Store
bindStore (Store IntMap Value
sb) Int
addr Value
val = IntMap Value -> Store
Store (Int -> Value -> IntMap Value -> IntMap Value
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
addr Value
val IntMap Value
sb)

bindStore' :: Store -> [Address] -> [Value] -> Store
bindStore' :: Store -> [Int] -> [Value] -> Store
bindStore' (Store IntMap Value
sb) [Int]
addrs [Value]
vals = IntMap Value -> Store
Store (IntMap Value -> IntMap Value -> IntMap Value
forall a. IntMap a -> IntMap a -> IntMap a
IntMap.union ([(Int, Value)] -> IntMap Value
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([Int] -> [Value] -> [(Int, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
addrs [Value]
vals)) IntMap Value
sb)

lookupStore :: MonadError String m => Store -> Address -> m Value
lookupStore :: forall (m :: * -> *).
MonadError String m =>
Store -> Int -> m Value
lookupStore (Store IntMap Value
sb) Int
addr = case Int -> IntMap Value -> Maybe Value
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
addr IntMap Value
sb of
  Maybe Value
Nothing -> String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String
"no value found at address " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
addr)
  Just Value
val -> Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
val

-- = The CESK(M) machine

-- |
-- A continuation annihilates with a 'Value' during computation to either halt
-- or transition to the next state.
data Kont
  = Halt -- ^ Bottom of the continuation stack.
  | Argk [Value] Kont -- ^ Arguments to be popped by a function binder.
  | Letk Symbol CbpvExp Env Kont -- ^ Sequencing between state transitions.

-- | A value is data which the machine actually stores, manipulates, and
-- evaluates expressions to.
data Value
  = Closure CbpvExp Env -- ^ A suspended computation
  | Continuation Kont -- ^ A captured continuation
  | IntV Integer -- ^ A literal integer.
  | FloatV Double -- ^ A literal floating point number.
  | BoolV Bool -- ^ A literal boolean value.

-- | 'CESKM' contains the state required for the operation of an abstract
-- __C__ontrol-string __E__nvironment __S__tore __K__ontinuation __M__eta machine
data CESKM = CESKM
  { CESKM -> CbpvExp
control :: CbpvExp     -- ^ The expression being evaluated
  , CESKM -> Env
environment :: Env     -- ^ Symbol -> Address + Defn
  , CESKM -> Store
store :: Store         -- ^ Address -> Value
  , CESKM -> Kont
kontinuation :: Kont   -- ^ The rest of the computation
  , CESKM -> [Kont]
meta :: [Kont]         -- ^ The meta-continuation: a LIFO stack of 'Kont's.
  }

-- | Construct an initial 'CESKM' with a given control expression.
inject :: CbpvExp -> CESKM
inject :: CbpvExp -> CESKM
inject CbpvExp
exp = CbpvExp -> Env -> Store -> Kont -> [Kont] -> CESKM
CESKM CbpvExp
exp Env
emptyEnv Store
emptyStore Kont
Halt []

-- | Utility function for generating globally unique 'Address'es.
gensym :: Runtime Address
gensym :: Runtime Int
gensym = do
  (RuntimeState -> RuntimeState) -> Runtime ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((RuntimeState -> RuntimeState) -> Runtime ())
-> (RuntimeState -> RuntimeState) -> Runtime ()
forall a b. (a -> b) -> a -> b
$ \RuntimeState
st -> RuntimeState
st { gensym_val :: Int
gensym_val = RuntimeState -> Int
gensym_val RuntimeState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
  (RuntimeState -> Int) -> Runtime Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RuntimeState -> Int
gensym_val

-- | Represents a single 'step' of a virtual machine state transition.
-- The function is not recursive although several of its constituent parts are.
step :: CESKM -> Runtime (Either Value CESKM)
step :: CESKM -> Runtime (Either Value CESKM)
step = CESKM -> Runtime (Either Value CESKM)
partial where
  partial :: CESKM -> Runtime (Either Value CESKM)
partial machine :: CESKM
machine@(CESKM CbpvExp
c Env
e Store
s Kont
k [Kont]
m) = case CbpvExp -> Cbpv CbpvExp
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap CbpvExp
c of
    AppA CbpvExp
op [CbpvExp]
erands -> do
      [Value]
vals <- [CbpvExp]
-> (CbpvExp
    -> StateT RuntimeState (WriterT [String] (Except String)) Value)
-> StateT RuntimeState (WriterT [String] (Except String)) [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CbpvExp]
erands ((CbpvExp
  -> StateT RuntimeState (WriterT [String] (Except String)) Value)
 -> StateT RuntimeState (WriterT [String] (Except String)) [Value])
-> (CbpvExp
    -> StateT RuntimeState (WriterT [String] (Except String)) Value)
-> StateT RuntimeState (WriterT [String] (Except String)) [Value]
forall a b. (a -> b) -> a -> b
$ \CbpvExp
erand -> CbpvExp
-> Env
-> Store
-> StateT RuntimeState (WriterT [String] (Except String)) Value
positive CbpvExp
erand Env
e Store
s
      CESKM -> Runtime (Either Value CESKM)
partial (CESKM -> Runtime (Either Value CESKM))
-> CESKM -> Runtime (Either Value CESKM)
forall a b. (a -> b) -> a -> b
$ CESKM
machine { control :: CbpvExp
control = CbpvExp
op , kontinuation :: Kont
kontinuation = [Value] -> Kont -> Kont
Argk [Value]
vals Kont
k }
    LetA String
v CbpvExp
exp CbpvExp
body -> CESKM -> Runtime (Either Value CESKM)
partial (CESKM -> Runtime (Either Value CESKM))
-> CESKM -> Runtime (Either Value CESKM)
forall a b. (a -> b) -> a -> b
$ CESKM
machine
      { control :: CbpvExp
control = CbpvExp
exp , kontinuation :: Kont
kontinuation = String -> CbpvExp -> Env -> Kont -> Kont
Letk String
v CbpvExp
body Env
e Kont
k }
    LetrecA [(String, CbpvExp)]
bindings CbpvExp
body -> do
      ([String]
vars, [Either Int CbpvExp]
exps) <- ((String, CbpvExp)
 -> StateT
      RuntimeState
      (WriterT [String] (Except String))
      (String, Either Int CbpvExp))
-> [(String, CbpvExp)]
-> StateT
     RuntimeState
     (WriterT [String] (Except String))
     ([String], [Either Int CbpvExp])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ((String, Either Int CbpvExp)
-> StateT
     RuntimeState
     (WriterT [String] (Except String))
     (String, Either Int CbpvExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, Either Int CbpvExp)
 -> StateT
      RuntimeState
      (WriterT [String] (Except String))
      (String, Either Int CbpvExp))
-> ((String, CbpvExp) -> (String, Either Int CbpvExp))
-> (String, CbpvExp)
-> StateT
     RuntimeState
     (WriterT [String] (Except String))
     (String, Either Int CbpvExp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CbpvExp -> Either Int CbpvExp)
-> (String, CbpvExp) -> (String, Either Int CbpvExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CbpvExp -> Either Int CbpvExp
forall a b. b -> Either a b
Right) [(String, CbpvExp)]
bindings
      CESKM -> Runtime (Either Value CESKM)
partial (CESKM -> Runtime (Either Value CESKM))
-> CESKM -> Runtime (Either Value CESKM)
forall a b. (a -> b) -> a -> b
$ CESKM
machine
        { control :: CbpvExp
control = CbpvExp
body
        , environment :: Env
environment = Env -> [String] -> [Either Int CbpvExp] -> Env
bindEnv' Env
e [String]
vars [Either Int CbpvExp]
exps }
    Cbpv CbpvExp
_ -> CESKM -> Runtime (Either Value CESKM)
transition CESKM
machine

  transition :: CESKM -> Runtime (Either Value CESKM)
transition machine :: CESKM
machine@(CESKM CbpvExp
c Env
e Store
s Kont
k [Kont]
m) = case CbpvExp -> Cbpv CbpvExp
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap CbpvExp
c of
    ShiftA String
karg CbpvExp
body -> do
      Int
addr <- Runtime Int
gensym
      CESKM -> Runtime (Either Value CESKM)
forall {a} {a}.
a
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a a)
next (CESKM -> Runtime (Either Value CESKM))
-> CESKM -> Runtime (Either Value CESKM)
forall a b. (a -> b) -> a -> b
$ CESKM
machine
        { control :: CbpvExp
control = CbpvExp
body
        , environment :: Env
environment = Env -> String -> Either Int CbpvExp -> Env
bindEnv Env
e String
karg (Int -> Either Int CbpvExp
forall a b. a -> Either a b
Left Int
addr)
        , store :: Store
store = Store -> Int -> Value -> Store
bindStore Store
s Int
addr (Kont -> Value
Continuation Kont
k)
        , kontinuation :: Kont
kontinuation = Kont
Halt }
    ResetA CbpvExp
body -> CESKM -> Runtime (Either Value CESKM)
forall {a} {a}.
a
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a a)
next (CESKM -> Runtime (Either Value CESKM))
-> CESKM -> Runtime (Either Value CESKM)
forall a b. (a -> b) -> a -> b
$ CESKM
machine
      { control :: CbpvExp
control = CbpvExp
body, kontinuation :: Kont
kontinuation = Kont
Halt, meta :: [Kont]
meta = Kont
k Kont -> [Kont] -> [Kont]
forall a. a -> [a] -> [a]
: [Kont]
m }
    IfA CbpvExp
c CbpvExp
t CbpvExp
el -> CbpvExp
-> Env
-> Store
-> StateT RuntimeState (WriterT [String] (Except String)) Value
positive CbpvExp
c Env
e Store
s StateT RuntimeState (WriterT [String] (Except String)) Value
-> (Value -> Runtime (Either Value CESKM))
-> Runtime (Either Value CESKM)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      BoolV Bool
tf -> CESKM -> Runtime (Either Value CESKM)
forall {a} {a}.
a
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a a)
next (CESKM -> Runtime (Either Value CESKM))
-> CESKM -> Runtime (Either Value CESKM)
forall a b. (a -> b) -> a -> b
$ CESKM
machine { control :: CbpvExp
control = if Bool
tf then CbpvExp
t else CbpvExp
el }
      Value
_        -> String -> Runtime (Either Value CESKM)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"conditional must be boolean"
    ResumeA CbpvExp
val -> CbpvExp
-> Env
-> Store
-> StateT RuntimeState (WriterT [String] (Except String)) Value
positive CbpvExp
val Env
e Store
s StateT RuntimeState (WriterT [String] (Except String)) Value
-> (Value -> Runtime (Either Value CESKM))
-> Runtime (Either Value CESKM)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Closure CbpvExp
body Env
e' -> CESKM -> Runtime (Either Value CESKM)
forall {a} {a}.
a
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a a)
next (CESKM -> Runtime (Either Value CESKM))
-> CESKM -> Runtime (Either Value CESKM)
forall a b. (a -> b) -> a -> b
$ CESKM
machine { control :: CbpvExp
control = CbpvExp
body, environment :: Env
environment = Env
e' }
      Value
val             -> Kont -> Value -> Store -> [Kont] -> Runtime (Either Value CESKM)
continue Kont
k Value
val Store
s [Kont]
m
    FunA [String]
args CbpvExp
body -> case Kont
k of
      Argk [Value]
vals Kont
k' -> do
        [Int]
addrs <- [Value]
-> (Value -> Runtime Int)
-> StateT RuntimeState (WriterT [String] (Except String)) [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Value]
vals (Runtime Int -> Value -> Runtime Int
forall a b. a -> b -> a
const Runtime Int
gensym)
        CESKM -> Runtime (Either Value CESKM)
forall {a} {a}.
a
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a a)
next (CESKM -> Runtime (Either Value CESKM))
-> CESKM -> Runtime (Either Value CESKM)
forall a b. (a -> b) -> a -> b
$ CESKM
machine
          { control :: CbpvExp
control = CbpvExp
body
          , environment :: Env
environment = Env -> [String] -> [Either Int CbpvExp] -> Env
bindEnv' Env
e [String]
args ((Int -> Either Int CbpvExp) -> [Int] -> [Either Int CbpvExp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Either Int CbpvExp
forall a b. a -> Either a b
Left [Int]
addrs)
          , store :: Store
store = Store -> [Int] -> [Value] -> Store
bindStore' Store
s [Int]
addrs [Value]
vals
          , kontinuation :: Kont
kontinuation = Kont
k' }
      Kont
_ -> String -> Runtime (Either Value CESKM)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"function expects argument continuation."
    Cbpv CbpvExp
_ -> CbpvExp
-> Env
-> Store
-> StateT RuntimeState (WriterT [String] (Except String)) Value
positive CbpvExp
c Env
e Store
s StateT RuntimeState (WriterT [String] (Except String)) Value
-> (Value -> Runtime (Either Value CESKM))
-> Runtime (Either Value CESKM)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Value
evaluated -> Kont -> Value -> Store -> [Kont] -> Runtime (Either Value CESKM)
continue Kont
k Value
evaluated Store
s [Kont]
m

  positive :: CbpvExp
-> Env
-> Store
-> StateT RuntimeState (WriterT [String] (Except String)) Value
positive CbpvExp
c Env
e Store
s = case CbpvExp -> Cbpv CbpvExp
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap CbpvExp
c of
    SymA String
"_" -> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
 -> StateT RuntimeState (WriterT [String] (Except String)) Value)
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall a b. (a -> b) -> a -> b
$ Kont -> Value
Continuation Kont
Halt
    SymA String
sym -> Env
-> String
-> StateT
     RuntimeState
     (WriterT [String] (Except String))
     (Either Int CbpvExp)
forall (m :: * -> *).
MonadError String m =>
Env -> String -> m (Either Int CbpvExp)
lookupEnv Env
e String
sym StateT
  RuntimeState
  (WriterT [String] (Except String))
  (Either Int CbpvExp)
-> (Either Int CbpvExp
    -> StateT RuntimeState (WriterT [String] (Except String)) Value)
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left Int
addr -> Store
-> Int
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall (m :: * -> *).
MonadError String m =>
Store -> Int -> m Value
lookupStore Store
s Int
addr
      Right CbpvExp
defn -> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
 -> StateT RuntimeState (WriterT [String] (Except String)) Value)
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall a b. (a -> b) -> a -> b
$ CbpvExp -> Env -> Value
Closure CbpvExp
defn Env
e
    SuspendA CbpvExp
comp -> if Cbpv CbpvExp -> Bool
forall a. Cbpv a -> Bool
isPositive (CbpvExp -> Cbpv CbpvExp
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap CbpvExp
comp)
      then CbpvExp
-> Env
-> Store
-> StateT RuntimeState (WriterT [String] (Except String)) Value
positive CbpvExp
comp Env
e Store
s
      else Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
 -> StateT RuntimeState (WriterT [String] (Except String)) Value)
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall a b. (a -> b) -> a -> b
$ CbpvExp -> Env -> Value
Closure CbpvExp
comp Env
e
    IntA Integer
n -> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
 -> StateT RuntimeState (WriterT [String] (Except String)) Value)
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall a b. (a -> b) -> a -> b
$ Integer -> Value
IntV Integer
n
    FloatA Double
n -> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
 -> StateT RuntimeState (WriterT [String] (Except String)) Value)
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall a b. (a -> b) -> a -> b
$ Double -> Value
FloatV Double
n
    BoolA Bool
b -> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
 -> StateT RuntimeState (WriterT [String] (Except String)) Value)
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV Bool
b
    OpA String
op_sym [CbpvExp]
erands ->
      [CbpvExp]
-> (CbpvExp
    -> StateT RuntimeState (WriterT [String] (Except String)) Value)
-> StateT RuntimeState (WriterT [String] (Except String)) [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CbpvExp]
erands (\CbpvExp
erand -> CbpvExp
-> Env
-> Store
-> StateT RuntimeState (WriterT [String] (Except String)) Value
positive CbpvExp
erand Env
e Store
s) StateT RuntimeState (WriterT [String] (Except String)) [Value]
-> ([Value]
    -> StateT RuntimeState (WriterT [String] (Except String)) Value)
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String
-> [Value]
-> StateT RuntimeState (WriterT [String] (Except String)) Value
op String
op_sym
    Cbpv CbpvExp
_ -> String
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Error evaluating term"

  continue :: Kont -> Value -> Store -> [Kont] -> Runtime (Either Value CESKM)
continue Kont
Halt Value
val Store
_ [] = Value -> Runtime (Either Value CESKM)
forall {a} {b}.
a
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a b)
halt Value
val
  continue Kont
Halt Value
val Store
s (Kont
m:[Kont]
ms) = Kont -> Value -> Store -> [Kont] -> Runtime (Either Value CESKM)
continue Kont
m Value
val Store
s [Kont]
ms
  continue (Letk String
var CbpvExp
body Env
e Kont
k) Value
val Store
s [Kont]
m = do
    Int
addr <- Runtime Int
gensym
    CESKM -> Runtime (Either Value CESKM)
forall {a} {a}.
a
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a a)
next (CESKM -> Runtime (Either Value CESKM))
-> CESKM -> Runtime (Either Value CESKM)
forall a b. (a -> b) -> a -> b
$ CESKM :: CbpvExp -> Env -> Store -> Kont -> [Kont] -> CESKM
CESKM
      { control :: CbpvExp
control = CbpvExp
body
      , environment :: Env
environment = Env -> String -> Either Int CbpvExp -> Env
bindEnv Env
e String
var (Int -> Either Int CbpvExp
forall a b. a -> Either a b
Left Int
addr)
      , store :: Store
store = Store -> Int -> Value -> Store
bindStore Store
s Int
addr Value
val
      , kontinuation :: Kont
kontinuation = Kont
k
      , meta :: [Kont]
meta = [Kont]
m }
  continue (Argk [Value
val] Kont
k) (Continuation Kont
k') Store
s [Kont]
m = Kont -> Value -> Store -> [Kont] -> Runtime (Either Value CESKM)
continue Kont
k' Value
val Store
s (Kont
k Kont -> [Kont] -> [Kont]
forall a. a -> [a] -> [a]
: [Kont]
m)
  continue Kont
_ Value
v Store
_ [Kont]
_ = String -> Runtime (Either Value CESKM)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Runtime (Either Value CESKM))
-> String -> Runtime (Either Value CESKM)
forall a b. (a -> b) -> a -> b
$ String
"error applying continuation: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
v

  next :: a
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a a)
next = Either a a
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a a
 -> StateT
      RuntimeState (WriterT [String] (Except String)) (Either a a))
-> (a -> Either a a)
-> a
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a a
forall a b. b -> Either a b
Right
  halt :: a
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a b)
halt = Either a b
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a b
 -> StateT
      RuntimeState (WriterT [String] (Except String)) (Either a b))
-> (a -> Either a b)
-> a
-> StateT
     RuntimeState (WriterT [String] (Except String)) (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left


-- | Drives each 'step' of the virtual machine until termination or error.
drive :: Either Value CESKM -> Runtime Value
drive :: Either Value CESKM
-> StateT RuntimeState (WriterT [String] (Except String)) Value
drive Either Value CESKM
mst = case Either Value CESKM
mst of
  Left Value
val -> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
val
  Right CESKM
st -> CESKM -> Runtime (Either Value CESKM)
step CESKM
st Runtime (Either Value CESKM)
-> (Either Value CESKM
    -> StateT RuntimeState (WriterT [String] (Except String)) Value)
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Value CESKM
-> StateT RuntimeState (WriterT [String] (Except String)) Value
drive

-- | The top-level function taking an expression 'CbpvExp' to either an error
--   'String' or a result 'Value'.
evaluate :: CbpvExp -> Either String (Value, [String])
evaluate :: CbpvExp -> Either String (Value, [String])
evaluate CbpvExp
exp = RuntimeState
-> StateT RuntimeState (WriterT [String] (Except String)) Value
-> Either String (Value, [String])
forall a. RuntimeState -> Runtime a -> Either String (a, [String])
runtime (Int -> RuntimeState
RuntimeState Int
0) (Either Value CESKM
-> StateT RuntimeState (WriterT [String] (Except String)) Value
drive (CESKM -> Either Value CESKM
forall a b. b -> Either a b
Right (CbpvExp -> CESKM
inject CbpvExp
exp)))

-- * Operators and other uninspiring utilities
-- | This function provides implementations of the built-in operators.
-- TODO
-- After making Runtime = RuntimeT Identity,
-- rename this to baseOps and for all monads m => RuntimeT m
-- THEN
-- create a typeclass ops and different monads
op :: Symbol -> [Value] -> Runtime Value
op :: String
-> [Value]
-> StateT RuntimeState (WriterT [String] (Except String)) Value
op String
"=?" = \[Value
a, Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (IntV Integer
a) (IntV Integer
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
b
  go (FloatV Double
a) (FloatV Double
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Double
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
b
  go (BoolV Bool
a) (BoolV Bool
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Bool
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"eq-int" = \[Value
a,Value
b]  -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (IntV Integer
a) (IntV Integer
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
b
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"lt-int" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (IntV Integer
a) (IntV Integer
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
b
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"gt-int" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (IntV Integer
a) (IntV Integer
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
b
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"gte-int" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (IntV Integer
a) (IntV Integer
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
b
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"lte-int" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (IntV Integer
a) (IntV Integer
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
b
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"eq-float" = \[Value
a,Value
b]  -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (FloatV Double
a) (FloatV Double
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Double
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
b
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"lt-float" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (FloatV Double
a) (FloatV Double
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
b
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"gt-float" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (FloatV Double
a) (FloatV Double
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
b
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"gte-float" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (FloatV Double
a) (FloatV Double
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
b
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"lte-float" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (FloatV Double
a) (FloatV Double
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
b
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"add-int" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (IntV Integer
a) (IntV Integer
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Integer -> Value
IntV (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
b)
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"mul-int" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (IntV Integer
a) (IntV Integer
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Integer -> Value
IntV (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
b)
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error, dog"

op String
"sub-int" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (IntV Integer
a) (IntV Integer
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Integer -> Value
IntV (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
b)
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"div-int" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (IntV Integer
a) (IntV Integer
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Integer -> Value
IntV (Integer
a Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
b)
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"add-float" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (FloatV Double
a) (FloatV Double
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Double -> Value
FloatV (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b)
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"mul-float" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (FloatV Double
a) (FloatV Double
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Double -> Value
FloatV (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
b)
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"sub-float" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (FloatV Double
a) (FloatV Double
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Double -> Value
FloatV (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
b)
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"div-float" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (FloatV Double
a) (FloatV Double
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Double -> Value
FloatV (Double
a Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
b)
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"mod-int" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (IntV Integer
a) (IntV Integer
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Integer -> Value
IntV (Integer
a Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
b)
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"mod-float" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (FloatV Double
a) (FloatV Double
b) =
    Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Double -> Value
FloatV (Double -> Value) -> Double -> Value
forall a b. (a -> b) -> a -> b
$ Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double
a Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
b))
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"eq-bool" = \[Value
a,Value
b]  -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (BoolV Bool
a) (BoolV Bool
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Bool
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"&&" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (BoolV Bool
a) (BoolV Bool
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool
a Bool -> Bool -> Bool
&& Bool
b)
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"||" = \[Value
a,Value
b] -> Value
-> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}.
MonadError String m =>
Value -> Value -> m Value
go Value
a Value
b where
  go :: Value -> Value -> m Value
go (BoolV Bool
a) (BoolV Bool
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool
a Bool -> Bool -> Bool
|| Bool
b)
  go Value
_ Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
"not" = \(Value
a:[Value]
_) -> Value
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall {m :: * -> *}. MonadError String m => Value -> m Value
go Value
a where
  go :: Value -> m Value
go (BoolV Bool
b) = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
BoolV (Bool -> Bool
not Bool
b)
  go Value
_ = String -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Runtime error"

op String
unknown = \[Value]
_ -> String
-> StateT RuntimeState (WriterT [String] (Except String)) Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"unknown operator"

instance Show Value where
  show :: Value -> String
show (Closure  CbpvExp
_ Env
_) = String
"#<closure>"
  show (Continuation Kont
_) = String
"#<kont>"
  show (IntV Integer
n) = Integer -> String
forall a. Show a => a -> String
show Integer
n
  show (FloatV Double
n) = Double -> String
forall a. Show a => a -> String
show Double
n
  show (BoolV Bool
b) = Bool -> String
forall a. Show a => a -> String
show Bool
b