sifflet-lib-1.1: Sifflet/Language/Expr.hs
module Sifflet.Language.Expr
(
exprToValue, valueToLiteral, valueToLiteral'
, Symbol(..)
, OStr, OBool, OChar
, Expr(..), eSymbol, eSym, eInt, eString, eChar, eFloat
, exprIsAtomic
, exprIsCompound
, eBool, eFalse, eTrue, eIf
, eList, eCall
, exprIsLiteral
, exprSymbols, exprVarNames
, Operator(..)
, Precedence
, OperatorGrouping(..)
, ExprTree, ExprNode(..), ExprNodeLabel(..)
, exprNodeIoletCounter -- needs work ****** get rid of it???
, exprToTree, treeToExpr, exprToReprTree
, EvalResult, EvalRes(EvalOk, EvalError, EvalUntried)
, evalTree, unevalTree
, Value(..), valueFunction
, Functions(..)
, Function(..), functionName, functionNArgs
, functionArgTypes, functionResultType, functionType
, functionArgNames, functionBody, functionImplementation
, FunctionDefTuple, functionToDef, functionFromDef
, FunctionImpl(..)
, VpType(..), typeMatch, typeCheck, vpTypeOf
, TypeEnv, emptyTypeEnv
, Env, emptyEnv, makeEnv, extendEnv, envInsertL, envPop
, envIns, envSet, envGet
, envGetFunction, envLookup, envLookupFunction
, envSymbols, envFunctionSymbols, envFunctions
, eval, apply
, decideTypes, newUndefinedFunction, undefinedTypes
, ePlus, eTimes, eMinus, eDiv, eMod
, eAdd1, eSub1
, eEq, eNe, eGt, eGe, eLt, eLe
, eZerop, ePositivep, eNegativep
, baseEnv)
where
-- drop this after debugging:
import System.IO.Unsafe(unsafePerformIO)
import Data.Map as Map hiding (filter, map, null)
import Data.List as List
import Data.Number.Sifflet
import Sifflet.Data.Tree as T
import Sifflet.Text.Pretty
import Sifflet.Text.Repr ()
import Sifflet.Util
-- | Transform a numerical expression into its negation,
-- e.g., 5 --> (-5).
-- Fails if the expression is not an ENumber.
eNegate :: Expr -> SuccFail Expr
eNegate expr =
case expr of
ENumber n -> Succ $ ENumber (negate n)
_ -> Fail $ "eNegate: cannot handle" ++ show expr
-- Symbols have names, and may or may not have values,
-- but the value is stored in an environment, not in the symbol itself.
data Symbol = Symbol String -- symbol name
deriving (Eq, Read, Show)
instance Pretty Symbol where
pretty (Symbol s) = s
instance Repr Symbol where repr (Symbol s) = s
-- The Haskell representations of V's primitive data types.
-- Data.Number.Sifflet.Number represents exact and inexact numbers.
type OStr = String
type OBool = Bool
type OChar = Char
-- | A more highly "parsed" type of expression
--
-- I've restricted function calls to the case where the function expression
-- is just a symbol, since otherwise it will be hard to visualize.
-- But with some thought, it may be possible to generalize
-- this to
-- ECall [Expr] -- (function:args)
-- The constructors EOp and EGroup are not used in Sifflet itself,
-- but they are needed for export to Python, Haskell, and similar languages;
-- they allow a distinction between operators and functions, and
-- wrapping expressions in parentheses.
-- EGroup e represents parentheses used for grouping: (e);
-- it is not used for other cases of parentheses, e.g.,
-- around the argument list in a function call.]
data Expr = EUndefined
| ESymbol Symbol
| EBool Bool
| EChar Char
| ENumber Number
| EString String
| EIf Expr Expr Expr -- ^ if test branch1 branch2
| EList [Expr]
| ECall Symbol [Expr] -- ^ function name, arglist
| EOp Operator Expr Expr -- ^ binary operator application
| EGroup Expr -- ^ grouping parentheses
deriving (Eq, Show)
instance Repr Expr where
repr e =
case e of
EUndefined -> "*undefined*"
ESymbol s -> repr s
EBool b -> repr b
EChar c -> repr c
ENumber n -> repr n
EString s -> show s
EIf t a b -> par "if" (map repr [t, a, b])
EList xs -> if exprIsLiteral e
then reprList "[" ", " "]" xs
else error ("Expr.repr: EList expression is non-literal: "
++ show e)
-- check *** was: par "EList" (map repr items)
ECall (Symbol fname) args -> par fname (map repr args)
EOp op left right -> unwords [repr left, opName op, repr right]
EGroup e' -> "(" ++ repr e' ++ ")"
-- | An Expr is "extended" if it uses the extended constructors
-- EOp or EGroup. In pure Sifflet, no extended Exprs are used.
exprIsExtended :: Expr -> Bool
exprIsExtended e =
case e of
EOp _ _ _ -> True
EGroup _ -> True
EIf t a b -> exprIsExtended t ||
exprIsExtended a ||
exprIsExtended b
EList xs -> any exprIsExtended xs
ECall (Symbol _) args -> any exprIsExtended args
_ -> False
-- | Is an Expr a literal? A literal is a boolean, character, number, string,
-- or list of literals. We (should) only allow user input expressions
-- to be literal expressions.
exprIsLiteral :: Expr -> Bool
exprIsLiteral e =
case e of
EBool _ -> True
EChar _ -> True
ENumber _ -> True
EString _ -> True
EList es -> all exprIsLiteral es
-- Shouldn't we say that
-- EGroup e' *not* a literal, even if e' is a literal?
-- But consider carefully the effect on exprIsAtomic and ()'s removal.
EGroup e' -> True -- or False, or exprIsLiteral e' ???
_ -> False
-- | Is an expression atomic?
-- Atomic expressions do not need parentheses in any reasonable language,
-- because there is nothing to be grouped (symbols, literals)
-- or in the case of lists, they already have brackets
-- which separate them from their neighbors.
--
-- All lists are atomic, even if they are not literals,
-- because (for example) we can remove parentheses
-- from ([a + b, 7])
exprIsAtomic :: Expr -> Bool
exprIsAtomic e =
case e of
ESymbol _ -> True
EList _ -> True
_ -> exprIsLiteral e
-- | Compound = non-atomic
exprIsCompound :: Expr -> Bool
exprIsCompound = not . exprIsAtomic
eSymbol, eSym :: String -> Expr
eSymbol = ESymbol . Symbol
eSym = eSymbol
eInt :: Integer -> Expr
eInt = ENumber . Exact
eString :: OStr -> Expr
eString = EString
eChar :: OChar -> Expr
eChar = EChar
eFloat :: Double -> Expr
eFloat = ENumber . Inexact
eBool :: Bool -> Expr
eBool = EBool
eFalse, eTrue :: Expr
eFalse = eBool False
eTrue = eBool True
eIf :: Expr -> Expr -> Expr -> Expr
eIf = EIf
eList :: [Expr] -> Expr
eList = EList
-- | Example:
-- ePlus_2_3 = eCall "+" [eInt 2, eInt 3]
eCall :: String -> [Expr] -> Expr
eCall = ECall . Symbol
-- | An operator, such as * or +
-- An operator is associative, like +, if (a + b) + c == a + (b + c).
-- Its grouping is left to right if (a op b op c) means (a op b) op c;
-- right to left if (a op b op c) means a op (b op c).
-- Most operators group left to right.
data Operator = Operator {opName :: String
, opPrec :: Precedence
, opAssoc :: Bool -- ^ associative?
, opGrouping :: OperatorGrouping
}
deriving (Eq, Show)
instance Pretty Operator where
pretty = opName
-- | Operator priority, normally is > 0 or >= 0,
-- but does that really matter? I think not.
type Precedence = Int
-- | Operator grouping: left to right or right to left,
-- or perhaps not at all
data OperatorGrouping = GroupLtoR | GroupRtoL | GroupNone
deriving (Eq, Show)
-- |
-- EXPRESSION TREES
-- For pure Sifflet, so not defined for extended expressions.
type ExprTree = Tree ExprNode
data ExprNode = ENode ExprNodeLabel EvalResult
deriving (Eq, Show)
data ExprNodeLabel = NUndefined | NSymbol Symbol
|
-- formerly NLit Value
NBool Bool | NChar Char | NNumber Number
| NString String
| NList [Expr] -- ???
deriving (Eq, Show)
instance Repr ExprNode where
reprl (ENode label evalRes) =
case label of
NUndefined ->
case evalRes of
EvalUntried -> ["undefined"]
EvalError e -> ["undefined", "error: " ++ e]
EvalOk _ ->
errcats ["reprl of ExprNode: NUndefined with EvalOk",
"should not happen!"]
NSymbol s ->
case evalRes of
EvalOk v -> [repr s, repr v]
EvalError e -> [repr s, "error: " ++ e]
EvalUntried -> reprl s
-- NLit l -> reprl l
NBool b -> reprl b
NChar c -> reprl c
NNumber n -> reprl n
NString s -> [show s]
NList es -> reprl (EList es) -- check ***
-- This was
-- exprNodeIoletCounter :: Env -> IoletCounter ExprNode
-- but IoletCounter is not available here, so use equivalent type.
-- Returns (no. of inlets, no. of outlets)
exprNodeIoletCounter :: Env -> ExprNode -> (Int, Int)
exprNodeIoletCounter env (ENode nodeLabel _nodeResult) =
case nodeLabel of
NUndefined -> (0, 1)
NSymbol (Symbol "if") -> (3, 1)
NSymbol (Symbol s) ->
case envLookup env s of
Nothing -> (0, 1) -- probably a parameter of the function
Just value ->
case value of
VFun function -> (functionNArgs function, 1)
_ -> (0, 1) -- symbol bound to non-function value
_ -> (0, 1)
exprToTree :: Expr -> ExprTree
exprToTree expr =
let leafnode :: ExprNodeLabel -> T.Tree ExprNode
leafnode e = node e []
node :: ExprNodeLabel -> [T.Tree ExprNode] -> T.Tree ExprNode
node e ts = T.Node (ENode e EvalUntried) ts
errext = error ("exprToTree: extended expr: " ++ show expr)
in case expr of
-- EUndefined, ESymbol, and literals map directly
-- to NUndefined, NSymbol, E(literal-type)
EUndefined -> leafnode NUndefined
ESymbol s -> leafnode (NSymbol s)
-- Literals
EBool b -> leafnode (NBool b)
EChar c -> leafnode (NChar c)
ENumber n -> leafnode (NNumber n)
EString s -> leafnode (NString s)
-- EIf maps to symbol "if" at the root, 3 subtrees
EIf t a b -> node (NSymbol (Symbol "if")) (map exprToTree [t, a, b])
-- ECall maps to symbol f (function name) at the root,
-- each argument forms a subtree
ECall f args -> node (NSymbol f) (map exprToTree args)
EList xs -> leafnode (NList xs)
-- Extended Exprs not supported!
EGroup _ -> errext
EOp _ _ _ -> errext
-- | Convert an expression tree (back) to an expression
-- It will not give back the *same* expression in the case of an EList.
treeToExpr :: ExprTree -> Expr
treeToExpr (T.Node (ENode label _) trees) =
let wrong msg =
errcat ["treeToExpr: ", msg, ": node label = ",
show label, "; trees = ", show trees]
lit e = if null trees then e
else wrong "literal node with non-empty subtrees"
in case label of
NUndefined -> EUndefined
NBool b -> lit (EBool b)
NChar c -> lit (EChar c)
NNumber n -> lit (ENumber n)
NString s -> lit (EString s)
NList xs -> lit (EList xs)
NSymbol s ->
if s == Symbol "if"
then case trees of
[q, a, b] ->
EIf (treeToExpr q) (treeToExpr a) (treeToExpr b)
_ -> wrong "'if' node with /= 3 subtrees"
else
-- VVV Do I really need to distinguish these two cases?
if null trees
then
-- s = terminal symbol
ESymbol s
else -- s = function symbol in function call
ECall s (map treeToExpr trees)
-- Convert an expression to a repr tree (of string elements)
-- (Why?)
exprToReprTree :: Expr -> Tree String
exprToReprTree = fmap repr . exprToTree
-- Evaluation results (or non-results)
type EvalResult = EvalRes Value
data EvalRes e = EvalOk e | EvalError String | EvalUntried
deriving (Eq, Show)
instance Monad EvalRes where
EvalOk value >>= f = f value
EvalError e >>= _f = EvalError e
EvalUntried >>= _f = EvalUntried
return = EvalOk
fail = EvalError
-- Evaluate an expression tree showing the evaluation at each node.
-- There's a lot of redundancy in this computation, but does it matter?
evalTree :: ExprTree -> Env -> ExprTree
evalTree atree env = evalTreeWithLimit atree env stackSize
evalTreeWithLimit :: ExprTree -> Env -> Int -> ExprTree
evalTreeWithLimit atree env stacksize =
let T.Node root subtrees = atree
ss' = pred stacksize
in case root of
ENode (NSymbol (Symbol "if")) _ ->
case subtrees of
[tt, ta, tb] ->
let tt' = evalTreeWithLimit tt env ss'
ENode _ testResult = rootLabel tt'
subEval subtree =
let subtree' = evalTreeWithLimit subtree env ss'
ENode _ subresult = rootLabel subtree'
in (subresult, subtree')
ifNode result = ENode (NSymbol (Symbol "if")) result
in case testResult of
EvalOk (VBool True) ->
let (taValue, ta') = subEval ta in
T.Node (ifNode taValue) [tt', ta', tb]
EvalOk (VBool False) ->
let (tbValue, tb') = subEval tb in
T.Node (ifNode tbValue) [tt', ta, tb']
EvalError msg ->
T.Node (ifNode (EvalError msg)) [tt', ta, tb]
_ -> errcats ["evalTreeWithLimit (if):",
"unexpected test result"]
_ -> error "evalTreeWithLimit: if: wrong number of subtrees"
ENode rootOper _ ->
T.Node (ENode rootOper (evalWithLimit (treeToExpr atree) env ss'))
[evalTreeWithLimit s env ss' | s <- subtrees]
-- remove the values from the ExprNodes
-- "inverse" of evalTree
unevalTree :: ExprTree -> ExprTree
unevalTree atree =
let unevalNode (ENode oper _) = ENode oper EvalUntried
in fmap unevalNode atree
-- VALUES AND EVALUATION
data Value = VBool OBool
| VChar OChar
| VNumber Number
| VString OStr
| VFun Function
| VList [Value]
deriving (Eq, Show)
-- no Read for Function
instance Repr Value where
repr (VBool b) = show b
repr (VChar c) = show c
repr (VNumber n) = show n
repr (VString s) = show s
repr (VFun f) = show f
repr (VList vs) = reprList "[" ", " "]" vs
valueFunction :: Value -> Function
valueFunction value =
case value of
VFun function -> function
_ -> error "valueFunction: non-function value"
-- | The value of an expression in the base environment.
exprToValue :: Expr -> SuccFail Value
exprToValue expr =
case eval expr baseEnv of
EvalOk value -> Succ value
EvalError msg -> Fail msg
EvalUntried -> error "exprToValue: eval resulted in EvalUntried"
valueToLiteral :: Value -> SuccFail Expr
valueToLiteral v =
case v of
VBool b -> Succ $ EBool b
VChar c -> Succ $ EChar c
VNumber n -> Succ $ ENumber n
VString s -> Succ $ EString s
-- VList [] -> Succ $ EList []
-- VV Should this be fixed? VV
-- VList _ -> Fail "cannot convert non-empty list to literal expression"
VList vs -> mapM valueToLiteral vs >>= Succ . EList
VFun _f -> Fail "cannot convert function to literal expression"
valueToLiteral' :: Value -> Expr
valueToLiteral' v = case valueToLiteral v of
Fail msg -> error ("valueToLiteral: " ++ msg)
Succ e -> e
-- | Convert a literal expression to the value it represents.
-- It is an error if the expression is non-literal.
-- See exprIsLiteral.
literalToValue :: Expr -> Value
literalToValue e =
case e of
EBool b -> VBool b
EChar c -> VChar c
ENumber n -> VNumber n
EString s -> VString s
EList es -> if exprIsLiteral e
then VList (map literalToValue es)
else errcats ["literalToValue: ",
"non-literal list expression: ",
show e]
_ -> errcats ["literalToValue: non-literal or extended expression: " ,
show e]
data VpType = VpTypeBool
| VpTypeChar
| VpTypeNum
| VpTypeString
| VpTypeList VpType -- list with fixed type of elements
| VpTypeFunction [VpType] VpType -- argument, result types
| VpTypeVar String -- named type variable
deriving (Eq, Show)
type TypeEnv = Map String VpType
emptyTypeEnv :: TypeEnv
emptyTypeEnv = Map.empty
-- | Try to match a single type and value,
-- may result in binding a type variable in a new environment
-- or just the old environment
typeMatch :: VpType -> Value -> TypeEnv -> SuccFail TypeEnv
typeMatch vptype value env =
let sorry x etype =
Fail $ repr x ++ ": " ++ etype ++ " expected"
in case (vptype, value) of
-- easy cases
(VpTypeBool, VBool _) -> Succ env
(VpTypeBool, x) -> sorry x "True or False"
(VpTypeChar, VChar _) -> Succ env
(VpTypeChar, x) -> sorry x "character"
(VpTypeNum, VNumber _) -> Succ env
(VpTypeNum, x) -> sorry x "number"
(VpTypeString, VString _) -> Succ env
(VpTypeString, x) -> sorry x "string"
-- VV Harder
-- VV Are the avalues below supposed to be equal to the value above?
(VpTypeVar name, avalue) ->
case Map.lookup name env of
Nothing ->
-- bind type variable
vpTypeOf avalue >>= \ vtype -> Succ $ Map.insert name vtype env
Just concreteType -> typeMatch concreteType avalue env
(VpTypeList etype, VList lvalues) ->
case lvalues of
[] -> Succ env
v:vs ->
typeMatch etype v env >>=
typeMatch (VpTypeList etype) (VList vs)
(VpTypeFunction _atypes _rtype, _) ->
-- this will require matching type variables with type variables!
error "typeMatch: unimplemented case for VpTypeFunction"
_ -> Fail $ "type mismatch: " ++ show (vptype, value)
-- | Determine the type of a value.
-- May result in a type variable.
vpTypeOf :: Value -> SuccFail VpType
vpTypeOf v =
case v of
VBool _ -> Succ VpTypeBool
VChar _ -> Succ VpTypeChar
VNumber _ -> Succ VpTypeNum
VString _ -> Succ VpTypeString
VFun (Function _ atypes rtype _) -> Succ $ VpTypeFunction atypes rtype
VList [] -> Succ $ VpTypeList $ VpTypeVar "list_element"
VList (x:xs) ->
do
xtype <- vpTypeOf x
xstypes <- mapM vpTypeOf xs
if filter (/= xtype) xstypes == []
then Succ $ VpTypeList xtype
else Fail "list with diverse element types"
-- | Check whether the values agree with the types (which may be abstract)
--
-- This is *probably* too lenient in the case of type variables:
-- it can pass a mixed-type list.
typeCheck :: [String] -> [VpType] -> [Value] -> SuccFail [Value]
typeCheck names types values =
let check :: TypeEnv -> [String] -> [VpType] -> [Value] -> SuccFail [Value]
check _ [] [] [] = Succ []
check env (n:ns) (t:ts) (v:vs) =
case typeMatch t v env of
Succ env' -> check env' ns ts vs >>= Succ . (v:)
Fail msg -> Fail $ "For variable " ++ n ++ ":\n" ++ msg
check _ _ _ _ = error "typeCheck: mismatched list lengths"
in check empty names types values
-- | A collection of functions, typically to be saved or exported
-- or read from a file
data Functions = Functions [Function]
deriving (Eq, Show)
-- | A function may have a name and always has an implementation
data Function = Function (Maybe String) -- function name
[VpType] -- argument types
VpType -- result type
FunctionImpl -- implementation
deriving (Show)
data FunctionImpl = Primitive ([Value] -> EvalResult) -- a Haskell function
| Compound [String] Expr -- arguments, body
instance Show FunctionImpl where
show (Primitive _) = "<primitive function>"
show (Compound args body) =
concat ["Compound function, args = " ++ show args ++
"; body = " ++ show body]
instance Read FunctionImpl where
readsPrec _ _ = error "readsPrec not implemented for FunctionImpl"
instance Repr Function where
repr (Function mname _ _ _) =
case mname of
Nothing -> "<an unnamed function>"
Just name -> "<function " ++ name ++ ">"
newUndefinedFunction :: String -> [String] -> Function
newUndefinedFunction name argnames =
let (atypes, rtype) = undefinedTypes argnames
impl = Compound argnames EUndefined
in Function (Just name) atypes rtype impl
functionName :: Function -> String
functionName (Function mname _ _ _) =
case mname of
Just name -> name
Nothing -> "anonymous function"
functionNArgs :: Function -> Int
functionNArgs = length . functionArgTypes
functionArgTypes :: Function -> [VpType]
functionArgTypes (Function _ argtypes _ _) = argtypes
functionResultType :: Function -> VpType
functionResultType (Function _ _ rtype _) = rtype
-- | Type type of a function, a tuple of (arg types, result type)
functionType :: Function -> ([VpType], VpType) -- (args., result type)
functionType f = (functionArgTypes f, functionResultType f)
functionImplementation :: Function -> FunctionImpl
functionImplementation (Function _ _ _ impl) = impl
functionArgNames :: Function -> [String]
functionArgNames f = case functionImplementation f of
Primitive _ ->
["dummy" | _t <- functionArgTypes f]
Compound args _body -> args
type FunctionDefTuple = (String, [String], [VpType], VpType, Expr)
functionToDef :: Function -> FunctionDefTuple
functionToDef (Function mname argTypes resType impl) =
case impl of
Primitive _ -> error "functionToDef: primitive function"
Compound argNames body ->
case mname of
Nothing -> error "functionToDef: unnamed function"
Just name -> (name, argNames, argTypes, resType, body)
functionFromDef :: FunctionDefTuple -> Function
functionFromDef (name, argNames, argTypes, resType, body) =
Function (Just name) argTypes resType (Compound argNames body)
functionBody :: Function -> Expr
functionBody f = case functionImplementation f of
Primitive _fp ->
errcats ["functionBody:",
"no body available for primitive function"]
Compound _args body -> body
-- | We need to be able to say functions are equal (or not) in order
-- to tell if environments are equal or not, in order to know whether
-- there are unsaved changes. This is tricky since the primitive
-- function implementations do not instantiate Eq, so if it's
-- primitive == primitive? we go by the names alone (there's nothing
-- else to go by). Otherwise all the parts must be equal.
instance Eq Function where
f1 == f2 =
let Function mname1 atypes1 anames1 impl1 = f1
Function mname2 atypes2 anames2 impl2 = f2
in case (impl1, impl2) of
(Primitive _, Primitive _) -> mname1 == mname2
(Compound args1 body1, Compound args2 body2 ) ->
mname1 == mname2 &&
atypes1 == atypes2 &&
anames1 == anames2 &&
args1 == args2 &&
body1 == body2
_ -> False
-- | An Environment contains variable bindings and may be linked to
-- a next environment
--
-- Perhaps it may also be used to generate Vp type variables (with int id's)
type EnvFrame = Map String Value
type Env = [EnvFrame] -- should be NON-empty
type Binding = (String, Value)
emptyEnv :: Env
emptyEnv = makeEnv [] []
makeEnv :: [String] -> [Value] -> Env
makeEnv names values = extendEnv names values []
extendEnv :: [String] -> [Value] -> Env -> Env
extendEnv names values env = fromList (zip names values) : env
-- | Insert names and values from lists into an environment
envInsertL :: Env -> [String] -> [Value] -> Env
envInsertL env names values =
case env of
[] -> error "envInsertL: empty list"
f : fs ->
let ins :: EnvFrame -> Binding -> EnvFrame
ins frame (name, value) = Map.insert name value frame
in foldl ins f (zip names values) : fs
envIns :: Env -> String -> Value -> Env
envIns env name value =
case env of
[] -> error "envIns: empty list"
f : fs -> Map.insert name value f : fs
envSet :: Env -> String -> Value -> Env
envSet env name value =
-- If name is bound in some map in the environment, update the binding
-- in that map; otherwise insert it into the "front" map
let loop :: Env -> Maybe Env
loop env1 =
case env1 of
[] -> Nothing
f:fs ->
case Map.lookup name f of
Just _ -> Just (envIns env1 name value)
Nothing ->
do -- in the Maybe monad:
fs' <- loop fs
return (f:fs')
in case loop env of
Just result -> result
Nothing -> envIns env name value
-- | Get the value of a variable from an environment
envGet :: Env -> String -> Value
envGet env name = case envLookup env name of
Just value -> value
Nothing -> errcats ["envGet: unbound variable:", name]
envGetFunction :: Env -> String -> Function
envGetFunction env name = func
where VFun func = envGet env name
envLookup :: Env -> String -> Maybe Value
envLookup env name =
case env of
[] -> Nothing
f:fs ->
case Map.lookup name f of
Just value -> Just value
Nothing -> envLookup fs name
envLookupFunction :: Env -> String -> Maybe Function
envLookupFunction env name =
case envLookup env name of
Nothing -> Nothing
Just value ->
case value of
VFun function -> Just function
_ -> Nothing
-- | List of all symbols bound in the environment
envSymbols :: Env -> [String]
envSymbols env =
case env of
[] -> []
f : fs -> keys f ++ envSymbols fs
-- | List of all symbols bound to functions in the environment
envFunctionSymbols :: Env -> [String]
envFunctionSymbols env =
let isFunction s = case envGet env s of
VFun _ -> True
_ -> False
in [s | s <- envSymbols env, isFunction s]
-- | All the functions in the environment
envFunctions :: Env -> Functions
envFunctions env =
Functions (map (envGetFunction env)
(envFunctionSymbols env))
-- | Return to the environment prior to an extendEnv
envPop :: Env -> Env
envPop env =
case env of
[] -> error "envPop: empty list"
_f:fs -> fs
unbound :: String -> Env -> Bool
unbound name env = envLookup env name == Nothing
-- EVALUATING EXPRESSIONS
-- Limit the stack size for recursion, since we are helping
-- novice programmers to learn
stackSize :: Int
stackSize = 1000
eval :: Expr -> Env -> EvalResult
eval expr env = evalWithLimit expr env stackSize
evalWithLimit :: Expr -> Env -> Int -> EvalResult
-- Evaluate an expression in an environment with a limited stack
evalWithLimit expr env stacksize =
if stacksize <= 0
then EvalError "stack overflow"
else
let stacksize' = pred stacksize in
case expr of
EUndefined -> EvalError "undefined"
ESymbol (Symbol name) ->
case envLookup env name of
Nothing -> EvalError $ "unbound variable: " ++ name
Just value -> EvalOk value
EBool b -> EvalOk (VBool b)
EChar c -> EvalOk (VChar c)
ENumber n -> EvalOk (VNumber n)
EString n -> EvalOk (VString n)
EIf t a b ->
case evalWithLimit t env stacksize' of
EvalOk (VBool True) -> evalWithLimit a env stacksize'
EvalOk (VBool False) -> evalWithLimit b env stacksize'
result -> result
ECall fsym args ->
-- evaluating a function call
-- I assume that call expressions have *symbols* for the
-- functions.
-- To relax this assumption: change the definition of ECall,
-- but how will you visualize it?
case evalWithLimit (ESymbol fsym) env stacksize' of
EvalOk f ->
case mapM (\ a -> evalWithLimit a env stacksize') args of
EvalOk argvalues -> apply f argvalues env stacksize'
-- why doesn't this work? err -> err
EvalError e -> EvalError e
EvalUntried -> EvalUntried
err -> err
EList elist ->
case mapM (\ elt -> evalWithLimit elt env stacksize') elist of
EvalOk values -> EvalOk (VList values)
EvalError e -> EvalError e
EvalUntried -> EvalUntried
_ -> errcats ["evalWithLimit: extended expression not supported",
show expr]
-- | Apply a function fvalue to a list of actual arguments args
-- in an environment env and with a limited stack size stacksize
apply :: Value -> [Value] -> Env -> Int -> EvalResult
apply fvalue args env stacksize =
case fvalue of
VFun f ->
case functionImplementation f of
Primitive pf -> pf args
Compound formalArgs body ->
evalWithLimit body (extendEnv formalArgs args env) stacksize
not_a_function ->
EvalError ("apply: first arg is not a function: " ++
show not_a_function)
-- Shortcuts for making expressions that call the primitive functions
ePlus :: Expr -> Expr -> Expr
ePlus e1 e2 = eCall "+" [e1, e2]
eTimes :: Expr -> Expr -> Expr
eTimes e1 e2 = eCall "*" [e1, e2]
eMinus, eDiv, eMod :: Expr -> Expr -> Expr
eMinus e1 e2 = eCall "-" [e1, e2]
eDiv e1 e2 = eCall "div" [e1, e2]
eMod e1 e2 = eCall "mod" [e1, e2]
eAdd1, eSub1 :: Expr -> Expr
eAdd1 e1 = eCall "add1" [e1]
eSub1 e1 = eCall "sub1" [e1]
eEq, eNe, eGt, eGe, eLt, eLe :: Expr -> Expr -> Expr
eEq e1 e2 = eCall "==" [e1, e2]
eNe e1 e2 = eCall "/=" [e1, e2]
eGt e1 e2 = eCall ">" [e1, e2]
eGe e1 e2 = eCall ">=" [e1, e2]
eLt e1 e2 = eCall "<" [e1, e2]
eLe e1 e2 = eCall "<=" [e1, e2]
eZerop, ePositivep, eNegativep :: Expr -> Expr
eZerop e1 = eCall "zero?" [e1]
ePositivep e1 = eCall "positive?" [e1]
eNegativep e1 = eCall "negative?" [e1]
-- A good base environment to get started with
primitiveFunctions :: [Function]
primitiveFunctions = [
-- Arithmetic
primN2N "+" (+), -- Number (+)
primN2N "-" (-),
primN2N "*" (*),
primIntDiv,
primIntMod,
primFloatDiv,
primN1N "add1" succ,
primN1N "sub1" pred,
-- Comparison
primN2B "==" (==),
primN2B "/=" (/=),
primN2B ">" (>),
primN2B ">=" (>=),
primN2B "<" (<),
primN2B "<=" (<=),
primN1B "zero?" eqZero,
primN1B "positive?" gtZero,
primN1B "negative?" ltZero,
-- List operations
-- null xs tells if xs is an empty list
prim "null" [VpTypeList (VpTypeVar "a")]
VpTypeBool primNull,
prim "head" [VpTypeList (VpTypeVar "c")]
(VpTypeVar "c")
primHead,
prim "tail" [VpTypeList (VpTypeVar "c")]
(VpTypeList (VpTypeVar "c"))
primTail,
prim ":" [VpTypeVar "d", VpTypeList (VpTypeVar "d")]
(VpTypeList (VpTypeVar "d"))
primCons
]
type PFun = [Value] -> EvalResult
-- Primitive functions of arbitrary type
prim :: String -> [VpType] -> VpType -> PFun -> Function
prim name atypes rtype = Function (Just name) atypes rtype . Primitive
-- Primitive arithmetic functions
-- | Integer div and mod operations, for exact integers only.
-- Using an inexact (floating point) argument is an error,
-- even if the argument is "equal" to an integer (e.g., 5.0).
-- Division (div or mod) by zero is an error.
primIntDivMod :: String -> (Number -> Number -> Number) -> Function
primIntDivMod name oper =
let func args =
let err msg = EvalError $ concat [name, ": ", msg,
" (", show args, ")"]
in case args of
[VNumber a, VNumber b] ->
if b == 0
then err "zero divisor"
else if isExact a && isExact b
then EvalOk $ VNumber (oper a b)
else err "arguments must be exact numbers"
_ -> error "wrong type or number of arguments"
in prim name [VpTypeNum, VpTypeNum] VpTypeNum func
primIntDiv, primIntMod :: Function
primIntDiv = primIntDivMod "div" div
primIntMod = primIntDivMod "mod" mod
-- | Floating point division.
-- Integer arguments are coerced to floating point,
-- and the result is always floating point.
-- operands are ints.
-- x / 0 is NaN if x == 0, Infinity if x > 0, -Infinity if x < 0.
primFloatDiv :: Function
primFloatDiv =
let divide args =
case args of
[VNumber x, VNumber y] -> EvalOk $ VNumber (x / y)
_ -> EvalError $ "/: invalid args: " ++ show args
in prim "/" [VpTypeNum, VpTypeNum] VpTypeNum divide
-- Primitive functions for lists
primArgCountError :: String -> EvalResult
primArgCountError name =
errcat [name, ": wrong number of arguments in primitive function"]
-- Some of the type-checking in these primitive functions
-- shouldn't be necessary, if Sifflet knew the types of the
-- functions and could do type inference and check input values.
primNull :: PFun
primNull args =
case args of
[VList list] -> EvalOk $ VBool (List.null list)
[_] -> EvalError "null: not a list"
_ -> primArgCountError "primNull"
primHead :: PFun
primHead args =
case args of
[VList (x : _xs)] -> EvalOk x
[VList []] -> EvalError "head: empty list"
[_] -> EvalError "head: not a list"
_ -> primArgCountError "primHead"
primTail :: PFun
primTail args =
case args of
[VList (_x : xs)] -> EvalOk $ VList xs
[VList []] -> EvalError "tail: empty list"
[_] -> EvalError "tail: not a list"
_ -> primArgCountError "primTail"
primCons :: PFun
primCons args =
case args of
[x, VList xs] -> EvalOk $ VList (x:xs)
[_, _] -> EvalError "cons: second argument not a list"
_ -> primArgCountError "primCons"
-- Functions for constructing Functions of common types
-- | Primitive function with 2 number arguments yield an number value
-- fn = Number function to implement for Number operands.
primN2N :: String -> (Number -> Number -> Number) -> Function
primN2N name fn =
let impl args =
case args of
[VNumber x, VNumber y] -> EvalOk $ VNumber (fn x y)
_ -> EvalError $ name ++ ": invalid args: " ++ show args
in prim name [VpTypeNum, VpTypeNum] VpTypeNum impl
-- | Primitive unary functions number to number
primN1N :: String -> (Number -> Number) -> Function
primN1N name fn =
let impl args =
case args of
[VNumber x] -> EvalOk $ VNumber (fn x)
_ -> EvalError $ name ++ ": invalid args: " ++ show args
in prim name [VpTypeNum] VpTypeNum impl
-- Primitive frunctions with 2 number args and a boolean result
primN2B :: String -> (Number -> Number -> OBool) -> Function
primN2B name fn =
let impl args =
case args of
[VNumber x, VNumber y] -> EvalOk $ VBool (fn x y)
_ -> EvalError $ name ++ ": invalid args: " ++ show args
in prim name [VpTypeNum, VpTypeNum] VpTypeBool impl
-- Primitive unary functions number to boolean
primN1B :: String -> (Number -> Bool) -> Function
primN1B name fn =
let impl args =
case args of
[VNumber x] -> EvalOk $ VBool (fn x)
_ -> EvalError $ name ++ ": invalid args: " ++ show args
in prim name [VpTypeNum] VpTypeBool impl
baseEnv :: Env
baseEnv =
makeEnv (map functionName primitiveFunctions)
(map VFun primitiveFunctions)
-- | Given an expression, return the list of names of variables
-- occurring n the expression
exprSymbols :: Expr -> [Symbol]
exprSymbols expr =
nub $ case expr of
EUndefined -> [] -- is *not* a variable
ESymbol s -> [s]
EIf t a b -> nub $ concat [exprSymbols t,
exprSymbols a,
exprSymbols b]
ECall f args ->
case args of
[] -> [f]
a:as -> nub $ concat [exprSymbols a,
exprSymbols (ECall f as)]
EList items -> nub $ concatMap exprSymbols items
_ -> if exprIsExtended expr
then errcats ["exprSymbols: extended expr not supported:",
show expr]
else [] -- literal types bool, char, number, string
-- | exprVarNames expr returns the names of variables in expr
-- that are UNBOUND in the base environment. This may not be ideal,
-- but it's a start.
exprVarNames :: Expr -> [String]
exprVarNames expr = [name | (Symbol name) <- exprSymbols expr,
unbound name baseEnv]
-- | decideTypes tries to find the argument types and return type
-- of an expression considered as the body of a function,
-- at the same time checking for consistency of inputs and
-- outputs between the parts of the expression.
-- It returns Right (argtypes, returntype) if successful;
-- Left errormessage otherwise.
decideTypes :: Expr -> [String] -> Env -> Either String ([VpType], VpType)
decideTypes expr args _env =
unsafePerformIO $ do
{
print "Fudged the decideTypes"
; print expr
; return (if True
then Right (undefinedTypes args)
else Left "decideTypes: not implemented")
}
undefinedTypes :: [String] -> ([VpType], VpType)
undefinedTypes argnames =
let atypes = [VpTypeVar ('_' : name) | name <- argnames]
rtype = VpTypeVar "_result"
in (atypes, rtype)