From 7b39ccc46871263227b537a455d0ba7290f8aaa6 Mon Sep 17 00:00:00 2001 From: Sami Samhuri Date: Fri, 25 Sep 2009 15:32:17 -0700 Subject: [PATCH] Initial commit, previous history in darcs repo\! --- README | 4 + Rakefile | 40 +++ TODO | 46 +++ lisp.hs | 990 +++++++++++++++++++++++++++++++++++++++++++++++++++++ stdlib.scm | 226 ++++++++++++ 5 files changed, 1306 insertions(+) create mode 100644 README create mode 100644 Rakefile create mode 100644 TODO create mode 100644 lisp.hs create mode 100644 stdlib.scm diff --git a/README b/README new file mode 100644 index 0000000..574c7b2 --- /dev/null +++ b/README @@ -0,0 +1,4 @@ +This was never intended for public consumption. Build with `rake build` and then run ./elschemo, that's it! + +sjs +sami.samhuri@gmail.com diff --git a/Rakefile b/Rakefile new file mode 100644 index 0000000..57118be --- /dev/null +++ b/Rakefile @@ -0,0 +1,40 @@ +bin = "elschemo" +names = %w[lisp] + +task :build do + sh "ghc --make -package parsec -fglasgow-exts -o #{bin} #{extensionize 'hs', names}" +end + +task :clean do + sh "rm -f #{bin} #{obj_files(names)}" +end + +def obj_files names + "#{extensionize 'hi', names} #{extensionize 'o', names}" +end + +def extensionize ext, names + names.join(".#{ext} ") + ".#{ext}" +end + + + +# bin = "elschemo" +# names = %w[main elschemo parser eval numeric primitives io] +# +# task :build do +# sh "ghc --make -package parsec -fglasgow-exts -o #{bin} #{extensionize 'hs', names}" +# end +# +# task :clean do +# sh "rm -f #{bin} #{obj_files(names)}" +# end +# +# def obj_files names +# "#{extensionize 'hi', names} #{extensionize 'o', names}" +# end +# +# def extensionize ext, names +# names.join(".#{ext} ") + ".#{ext}" +# end +# diff --git a/TODO b/TODO new file mode 100644 index 0000000..0892213 --- /dev/null +++ b/TODO @@ -0,0 +1,46 @@ +my own wishes for this little scheme +------------------------------------ + +* implement char=?, char?, char<=?, and char>=? + (char #t + +* readline support (blah, use emacs it's good enough) + +* eval code in any given binding (and, hence, expose the binding somehow) + + +tutorial exercises +------------------ + +* Add data types and parsers to support the full numeric tower of Scheme numeric types. Haskell has built-in + types to represent many of these; check the Prelude. For the others, you can define compound types that + represent eg. a Rational as a numerator and denominator, or a Complex as a real and imaginary part (each + itself a Real number). + + http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_sec_6.2.1 + + +* Add support for the backquote syntactic sugar: the Scheme standard details what it should expand into + (quasiquote/unquote). + + http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-7.html#%_sec_4.2.6 + +* Add support for vectors. The Haskell representation is up to you: GHC does have an Array data type, but it + can be difficult to use. Strictly speaking, a vector should have constant-time indexing and updating, but + destructive update in a purely functional language is difficult. You may have a better idea how to do this + after the section on set!, later in this tutorial. + + http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_sec_6.3.6 + http://www.haskell.org/ghc/docs/latest/html/libraries/base/Data-Array.html + +* Instead of using the try combinator, left-factor the grammar so that the common subsequence is its own + parser. You should end up with a parser that matches a string of expressions, and one that matches either + nothing or a dot and a single expressions. Combining the return values of these into either a List or a + DottedList is left as a (somewhat tricky) exercise for the reader: you may want to break it out into another + helper function. + + +* Implement cond and case expressions. + +* Add the rest of the string functions. You don't yet know enough to do string-set!; this is difficult to + implement in Haskell, but you'll have enough information after the next 2 sections diff --git a/lisp.hs b/lisp.hs new file mode 100644 index 0000000..0dfb91d --- /dev/null +++ b/lisp.hs @@ -0,0 +1,990 @@ +-- author: sjs +-- last updated: july-10-2007 +-- +-- A small Scheme based on the tutorial by Jonathan Tang. +-- http://halogen.note.amherst.edu/~jdtang/scheme_in_48/tutorial/overview.html +-- +-- Where possible and convenient I try to support R5RS. +-- http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-2.html + +module Main where +import Char +import Control.Monad.Error +import Data.IORef +import Data.List (isPrefixOf) +import IO hiding (try) +import Monad +import Numeric +import System.Environment +import System.Random +import Text.ParserCombinators.Parsec hiding (spaces) + +elSchemoVersion = "0.7" + +-- If no file is named on the command line run the REPL, otherwise run the +-- file then start the REPL +main :: IO () +main = do args <- getArgs + putStrLn ("ElSchemo v" ++ elSchemoVersion ++ " by sjs") + if null args + then runRepl + else runOneThenRepl args + +-- Some very basic syntax error messages +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 = readOrThrow parseExpr +readExprList = readOrThrow (endBy parseExpr maybeSpaces) + +type Name = String +type LispInt = Integer +type LispFloat = Float + +-- numeric lisp data types +data LispNum = Integer LispInt + | Float LispFloat + deriving (Eq, Ord, Show) + +-- lisp data types +data LispVal = Atom Name + | List [LispVal] + | DottedList [LispVal] LispVal + | Number LispNum + | Char Char + | String String + | Bool Bool + | PrimitiveFunc Name ([LispVal] -> ThrowsError LispVal) + | Func {params :: [Name], vararg :: (Maybe String), + body :: [LispVal], closure :: Env} + | IOFunc Name ([LispVal] -> IOThrowsError LispVal) + | Port Handle + | Null Bool + + +-- make the lisp data types instances of relevant classes + +lispNumPlus :: LispNum -> LispNum -> LispNum +lispNumPlus (Integer x) (Integer y) = Integer $ x + y +lispNumPlus (Integer x) (Float y) = Float $ (fromInteger x) + y +lispNumPlus (Float x) (Float y) = Float $ x + y +lispNumPlus (Float x) (Integer y) = Float $ x + (fromInteger y) + +lispNumMinus :: LispNum -> LispNum -> LispNum +lispNumMinus (Integer x) (Integer y) = Integer $ x - y +lispNumMinus (Integer x) (Float y) = Float $ (fromInteger x) - y +lispNumMinus (Float x) (Float y) = Float $ x - y +lispNumMinus (Float x) (Integer y) = Float $ x - (fromInteger y) + +lispNumMult :: LispNum -> LispNum -> LispNum +lispNumMult (Integer x) (Integer y) = Integer $ x * y +lispNumMult (Integer x) (Float y) = Float $ (fromInteger x) * y +lispNumMult (Float x) (Float y) = Float $ x * y +lispNumMult (Float x) (Integer y) = Float $ x * (fromInteger y) + +lispNumDiv :: LispNum -> LispNum -> LispNum +lispNumDiv (Integer x) (Integer y) = Integer $ x `div` y +lispNumDiv (Integer x) (Float y) = Float $ (fromInteger x) / y +lispNumDiv (Float x) (Float y) = Float $ x / y +lispNumDiv (Float x) (Integer y) = Float $ x / (fromInteger y) + +lispNumAbs :: LispNum -> LispNum +lispNumAbs (Integer x) = Integer (abs x) +lispNumAbs (Float x) = Float (abs x) + +lispNumSignum :: LispNum -> LispNum +lispNumSignum (Integer x) = Integer (signum x) +lispNumSignum (Float x) = Float (signum x) + +instance Num LispNum where + (+) = lispNumPlus + (-) = lispNumMinus + (*) = lispNumMult + abs = lispNumAbs + signum = lispNumSignum + fromInteger x = Integer x + + +lispNumToRational :: LispNum -> Rational +lispNumToRational (Integer x) = toRational x +lispNumToRational (Float x) = toRational x + +instance Real LispNum where + toRational = lispNumToRational + + +lispValEq :: LispVal -> LispVal -> Bool +lispValEq (Bool arg1) (Bool arg2) = arg1 == arg2 +lispValEq (Number arg1) (Number arg2) = arg1 == arg2 +lispValEq (String arg1) (String arg2) = arg1 == arg2 +lispValEq (Atom arg1) (Atom arg2) = arg1 == arg2 +lispValEq (DottedList xs x) (DottedList ys y) = lispValEq (List $ xs ++ [x]) (List $ ys ++ [y]) +lispValEq (List arg1) (List arg2) = (length arg1 == length arg2) && + (and $ map equalPair $ zip arg1 arg2) + where equalPair (x1, x2) = lispValEq x1 x2 +lispValEq _ _ = False + +instance Eq LispVal where (==) = lispValEq + + +-- Empty values for each LispVal, these are used for letrec + +emptyValue :: LispVal -> LispVal +emptyValue (Number (Integer _)) = Number (Integer 0) +emptyValue (Number (Float _)) = Number (Float 0.0) +emptyValue (Atom _) = Atom "_" +emptyValue (List _) = List [] +emptyValue (DottedList l r) = DottedList [] (emptyValue r) +emptyValue (Char _) = Char ' ' +emptyValue (String _) = String "" +emptyValue (Bool _) = Bool False +emptyValue (Func params vararg _ env) = Func params vararg [PrimitiveFunc "null" nullFunc] env + +nullFunc :: [LispVal] -> ThrowsError LispVal +nullFunc _ = return $ Null False + + +-- Parser + +whitespace :: Parser () +whitespace = skipMany1 space + +maybeSpaces :: Parser () +maybeSpaces = skipMany space + +symbol :: Parser Char +symbol = oneOf "!$%&|*+-/:<=>?@^_~#" "symbol" + + +-- parse a binary digit, analagous to decDigit, octDigit, hexDigit +binDigit :: Parser Char +binDigit = oneOf "01" "binary digit (0 or 1)" + +-- analogous to isDigit, isOctdigit, isHexDigit +isBinDigit :: Char -> Bool +isBinDigit c = (c == '0' || c == '1') + +-- analogous to readDec, readOct, readHex +readBin :: (Integral a) => ReadS a +readBin = readInt 2 isBinDigit digitToInt + + +-- Integers, floats, characters and atoms can all start with a # so wrap those with try. +-- (Maybe left factor the grammar in the future) +parseExpr :: Parser LispVal +parseExpr = (try parseFloat "float") + <|> (try parseInteger "int") + <|> (try parseChar "char") + <|> (parseAtom "atom") + <|> (parseString "string") + <|> (parseQuoted "quoted expression") + <|> do (char '(' "expression") -- should use between? + x <- (try parseList) <|> parseDottedList + char ')' + return x + <|> (parseComment "comment") + + +parseComment :: Parser LispVal +parseComment = do skipMany space + char ';' + skipMany $ noneOf "\n\r" + return $ Null False + + +parseAtom :: Parser LispVal +parseAtom = do first <- letter <|> symbol + rest <- many (letter <|> digit <|> symbol) + let atom = [first] ++ rest + return $ case atom of + "#t" -> Bool True + "#f" -> Bool False + otherwise -> Atom atom + + +parseSign :: Parser Char +parseSign = do try (char '-') + <|> do optional (char '+') + return '+' + +applySign :: Char -> LispNum -> LispNum +applySign sign n = if sign == '-' then negate n else n + +-- Parse binary, octal, decimal, and hexadecimal integers according to R5RS (#b, #d, #o, #x), +-- or parse a regular integer in decimal format. +parseInteger :: Parser LispVal +parseInteger = do base <- do { char '#'; oneOf "bdox" } <|> return 'd' + sign <- parseSign + int <- parseDigits base + return . Number $ applySign sign $ Integer . fst . head . (reader base) $ int + where reader base = case base of + 'b' -> readBin + 'd' -> readDec + 'o' -> readOct + 'x' -> readHex + + +-- Parse a string of digits in the given base. +parseDigits :: Char -> Parser String +parseDigits base = many1 d >>= return + where d = case base of + 'b' -> binDigit + 'd' -> digit + 'o' -> octDigit + 'x' -> hexDigit + + +-- Parse floating point numbers, but only in decimal. +parseFloat :: Parser LispVal +parseFloat = do optional (string "#d") + sign <- parseSign + whole <- many1 digit + char '.' + fract <- many1 digit + return . Number $ applySign sign (makeFloat whole fract) + where makeFloat whole fract = Float . fst . head . readFloat $ whole ++ "." ++ fract + + +-- Parse a single character according to R5RS (#\a, #\A, #\(, ...). +parseChar :: Parser LispVal +parseChar = do char '#' >> char '\\' + c <- letter <|> digit <|> symbol <|> oneOf "()[]{} " + return $ Char c + + +-- Parse an R5RS compliant string. +parseString :: Parser LispVal +parseString = do + char '"' + x <- many singleChar -- "character" + char '"' + return $ String x + + +escapedChars :: String +escapedChars = "n\"\\" + +singleChar :: Parser Char +singleChar = noneOf "\\\"" + <|> try (do c <- char '\\' >> oneOf escapedChars + if c == 'n' then return '\n' else return c) + <|> char '\\' + + + +-- Parse lists +parseList :: Parser LispVal +parseList = liftM List $ sepBy parseExpr whitespace + + +-- Parse lists of the form (head . tail) +parseDottedList :: Parser LispVal +parseDottedList = do + head <- endBy parseExpr whitespace + tail <- char '.' >> whitespace >> parseExpr + return $ DottedList head tail + + +-- Parse a quoted expression, ie. '(+ 3 5) +parseQuoted :: Parser LispVal +parseQuoted = do + char '\'' + x <- parseExpr + return $ List [Atom "quote", x] + + +-- Convert LispVals to strings suitable for display +showVal :: LispVal -> String +showVal (Null False) = "" +showVal (String contents) = "\"" ++ escape contents ++ "\"" +showVal (Char c) = "#\\" ++ [c] +showVal (Atom name) = name +showVal (List []) = "()" +showVal (Number (Integer n)) = show n +showVal (Number (Float n)) = show n +showVal (Bool True) = "#t" +showVal (Bool False) = "#f" +showVal (List contents) = "(" ++ unwordsList contents ++ ")" +showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")" +showVal (PrimitiveFunc name _) = "#" +showVal (Func {params = args, vararg = varargs, body = body, closure = env}) = + "(lambda (" ++ unwords(map show args) ++ + (case varargs of + Nothing -> "" + Just arg -> " . " ++ arg) ++ ") ...)" +showVal (Port _) = "#" +showVal (IOFunc name _) = "#" + +unwordsList :: [LispVal] -> String +unwordsList = unwords . map showVal + +instance Show LispVal where show = showVal + + +-- xs =~ s/from/to/g +subst :: (Eq a) => [a] -> [a] -> [a] -> [a] +subst _ _ [ ] = [] +subst from to xs@(a:as) = + if isPrefixOf from xs + then to ++ drop (length from) xs + else a : subst from to as + +-- escape a string for display +escape :: String -> String +escape s = subst "\n" "\\n" (subst "\"" "\\\"" (subst "\\" "\\\\" s)) + +-- Evaluation +eval :: Env -> LispVal -> IOThrowsError LispVal +eval env (List [Atom "load", String filename]) = do + load filename >>= evalExprs env + return $ Atom ("Loaded " ++ filename ++ ".") +eval env (Null _) = return $ Null False +eval env val@(Char _) = return val +eval env val@(String _) = return val +eval env val@(Number _) = return val +eval env val@(Bool _) = return val +eval env (Atom id) = getVar env id +eval env (List []) = return $ List [] +eval env (List [Atom "quote", val]) = return val +eval env (List (Atom "and" : params)) = lispAnd env params +eval env (List (Atom "or" : params)) = lispOr env params +eval env (List (Atom "if" : params)) = lispIf env params +eval env (List (Atom "cond" : params)) = lispCond env params +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 "let" : List params : body)) = do + values <- evalArgs env params + (liftIO $ bindVars env $ zip names values) >>= evalBody + where evalBody env = liftM last $ evalExprs env body + names = argNames params + +eval env (List (Atom "let*" : List [List [Atom var, form]] : body)) = do + eval env form >>= defineVar env var + liftM last $ evalExprs env body +eval env (List (Atom "let*" : List (List [Atom var, form] : rest) : body)) = do + eval env form >>= defineVar env var + eval env (List (Atom "let*" : List rest : body)) + +eval env (List (Atom "letrec" : List params : body)) = do + -- bind the names of vars so they are visible to everything within the letrec + env <- liftIO $ bindVars env $ zip names emptyValues + -- now evaluate the args and set the proper values + values <- evalArgs env params + setVars env $ zip names values + -- ready to evaluate the body + liftM last $ evalExprs env body + where names = argNames params + emptyValues = [emptyValue x | x <- params] + +-- R6RS adds letrec*, with fairly obvious semantics + +eval env (List (function : args)) = do + func <- eval env function + argVals <- mapM (eval env) args + apply func argVals + +-- taken from Arc, (f . (1 2 3)) is the same as (apply f '(1 2 3)) +eval env (DottedList [function] (List args)) = do + func <- eval env function + argVals <- mapM (eval env) args + apply func argVals + +eval env badForm = throwError $ BadSpecialForm "Unrecongized special form" badForm + + +evalExprs :: Env -> [LispVal] -> IOThrowsError [LispVal] +evalExprs env exprs = mapM (eval env) exprs + +argNames :: [LispVal] -> [Name] +argNames params = map (\(List [Atom x, y]) -> x) params + +args :: [LispVal] -> [LispVal] +args params = map (\(List [x, y]) -> y) params + +evalArgs :: Env -> [LispVal] -> IOThrowsError [LispVal] +evalArgs env params = evalExprs env (args params) + + +-- Call primitive functions directly. +-- Call user-defined functions after ensuring the correct number of arguments are present, +-- and then evaluating those args in the proper context. +apply :: LispVal -> [LispVal] -> IOThrowsError LispVal +apply (PrimitiveFunc _ func) args = liftThrows $ func args +apply (IOFunc _ func) args = 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 $ evalExprs env body + bindVarArgs arg env = case arg of + Just argName -> liftIO $ bindVars env [(argName, List remainingArgs)] + Nothing -> return env +apply unFunc args = throwError $ NotFunction "Not a function" (show unFunc) + + +-- special forms + +lispAnd :: Env -> [LispVal] -> IOThrowsError LispVal +lispAnd env [pred] = eval env pred +lispAnd env (pred:rest) = do + result <- eval env pred + case result of + Bool False -> return $ Bool False + _ -> lispAnd env rest + +lispOr :: Env -> [LispVal] -> IOThrowsError LispVal +lispOr env [pred] = eval env pred +lispOr env (pred:rest) = do + result <- eval env pred + case result of + Bool False -> lispOr env rest + val -> return val + +lispIf :: Env -> [LispVal] -> IOThrowsError LispVal +lispIf env (pred:conseq:alt) = do + result <- eval env pred + case result of + Bool False -> eval env $ head alt + Bool True -> eval env conseq + badCond -> throwError $ TypeMismatch "boolean" badCond + +lispCond :: Env -> [LispVal] -> IOThrowsError LispVal +lispCond env (List (Atom "else" : exprs) : []) = liftM last $ evalExprs env exprs +lispCond env (List (pred:conseq) : rest) = do + result <- eval env pred + case result of + Bool False -> case rest of + [] -> return $ Null False + _ -> lispCond env rest + _ -> liftM last $ evalExprs env conseq + + +primitives :: [(Name, [LispVal] -> ThrowsError LispVal)] +primitives = [("+", numericBinop (+)), + ("-", subtractOp), + ("*", numericBinop (*)), + ("/", floatBinop (/)), + ("mod", integralBinop mod), + ("quotient", integralBinop quot), + ("remainder", integralBinop rem), + ("=", numBoolBinop (==)), + ("<", numBoolBinop (<)), + (">", numBoolBinop (>)), + ("/=", numBoolBinop (/=)), + (">=", numBoolBinop (>=)), + ("<=", numBoolBinop (<=)), + ("&&", boolBoolBinop (&&)), + ("||", boolBoolBinop (||)), + ("car", car), + ("cdr", cdr), + ("cons", cons), + ("null?", nullBoolUnop), + ("eq?", eqv), + ("eqv?", eqv), + ("equal?", equal), + ("string=?", strBoolBinop (==)), + ("string<", strBoolBinop (<)), + ("string>?", strBoolBinop (>)), + ("string<=?", strBoolBinop (<=)), + ("string>=?", strBoolBinop (>=)), + ("symbol?", symbolBoolUnop), + ("list?", listBoolUnop), + ("dotted-list?", dottedListBoolUnop), + ("number?", numBoolUnop), + ("integer?", intBoolUnop), + ("float?", floatBoolUnop), + ("char?", charBoolUnop), + ("string?", strBoolUnop), + ("bool?", boolBoolUnop), + ("symbol->string", convertSymbolToString), + ("string->symbol", convertStringToSymbol), + ("string->list", convertStringToList), + ("list->string", convertListToString), + ("char->integer", convertCharToInt), + ("integer->char", convertIntToChar), + ("char-upcase", convertCharUpcase), + ("char-downcase", convertCharDowncase), + ("char-at", charAt), + ("ceiling", floatingUnop ceiling), + ("floor", floatingUnop floor), + ("string-concatenate", stringConcatenate), + ("string-slice", stringSlice), + ("string-reverse", stringReverse)] + +primitiveBindings :: IO Env +primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives + ++ map (makeFunc PrimitiveFunc) primitives) + where makeFunc constructor (var, func) = (var, constructor var func) + +numericBinop :: (LispNum -> LispNum -> LispNum) -> [LispVal] -> ThrowsError LispVal +numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal +numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op + +integralBinop :: (LispInt -> LispInt -> LispInt) -> [LispVal] -> ThrowsError LispVal +integralBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal +integralBinop op params = mapM unpackInt params >>= return . Number . Integer . foldl1 op + +floatBinop :: (LispFloat -> LispFloat -> LispFloat) -> [LispVal] -> ThrowsError LispVal +floatBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal +floatBinop op params = mapM unpackFloat params >>= return . Number . Float . foldl1 op + +subtractOp :: [LispVal] -> ThrowsError LispVal +subtractOp num@[_] = unpackNum (head num) >>= return . Number . negate +subtractOp params = numericBinop (-) params + +boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal +boolBinop unpacker op singleVal@[_] = throwError $ NumArgs 2 singleVal +boolBinop unpacker op args = do left <- unpacker $ head args + right <- unpacker $ args !! 1 + return $ Bool $ left `op` right + +numBoolBinop :: (LispNum -> LispNum -> Bool) -> [LispVal] -> ThrowsError LispVal +numBoolBinop op params = boolBinop unpackNum op params + +strBoolBinop = boolBinop unpackStr +boolBoolBinop = boolBinop unpackBool + +unpackNum :: LispVal -> ThrowsError LispNum +unpackNum (Number (Integer n)) = return $ Integer n +unpackNum (Number (Float n)) = return $ Float n +unpackNum notNum = throwError $ TypeMismatch "number" notNum + +unpackInt :: LispVal -> ThrowsError Integer +unpackInt (Number (Integer n)) = return n +unpackInt (String n) = let parsed = reads n in + if null parsed + then throwError $ TypeMismatch "integer" $ String n + else return . fst . head $ parsed +unpackInt (List [n]) = unpackInt n +unpackInt notInt = throwError $ TypeMismatch "integer" notInt + +unpackFloat :: LispVal -> ThrowsError Float +unpackFloat (Number (Float f)) = return f +unpackFloat (Number (Integer f)) = return $ fromInteger f +unpackFloat (String f) = let parsed = reads f in + if null parsed + then throwError $ TypeMismatch "float" $ String f + else return . fst . head $ parsed +unpackFloat (List [f]) = unpackFloat f +unpackFloat notFloat = throwError $ TypeMismatch "float" notFloat + +unpackStr :: LispVal -> ThrowsError String +unpackStr (String s) = return s +unpackStr (Number (Integer s)) = return $ show s +unpackStr (Number (Float 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 + + +-- list processing (and strings now too) +car :: [LispVal] -> ThrowsError LispVal +car [List (x : xs)] = return x +car [DottedList (x : xs) _] = return x +car [String (c:xs)] = return . Char $ c +car [badArg] = throwError $ TypeMismatch "pair" badArg +car badArgs = throwError $ NumArgs 1 badArgs + +cdr :: [LispVal] -> ThrowsError LispVal +cdr [List (x : xs)] = return $ List xs +cdr [DottedList [xs] x] = return x +cdr [DottedList (_ : xs) x] = return $ DottedList xs x +cdr [String (_:rest)] = return $ String rest +cdr [badArg] = throwError $ TypeMismatch "pair" badArg +cdr badArgs = throwError $ NumArgs 1 badArgs + +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 [Char c, String s] = return $ String (c:s) +cons [String a, String b] = return $ String (a ++ b) +cons [x1, x2] = return $ DottedList [x1] x2 +cons badArgs = throwError $ NumArgs 2 badArgs + + +-- equivalence testing +eqv :: [LispVal] -> ThrowsError LispVal +eqv [arg1, arg2] = return . Bool $ lispValEq arg1 arg2 +eqv badArgs = throwError $ NumArgs 2 badArgs + +-- For any type that is an instance of Eq, you can define an Unpacker that takes a function +-- from LispVal to that type, and may throw an error. +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) + + +equal :: [LispVal] -> ThrowsError LispVal +equal [List arg1, List arg2] = return . Bool $ (length arg1 == length arg2) && + (and $ map equalPair $ zip arg1 arg2) + where equalPair (x1, x2) =let (Bool x) = extractValue $ equal [x1, x2] in x + +equal [arg1, arg2] = do + primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2) + [AnyUnpacker unpackNum, AnyUnpacker unpackFloat, AnyUnpacker unpackInt, AnyUnpacker unpackStr, AnyUnpacker unpackBool] + return $ Bool $ (primitiveEquals || lispValEq arg1 arg2) +equal badArgs = throwError $ NumArgs 2 badArgs + + +boolUnop :: (LispVal -> LispVal) -> [LispVal] -> ThrowsError LispVal +boolUnop op [val] = return . op $ val +boolUnop op badArgs = throwError $ NumArgs 1 badArgs + +symbolBoolUnop = boolUnop isLispSymbol +listBoolUnop = boolUnop isLispList +dottedListBoolUnop = boolUnop isLispDottedList +numBoolUnop = boolUnop isLispNumber +intBoolUnop = boolUnop isLispInteger +floatBoolUnop = boolUnop isLispFloat +charBoolUnop = boolUnop isLispChar +strBoolUnop = boolUnop isLispString +boolBoolUnop = boolUnop isLispBool +nullBoolUnop = boolUnop isNull + +floatingUnop :: (LispFloat -> LispInt) -> [LispVal] -> ThrowsError LispVal +floatingUnop op [Number (Float val)] = return . Number . Integer . op $ val +floatingUnop op [badArg] = throwError $ TypeMismatch "float" badArg +floatingUnop op badArgs = throwError $ NumArgs 1 badArgs + +-- type identification primitives +isLispSymbol :: LispVal -> LispVal +isLispSymbol (Atom _) = Bool True +isLispSymbol _ = Bool False + +isLispList :: LispVal -> LispVal +isLispList (List _) = Bool True +isLispList _ = Bool False + +isLispDottedList :: LispVal -> LispVal +isLispDottedList (DottedList _ _) = Bool True +isLispDottedList _ = Bool False + +isLispNumber :: LispVal -> LispVal +isLispNumber (Number _) = Bool True +isLispNumber _ = Bool False + +isLispInteger :: LispVal -> LispVal +isLispInteger (Number (Integer _)) = Bool True +isLispInteger _ = Bool False + +isLispFloat :: LispVal -> LispVal +isLispFloat (Number (Float _)) = Bool True +isLispFloat _ = Bool False + +isLispChar :: LispVal -> LispVal +isLispChar (Char _) = Bool True +isLispChar _ = Bool False + +isLispString :: LispVal -> LispVal +isLispString (String _) = Bool True +isLispString _ = Bool False + +isLispBool :: LispVal -> LispVal +isLispBool (Bool _) = Bool True +isLispBool _ = Bool False + +isNull :: LispVal -> LispVal +isNull (List []) = Bool True +isNull _ = Bool False + +-- conversions + +conversion :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal +conversion func [arg] = func arg +conversion _ badArgs = throwError $ NumArgs 1 badArgs + +convertSymbolToString = conversion symbolToString +convertStringToSymbol = conversion stringToSymbol +convertStringToList = conversion stringToList +convertListToString = conversion listToString +convertCharUpcase = conversion charUpcase +convertCharDowncase = conversion charDowncase +convertCharToInt = conversion charToInt +convertIntToChar = conversion intToChar + +symbolToString :: LispVal -> ThrowsError LispVal +symbolToString (Atom a) = return $ String a +symbolToString badArg = throwError $ TypeMismatch "atom" badArg + +stringToSymbol :: LispVal -> ThrowsError LispVal +stringToSymbol (String s) = return $ Atom s +stringToSymbol badArg = throwError $ TypeMismatch "string" badArg + +stringToList :: LispVal -> ThrowsError LispVal +stringToList (String s) = return $ str2lst (String s) +stringToList badArg = throwError $ TypeMismatch "atom" badArg + +listToString :: LispVal -> ThrowsError LispVal +listToString (List l) = return $ lst2str (List l) +listToString badArg = throwError $ TypeMismatch "list" badArg + +charUpcase :: LispVal -> ThrowsError LispVal +charUpcase (Char c) = return $ Char $ toUpper c +charUpcase badArg = throwError $ TypeMismatch "char" badArg + +charDowncase :: LispVal -> ThrowsError LispVal +charDowncase (Char c) = return $ Char $ toLower c +charDowncase badArg = throwError $ TypeMismatch "char" badArg + +charToInt :: LispVal -> ThrowsError LispVal +charToInt (Char c) = return $ Number . Integer . toInteger $ ord c +charToInt badArg = throwError $ TypeMismatch "char" badArg + +intToChar :: LispVal -> ThrowsError LispVal +intToChar (Number (Integer n)) = return $ Char . chr $ fromInteger n +intToChar badArg = throwError $ TypeMismatch "integer" badArg + + +-- string functions + +lst2str :: LispVal -> LispVal +lst2str (List l) = String [c | Char c <- l] + +str2lst :: LispVal -> LispVal +str2lst (String s) = List [Char c | c <- s] + +charAt :: [LispVal] -> ThrowsError LispVal +charAt [Number (Integer idx), String s] = return . Char $ s !! (fromInteger idx) +charAt [badArg, String _] = throwError $ TypeMismatch "integer" badArg +charAt [Number (Integer _), badArg] = throwError $ TypeMismatch "string" badArg +charAt badArgs = throwError $ NumArgs 2 badArgs + +stringConcatenate :: [LispVal] -> ThrowsError LispVal +stringConcatenate [List xs] = return . String $ foldl (++) "" strings + where strings = [s | String s <- xs] +stringConcatenate [badArg] = throwError $ TypeMismatch "list" badArg +stringConcatenate badArgs = throwError $ NumArgs 1 badArgs + +stringSlice :: [LispVal] -> ThrowsError LispVal +stringSlice [String s, Number (Integer start), Number (Integer len)] = + return . String $ take (fromInteger len) $ drop (fromInteger start) s +stringSlice badArgs@[_,_,_] = throwError $ TypeMismatch "string,integer,integer" (List badArgs) +stringSlice badArgs = throwError $ NumArgs 3 badArgs + +stringReverse :: [LispVal] -> ThrowsError LispVal +stringReverse [String s] = return . String $ reverse s +stringReverse [badArg] = throwError $ TypeMismatch "string" badArg +stringReverse badArgs = throwError $ NumArgs 1 badArgs + + +-- error checking +data LispError = NumArgs Integer [LispVal] + | TypeMismatch String LispVal + | Parser ParseError + | BadSpecialForm String LispVal + | NotFunction String String + | UnboundVar String String + | Default String + | FileNotFound String + +showError :: LispError -> String +showError (UnboundVar message varname) = message ++ ": " ++ varname +showError (BadSpecialForm message form) = message ++ ": " ++ show form +showError (NotFunction message func) = message ++ ": " ++ 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) = "Parse error at " ++ show parseErr +showError (FileNotFound filename) = "File not found: " ++ show filename + +instance Show LispError where show = showError + +instance Error LispError where + noMsg = Default "An error has occured" + strMsg = Default + +type ThrowsError = Either LispError + +--XXX what type does trapError have? +trapError action = catchError action (return . show) + +extractValue :: ThrowsError a -> a +extractValue (Right val) = val + +-- REPL (read-eval-print loop) + +flushStr :: String -> IO () +flushStr str = putStr str >> 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 = do + result <- evalString env expr + if result == "" + then return () + else putStrLn result + +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 + +runOneThenRepl :: [String] -> IO () +runOneThenRepl 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 + runReplWithEnv $ return env + +runReplWithEnv :: IO Env -> IO () +runReplWithEnv env = do env >>= until_ (== "quit") (readPrompt "> ") . evalAndPrint + +runRepl :: IO () +runRepl = runReplWithEnv primitiveBindings +-- +--runOneThenRepl :: [String] -> IO () +--runOneThenRepl args = do runOneWithEnv primitiveBindings args >>= runReplWithEnv + + +-- saving state, the environment (a list of strings paired to mutable values) +type Env = IORef [(String, IORef LispVal)] + +nullEnv :: IO Env +nullEnv = newIORef [] + + +type IOThrowsError = ErrorT LispError IO + +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 + +setVars :: Env -> [(String, LispVal)] -> IOThrowsError LispVal +setVars envRef values = liftM last $ mapM set values + where set (var, value) = setVar envRef var 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) + +--- XXX types? same as makeFunc, no? +makeFunc varargs env params body = return $ Func (map showVal params) varargs body env +makeNormalFunc = makeFunc Nothing +makeVarargs = makeFunc . Just . showVal + + +ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)] +ioPrimitives = [("apply", applyProc), + ("open-input-file", makePort ReadMode), + ("open-output-file", makePort WriteMode), + ("close-input-file", closePort), + ("close-output-file", closePort), + ("read", readProc), + ("write", writeProc), + ("read-contents", readContents), + ("read-all", readAll), + ("display", display), + ("random", randomInt)] + +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 + + +-- display values, fallback on showVal since only strings and chars need to be displayed differently +displayVal :: LispVal -> String +displayVal (String contents) = contents +displayVal (Char c) = [c] +displayVal x = showVal x + + +display :: [LispVal] -> IOThrowsError LispVal +display [] = return $ Null False +display (x : xs) = do liftIO . putStr $ displayVal x; display xs + +randomInt :: [LispVal] -> IOThrowsError LispVal +randomInt [Number (Integer high)] = liftM (Number . Integer) $ liftIO num + where num = getStdRandom (randomR (0,high-1)) +randomInt [badArg] = throwError $ TypeMismatch "integer" badArg +randomInt args = throwError $ NumArgs 1 args diff --git a/stdlib.scm b/stdlib.scm new file mode 100644 index 0000000..bc2fe3b --- /dev/null +++ b/stdlib.scm @@ -0,0 +1,226 @@ +;; the basics +(define nil ()) +(define null nil) +(define true #t) +(define false #f) +(define (pair? x) (and (list? x) (not (null? x)))) +(define (not x) (if (eq? #f x) #t #f)) +(define (newline) (display "\n")) + +(define (list . objs) objs) +(define (id obj) obj) +(define (flip func) + (lambda (arg1 arg2) (func arg2 arg1))) +(define (curry func arg1) + (lambda (arg) (func arg1 arg))) +(define (compose f g) + (lambda (arg) (f (apply g arg)))) + +;; math +(define zero? (curry = 0)) +(define negative? (curry (flip <) 0)) +(define positive? (curry (flip >) 0)) +(define inc (curry + 1)) +(define dec (curry (flip -) 1)) + +(define (divides? a b) + (zero? (remainder b a))) + +(define (prime? x) + (= x (smallest-divisor x))) + +;; this sort of coercion shouldn't be necessary +(define (odd? num) + (cond ((and (float? num) (equal? num (floor num))) (= (mod (floor num) 2) 1)) + ((float? num) (display "odd? expects an integer, given:" num) #f) + (else (= (mod num 2) 1)))) +(define (even? num) + (cond ((and (float? num) (equal? num (floor num))) (zero? (mod (floor num) 2))) + ((float? num) (display "even? expects an integer, given:" num) #f) + (else (zero? (mod num 2))))) + +(define (square x) (* x x)) +(define (abs x) + (cond ((< x 0) (- x)) + (else x))) + +;; exponentation using recursion (pretty fast) +(define (expt-rec b n) + (if (zero? n) + 1 + (* b (expt-rec b (dec n))))) + +;; exponentation using foldl (slowest) +(define (expt-fold b n) + (fold * 1 (fill (range 1 n) b))) + +;; exponentation using iteration +;; (seems a bit slower than the recursive version, but still fast) +(define (expt-iter b counter . product) + (let product (lambda (if (null? product) 1 (car product))) + (if (zero? counter) + product + (expt-iter b (dec counter) (* b product))))) + +;; fast exponentation +(define (fast-expt b n) + (cond ((= n 0) 1) + ((even? n) (square (fast-expt b (/ n 2)))) + (else (* b (fast-expt b (- n 1)))))) +(define expt fast-expt) + +;; calculate square roots +(define (sqrt-good-enough? guess x) + (let ((delta 0.0001)) + (< (abs (- (square guess) x)) + delta))) + +(define (sqrt-improve guess x) + (average guess (/ x guess))) + +(define (sqrt-iter guess x) + (if (sqrt-good-enough? guess x) + guess + (sqrt-iter (sqrt-improve guess x) x))) + +(define (sqrt x) + (sqrt-iter 1.0 x)) + +(define (factorial n) + (if (<= n 1) + 1 + (* n (factorial (- n 1))))) +(define ! factorial) + +;; greatest common denominator +(define (gcd a b) + (if (zero? b) + a + (gcd b (remainder a b)))) + +(define (find-divisor n test-divisor) + (let ((next (lambda (n) + (if (eq? n 2) + 3 + (+ n 2))))) + (cond ((> (square test-divisor) n) n) + ((divides? test-divisor n) test-divisor) + (else (find-divisor n (next test-divisor)))))) + +(define (smallest-divisor n) + (find-divisor n 2)) + +(define (expmod base exp m) + (cond ((zero? exp) 1) + ((even? exp) + (remainder (square (expmod base (/ exp 2) m)) + m)) + (else + (remainder (* base (expmod base (dec exp) m)) + m)))) + +;; test for prime numbers using Fermat's method +(define (fermat-test n) + (let ((try-it (lambda (a) + (= (expmod a n n) a)))) + (try-it (inc (random (dec n)))))) + +;; this runs Fermat's test a given number of times +(define (fast-prime? n times) + (cond ((zero? times) true) + ((fermat-test n) (fast-prime? n (dec times))) + (else false))) + +;; folds + +;; SICP calls this accumulate +(define (foldr func end lst) + (if (null? lst) + end + (func (car lst) (foldr func end (cdr lst))))) + +(define (foldl func accum lst) + (if (null? lst) + accum + (foldl func (func accum (car lst)) (cdr lst)))) + +(define fold foldl) +(define reduce fold) + +(define (unfold func init pred) + (if (pred init) + (cons init '()) + (cons init (unfold func (func init) pred)))) + +(define (sum-list lst) (fold + 0 lst)) +(define (sum . lst) (sum-list lst)) +(define (product . lst) (fold * 0 lst)) +(define (average . xs) (/ (sum-list xs) (length xs))) +(define avg average) + +(define (max first . num-list) (fold (lambda (old new) (if (> old new) old new)) first num-list)) +(define (min first . num-list) (fold (lambda (old new) (if (< old new) old new)) first num-list)) +(define (length lst) (fold (lambda (x y) (+ x 1)) 0 lst)) +(define (reverse lst) (fold (flip cons) '() lst)) +(define (nth n lst) (if (= n 1) (car lst) (nth (- n 1) (cdr lst)))) + + +(define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc))) +(define (memq obj lst) (fold (mem-helper (curry eq? obj) id) #f lst)) +(define (memv obj lst) (fold (mem-helper (curry eqv? obj) id) #f lst)) +(define (member obj lst) (fold (mem-helper (curry equal? obj) id) #f lst)) +(define (assq obj alist) (fold (mem-helper (curry eq? obj) car) #f alist)) +(define (assv obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist)) +(define (assoc obj alist) (fold (mem-helper (curry equal? obj) car) #f alist)) + +;; TODO define fold-k (fold w/ continuations) and use it to short-circuit these +(define (any? pred lst) (fold (lambda (any-found x) (or any-found (pred x))) #f lst)) +(define (all? pred lst) (fold (lambda (all-matched x) (and (pred x) all-matched)) #t lst)) + +;; transformations +;; (define (map func lst) (foldr (lambda (x y) (cons (func x) y)) '() lst)) +;; (define (mapr func lst) (fold (lambda (x y) (cons (func y) x)) '() lst)) +(define (filter pred lst) (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst)) +(define (fill lst n) (map (lambda (x) n) lst)) + +;; the more general version of map, similar to mapcar in Lisp +(define (map func . seqs) + (cond ((= 1 (length seqs)) + (foldr (lambda (x y) (cons (func x) y)) '() (car seqs))) + ((null? (car seqs)) nil) + (else + (cons (apply func (map car seqs)) + (apply map (cons func (map cdr seqs))))))) + + +(define (caar lst) (car (car lst))) +(define (cadr lst) (car (cdr lst))) +(define (caddr lst) (car (cdr (cdr lst)))) +(define (cadddr lst) (car (cdr (cdr (cdr lst))))) + + +;; like python's range +;; SICP calls this enumerate-interval ... i prefer range +(define (range min max) + (if (> min max) + nil + (cons min (range (inc min) max)))) + +;; recursive method of concatenating 2 lists +(define (append list1 list2) + (if (null? list1) + list2 + (cons (car list1) (append (cdr list1) list2)))) + +;; string manipulation +(define (string-map func s) + (list->string (map func (string->list s)))) + +(define (string-upcase s) + (string-map char-upcase s)) + +(define (string-downcase s) + (string-map char-downcase s)) + +(define (string-append . lst) + (string-concatenate lst)) \ No newline at end of file