husk-scheme (empty) → 1.0
raw patch · 12 files changed
+2631/−0 lines, 12 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, haskeline, haskell98, mtl, parsec
Files
- LICENSE +19/−0
- README.markdown +98/−0
- Setup.hs +3/−0
- hs-src/Scheme/Core.hs +794/−0
- hs-src/Scheme/Macro.hs +449/−0
- hs-src/Scheme/Numerical.hs +368/−0
- hs-src/Scheme/Parser.hs +243/−0
- hs-src/Scheme/Types.hs +205/−0
- hs-src/Scheme/Variables.hs +76/−0
- hs-src/shell.hs +84/−0
- husk-scheme.cabal +51/−0
- stdlib.scm +241/−0
+ LICENSE view
@@ -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.
+ README.markdown view
@@ -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: <http://practical-scheme.net/wiliki/schemexref.cgi?R5RS> and <http://en.wikipedia.org/wiki/Scheme_(programming_language)>+- 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).+
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ hs-src/Scheme/Core.hs view
@@ -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>=?", strBoolBinop (>=)),+ ("string-ci=?", stringCIEquals),+ ("string-ci<?", stringCIBoolBinop (<)),+ ("string-ci>?", stringCIBoolBinop (>)),+ ("string-ci<=?", stringCIBoolBinop (<=)),+ ("string-ci>=?", stringCIBoolBinop (>=)),++ ("car", car),+ ("cdr", cdr),+ ("cons", cons),+ ("eq?", eqv),+ ("eqv?", eqv),+ ("equal?", equal),++ ("pair?", isDottedList),+ ("procedure?", isProcedure),+{-+ 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+-}
+ hs-src/Scheme/Macro.hs view
@@ -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
+ hs-src/Scheme/Numerical.hs view
@@ -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
+ hs-src/Scheme/Parser.hs view
@@ -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)+
+ hs-src/Scheme/Types.hs view
@@ -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 <http://www.opensubscriber.com/message/haskell-cafe@haskell.org/10779624.html> 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 _) = "<hash-table>"+showVal (List contents) = "(" ++ unwordsList contents ++ ")"+showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"+showVal (PrimitiveFunc _) = "<primitive>"+showVal (Func {params = args, vararg = varargs, body = body, closure = env}) = + "(lambda (" ++ unwords (map show args) +++ (case varargs of+ Nothing -> ""+ Just arg -> " . " ++ arg) ++ ") ...)"+showVal (Port _) = "<IO port>"+showVal (IOFunc _) = "<IO primitive>"++unwordsList :: [LispVal] -> String+unwordsList = unwords . map showVal++-- |Allow conversion of lispval instances to strings+instance Show LispVal where show = showVal
+ hs-src/Scheme/Variables.hs view
@@ -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)+
+ hs-src/shell.hs view
@@ -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
+ husk-scheme.cabal view
@@ -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 <github.com/justinethier>+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
+ stdlib.scm view
@@ -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+; +