module Sifflet.Language.Expr
    (
     exprToValue, valueToLiteral, valueToLiteral'
    , Symbol(..)
    , OStr, OBool, OChar
    , Expr(..), eSymbol, eSym, eInt, eString, eChar, eFloat
    , exprIsAtomic
    , exprIsCompound
    , eBool, eFalse, eTrue, eIf
    , eList, eCall
    , exprIsLiteral
    , exprSymbols, exprVarNames
    , Operator(..)
    , Precedence
    , OperatorGrouping(..)
    , ExprTree, ExprNode(..), ExprNodeLabel(..)
    , exprNodeIoletCounter -- needs work ****** get rid of it???
    , exprToTree, treeToExpr, exprToReprTree
    , EvalResult, EvalRes(EvalOk, EvalError, EvalUntried)
    , evalTree, unevalTree
    , Value(..), valueFunction
    , Functions(..)
    , Function(..), functionName, functionNArgs
    , functionArgTypes, functionResultType, functionType
    , functionArgNames, functionBody, functionImplementation
    , FunctionDefTuple, functionToDef, functionFromDef
    , FunctionImpl(..)
    , VpType(..), typeMatch, typeCheck, vpTypeOf
    , TypeEnv, emptyTypeEnv
    , Env, emptyEnv, makeEnv, extendEnv, envInsertL, envPop
    , envIns, envSet, envGet
    , envGetFunction, envLookup, envLookupFunction
    , envSymbols, envFunctionSymbols, envFunctions
    , eval, apply
    , decideTypes, newUndefinedFunction, undefinedTypes
    , 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, map, null)
import Data.List as List

import Data.Number.Sifflet
import Sifflet.Data.Tree as T
import Sifflet.Text.Pretty
import Sifflet.Text.Repr ()
import 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.

data Symbol = Symbol String -- symbol name
            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
--
-- I've restricted function calls to the case where the function expression
-- is just a symbol, since otherwise it will be hard to visualize.
-- But with some thought, it may be possible to generalize
-- this to 
--   ECall [Expr] -- (function:args) 
-- 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]
          | 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)
        ECall (Symbol fname) args -> par fname (map repr args)
        EOp op left right -> unwords [repr left, opName op, repr right]
        EGroup e' -> "(" ++ repr e' ++ ")"


-- | 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
        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)

-- | 
-- EXPRESSION TREES
-- For pure Sifflet, so not defined for extended expressions.

type ExprTree = Tree ExprNode
data ExprNode = ENode ExprNodeLabel EvalResult
              deriving (Eq, Show)

data ExprNodeLabel = NUndefined | NSymbol Symbol 
                   |
                     -- formerly NLit Value
                     NBool Bool | NChar Char | NNumber Number 
                   | NString String
                   | NList [Expr] -- ???
              deriving (Eq, Show)

instance Repr ExprNode where
    reprl (ENode label evalRes) =
        case label of
          NUndefined ->
              case evalRes of
                EvalUntried -> ["undefined"]
                EvalError e -> ["undefined", "error: " ++ e]
                EvalOk _ -> 
                    errcats ["reprl of ExprNode: NUndefined with EvalOk",
                             "should not happen!"]
          NSymbol s ->
              case evalRes of
                EvalOk v -> [repr s, repr v]
                EvalError e -> [repr s, "error: " ++ e]
                EvalUntried -> reprl s

          -- NLit l -> reprl l
          NBool b -> reprl b
          NChar c -> reprl c
          NNumber n -> reprl n
          NString s -> [show s]
          NList es -> reprl (EList es) -- check ***

-- This was
-- exprNodeIoletCounter :: Env -> IoletCounter ExprNode
-- but IoletCounter is not available here, so use equivalent type.
-- Returns (no. of inlets, no. of outlets)
exprNodeIoletCounter :: Env -> ExprNode -> (Int, Int)
exprNodeIoletCounter env (ENode nodeLabel _nodeResult) =
    case nodeLabel of
      NUndefined -> (0, 1)
      NSymbol (Symbol "if") -> (3, 1) 
      NSymbol (Symbol s) -> 
          case envLookup env s of
            Nothing -> (0, 1)   -- probably a parameter of the function
            Just value ->
                case value of
                  VFun function -> (functionNArgs function, 1)
                  _ -> (0, 1)   -- symbol bound to non-function value
      _ -> (0, 1)

exprToTree :: Expr -> ExprTree
exprToTree expr =
    let leafnode :: ExprNodeLabel -> T.Tree ExprNode
        leafnode e = node e []
        node :: ExprNodeLabel -> [T.Tree ExprNode] -> T.Tree ExprNode
        node e ts = T.Node (ENode e EvalUntried) ts
        errext = error ("exprToTree: extended expr: " ++ show expr)
    in case expr of
         -- EUndefined, ESymbol, and literals map directly 
         -- to NUndefined, NSymbol, E(literal-type) 
         EUndefined -> leafnode NUndefined
         ESymbol s -> leafnode (NSymbol s)

         -- Literals
         EBool b -> leafnode (NBool b)
         EChar c -> leafnode (NChar c)
         ENumber n -> leafnode (NNumber n)
         EString s -> leafnode (NString s)

         -- EIf maps to symbol "if" at the root, 3 subtrees
         EIf t a b -> node (NSymbol (Symbol "if")) (map exprToTree [t, a, b])

         -- ECall maps to symbol f (function name) at the root,
         -- each argument forms a subtree
         ECall f args -> node (NSymbol f) (map exprToTree args)
         EList xs -> leafnode (NList xs)
         -- Extended Exprs not supported!
         EGroup _ -> errext
         EOp _ _ _ -> errext

