module Expr (stringToExpr, exprToValue, stringToValue,
             stringToLiteral,
             Symbol(..), 
             Expr(..), eSymbol, eInt, eString, eChar, eFloat,
             eBool, eFalse, eTrue, eIf, 
             eList, eCall,
             exprSymbols, exprVarNames,
             ExprTree, ExprNode(..), ExprNodeLabel(..), 
             exprNodeIoletCounter, -- needs work ****** get rid of it???
             exprToTree, treeToExpr, exprToReprTree,
             EvalResult, EvalRes(EvalOk, EvalError, EvalUntried),
             evalTree, unevalTree,
             Value(..), valueFunction, 
             Function(..), functionName, functionNArgs,
             functionArgTypes, functionResultType,
             functionArgNames, functionBody, functionImplementation,
             FunctionDefTuple, functionToDef, functionFromDef,
             FunctionImpl(..),
             VpType(..), typeCheck, vpTypeOf,
             Env, makeEnv, extendEnv, envInsertL, envPop, 
             envIns, envSet, envGet, 
             envGetFunction, envLookup, envLookupFunction,
             envSymbols, envFunctionSymbols,
             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 Language.Haskell.Syntax
import Language.Haskell.Parser
{-
import Language.Haskell.Pretty
-}


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

import Tree as T
import Util

{-
testHsParse = do
  let (ParseOk (HsModule srcLoc pmod mExports imports decls)) = parseModule "foo x y = x + y"
  print $ length decls
  print $ decls!!0
  putStrLn "Wow, this is complex."
-}

stringToExpr :: String -> SuccFail Expr
stringToExpr string =
    case parseModule ("x = " ++ string) of
      ParseOk (HsModule 
               _srcLoc -- (SrcLoc ...)
               _module -- (Module "Main")
               _justMain -- (Just [HsEVar (UnQual (HsIdent "main"))])
               _ -- [] 
               result)
          -> 
          case result of
              [HsPatBind _ _ (HsUnGuardedRhs expr) []] -> 
                  hsExpToVp expr
              _ -> 
                  errcat ["stringToExpr: unexpected parse result " ++
                          "from string " ++ show string ++
                          "; result = " ++ show result]

      ParseFailed _ str -> Fail str -- not very informative

hsExpToVp :: HsExp -> SuccFail Expr
hsExpToVp hsExp = 
    case hsExp of

      HsVar (UnQual (HsSymbol name)) -> Succ $ eSymbol name -- e.g. "+"
      HsVar (UnQual (HsIdent name)) -> Succ $ eSymbol name -- e.g. "head"

      HsLit (HsInt i) -> Succ $ eInt i
      HsLit (HsFrac r) -> Succ $ eFloat (fromRational r)
      HsLit (HsChar a) -> Succ $ eChar a
      HsLit (HsString s) -> Succ $ eString s

      HsCon (UnQual (HsIdent "False")) -> Succ eFalse
      HsCon (UnQual (HsIdent "True")) -> Succ eTrue

      HsList items -> 
          case hsListItemsToVps [] items of
            Fail msg -> Fail msg
            Succ items' -> Succ (eList items')

      HsNegApp hslit -> hsExpToVp hslit >>= eNegate

      HsApp (HsVar (UnQual (HsIdent name))) hsArg -> 
          do
            arg <- hsExpToVp hsArg
            Succ $ eCall name [arg] -- ??? ***
      HsApp (HsApp hsApp1 hsArg1) hsArg2 ->
          do 
            call1 <- hsExpToVp (HsApp hsApp1 hsArg1)
            arg2 <- hsExpToVp hsArg2
            let ECall f args = call1
            Succ $ ECall f (args ++ [arg2])
      HsInfixApp hsArg1 (HsQVarOp (UnQual (HsSymbol op))) hsArg2 ->
          do
            arg1 <- hsExpToVp hsArg1
            arg2 <- hsExpToVp hsArg2
            Succ $ eCall op [arg1, arg2]

      HsIf hsExp1 hsExp2 hsExp3 ->
          do
            expr1 <- hsExpToVp hsExp1
            expr2 <- hsExpToVp hsExp2
            expr3 <- hsExpToVp hsExp3
            Succ $ eIf expr1 expr2 expr3

      HsParen hsExp1 -> hsExpToVp hsExp1

      _ -> Fail ("hsExpToVp: unknown expression type: " ++ show hsExp)

