Expr.hs

module Language.Sifflet.Expr
    (
     ArgSpec(..)
    , aspecsLookup
    , EvalResult, EvalRes(EvalOk, EvalError, EvalUntried)
    , exprToValue, valueToLiteral, valueToLiteral'
    , Symbol(..)
    , OStr, OBool, OChar
    , Expr(..), eSymbol, eSym, eInt, eString, eChar, eFloat
    , toLambdaExpr
    , callToApp, mapply
    , appToCall, mcall
    , exprIsAtomic
    , exprIsCompound
    , eBool, eFalse, eTrue, eIf
    , eList, eCall
    , exprIsLiteral
    , exprSymbols, exprVarNames
    , Operator(..)
    , Precedence
    , OperatorGrouping(..)
    , Value(..), valueFunction
    , Functions(..)
    , Function(..), functionName, functionNArgs
    , functionArgSpecs
    , functionArgTypes, functionResultType, functionArgResultTypes
    , functionType
    , functionArgNames, functionBody, functionImplementation
    , FunctionDefTuple, functionToDef, functionFromDef
    , FunctionImpl(..)
    , TypeVarName, TypeConsName, Type(..)
    , typeBool, typeChar, typeNum, typeString
    , typeList, typeFunction
    , Env, emptyEnv, makeEnv, extendEnv, envInsertL, envPop
    , envIns, envSet, envGet
    , envGetFunction, envLookup, envLookupFunction
    , envSymbols, envFunctionSymbols, envFunctions
    , eval, evalWithLimit, stackSize, apply
    , newUndefinedFunction
    , ePlus, eTimes, eMinus, eDiv, eMod
    , eAdd1, eSub1
    , eEq, eNe, eGt, eGe, eLt, eLe
    , eZerop, ePositivep, eNegativep
    , baseEnv)

where

-- drop this after debugging:
-- import System.IO.Unsafe(unsafePerformIO)

import Data.Map as Map hiding (filter, foldl, map, null)
import Data.List as List

import Data.Number.Sifflet

import Data.Sifflet.Tree as T

import Text.Sifflet.Pretty
import Text.Sifflet.Repr ()

import Language.Sifflet.Util

-- | Transform a numerical expression into its negation,
-- e.g., 5 --> (-5).
-- Fails if the expression is not an ENumber.

eNegate :: Expr -> SuccFail Expr
eNegate expr = 
  case expr of
    ENumber n -> Succ $ ENumber (negate n)
    _ -> Fail $ "eNegate: cannot handle" ++ show expr

-- Symbols have names, and may or may not have values,
-- but the value is stored in an environment, not in the symbol itself.

newtype Symbol = Symbol String
    deriving (Eq, Read, Show)

instance Pretty Symbol where
    pretty (Symbol s) = s

instance Repr Symbol where repr (Symbol s) = s

-- The Haskell representations of V's primitive data types.
-- Data.Number.Sifflet.Number represents exact and inexact numbers.
type OStr = String
type OBool = Bool
type OChar = Char

-- | A more highly "parsed" type of expression
--
-- Function calls have two kinds:
-- 1.  ECall:
--     restricted to the case where the function expression
--     is just a symbol, since otherwise it will be hard to visualize.
-- 2.  EApp: allows any expression to be the function,
--     but is applied to only one argument.
-- For now, the type checker will convert ECall expressions to
-- EApp expressions.  Ultimately, the two variants ought to be
-- unified.
--
-- The constructors EOp and EGroup are not used in Sifflet itself,
-- but they are needed for export to Python, Haskell, and similar languages;
-- they allow a distinction between operators and functions, and
-- wrapping expressions in parentheses.
-- EGroup e represents parentheses used for grouping: (e);
-- it is not used for other cases of parentheses, e.g.,
-- around the argument list in a function call.] 

data Expr = EUndefined
          | ESymbol Symbol 
          | EBool Bool
          | EChar Char
          | ENumber Number
          | EString String
          | EIf Expr Expr Expr -- ^ if test branch1 branch2
          | EList [Expr]
          | ELambda Symbol Expr 
          | EApp Expr Expr -- ^ apply function to argument
          | ECall Symbol [Expr] -- ^ function name, arglist
          | EOp Operator Expr Expr -- ^ binary operator application
          | EGroup Expr            -- ^ grouping parentheses
            deriving (Eq, Show)