-- | Convert an expression tree (back) to an expression
-- It will not give back the *same* expression in the case of an EList.
treeToExpr :: ExprTree -> Expr
treeToExpr (T.Node (ENode label _) trees) =
    let wrong msg =
            errcat ["treeToExpr: ", msg, ": node label = ",
                    show label, "; trees = ", show trees]
        lit e = if null trees then e
                    else wrong "literal node with non-empty subtrees"
    in case label of
         NUndefined -> EUndefined
         NBool b -> lit (EBool b)
         NChar c -> lit (EChar c)
         NNumber n -> lit (ENumber n)
         NString s -> lit (EString s)
         NList xs -> lit (EList xs)
         NSymbol s -> 
             if s == Symbol "if"
                then case trees of
                       [q, a, b] -> 
                           EIf (treeToExpr q) (treeToExpr a) (treeToExpr b)
                       _ -> wrong "'if' node with /= 3 subtrees"
                else 
                    -- VVV Do I really need to distinguish these two cases?
                    if null trees 
                    then 
                        -- s = terminal symbol
                        ESymbol s 
                    else -- s = function symbol in function call
                        ECall s (map treeToExpr trees) 

-- Convert an expression to a repr tree (of string elements)
-- (Why?)

exprToReprTree :: Expr -> Tree String
exprToReprTree = fmap repr . exprToTree

-- Evaluation results (or non-results)

type EvalResult = EvalRes Value

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

instance Monad EvalRes where
  EvalOk value >>= f = f value
  EvalError e >>= _f = EvalError e
  EvalUntried >>= _f = EvalUntried
  return = EvalOk
  fail = EvalError

-- Evaluate an expression tree showing the evaluation at each node.
-- There's a lot of redundancy in this computation, but does it matter?

evalTree :: ExprTree -> Env -> ExprTree
evalTree atree env = evalTreeWithLimit atree env stackSize

