sifflet-lib-1.0: Sifflet/Language/Expr.hs
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)