instance Repr Expr where
  repr e =
      case e of
        EUndefined -> "*undefined*"
        ESymbol s -> repr s
        EBool b -> repr b
        EChar c -> repr c
        ENumber n -> repr n
        EString s -> show s
        EIf t a b -> par "if" (map repr [t, a, b])
        EList xs -> if exprIsLiteral e
                    then reprList "[" ", " "]" xs
                    else error ("Expr.repr: EList expression is non-literal: " 
                                ++ show e)
                       -- check *** was: par "EList" (map repr items)
        ELambda x body -> par "lambda" [repr x , "->", repr body]
        EApp f arg -> par (repr f) [repr arg]
        ECall (Symbol fname) args -> par fname (map repr args)
        EOp op left right -> unwords [repr left, opName op, repr right]
        EGroup e' -> "(" ++ repr e' ++ ")"

-- | Try to convert the arguments and body of a function to a lambda expression.
-- Fails if there are no arguments, since a lambda expression requires one.
-- If there are multiple arguments, then we get a nested lambda expression.

toLambdaExpr :: [String] -> Expr -> SuccFail Expr
toLambdaExpr args body =
     case args of
       [] -> Fail "toLambdaExpr: no arguments; at least one needed"
       a:[] -> Succ $ ELambda (Symbol a) body
       a:as -> do
         {
           expr <- toLambdaExpr as body
         ; Succ $ ELambda (Symbol a) expr
         }
    
-- | Convert an ECall expression to an EApp expression

callToApp :: Expr -> Expr
callToApp expr =
    case expr of
      ECall fsym args -> mapply (ESymbol fsym) args
      _ -> error "callToApp: requires ECall expression"

-- | Helper for callToApp, but may have other uses.
-- Creates an EApp expression representing a function call
-- with possibly many arguments.
mapply :: Expr -> [Expr] -> Expr
mapply fexpr args =
    case args of
      [] -> error "mapply: no argument, cannot happen"
      arg:[] -> EApp fexpr arg
      arg:args' -> mapply (EApp fexpr arg) args'


-- | Convert an EApp expression to an ECall expression

appToCall :: Expr -> Expr
appToCall expr =
    case expr of
      EApp f arg -> mcall f [arg]
      _ -> error "appToCall: requires an EApp expression"


-- | Helper for appToCall, but may have other uses.
-- Creates an ECall expression.

mcall :: Expr -> [Expr] -> Expr
mcall f args =
    case f of
       ESymbol fsym -> ECall fsym args
       EApp g arg -> mcall g (arg:args)
       _ ->
          error "mcall: function must be represented as a symbol or an EApp"

-- | An Expr is "extended" if it uses the extended constructors
-- EOp or EGroup.  In pure Sifflet, no extended Exprs are used.

exprIsExtended :: Expr -> Bool
exprIsExtended e =
    case e of
        EOp _ _ _ -> True
        EGroup _ -> True
        EIf t a b -> exprIsExtended t ||
                     exprIsExtended a ||
                     exprIsExtended b
        EList xs -> any exprIsExtended xs
        ELambda _ body -> exprIsExtended body
        ECall (Symbol _) args -> any exprIsExtended args
        _ -> False

-- | Is an Expr a literal?  A literal is a boolean, character, number, string,
-- or list of literals.  We (should) only allow user input expressions
-- to be literal expressions.

exprIsLiteral :: Expr -> Bool
exprIsLiteral e =
    case e of 
      EBool _ -> True
      EChar _ -> True
      ENumber _ -> True
      EString _ -> True
      EList es -> all exprIsLiteral es
      -- Shouldn't we say that 
      -- EGroup e' *not* a literal, even if e' is a literal?
      -- But consider carefully the effect on exprIsAtomic and ()'s removal.
      EGroup _e' -> True -- or False, or exprIsLiteral e' ???
      _ -> False

-- | Is an expression atomic?
-- Atomic expressions do not need parentheses in any reasonable language,
-- because there is nothing to be grouped (symbols, literals)
-- or in the case of lists, they already have brackets
-- which separate them from their neighbors.
--
-- All lists are atomic, even if they are not literals,
-- because (for example) we can remove parentheses
-- from ([a + b, 7])

exprIsAtomic :: Expr -> Bool
exprIsAtomic e =
    case e of
      ESymbol _ -> True
      EList _ -> True
      _ -> exprIsLiteral e

-- | Compound = non-atomic
exprIsCompound :: Expr -> Bool
exprIsCompound = not . exprIsAtomic