eNegate :: Expr -> SuccFail Expr
eNegate expr = 
  case expr of
    ELit (VInt i)  -> Succ $ ELit (VInt (negate i))
    ELit (VFloat x) -> Succ $ ELit (VFloat (negate x))
    _ -> Fail $ "eNegate: cannot handle" ++ show expr

hsListItemsToVps :: [Expr] -> [HsExp] -> SuccFail [Expr]
hsListItemsToVps result items =
    case items of
      [] -> Succ (reverse result)
      (x:xs) ->
          case hsExpToVp x of
            Fail msg -> Fail msg
            Succ x' -> hsListItemsToVps (x':result) xs

-- 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 Repr Symbol where repr (Symbol s) = s

-- The Haskell representations of V's primitive data types
type OInt = Integer
type OStr = String
type OBool = Bool
type OChar = Char
type OFloat = Double

stringToLiteral :: String -> SuccFail Expr
stringToLiteral s = stringToValue s >>= valueToLiteral
 
-- | A more highly "parsed" type of expression
--
-- ELit (literals) are "primitive" (self-evaluating) expressions,
-- in the sense that if x is a literal, then eval x env = EvalOk x
-- for any environment env.

data Expr = EUndefined
          | ESymbol Symbol 
          | ELit Value
          | EIf Expr Expr Expr -- if test branch1 branch2
          | EList [Expr] -- needed for hsExpToVp case HsList
          | ECall Symbol [Expr] -- function name, arglist
          -- A function expression other than a symbol will
          -- be hard to visualize:
          -- | ECall [Expr] -- (function:args) 
            deriving (Eq, Read, Show)

instance Repr Expr where
  repr EUndefined = "*undefined*"
  repr (ESymbol s) = repr s
  repr (ELit x) = repr x
  repr (EIf t a b) = par "if" (map repr [t, a, b])
  repr (EList items) = par "EList" (map repr items)
  repr (ECall (Symbol fname) args) = par fname (map repr args)

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

eInt :: OInt -> Expr
eInt = ELit . VInt

eString :: OStr -> Expr
eString = ELit . VStr

eChar :: OChar -> Expr
eChar = ELit . VChar

eFloat :: OFloat -> Expr
eFloat = ELit . VFloat

eBool :: Bool -> Expr
eBool = ELit . VBool

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


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

data ExprNodeLabel = NUndefined | NSymbol Symbol | NLit Value
              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

-- 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
      NLit _ -> (0, 1)

exprToTree :: Expr -> ExprTree
exprToTree expr =
    case expr of
      -- EUndefined, ESymbol, ELit map direclty to NUndefined, NSymbol, NLit
      EUndefined -> T.Node (ENode NUndefined EvalUntried) []
      ESymbol s -> T.Node (ENode (NSymbol s) EvalUntried) []
      ELit l -> T.Node (ENode (NLit l) EvalUntried) []
      -- EIf maps to symbol "if" at the root, 3 subtrees
      EIf t a b -> T.Node (ENode (NSymbol (Symbol "if")) EvalUntried)
                   (map exprToTree [t, a, b])
      -- ECall maps to symbol f (function name) at the root,
      -- each argument forms a subtree
      ECall f args -> T.Node (ENode (NSymbol f) EvalUntried)
                      (map exprToTree args)
      -- EList maps to the *symbol* (yes!) "[]" or to a ":" (cons) expression
      EList [] -> T.Node (ENode (NSymbol (Symbol "[]")) EvalUntried) []
      EList (x:xs) -> exprToTree (ECall (Symbol ":") [x, EList xs])

-- | 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]
    in case label of
         NUndefined -> EUndefined
         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) 
         NLit lit -> if null trees then ELit lit
                     else wrong "literal node with non-empty subtrees"

-- 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
           | VInt OInt
           | VFloat OFloat
           | VStr OStr
           | VFun Function
           | VList [Value] 
           deriving (Eq, Read, Show)
           -- no Read for Function

instance Repr Value where
  repr (VBool b) = show b
  repr (VChar c) = show c
  repr (VInt i) = show i
  repr (VFloat x) = show x
  repr (VStr s) = show s
  repr (VFun f) = show f
  repr (VList l) = 
       "[" ++ 
       concat (intersperse ", " (map repr l)) ++ 
       "]"

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
      VFun _f -> Fail "cannot convert a function to a literal"
      _ -> Succ (ELit v)
    
