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
, 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 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
stringToExpr :: String -> SuccFail Expr
stringToExpr string =
case parseModule ("x = " ++ string) of
ParseOk (HsModule
_srcLoc
_module
_justMain
_
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
hsExpToVp :: HsExp -> SuccFail Expr
hsExpToVp hsExp =
case hsExp of
HsVar (UnQual (HsSymbol name)) -> Succ $ eSymbol name
HsVar (UnQual (HsIdent name)) -> Succ $ eSymbol name
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
data Symbol = Symbol String
deriving (Eq, Read, Show)
instance Repr Symbol where repr (Symbol s) = s
type OInt = Integer
type OStr = String
type OBool = Bool
type OChar = Char
type OFloat = Double
stringToLiteral :: String -> SuccFail Expr
stringToLiteral s = stringToValue s >>= valueToLiteral
data Expr = EUndefined
| ESymbol Symbol
| ELit Value
| EIf Expr Expr Expr
| EList [Expr]
| ECall Symbol [Expr]
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
eCall :: String -> [Expr] -> Expr
eCall = ECall . Symbol
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
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)
NLit _ -> (0, 1)
exprToTree :: Expr -> ExprTree
exprToTree expr =
case expr of
EUndefined -> T.Node (ENode NUndefined EvalUntried) []
ESymbol s -> T.Node (ENode (NSymbol s) EvalUntried) []
ELit l -> T.Node (ENode (NLit l) EvalUntried) []
EIf t a b -> T.Node (ENode (NSymbol (Symbol "if")) EvalUntried)
(map exprToTree [t, a, b])
ECall f args -> T.Node (ENode (NSymbol f) EvalUntried)
(map exprToTree args)
EList [] -> T.Node (ENode (NSymbol (Symbol "[]")) EvalUntried) []
EList (x:xs) -> exprToTree (ECall (Symbol ":") [x, EList xs])
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
if null trees
then
ESymbol s
else
ECall s (map treeToExpr trees)
NLit lit -> if null trees then ELit lit
else wrong "literal node with non-empty subtrees"
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']
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
| VInt OInt
| VFloat OFloat
| VStr OStr
| VFun Function
| VList [Value]
deriving (Eq, Read, Show)
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"
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 = VpTypeBool
| VpTypeChar
| VpTypeNum
| VpTypeString
| VpTypeList VpType
| VpTypeFunction [VpType] VpType
| VpTypeVar String
deriving (Eq, Read, 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, VInt _) -> Succ env
(VpTypeNum, VFloat _) -> Succ env
(VpTypeNum, x) -> sorry x "number"
(VpTypeString, VStr _) -> 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
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"
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 (Read, 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
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 ->
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
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 succ,
primN1N "sub1" pred pred,
primN2B "==" (==) (==),
primN2B "/=" (/=) (/=),
primN2B ">" (>) (>),
primN2B ">=" (>=) (>=),
primN2B "<" (<) (<),
primN2B "<=" (<=) (<=),
primN1B "zero?" (== 0) (== 0.0),
primN1B "positive?" (> 0) (> 0.0),
primN1B "negative?" (< 0) (< 0.0),
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 -> (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
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
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 -> (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
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
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
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)
exprSymbols :: Expr -> [Symbol]
exprSymbols expr =
nub $ case expr of
EUndefined -> []
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 -> [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)