diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2010 Justin Ethier + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,98 @@ +husk is a dialect of Scheme written in Haskell that implements a subset of the [R5RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Husk is not intended to be a highly optimized version of Scheme. Rather, the goal of the project is to provide a tight integration between Haskell and Scheme while at the same time providing a great opportunity for deeper understanding of both languages. In addition, by closely following the R5RS standard the intent is to develop a Scheme that is as compatible as possible with other R5RS Schemes. + +Scheme is one of two main dialects of Lisp. Scheme follows a minimalist design philosophy: the core language consists of a small number of fundamental forms, which may be used to implement the other built-in forms. Scheme is an excellent language for writing small, elegant programs, and may also be used to write scripts or embed scripting functionality within a larger application. + +Feature List +------------ +husk includes the following features: + +- Most primitive data types and their standard forms (TODO: which are? string, char, etc) +- Conditionals: if, case, cond +- Assignment operations +- Sequencing: begin +- Iteration: do +- Quasi-quotation +- Delayed Execution: delay, force +- Binding constructs: let, named let, let*, letrec +- Basic IO functions +- Standard library of Scheme functions +- Read-Eval-Print-Loop (REPL) interpreter, with input driven by Haskeline +- Proper tail recursion +- Full numeric tower - includes support for parsing/storing types (exact, inexact, etc), support for operations on these types as well as mixing types, other constraints from spec. +- Hash tables, as specified by [SRFI 69](http://srfi.schemers.org/srfi-69/srfi-69.html) +- Hygenic Macros: High-level macros via define-syntax - *Note this is still a heavy work in progress* and while it works well enough that many derived forms are implemented in our standard library, you may still run into problems when defining your own macros. + +Roadmap +------- + +Features planned for development: + +- A scheme "library" that may be used to embed scheme scripting within a Haskell program. This will necessitate extracting the repl code from Core.hs and relocating it to its own file. + + See: http://book.realworldhaskell.org/read/writing-a-library-working-with-json-data.html + +- Documentation, including a description of Scheme / Haskell, API docs (?), etc +- Release as a cabal package - see: http://www.haskell.org/haskellwiki/How_to_write_a_Haskell_program +- Continuations +- Implementation of approved SRFI's + +TODO Items: + +- Better error reporting. For example: + * huski crashes when macro transformation not enclosed in () + * What's up with this error message: + huski> (define vec) + Getting an unbound variable: define +- huski crashes if the first line of a scheme file is blank +- Correct parsing of comments, including allowing them in the middle of a form (eg: (cond)) +- Test cases, including those for: backtick, primitives (see spec section 4.1), others +- More example programs, perhaps derive some from SICP and http://www.scheme.dk/planet/ +- General refactoring of haskell code including addressing of TODO items, etc... +- Compare our features to R5RS spec: and +- At some point, need to enter bugs for this sort of thing... + +husk scheme is available under the [MIT license](http://www.opensource.org/licenses/mit-license.php). + +Usage +----- + +The interpreter may be invoked by running it directly from the command line: + + ./huski + +Alternatively, you may run an individual scheme program: + + ./huski my-scheme-file.scm + +A Haskell API is also provided to allow you to embed a Scheme interpreter within a Haskell program. The key API modules are: + +- Scheme.Core - Contains functions to evaluate (execute) Scheme code. +- Scheme.Types - Contains Haskell data types used to represent Scheme primitives. + +For more information, run `make doc` to generate API documentation from the source code. Also, see `shell.hs` for a quick example of how you might get started. + +Development +----------- + +The following packages are required to build husk scheme: + +- [GHC](http://www.haskell.org/ghc/) - Or at the very least, no other compiler has been tested. +- [cabal-install](http://hackage.haskell.org/trac/hackage/wiki/CabalInstall) may be used to build, deploy, and generate packages for husk. +- Haskeline - which may be installed using cabal: + + cabal install haskeline + +The 'scm-unit-tests' directory contains unit tests for much of the scheme code. Tests may be executed via 'make test' + +The examples directory contains example scheme programs. + + +Credits +------- + +husk scheme is developed by [Justin Ethier](http://github.com/justinethier). + +The interpreter is based on the code from the book [Write Yourself a Scheme in 48 Hours](http://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours) written by Jonathan Tang and hosted / maintained by Wikibooks. + +If you would like to request changes, report bug fixes, or contact me, visit the project web site at [GitHub](http://github.com/justinethier/husk-scheme). + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/hs-src/Scheme/Core.hs b/hs-src/Scheme/Core.hs new file mode 100644 --- /dev/null +++ b/hs-src/Scheme/Core.hs @@ -0,0 +1,794 @@ +{- + - husk scheme interpreter + - + - A lightweight dialect of R5RS scheme. + - Core functionality + - + - @author Justin Ethier + - + - -} + +{- + - TODO: + - + - => compare my functions against those listed on + - http://en.wikipedia.org/wiki/Scheme_(programming_language) + - + - -} + +module Scheme.Core + ( + eval + , evalLisp + , evalString + , evalAndPrint + , primitiveBindings -- FUTURE: this may be a bad idea... + -- but there should be an interface to inject custom functions written in Haskell + ) where +import Scheme.Macro +import Scheme.Numerical +import Scheme.Parser +import Scheme.Types +import Scheme.Variables +import Complex +import Control.Monad +import Control.Monad.Error +import Char +import Data.Array +import Data.IORef +import qualified Data.Map +import Maybe +import List +import IO hiding (try) +import Numeric +import Ratio + +{-| Evaluate a string containing Scheme code. + + For example: + +@ +env <- primitiveBindings + +evalString env "(+ x x x)" +"3" + +evalString env "(+ x x x (* 3 9))" +"30" + +evalString env "(* 3 9)" +"27" +@ +-} +evalString :: Env -> String -> IO String +evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= macroEval env >>= eval env + +-- |Evaluate a string and print results to console +evalAndPrint :: Env -> String -> IO () +evalAndPrint env expr = evalString env expr >>= putStrLn + +-- |Evaluate lisp code that has already been loaded into haskell +-- +-- TODO: code example for this, via ghci and/or a custom program. +evalLisp :: Env -> LispVal -> IOThrowsError LispVal +evalLisp env lisp = macroEval env lisp >>= eval env + +-- |Core eval function +-- +-- NOTE: This function does not include macro support and should not be called directly. Instead, use 'evalLisp' +eval :: Env -> LispVal -> IOThrowsError LispVal +eval env val@(Nil _) = return val +eval env val@(String _) = return val +eval env val@(Char _) = return val +eval env val@(Complex _) = return val +eval env val@(Float _) = return val +eval env val@(Rational _) = return val +eval env val@(Number _) = return val +eval env val@(Bool _) = return val +eval env val@(HashTable _) = return val +eval env (Atom id) = getVar env id +eval env (List [Atom "quote", val]) = return val +eval env (List [Atom "quasiquote", val]) = do + case val of + List [Atom "unquote", val] -> eval env val -- Handle cases like `,(+ 1 2) + List [Atom "unquote-splicing", val] -> eval env val -- TODO: not quite right behavior + List (x : xs) -> mapM (doUnQuote env) (x:xs) >>= return . List -- TODO: understand *why* this works + otherwise -> doUnQuote env val + where doUnQuote :: Env -> LispVal -> IOThrowsError LispVal + doUnQuote env val = do + case val of + List [Atom "unquote", val] -> eval env val + List [Atom "unquote-splicing", val] -> eval env val -- TODO: not quite right behavior + otherwise -> eval env (List [Atom "quote", val]) -- TODO: could this be simplified? + +eval env (List [Atom "if", pred, conseq, alt]) = + do result <- eval env pred + case result of + Bool False -> eval env alt + otherwise -> eval env conseq + {- ex #1: only allow boolean conditions: otherwise -> throwError $ TypeMismatch "bool" otherwise-} + +-- TODO: implement this 'if' form, such that it returns nothing if the pred evaluates to false +eval env (List [Atom "if", pred, conseq]) = + do result <- eval env pred + case result of + Bool True -> eval env conseq + otherwise -> eval env $ List [] + +eval env (List (Atom "cond" : clauses)) = + if length clauses == 0 + then throwError $ BadSpecialForm "No matching clause" $ String "cond" + else do + let c = clauses !! 0 -- First clause + let cs = tail clauses -- other clauses + test <- case c of + List (Atom "else" : expr) -> eval env $ Bool True + List (cond : expr) -> eval env cond + badType -> throwError $ TypeMismatch "clause" badType + case test of + Bool True -> evalCond env c + otherwise -> eval env $ List $ (Atom "cond" : cs) + +eval env (List (Atom "case" : keyAndClauses)) = + do let key = keyAndClauses !! 0 + let cls = tail keyAndClauses + ekey <- eval env key + evalCase env $ List $ (ekey : cls) + +eval env (List (Atom "begin" : funcs)) = + if length funcs == 0 + then eval env $ Nil "" + else if length funcs == 1 + then eval env (head funcs) + else do + let fs = tail funcs + eval env (head funcs) + eval env (List (Atom "begin" : fs)) + +eval env (List [Atom "load", String filename]) = + load filename >>= liftM last . mapM (evaluate env) + where evaluate env val = macroEval env val >>= eval env + +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 + +{- TODO: for proper tail calls (above): + - + - consider comments from http://www.sidhe.org/~dan/blog/archives/000211.html + - in particular: + - - how a compiler can deal with tail recursion + - - And if you have a continuation passing style of calling functions, it turns out to be essentially free, which is really cool, though the topic of another WTHI entry + - perhaps: http://www.sidhe.org/~dan/blog/archives/000213.html + - + - -} + +eval env (List [Atom "string-fill!", Atom var, character]) = do + str <- eval env =<< getVar env var + chr <- eval env character + (eval env $ fillStr(str, chr)) >>= setVar env var + where fillStr (String str, Char chr) = doFillStr (String "", Char chr, length str) + + doFillStr (String str, Char chr, left) = do + if left == 0 + then String str + else doFillStr(String $ chr : str, Char chr, left - 1) + +eval env (List [Atom "string-set!", Atom var, index, character]) = do + idx <- eval env index + chr <- eval env character + str <- eval env =<< getVar env var + (eval env $ substr(str, character, idx)) >>= setVar env var + where substr (String str, Char chr, Number index) = do + let slength = fromInteger index + String $ (take (fromInteger index) . drop 0) str ++ + [chr] ++ + (take (length str) . drop (fromInteger index + 1)) str + -- TODO: error handler + +eval env val@(Vector _) = return val + +eval env (List [Atom "vector-set!", Atom var, index, object]) = do + idx <- eval env index + obj <- eval env object + vec <- eval env =<< getVar env var + (eval env $ (updateVector vec idx obj)) >>= setVar env var + where updateVector (Vector vec) (Number idx) obj = Vector $ vec//[(fromInteger idx, obj)] + -- TODO: error handler? +-- TODO: error handler? - eval env (List [Atom "vector-set!", args]) = throwError $ NumArgs 2 args + +eval env (List [Atom "vector-fill!", Atom var, object]) = do + obj <- eval env object + vec <- eval env =<< getVar env var + (eval env $ (fillVector vec obj)) >>= setVar env var + where fillVector (Vector vec) obj = do + let l = replicate (lenVector vec) obj + Vector $ (listArray (0, length l - 1)) l + lenVector v = length (elems v) + -- TODO: error handler? +-- TODO: error handler? - eval env (List [Atom "vector-fill!", args]) = throwError $ NumArgs 2 args + +eval env (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do + key <- eval env rkey + value <- eval env rvalue + h <- eval env =<< getVar env var + case h of + HashTable ht -> (eval env $ HashTable $ Data.Map.insert key value ht) >>= setVar env var + otherwise -> throwError $ TypeMismatch "hash-table" otherwise + +eval env (List [Atom "hash-table-delete!", Atom var, rkey]) = do + key <- eval env rkey + h <- eval env =<< getVar env var + case h of + HashTable ht -> (eval env $ HashTable $ Data.Map.delete key ht) >>= setVar env var + otherwise -> throwError $ TypeMismatch "hash-table" otherwise + +-- TODO: +-- hash-table-update! +-- hash-table-update!/default +-- hash-table-merge! + +eval env (List (function : args)) = do + func <- eval env function + argVals <- mapM (eval env) args + apply func argVals + +--Obsolete (?) - eval env (List (Atom func : args)) = mapM (eval env) args >>= liftThrows . apply func +eval env badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm + +-- Helper function for evaluating 'case' +-- TODO: still need to handle case where nothing matches key +-- (same problem exists with cond, if) +evalCase :: Env -> LispVal -> IOThrowsError LispVal +evalCase env (List (key : cases)) = do + let c = cases !! 0 + ekey <- eval env key + case c of + List (Atom "else" : exprs) -> last $ map (eval env) exprs + List (List cond : exprs) -> do test <- checkEq env ekey (List cond) + case test of + Bool True -> last $ map (eval env) exprs + otherwise -> evalCase env $ List $ ekey : tail cases + badForm -> throwError $ BadSpecialForm "Unrecognized special form in case" badForm + where + checkEq env ekey (List (x : xs)) = do + test <- eval env $ List [Atom "eqv?", ekey, x] + case test of + Bool True -> eval env $ Bool True + otherwise -> checkEq env ekey (List xs) + + checkEq env ekey val = + case val of + List [] -> eval env $ Bool False -- If nothing else is left, then nothing matched key + otherwise -> do + test <- eval env $ List [Atom "eqv?", ekey, val] + case test of + Bool True -> eval env $ Bool True + otherwise -> eval env $ Bool False + +evalCase key badForm = throwError $ BadSpecialForm "case: Unrecognized special form" badForm + +-- Helper function for evaluating 'cond' +evalCond :: Env -> LispVal -> IOThrowsError LispVal +evalCond env (List [test, expr]) = eval env expr +evalCond env (List (test : expr)) = last $ map (eval env) expr -- TODO: all expr's need to be evaluated, not sure happening right now +evalCond env badForm = throwError $ BadSpecialForm "evalCond: Unrecognized special form" badForm + +makeFunc varargs env params body = return $ Func (map showVal params) varargs body env False +makeNormalFunc = makeFunc Nothing +makeVarargs = makeFunc . Just . showVal + +apply :: LispVal -> [LispVal] -> IOThrowsError LispVal +apply (IOFunc func) args = func args +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 (map ((,) varNamespace) params) args) >>= bindVarArgs varargs >>= (evalBody body) + where remainingArgs = drop (length params) args + num = toInteger . length + evalBody restBody env = do + -- Iterate through, executing each member of the body + -- Interestingly, this seems to handle Scheme tail recursion just fine. Need to analyze this + -- a bit more, but the trampoline itself may be unnecessary (which makes sense as Haskell has TCO) + +-- Old code, which will overflow stack: liftM last $ mapM (eval env) restBody + + case restBody of + [lv] -> eval env lv + (lv : lvs) -> do + eval env lv + evalBody lvs env + bindVarArgs arg env = case arg of + Just argName -> liftIO $ bindVars env [((varNamespace, argName), List $ remainingArgs)] + Nothing -> return env +apply func args = throwError $ BadSpecialForm "Unable to evaluate form" $ List (func : args) + +-- |Environment containing the primitive forms that are built into the Scheme language. Note that this only includes +-- forms that are implemented in Haskell; derived forms implemented in Scheme (such as let, list, etc) are available +-- in the standard library which must be pulled into the environment using (load). +primitiveBindings :: IO Env +primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives + ++ map (makeFunc PrimitiveFunc) primitives) + where makeFunc constructor (var, func) = ((varNamespace, var), constructor func) + +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)] + +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 $ Nil "") + +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 + +primitives :: [(String, [LispVal] -> ThrowsError LispVal)] +primitives = [("+", numAdd), + ("-", numSub), + ("*", numMul), + ("/", numDiv), + ("modulo", numericBinop mod), + ("quotient", numericBinop quot), + ("remainder", numericBinop rem), + + ("round", numRound), + ("floor", numFloor), + ("ceiling", numCeiling), + ("truncate", numTruncate), + + ("numerator", numNumerator), + ("denominator", numDenominator), + + ("exp", numExp), + ("log", numLog), + ("sin", numSin), + ("cos", numCos), + ("tan", numTan), + ("asin", numAsin), + ("acos", numAcos), + ("atan", numAtan), + + ("sqrt", numSqrt), + ("expt", numExpt), + + ("make-rectangular", numMakeRectangular), + ("make-polar", numMakePolar), + ("real-part", numRealPart ), + ("imag-part", numImagPart), + ("magnitude", numMagnitude), + ("angle", numAngle ), + + ("exact->inexact", numExact2Inexact), + ("inexact->exact", numInexact2Exact), + + ("number->string", num2String), + + ("=", numBoolBinopEq), + (">", numBoolBinopGt), + (">=", numBoolBinopGte), + ("<", numBoolBinopLt), + ("<=", numBoolBinopLte), + +-- TODO: sweep through the spec to make sure all numeric procedures are accounted for + +-- TODO: sweep through spec and implement all numeric "library procedures" - but in stdlib.scm + +-- TODO: string and number conversion functions; need to make +-- sure they are implemented and that they handle the full tower + + + ("&&", boolBoolBinop (&&)), + ("||", boolBoolBinop (||)), + ("string=?", strBoolBinop (==)), + ("string?", strBoolBinop (>)), + ("string<=?", strBoolBinop (<=)), + ("string>=?", strBoolBinop (>=)), + ("string-ci=?", stringCIEquals), + ("string-ci?", stringCIBoolBinop (>)), + ("string-ci<=?", stringCIBoolBinop (<=)), + ("string-ci>=?", stringCIBoolBinop (>=)), + + ("car", car), + ("cdr", cdr), + ("cons", cons), + ("eq?", eqv), + ("eqv?", eqv), + ("equal?", equal), + + ("pair?", isDottedList), + ("procedure?", isProcedure), +{- + TODO: full numeric tower: number?, complex?, rational? + --} + ("number?", isNumber), + ("complex?", isComplex), + ("real?", isReal), + ("rational?", isRational), + ("integer?", isInteger), + ("list?", unaryOp isList), + ("null?", isNull), + ("symbol?", isSymbol), + ("symbol->string", symbol2String), + ("string->symbol", string2Symbol), + ("char?", isChar), + + ("vector?", unaryOp isVector), + ("make-vector", makeVector), + ("vector", buildVector), + ("vector-length", vectorLength), + ("vector-ref", vectorRef), + ("vector->list", vectorToList), + ("list->vector", listToVector), + + ("make-hash-table", hashTblMake), + ("hash-table?", isHashTbl), +-- TODO: alist->hash-table + ("hash-table-exists?", hashTblExists), + ("hash-table-ref", hashTblRef), + ("hash-table-size", hashTblSize), + ("hash-table->alist", hashTbl2List), + ("hash-table-keys", hashTblKeys), + ("hash-table-values", hashTblValues), +-- TODO next: hash-table-walk, hash-table-fold +-- TODO: many more, see SRFI + ("hash-table-copy", hashTblCopy), + + ("string?", isString), + ("string", buildString), + ("make-string", makeString), + ("string-length", stringLength), + ("string-ref", stringRef), + ("substring", substring), + ("string-append", stringAppend), + ("string->number", stringToNumber), + ("string->list", stringToList), + ("list->string", listToString), + ("string-copy", stringCopy), + + ("boolean?", isBoolean)] + +data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a) + +unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool +unpackEquals arg1 arg2 (AnyUnpacker unpacker) = + do unpacked1 <- unpacker arg1 + unpacked2 <- unpacker arg2 + return $ unpacked1 == unpacked2 + `catchError` (const $ return False) + +boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal +boolBinop unpacker op args = if length args /= 2 + then throwError $ NumArgs 2 args + else do left <- unpacker $ args !! 0 + right <- unpacker $ args !! 1 + return $ Bool $ left `op` right + +unaryOp :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal +unaryOp f [v] = f v + +numBoolBinop = boolBinop unpackNum +strBoolBinop = boolBinop unpackStr +boolBoolBinop = boolBinop unpackBool + +unpackStr :: LispVal -> ThrowsError String +unpackStr (String s) = return s +unpackStr (Number s) = return $ show s +unpackStr (Bool s) = return $ show s +unpackStr notString = throwError $ TypeMismatch "string" notString + +unpackBool :: LispVal -> ThrowsError Bool +unpackBool (Bool b) = return b +unpackBool notBool = throwError $ TypeMismatch "boolean" notBool + +{- List 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 (x : xs)] = return $ List xs +cdr [DottedList [xs] x] = return x +cdr [DottedList (_ : xs) x] = return $ DottedList xs x +cdr [badArg] = throwError $ TypeMismatch "pair" badArg +cdr badArgList = throwError $ NumArgs 1 badArgList + +cons :: [LispVal] -> ThrowsError LispVal +cons [x1, List []] = return $ List [x1] +cons [x, List xs] = return $ List $ x : xs +cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast +cons [x1, x2] = return $ DottedList [x1] x2 +cons badArgList = throwError $ NumArgs 2 badArgList + +equal :: [LispVal] -> ThrowsError LispVal +equal [(Vector arg1), (Vector arg2)] = eqvList equal [List $ (elems arg1), List $ (elems arg2)] +-- TODO: hash table? +equal [l1@(List arg1), l2@(List arg2)] = eqvList equal [l1, l2] +equal [(DottedList xs x), (DottedList ys y)] = equal [List $ xs ++ [x], List $ ys ++ [y]] +equal [arg1, arg2] = do + primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2) + [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool] + eqvEquals <- eqv [arg1, arg2] + return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x) +equal badArgList = throwError $ NumArgs 2 badArgList + +-------------- Vector Primitives -------------- + +makeVector, buildVector, vectorLength, vectorRef, vectorToList, listToVector :: [LispVal] -> ThrowsError LispVal +makeVector [(Number n)] = makeVector [Number n, List []] +makeVector [(Number n), a] = do + let l = replicate (fromInteger n) a + return $ Vector $ (listArray (0, length l - 1)) l +makeVector [badType] = throwError $ TypeMismatch "integer" badType +makeVector badArgList = throwError $ NumArgs 1 badArgList + +buildVector (o:os) = do + let lst = o:os + return $ Vector $ (listArray (0, length lst - 1)) lst +buildVector badArgList = throwError $ NumArgs 1 badArgList + +vectorLength [(Vector v)] = return $ Number $ toInteger $ length (elems v) +vectorLength [badType] = throwError $ TypeMismatch "vector" badType +vectorLength badArgList = throwError $ NumArgs 1 badArgList + +vectorRef [(Vector v), (Number n)] = return $ v ! (fromInteger n) +vectorRef [badType] = throwError $ TypeMismatch "vector integer" badType +vectorRef badArgList = throwError $ NumArgs 2 badArgList + +vectorToList [(Vector v)] = return $ List $ elems v +vectorToList [badType] = throwError $ TypeMismatch "vector" badType +vectorToList badArgList = throwError $ NumArgs 1 badArgList + +listToVector [(List l)] = return $ Vector $ (listArray (0, length l - 1)) l +listToVector [badType] = throwError $ TypeMismatch "list" badType +listToVector badArgList = throwError $ NumArgs 1 badArgList + +-------------- Hash Table Primitives -------------- + +-- Future: support (equal?), (hash) parameters +hashTblMake, isHashTbl, hashTblExists, hashTblRef, hashTblSize, hashTbl2List, hashTblKeys, hashTblValues, hashTblCopy:: [LispVal] -> ThrowsError LispVal +hashTblMake _ = return $ HashTable $ Data.Map.fromList [] + +isHashTbl [(HashTable _)] = return $ Bool True +isHashTbl _ = return $ Bool False + +hashTblExists [(HashTable ht), key@(_)] = do + case Data.Map.lookup key ht of + Just val -> return $ Bool True + Nothing -> return $ Bool False + +hashTblRef [(HashTable ht), key@(_)] = do + case Data.Map.lookup key ht of + Just val -> return $ val + Nothing -> throwError $ BadSpecialForm "Hash table does not contain key" key +-- TODO: a thunk can optionally be specified, this drives definition of /default +hashTblRef [(HashTable ht), key@(_), thunk@(Func params vararg body closure _)] = do + case Data.Map.lookup key ht of + Just val -> return $ val +-- TODO: Nothing -> apply thunk [] +hashTblRef [badType] = throwError $ TypeMismatch "hash-table" badType +hashTblRef badArgList = throwError $ NumArgs 2 badArgList + +hashTblSize [(HashTable ht)] = return $ Number $ toInteger $ Data.Map.size ht +hashTblSize [badType] = throwError $ TypeMismatch "hash-table" badType +hashTblSize badArgList = throwError $ NumArgs 1 badArgList + +hashTbl2List [(HashTable ht)] = do + return $ List $ map (\(k, v) -> List [k, v]) $ Data.Map.toList ht +hashTbl2List [badType] = throwError $ TypeMismatch "hash-table" badType +hashTbl2List badArgList = throwError $ NumArgs 1 badArgList + +hashTblKeys [(HashTable ht)] = do + return $ List $ map (\(k, v) -> k) $ Data.Map.toList ht +hashTblKeys [badType] = throwError $ TypeMismatch "hash-table" badType +hashTblKeys badArgList = throwError $ NumArgs 1 badArgList + +hashTblValues [(HashTable ht)] = do + return $ List $ map (\(k, v) -> v) $ Data.Map.toList ht +hashTblValues [badType] = throwError $ TypeMismatch "hash-table" badType +hashTblValues badArgList = throwError $ NumArgs 1 badArgList + +hashTblCopy [(HashTable ht)] = do + return $ HashTable $ Data.Map.fromList $ Data.Map.toList ht +hashTblCopy [badType] = throwError $ TypeMismatch "hash-table" badType +hashTblCopy badArgList = throwError $ NumArgs 1 badArgList + +-------------- String Primitives -------------- + +buildString :: [LispVal] -> ThrowsError LispVal +buildString [(Char c)] = return $ String [c] +buildString (Char c:rest) = do + cs <- buildString rest + case cs of + String s -> return $ String $ [c] ++ s + badType -> throwError $ TypeMismatch "character" badType +buildString [badType] = throwError $ TypeMismatch "character" badType +buildString badArgList = throwError $ NumArgs 1 badArgList + +makeString :: [LispVal] -> ThrowsError LispVal +makeString [(Number n)] = return $ doMakeString n ' ' "" +makeString [(Number n), (Char c)] = return $ doMakeString n c "" +makeString badArgList = throwError $ NumArgs 1 badArgList + +doMakeString n chr s = + if n == 0 + then String s + else doMakeString (n - 1) chr (s ++ [chr]) + +stringLength :: [LispVal] -> ThrowsError LispVal +stringLength [String s] = return $ Number $ foldr (const (+1)) 0 s -- Could probably do 'length s' instead... +stringLength [badType] = throwError $ TypeMismatch "string" badType +stringLength badArgList = throwError $ NumArgs 1 badArgList + +stringRef :: [LispVal] -> ThrowsError LispVal +stringRef [(String s), (Number k)] = return $ Char $ s !! fromInteger k +stringRef [badType] = throwError $ TypeMismatch "string number" badType +stringRef badArgList = throwError $ NumArgs 2 badArgList + +substring :: [LispVal] -> ThrowsError LispVal +substring [(String s), (Number start), (Number end)] = + do let length = fromInteger $ end - start + let begin = fromInteger start + return $ String $ (take length . drop begin) s +substring [badType] = throwError $ TypeMismatch "string number number" badType +substring badArgList = throwError $ NumArgs 3 badArgList + +stringCIEquals :: [LispVal] -> ThrowsError LispVal +stringCIEquals [(String s1), (String s2)] = do + if (length s1) /= (length s2) + then return $ Bool False + else return $ Bool $ ciCmp s1 s2 0 + where ciCmp s1 s2 idx = if idx == (length s1) + then True + else if (toLower $ s1 !! idx) == (toLower $ s2 !! idx) + then ciCmp s1 s2 (idx + 1) + else False +stringCIEquals [badType] = throwError $ TypeMismatch "string string" badType +stringCIEquals badArgList = throwError $ NumArgs 2 badArgList + +stringCIBoolBinop :: ([Char] -> [Char] -> Bool) -> [LispVal] -> ThrowsError LispVal +stringCIBoolBinop op [(String s1), (String s2)] = boolBinop unpackStr op [(String $ strToLower s1), (String $ strToLower s2)] + where strToLower str = map (toLower) str +stringCIBoolBinop op [badType] = throwError $ TypeMismatch "string string" badType +stringCIBoolBinop op badArgList = throwError $ NumArgs 2 badArgList + +stringAppend :: [LispVal] -> ThrowsError LispVal +stringAppend [(String s)] = return $ String s -- Needed for "last" string value +stringAppend (String st:sts) = do + rest <- stringAppend sts +-- TODO: I needed to use <- instead of "let = " here, for type problems. Why??? +-- TBD: this probably will solve type problems when processing other lists of objects in the other string functions + case rest of + String s -> return $ String $ st ++ s + otherwise -> throwError $ TypeMismatch "string" otherwise +stringAppend [badType] = throwError $ TypeMismatch "string" badType +stringAppend badArgList = throwError $ NumArgs 1 badArgList + +-- This could be expanded, for now just converts integers +-- TODO: handle a radix param +stringToNumber :: [LispVal] -> ThrowsError LispVal +stringToNumber [(String s)] = do + result <- (readExpr s) -- result <- parseExpr s + case result of + n@(Number _) -> return n + n@(Rational _) -> return n + n@(Float _) -> return n + n@(Complex _) -> return n + otherwise -> return $ Bool False +stringToNumber [badType] = throwError $ TypeMismatch "string" badType +stringToNumber badArgList = throwError $ NumArgs 1 badArgList + +stringToList :: [LispVal] -> ThrowsError LispVal +stringToList [(String s)] = return $ List $ map (Char) s +stringToList [badType] = throwError $ TypeMismatch "string" badType +stringToList badArgList = throwError $ NumArgs 1 badArgList + +listToString :: [LispVal] -> ThrowsError LispVal +listToString [(List [])] = return $ String "" +listToString [(List l)] = buildString l +listToString [badType] = throwError $ TypeMismatch "list" badType + +stringCopy :: [LispVal] -> ThrowsError LispVal +stringCopy [String s] = return $ String s +stringCopy [badType] = throwError $ TypeMismatch "string" badType +stringCopy badArgList = throwError $ NumArgs 2 badArgList + +isDottedList :: [LispVal] -> ThrowsError LispVal +isDottedList ([DottedList l d]) = return $ Bool True +isDottedList _ = return $ Bool False + +isProcedure :: [LispVal] -> ThrowsError LispVal +isProcedure ([PrimitiveFunc f]) = return $ Bool True +isProcedure ([Func params vararg body closure partial]) = return $ Bool True +isProcedure ([IOFunc f]) = return $ Bool True +isProcedure _ = return $ Bool False + +isVector, isList :: LispVal -> ThrowsError LispVal +isVector (Vector _) = return $ Bool True +isVector _ = return $ Bool False +isList (List _) = return $ Bool True +isList _ = return $ Bool False + +isNull :: [LispVal] -> ThrowsError LispVal +isNull ([List []]) = return $ Bool True +isNull _ = return $ Bool False + +isSymbol :: [LispVal] -> ThrowsError LispVal +isSymbol ([Atom a]) = return $ Bool True +isSymbol _ = return $ Bool False + +symbol2String :: [LispVal] -> ThrowsError LispVal +symbol2String ([Atom a]) = return $ String a +symbol2String [notAtom] = throwError $ TypeMismatch "symbol" notAtom + +string2Symbol :: [LispVal] -> ThrowsError LispVal +string2Symbol ([String s]) = return $ Atom s +string2Symbol [notString] = throwError $ TypeMismatch "string" notString + +isChar :: [LispVal] -> ThrowsError LispVal +isChar ([Char a]) = return $ Bool True +isChar _ = return $ Bool False + +isString :: [LispVal] -> ThrowsError LispVal +isString ([String s]) = return $ Bool True +isString _ = return $ Bool False + +isBoolean :: [LispVal] -> ThrowsError LispVal +isBoolean ([Bool n]) = return $ Bool True +isBoolean _ = return $ Bool False +-- end Eval section + +{- Should not need this function, since we are using Haskell +trampoline :: Env -> LispVal -> IOThrowsError LispVal +trampoline env val = do + result <- eval env val + case result of + -- If a form is not fully-evaluated to a value, bounce it back onto the trampoline... + func@(Func params vararg body closure True) -> trampoline env func -- next iteration, via tail call (?) + val -> return val +-} diff --git a/hs-src/Scheme/Macro.hs b/hs-src/Scheme/Macro.hs new file mode 100644 --- /dev/null +++ b/hs-src/Scheme/Macro.hs @@ -0,0 +1,449 @@ +{- + - husk scheme + - Macro + - @author Justin Ethier + - + - Purpose: + - + - This file contains code for hygienic macros. + - + - During transformation, the following components are considered: + - - Pattern (part of a rule that matches input) + - - Transform (what the macro "expands" into) + - - Input (the actual code in the user's program) + - + - At a high level, macro transformation is broken down into the following steps: + - + - 1) Search for a rule that matches the input. + - During this process, any variables in the input are loaded into a temporary environment + - 2) If a rule matches, + - 3) Transform by walking the transform, inserting variables as needed + - + - + - Remaining Work: + - + - * Vectors are currently not supported + - + - * Dotted lists are not 100% correctly implemented. In particular, the transformation should + - take into account whether the input was presented as a list or a pair, and replicate that + - in the output. + - + - -} +module Scheme.Macro + ( + macroEval + ) where +import Scheme.Types +import Scheme.Variables +import Control.Monad +import Control.Monad.Error +import Debug.Trace -- Only req'd to support trace, can be disabled at any time... + +-- Nice FAQ regarding macro's, points out some of the limitations of current implementation +-- http://community.schemewiki.org/?scheme-faq-macros + +-- Search for macro's in the AST, and transform any that are found. +-- There is also a special case (define-syntax) that loads new rules. +macroEval :: Env -> LispVal -> IOThrowsError LispVal +macroEval env (List [Atom "define-syntax", Atom keyword, syntaxRules@(List (Atom "syntax-rules" : (List identifiers : rules)))]) = do + -- TODO: there really ought to be some error checking of the syntax rules, since they could be malformed... + -- As it stands now, there is no checking until the code attempts to perform a macro transformation. + defineNamespacedVar env macroNamespace keyword syntaxRules + return $ Nil "" -- Sentinal value +macroEval env lisp@(List (x@(List _) : xs)) = do + first <- macroEval env x + rest <- mapM (macroEval env) xs + return $ List $ first : rest +-- TODO: equivalent matches/transforms for vectors +-- what about dotted lists? +macroEval env lisp@(List (Atom x : xs)) = do + isDefined <- liftIO $ isNamespacedBound env macroNamespace x + if isDefined + then do + syntaxRules@(List (Atom "syntax-rules" : (List identifiers : rules))) <- getNamespacedVar env macroNamespace x + -- Transform the input and then call macroEval again, since a macro may be contained within... + macroEval env =<< macroTransform env (List identifiers) rules lisp + else do + rest <- mapM (macroEval env) xs + return $ List $ (Atom x) : rest +macroEval _ lisp@(_) = return lisp + +-- Given input and syntax-rules, determine if any rule is a match and transform it. +-- +-- FUTURE: validate that the pattern's template and pattern are consistent (IE: no vars in transform that do not appear in matching pattern - csi "stmt1" case) +-- +-- Parameters: +-- env - Higher level LISP environment +-- identifiers - Literal identifiers - IE, atoms that should not be transformed +-- rules - pattern/transform pairs to compare to input +-- input - Code from the scheme application +macroTransform :: Env -> LispVal -> [LispVal] -> LispVal -> IOThrowsError LispVal +macroTransform env identifiers rules@(rule@(List r) : rs) input = do + localEnv <- liftIO $ nullEnv -- Local environment used just for this invocation + result <- matchRule env identifiers localEnv rule input + case result of + Nil _ -> macroTransform env identifiers rs input + otherwise -> return result +-- Ran out of rules to match... +macroTransform _ _ _ input = throwError $ BadSpecialForm "Input does not match a macro pattern" input + +-- Determine if the next element in a list matches 0-to-n times due to an ellipsis +macroElementMatchesMany :: LispVal -> Bool +macroElementMatchesMany (List (p:ps)) = do + if length ps > 0 + then case (head ps) of + Atom "..." -> True + otherwise -> False + else False +macroElementMatchesMany _ = False + +-- Given input, determine if that input matches any rules +-- @return Transformed code, or Nil if no rules match +matchRule :: Env -> LispVal -> Env -> LispVal -> LispVal -> IOThrowsError LispVal +--matchRule env identifiers localEnv (List [p@(List patternVar), template@(List _)]) (List inputVar) = do +matchRule env identifiers localEnv (List [pattern, template]) (List inputVar) = do + let is = tail inputVar + let p = case pattern of + DottedList ds d -> case ds of + (Atom l : ls) -> List [Atom l, DottedList ls d] + otherwise -> pattern + otherwise -> pattern + case p of + List (Atom _ : ps) -> do + match <- loadLocal localEnv identifiers (List ps) (List is) False False + case match of + Bool False -> return $ Nil "" + otherwise -> transformRule localEnv 0 (List []) template (List []) + otherwise -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" p + +matchRule _ identifiers _ rule input = do + throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ List [Atom "rule: ", rule, Atom "input: ", input] + +-- +-- loadLocal - Determine if pattern matches input, loading input into pattern variables as we go, +-- in preparation for macro transformation. +loadLocal :: Env -> LispVal -> LispVal -> LispVal -> Bool -> Bool -> IOThrowsError LispVal +loadLocal localEnv identifiers pattern input hasEllipsis outerHasEllipsis = do -- TODO: kind of a hack to have both ellipsis vars. Is only outer req'd? + case (pattern, input) of + + -- Future: vector + + ((DottedList ps p), (DottedList is i)) -> do + result <- loadLocal localEnv identifiers (List ps) (List is) False outerHasEllipsis + case result of + Bool True -> loadLocal localEnv identifiers p i False outerHasEllipsis + otherwise -> return $ Bool False + + (List (p:ps), List (i:is)) -> do -- check first input against first pattern, recurse... + + let hasEllipsis = macroElementMatchesMany pattern + + -- TODO: error if ... detected when there is an outer ... ???? + -- no, this should (eventually) be allowed. See scheme-faq-macros + + status <- checkLocal localEnv identifiers (hasEllipsis || outerHasEllipsis) p i + case status of + -- No match + Bool False -> if hasEllipsis + -- No match, must be finished with ... + -- Move past it, but keep the same input. + then do + loadLocal localEnv identifiers (List $ tail ps) (List (i:is)) False outerHasEllipsis + else return $ Bool False + -- There was a match + otherwise -> if hasEllipsis + then loadLocal localEnv identifiers pattern (List is) True outerHasEllipsis + else loadLocal localEnv identifiers (List ps) (List is) False outerHasEllipsis + + -- Base case - All data processed + (List [], List []) -> return $ Bool True + + -- Ran out of input to process + (List (p:ps), List []) -> do + -- Ensure any patterns that are not present in the input still + -- have their variables initialized so they are ready during trans. + initializePatternVars localEnv "list" identifiers pattern + let hasEllipsis = macroElementMatchesMany pattern + if hasEllipsis && ((length ps) == 1) + then return $ Bool True + else return $ Bool False + + -- Pattern ran out, but there is still input. No match. + (List [], _) -> return $ Bool False + + -- Check input against pattern (both should be single var) + (_, _) -> checkLocal localEnv identifiers (hasEllipsis || outerHasEllipsis) pattern input + +-- Check pattern against input to determine if there is a match +-- +-- @param localEnv - Local variables for the macro, used during transform +-- @param hasEllipsis - Determine whether we are in a zero-or-many match. +-- Used for loading local vars and NOT for purposes of matching. +-- @param pattern - Pattern to match +-- @param input - Input to be matched +checkLocal :: Env -> LispVal -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal +checkLocal localEnv identifiers hasEllipsis (Bool pattern) (Bool input) = return $ Bool $ pattern == input +checkLocal localEnv identifiers hasEllipsis (Number pattern) (Number input) = return $ Bool $ pattern == input +checkLocal localEnv identifiers hasEllipsis (Float pattern) (Float input) = return $ Bool $ pattern == input +checkLocal localEnv identifiers hasEllipsis (String pattern) (String input) = return $ Bool $ pattern == input +checkLocal localEnv identifiers hasEllipsis (Char pattern) (Char input) = return $ Bool $ pattern == input +checkLocal localEnv identifiers hasEllipsis (Atom pattern) input = do + if hasEllipsis + -- Var is part of a 0-to-many match, store up in a list... + then do isDefined <- liftIO $ isBound localEnv pattern + -- If pattern is a literal identifier, then just pass it along as-is + found <- findAtom (Atom pattern) identifiers + let val = case found of + (Bool True) -> Atom pattern + otherwise -> input + -- Set variable in the local environment + if isDefined + then do v <- getVar localEnv pattern + case v of + (List vs) -> setVar localEnv pattern (List $ vs ++ [val]) + else defineVar localEnv pattern (List [val]) + -- Simple var, load up into macro env + else defineVar localEnv pattern input + return $ Bool True + +-- TODO: vector support. And what the heck are these next two TODO's doing here? :) +-- TODO, load into localEnv in some (all?) cases?: eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2 +-- TODO: eqv [(Vector arg1), (Vector arg2)] = eqv [List $ (elems arg1), List $ (elems arg2)] +-- +checkLocal localEnv identifiers hasEllipsis pattern@(DottedList ps p) input@(DottedList is i) = + loadLocal localEnv identifiers pattern input False hasEllipsis +-- throwError $ BadSpecialForm "Test" input +checkLocal localEnv identifiers hasEllipsis pattern@(DottedList ps p) input@(List (i : is)) = do + if (length ps) == (length is) + -- Lists are same length, implying elements in both should be the same. + -- Cast pair to a List for further processing + then loadLocal localEnv identifiers (List $ ps ++ [p]) input False hasEllipsis + -- Idea here is that if we have a dotted list, the last component does not have to be provided + -- in the input. So in that case just fill in an empty list for the missing component. + else loadLocal localEnv identifiers pattern (DottedList (i : is) (List [])) False hasEllipsis +checkLocal localEnv identifiers hasEllipsis pattern@(List _) input@(List _) = + loadLocal localEnv identifiers pattern input False hasEllipsis + +checkLocal localEnv identifiers hasEllipsis _ _ = return $ Bool False + +-- Transform input by walking the tranform structure and creating a new structure +-- with the same form, replacing identifiers in the tranform with those bound in localEnv +transformRule :: Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal + +-- Recursively transform a list +-- +-- Parameters: +-- +-- localEnv - Local variable environment +-- ellipsisIndex - Zero-or-more match variables are stored as a list. +-- This is the index into the current value to read from list +-- result - Resultant value, must be a parameter as it mutates with each function call, so we pass it using CPS +-- transform - The macro transformation, we read it out one atom at a time, and rewrite it into result +-- ellipsisList - Temporarily holds value of the "outer" result while we process the +-- zero-or-more match. Once that is complete we swap this value back into it's rightful place +-- +transformRule localEnv ellipsisIndex (List result) transform@(List(List l : ts)) (List ellipsisList) = do + if macroElementMatchesMany transform + then do + curT <- transformRule localEnv (ellipsisIndex + 1) (List []) (List l) (List result) + case curT of + Nil _ -> if ellipsisIndex == 0 + -- First time through and no match ("zero" case). Use tail to move past the "..." + then transformRule localEnv 0 (List $ result) (List $ tail ts) (List []) + -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..." + else transformRule localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List []) + -- Dotted list transform returned during processing... + List [Nil _, List elst] -> if ellipsisIndex == 0 + -- First time through and no match ("zero" case). Use tail to move past the "..." + then transformRule localEnv 0 (List $ result) (List $ tail ts) (List []) + -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..." + else transformRule localEnv 0 (List $ result) (List $ tail ts) (List []) + List t -> transformRule localEnv (ellipsisIndex + 1) (List $ result ++ [curT]) transform (List ellipsisList) + else do + lst <- transformRule localEnv ellipsisIndex (List []) (List l) (List ellipsisList) + case lst of + List [Nil _, l] -> return lst + List _ -> transformRule localEnv ellipsisIndex (List $ result ++ [lst]) (List ts) (List ellipsisList) + Nil _ -> return lst + otherwise -> throwError $ BadSpecialForm "Macro transform error" $ List [lst, (List l), Number $ toInteger ellipsisIndex] + + where lastElementIsNil l = case (last l) of + Nil _ -> True + otherwise -> False + getListAtTail l = case (last l) of + List lst -> lst + + +-- TODO: vector transform (and taking vectors into account in other cases as well???) + + +transformRule localEnv ellipsisIndex (List result) transform@(List (dl@(DottedList ds d) : ts)) (List ellipsisList) = do + if macroElementMatchesMany transform + then do + -- Idea here is that we need to handle case where you have (pair ...) - EG: ((var . step) ...) + curT <- transformDottedList localEnv (ellipsisIndex + 1) (List []) (List [dl]) (List result) + case curT of + Nil _ -> if ellipsisIndex == 0 + -- First time through and no match ("zero" case). Use tail to move past the "..." + then transformRule localEnv 0 (List $ result) (List $ tail ts) (List []) + -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..." + else transformRule localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List []) + -- This case is here because we need to process individual components of the pair to determine + -- whether we are done with the match. It is similar to above but not exact... + List [Nil _, List elst] -> if ellipsisIndex == 0 + -- First time through and no match ("zero" case). Use tail to move past the "..." + then transformRule localEnv 0 (List $ result) (List $ tail ts) (List []) + -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..." + else transformRule localEnv 0 (List $ result) (List $ tail ts) (List []) + List t -> transformRule localEnv (ellipsisIndex + 1) (List $ result ++ t) transform (List ellipsisList) + else do lst <- transformDottedList localEnv ellipsisIndex (List []) (List [dl]) (List ellipsisList) + case lst of + List [Nil _, List l] -> return lst + List l -> transformRule localEnv ellipsisIndex (List $ result ++ l) (List ts) (List ellipsisList) + Nil n -> return lst + otherwise -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [dl]), Number $ toInteger ellipsisIndex] + + where transformDottedList :: Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal + transformDottedList localEnv ellipsisIndex (List result) transform@(List (DottedList ds d : ts)) (List ellipsisList) = do + lsto <- transformRule localEnv ellipsisIndex (List []) (List ds) (List ellipsisList) + case lsto of + List lst -> do + r <- transformRule localEnv ellipsisIndex (List []) (List [d]) (List ellipsisList) + case r of + -- Trailing symbol in the pattern may be neglected in the transform, so skip it... + List [List []] -> transformRule localEnv ellipsisIndex (List $ result ++ [List lst]) (List ts) (List ellipsisList) + -- TODO: the transform needs to be as follows: + -- - transform into a list if original input was a list - code is below but commented-out + -- - transform into a dotted list if original input was a dotted list + -- + -- Could implement this by calling a new function on input (ds?) that goes through it and + -- looks up each atom that it finds, looking for its src. The src (or Nil?) would then be returned + -- and used here to determine what type of transform is used. + -- +-- List [rst] -> transformRule localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList) +-- List [rst] -> transformRule localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList) + List [rst] -> do + src <- lookupPatternVarSrc localEnv $ List ds + case src of + String "pair" -> transformRule localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList) + otherwise -> transformRule localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList) + otherwise -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d + Nil _ -> return $ List [Nil "", List ellipsisList] + otherwise -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d + +-- Transform an atom by attempting to look it up as a var... +transformRule localEnv ellipsisIndex (List result) transform@(List (Atom a : ts)) unused = do + let hasEllipsis = macroElementMatchesMany transform + isDefined <- liftIO $ isBound localEnv a + if hasEllipsis + then if isDefined + then do + -- get var + var <- getVar localEnv a + -- ensure it is a list + case var of + -- add all elements of the list into result + List v -> transformRule localEnv ellipsisIndex (List $ result ++ v) (List $ tail ts) unused + v@(_) -> transformRule localEnv ellipsisIndex (List $ result ++ [v]) (List $ tail ts) unused + else -- Matched 0 times, skip it + transformRule localEnv ellipsisIndex (List result) (List $ tail ts) unused + else do t <- if isDefined + then do var <- getVar localEnv a + if ellipsisIndex > 0 + then do case var of + List v -> if (length v) > (ellipsisIndex - 1) + then return $ v !! (ellipsisIndex - 1) + else return $ Nil "" + else return var + else return $ Atom a + case t of + Nil _ -> return t + otherwise -> transformRule localEnv ellipsisIndex (List $ result ++ [t]) (List ts) unused + +-- Transform anything else as itself... +transformRule localEnv ellipsisIndex (List result) transform@(List (t : ts)) (List ellipsisList) = do + transformRule localEnv ellipsisIndex (List $ result ++ [t]) (List ts) (List ellipsisList) + +-- Base case - empty transform +transformRule localEnv ellipsisIndex result@(List _) transform@(List []) unused = do + return result + +transformRule localEnv ellipsisIndex result transform unused = do + throwError $ BadSpecialForm "An error occurred during macro transform" $ List [(Number $ toInteger ellipsisIndex), result, transform, unused] + +-- Find an atom in a list; non-recursive (IE, a sub-list will not be inspected) +findAtom :: LispVal -> LispVal -> IOThrowsError LispVal +findAtom (Atom target) (List (Atom a:as)) = do + if target == a + then return $ Bool True + else findAtom (Atom target) (List as) +findAtom target (List (badtype : _)) = throwError $ TypeMismatch "symbol" badtype -- TODO: test this, non-atoms should throw err +findAtom target _ = return $ Bool False + +-- Initialize any pattern variables as an empty list. +-- That way a zero-match case can be identified later during transformation. +-- +-- Input: +-- localEnv - Local environment that contains variables +-- src - Input source, required because a pair in the pattern may be matched by either a list or a pair, +-- and the transform needs to know this... +-- identifiers - Literal identifiers that are transformed as themselves +-- pattern - Pattern portion of the syntax rule +initializePatternVars :: Env -> String -> LispVal -> LispVal -> IOThrowsError LispVal +initializePatternVars localEnv src identifiers pattern@(List _) = do + case pattern of + List (p:ps) -> do initializePatternVars localEnv src identifiers p + initializePatternVars localEnv src identifiers $ List ps + List [] -> return $ Bool True + +initializePatternVars localEnv src identifiers pattern@(DottedList ps p) = do + initializePatternVars localEnv src identifiers $ List ps + initializePatternVars localEnv src identifiers p + +-- TODO: vector + +initializePatternVars localEnv src identifiers (Atom pattern) = + -- FUTURE: + -- there is code to attempt to flag "src" here, but it is not + -- wire up correctly. In fact, the whole design here probably + -- needs to be rethinked. + do defineNamespacedVar localEnv "src" pattern $ String src + isDefined <- liftIO $ isBound localEnv pattern + found <- findAtom (Atom pattern) identifiers + case found of + (Bool False) -> if not isDefined -- Set variable in the local environment + then do + defineVar localEnv pattern (List []) + else do + return $ Bool True + -- Ignore identifiers since they are just passed along as-is + otherwise -> return $ Bool True + +initializePatternVars localEnv src identifiers pattern = + return $ Bool True + +-- Find the first pattern var that reports being from a src, or False if none +lookupPatternVarSrc :: Env -> LispVal -> IOThrowsError LispVal +lookupPatternVarSrc localEnv pattern@(List _) = do + case pattern of + List (p:ps) -> do result <- lookupPatternVarSrc localEnv p + case result of + Bool False -> lookupPatternVarSrc localEnv $ List ps + otherwise -> return result + List [] -> return $ Bool False + +lookupPatternVarSrc localEnv pattern@(DottedList ps p) = do + result <- lookupPatternVarSrc localEnv $ List ps + case result of + Bool False -> lookupPatternVarSrc localEnv p + otherwise -> return result + +-- TODO: vector + +lookupPatternVarSrc localEnv (Atom pattern) = + do isDefined <- liftIO $ isNamespacedBound localEnv "src" pattern + if isDefined then getNamespacedVar localEnv "src" pattern + else return $ Bool False + +lookupPatternVarSrc localEnv pattern = + return $ Bool False diff --git a/hs-src/Scheme/Numerical.hs b/hs-src/Scheme/Numerical.hs new file mode 100644 --- /dev/null +++ b/hs-src/Scheme/Numerical.hs @@ -0,0 +1,368 @@ +{- + - husk scheme interpreter + - + - A lightweight dialect of R5RS scheme. + - Numerical tower functionality + - + - @author Justin Ethier + - + - -} + +module Scheme.Numerical where +import Scheme.Types +import Scheme.Variables +import Complex +import Control.Monad.Error +import Numeric +import Ratio +import Text.Printf + +numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal +numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal +numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op + +--- Begin GenUtil - http://repetae.net/computer/haskell/GenUtil.hs +foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a +foldlM f v (x:xs) = (f v x) >>= \a -> foldlM f a xs +foldlM _ v [] = return v + +foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a +foldl1M f (x:xs) = foldlM f x xs +foldl1M _ _ = error "foldl1M" +-- end GenUtil + + +--- Numeric operations section --- +-- TODO: move all of this out into its own file + +numAdd, numSub, numMul, numDiv :: [LispVal] -> ThrowsError LispVal +numAdd params = do + foldl1M (\a b -> doAdd =<< (numCast [a, b])) params + where doAdd (List [(Number a), (Number b)]) = return $ Number $ a + b + doAdd (List [(Float a), (Float b)]) = return $ Float $ a + b + doAdd (List [(Rational a), (Rational b)]) = return $ Rational $ a + b + doAdd (List [(Complex a), (Complex b)]) = return $ Complex $ a + b +numSub [Number n] = return $ Number $ -1 * n +numSub [Float n] = return $ Float $ -1 * n +numSub [Rational n] = return $ Rational $ -1 * n +numSub [Complex n] = return $ Complex $ -1 * n +numSub params = do + foldl1M (\a b -> doSub =<< (numCast [a, b])) params + where doSub (List [(Number a), (Number b)]) = return $ Number $ a - b + doSub (List [(Float a), (Float b)]) = return $ Float $ a - b + doSub (List [(Rational a), (Rational b)]) = return $ Rational $ a - b + doSub (List [(Complex a), (Complex b)]) = return $ Complex $ a - b +numMul params = do + foldl1M (\a b -> doMul =<< (numCast [a, b])) params + where doMul (List [(Number a), (Number b)]) = return $ Number $ a * b + doMul (List [(Float a), (Float b)]) = return $ Float $ a * b + doMul (List [(Rational a), (Rational b)]) = return $ Rational $ a * b + doMul (List [(Complex a), (Complex b)]) = return $ Complex $ a * b +numDiv [Number n] = return $ Rational $ 1 / (fromInteger n) +numDiv [Float n] = return $ Float $ 1.0 / n +numDiv [Rational n] = return $ Rational $ 1 / n +numDiv [Complex n] = return $ Complex $ 1 / n +numDiv params = do -- TODO: for Number type, need to cast results to Rational, per R5RS spec + foldl1M (\a b -> doDiv =<< (numCast [a, b])) params + where doDiv (List [(Number a), (Number b)]) = if b == 0 + then throwError $ DivideByZero + else return $ Number $ div a b + doDiv (List [(Float a), (Float b)]) = if b == 0.0 + then throwError $ DivideByZero + else return $ Float $ a / b + doDiv (List [(Rational a), (Rational b)]) = if b == 0 + then throwError $ DivideByZero + else return $ Rational $ a / b + doDiv (List [(Complex a), (Complex b)]) = if b == 0 + then throwError $ DivideByZero + else return $ Complex $ a / b + +numBoolBinopEq :: [LispVal] -> ThrowsError LispVal +numBoolBinopEq params = do + foldl1M (\a b -> doOp =<< (numCast [a, b])) params + where doOp (List [(Number a), (Number b)]) = return $ Bool $ a == b + doOp (List [(Float a), (Float b)]) = return $ Bool $ a == b + doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a == b + doOp (List [(Complex a), (Complex b)]) = return $ Bool $ a == b + +numBoolBinopGt :: [LispVal] -> ThrowsError LispVal +numBoolBinopGt params = do + foldl1M (\a b -> doOp =<< (numCast [a, b])) params + where doOp (List [(Number a), (Number b)]) = return $ Bool $ a > b + doOp (List [(Float a), (Float b)]) = return $ Bool $ a > b + doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a > b + +numBoolBinopGte :: [LispVal] -> ThrowsError LispVal +numBoolBinopGte params = do + foldl1M (\a b -> doOp =<< (numCast [a, b])) params + where doOp (List [(Number a), (Number b)]) = return $ Bool $ a >= b + doOp (List [(Float a), (Float b)]) = return $ Bool $ a >= b + doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a >= b + +numBoolBinopLt :: [LispVal] -> ThrowsError LispVal +numBoolBinopLt params = do + foldl1M (\a b -> doOp =<< (numCast [a, b])) params + where doOp (List [(Number a), (Number b)]) = return $ Bool $ a < b + doOp (List [(Float a), (Float b)]) = return $ Bool $ a < b + doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a < b + +numBoolBinopLte :: [LispVal] -> ThrowsError LispVal +numBoolBinopLte params = do + foldl1M (\a b -> doOp =<< (numCast [a, b])) params + where doOp (List [(Number a), (Number b)]) = return $ Bool $ a <= b + doOp (List [(Float a), (Float b)]) = return $ Bool $ a <= b + doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a <= b + +numCast :: [LispVal] -> ThrowsError LispVal +numCast [a@(Number _), b@(Number _)] = return $ List [a, b] +numCast [a@(Float _), b@(Float _)] = return $ List [a, b] +numCast [a@(Rational _), b@(Rational _)] = return $ List [a, b] +numCast [a@(Complex _), b@(Complex _)] = return $ List [a, b] +numCast [(Number a), b@(Float _)] = return $ List [Float $ fromInteger a, b] +numCast [(Number a), b@(Rational _)] = return $ List [Rational $ fromInteger a, b] +numCast [(Number a), b@(Complex _)] = return $ List [Complex $ fromInteger a, b] +numCast [a@(Float _), (Number b)] = return $ List [a, Float $ fromInteger b] +numCast [a@(Float _), (Rational b)] = return $ List [a, Float $ fromRational b] +numCast [(Float a), b@(Complex _)] = return $ List [Complex $ a :+ 0, b] +numCast [a@(Rational _), (Number b)] = return $ List [a, Rational $ fromInteger b] +numCast [(Rational a), b@(Float _)] = return $ List [Float $ fromRational a, b] +numCast [(Rational a), b@(Complex _)] = return $ List [Complex $ (fromInteger $ numerator a) / (fromInteger $ denominator a), b] +numCast [a@(Complex _), (Number b)] = return $ List [a, Complex $ fromInteger b] +numCast [a@(Complex _), (Float b)] = return $ List [a, Complex $ b :+ 0] +numCast [a@(Complex _), (Rational b)] = return $ List [a, Complex $ (fromInteger $ numerator b) / (fromInteger $ denominator b)] +numCast [a, b] = case a of + Number _ -> doThrowError b + Float _ -> doThrowError b + Rational _ -> doThrowError b + Complex _ -> doThrowError b + otherwise -> doThrowError a + where doThrowError a = throwError $ TypeMismatch "number" a + + +numRound, numFloor, numCeiling, numTruncate :: [LispVal] -> ThrowsError LispVal +numRound [n@(Number _)] = return n +numRound [(Rational n)] = return $ Number $ round n +numRound [(Float n)] = return $ Float $ fromInteger $ round n +-- TODO: complex (?) +numRound [x] = throwError $ TypeMismatch "number" x +numRound badArgList = throwError $ NumArgs 1 badArgList + +-- TODO: +numFloor [n@(Number _)] = return n +numFloor [(Rational n)] = return $ Number $ floor n +numFloor [(Float n)] = return $ Float $ fromInteger $ floor n +-- TODO: complex (?) +numFloor [x] = throwError $ TypeMismatch "number" x +numFloor badArgList = throwError $ NumArgs 1 badArgList + +numCeiling [n@(Number _)] = return n +numCeiling [(Rational n)] = return $ Number $ ceiling n +numCeiling [(Float n)] = return $ Float $ fromInteger $ ceiling n +-- TODO: complex (?) +numCeiling [x] = throwError $ TypeMismatch "number" x +numCeiling badArgList = throwError $ NumArgs 1 badArgList + +numTruncate [n@(Number _)] = return n +numTruncate [(Rational n)] = return $ Number $ truncate n +numTruncate [(Float n)] = return $ Float $ fromInteger $ truncate n +-- TODO: complex (?) +numTruncate [x] = throwError $ TypeMismatch "number" x +numTruncate badArgList = throwError $ NumArgs 1 badArgList + + +numSin :: [LispVal] -> ThrowsError LispVal +numSin [(Number n)] = return $ Float $ sin $ fromInteger n +numSin [(Float n)] = return $ Float $ sin n +numSin [(Rational n)] = return $ Float $ sin $ fromRational n +numSin [(Complex n)] = return $ Complex $ sin n +numSin [x] = throwError $ TypeMismatch "number" x +numSin badArgList = throwError $ NumArgs 1 badArgList + +numCos :: [LispVal] -> ThrowsError LispVal +numCos [(Number n)] = return $ Float $ cos $ fromInteger n +numCos [(Float n)] = return $ Float $ cos n +numCos [(Rational n)] = return $ Float $ cos $ fromRational n +numCos [(Complex n)] = return $ Complex $ cos n +numCos [x] = throwError $ TypeMismatch "number" x +numCos badArgList = throwError $ NumArgs 1 badArgList + +numTan :: [LispVal] -> ThrowsError LispVal +numTan [(Number n)] = return $ Float $ tan $ fromInteger n +numTan [(Float n)] = return $ Float $ tan n +numTan [(Rational n)] = return $ Float $ tan $ fromRational n +numTan [(Complex n)] = return $ Complex $ tan n +numTan [x] = throwError $ TypeMismatch "number" x +numTan badArgList = throwError $ NumArgs 1 badArgList + +numAsin :: [LispVal] -> ThrowsError LispVal +numAsin [(Number n)] = return $ Float $ asin $ fromInteger n +numAsin [(Float n)] = return $ Float $ asin n +numAsin [(Rational n)] = return $ Float $ asin $ fromRational n +numAsin [(Complex n)] = return $ Complex $ asin n +numAsin [x] = throwError $ TypeMismatch "number" x +numAsin badArgList = throwError $ NumArgs 1 badArgList + +numAcos :: [LispVal] -> ThrowsError LispVal +numAcos [(Number n)] = return $ Float $ acos $ fromInteger n +numAcos [(Float n)] = return $ Float $ acos n +numAcos [(Rational n)] = return $ Float $ acos $ fromRational n +numAcos [(Complex n)] = return $ Complex $ acos n +numAcos [x] = throwError $ TypeMismatch "number" x +numAcos badArgList = throwError $ NumArgs 1 badArgList + +-- TODO: support for (atan y x) - see spec +numAtan :: [LispVal] -> ThrowsError LispVal +numAtan [(Number n)] = return $ Float $ atan $ fromInteger n +numAtan [(Float n)] = return $ Float $ atan n +numAtan [(Rational n)] = return $ Float $ atan $ fromRational n +numAtan [(Complex n)] = return $ Complex $ atan n +numAtan [x] = throwError $ TypeMismatch "number" x +numAtan badArgList = throwError $ NumArgs 1 badArgList + +numSqrt, numExpt :: [LispVal] -> ThrowsError LispVal +numSqrt [(Number n)] = if n >= 0 then return $ Float $ sqrt $ fromInteger n + else return $ Complex $ sqrt ((fromInteger n) :+ 0) +numSqrt [(Float n)] = if n >= 0 then return $ Float $ sqrt n + else return $ Complex $ sqrt (n :+ 0) +numSqrt [(Rational n)] = numSqrt [Float $ fromRational n] +numSqrt [(Complex n)] = return $ Complex $ sqrt n +numSqrt [x] = throwError $ TypeMismatch "number" x +numSqrt badArgList = throwError $ NumArgs 1 badArgList + +numExpt [(Number n), (Number p)] = return $ Float $ (fromInteger n) ^ p +numExpt [(Rational n), (Number p)] = return $ Float $ (fromRational n) ^ p +numExpt [(Float n), (Number p)] = return $ Float $ n ^ p +numExpt [(Complex n), (Number p)] = return $ Complex $ n ^ p +numExpt [x, y] = throwError $ TypeMismatch "integer" y +numExpt badArgList = throwError $ NumArgs 2 badArgList + +{-numExpt params = do + foldl1M (\a b -> doExpt =<< (numCast [a, b])) params + where doExpt (List [(Number a), (Number b)]) = return $ Float $ (fromInteger a) ^ (fromInteger b) +-- doExpt (List [(Rational a), (Rational b)]) = return $ Float $ fromRational $ a ^ b + doExpt (List [(Float a), (Float b)]) = return $ Float $ a ^ b +-- doExpt (List [(Complex a), (Complex b)]) = return $ Complex $ a ^ b-} + +numExp :: [LispVal] -> ThrowsError LispVal +numExp [(Number n)] = return $ Float $ exp $ fromInteger n +numExp [(Float n)] = return $ Float $ exp n +numExp [(Rational n)] = return $ Float $ exp $ fromRational n +numExp [(Complex n)] = return $ Complex $ exp n +numExp [x] = throwError $ TypeMismatch "number" x +numExp badArgList = throwError $ NumArgs 1 badArgList + +numLog :: [LispVal] -> ThrowsError LispVal +numLog [(Number n)] = return $ Float $ log $ fromInteger n +numLog [(Float n)] = return $ Float $ log n +numLog [(Rational n)] = return $ Float $ log $ fromRational n +numLog [(Complex n)] = return $ Complex $ log n +numLog [x] = throwError $ TypeMismatch "number" x +numLog badArgList = throwError $ NumArgs 1 badArgList + + +-- Complex number functions +numMakeRectangular, numMakePolar, numRealPart, numImagPart, numMagnitude, numAngle :: [LispVal] -> ThrowsError LispVal +numMakeRectangular [(Float x), (Float y)] = return $ Complex $ x :+ y +-- TODO: other members of the numeric tower (?) +numMakeRectangular [x, y] = throwError $ TypeMismatch "real real" $ List [x, y] +numMakeRectangular badArgList = throwError $ NumArgs 2 badArgList + +numMakePolar [(Float x), (Float y)] = return $ Complex $ mkPolar x y +-- TODO: other members of the numeric tower (?) +numMakePolar [x, y] = throwError $ TypeMismatch "real real" $ List [x, y] +numMakePolar badArgList = throwError $ NumArgs 2 badArgList + +numAngle [(Complex c)] = return $ Float $ phase c -- TODO: correct?? need to check this +numAngle [x] = throwError $ TypeMismatch "number" x +numAngle badArgList = throwError $ NumArgs 1 badArgList + +numMagnitude [(Complex c)] = return $ Float $ magnitude c +numMagnitude [x] = throwError $ TypeMismatch "number" x +numMagnitude badArgList = throwError $ NumArgs 1 badArgList + +numRealPart [(Complex c)] = return $ Float $ realPart c +numRealPart [x] = throwError $ TypeMismatch "number" x +numRealPart badArgList = throwError $ NumArgs 1 badArgList + +numImagPart [(Complex c)] = return $ Float $ imagPart c +numImagPart [x] = throwError $ TypeMismatch "number" x +numImagPart badArgList = throwError $ NumArgs 1 badArgList + + +numNumerator, numDenominator:: [LispVal] -> ThrowsError LispVal +numNumerator [(Rational r)] = return $ Number $ numerator r +-- TODO: real? +numNumerator [x] = throwError $ TypeMismatch "rational number" x +numNumerator badArgList = throwError $ NumArgs 1 badArgList + +numDenominator [(Rational r)] = return $ Number $ denominator r +-- TODO: real? +numDenominator [x] = throwError $ TypeMismatch "rational number" x +numDenominator badArgList = throwError $ NumArgs 1 badArgList + +numExact2Inexact, numInexact2Exact :: [LispVal] -> ThrowsError LispVal +numExact2Inexact [(Number n)] = return $ Float $ fromInteger n +numExact2Inexact [(Rational n)] = return $ Float $ fromRational n +numExact2Inexact [n@(Float _)] = return n +-- TODO: numExact2Inexact [(Complex n)] = return ?? + +numInexact2Exact [n@(Number _)] = return n +numInexact2Exact [n@(Rational _)] = return n +numInexact2Exact [(Float n)] = return $ Number $ round n +-- TODO: numInexact2Exact [(Complex n)] = return ?? + +-- TODO: remember to support both forms: +-- procedure: (number->string z) +-- procedure: (number->string z radix) +num2String :: [LispVal] -> ThrowsError LispVal +num2String [(Number n)] = return $ String $ show n +num2String [(Number n), (Number radix)] = do + case radix of +-- TODO: boolean 2 -> return $ String $ printf "%x" n + 8 -> return $ String $ printf "%o" n + 10 -> return $ String $ printf "%d" n + 16 -> return $ String $ printf "%x" n + otherwise -> throwError $ BadSpecialForm "Invalid radix value" $ Number radix +num2String [n@(Rational _)] = return $ String $ show n +num2String [(Float n)] = return $ String $ show n +num2String [n@(Complex _)] = return $ String $ show n +num2String [x] = throwError $ TypeMismatch "number" x +num2String badArgList = throwError $ NumArgs 1 badArgList + +-- TODO: relocated string->number logic here (???), +-- and extend to support all of the tower... + +isNumber, isComplex, isReal, isRational, isInteger :: [LispVal] -> ThrowsError LispVal +isNumber ([Number n]) = return $ Bool True +isNumber ([Float f]) = return $ Bool True +isNumber ([Complex _]) = return $ Bool True +isNumber ([Rational _]) = return $ Bool True +isNumber _ = return $ Bool False + +isComplex ([Complex _]) = return $ Bool True +isComplex ([Number _]) = return $ Bool True +isComplex ([Rational _]) = return $ Bool True +isComplex ([Float _]) = return $ Bool True +isComplex _ = return $ Bool False + +isReal ([Number _]) = return $ Bool True +isReal ([Rational _]) = return $ Bool True +isReal ([Float _]) = return $ Bool True +isReal ([Complex c]) = return $ Bool $ (imagPart c) == 0 +isReal _ = return $ Bool False + +isRational ([Number _]) = return $ Bool True +isRational ([Rational _]) = return $ Bool True +-- TODO: true of float if it can be represented exactly??? +isRational _ = return $ Bool False + +isInteger ([Number _]) = return $ Bool True +-- TODO: true of real/rational types if they round to an integer +isInteger _ = return $ Bool False + +--- end Numeric operations section --- + + +unpackNum :: LispVal -> ThrowsError Integer +unpackNum (Number n) = return n +unpackNum notNum = throwError $ TypeMismatch "number" notNum diff --git a/hs-src/Scheme/Parser.hs b/hs-src/Scheme/Parser.hs new file mode 100644 --- /dev/null +++ b/hs-src/Scheme/Parser.hs @@ -0,0 +1,243 @@ +{- + - husk scheme + - Parser + - + - This file contains the code for parsing scheme + - + - @author Justin Ethier + - + - -} +module Scheme.Parser where +import Scheme.Types +import Control.Monad.Error +import Char +import Complex +import Data.Array +import Numeric +import Ratio +import Text.ParserCombinators.Parsec hiding (spaces) + +symbol :: Parser Char +symbol = oneOf "!$%&|*+-/:<=>?@^_~" -- TODO: I removed #, make sure this is OK w/spec, and test cases + +spaces :: Parser () +spaces = skipMany1 space + +parseAtom :: Parser LispVal +parseAtom = do + first <- letter <|> symbol <|> (oneOf ".") + rest <- many (letter <|> digit <|> symbol <|> (oneOf ".")) + let atom = first:rest + if atom == "." + then pzero -- Do not match this form + else return $ Atom atom + +parseBool :: Parser LispVal +parseBool = do string "#" + x <- oneOf "tf" + return $ case x of + 't' -> Bool True + 'f' -> Bool False + +parseChar :: Parser LispVal +parseChar = do + try (string "#\\") + c <- anyChar + r <- many(letter) + let chr = c:r + return $ case chr of + "space" -> Char ' ' + "newline" -> Char '\n' + _ -> Char c {- TODO: err if invalid char -} + +parseOctalNumber :: Parser LispVal +parseOctalNumber = do + try (string "#o") + sign <- many (oneOf "-") + num <- many1(oneOf "01234567") + case (length sign) of + 0 -> return $ Number $ fst $ Numeric.readOct num !! 0 + 1 -> return $ Number $ toInteger $ (*) (-1) $ fst $ Numeric.readOct num !! 0 + _ -> pzero + +parseBinaryNumber :: Parser LispVal +parseBinaryNumber = do + try (string "#b") + sign <- many (oneOf "-") + num <- many1(oneOf "01") + case (length sign) of + 0 -> return $ Number $ fst $ Numeric.readInt 2 (`elem` "01") Char.digitToInt num !! 0 + 1 -> return $ Number $ toInteger $ (*) (-1) $ fst $ Numeric.readInt 2 (`elem` "01") Char.digitToInt num !! 0 + _ -> pzero + +parseHexNumber :: Parser LispVal +parseHexNumber = do + try (string "#x") + sign <- many (oneOf "-") + num <- many1(digit <|> oneOf "abcdefABCDEF") + case (length sign) of + 0 -> return $ Number $ fst $ Numeric.readHex num !! 0 + 1 -> return $ Number $ toInteger $ (*) (-1) $ fst $ Numeric.readHex num !! 0 + _ -> pzero + +-- |Parser for Integer, base 10 +parseDecimalNumber :: Parser LispVal +parseDecimalNumber = do + try (many(string "#d")) + sign <- many (oneOf "-") + num <- many1 (digit) + if (length sign) > 1 + then pzero + else return $ (Number . read) $ sign ++ num + +parseNumber :: Parser LispVal +parseNumber = parseDecimalNumber <|> + parseHexNumber <|> + parseBinaryNumber <|> + parseOctalNumber + "Unable to parse number" + +{- Parser for floating points + - + - TODO: parse numbers in format #e1e10 + - TODO: bug - + - huski> (string->number "3.42323+2i") + - 3.42323 + - -} +parseRealNumber :: Parser LispVal +parseRealNumber = do + sign <- many (oneOf "-") + num <- many1(digit) + char '.' + frac <- many1(digit) + let dec = num ++ "." ++ frac + case (length sign) of + 0 -> return $ Float $ fst $ Numeric.readFloat dec !! 0 + 1 -> return $ Float $ (*) (-1.0) $ fst $ Numeric.readFloat dec !! 0 + _ -> pzero + +parseRationalNumber :: Parser LispVal +parseRationalNumber = do + numerator <- parseDecimalNumber + case numerator of + Number n -> do + char '/' + sign <- many (oneOf "-") + num <- many1 (digit) + if (length sign) > 1 + then pzero + else return $ Rational $ n % (read $ sign ++ num) + otherwise -> pzero + +parseComplexNumber :: Parser LispVal +parseComplexNumber = do + lispreal <- (try(parseRealNumber) <|> parseDecimalNumber) + let real = case lispreal of + Number n -> fromInteger n + Float f -> f + char '+' + lispimag <- (try(parseRealNumber) <|> parseDecimalNumber) + let imag = case lispimag of + Number n -> fromInteger n + Float f -> f + char 'i' + return $ Complex $ real :+ imag + +parseEscapedChar = do + char '\\' + c <- anyChar + return $ case c of + 'n' -> '\n' + 't' -> '\t' + 'r' -> '\r' + _ -> c + +parseString :: Parser LispVal +parseString = do + char '"' + x <- many (parseEscapedChar <|> noneOf("\"")) + char '"' + return $ String x + +parseVector :: Parser LispVal +parseVector = do + vals <- sepBy parseExpr spaces + return $ Vector (listArray (0, (length vals - 1)) vals) +-- TODO: old code from Data.Vector implementation: return $ Vector $ Data.Vector.fromList vals + +parseList :: Parser LispVal +parseList = liftM List $ sepBy parseExpr spaces + +parseDottedList :: Parser LispVal +parseDottedList = do + head <- endBy parseExpr spaces + tail <- char '.' >> spaces >> parseExpr + return $ DottedList head tail + +parseQuoted :: Parser LispVal +parseQuoted = do + char '\'' + x <- parseExpr + return $ List [Atom "quote", x] + +parseQuasiQuoted :: Parser LispVal +parseQuasiQuoted = do + char '`' + x <- parseExpr + return $ List [Atom "quasiquote", x] + +parseUnquoted :: Parser LispVal +parseUnquoted = do + try (char ',') + x <- parseExpr + return $ List [Atom "unquote", x] + +parseUnquoteSpliced :: Parser LispVal +parseUnquoteSpliced = do + try (string ",@") + x <- parseExpr + return $ List [Atom "unquote-splicing", x] + + +-- Comment parser +-- TODO: this is a hack, it should really not return anything... +parseComment :: Parser LispVal +parseComment = do + char ';' + many (noneOf ("\n")) + return $ Nil "" + + +parseExpr :: Parser LispVal +parseExpr = + try(parseRationalNumber) + <|> try(parseComplexNumber) + <|> parseComment + <|> try(parseRealNumber) + <|> try(parseNumber) + <|> parseChar + <|> parseUnquoteSpliced + <|> do try (string "#(") + x <- parseVector + char ')' + return x + <|> try (parseAtom) + <|> parseString + <|> parseBool + <|> parseQuoted + <|> parseQuasiQuoted + <|> parseUnquoted + <|> do char '(' + x <- try parseList <|> parseDottedList + char ')' + return x + "Expression" + +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 spaces) + diff --git a/hs-src/Scheme/Types.hs b/hs-src/Scheme/Types.hs new file mode 100644 --- /dev/null +++ b/hs-src/Scheme/Types.hs @@ -0,0 +1,205 @@ +{- + - husk scheme + - Types + - + - This file contains top-level data type definitions and their associated functions, including: + - - Scheme data types + - - Scheme errors + - + - @author Justin Ethier + - + - -} +module Scheme.Types where +import Complex +import Control.Monad +import Control.Monad.Error +import Data.Array +import Data.IORef +import qualified Data.Map +import IO hiding (try) +import Ratio +import System.Environment +import Text.ParserCombinators.Parsec hiding (spaces) + +{- Environment management -} + +-- |A Scheme environment containing variable bindings of form @(namespaceName, variableName), variableValue@ +type Env = IORef [((String, String), IORef LispVal)] -- lookup via: (namespace, variable) + +-- |An empty environment +nullEnv :: IO Env +nullEnv = newIORef [] + +-- Internal namespace for macros +macroNamespace = "m" + +-- Internal namespace for variables +varNamespace = "v" + +-- |Types of errors that may occur when evaluating Scheme code +data LispError = NumArgs Integer [LispVal] -- ^Invalid number of function arguments + | TypeMismatch String LispVal -- ^Type error + | Parser ParseError -- ^Parsing error + | BadSpecialForm String LispVal -- ^Invalid special (built-in) form + | NotFunction String String + | UnboundVar String String + | DivideByZero -- ^Divide by Zero error + | Default String -- ^Default error + +-- |Create a textual description for a 'LispError' +showError :: LispError -> String +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 (BadSpecialForm message form) = message ++ ": " ++ show form +showError (NotFunction message func) = message ++ ": " ++ show func +showError (UnboundVar message varname) = message ++ ": " ++ varname +showError (DivideByZero) = "Division by zero" + +instance Show LispError where show = showError +instance Error LispError where + noMsg = Default "An error has occurred" + strMsg = Default + +type ThrowsError = Either LispError + +trapError action = catchError action (return . show) + +extractValue :: ThrowsError a -> a +extractValue (Right val) = val + +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 + + +-- |Scheme data types +data LispVal = Atom String + -- ^Symbol + | List [LispVal] + -- ^List + | DottedList [LispVal] LispVal + -- ^Pair + | Vector (Array Int LispVal) + -- ^Vector + | HashTable (Data.Map.Map LispVal LispVal) + -- ^Hash table. Map is technically the wrong structure to use for a hash table since it is based on a binary tree and hence operations tend to be O(log n) instead of O(1). However, according to Map has good performance characteristics compared to the alternatives. So it stays for the moment... + | Number Integer + -- ^Integer + | Float Double -- TODO: rename this "Real" instead of "Float"... + -- ^Floating point + | Complex (Complex Double) + -- ^Complex number + | Rational Rational + -- ^Rational number + | String String + -- ^String + | Char Char + -- ^Character + | Bool Bool + -- ^Boolean + | PrimitiveFunc ([LispVal] -> ThrowsError LispVal) + -- ^ + | Func {params :: [String], + vararg :: (Maybe String), + body :: [LispVal], + closure :: Env, + partialEval :: Bool + } -- TODO: continuation member? + -- ^Function + | IOFunc ([LispVal] -> IOThrowsError LispVal) + -- ^ + | Port Handle + -- ^I/O port + | Nil String + -- ^Internal use only; do not use this type directly. + +instance Ord LispVal where + compare (Bool a) (Bool b) = compare a b + compare (Number a) (Number b) = compare a b + compare (Rational a) (Rational b) = compare a b + compare (Float a) (Float b) = compare a b + compare (String a) (String b) = compare a b + compare (Char a) (Char b) = compare a b + compare (Atom a) (Atom b) = compare a b +-- compare (DottedList xs x) (DottedList xs x) = compare a b +-- Vector +-- HashTable +-- List +-- Func +-- Others? + compare a b = compare (show a) (show b) -- Hack (??): sort alphabetically when types differ or have no handlers + +-- |Compare two 'LispVal' instances +eqv :: [LispVal] -> ThrowsError LispVal +eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2 +eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2 +eqv [(Complex arg1), (Complex arg2)] = return $ Bool $ arg1 == arg2 +eqv [(Rational arg1), (Rational arg2)] = return $ Bool $ arg1 == arg2 +eqv [(Float arg1), (Float arg2)] = return $ Bool $ arg1 == arg2 +eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2 +eqv [(Char arg1), (Char arg2)] = return $ Bool $ arg1 == arg2 +eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2 +eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]] +eqv [(Vector arg1), (Vector arg2)] = eqv [List $ (elems arg1), List $ (elems arg2)] +eqv [(HashTable arg1), (HashTable arg2)] = + eqv [List $ (map (\(x, y) -> List [x, y]) $ Data.Map.toAscList arg1), + List $ (map (\(x, y) -> List [x, y]) $ Data.Map.toAscList arg2)] +eqv [l1@(List arg1), l2@(List arg2)] = eqvList eqv [l1, l2] +eqv [_, _] = return $ Bool False +eqv badArgList = throwError $ NumArgs 2 badArgList + +eqvList :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal +eqvList eqvFunc [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) && + (all eqvPair $ zip arg1 arg2) + where eqvPair (x1, x2) = case eqvFunc [x1, x2] of + Left err -> False + Right (Bool val) -> val + +eqVal :: LispVal -> LispVal -> Bool +eqVal a b = do + let result = eqv [a, b] + case result of + Left err -> False + Right (Bool val) -> val + +instance Eq LispVal where + x == y = eqVal x y + +-- |Create a textual description of a 'LispVal' +showVal :: LispVal -> String +showVal (Nil _) = "" +showVal (String contents) = "\"" ++ contents ++ "\"" +showVal (Char chr) = [chr] +showVal (Atom name) = name +showVal (Number contents) = show contents +showVal (Complex contents) = (show $ realPart contents) ++ "+" ++ (show $ imagPart contents) ++ "i" +showVal (Rational contents) = (show (numerator contents)) ++ "/" ++ (show (denominator contents)) +showVal (Float contents) = show contents +showVal (Bool True) = "#t" +showVal (Bool False) = "#f" +showVal (Vector contents) = "#(" ++ (unwordsList $ Data.Array.elems contents) ++ ")" +showVal (HashTable _) = "" +showVal (List contents) = "(" ++ unwordsList contents ++ ")" +showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")" +showVal (PrimitiveFunc _) = "" +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 _) = "" + +unwordsList :: [LispVal] -> String +unwordsList = unwords . map showVal + +-- |Allow conversion of lispval instances to strings +instance Show LispVal where show = showVal diff --git a/hs-src/Scheme/Variables.hs b/hs-src/Scheme/Variables.hs new file mode 100644 --- /dev/null +++ b/hs-src/Scheme/Variables.hs @@ -0,0 +1,76 @@ +{- + - husk scheme + - Variables + - + - This file contains code for working with Scheme variables + - + - @author Justin Ethier + - + - -} +module Scheme.Variables where +import Scheme.Types +import Control.Monad +import Control.Monad.Error +import Data.IORef + +-- |Determine if a variable is bound in the default namespace +isBound :: Env -> String -> IO Bool +isBound envRef var = isNamespacedBound envRef varNamespace var + +-- |Determine if a variable is bound in a given namespace +isNamespacedBound :: Env -> String -> String -> IO Bool +isNamespacedBound envRef namespace var = readIORef envRef >>= return . maybe False (const True) . lookup (namespace, var) + +-- |Retrieve the value of a variable defined in the default namespace +getVar :: Env -> String -> IOThrowsError LispVal +getVar envRef var = getNamespacedVar envRef varNamespace var + +-- |Retrieve the value of a variable defined in a given namespace +getNamespacedVar :: Env -> String -> String -> IOThrowsError LispVal +getNamespacedVar envRef + namespace + var = do env <- liftIO $ readIORef envRef + maybe (throwError $ UnboundVar "Getting an unbound variable" var) + (liftIO . readIORef) + (lookup (namespace, var) env) + +-- |Set a variable in the default namespace +setVar, defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal +setVar envRef var value = setNamespacedVar envRef varNamespace var value + +-- ^Bind a variable in the default namespace +defineVar envRef var value = defineNamespacedVar envRef varNamespace var value + +-- |Set a variable in a given namespace +setNamespacedVar :: Env -> String -> String -> LispVal -> IOThrowsError LispVal +setNamespacedVar envRef + namespace + var value = do env <- liftIO $ readIORef envRef + maybe (throwError $ UnboundVar "Setting an unbound variable: " var) + (liftIO . (flip writeIORef value)) + (lookup (namespace, var) env) + return value + +-- |Bind a variable in the given namespace +defineNamespacedVar :: Env -> String -> String -> LispVal -> IOThrowsError LispVal +defineNamespacedVar envRef + namespace + var value = do + alreadyDefined <- liftIO $ isNamespacedBound envRef namespace var + if alreadyDefined + then setNamespacedVar envRef namespace var value >> return value + else liftIO $ do + valueRef <- newIORef value + env <- readIORef envRef + writeIORef envRef (((namespace, var), valueRef) : env) + return value + +-- |Bind a series of values to the given environment. +-- +-- Input is of form: @(namespaceName, variableName), variableValue@ +bindVars :: Env -> [((String, 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) + diff --git a/hs-src/shell.hs b/hs-src/shell.hs new file mode 100644 --- /dev/null +++ b/hs-src/shell.hs @@ -0,0 +1,84 @@ +{- + - husk scheme interpreter + - + - A lightweight dialect of R5RS scheme. + - + - This file implements a REPL "shell" to host the interpreter, and also + - allows execution of stand-alone files containing Scheme code. + - + - @author Justin Ethier + - + - -} + +module Main where +import Paths_husk_scheme +import Scheme.Core -- Scheme Interpreter +import Scheme.Types -- Scheme data types +import Scheme.Variables -- Scheme variable operations +import Control.Monad.Error +import IO hiding (try) +import System.Environment +import System.Console.Haskeline + +main :: IO () +main = do args <- getArgs + if null args then do showBanner + runRepl + else runOne $ args + +-- REPL Section +flushStr :: String -> IO () +flushStr str = putStr str >> hFlush stdout + +runOne :: [String] -> IO () +runOne args = do + env <-primitiveBindings >>= flip bindVars [((varNamespace, "args"), List $ map String $ drop 1 args)] + (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)])) + >>= hPutStrLn stderr -- echo this or not?? + + -- Call into (main) if it exists... + alreadyDefined <- liftIO $ isBound env "main" + let argv = List $ map String $ args + if alreadyDefined + then (runIOThrows $ liftM show $ eval env (List [Atom "main", List [Atom "quote", argv]])) >>= hPutStrLn stderr + else (runIOThrows $ liftM show $ eval env $ Nil "") >>= hPutStrLn stderr + +showBanner :: IO () +showBanner = do + putStrLn " __ __ __ __ ______ __ __ " + putStrLn "/\\ \\_\\ \\ /\\ \\/\\ \\ /\\ ___\\ /\\ \\/ / Scheme Interpreter " + putStrLn "\\ \\ __ \\ \\ \\ \\_\\ \\ \\ \\___ \\ \\ \\ _\\\"-. Version 1.0" + putStrLn " \\ \\_\\ \\_\\ \\ \\_____\\ \\/\\_____\\ \\ \\_\\ \\_\\ (c) 2010 Justin Ethier " + putStrLn " \\/_/\\/_/ \\/_____/ \\/_____/ \\/_/\\/_/ github.com/justinethier/husk-scheme " + putStrLn "" + +runRepl :: IO () +runRepl = do + stdlib <- getDataFileName "stdlib.scm" + env <- primitiveBindings + evalString env $ "(load \"" ++ stdlib ++ "\")" -- Load standard library into the REPL + runInputT defaultSettings (loop env) + where + loop :: Env -> InputT IO () + loop env = do + minput <- getInputLine "huski> " + case minput of + Nothing -> return () + Just "quit" -> return () + Just "" -> loop env -- FUTURE: integrate with strip to ignore inputs of just whitespace + Just input -> do result <- liftIO (evalString env input) + if (length result) > 0 + then do outputStrLn result + loop env + else loop env +-- End REPL Section + +-- Begin Util section, of generic functions + +-- Remove leading/trailing white space from a string; based on corresponding Python function +-- Code taken from: http://gimbo.org.uk/blog/2007/04/20/splitting-a-string-in-haskell/ +strip :: String -> String +strip s = dropWhile ws $ reverse $ dropWhile ws $ reverse s + where ws = (`elem` [' ', '\n', '\t', '\r']) + +-- End Util diff --git a/husk-scheme.cabal b/husk-scheme.cabal new file mode 100644 --- /dev/null +++ b/husk-scheme.cabal @@ -0,0 +1,51 @@ +Name: husk-scheme +Version: 1.0 +Synopsis: R5RS Scheme interpreter program and library. +Description: Husk is a dialect of Scheme written in Haskell that implements + a subset of the R5RS standard. Husk is not intended to be a + highly optimized version of Scheme. Rather, the goal of the + project is to provide a tight integration between Haskell and + Scheme while at the same time providing a great opportunity for + deeper understanding of both languages. In addition, by closely + following the R5RS standard the intent is to develop a Scheme + that is as compatible as possible with other R5RS Schemes. + + This package includes a stand-alone executable as well as + a library that allows an interpreter to be embedded within an + existing Haskell application. + +License: MIT +License-file: LICENSE +Author: Justin Ethier +Maintainer: Justin Ethier +Homepage: https://github.com/justinethier/husk-scheme +Cabal-Version: >= 1.4 +Build-Type: Simple +Category: Compilers/Interpreters, Language + +Extra-Source-Files: README.markdown + LICENSE +Data-Files: stdlib.scm + +Library + Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec + Extensions: ExistentialQuantification + Hs-Source-Dirs: hs-src + Exposed-Modules: Scheme.Core + Scheme.Types + Scheme.Variables + Other-Modules: Scheme.Macro + Scheme.Numerical + Scheme.Parser + +Executable huski + Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec + Extensions: ExistentialQuantification + Main-is: shell.hs + Hs-Source-Dirs: hs-src + Other-Modules: Scheme.Core + Scheme.Types + Scheme.Variables + Scheme.Macro + Scheme.Numerical + Scheme.Parser diff --git a/stdlib.scm b/stdlib.scm new file mode 100644 --- /dev/null +++ b/stdlib.scm @@ -0,0 +1,241 @@ +; +; husk-scheme +; http://github.com/justinethier/husk-scheme +; +; Written by Justin Ethier +; +; Standard library of scheme functions +; +(define (caar pair) (car (car pair))) +(define (cadr pair) (car (cdr pair))) +(define (cdar pair) (cdr (car pair))) +(define (cddr pair) (cdr (cdr pair))) +(define (caaar pair) (car (car (car pair)))) +(define (caadr pair) (car (car (cdr pair)))) +(define (cadar pair) (car (cdr (car pair)))) +(define (caddr pair) (car (cdr (cdr pair)))) +(define (cdaar pair) (cdr (car (car pair)))) +(define (cdadr pair) (cdr (car (cdr pair)))) +(define (cddar pair) (cdr (cdr (car pair)))) +(define (cdddr pair) (cdr (cdr (cdr pair)))) +(define (caaaar pair) (car (car (car (car pair))))) +(define (caaadr pair) (car (car (car (cdr pair))))) +(define (caadar pair) (car (car (cdr (car pair))))) +(define (caaddr pair) (car (car (cdr (cdr pair))))) +(define (cadaar pair) (car (cdr (car (car pair))))) +(define (cadadr pair) (car (cdr (car (cdr pair))))) +(define (caddar pair) (car (cdr (cdr (car pair))))) +(define (cadddr pair) (car (cdr (cdr (cdr pair))))) +(define (cdaaar pair) (cdr (car (car (car pair))))) +(define (cdaadr pair) (cdr (car (car (cdr pair))))) +(define (cdadar pair) (cdr (car (cdr (car pair))))) +(define (cdaddr pair) (cdr (car (cdr (cdr pair))))) +(define (cddaar pair) (cdr (cdr (car (car pair))))) +(define (cddadr pair) (cdr (cdr (car (cdr pair))))) +(define (cdddar pair) (cdr (cdr (cdr (car pair))))) +(define (cddddr pair) (cdr (cdr (cdr (cdr pair))))) + + +(define (not x) (if x #f #t)) + +(define (list . objs) objs) +(define (id obj) obj) + +(define (flip func) (lambda (arg1 arg2) (func arg2 arg1))) + +(define (curry func arg1) (lambda (arg) (apply func (cons arg1 (list arg))))) +(define (compose f g) (lambda (arg) (f (apply g arg)))) + +(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 . lst) (fold + 0 lst)) +(define (product . lst) (fold * 1 lst)) +(define (and . lst) (fold && #t lst)) +(define (or . lst) (fold || #f lst)) + +(define (abs num) + (if (negative? num) + (* num -1) + num)) + +(define (max first . rest) (fold (lambda (old new) (if (> old new) old new)) first rest)) +(define (min first . rest) (fold (lambda (old new) (if (< old new) old new)) first rest)) + +(define zero? (curry = 0)) +(define positive? (curry < 0)) +(define negative? (curry > 0)) +(define (odd? num) (= (modulo num 2) 1)) +(define (even? num) (= (modulo num 2) 0)) + +(define (length lst) (fold (lambda (x y) (+ x 1)) 0 lst)) +(define (reverse lst) (fold (flip cons) '() lst)) + +(define (my-mem-helper obj lst cmp-proc) + (cond + ((null? lst) #f) + ((cmp-proc obj (car lst)) lst) + (else (my-mem-helper obj (cdr lst) cmp-proc)))) +(define (memq obj lst) (my-mem-helper obj lst eq?)) +(define (memv obj lst) (my-mem-helper obj lst eqv?)) +(define (member obj lst) (my-mem-helper obj lst equal?)) + +(define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc))) +(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 on map and for-each - Support variable number of args, per spec: +; http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_sec_6.4 +;(define (for-each func . lsts) ) + +(define (for-each func lst) + (if (eq? 1 (length lst)) + (func (car lst)) + (begin (func (car lst)) + (for-each func (cdr lst))))) + +(define (map func lst) (foldr (lambda (x y) (cons (func x) y)) '() lst)) +(define (filter pred lst) (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst)) + + +(define (list-tail lst k) + (if (zero? k) + lst + (list-tail (cdr lst) (- k 1)))) +(define (list-ref lst k) (car (list-tail lst k))) + +(define (append inlist alist) (foldr (lambda (ap in) (cons ap in)) alist inlist)) + +; Let forms +(define-syntax letrec + (syntax-rules () + ((_ ((x v) ...) e1 e2 ...) + (let () + (define x v) ... + (let () e1 e2 ...))))) +; TODO: should be able to use dotted lists, as below: +;(define-syntax letrec +; (syntax-rules () +; ((_ ((x v) ...) . body) +; (let () +; (define x v) ... +; (let () . body))))) + +; let and named let (using the Y-combinator): +(define-syntax let + (syntax-rules () + ((_ ((x v) ...) e1 e2 ...) + ((lambda (x ...) e1 e2 ...) v ...)) + ((_ name ((x v) ...) e1 e2 ...) + (let* + ((f (lambda (name) + (lambda (x ...) e1 e2 ...))) + (ff ((lambda (proc) (f (lambda (x ...) ((proc proc) + x ...)))) + (lambda (proc) (f (lambda (x ...) ((proc proc) + x ...))))))) + (ff v ...))))) + +; +; It would be nice to change first rule back to: +; ((_ () body) body) +; +(define-syntax let* + (syntax-rules () + ((_ () body) ((lambda () body))) + ((_ ((var val) + (vars vals) ...) + body) + (let ((var val)) + (let* ((vars vals) ...) + body))))) + +; Iteration - do +; TODO: New version of do that makes step optional on a per-variable basis +; This works great in csi but the macro does not match in huski. +; It looks like our macro logic needs to have some more work done :) +(define-syntax do + (syntax-rules () + ((_ ((var init . step) ...) + (test expr ...) + command ...) + (let loop ((var init) ...) + (if test + (begin expr ...) + (begin (begin command ...) + (loop + (if (null? (cdr (list var . step))) + (car (list var . step)) + (cadr (list var . step))) ...))))))) +; TODO: above (if) block has many transformation problems that need to be worked through + +; Old version that always requires step be specified, which violates spec +;(define-syntax old-do +; (syntax-rules () +; ((_ ((var init step ...) ...) +; (test expr ...) +; command ...) +; (let loop ((var init) ...) +; (if test +; (begin expr ...) +; (begin (begin command ...) +; (loop step ...))))))) + + +; Delayed evaluation functions +(define force + (lambda (object) + (object))) + +(define-syntax delay + (syntax-rules () + ((delay expression) + (make-promise (lambda () expression))))) + +(define make-promise + (lambda (proc) + (let ((result-ready? #f) + (result #f)) + (lambda () + (if result-ready? + result + (let ((x (proc))) + (if result-ready? + result + (begin (set! result x) + (set! result-ready? #t) + result)))))))) + +(define hash-table-walk + (lambda (ht proc) + (map + (lambda (kv) (proc (car kv) (cdr kv))) + (hash-table->alist ht)))) + +; TODO: hash-table-fold + +; End delayed evaluation section + +; TODO: from numeric section - +; gcd +;(define (gcd . nums) nums) +; lcm +; rationalize +; +