Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Added listings for chapter 9

Also added a factorial scheme program to go with it :)
  • Loading branch information...
commit db9faedcdfeb71c8b4ec38a0bb19c7f3b4fcd25d 1 parent 0649e56
@dstcruz authored
Showing with 784 additions and 0 deletions.
  1. +3 −0  ch09/factorial.scm
  2. +781 −0 ch09/listing_1.hs
View
3  ch09/factorial.scm
@@ -0,0 +1,3 @@
+(define (factorial x) (if (= x 1) 1 (* x (factorial (- x 1)))))
+
+(factorial 10)
View
781 ch09/listing_1.hs
@@ -0,0 +1,781 @@
+{-# 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
+ }
+ | IOFunc ([LispVal] -> IOThrowsError LispVal)
+ | Port Handle
+
+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
+ if null args then runRepl else runOne $ args
+
+readOrThrow :: Parser a -> String -> ThrowsError a
+readOrThrow parser input = case parse parser "lisp" input of
+ Left err -> throwError $ Parser err
+ Right val -> return val
+
+--readExpr :: String -> ThrowsError LispVal
+readExpr = readOrThrow parseExpr
+readExprList = readOrThrow (endBy parseExpr spaces)
+
+runOne :: [String] -> IO ()
+runOne args = do
+ env <- primitiveBindings >>= flip bindVars [("args", List $ map String $ drop 1 args)]
+ (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)]))
+ >>= hPutStrLn stderr
+
+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) ++ ") ...)"
+
+showVal (Port _) = "<IO port>"
+showVal (IOFunc _) = "<IO primitive>"
+
+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 [Atom "load", String filename]) =
+ load filename >>= liftM last . mapM (eval env)
+
+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 (<=))
+ ,("string>=?", strBoolBinop (>=))
+ ,("string-ci=?", strBoolBinop (ci_help (==)))
+ ,("string-ci<?", strBoolBinop (ci_help (<)))
+ ,("string-ci>?", strBoolBinop (ci_help (>)))
+ ,("string-ci<=?", strBoolBinop (ci_help (<=)))
+ ,("string-ci>=?", strBoolBinop (ci_help (>=)))
+ ,("not", unaryOp not')
+ ,("boolean?", unaryOp boolP)
+ ,("list?", unaryOp listP)
+ ,("symbol?", unaryOp symbolP)
+ ,("char?", unaryOp charP)
+ ,("string?", unaryOp stringP)
+ ,("vector?", unaryOp vectorP)
+ ,("symbol->string", unaryOp symbol2string)
+ ,("string->symbol", unaryOp string2symbol)
+ ,("car", car)
+ ,("cdr", cdr)
+ ,("cons", cons)
+ ,("eqv?", eqv)
+ ,("eq?", eqv)
+ ,("equal?", equal)
+ ,("make-string", make_string)
+ ,("string", create_string)
+ ,("string-length", string_length)
+ ,("string-ref", char_at)
+ ,("substring", substring)
+ ,("string-append", string_append)
+ ]
+
+--
+-- IO Primitives
+--
+ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
+ioPrimitives = [("apply", applyProc)
+ ,("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)
+ ]
+
+--
+-- IO Primitive helpers
+--
+applyProc :: [LispVal] -> IOThrowsError LispVal
+applyProc [func, List args] = apply func args
+applyProc (func : args) = apply func args
+
+makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
+makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
+
+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
+
+writeProc :: [LispVal] -> IOThrowsError LispVal
+writeProc [obj] = writeProc [obj, Port stdout]
+writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)
+
+readContents :: [LispVal] -> IOThrowsError LispVal
+readContents [String filename] = liftM String $ liftIO $ readFile filename
+
+load :: String -> IOThrowsError [LispVal]
+load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList
+
+readAll :: [LispVal] -> IOThrowsError LispVal
+readAll [String filename] = liftM List $ load filename
+
+--
+-- 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"
+
+ci_help :: (String -> String -> Bool) -> String -> String -> Bool
+ci_help f a b = f (map toLower a) (map toLower b)
+
+--
+-- 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
+
+apply (IOFunc func) args = func args
+
+
+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 (makeFunc IOFunc) ioPrimitives
+ ++ map (makeFunc PrimitiveFunc) primitives)
+ where makeFunc constructor (var, func) = (var, constructor func)
+
+makeFunc varargs env params body = return $ Func (map showVal params) varargs body env
+makeNormalFunc = makeFunc Nothing
+makeVarargs = makeFunc . Just . showVal
Please sign in to comment.
Something went wrong with that request. Please try again.