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
, 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
import System.IO.Unsafe(unsafePerformIO)
import Data.Map as Map hiding (filter, foldl, 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
eNegate :: Expr -> SuccFail Expr
eNegate expr =
case expr of
ENumber n -> Succ $ ENumber (negate n)
_ -> Fail $ "eNegate: cannot handle" ++ show expr
data Symbol = Symbol String
deriving (Eq, Read, Show)
instance Pretty Symbol where
pretty (Symbol s) = s
instance Repr Symbol where repr (Symbol s) = s
type OStr = String
type OBool = Bool
type OChar = Char
data Expr = EUndefined
| ESymbol Symbol
| EBool Bool
| EChar Char
| ENumber Number
| EString String
| EIf Expr Expr Expr
| EList [Expr]
| ECall Symbol [Expr]
| EOp Operator Expr Expr
| EGroup Expr
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)
ECall (Symbol fname) args -> par fname (map repr args)
EOp op left right -> unwords [repr left, opName op, repr right]
EGroup e' -> "(" ++ repr e' ++ ")"
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
exprIsLiteral :: Expr -> Bool
exprIsLiteral e =
case e of
EBool _ -> True
EChar _ -> True
ENumber _ -> True
EString _ -> True
EList es -> all exprIsLiteral es
EGroup e' -> True
_ -> False
exprIsAtomic :: Expr -> Bool
exprIsAtomic e =
case e of
ESymbol _ -> True
EList _ -> True
_ -> exprIsLiteral e
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
eCall :: String -> [Expr] -> Expr
eCall = ECall . Symbol
data Operator = Operator {opName :: String
, opPrec :: Precedence
, opAssoc :: Bool
, opGrouping :: OperatorGrouping
}
deriving (Eq, Show)
instance Pretty Operator where
pretty = opName
type Precedence = Int
data OperatorGrouping = GroupLtoR | GroupRtoL | GroupNone
deriving (Eq, Show)
type ExprTree = Tree ExprNode
data ExprNode = ENode ExprNodeLabel EvalResult
deriving (Eq, Show)
data ExprNodeLabel = NUndefined | NSymbol Symbol
|
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
NBool b -> reprl b
NChar c -> reprl c
NNumber n -> reprl n
NString s -> [show s]
NList es -> reprl (EList es)
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)
Just value ->
case value of
VFun function -> (functionNArgs function, 1)
_ -> (0, 1)
_ -> (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 -> leafnode NUndefined
ESymbol s -> leafnode (NSymbol s)
EBool b -> leafnode (NBool b)
EChar c -> leafnode (NChar c)
ENumber n -> leafnode (NNumber n)
EString s -> leafnode (NString s)
EIf t a b -> node (NSymbol (Symbol "if")) (map exprToTree [t, a, b])
ECall f args -> node (NSymbol f) (map exprToTree args)
EList xs -> leafnode (NList xs)
EGroup _ -> errext
EOp _ _ _ -> errext
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
if null trees
then
ESymbol s
else
ECall s (map treeToExpr trees)
exprToReprTree :: Expr -> Tree String
exprToReprTree = fmap repr . exprToTree
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
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']
EvalOk weirdValue ->
let msg = "if: non-boolean condition value: " ++
repr weirdValue
in T.Node (ifNode (EvalError msg)) [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]
unevalTree :: ExprTree -> ExprTree
unevalTree atree =
let unevalNode (ENode oper _) = ENode oper EvalUntried
in fmap unevalNode atree
data Value = VBool OBool
| VChar OChar
| VNumber Number
| VString OStr
| VFun Function
| VList [Value]
deriving (Eq, Show)
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"
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 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
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
| VpTypeFunction [VpType] VpType
| VpTypeVar String
deriving (Eq, Show)
type TypeEnv = Map String VpType
emptyTypeEnv :: TypeEnv
emptyTypeEnv = Map.empty
typeMatch :: VpType -> Value -> TypeEnv -> SuccFail TypeEnv
typeMatch vptype value env =
let sorry x etype =
Fail $ repr x ++ ": " ++ etype ++ " expected"
in case (vptype, value) of
(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"
(VpTypeVar name, avalue) ->
case Map.lookup name env of
Nothing ->
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, _) ->
error "typeMatch: unimplemented case for VpTypeFunction"
_ -> Fail $ "type mismatch: " ++ show (vptype, value)
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"
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
data Functions = Functions [Function]
deriving (Eq, Show)
data Function = Function (Maybe String)
[VpType]
VpType
FunctionImpl
deriving (Show)
data FunctionImpl = Primitive ([Value] -> EvalResult)
| Compound [String] Expr
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
functionType :: Function -> ([VpType], VpType)
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
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
type EnvFrame = Map String Value
type Env = [EnvFrame]
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
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 =
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
fs' <- loop fs
return (f:fs')
in case loop env of
Just result -> result
Nothing -> envIns env name value
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
envSymbols :: Env -> [String]
envSymbols env =
case env of
[] -> []
f : fs -> keys f ++ envSymbols fs
envFunctionSymbols :: Env -> [String]
envFunctionSymbols env =
let isFunction s = case envGet env s of
VFun _ -> True
_ -> False
in [s | s <- envSymbols env, isFunction s]
envFunctions :: Env -> Functions
envFunctions env =
Functions (map (envGetFunction env)
(envFunctionSymbols env))
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
stackSize :: Int
stackSize = 1000
eval :: Expr -> Env -> EvalResult
eval expr env = evalWithLimit expr env stackSize
evalWithLimit :: Expr -> Env -> Int -> EvalResult
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 ->
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'
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 :: 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)
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]
primitiveFunctions :: [Function]
primitiveFunctions = [
primN2N "+" (+),
primN2N "-" (),
primN2N "*" (*),
primIntDiv,
primIntMod,
primFloatDiv,
primN1N "add1" succ,
primN1N "sub1" pred,
primN2B "==" (==),
primN2B "/=" (/=),
primN2B ">" (>),
primN2B ">=" (>=),
primN2B "<" (<),
primN2B "<=" (<=),
primN1B "zero?" eqZero,
primN1B "positive?" gtZero,
primN1B "negative?" ltZero,
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
prim :: String -> [VpType] -> VpType -> PFun -> Function
prim name atypes rtype = Function (Just name) atypes rtype . Primitive
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
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
primArgCountError :: String -> EvalResult
primArgCountError name =
errcat [name, ": wrong number of arguments in primitive function"]
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"
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
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
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
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)
exprSymbols :: Expr -> [Symbol]
exprSymbols expr =
nub $ case expr of
EUndefined -> []
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 []
exprVarNames :: Expr -> [String]
exprVarNames expr = [name | (Symbol name) <- exprSymbols expr,
unbound name baseEnv]
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)