module Scheme.Core
(
eval
, evalLisp
, evalString
, evalAndPrint
, primitiveBindings
) where
import Scheme.Macro
import Scheme.Numerical
import Scheme.Parser
import Scheme.Types
import Scheme.Variables
import Control.Monad.Error
import Char
import Data.Array
import qualified Data.Map
import Maybe
import List
import IO hiding (try)
evalString :: Env -> String -> IO String
evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= macroEval env >>= (eval env (makeNullContinuation env))
evalAndPrint :: Env -> String -> IO ()
evalAndPrint env expr = evalString env expr >>= putStrLn
evalLisp :: Env -> LispVal -> IOThrowsError LispVal
evalLisp env lisp = macroEval env lisp >>= (eval env (makeNullContinuation env))
continueEval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
continueEval _ (Continuation cEnv cBody cCont Nothing Nothing) val = do
case cBody of
[] -> do
case cCont of
Continuation nEnv _ _ _ _ -> continueEval nEnv cCont val
_ -> return val
[lv] -> eval cEnv (Continuation cEnv [] cCont Nothing Nothing) lv --val
(lv : lvs) -> eval cEnv (Continuation cEnv lvs cCont Nothing Nothing) lv
continueEval _ _ _ = throwError $ Default "Internal error in continueEval"
eval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
eval env cont val@(Nil _) = continueEval env cont val
eval env cont val@(String _) = continueEval env cont val
eval env cont val@(Char _) = continueEval env cont val
eval env cont val@(Complex _) = continueEval env cont val
eval env cont val@(Float _) = continueEval env cont val
eval env cont val@(Rational _) = continueEval env cont val
eval env cont val@(Number _) = continueEval env cont val
eval env cont val@(Bool _) = continueEval env cont val
eval env cont val@(HashTable _) = continueEval env cont val
eval env cont val@(Vector _) = continueEval env cont val
eval env cont (Atom a) = continueEval env cont =<< getVar env a
eval env cont (List [Atom "quote", val]) = continueEval env cont val
eval envi cont (List [Atom "quasiquote", value]) = continueEval envi cont =<< doUnQuote envi value
where doUnQuote :: Env -> LispVal -> IOThrowsError LispVal
doUnQuote env val = do
case val of
List [Atom "unquote", vval] -> eval env (makeNullContinuation env) vval
List (x : xs) -> unquoteListM env (x:xs) >>= return . List
DottedList xs x -> do
rxs <- unquoteListM env xs >>= return
rx <- doUnQuote env x
case rx of
List [] -> return $ List rxs
List rxlst -> return $ List $ rxs ++ rxlst
DottedList rxlst rxlast -> return $ DottedList (rxs ++ rxlst) rxlast
_ -> return $ DottedList rxs rx
Vector vec -> do
let len = length (elems vec)
vList <- unquoteListM env $ elems vec >>= return
return $ Vector $ listArray (0, len) vList
_ -> eval env (makeNullContinuation env) (List [Atom "quote", val])
unquoteListM env lst = foldlM (unquoteListFld env) ([]) lst
unquoteListFld env (acc) val = do
case val of
List [Atom "unquote-splicing", vvar] -> do
evalue <- eval env (makeNullContinuation env) vvar
case evalue of
List v -> return $ (acc ++ v)
_ -> throwError $ TypeMismatch "proper list" evalue
_ -> do result <- doUnQuote env val
return $ (acc ++ [result])
eval env cont (List [Atom "if", predic, conseq, alt]) =
do result <- eval env cont predic
case result of
Bool False -> eval env cont alt
_ -> eval env cont conseq
eval env cont (List [Atom "if", predic, conseq]) =
do result <- eval env cont predic
case result of
Bool True -> eval env cont conseq
_ -> eval env cont $ List []
eval env cont (List (Atom "cond" : clauses)) =
if length clauses == 0
then throwError $ BadSpecialForm "No matching clause" $ String "cond"
else do
let c = clauses !! 0
let cs = tail clauses
test <- case c of
List (Atom "else" : _) -> eval env cont $ Bool True
List (cond : _) -> eval env cont cond
badType -> throwError $ TypeMismatch "clause" badType
case test of
Bool True -> evalCond env cont c
_ -> eval env cont $ List $ (Atom "cond" : cs)
eval env cont (List (Atom "case" : keyAndClauses)) =
do let key = keyAndClauses !! 0
let cls = tail keyAndClauses
ekey <- eval env cont key
evalCase env cont $ List $ (ekey : cls)
eval env cont (List (Atom "begin" : funcs)) =
if length funcs == 0
then eval env cont $ Nil ""
else if length funcs == 1
then eval env cont (head funcs)
else do
let fs = tail funcs
eval env cont (head funcs)
eval env cont (List (Atom "begin" : fs))
eval env cont (List [Atom "load", String filename]) = do
result <- load filename >>= liftM last . mapM (evaluate env (makeNullContinuation env))
continueEval env cont result
where evaluate env2 cont2 val2 = macroEval env2 val2 >>= eval env2 cont2
eval env cont (List [Atom "set!", Atom var, form]) = do
result <- eval env (makeNullContinuation env) form >>= setVar env var
continueEval env cont result
eval env cont (List [Atom "define", Atom var, form]) = do
result <- eval env (makeNullContinuation env) form >>= defineVar env var
continueEval env cont result
eval env cont (List (Atom "define" : List (Atom var : fparams) : fbody )) = do
result <- (makeNormalFunc env fparams fbody >>= defineVar env var)
continueEval env cont result
eval env cont (List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) = do
result <- (makeVarargs varargs env fparams fbody >>= defineVar env var)
continueEval env cont result
eval env cont (List (Atom "lambda" : List fparams : fbody)) = do
result <- makeNormalFunc env fparams fbody
continueEval env cont result
eval env cont (List (Atom "lambda" : DottedList fparams varargs : fbody)) = do
result <- makeVarargs varargs env fparams fbody
continueEval env cont result
eval env cont (List (Atom "lambda" : varargs@(Atom _) : fbody)) = do
result <- makeVarargs varargs env [] fbody
continueEval env cont result
eval env cont (List [Atom "string-fill!", Atom var, character]) = do
str <- eval env (makeNullContinuation env) =<< getVar env var
echr <- eval env (makeNullContinuation env) character
result <- ((eval env (makeNullContinuation env) =<< fillStr(str, echr))) >>= setVar env var
continueEval env cont result
where fillStr (String str, Char achr) = doFillStr (String "", Char achr, length str)
fillStr (String _, c) = throwError $ TypeMismatch "character" c
fillStr (s, _) = throwError $ TypeMismatch "string" s
doFillStr (String str, Char achr, left) = do
if left == 0
then return $ String str
else doFillStr(String $ achr : str, Char achr, left 1)
doFillStr (String _, c, _) = throwError $ TypeMismatch "character" c
doFillStr (s, Char _, _) = throwError $ TypeMismatch "string" s
doFillStr (_, _, _) = throwError $ BadSpecialForm "Unexpected error in string-fill!" $ List []
eval env cont (List [Atom "string-set!", Atom var, i, character]) = do
idx <- eval env (makeNullContinuation env) i
str <- eval env (makeNullContinuation env) =<< getVar env var
result <- ((eval env (makeNullContinuation env) =<< substr(str, character, idx))) >>= setVar env var
continueEval env cont result
where substr (String str, Char char, Number ii) = do
return $ String $ (take (fromInteger ii) . drop 0) str ++
[char] ++
(take (length str) . drop (fromInteger ii + 1)) str
substr (String _, Char _, n) = throwError $ TypeMismatch "number" n
substr (String _, c, _) = throwError $ TypeMismatch "character" c
substr (s, _, _) = throwError $ TypeMismatch "string" s
eval env cont (List [Atom "vector-set!", Atom var, i, object]) = do
idx <- eval env (makeNullContinuation env) i
obj <- eval env (makeNullContinuation env) object
vec <- eval env (makeNullContinuation env) =<< getVar env var
result <- ((eval env (makeNullContinuation env) =<< (updateVector vec idx obj))) >>= setVar env var
continueEval env cont result
where updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateVector (Vector vec) (Number idx) obj = return $ Vector $ vec//[(fromInteger idx, obj)]
updateVector v _ _ = throwError $ TypeMismatch "vector" v
eval env cont (List [Atom "vector-fill!", Atom var, object]) = do
obj <- eval env (makeNullContinuation env) object
vec <- eval env (makeNullContinuation env) =<< getVar env var
result <- ((eval env (makeNullContinuation env) =<< (fillVector vec obj))) >>= setVar env var
continueEval env cont result
where fillVector :: LispVal -> LispVal -> IOThrowsError LispVal
fillVector (Vector vec) obj = do
let l = replicate (lenVector vec) obj
return $ Vector $ (listArray (0, length l 1)) l
fillVector v _ = throwError $ TypeMismatch "vector" v
lenVector v = length (elems v)
eval env cont (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do
key <- eval env (makeNullContinuation env) rkey
value <- eval env (makeNullContinuation env) rvalue
h <- eval env (makeNullContinuation env) =<< getVar env var
case h of
HashTable ht -> do
result <- (eval env (makeNullContinuation env) $ HashTable $ Data.Map.insert key value ht) >>= setVar env var
continueEval env cont result
other -> throwError $ TypeMismatch "hash-table" other
eval env cont (List [Atom "hash-table-delete!", Atom var, rkey]) = do
key <- eval env (makeNullContinuation env) rkey
h <- eval env (makeNullContinuation env) =<< getVar env var
case h of
HashTable ht -> do
result <- (eval env (makeNullContinuation env) $ HashTable $ Data.Map.delete key ht) >>= setVar env var
continueEval env cont result
other -> throwError $ TypeMismatch "hash-table" other
eval _ _ (List [Atom "apply"]) = throwError $ BadSpecialForm "apply" $ String "Function not specified"
eval _ _ (List [Atom "apply", _]) = throwError $ BadSpecialForm "apply" $ String "Arguments not specified"
eval env cont (List (Atom "apply" : args)) = do
proc <- eval env (makeNullContinuation env) $ head $ args
lst <- eval env (makeNullContinuation env) $ head $ reverse args
argVals <- mapM (eval env (makeNullContinuation env)) $ tail $ reverse $ tail (reverse args)
case lst of
List l -> apply cont proc (argVals ++ l)
other -> throwError $ TypeMismatch "list" other
eval env cont (List (Atom "call-with-current-continuation" : args)) =
eval env cont (List (Atom "call/cc" : args))
eval _ _ (List [Atom "call/cc"]) = throwError $ Default "Procedure not specified"
eval env cont (List [Atom "call/cc", proc]) = do
func <- eval env (makeNullContinuation env) proc
case func of
PrimitiveFunc f -> liftThrows $ f [cont]
Func aparams _ _ _ _ ->
if (toInteger $ length aparams) == 1
then apply cont func [cont]
else throwError $ NumArgs (toInteger $ length aparams) [cont]
other -> throwError $ TypeMismatch "procedure" other
eval env cont (List (function : args)) = do
func <- eval env (makeNullContinuation env) function
argVals <- mapM (eval env (makeNullContinuation env)) args
apply cont func argVals
eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm
evalCase :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
evalCase envOuter cont (List (key : cases)) = do
let c = cases !! 0
ekey <- eval envOuter cont key
case c of
List (Atom "else" : exprs) -> last $ map (eval envOuter cont) exprs
List (List cond : exprs) -> do test <- checkEq envOuter ekey (List cond)
case test of
Bool True -> last $ map (eval envOuter cont) exprs
_ -> evalCase envOuter cont $ List $ ekey : tail cases
badForm -> throwError $ BadSpecialForm "Unrecognized special form in case" badForm
where
checkEq env ekey (List (x : xs)) = do
test <- eval env cont $ List [Atom "eqv?", ekey, x]
case test of
Bool True -> eval env cont $ Bool True
_ -> checkEq env ekey (List xs)
checkEq env ekey val =
case val of
List [] -> eval env cont $ Bool False
_ -> do
test <- eval env cont $ List [Atom "eqv?", ekey, val]
case test of
Bool True -> eval env cont $ Bool True
_ -> eval env cont $ Bool False
evalCase _ _ badForm = throwError $ BadSpecialForm "case: Unrecognized special form" badForm
evalCond :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
evalCond env cont (List [_, expr]) = eval env cont expr
evalCond env cont (List (_ : expr)) = last $ map (eval env cont) expr
evalCond _ _ badForm = throwError $ BadSpecialForm "evalCond: Unrecognized special form" badForm
makeFunc ::
(Monad m) =>
Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal
makeFunc varargs env fparams fbody = return $ Func (map showVal fparams) varargs fbody env False
makeNormalFunc :: (Monad m) => Env
-> [LispVal]
-> [LispVal]
-> m LispVal
makeNormalFunc = makeFunc Nothing
makeVarargs :: (Monad m) => LispVal -> Env
-> [LispVal]
-> [LispVal]
-> m LispVal
makeVarargs = makeFunc . Just . showVal
apply :: LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply _ c@(Continuation env _ _ _ _) args = do
if (toInteger $ length args) /= 1
then throwError $ NumArgs 1 args
else continueEval env c $ head args
apply _ (IOFunc func) args = func args
apply _ (PrimitiveFunc func) args = liftThrows $ func args
apply cont (Func aparams avarargs abody aclosure _) args =
if num aparams /= num args && avarargs == Nothing
then throwError $ NumArgs (num aparams) args
else (liftIO $ extendEnv aclosure $ zip (map ((,) varNamespace) aparams) args) >>= bindVarArgs avarargs >>= (evalBody abody)
where remainingArgs = drop (length aparams) args
num = toInteger . length
evalBody evBody env = case cont of
Continuation _ cBody cCont _ _ -> if length cBody == 0
then continueWithContinuation env evBody cCont
else continueWithContinuation env evBody cont
_ -> continueWithContinuation env evBody cont
continueWithContinuation cwcEnv cwcBody cwcCont =
continueEval cwcEnv (Continuation cwcEnv cwcBody cwcCont Nothing Nothing) $ Nil ""
bindVarArgs arg env = case arg of
Just argName -> liftIO $ extendEnv env [((varNamespace, argName), List $ remainingArgs)]
Nothing -> return env
apply _ func args = throwError $ BadSpecialForm "Unable to evaluate form" $ List (func : args)
primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= (flip extendEnv $ map (domakeFunc IOFunc) ioPrimitives
++ map (domakeFunc PrimitiveFunc) primitives)
where domakeFunc constructor (var, func) = ((varNamespace, var), constructor func)
ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
ioPrimitives = [("open-input-file", makePort ReadMode),
("open-output-file", makePort WriteMode),
("close-input-port", closePort),
("close-output-port", closePort),
("read", readProc),
("write", writeProc),
("read-contents", readContents),
("read-all", readAll)]
makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
makePort _ [] = throwError $ NumArgs 1 []
makePort _ args@(_ : _) = throwError $ NumArgs 1 args
closePort :: [LispVal] -> IOThrowsError LispVal
closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
closePort _ = return $ Bool False
readProc :: [LispVal] -> IOThrowsError LispVal
readProc [] = readProc [Port stdin]
readProc [Port port] = (liftIO $ hGetLine port) >>= liftThrows . readExpr
readProc args@(_ : _) = throwError $ BadSpecialForm "" $ List args
writeProc :: [LispVal] -> IOThrowsError LispVal
writeProc [obj] = writeProc [obj, Port stdout]
writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Nil "")
writeProc other = if length other == 2
then throwError $ TypeMismatch "(value port)" $ List other
else throwError $ NumArgs 2 other
readContents :: [LispVal] -> IOThrowsError LispVal
readContents [String filename] = liftM String $ liftIO $ readFile filename
readContents [] = throwError $ NumArgs 1 []
readContents args@(_ : _) = throwError $ NumArgs 1 args
load :: String -> IOThrowsError [LispVal]
load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList
readAll :: [LispVal] -> IOThrowsError LispVal
readAll [String filename] = liftM List $ load filename
readAll [] = throwError $ NumArgs 1 []
readAll args@(_ : _) = throwError $ NumArgs 1 args
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [("+", numAdd),
("-", numSub),
("*", numMul),
("/", numDiv),
("modulo", numericBinop mod),
("quotient", numericBinop quot),
("remainder", numericBinop rem),
("round", numRound),
("floor", numFloor),
("ceiling", numCeiling),
("truncate", numTruncate),
("numerator", numNumerator),
("denominator", numDenominator),
("exp", numExp),
("log", numLog),
("sin", numSin),
("cos", numCos),
("tan", numTan),
("asin", numAsin),
("acos", numAcos),
("atan", numAtan),
("sqrt", numSqrt),
("expt", numExpt),
("make-rectangular", numMakeRectangular),
("make-polar", numMakePolar),
("real-part", numRealPart ),
("imag-part", numImagPart),
("magnitude", numMagnitude),
("angle", numAngle ),
("exact->inexact", numExact2Inexact),
("inexact->exact", numInexact2Exact),
("number->string", num2String),
("=", numBoolBinopEq),
(">", numBoolBinopGt),
(">=", numBoolBinopGte),
("<", numBoolBinopLt),
("<=", numBoolBinopLte),
("&&", boolBoolBinop (&&)),
("||", boolBoolBinop (||)),
("string=?", strBoolBinop (==)),
("string<?", strBoolBinop (<)),
("string>?", strBoolBinop (>)),
("string<=?", strBoolBinop (<=)),
("string>=?", strBoolBinop (>=)),
("string-ci=?", stringCIEquals),
("string-ci<?", stringCIBoolBinop (<)),
("string-ci>?", stringCIBoolBinop (>)),
("string-ci<=?", stringCIBoolBinop (<=)),
("string-ci>=?", stringCIBoolBinop (>=)),
("car", car),
("cdr", cdr),
("cons", cons),
("eq?", eqv),
("eqv?", eqv),
("equal?", equal),
("pair?", isDottedList),
("procedure?", isProcedure),
("number?", isNumber),
("complex?", isComplex),
("real?", isReal),
("rational?", isRational),
("integer?", isInteger),
("list?", unaryOp isList),
("null?", isNull),
("symbol?", isSymbol),
("symbol->string", symbol2String),
("string->symbol", string2Symbol),
("char?", isChar),
("vector?", unaryOp isVector),
("make-vector", makeVector),
("vector", buildVector),
("vector-length", vectorLength),
("vector-ref", vectorRef),
("vector->list", vectorToList),
("list->vector", listToVector),
("make-hash-table", hashTblMake),
("hash-table?", isHashTbl),
("hash-table-exists?", hashTblExists),
("hash-table-ref", hashTblRef),
("hash-table-size", hashTblSize),
("hash-table->alist", hashTbl2List),
("hash-table-keys", hashTblKeys),
("hash-table-values", hashTblValues),
("hash-table-copy", hashTblCopy),
("string?", isString),
("string", buildString),
("make-string", makeString),
("string-length", stringLength),
("string-ref", stringRef),
("substring", substring),
("string-append", stringAppend),
("string->number", stringToNumber),
("string->list", stringToList),
("list->string", listToString),
("string-copy", stringCopy),
("boolean?", isBoolean)]
data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)
unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
unpackEquals arg1 arg2 (AnyUnpacker unpacker) =
do unpacked1 <- unpacker arg1
unpacked2 <- unpacker arg2
return $ unpacked1 == unpacked2
`catchError` (const $ return False)
boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args = if length args /= 2
then throwError $ NumArgs 2 args
else do left <- unpacker $ args !! 0
right <- unpacker $ args !! 1
return $ Bool $ left `op` right
unaryOp :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal
unaryOp f [v] = f v
unaryOp _ [] = throwError $ NumArgs 1 []
unaryOp _ args@(_ : _) = throwError $ NumArgs 1 args
strBoolBinop :: (String -> String -> Bool) -> [LispVal] -> ThrowsError LispVal
strBoolBinop = boolBinop unpackStr
boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBoolBinop = boolBinop unpackBool
unpackStr :: LispVal -> ThrowsError String
unpackStr (String s) = return s
unpackStr (Number s) = return $ show s
unpackStr (Bool s) = return $ show s
unpackStr notString = throwError $ TypeMismatch "string" notString
unpackBool :: LispVal -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
car :: [LispVal] -> ThrowsError LispVal
car [List (x : _)] = return x
car [DottedList (x : _) _] = return x
car [badArg] = throwError $ TypeMismatch "pair" badArg
car badArgList = throwError $ NumArgs 1 badArgList
cdr :: [LispVal] -> ThrowsError LispVal
cdr [List (_ : xs)] = return $ List xs
cdr [DottedList [_] x] = return x
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [badArg] = throwError $ TypeMismatch "pair" badArg
cdr badArgList = throwError $ NumArgs 1 badArgList
cons :: [LispVal] -> ThrowsError LispVal
cons [x1, List []] = return $ List [x1]
cons [x, List xs] = return $ List $ x : xs
cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast
cons [x1, x2] = return $ DottedList [x1] x2
cons badArgList = throwError $ NumArgs 2 badArgList
equal :: [LispVal] -> ThrowsError LispVal
equal [(Vector arg1), (Vector arg2)] = eqvList equal [List $ (elems arg1), List $ (elems arg2)]
equal [l1@(List _), l2@(List _)] = eqvList equal [l1, l2]
equal [(DottedList xs x), (DottedList ys y)] = equal [List $ xs ++ [x], List $ ys ++ [y]]
equal [arg1, arg2] = do
primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
[AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
eqvEquals <- eqv [arg1, arg2]
return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs 2 badArgList
makeVector, buildVector, vectorLength, vectorRef, vectorToList, listToVector :: [LispVal] -> ThrowsError LispVal
makeVector [(Number n)] = makeVector [Number n, List []]
makeVector [(Number n), a] = do
let l = replicate (fromInteger n) a
return $ Vector $ (listArray (0, length l 1)) l
makeVector [badType] = throwError $ TypeMismatch "integer" badType
makeVector badArgList = throwError $ NumArgs 1 badArgList
buildVector (o:os) = do
let lst = o:os
return $ Vector $ (listArray (0, length lst 1)) lst
buildVector badArgList = throwError $ NumArgs 1 badArgList
vectorLength [(Vector v)] = return $ Number $ toInteger $ length (elems v)
vectorLength [badType] = throwError $ TypeMismatch "vector" badType
vectorLength badArgList = throwError $ NumArgs 1 badArgList
vectorRef [(Vector v), (Number n)] = return $ v ! (fromInteger n)
vectorRef [badType] = throwError $ TypeMismatch "vector integer" badType
vectorRef badArgList = throwError $ NumArgs 2 badArgList
vectorToList [(Vector v)] = return $ List $ elems v
vectorToList [badType] = throwError $ TypeMismatch "vector" badType
vectorToList badArgList = throwError $ NumArgs 1 badArgList
listToVector [(List l)] = return $ Vector $ (listArray (0, length l 1)) l
listToVector [badType] = throwError $ TypeMismatch "list" badType
listToVector badArgList = throwError $ NumArgs 1 badArgList
hashTblMake, isHashTbl, hashTblExists, hashTblRef, hashTblSize, hashTbl2List, hashTblKeys, hashTblValues, hashTblCopy:: [LispVal] -> ThrowsError LispVal
hashTblMake _ = return $ HashTable $ Data.Map.fromList []
isHashTbl [(HashTable _)] = return $ Bool True
isHashTbl _ = return $ Bool False
hashTblExists [(HashTable ht), key@(_)] = do
case Data.Map.lookup key ht of
Just _ -> return $ Bool True
Nothing -> return $ Bool False
hashTblExists [] = throwError $ NumArgs 2 []
hashTblExists args@(_ : _) = throwError $ NumArgs 2 args
hashTblRef [(HashTable ht), key@(_)] = do
case Data.Map.lookup key ht of
Just val -> return $ val
Nothing -> throwError $ BadSpecialForm "Hash table does not contain key" key
hashTblRef [(HashTable ht), key@(_), Func _ _ _ _ _] = do
case Data.Map.lookup key ht of
Just val -> return $ val
Nothing -> throwError $ NotImplemented "thunk"
hashTblRef [badType] = throwError $ TypeMismatch "hash-table" badType
hashTblRef badArgList = throwError $ NumArgs 2 badArgList
hashTblSize [(HashTable ht)] = return $ Number $ toInteger $ Data.Map.size ht
hashTblSize [badType] = throwError $ TypeMismatch "hash-table" badType
hashTblSize badArgList = throwError $ NumArgs 1 badArgList
hashTbl2List [(HashTable ht)] = do
return $ List $ map (\(k, v) -> List [k, v]) $ Data.Map.toList ht
hashTbl2List [badType] = throwError $ TypeMismatch "hash-table" badType
hashTbl2List badArgList = throwError $ NumArgs 1 badArgList
hashTblKeys [(HashTable ht)] = do
return $ List $ map (\(k, _) -> k) $ Data.Map.toList ht
hashTblKeys [badType] = throwError $ TypeMismatch "hash-table" badType
hashTblKeys badArgList = throwError $ NumArgs 1 badArgList
hashTblValues [(HashTable ht)] = do
return $ List $ map (\(_, v) -> v) $ Data.Map.toList ht
hashTblValues [badType] = throwError $ TypeMismatch "hash-table" badType
hashTblValues badArgList = throwError $ NumArgs 1 badArgList
hashTblCopy [(HashTable ht)] = do
return $ HashTable $ Data.Map.fromList $ Data.Map.toList ht
hashTblCopy [badType] = throwError $ TypeMismatch "hash-table" badType
hashTblCopy badArgList = throwError $ NumArgs 1 badArgList
buildString :: [LispVal] -> ThrowsError LispVal
buildString [(Char c)] = return $ String [c]
buildString (Char c:rest) = do
cs <- buildString rest
case cs of
String s -> return $ String $ [c] ++ s
badType -> throwError $ TypeMismatch "character" badType
buildString [badType] = throwError $ TypeMismatch "character" badType
buildString badArgList = throwError $ NumArgs 1 badArgList
makeString :: [LispVal] -> ThrowsError LispVal
makeString [(Number n)] = return $ doMakeString n ' ' ""
makeString [(Number n), (Char c)] = return $ doMakeString n c ""
makeString badArgList = throwError $ NumArgs 1 badArgList
doMakeString :: forall a.(Num a) => a -> Char -> String -> LispVal
doMakeString n char s =
if n == 0
then String s
else doMakeString (n 1) char (s ++ [char])
stringLength :: [LispVal] -> ThrowsError LispVal
stringLength [String s] = return $ Number $ foldr (const (+1)) 0 s
stringLength [badType] = throwError $ TypeMismatch "string" badType
stringLength badArgList = throwError $ NumArgs 1 badArgList
stringRef :: [LispVal] -> ThrowsError LispVal
stringRef [(String s), (Number k)] = return $ Char $ s !! fromInteger k
stringRef [badType] = throwError $ TypeMismatch "string number" badType
stringRef badArgList = throwError $ NumArgs 2 badArgList
substring :: [LispVal] -> ThrowsError LispVal
substring [(String s), (Number start), (Number end)] =
do let slength = fromInteger $ end start
let begin = fromInteger start
return $ String $ (take slength . drop begin) s
substring [badType] = throwError $ TypeMismatch "string number number" badType
substring badArgList = throwError $ NumArgs 3 badArgList
stringCIEquals :: [LispVal] -> ThrowsError LispVal
stringCIEquals [(String str1), (String str2)] = do
if (length str1) /= (length str2)
then return $ Bool False
else return $ Bool $ ciCmp str1 str2 0
where ciCmp s1 s2 idx = if idx == (length s1)
then True
else if (toLower $ s1 !! idx) == (toLower $ s2 !! idx)
then ciCmp s1 s2 (idx + 1)
else False
stringCIEquals [badType] = throwError $ TypeMismatch "string string" badType
stringCIEquals badArgList = throwError $ NumArgs 2 badArgList
stringCIBoolBinop :: ([Char] -> [Char] -> Bool) -> [LispVal] -> ThrowsError LispVal
stringCIBoolBinop op [(String s1), (String s2)] = boolBinop unpackStr op [(String $ strToLower s1), (String $ strToLower s2)]
where strToLower str = map (toLower) str
stringCIBoolBinop _ [badType] = throwError $ TypeMismatch "string string" badType
stringCIBoolBinop _ badArgList = throwError $ NumArgs 2 badArgList
stringAppend :: [LispVal] -> ThrowsError LispVal
stringAppend [(String s)] = return $ String s
stringAppend (String st:sts) = do
rest <- stringAppend sts
case rest of
String s -> return $ String $ st ++ s
other -> throwError $ TypeMismatch "string" other
stringAppend [badType] = throwError $ TypeMismatch "string" badType
stringAppend badArgList = throwError $ NumArgs 1 badArgList
stringToNumber :: [LispVal] -> ThrowsError LispVal
stringToNumber [(String s)] = do
result <- (readExpr s)
case result of
n@(Number _) -> return n
n@(Rational _) -> return n
n@(Float _) -> return n
n@(Complex _) -> return n
_ -> return $ Bool False
stringToNumber [badType] = throwError $ TypeMismatch "string" badType
stringToNumber badArgList = throwError $ NumArgs 1 badArgList
stringToList :: [LispVal] -> ThrowsError LispVal
stringToList [(String s)] = return $ List $ map (Char) s
stringToList [badType] = throwError $ TypeMismatch "string" badType
stringToList badArgList = throwError $ NumArgs 1 badArgList
listToString :: [LispVal] -> ThrowsError LispVal
listToString [(List [])] = return $ String ""
listToString [(List l)] = buildString l
listToString [badType] = throwError $ TypeMismatch "list" badType
listToString [] = throwError $ NumArgs 1 []
listToString args@(_ : _) = throwError $ NumArgs 1 args
stringCopy :: [LispVal] -> ThrowsError LispVal
stringCopy [String s] = return $ String s
stringCopy [badType] = throwError $ TypeMismatch "string" badType
stringCopy badArgList = throwError $ NumArgs 2 badArgList
isDottedList :: [LispVal] -> ThrowsError LispVal
isDottedList ([DottedList _ _]) = return $ Bool True
isDottedList _ = return $ Bool False
isProcedure :: [LispVal] -> ThrowsError LispVal
isProcedure ([Continuation _ _ _ _ _]) = return $ Bool True
isProcedure ([PrimitiveFunc _]) = return $ Bool True
isProcedure ([Func _ _ _ _ _]) = return $ Bool True
isProcedure ([IOFunc _]) = return $ Bool True
isProcedure _ = return $ Bool False
isVector, isList :: LispVal -> ThrowsError LispVal
isVector (Vector _) = return $ Bool True
isVector _ = return $ Bool False
isList (List _) = return $ Bool True
isList _ = return $ Bool False
isNull :: [LispVal] -> ThrowsError LispVal
isNull ([List []]) = return $ Bool True
isNull _ = return $ Bool False
isSymbol :: [LispVal] -> ThrowsError LispVal
isSymbol ([Atom _]) = return $ Bool True
isSymbol _ = return $ Bool False
symbol2String :: [LispVal] -> ThrowsError LispVal
symbol2String ([Atom a]) = return $ String a
symbol2String [notAtom] = throwError $ TypeMismatch "symbol" notAtom
symbol2String [] = throwError $ NumArgs 1 []
symbol2String args@(_ : _) = throwError $ NumArgs 1 args
string2Symbol :: [LispVal] -> ThrowsError LispVal
string2Symbol ([String s]) = return $ Atom s
string2Symbol [] = throwError $ NumArgs 1 []
string2Symbol [notString] = throwError $ TypeMismatch "string" notString
string2Symbol args@(_ : _) = throwError $ NumArgs 1 args
isChar :: [LispVal] -> ThrowsError LispVal
isChar ([Char _]) = return $ Bool True
isChar _ = return $ Bool False
isString :: [LispVal] -> ThrowsError LispVal
isString ([String _]) = return $ Bool True
isString _ = return $ Bool False
isBoolean :: [LispVal] -> ThrowsError LispVal
isBoolean ([Bool _]) = return $ Bool True
isBoolean _ = return $ Bool False