stringToValue :: String -> SuccFail Value
stringToValue s =
    case stringToExpr s of
      Succ expr -> exprToValue expr
      Fail errmsg -> Fail errmsg

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


type TypeEnv = Map String VpType

-- | 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, VInt _) -> Succ env
      (VpTypeNum, VFloat _) -> Succ env
      (VpTypeNum, x) -> sorry x "number"
      (VpTypeString, VStr _) -> 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
      VInt _ -> Succ VpTypeNum
      VFloat _ -> Succ VpTypeNum
      VStr _ -> 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 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 (Read, 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)
-- -- Unused
-- 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)

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]

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

          ELit value -> EvalOk value

          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

-- | 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 "+" (+) (+), -- Integer (+), Double (+)
                       primN2N "-" (-) (-),
                       primN2N "*" (*) (*),
                       primIntDiv,
                       primIntMod,
                       primFloatDiv,

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

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

                       primN1B "zero?" (== 0) (== 0.0),
                       primN1B "positive?" (> 0) (> 0.0),
                       primN1B "negative?" (< 0) (< 0.0),

                       -- 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 -> (OInt -> OInt -> OInt) -> Function
primIntDivMod name oper  =
    let func args =
            let err msg = EvalError $ concat [name, ": ", msg, 
                                              " (", show args, ")"]
            in case args of
                 [VInt a, VInt b] ->
                     if b == 0
                     then err "zero divisor"
                     else EvalOk $ VInt (oper a b)
                 [VFloat _, _] -> err "arguments must be exact numbers"
                 [_, VFloat _] -> 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
              [VInt ix, VInt iy] -> 
                  EvalOk $ VFloat (fromIntegral ix / fromIntegral iy)
              [VInt ix, VFloat y] -> EvalOk $ VFloat (fromIntegral ix / y)
              [VFloat x, VInt iy] -> EvalOk $ VFloat (x / fromIntegral iy)
              [VFloat x, VFloat y] -> EvalOk $ VFloat (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
-- fi = integer function to implement for integer operands.
-- fx = float function to implement for float operands.
primN2N :: String -> (OInt -> OInt -> OInt) -> (OFloat -> OFloat -> OFloat)
         -> Function
primN2N name fi fx =
    let impl args =
            case args of
              [VInt ix, VInt iy] -> EvalOk $ VInt (fi ix iy)
              [VInt ix, VFloat y] -> EvalOk $ VFloat (fx (fromIntegral ix) y)
              [VFloat x, VInt iy] -> EvalOk $ VFloat (fx x (fromIntegral iy))
              [VFloat x, VFloat y] -> EvalOk $ VFloat (fx x y)
              _ -> EvalError $ name ++ ": invalid args: " ++ show args
    in prim name [VpTypeNum, VpTypeNum] VpTypeNum impl

-- | Primitive unary functions number to number
primN1N :: String -> (OInt -> OInt) -> (OFloat -> OFloat) -> Function
primN1N name fi fx = 
    let impl args =
            case args of
              [VInt ix] -> EvalOk $ VInt (fi ix)
              [VFloat x] -> EvalOk $ VFloat (fx 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 -> (OInt -> OInt -> OBool) -> (OFloat -> OFloat -> OBool)
         -> Function
primN2B name fi fx =
    let impl args =
            case args of
              [VInt x, VInt y] -> EvalOk $ VBool (fi x y)
              [VInt ix, VFloat y] -> EvalOk $ VBool (fx (fromIntegral ix) y)
              [VFloat x, VInt iy] -> EvalOk $ VBool (fx x (fromIntegral iy))
              [VFloat x, VFloat y] -> EvalOk $ VBool (fx x y)
              _ -> EvalError $ name ++ ": invalid args: " ++ show args
    in prim name [VpTypeNum, VpTypeNum] VpTypeBool impl


-- Primitive unary functions number to boolean
primN1B :: String -> (OInt -> Bool) -> (OFloat -> OBool) -> Function
primN1B name fi fx = 
    let impl args =
            case args of
              [VInt ix] -> EvalOk $ VBool (fi ix)
              [VFloat x] -> EvalOk $ VBool (fx 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]
            ELit _ -> []
            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

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