eSymbol, eSym :: String -> Expr
eSymbol = ESymbol . Symbol
eSym = eSymbol

eInt :: Integer -> Expr
eInt = ENumber . Exact

eString :: OStr -> Expr
eString = EString

eChar :: OChar -> Expr
eChar = EChar

eFloat :: Double -> Expr
eFloat = ENumber . Inexact

eBool :: Bool -> Expr
eBool = EBool

eFalse, eTrue :: Expr
eFalse = eBool False
eTrue = eBool True

eIf :: Expr -> Expr -> Expr -> Expr
eIf = EIf

eList :: [Expr] -> Expr
eList = EList

-- | Example:
-- ePlus_2_3 = eCall "+" [eInt 2, eInt 3]
eCall :: String -> [Expr] -> Expr
eCall = ECall . Symbol

-- | An operator, such as * or +
-- An operator is associative, like +, if (a + b) + c == a + (b + c).
-- Its grouping is left to right if (a op b op c) means (a op b) op c;
-- right to left if (a op b op c) means a op (b op c).
-- Most operators group left to right.
data Operator = Operator  {opName :: String
                           , opPrec :: Precedence
                           , opAssoc :: Bool -- ^ associative?
                           , opGrouping :: OperatorGrouping
                            }
                deriving (Eq, Show)

instance Pretty Operator where
    pretty = opName

-- | Operator priority, normally is > 0 or >= 0, 
-- but does that really matter?  I think not.
type Precedence = Int

-- | Operator grouping: left to right or right to left,
-- or perhaps not at all
data OperatorGrouping = GroupLtoR | GroupRtoL | GroupNone
                      deriving (Eq, Show)

-- VALUES AND EVALUATION

data Value = VBool OBool
           | VChar OChar
           | VNumber Number
           | VString OStr
           | VFun Function
           | VList [Value] 
           deriving (Eq, Show)
           -- no Read for Function

instance Repr Value where
  repr (VBool b) = show b
  repr (VChar c) = show c
  repr (VNumber n) = show n
  repr (VString s) = show s
  repr (VFun f) = repr f
  repr (VList vs) = reprList "[" ", " "]" vs

valueFunction :: Value -> Function
valueFunction value =
    case value of
      VFun function -> function
      _ -> error "valueFunction: non-function value"

-- Evaluation results (or non-results)

type EvalResult = EvalRes Value

data EvalRes e = EvalOk e | EvalError String | EvalUntried
  deriving (Eq, Show)

instance Functor EvalRes where
  fmap f (EvalOk v) = EvalOk (f v)
  fmap _ (EvalError s) = EvalError s
  fmap _ EvalUntried = EvalUntried

instance Applicative EvalRes where
  pure = EvalOk
  EvalOk f <*> EvalOk v = EvalOk (f v)
  EvalOk _ <*> EvalError s = EvalError s
  EvalOk _ <*> EvalUntried = EvalUntried

  -- It seems that the other cases should be consistent
  -- with evalWithLimit for ECall below,
  -- whatever that means ...
  EvalError s <*> _ = EvalError s
  EvalUntried <*> _ = EvalUntried
  
instance Monad EvalRes where
  EvalOk value >>= f = f value
  EvalError e >>= _f = EvalError e
  EvalUntried >>= _f = EvalUntried
  return = EvalOk
  fail = EvalError

-- | The value of an expression in the base environment.

exprToValue :: Expr -> SuccFail Value
exprToValue expr = 
    case eval expr baseEnv of 
      EvalOk value -> Succ value
      EvalError msg -> Fail msg
      EvalUntried -> error "exprToValue: eval resulted in EvalUntried"

valueToLiteral :: Value -> SuccFail Expr
valueToLiteral v = 
    case v of
      VBool b -> Succ $ EBool b
      VChar c -> Succ $ EChar c
      VNumber n -> Succ $ ENumber n
      VString s -> Succ $ EString s
      -- VList [] -> Succ $ EList []
      -- VV Should this be fixed? VV
      -- VList _ -> Fail "cannot convert non-empty list to literal expression"
      VList vs -> mapM valueToLiteral vs >>= Succ . EList
      VFun _f -> Fail "cannot convert function to literal expression"

valueToLiteral' :: Value -> Expr
valueToLiteral' v = case valueToLiteral v of
                      Fail msg -> error ("valueToLiteral: " ++ msg)
                      Succ e -> e