evalTreeWithLimit :: ExprTree -> Env -> Int -> ExprTree
evalTreeWithLimit atree env stacksize =

    let T.Node root subtrees = atree
        ss' = pred stacksize
    in case root of
         ENode (NSymbol (Symbol "if")) _ ->
             case subtrees of
               [tt, ta, tb] ->
                   let tt' = evalTreeWithLimit tt env ss'
                       ENode _ testResult = rootLabel tt'
                       subEval subtree =
                           let subtree' = evalTreeWithLimit subtree env ss'
                               ENode _ subresult = rootLabel subtree'
                           in (subresult, subtree')
                       ifNode result = ENode (NSymbol (Symbol "if")) result
                   in case testResult of
                        EvalOk (VBool True) -> 
                            let (taValue, ta') = subEval ta in
                            T.Node (ifNode taValue) [tt', ta', tb]

                        EvalOk (VBool False) -> 
                            let (tbValue, tb') = subEval tb in
                            T.Node (ifNode tbValue) [tt', ta, tb']

                        EvalError msg ->
                            T.Node (ifNode (EvalError msg)) [tt', ta, tb]

                        _ -> errcats ["evalTreeWithLimit (if):",
                                      "unexpected test result"]

               _ -> error "evalTreeWithLimit: if: wrong number of subtrees"

         ENode rootOper _ ->
             T.Node (ENode rootOper (evalWithLimit (treeToExpr atree) env ss'))
                  [evalTreeWithLimit s env ss' | s <- subtrees]

-- remove the values from the ExprNodes
-- "inverse" of evalTree 
unevalTree :: ExprTree -> ExprTree
unevalTree atree = 
    let unevalNode (ENode oper _) = ENode oper EvalUntried
    in fmap unevalNode atree

-- 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) = show f
  repr (VList vs) = reprList "[" ", " "]" vs

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

-- | 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]
                       

data VpType = VpTypeBool
            | VpTypeChar
            | VpTypeNum
            | VpTypeString 
            | VpTypeList VpType -- list with fixed type of elements
            | VpTypeFunction [VpType] VpType -- argument, result types
            | VpTypeVar String               -- named type variable
          deriving (Eq, Show)


type TypeEnv = Map String VpType

emptyTypeEnv :: TypeEnv
emptyTypeEnv = Map.empty

-- | Try to match a single type and value,
-- may result in binding a type variable in a new environment
-- or just the old environment
typeMatch :: VpType -> Value -> TypeEnv -> SuccFail TypeEnv
typeMatch vptype value env = 
    let sorry x etype =
            Fail $ repr x ++ ": " ++ etype ++ " expected"
    in case (vptype, value) of
      -- easy cases
      (VpTypeBool, VBool _) -> Succ env
      (VpTypeBool, x) -> sorry x "True or False"
      (VpTypeChar, VChar _) -> Succ env
      (VpTypeChar, x) -> sorry x "character"
      (VpTypeNum, VNumber _) -> Succ env
      (VpTypeNum, x) -> sorry x "number"
      (VpTypeString, VString _) -> Succ env
      (VpTypeString, x) -> sorry x "string"
      -- VV Harder
      -- VV Are the avalues below supposed to be equal to the value above?
      (VpTypeVar name, avalue) -> 
          case Map.lookup name env of
            Nothing -> 
                -- bind type variable
                vpTypeOf avalue >>= \ vtype -> Succ $ Map.insert name vtype env
            Just concreteType -> typeMatch concreteType avalue env
      (VpTypeList etype, VList lvalues) ->
          case lvalues of
            [] -> Succ env
            v:vs -> 
                typeMatch etype v env >>= 
                typeMatch (VpTypeList etype) (VList vs)
      (VpTypeFunction _atypes _rtype, _) ->
          -- this will require matching type variables with type variables!
          error "typeMatch: unimplemented case for VpTypeFunction"
      _ -> Fail $ "type mismatch: " ++ show (vptype, value)


-- | Determine the type of a value.
-- May result in a type variable.

vpTypeOf :: Value -> SuccFail VpType
vpTypeOf v =
    case v of
      VBool _ -> Succ VpTypeBool
      VChar _ -> Succ VpTypeChar
      VNumber _ -> Succ VpTypeNum
      VString _ -> Succ VpTypeString
      VFun (Function _ atypes rtype _) -> Succ $ VpTypeFunction atypes rtype

      VList []  -> Succ $ VpTypeList $ VpTypeVar "list_element"
      VList (x:xs) -> 
          do
            xtype <- vpTypeOf x
            xstypes <- mapM vpTypeOf xs
            if filter (/= xtype) xstypes == []
               then Succ $ VpTypeList xtype
               else Fail "list with diverse element types"

-- | Check whether the values agree with the types (which may be abstract)
--
-- This is *probably* too lenient in the case of type variables:
-- it can pass a mixed-type list.

typeCheck :: [String] -> [VpType] -> [Value] -> SuccFail [Value]
typeCheck names types values =
    let check :: TypeEnv -> [String] -> [VpType] -> [Value] -> SuccFail [Value]
        check _ [] [] [] = Succ []
        check env (n:ns) (t:ts) (v:vs) = 
            case typeMatch t v env of
              Succ env' -> check env' ns ts vs >>= Succ . (v:)
              Fail msg -> Fail $ "For variable " ++ n ++ ":\n" ++ msg
        check _ _ _ _ = error "typeCheck: mismatched list lengths"
    in check empty names types values
       
-- | A collection of functions, typically to be saved or exported
-- or read from a file

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

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

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 (Function mname _ _ _) =
      case mname of
        Nothing -> "<an unnamed function>"
        Just name -> "<function " ++ name ++ ">"

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

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

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

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

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

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

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], [VpType], VpType, 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'
                result -> result

          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" [VpTypeList (VpTypeVar "a")] 
                            VpTypeBool primNull,

                       prim "head" [VpTypeList (VpTypeVar "c")] 
                            (VpTypeVar "c")
                            primHead,
                       prim "tail" [VpTypeList (VpTypeVar "c")] 
                            (VpTypeList (VpTypeVar "c"))
                            primTail,
                       prim ":" [VpTypeVar "d", VpTypeList (VpTypeVar "d")]
                            (VpTypeList (VpTypeVar "d"))
                            primCons
                     ]

type PFun = [Value] -> EvalResult

-- Primitive functions of arbitrary type
prim :: String -> [VpType] -> VpType -> 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"
                 _ -> error "wrong type or number of arguments"
    in prim name [VpTypeNum, VpTypeNum] VpTypeNum 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 "/" [VpTypeNum, VpTypeNum] VpTypeNum 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 [VpTypeNum, VpTypeNum] VpTypeNum 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 [VpTypeNum] VpTypeNum 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 [VpTypeNum, VpTypeNum] VpTypeBool 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 [VpTypeNum] VpTypeBool impl

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

-- | Given an expression, return the list of names of variables
-- occurring n 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]
            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]

-- | decideTypes tries to find the argument types and return type
-- of an expression considered as the body of a function,
-- at the same time checking for consistency of inputs and
-- outputs between the parts of the expression.
-- It returns Right (argtypes, returntype) if successful;
-- Left errormessage otherwise.

decideTypes :: Expr -> [String] -> Env -> Either String ([VpType], VpType)
decideTypes expr args _env =
    unsafePerformIO $ do 
      {
        print "Fudged the decideTypes"
      ; print expr
      ; return (if True
                then Right (undefinedTypes args)
                else Left "decideTypes: not implemented")
      }

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