module Sifflet.Language.Expr
    (stringToExpr, exprToValue, stringToValue
    , stringToLiteral
    , Symbol(..)
    , OInt, OStr, OBool, OChar, OFloat
    , 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
    , 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)

-- Try to get rid of these:
import Language.Haskell.Syntax
import Language.Haskell.Parser


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

import Sifflet.Data.Tree as T
import Sifflet.Text.Repr ()
import Sifflet.Util

{-# DEPRECATED stringToExpr "Use Sifflet.Language.Parser.parseExpr or Sifflet.Language.Parser.parseInput instead  But stringToExpr is more general, so it may be needed in some cases." #-}

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

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, Read, 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, 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 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 (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)
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

          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)