-- | Convert a literal expression to the value it represents.
-- It is an error if the expression is non-literal.
-- See exprIsLiteral.    
literalToValue :: Expr -> Value
literalToValue e =
    case e of
      EBool b -> VBool b
      EChar c -> VChar c
      ENumber n -> VNumber n
      EString s -> VString s
      EList es -> if exprIsLiteral e
                  then VList (map literalToValue es)
                  else errcats ["literalToValue: ",
                                "non-literal list expression: ",
                                show e]
      _ -> errcats ["literalToValue: non-literal or extended expression: " , 
                    show e]

-- | Type variable name                       
type TypeVarName = String

-- | Type constructor name
type TypeConsName = String

-- | A Type is either a type variable or a constructed type
-- with a constructor and a list of type parameters

data Type = TypeVar TypeVarName          -- named type variable
          | TypeCons TypeConsName [Type] -- constructed type
            deriving (Eq)

instance Show Type where
    show (TypeVar vname) = vname
    show (TypeCons ctor ts) =
        case ts of
          [] -> ctor
          (t:ts') ->
              case ctor of
                "List" -> "[" ++ show t ++ "]"
                "Function" -> "(" ++ show t ++ " -> " ++
                              show (head ts') ++ ")"
                _ -> "(" ++ ctor ++ (unwords (map show ts)) ++ ")"


typeToArity :: Type -> Int
typeToArity atype =
    case atype of 
      TypeCons "Function" [_, next] -> 1 + typeToArity next
      _ -> 0

-- Primitive types

primType :: TypeConsName -> Type
primType tname = TypeCons tname []

typeBool, typeChar, typeNum, typeString :: Type
typeBool = primType "Bool"
typeChar = primType "Char"
typeNum = primType "Num"
typeString = primType "String"

-- Built-in compound types

typeList :: Type -> Type
typeList t = TypeCons "List" [t]

-- | The type of a function, from its argument types and result type,
-- where (a -> b) is represented as TypeCons "Function" [a, b].
-- Note that for n-ary functions, n > 2 implies nested function types: 
-- (a -> b -> c) is represented as
-- TypeCons "Function" [a, TypeCons "Function" [b, c]], etc.

typeFunction :: [Type] -> Type -> Type
typeFunction atypes rtype =
    let func a b = TypeCons "Function" [a, b]
    in case atypes of
         [] -> error "typeFunction: empty argument type list"
         atype:[] -> func atype rtype
         atype:atypes' -> func atype (typeFunction atypes' rtype)

-- | A collection of functions, typically to be saved or exported
-- or read from a file

newtype Functions = Functions [Function]
               deriving (Eq, Show)

-- | A function may have a name and always has an implementation
data Function = Function (Maybe String) -- function name
                         [Type]       -- argument types
                         Type         -- result type
                         FunctionImpl   -- implementation
  deriving (Show)


data ArgSpec = ArgSpec {argName :: String, -- argument name
                        argInlets :: Int   -- number of inputs
                       }
               deriving (Eq, Show)

-- | Try to find the number of inlets for an argument
-- from a list of ArgSpec
aspecsLookup :: String -> [ArgSpec] -> Maybe Int
aspecsLookup name specs =
    case specs of 
      [] -> Nothing
      s:ss ->
          if argName s == name
          then Just (argInlets s)
          else aspecsLookup name ss

functionArgSpecs :: Function -> [ArgSpec]
functionArgSpecs f@(Function _ argTypes _ _) = 
    [ArgSpec {argName = n, argInlets = typeToArity t} |
     (n, t) <- zip (functionArgNames f) argTypes]

data FunctionImpl = Primitive ([Value] -> EvalResult) -- a Haskell function
                  | Compound [String] Expr       -- arguments, body

instance Show FunctionImpl where
    show (Primitive _) = "<primitive function>"
    show (Compound args body) = 
        concat ["Compound function, args = " ++ show args ++ 
                "; body = " ++ show body]

instance Read FunctionImpl where
    readsPrec _ _ = error "readsPrec not implemented for FunctionImpl"

instance Repr Function where
  repr f =
      let name = functionName f
      in case functionImplementation f of
           Primitive _ -> "<primfunc " ++ name ++ ">"
           Compound _args _body -> "<func " ++ name ++ ">"

newUndefinedFunction :: String -> [String] -> Function
newUndefinedFunction name argnames =
    let (atypes, rtype) = undefinedTypes argnames
        impl = Compound argnames EUndefined
    in Function (Just name) atypes rtype impl

undefinedTypes :: [String] -> ([Type], Type)
undefinedTypes argnames =
    let atypes = [TypeVar ('_' : name) | name <- argnames]
        rtype = TypeVar "_result"
    in (atypes, rtype)

functionName :: Function -> String
functionName (Function mname _ _ _) = 
    case mname of
      Just name -> name
      Nothing -> "(unnamed)"

functionNArgs :: Function -> Int
functionNArgs = length . functionArgTypes

functionArgTypes :: Function -> [Type]
functionArgTypes (Function _ argtypes _ _) = argtypes

functionResultType :: Function -> Type
functionResultType (Function _ _ rtype _) = rtype

-- | Type type of a function, a tuple of (arg types, result type)
functionArgResultTypes :: Function -> ([Type], Type) -- (args., result type)
functionArgResultTypes f = (functionArgTypes f, functionResultType f)

-- | The type of a function, 
-- where (a -> b) is represented as TypeCons "Function" [a, b]
functionType :: Function -> Type
functionType (Function _ argTs resultT _) = typeFunction argTs resultT

functionImplementation :: Function -> FunctionImpl
functionImplementation (Function _ _ _ impl) = impl

functionArgNames :: Function -> [String]
functionArgNames f = case functionImplementation f of
                       Primitive _ -> 
                           ["dummy" | _t <- functionArgTypes f]
                       Compound args _body -> args

type FunctionDefTuple = (String, [String], [Type], Type, Expr)

functionToDef :: Function -> FunctionDefTuple
functionToDef (Function mname argTypes resType impl) = 
    case impl of
      Primitive _ -> error "functionToDef: primitive function"
      Compound argNames body ->
          case mname of
            Nothing -> error "functionToDef: unnamed function"
            Just name -> (name, argNames, argTypes, resType, body)

functionFromDef :: FunctionDefTuple -> Function
functionFromDef (name, argNames, argTypes, resType, body) =
    Function (Just name) argTypes resType (Compound argNames body)

functionBody :: Function -> Expr
functionBody f = case functionImplementation f of
                   Primitive _fp -> 
                       errcats ["functionBody:",
                                "no body available for primitive function"]
                   Compound _args body -> body

-- | We need to be able to say functions are equal (or not) in order
-- to tell if environments are equal or not, in order to know whether
-- there are unsaved changes.  This is tricky since the primitive
-- function implementations do not instantiate Eq, so if it's
-- primitive == primitive? we go by the names alone (there's nothing
-- else to go by).  Otherwise all the parts must be equal.
instance Eq Function where
    f1 == f2 =
        let Function mname1 atypes1 anames1 impl1 = f1
            Function mname2 atypes2 anames2 impl2 = f2
        in case (impl1, impl2) of
             (Primitive _, Primitive _) -> mname1 == mname2
             (Compound args1 body1, Compound args2 body2 ) -> 
                 mname1 == mname2 &&
                 atypes1 == atypes2 &&
                 anames1 == anames2 &&
                 args1 == args2 &&
                 body1 == body2
             _ -> False

-- | An Environment contains variable bindings and may be linked to 
-- a next environment
--
-- Perhaps it may also be used to generate Vp type variables (with int id's)

type EnvFrame = Map String Value
type Env = [EnvFrame]           -- should be NON-empty
type Binding = (String, Value)

emptyEnv :: Env
emptyEnv = makeEnv [] []

makeEnv :: [String] -> [Value] -> Env 
makeEnv names values = extendEnv names values []

extendEnv :: [String] -> [Value] -> Env -> Env
extendEnv names values env = fromList (zip names values) : env

-- | Insert names and values from lists into an environment
envInsertL :: Env -> [String] -> [Value] -> Env
envInsertL env names values =
    case env of
      [] -> error "envInsertL: empty list"
      f : fs ->
        let ins :: EnvFrame -> Binding -> EnvFrame
            ins frame (name, value) = Map.insert name value frame
        in foldl ins f (zip names values) : fs

envIns :: Env -> String -> Value -> Env
envIns env name value =
    case env of
      [] -> error "envIns: empty list"
      f : fs -> Map.insert name value f : fs

envSet :: Env -> String -> Value -> Env
envSet env name value = 
    -- If name is bound in some map in the environment, update the binding
    -- in that map; otherwise insert it into the "front" map
    let loop :: Env -> Maybe Env
        loop env1 =
            case env1 of
              [] -> Nothing
              f:fs ->
                  case Map.lookup name f of
                    Just _ -> Just (envIns env1 name value)
                    Nothing ->
                        do      -- in the Maybe monad:
                          fs' <- loop fs
                          return (f:fs')

    in case loop env of
         Just result -> result
         Nothing -> envIns env name value

-- | Get the value of a variable from an environment
envGet :: Env -> String -> Value
envGet env name = case envLookup env name of
                    Just value -> value
                    Nothing -> errcats ["envGet: unbound variable:", name]

envGetFunction :: Env -> String -> Function
envGetFunction env name = func 
    where VFun func = envGet env name

envLookup :: Env -> String -> Maybe Value
envLookup env name =
    case env of
      [] -> Nothing
      f:fs ->
          case Map.lookup name f of
            Just value -> Just value
            Nothing -> envLookup fs name

envLookupFunction :: Env -> String -> Maybe Function
envLookupFunction env name = 
    case envLookup env name of
      Nothing -> Nothing
      Just value ->
          case value of
            VFun function -> Just function
            _ -> Nothing

-- | List of all symbols bound in the environment
envSymbols :: Env -> [String]
envSymbols env =
    case env of
      [] -> []
      f : fs -> keys f ++  envSymbols fs

-- | List of all symbols bound to functions in the environment
envFunctionSymbols :: Env -> [String]
envFunctionSymbols env =
    let isFunction s = case envGet env s of
                         VFun _ -> True
                         _ -> False
    in [s | s <- envSymbols env, isFunction s]

-- | All the functions in the environment
envFunctions :: Env -> Functions
envFunctions env = 
    Functions (map (envGetFunction env) 
                   (envFunctionSymbols env))

-- | Return to the environment prior to an extendEnv
envPop :: Env -> Env
envPop env =
    case env of
      [] -> error "envPop: empty list"
      _f:fs -> fs
 
unbound :: String -> Env -> Bool
unbound name env = envLookup env name == Nothing

-- EVALUATING EXPRESSIONS

-- Limit the stack size for recursion, since we are helping
-- novice programmers to learn

stackSize :: Int
stackSize = 1000

eval :: Expr -> Env -> EvalResult
eval expr env = evalWithLimit expr env stackSize

evalWithLimit :: Expr -> Env -> Int -> EvalResult

-- Evaluate an expression in an environment with a limited stack

evalWithLimit expr env stacksize =
    if stacksize <= 0
    then EvalError "stack overflow"
    else
        let stacksize' = pred stacksize in
        case expr of
          EUndefined -> EvalError "undefined"
          ESymbol (Symbol name) ->
              case envLookup env name of
                Nothing -> EvalError $ "unbound variable: " ++ name
                Just value -> EvalOk value

          EBool b -> EvalOk (VBool b)
          EChar c -> EvalOk (VChar c)
          ENumber n -> EvalOk (VNumber n)
          EString n -> EvalOk (VString n)

          EIf t a b ->
              case evalWithLimit t env stacksize' of
                EvalOk (VBool True) -> evalWithLimit a env stacksize'
                EvalOk (VBool False) -> evalWithLimit b env stacksize'
                -- Should there be another case here, where we get
                -- EvalOk(something not boolean) and this should be
                -- an error?
                result -> result

          ELambda _ _ -> error "evalWithLimit: not implemented for lambda expr"
          ECall fsym args ->
              -- evaluating a function call
              -- I assume that call expressions have *symbols* for the 
              -- functions.
              -- To relax this assumption: change the definition of ECall,
              -- but how will you visualize it?

              case evalWithLimit (ESymbol fsym) env stacksize' of
                EvalOk f -> 
                    case mapM (\ a -> evalWithLimit a env stacksize') args of
                      EvalOk argvalues -> apply f argvalues env stacksize'
                      -- why doesn't this work? err -> err
                      EvalError e -> EvalError e
                      EvalUntried -> EvalUntried
                err -> err

          EList elist ->
              case mapM (\ elt -> evalWithLimit elt env stacksize') elist of
                EvalOk values -> EvalOk (VList values)
                EvalError e -> EvalError e
                EvalUntried -> EvalUntried
          _ -> errcats ["evalWithLimit: extended expression not supported",
                        show expr]
          
-- | Apply a function fvalue to a list of actual arguments args
-- in an environment env and with a limited stack size stacksize
apply :: Value -> [Value] -> Env -> Int -> EvalResult
apply fvalue args env stacksize =
    case fvalue of
      VFun f ->
          case functionImplementation f of
            Primitive pf -> pf args
            Compound formalArgs body ->
                evalWithLimit body (extendEnv formalArgs args env) stacksize
      not_a_function ->
          EvalError ("apply: first arg is not a function: " ++ 
                     show not_a_function)

-- Shortcuts for making expressions that call the primitive functions
ePlus :: Expr -> Expr -> Expr
ePlus e1 e2 = eCall "+" [e1, e2]

eTimes :: Expr -> Expr -> Expr
eTimes e1 e2 = eCall "*" [e1, e2]

eMinus, eDiv, eMod :: Expr -> Expr -> Expr
eMinus e1 e2 = eCall "-" [e1, e2]
eDiv e1 e2 = eCall "div" [e1, e2]
eMod e1 e2 = eCall "mod" [e1, e2]

eAdd1, eSub1 :: Expr -> Expr
eAdd1 e1 = eCall "add1" [e1]
eSub1 e1 = eCall "sub1" [e1]

eEq, eNe, eGt, eGe, eLt, eLe :: Expr -> Expr -> Expr
eEq e1 e2 = eCall "==" [e1, e2]
eNe e1 e2 = eCall "/=" [e1, e2]
eGt e1 e2 = eCall ">" [e1, e2]
eGe e1 e2 = eCall ">=" [e1, e2]
eLt e1 e2 = eCall "<" [e1, e2]
eLe e1 e2 = eCall "<=" [e1, e2]


eZerop, ePositivep, eNegativep :: Expr -> Expr
eZerop e1 = eCall "zero?" [e1]
ePositivep e1 = eCall "positive?" [e1]
eNegativep e1 = eCall "negative?" [e1]

-- A good base environment to get started with 

primitiveFunctions :: [Function]
primitiveFunctions = [
                       -- Arithmetic
                       primN2N "+" (+), -- Number (+)
                       primN2N "-" (-),
                       primN2N "*" (*),
                       primIntDiv,
                       primIntMod,
                       primFloatDiv,

                       primN1N "add1" succ,
                       primN1N "sub1" pred,

                       -- Comparison
                       primN2B "==" (==),
                       primN2B "/=" (/=),
                       primN2B ">" (>),
                       primN2B ">=" (>=),
                       primN2B "<" (<),
                       primN2B "<=" (<=),

                       primN1B "zero?" eqZero,
                       primN1B "positive?" gtZero,
                       primN1B "negative?" ltZero,

                       -- List operations

                       -- null xs tells if xs is an empty list
                       prim "null" [typeList (TypeVar "a")] 
                            typeBool primNull,

                       prim "head" [typeList (TypeVar "b")] 
                            (TypeVar "b")
                            primHead,
                       prim "tail" [typeList (TypeVar "c")] 
                            (typeList (TypeVar "c"))
                            primTail,
                       prim ":" [TypeVar "d", typeList (TypeVar "d")]
                            (typeList (TypeVar "d"))
                            primCons
                     ]

type PFun = [Value] -> EvalResult

-- Primitive functions of arbitrary type
prim :: String -> [Type] -> Type -> PFun -> Function
prim name atypes rtype = Function (Just name) atypes rtype . Primitive

-- Primitive arithmetic functions

-- | Integer div and mod operations, for exact integers only.
-- Using an inexact (floating point) argument is an error,
-- even if the argument is "equal" to an integer (e.g., 5.0).
-- Division (div or mod) by zero is an error.
primIntDivMod :: String -> (Number -> Number -> Number) -> Function
primIntDivMod name oper  =
    let func args =
            let err msg = EvalError $ concat [name, ": ", msg, 
                                              " (", show args, ")"]
            in case args of
                 [VNumber a, VNumber b] ->
                     if b == 0
                     then err "zero divisor"
                     else if isExact a && isExact b
                          then EvalOk $ VNumber (oper a b)
                          else err "arguments must be exact numbers"
                 _ -> err "wrong type or number of arguments"
    in prim name [typeNum, typeNum] typeNum func

primIntDiv, primIntMod :: Function
primIntDiv = primIntDivMod "div" div
primIntMod = primIntDivMod "mod" mod

-- | Floating point division.
-- Integer arguments are coerced to floating point,
-- and the result is always floating point.
-- operands are ints.   
-- x / 0 is NaN if x == 0, Infinity if x > 0, -Infinity if x < 0.
primFloatDiv :: Function
primFloatDiv =
    let divide args =
            case args of
              [VNumber x, VNumber y] -> EvalOk $ VNumber (x / y)
              _ -> EvalError $ "/: invalid args: " ++ show args
    in prim "/" [typeNum, typeNum] typeNum divide

-- Primitive functions for lists

primArgCountError :: String -> EvalResult
primArgCountError name = 
    errcat [name, ": wrong number of arguments in primitive function"]

-- Some of the type-checking in these primitive functions
-- shouldn't be necessary, if Sifflet knew the types of the
-- functions and could do type inference and check input values.

primNull :: PFun
primNull args =
    case args of
      [VList list] -> EvalOk $ VBool (List.null list)
      [_] -> EvalError "null: not a list"
      _ -> primArgCountError "primNull"

primHead :: PFun
primHead args =
    case args of
      [VList (x : _xs)] -> EvalOk x
      [VList []] -> EvalError "head: empty list"
      [_] -> EvalError "head: not a list"
      _ -> primArgCountError "primHead"

primTail :: PFun
primTail args =
    case args of
      [VList (_x : xs)] -> EvalOk $ VList xs
      [VList []] -> EvalError "tail: empty list"
      [_] -> EvalError "tail: not a list"
      _ -> primArgCountError "primTail"

primCons :: PFun
primCons args =
    case args of
      [x, VList xs] -> EvalOk $ VList (x:xs)
      [_, _] -> EvalError "cons: second argument not a list"
      _ -> primArgCountError "primCons"

-- Functions for constructing Functions of common types

-- | Primitive function with 2 number arguments yield an number value
-- fn = Number function to implement for Number operands.
primN2N :: String -> (Number -> Number -> Number) -> Function
primN2N name fn =
    let impl args =
            case args of
              [VNumber x, VNumber y] -> EvalOk $ VNumber (fn x y)
              _ -> EvalError $ name ++ ": invalid args: " ++ show args
    in prim name [typeNum, typeNum] typeNum impl

-- | Primitive unary functions number to number
primN1N :: String -> (Number -> Number) -> Function
primN1N name fn = 
    let impl args =
            case args of
              [VNumber x] -> EvalOk $ VNumber (fn x)
              _ -> EvalError $ name ++ ": invalid args: " ++ show args
    in prim name [typeNum] typeNum impl

-- Primitive frunctions with 2 number args and a boolean result
primN2B :: String -> (Number -> Number -> OBool) -> Function
primN2B name fn =
    let impl args =
            case args of
              [VNumber x, VNumber y] -> EvalOk $ VBool (fn x y)
              _ -> EvalError $ name ++ ": invalid args: " ++ show args
    in prim name [typeNum, typeNum] typeBool impl


-- Primitive unary functions number to boolean
primN1B :: String -> (Number -> Bool) -> Function
primN1B name fn = 
    let impl args =
            case args of
              [VNumber x] -> EvalOk $ VBool (fn x)
              _ -> EvalError $ name ++ ": invalid args: " ++ show args
    in prim name [typeNum] typeBool impl

baseEnv :: Env
baseEnv = 
    makeEnv (map functionName primitiveFunctions)
            (map VFun primitiveFunctions)

-- | Given an expression, return the list of names of variables
-- occurring in the expression
exprSymbols :: Expr -> [Symbol]
exprSymbols expr = 
    nub $ case expr of
            EUndefined -> []    -- is *not* a variable
            ESymbol s -> [s]
            EIf t a b -> nub $ concat [exprSymbols t,
                                       exprSymbols a,
                                       exprSymbols b]
            ELambda x body -> nub (x : exprSymbols body)
            ECall f args -> 
                case args of
                  [] -> [f]
                  a:as -> nub $ concat [exprSymbols a,
                                        exprSymbols (ECall f as)]
            EList items -> nub $ concatMap exprSymbols items
            _ -> if exprIsExtended expr
                 then errcats ["exprSymbols: extended expr not supported:",
                               show expr]
                 else [] -- literal types bool, char, number, string

-- | exprVarNames expr returns the names of variables in expr
-- that are UNBOUND in the base environment.  This may not be ideal,
-- but it's a start.

exprVarNames :: Expr -> [String]
exprVarNames expr = [name | (Symbol name) <- exprSymbols expr,
                            unbound name baseEnv]