An interpreter for scheme written in haskell.
(Does not include file primitives and a standard library)
Includes solutions to chapter 5 exercise from the book “Write yourself a scheme in 48 hours” by Jonathan Tang.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE ExistentialQuantification #-} | |
| module Main where | |
| import Char (toLower) | |
| import Control.Monad (liftM) | |
| import Control.Monad.Error | |
| import Data.Array (Array (..), listArray) | |
| import Data.Char (toLower) | |
| import Data.Complex (Complex (..)) | |
| import Data.IORef | |
| import Data.Ratio (Rational (..), (%)) | |
| import IO hiding (try) | |
| import Numeric (readOct, readHex) | |
| import System.Environment | |
| import Text.ParserCombinators.Parsec hiding (spaces) | |
| data LispVal = Atom String | |
| | List [LispVal] | |
| | DottedList [LispVal] LispVal | |
| | Number Integer | |
| | Ratio Rational | |
| | Float Double | |
| | Complex (Complex Double) | |
| | String String | |
| | Char Char | |
| | Bool Bool | |
| | Vector (Array Int LispVal) | |
| | PrimitiveFunc ([LispVal] -> ThrowsError LispVal) | |
| | Func { params :: [String] | |
| , vararg :: (Maybe String) | |
| , body :: [LispVal] | |
| , closure :: Env | |
| } | |
| instance Show LispVal where show = showVal | |
| data LispError = NumArgs Integer [LispVal] | |
| | ExpectCondClauses | |
| | ExpectCaseClauses | |
| | TypeMismatch String LispVal | |
| | Parser ParseError | |
| | BadSpecialForm String LispVal | |
| | NotFunction String String | |
| | UnboundVar String String | |
| | Default String | |
| instance Show LispError where show = showError | |
| instance Error LispError where | |
| noMsg = Default "An error has occurred" | |
| strMsg = Default | |
| type ThrowsError = Either LispError | |
| type Env = IORef [(String, IORef LispVal)] | |
| type IOThrowsError = ErrorT LispError IO | |
| data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a) | |
| main :: IO () | |
| main = do | |
| args <- getArgs | |
| case length args of | |
| 0 -> runRepl | |
| 1 -> runOne $ args !! 0 | |
| otherwise -> putStrLn "Program takes 0 or 1 argument" | |
| readExpr :: String -> ThrowsError LispVal | |
| readExpr input = case parse parseExpr "lisp" input of | |
| Left err -> throwError $ Parser err | |
| Right val -> return val | |
| runOne :: String -> IO () | |
| runOne expr = primitiveBindings >>= flip evalAndPrint expr | |
| runRepl :: IO () | |
| runRepl = primitiveBindings >>= until_ (== "quit") (readPrompt "Lisp>>> ") . evalAndPrint | |
| — | |
| — LispVal Parsers | |
| — | |
| parseExpr :: Parser LispVal | |
| parseExpr = parseAtom | |
| <|> parseString | |
| <|> try parseChar | |
| <|> try parseComplex | |
| <|> try parseFloat | |
| <|> try parseRatio | |
| <|> try parseNumber | |
| <|> parseBool | |
| <|> parseQuoted | |
| <|> parseQuasiquote | |
| <|> try parseUnquoteSplicing | |
| <|> parseUnquote | |
| <|> parseList | |
| parseAtom :: Parser LispVal | |
| parseAtom = do first <- letter <|> symbol | |
| rest <- many (letter <|> digit <|> symbol) | |
| (return . Atom) (first:rest) | |
| parseList :: Parser LispVal | |
| parseList = char '(' >> parseList1 | |
| parseList1 :: Parser LispVal | |
| parseList1 = (char ')' >> (return . List) []) | |
| <|> do expr <- parseExpr | |
| parseList2 [expr] | |
| parseList2 :: [LispVal] -> Parser LispVal | |
| parseList2 expr = (char ')' >> (return . List) (reverse expr)) | |
| <|> (spaces >> parseList3 expr) | |
| parseList3 :: [LispVal] -> Parser LispVal | |
| parseList3 expr = do char '.' >> spaces | |
| dotted <- parseExpr | |
| char ')' | |
| return $ DottedList expr dotted | |
| <|> do next <- parseExpr | |
| parseList2 (next:expr) | |
| parseQuoted :: Parser LispVal | |
| parseQuoted = do char '\'' | |
| x <- parseExpr | |
| return $ List [Atom "quote", x] | |
| parseNumber :: Parser LispVal | |
| parseNumber = parsePlainNumber <|> parseRadixNumber | |
| parsePlainNumber :: Parser LispVal | |
| parsePlainNumber = many1 digit >>= return . Number . read | |
| parseRadixNumber :: Parser LispVal | |
| parseRadixNumber = char '#' >> | |
| ( | |
| parseDecimal | |
| <|> parseBinary | |
| <|> parseOctal | |
| <|> parseHex | |
| ) | |
| parseDecimal :: Parser LispVal | |
| parseDecimal = do char 'd' | |
| n <- many1 digit | |
| (return . Number . read) n | |
| parseBinary :: Parser LispVal | |
| parseBinary = do char 'b' | |
| n <- many $ oneOf "01" | |
| (return . Number . bin2int) n | |
| parseOctal :: Parser LispVal | |
| parseOctal = do char 'o' | |
| n <- many $ oneOf "01234567" | |
| (return . Number . (readWith readOct)) n | |
| parseHex :: Parser LispVal | |
| parseHex = do char 'x' | |
| n <- many $ oneOf "0123456789abcdefABCDEF" | |
| (return . Number . (readWith readHex)) n | |
| parseRatio :: Parser LispVal | |
| parseRatio = do num <- fmap read $ many1 digit | |
| char '/' | |
| denom <- fmap read $ many1 digit | |
| (return . Ratio) (num % denom) | |
| parseFloat :: Parser LispVal | |
| parseFloat = do whole <- many1 digit | |
| char '.' | |
| decimal <- many1 digit | |
| return $ Float (read (whole++"."++decimal)) | |
| parseComplex :: Parser LispVal | |
| parseComplex = do r <- fmap toDouble (try parseFloat <|> parsePlainNumber) | |
| char '+' | |
| i <- fmap toDouble (try parseFloat <|> parsePlainNumber) | |
| char 'i' | |
| (return . Complex) (r :+ i) | |
| where toDouble (Float x) = x | |
| toDouble (Number x) = fromIntegral x | |
| parseString :: Parser LispVal | |
| parseString = do char '"' | |
| s <- many (escapedChars <|> (noneOf ['\\', '"'])) | |
| char '"' | |
| (return . String) s | |
| parseChar :: Parser LispVal | |
| parseChar = do string "#\\" | |
| s <- many1 letter | |
| return $ case (map toLower s) of | |
| "space" -> Char ' ' | |
| "newline" -> Char '\n' | |
| [x] -> Char x | |
| parseBool :: Parser LispVal | |
| parseBool = do char '#' | |
| c <- oneOf "tf" | |
| return $ case c of | |
| 't' -> Bool True | |
| 'f' -> Bool False | |
| parseQuasiquote :: Parser LispVal | |
| parseQuasiquote = do char '`' | |
| expr <- parseExpr | |
| return $ List [Atom "quasiquote", expr] | |
| — Bug: this allows the unquote to appear outside of a quasiquoted list | |
| parseUnquote :: Parser LispVal | |
| parseUnquote = do char ',' | |
| expr <- parseExpr | |
| return $ List [Atom "unquote", expr] | |
| — Bug: this allows unquote-splicing to appear outside of a quasiquoted list | |
| parseUnquoteSplicing :: Parser LispVal | |
| parseUnquoteSplicing = do string ",@" | |
| expr <- parseExpr | |
| return $ List [Atom "unquote-splicing", expr] | |
| parseVector :: Parser LispVal | |
| parseVector = do string "#(" | |
| elems <- sepBy parseExpr spaces | |
| char ')' | |
| return $ Vector (listArray (0, (length elems)-1) elems) | |
| — | |
| — Show functions | |
| — | |
| showVal :: LispVal -> String | |
| showVal (String s) = "\"" ++ s ++ "\"" | |
| showVal (Atom name) = name | |
| showVal (Number n) = show n | |
| showVal (Bool True) = "#t" | |
| showVal (Bool False) = "#f" | |
| showVal (List xs) = "(" ++ unwordsList xs ++ ")" | |
| showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")" | |
| showVal (Char c) = ['\'', c, '\''] | |
| showVal (PrimitiveFunc _) = "<primitive>" | |
| showVal (Func {params=args, vararg=varargs, body=body, closure=env}) = | |
| "(lambda (" ++ unwords (map show args) ++ | |
| (case varargs of | |
| Nothing -> "" | |
| Just arg -> " . " ++ arg) ++ ") …)" | |
| showError :: LispError -> String | |
| showError ExpectCondClauses = "Expect at least 1 true cond clause" | |
| showError ExpectCaseClauses = "Expect at least 1 true case clause" | |
| showError (UnboundVar msg varname) = msg ++ ": " ++ varname | |
| showError (BadSpecialForm msg form) = msg ++ ": " ++ show form | |
| showError (NotFunction msg func) = msg ++ ": " ++ show func | |
| showError (NumArgs expected found) = "Expected " ++ show expected | |
| ++ " args; found values: " ++ unwordsList found | |
| showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected | |
| ++ ", found " ++ show found | |
| showError (Parser parseErr) = "Parser error at " ++ show parseErr | |
| — | |
| — Evaluator | |
| — | |
| eval :: Env -> LispVal -> IOThrowsError LispVal | |
| eval env val@(String _) = return val | |
| eval env val@(Char _) = return val | |
| eval env val@(Number _) = return val | |
| eval env val@(Bool _) = return val | |
| eval env (Atom id) = getVar env id | |
| eval env (List [Atom "quote", val]) = return val | |
| eval env (List [Atom "if", pred, conseq, alt]) = do | |
| result <- eval env pred | |
| case result of | |
| Bool False -> eval env alt | |
| Bool True -> eval env conseq | |
| otherwise -> throwError $ TypeMismatch "boolean" result | |
| eval env (List (Atom "cond" : [])) = throwError ExpectCondClauses | |
| eval env (List (Atom "cond" : cs)) = evalConds env cs | |
| eval env (List (Atom "case" : [])) = throwError ExpectCaseClauses | |
| eval env (List (Atom "case" : key : cs)) = do | |
| keyVal <- eval env key | |
| evalCaseCases env keyVal cs | |
| eval env (List [Atom "set!", Atom var, form]) = | |
| eval env form >>= setVar env var | |
| eval env (List [Atom "define", Atom var, form]) = | |
| eval env form >>= defineVar env var | |
| eval env (List (Atom "define" : List (Atom var : params) : body)) = | |
| makeNormalFunc env params body >>= defineVar env var | |
| eval env (List (Atom "define" : DottedList (Atom var : params) varargs : body)) = | |
| makeVarargs varargs env params body >>= defineVar env var | |
| eval env (List (Atom "lambda" : List params : body)) = | |
| makeNormalFunc env params body | |
| eval env (List (Atom "lambda" : DottedList params varargs : body)) = | |
| makeVarargs varargs env params body | |
| eval env (List (Atom "lambda" : varargs@(Atom _) : body)) = | |
| makeVarargs varargs env [] body | |
| eval env (List (function : args)) = do | |
| func <- eval env function | |
| argVals <- mapM (eval env) args | |
| apply func argVals | |
| eval env badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm | |
| — | |
| — Evaluator Helpers | |
| — | |
| evalConds :: Env -> [LispVal] -> IOThrowsError LispVal | |
| evalConds env (List (Atom "else" : xs) : []) = evalCondElse env xs | |
| evalConds _ [] = throwError ExpectCondClauses | |
| evalConds env (List clause : cs) = evalCondClause env clause cs | |
| evalConds _ badClauses = throwError $ TypeMismatch "cond clauses" $ List badClauses | |
| evalCondClause env (test : xs) rest = do | |
| result <- eval env test | |
| case test of | |
| Bool False -> evalConds env rest | |
| Bool True -> trueDo xs | |
| otherwise -> throwError $ TypeMismatch "boolean" result | |
| where | |
| trueDo [] = return $ Bool True | |
| trueDo xs = evalToLast env xs | |
| evalCondElse :: Env -> [LispVal] -> IOThrowsError LispVal | |
| evalCondElse _ [] = throwError ExpectCondClauses | |
| evalCondElse env xs = evalToLast env xs | |
| evalCaseCases :: Env -> LispVal -> [LispVal] -> IOThrowsError LispVal | |
| evalCaseCases _ _ [] = throwError ExpectCaseClauses | |
| evalCaseCases env _ [List (Atom "else" : cExprs)] = evalToLast env cExprs | |
| evalCaseCases env key ((List ((List cKeys) : cExprs)) : cs) = do | |
| let result = any anyOf $ map (\x -> eqv [key, x]) cKeys | |
| case result of | |
| False -> evalCaseCases env key cs | |
| True -> evalToLast env cExprs | |
| where | |
| anyOf (Right (Bool True)) = True | |
| anyOf _ = False | |
| evalCaseCases _ _ _ = throwError ExpectCaseClauses | |
| evalToLast :: Env -> [LispVal] -> IOThrowsError LispVal | |
| evalToLast _ [] = throwError $ NumArgs 1 [] | |
| evalToLast env xs = liftM last $ mapM (eval env) xs | |
| — | |
| — Primitive functions lookup table | |
| — | |
| primitives :: [(String, [LispVal] -> ThrowsError LispVal)] | |
| primitives = [("+", numericBinop (+)), | |
| ("-", numericBinop (-)), | |
| ("*", numericBinop (*)), | |
| ("/", numericBinop div), | |
| ("mod", numericBinop mod), | |
| ("quotient", numericBinop quot), | |
| ("remainder", numericBinop rem), | |
| ("=", numBoolBinop (==)), | |
| ("<", numBoolBinop (<)), | |
| (">", numBoolBinop (>)), | |
| ("/=", numBoolBinop (/=)), | |
| (">=", numBoolBinop (>=)), | |
| ("<=", numBoolBinop (<=)), | |
| ("&&", boolBoolBinop (&&)), | |
| ("||", boolBoolBinop (||)), | |
| ("string=?", strBoolBinop (==)), | |
| ("string?", strBoolBinop (>)), | |
| ("string<=?", strBoolBinop (<=)), | |
| ("string>=?", strBoolBinop (>=)), | |
| ("car", car), | |
| ("cdr", cdr), | |
| ("cons", cons), | |
| ("eq?", eqv), | |
| ("eqv?", eqv), | |
| ("equal?", equal)] | |
| — Unary primitive defs all have type | |
| — LispVal -> LispVal | |
| — | |
| not' (Bool x) = (Bool . not) x | |
| not' _ = Bool False | |
| boolP (Bool _) = Bool True | |
| boolP _ = Bool False | |
| listP (List _) = Bool True | |
| listP (DottedList _ _) = Bool True | |
| listP _ = Bool False | |
| symbolP (Atom _) = Bool True | |
| symbolP _ = Bool False | |
| charP (Char _) = Bool True | |
| charP _ = Bool False | |
| stringP (String _) = Bool True | |
| stringP _ = Bool False | |
| vectorP (Vector _) = Bool True | |
| vectorP _ = Bool False | |
| symbol2string (Atom s) = String s | |
| symbol2string _ = error "Expecting an Atom" | |
| string2symbol (String s) = Atom s | |
| string2symbol _ = error "Expecting a String" | |
| — | |
| — Other primitives | |
| — | |
| car :: [LispVal] -> ThrowsError LispVal | |
| car [List (x:xs)] = return x | |
| car [DottedList (x:xs) _] = 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] y] = return x | |
| cdr [DottedList (_:xs) y] = return $ DottedList xs y | |
| cdr [badArg] = throwError $ TypeMismatch "pair" badArg | |
| cdr badArgList = throwError $ NumArgs 1 badArgList | |
| cons :: [LispVal] -> ThrowsError LispVal | |
| cons [x, List []] = return $ List [x] | |
| cons [x, List xs] = return $ List (x:xs) | |
| cons [x, DottedList xs last] = return $ DottedList (x:xs) last | |
| cons [x,y] = return $ DottedList [x] y | |
| cons badArgList = throwError $ NumArgs 2 badArgList | |
| eqv :: [LispVal] -> ThrowsError LispVal | |
| eqv [(Bool b1), (Bool b2)] = (return . Bool) $ b1 == b2 | |
| eqv [(Number n1), (Number n2)] = (return . Bool) $ n1 == n2 | |
| eqv [(String s1), (String s2)] = (return . Bool) $ s1 == s2 | |
| eqv [(Atom a1), (Atom a2)] = (return . Bool) $ a1 == a2 | |
| eqv [(DottedList xs x), (DottedList ys y)] = | |
| eqv [List $ xs ++ [x], List $ ys ++ [y]] | |
| eqv [(List l1), (List l2)] = (return . Bool) $ all byPairs $ zip l1 l2 | |
| where byPairs (x,y) = case eqv [x,y] of | |
| Left err -> False | |
| Right (Bool val) -> val | |
| eqv [_, _] = return $ Bool False | |
| eqv badArgList = throwError $ NumArgs 2 badArgList | |
| equal :: [LispVal] -> ThrowsError LispVal | |
| equal [(List l1), (List l2)] = (return . Bool) $ all byPairs $ zip l1 l2 | |
| where byPairs (x,y) = case equal [x,y] of | |
| Left err -> False | |
| Right (Bool val) -> val | |
| 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 | |
| — | |
| — String primitives | |
| — | |
| make_string :: [LispVal] -> ThrowsError LispVal | |
| make_string [Number k, Char c] = return $ String $ replicate (fromIntegral k) c | |
| make_string badArgs = throwError $ TypeMismatch "int char" $ List badArgs | |
| create_string :: [LispVal] -> ThrowsError LispVal | |
| create_string xs | |
| | all isChar xs = return $ String $ foldr f "" xs | |
| | otherwise = throwError $ TypeMismatch "list of chars" $ List xs | |
| where | |
| isChar (Char _) = True | |
| isChar _ = False | |
| f (Char c) accum = c : accum | |
| string_length :: [LispVal] -> ThrowsError LispVal | |
| string_length [String s] = (return . Number . fromIntegral . length) s | |
| string_length badArgs = throwError $ TypeMismatch "string" $ List badArgs | |
| char_at :: [LispVal] -> ThrowsError LispVal | |
| char_at [String s, Number n] = (return . Char) (s !! (fromIntegral n)) | |
| char_at badArgs = throwError $ TypeMismatch "(string number)" $ List badArgs | |
| substring :: [LispVal] -> ThrowsError LispVal | |
| substring [String s, Number start, Number end] = | |
| let start' = fromIntegral start | |
| end' = fromIntegral end | |
| in (return . String) (drop start' $ take end' $ s) | |
| substring badArgs = throwError $ TypeMismatch "(string number number)" $ List badArgs | |
| string_append :: [LispVal] -> ThrowsError LispVal | |
| string_append ss | |
| | all isString ss = (return . String . concat) $ map (\(String s) -> s) ss | |
| | otherwise = throwError $ TypeMismatch "list of string" $ List ss | |
| where | |
| isString (String _) = True | |
| isString _ = False | |
| — | |
| — Primitive helpers | |
| — | |
| numericBinop :: (Integer -> Integer -> Integer) | |
| -> [LispVal] | |
| -> ThrowsError LispVal | |
| numericBinop op single@[_] = throwError $ NumArgs 2 single | |
| numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op | |
| numBoolBinop = boolBinop unpackNum | |
| strBoolBinop = boolBinop unpackStr | |
| boolBoolBinop = boolBinop unpackBool | |
| unaryOp :: (LispVal -> LispVal) | |
| -> [LispVal] | |
| -> ThrowsError LispVal | |
| unaryOp func [arg] = return $ func arg | |
| boolBinop :: (LispVal -> ThrowsError a) | |
| -> (a -> a -> Bool) | |
| -> [LispVal] | |
| -> ThrowsError LispVal | |
| boolBinop unpacker op [x,y] = do | |
| left <- unpacker x | |
| right <- unpacker y | |
| return $ Bool $ left `op` right | |
| boolBinop _ _ args = throwError $ NumArgs 2 args | |
| unpackNum :: LispVal -> ThrowsError Integer | |
| unpackNum (Number n) = return n | |
| unpackNum (List [n]) = unpackNum n | |
| unpackNum notNum = throwError $ TypeMismatch "number" notNum | |
| unpackStr :: LispVal -> ThrowsError String | |
| unpackStr (String s) = return s | |
| unpackStr (Number s) = return $ show s | |
| unpackStr (Bool s) = return $ show s | |
| unpackStr notStr = throwError $ TypeMismatch "string" notStr | |
| unpackBool :: LispVal -> ThrowsError Bool | |
| unpackBool (Bool b) = return b | |
| unpackBool notBool = throwError $ TypeMismatch "boolean" notBool | |
| 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) | |
| — | |
| — Misc Helpers | |
| — | |
| escapedChars :: Parser Char | |
| escapedChars = do | |
| char '\\' | |
| c <- oneOf ['\\','"', 'n', 'r', 't'] | |
| return $ case c of | |
| '\\' -> c | |
| '"' -> c | |
| 'n' -> '\n' | |
| 'r' -> '\r' | |
| 't' -> '\t' | |
| symbol :: Parser Char | |
| symbol = oneOf "!$%&|*+-/:<=>?@^_~" | |
| spaces :: Parser () | |
| spaces = skipMany1 space | |
| bin2int :: String -> Integer | |
| bin2int s = sum $ map (\(i,x) -> i*(2^x)) $ zip [0..] $ map p (reverse s) | |
| where p '0' = 0 | |
| p '1' = 1 | |
| readWith :: (t -> [(a, b)]) -> t -> a | |
| readWith f s = fst $ f s !! 0 | |
| unwordsList :: [LispVal] -> String | |
| unwordsList = unwords . map showVal | |
| apply :: LispVal -> [LispVal] -> IOThrowsError LispVal | |
| apply (PrimitiveFunc func) args = liftThrows $ func args | |
| apply (Func params varargs body closure) args = | |
| if num params /= num args && varargs == Nothing | |
| then throwError $ NumArgs (num params) args | |
| else (liftIO $ bindVars closure $ zip params args) >>= | |
| bindVarArgs varargs >>= | |
| evalBody | |
| where remainingArgs = drop (length params) args | |
| num = toInteger . length | |
| evalBody env = liftM last $ mapM (eval env) body | |
| bindVarArgs arg env = case arg of | |
| Just argName -> liftIO $ bindVars env [(argName, List $ remainingArgs)] | |
| Nothing -> return env | |
| trapError action = catchError action (return . show) | |
| extractValue :: ThrowsError a -> a | |
| extractValue (Right val) = val | |
| flushStr :: String -> IO () | |
| flushStr s = putStr s >> hFlush stdout | |
| readPrompt :: String -> IO String | |
| readPrompt prompt = flushStr prompt >> getLine | |
| evalString :: Env -> String -> IO String | |
| evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= eval env | |
| evalAndPrint :: Env -> String -> IO () | |
| evalAndPrint env expr = evalString env expr >>= putStrLn | |
| until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m () | |
| until_ pred prompt action = do | |
| result <- prompt | |
| if pred result | |
| then return () | |
| else action result >> until_ pred prompt action | |
| nullEnv :: IO Env | |
| nullEnv = newIORef [] | |
| liftThrows :: ThrowsError a -> IOThrowsError a | |
| liftThrows (Left err) = throwError err | |
| liftThrows (Right val) = return val | |
| runIOThrows :: IOThrowsError String -> IO String | |
| runIOThrows action = runErrorT (trapError action) >>= return . extractValue | |
| isBound :: Env -> String -> IO Bool | |
| isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var | |
| getVar :: Env -> String -> IOThrowsError LispVal | |
| getVar envRef var = do | |
| env <- liftIO $ readIORef envRef | |
| maybe (throwError $ UnboundVar "Getting an unbound variable" var) | |
| (liftIO . readIORef) | |
| (lookup var env) | |
| setVar :: Env -> String -> LispVal -> IOThrowsError LispVal | |
| setVar envRef var value = do | |
| env <- liftIO $ readIORef envRef | |
| maybe (throwError $ UnboundVar "Setting an unbound variable" var) | |
| (liftIO . (flip writeIORef value)) | |
| (lookup var env) | |
| return value | |
| defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal | |
| defineVar envRef var value = do | |
| alreadyDefined <- liftIO $ isBound envRef var | |
| if alreadyDefined | |
| then setVar envRef var value >> return value | |
| else liftIO $ do | |
| valueRef <- newIORef value | |
| env <- readIORef envRef | |
| writeIORef envRef ((var, valueRef) : env) | |
| return value | |
| bindVars :: Env -> [(String, LispVal)] -> IO Env | |
| bindVars envRef bindings = readIORef envRef >>= extendEnv bindings >>= newIORef | |
| where extendEnv bindings env = liftM (++ env) (mapM addBinding bindings) | |
| addBinding (var, value) = do | |
| ref <- newIORef value | |
| return (var, ref) | |
| primitiveBindings :: IO Env | |
| primitiveBindings = nullEnv >>= (flip bindVars $ map makePrimitiveFunc primitives) | |
| where makePrimitiveFunc (var, func) = (var, PrimitiveFunc func) | |
| makeFunc varargs env params body = return $ Func (map showVal params) varargs body env | |
| makeNormalFunc = makeFunc Nothing | |
| makeVarargs = makeFunc . Just . showVal | |