sifflet-0.1.5: Expr.hs
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
_ ->
error $ "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 _ ->
error $ "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 =
error $ concat ["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]
_ -> error $ "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 ->
error ("functionBody: " ++
"no body available for primitive function")
Compound _args body -> body
instance Eq Function where
Function Nothing _ _ _ == Function Nothing _ _ _ =
error "Function (==): equality of nameless functions is undecidable"
Function mname _ _ _ == Function mname' _ _ _ = mname == mname'
-- | 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 -> error ("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
primArgError :: String -> EvalResult
primArgError name =
error $ name ++ ": wrong number of arguments in primitive function"
primNull :: PFun
primNull [VList list] = EvalOk $ VBool (List.null list)
primNull _ = primArgError "primNull"
primHead :: PFun
primHead [VList list] =
case list of
x : _xs -> EvalOk x
[] -> EvalError "head: empty list"
primHead _ = primArgError "primHead"
primTail :: PFun
primTail [VList list] =
case list of
_x : xs -> EvalOk $ VList xs
[] -> EvalError "tail: empty list"
primTail _ = primArgError "primTail"
primCons :: PFun
primCons [x, VList xs] = EvalOk $ VList (x:xs)
primCons _ = primArgError "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)