husk-scheme 2.4 → 3.0
raw patch · 10 files changed
+922/−760 lines, 10 filesdep +ghcdep +ghc-paths
Dependencies added: ghc, ghc-paths
Files
- README.markdown +27/−4
- hs-src/Language/Scheme/Core.hs +337/−280
- hs-src/Language/Scheme/Macro.hs +194/−188
- hs-src/Language/Scheme/Numerical.hs +83/−77
- hs-src/Language/Scheme/Parser.hs +85/−80
- hs-src/Language/Scheme/Plugins/CPUTime.hs +39/−0
- hs-src/Language/Scheme/Types.hs +97/−89
- hs-src/Language/Scheme/Variables.hs +21/−13
- hs-src/shell.hs +32/−24
- husk-scheme.cabal +7/−5
README.markdown view
@@ -2,7 +2,7 @@ husk is a dialect of Scheme written in Haskell that implements a subset of the [R<sup>5</sup>RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R<sup>5</sup>RS features are provided including continuations, hygienic macros, and a full numeric tower. -husk provides many features and is intended as a good choice for certain applications, however it is not 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 an opportunity for deeper understanding of both languages. In addition, by closely following the R<sup>5</sup>RS standard, the intent is to develop a Scheme that is as compatible as possible with other R<sup>5</sup>RS Schemes.+husk provides many features and is intended as a good choice for non-performance critical applications, as it is not a highly optimized Scheme. Rather, the goal of the project is to provide a tight integration between Haskell and Scheme while at the same time providing an opportunity for deeper understanding of both languages. In addition, by closely following the R<sup>5</sup>RS standard, the intent is to develop a Scheme that is as compatible as possible with other R<sup>5</sup>RS 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. @@ -60,18 +60,41 @@ 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. +Foreign Function Interface+--------------------------++A foreign function interface (FFI) is provided to allow husk to call into arbitrary Haskell code. The interface is currently available via the `load-ffi` function:++ (load-ffi "Language.Scheme.Plugins.CPUTime" "precision" "cpu-time:precision")++`load-ffi` accepts the following string arguments:++- Name of a Haskell module to dynamically load+- Haskell function to load from that module+- Name to use for the function after it is loaded into husk++From the previous example, once `cpu-time:precision` is loaded, it may be called directly from husk just like a regular Scheme function:++ (cpu-time:precision)++Any Haskell function loaded via the FFI must be of the following type:++ [LispVal] -> IOThrowsError LispVal++See husk's `Language.Scheme.Plugins.CPUTime` module for an example of how to use the husk FFI.+ 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.+- [GHC](http://www.haskell.org/ghc/) - [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`+- [Haskeline](http://trac.haskell.org/haskeline) - which may be installed using cabal: `cabal install haskeline` The `scm-unit-tests` directory contains unit tests for much of the scheme code. All tests may be executed via `make test` command. -The examples directory contains example scheme programs.+The `examples` directory contains example scheme programs. Patches are welcome; please send via pull request on github.
hs-src/Language/Scheme/Core.hs view
@@ -1,26 +1,26 @@-{-- - husk scheme interpreter- -- - A lightweight dialect of R5RS scheme.- - This file contains Core functionality, primarily Scheme expression evaluation.- -- - @author Justin Ethier- -- - -}+{- |+Module : Language.Scheme.Core+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution) -module Language.Scheme.Core +Maintainer : github.com/justinethier+Stability : experimental+Portability : non-portable (GHC API)++husk scheme interpreter++A lightweight dialect of R5RS scheme.++This module contains Core functionality, primarily Scheme expression evaluation.+-}++module Language.Scheme.Core ( eval , evalLisp , evalString , evalAndPrint- , primitiveBindings -- FUTURE: this is a bad idea.- -- There should be an interface to inject custom functions written in Haskell.- --- -- Probably any new func should be added as an EvalFunc or IOFunc- --- -- If so, need to ensure that apply handles them properly, and that continuations are- -- captured properly.+ , primitiveBindings ) where import Language.Scheme.Macro import Language.Scheme.Numerical@@ -31,15 +31,18 @@ import Char import Data.Array import qualified Data.Map-import Maybe-import List import IO hiding (try) import System.Directory (doesFileExist) import System.IO.Error---import Debug.Trace -{-| Evaluate a string containing Scheme code.+import qualified GHC+import qualified GHC.Paths (libdir)+import qualified DynFlags+import qualified Unsafe.Coerce (unsafeCoerce)+-- import Debug.Trace +{- |Evaluate a string containing Scheme code.+ For example: @@@ -51,7 +54,7 @@ evalString env "(+ x x x (* 3 9))" "30" -evalString env "(* 3 9)" +evalString env "(* 3 9)" "27" @ -}@@ -62,9 +65,8 @@ evalAndPrint :: Env -> String -> IO () evalAndPrint env expr = evalString env expr >>= putStrLn --- |Evaluate lisp code that has already been loaded into haskell------ FUTURE: code example for this, via ghci and/or a custom Haskell program.+{- |Evaluate lisp code that has already been loaded into haskell+FUTURE: code example for this, via ghci and/or a custom Haskell program. -} evalLisp :: Env -> LispVal -> IOThrowsError LispVal evalLisp env lisp = macroEval env lisp >>= (eval env (makeNullContinuation env)) @@ -77,32 +79,34 @@ - -} continueEval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal --- Passing a higher-order function as the continuation; just evaluate it. This is --- done to enable an 'eval' function to be broken up into multiple sub-functions,--- so that any of the sub-functions can be passed around as a continuation.------ Carry extra args from the current continuation into the next, to support (call-with-values)+{- Passing a higher-order function as the continuation; just evaluate it. This is+ - done to enable an 'eval' function to be broken up into multiple sub-functions,+ - so that any of the sub-functions can be passed around as a continuation. + -+ - Carry extra args from the current continuation into the next, to support (call-with-values)+ -} continueEval _- (Continuation cEnv (Just (HaskellBody func funcArgs)) - (Just (Continuation cce cnc ccc _ cdynwind)) + (Continuation cEnv (Just (HaskellBody func funcArgs))+ (Just (Continuation cce cnc ccc _ cdynwind)) xargs _) -- rather sloppy, should refactor code so this is not necessary val = func cEnv (Continuation cce cnc ccc xargs cdynwind) val funcArgs---- No higher order function, so:------ If there is Scheme code to evaluate in the function body, we continue to evaluate it.------ Otherwise, if all code in the function has been executed, we 'unwind' to an outer--- continuation (if there is one), or we just return the result. Yes technically with--- CPS you are supposed to keep calling into functions and never return, but in this case--- when the computation is complete, you have to return something.+{-+ - No higher order function, so:+ -+ - If there is Scheme code to evaluate in the function body, we continue to evaluate it.+ -+ - Otherwise, if all code in the function has been executed, we 'unwind' to an outer+ - continuation (if there is one), or we just return the result. Yes technically with+ - CPS you are supposed to keep calling into functions and never return, but in this case+ - when the computation is complete, you have to return something. + -} continueEval _ (Continuation cEnv (Just (SchemeBody cBody)) (Just cCont) extraArgs dynWind) val = do case cBody of [] -> do case cCont of- Continuation nEnv ncCont nnCont _ nDynWind -> + Continuation nEnv ncCont nnCont _ nDynWind -> -- Pass extra args along if last expression of a function, to support (call-with-values)- continueEval nEnv (Continuation nEnv ncCont nnCont extraArgs nDynWind) val + continueEval nEnv (Continuation nEnv ncCont nnCont extraArgs nDynWind) val _ -> return (val) [lv] -> eval cEnv (Continuation cEnv (Just (SchemeBody [])) (Just cCont) Nothing dynWind) (lv) (lv : lvs) -> eval cEnv (Continuation cEnv (Just (SchemeBody lvs)) (Just cCont) Nothing dynWind) (lv)@@ -114,63 +118,63 @@ continueEval _ (Continuation _ Nothing Nothing _ _) val = return val continueEval _ _ _ = throwError $ Default "Internal error in continueEval" --- |Core eval function--- Evaluate a scheme expression. --- NOTE: This function does not include macro support and should not be called directly. Instead, use 'evalLisp'+{- |Core eval function+Evaluate a scheme expression.+NOTE: This function does not include macro support and should not be called directly. Instead, use 'evalLisp' -} -- ----- Implementation Notes:+-- Implementation Notes: ----- Internally, this function is written in continuation passing style (CPS) to allow the Scheme language--- itself to support first-class continuations. That is, at any point in the evaluation, call/cc may--- be used to capture the current continuation. Thus this code must call into the next continuation point, eg:+-- Internally, this function is written in continuation passing style (CPS) to allow the Scheme language+-- itself to support first-class continuations. That is, at any point in the evaluation, call/cc may+-- be used to capture the current continuation. Thus this code must call into the next continuation point, eg: ----- eval ... (makeCPS ...)+-- eval ... (makeCPS ...) ----- Instead of calling eval directly from within the same function, eg:+-- Instead of calling eval directly from within the same function, eg: ----- eval ...--- eval ...+-- eval ...+-- eval ... ----- This can make the code harder to follow, however some coding conventions have been established to make the--- code easier to follow. Whenever a single function has been broken into multiple ones for the purpose of CPS,--- those additional functions are defined locally using 'where', and each has been given a 'cps' prefix.+-- This can make the code harder to follow, however some coding conventions have been established to make the+-- code easier to follow. Whenever a single function has been broken into multiple ones for the purpose of CPS,+-- those additional functions are defined locally using 'where', and each has been given a 'cps' prefix. -- eval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal-eval env cont val@(Nil _) = continueEval env cont val-eval env cont val@(String _) = continueEval env cont val-eval env cont val@(Char _) = continueEval env cont val-eval env cont val@(Complex _) = continueEval env cont val-eval env cont val@(Float _) = continueEval env cont val-eval env cont val@(Rational _) = continueEval env cont val-eval env cont val@(Number _) = continueEval env cont val-eval env cont val@(Bool _) = continueEval env cont val+eval env cont val@(Nil _) = continueEval env cont val+eval env cont val@(String _) = continueEval env cont val+eval env cont val@(Char _) = continueEval env cont val+eval env cont val@(Complex _) = continueEval env cont val+eval env cont val@(Float _) = continueEval env cont val+eval env cont val@(Rational _) = continueEval env cont val+eval env cont val@(Number _) = continueEval env cont val+eval env cont val@(Bool _) = continueEval env cont val eval env cont val@(HashTable _) = continueEval env cont val-eval env cont val@(Vector _) = continueEval env cont val-eval env cont (Atom a) = continueEval env cont =<< getVar env a+eval env cont val@(Vector _) = continueEval env cont val+eval env cont (Atom a) = continueEval env cont =<< getVar env a -- Quote an expression by simply passing along the value-eval env cont (List [Atom "quote", val]) = continueEval env cont val+eval env cont (List [Atom "quote", val]) = continueEval env cont val --- Unquote an expression; unquoting is different than quoting in that--- it may also be inter-spliced with code that is meant to be evaluated.+{- Unquote an expression; unquoting is different than quoting in that+it may also be inter-spliced with code that is meant to be evaluated. -} -- ----- FUTURE: Issue #8 - https://github.com/justinethier/husk-scheme/issues/#issue/8--- need to take nesting of ` into account, as per spec:--- --- * Quasiquote forms may be nested. --- * Substitutions are made only for unquoted components appearing at the --- same nesting level as the outermost backquote. --- * The nesting level increases by one inside each successive quasiquotation, --- and decreases by one inside each unquotation.+{- FUTURE: Issue #8 - https://github.com/justinethier/husk-scheme/issues/#issue/8+need to take nesting of ` into account, as per spec: -} ----- So the upshoot is that a new nesting level var needs to be threaded through,--- and used to determine whether or not to evaluate an unquote.+{- - Quasiquote forms may be nested.+- Substitutions are made only for unquoted components appearing at the+same nesting level as the outermost backquote.+- The nesting level increases by one inside each successive quasiquotation,+and decreases by one inside each unquotation. -} --+{- So the upshoot is that a new nesting level var needs to be threaded through,+and used to determine whether or not to evaluate an unquote. -}+-- eval envi cont (List [Atom "quasiquote", value]) = cpsUnquote envi cont value Nothing where cpsUnquote :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsUnquote e c val _ = do + cpsUnquote e c val _ = do case val of List [Atom "unquote", vval] -> eval e c vval List (_ : _) -> doCpsUnquoteList e c val@@ -181,27 +185,27 @@ if len > 0 then doCpsUnquoteList e (makeCPS e c cpsUnquoteVector) $ List $ elems vec else continueEval e c $ Vector $ listArray (0, -1) []- _ -> eval e c (List [Atom "quote", val]) -- Behave like quote if there is nothing to "unquote"...+ _ -> eval e c (List [Atom "quote", val]) -- Behave like quote if there is nothing to "unquote"... - -- Unquote a pair- -- This must be started by unquoting the "left" hand side of the pair,- -- then pass a continuation to this function to unquote the right-hand side (RHS).- -- This function does the RHS and then calls into a continuation to finish the pair.+ {- Unquote a pair+ This must be started by unquoting the "left" hand side of the pair,+ then pass a continuation to this function to unquote the right-hand side (RHS).+ This function does the RHS and then calls into a continuation to finish the pair. -} cpsUnquotePair :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsUnquotePair e c (List rxs) (Just [rx]) = do cpsUnquote e (makeCPSWArgs e c cpsUnquotePairFinish $ [List rxs]) rx Nothing cpsUnquotePair _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquotePair"- + -- Finish unquoting a pair by combining both of the unquoted left/right hand sides. cpsUnquotePairFinish :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsUnquotePairFinish e c rx (Just [List rxs]) = do case rx of List [] -> continueEval e c $ List rxs- List rxlst -> continueEval e c $ List $ rxs ++ rxlst + List rxlst -> continueEval e c $ List $ rxs ++ rxlst DottedList rxlst rxlast -> continueEval e c $ DottedList (rxs ++ rxlst) rxlast _ -> continueEval e c $ DottedList rxs rx cpsUnquotePairFinish _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquotePairFinish"- + -- Unquote a vector cpsUnquoteVector :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsUnquoteVector e c (List vList) _ = continueEval e c (Vector $ listArray (0, (length vList - 1)) vList)@@ -209,7 +213,7 @@ -- Front-end to cpsUnquoteList, to encapsulate default values in the call doCpsUnquoteList :: Env -> LispVal -> LispVal -> IOThrowsError LispVal- doCpsUnquoteList e c (List (x:xs)) = cpsUnquoteList e c x $ Just ([List xs, List []])+ doCpsUnquoteList e c (List (x : xs)) = cpsUnquoteList e c x $ Just ([List xs, List []]) doCpsUnquoteList _ _ _ = throwError $ InternalError "Unexpected parameters to doCpsUnquoteList" -- Unquote a list@@ -218,7 +222,7 @@ case val of List [Atom "unquote-splicing", vvar] -> do eval e (makeCPSWArgs e c cpsUnquoteSplicing $ [List unEvaled, List acc]) vvar- _ -> cpsUnquote e (makeCPSWArgs e c cpsUnquoteFld $ [List unEvaled, List acc]) val Nothing + _ -> cpsUnquote e (makeCPSWArgs e c cpsUnquoteFld $ [List unEvaled, List acc]) val Nothing cpsUnquoteList _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteList" -- Evaluate an expression instead of quoting it@@ -241,22 +245,22 @@ eval env cont (List [Atom "if", predic, conseq, alt]) = do eval env (makeCPS env cont cps) (predic)- where cps :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cps e c result _ = + where cps :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal+ cps e c result _ = case (result) of Bool False -> eval e c alt _ -> eval e c conseq -eval env cont (List [Atom "if", predic, conseq]) = +eval env cont (List [Atom "if", predic, conseq]) = eval env (makeCPS env cont cpsResult) predic where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsResult e c result _ = + cpsResult e c result _ = case result of Bool True -> eval e c conseq _ -> continueEval e c $ Nil "" -- Unspecified return value per R5RS -- FUTURE: convert cond to a derived form (scheme macro)-eval env cont (List (Atom "cond" : clauses)) = +eval env cont (List (Atom "cond" : clauses)) = if length clauses == 0 then throwError $ BadSpecialForm "No matching clause" $ String "cond" else do@@ -264,12 +268,12 @@ List [test, Atom "=>", expr] -> eval env (makeCPSWArgs env cont cpsAlt [test]) expr List (Atom "else" : _) -> eval env (makeCPSWArgs env cont cpsResult clauses) $ Bool True List (cond : _) -> eval env (makeCPSWArgs env cont cpsResult clauses) cond- badType -> throwError $ TypeMismatch "clause" badType + badType -> throwError $ TypeMismatch "clause" badType where- -- If a condition is true, evaluate that condition's expressions.- -- Otherwise just pick up at the next condition...+ {- If a condition is true, evaluate that condition's expressions.+ Otherwise just pick up at the next condition... -} cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsResult e cnt result (Just (c:cs)) = + cpsResult e cnt result (Just (c : cs)) = case result of Bool True -> evalCond e cnt c _ -> eval env cnt $ List $ (Atom "cond" : cs)@@ -291,26 +295,26 @@ cpsAltEvaled _ c test (Just [expr]) = apply c expr [test] cpsAltEvaled _ _ _ _ = throwError $ Default "Unexpected error in cond" -eval env cont (List (Atom "begin" : funcs)) = +eval env cont (List (Atom "begin" : funcs)) = if length funcs == 0 then eval env cont $ Nil "" else if length funcs == 1 then eval env cont (head funcs) else eval env (makeCPSWArgs env cont cpsRest $ tail funcs) (head funcs) where cpsRest :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsRest e c _ args = + cpsRest e c _ args = case args of Just fArgs -> eval e c $ List (Atom "begin" : fArgs) Nothing -> throwError $ Default "Unexpected error in begin" -eval env cont (List [Atom "set!", Atom var, form]) = do +eval env cont (List [Atom "set!", Atom var, form]) = do eval env (makeCPS env cont cpsResult) form where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsResult e c result _ = setVar e var result >>= continueEval e c-eval _ _ (List [Atom "set!", nonvar, _]) = throwError $ TypeMismatch "variable" nonvar +eval _ _ (List [Atom "set!", nonvar, _]) = throwError $ TypeMismatch "variable" nonvar eval _ _ (List (Atom "set!" : args)) = throwError $ NumArgs 2 args -eval env cont (List [Atom "define", Atom var, form]) = do +eval env cont (List [Atom "define", Atom var, form]) = do eval env (makeCPS env cont cpsResult) form where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsResult e c result _ = defineVar e var result >>= continueEval e c@@ -335,60 +339,60 @@ result <- makeVarargs varargs env [] fbody continueEval env cont result -eval env cont (List [Atom "string-set!", Atom var, i, character]) = do +eval env cont (List [Atom "string-set!", Atom var, i, character]) = do eval env (makeCPS env cont cpsStr) i- where + where cpsStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsStr e c idx _ = eval e (makeCPSWArgs e c cpsSubStr $ [idx]) =<< getVar e var cpsSubStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsSubStr e c str (Just [idx]) = - substr(str, character, idx) >>= setVar e var >>= continueEval e c- cpsSubStr _ _ _ _ = throwError $ InternalError "Invalid argument to cpsSubStr" + cpsSubStr e c str (Just [idx]) =+ substr (str, character, idx) >>= setVar e var >>= continueEval e c+ cpsSubStr _ _ _ _ = throwError $ InternalError "Invalid argument to cpsSubStr" substr (String str, Char char, Number ii) = do- return $ String $ (take (fromInteger ii) . drop 0) str ++ + return $ String $ (take (fromInteger ii) . drop 0) str ++ [char] ++ (take (length str) . drop (fromInteger ii + 1)) str substr (String _, Char _, n) = throwError $ TypeMismatch "number" n substr (String _, c, _) = throwError $ TypeMismatch "character" c substr (s, _, _) = throwError $ TypeMismatch "string" s-eval _ _ (List [Atom "string-set!" , nonvar , _ , _ ]) = throwError $ TypeMismatch "variable" nonvar +eval _ _ (List [Atom "string-set!" , nonvar , _ , _ ]) = throwError $ TypeMismatch "variable" nonvar eval _ _ (List (Atom "string-set!" : args)) = throwError $ NumArgs 3 args eval env cont (List [Atom "set-car!", Atom var, argObj]) = do continueEval env (makeCPS env cont cpsObj) =<< getVar env var- where + where cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsObj _ _ obj@(List []) _ = throwError $ TypeMismatch "pair" obj- cpsObj e c obj@(List (_:_)) _ = eval e (makeCPSWArgs e c cpsSet $ [obj]) argObj+ cpsObj e c obj@(List (_ : _)) _ = eval e (makeCPSWArgs e c cpsSet $ [obj]) argObj cpsObj e c obj@(DottedList _ _) _ = eval e (makeCPSWArgs e c cpsSet $ [obj]) argObj- cpsObj _ _ obj _ = throwError $ TypeMismatch "pair" obj + cpsObj _ _ obj _ = throwError $ TypeMismatch "pair" obj cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsSet e c obj (Just [List (_ : ls)]) = setVar e var (List (obj : ls)) >>= continueEval e c -- Wrong constructor? Should it be DottedList? cpsSet e c obj (Just [DottedList (_ : ls) l]) = setVar e var (DottedList (obj : ls) l) >>= continueEval e c- cpsSet _ _ _ _ = throwError $ InternalError "Unexpected argument to cpsSet" -eval _ _ (List [Atom "set-car!" , nonvar , _ ]) = throwError $ TypeMismatch "variable" nonvar + cpsSet _ _ _ _ = throwError $ InternalError "Unexpected argument to cpsSet"+eval _ _ (List [Atom "set-car!" , nonvar , _ ]) = throwError $ TypeMismatch "variable" nonvar eval _ _ (List (Atom "set-car!" : args)) = throwError $ NumArgs 2 args eval env cont (List [Atom "set-cdr!", Atom var, argObj]) = do continueEval env (makeCPS env cont cpsObj) =<< getVar env var- where + where cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsObj _ _ pair@(List []) _ = throwError $ TypeMismatch "pair" pair - cpsObj e c pair@(List (_:_)) _ = eval e (makeCPSWArgs e c cpsSet $ [pair]) argObj+ cpsObj _ _ pair@(List []) _ = throwError $ TypeMismatch "pair" pair+ cpsObj e c pair@(List (_ : _)) _ = eval e (makeCPSWArgs e c cpsSet $ [pair]) argObj cpsObj e c pair@(DottedList _ _) _ = eval e (makeCPSWArgs e c cpsSet $ [pair]) argObj- cpsObj _ _ pair _ = throwError $ TypeMismatch "pair" pair + cpsObj _ _ pair _ = throwError $ TypeMismatch "pair" pair cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsSet e c obj (Just [List (l : _)]) = setVar e var (DottedList [l] obj) >>= continueEval e c cpsSet e c obj (Just [DottedList (l : _) _]) = setVar e var (DottedList [l] obj) >>= continueEval e c- cpsSet _ _ _ _ = throwError $ InternalError "Unexpected argument to cpsSet" -eval _ _ (List [Atom "set-cdr!" , nonvar , _ ]) = throwError $ TypeMismatch "variable" nonvar + cpsSet _ _ _ _ = throwError $ InternalError "Unexpected argument to cpsSet"+eval _ _ (List [Atom "set-cdr!" , nonvar , _ ]) = throwError $ TypeMismatch "variable" nonvar eval _ _ (List (Atom "set-cdr!" : args)) = throwError $ NumArgs 2 args -eval env cont (List [Atom "vector-set!", Atom var, i, object]) = do +eval env cont (List [Atom "vector-set!", Atom var, i, object]) = do eval env (makeCPS env cont cpsObj) i where cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal@@ -399,83 +403,83 @@ cpsVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsVec" cpsUpdateVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsUpdateVec e c vec (Just [idx, obj]) = + cpsUpdateVec e c vec (Just [idx, obj]) = updateVector vec idx obj >>= setVar e var >>= continueEval e c cpsUpdateVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsUpdateVec" updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal- updateVector (Vector vec) (Number idx) obj = return $ Vector $ vec//[(fromInteger idx, obj)]+ updateVector (Vector vec) (Number idx) obj = return $ Vector $ vec // [(fromInteger idx, obj)] updateVector v _ _ = throwError $ TypeMismatch "vector" v-eval _ _ (List [Atom "vector-set!" , nonvar , _ , _]) = throwError $ TypeMismatch "variable" nonvar +eval _ _ (List [Atom "vector-set!" , nonvar , _ , _]) = throwError $ TypeMismatch "variable" nonvar eval _ _ (List (Atom "vector-set!" : args)) = throwError $ NumArgs 3 args -eval env cont (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do +eval env cont (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do eval env (makeCPS env cont cpsValue) rkey where cpsValue :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsValue e c key _ = eval e (makeCPSWArgs e c cpsH $ [key]) rvalue- + cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsH e c value (Just [key]) = eval e (makeCPSWArgs e c cpsEvalH $ [key, value]) =<< getVar e var- cpsH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsH" + cpsH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsH" cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsEvalH e c h (Just [key, value]) = do + cpsEvalH e c h (Just [key, value]) = do case h of HashTable ht -> do setVar env var (HashTable $ Data.Map.insert key value ht) >>= eval e c other -> throwError $ TypeMismatch "hash-table" other cpsEvalH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsEvalH"-eval _ _ (List [Atom "hash-table-set!" , nonvar , _ , _]) = throwError $ TypeMismatch "variable" nonvar +eval _ _ (List [Atom "hash-table-set!" , nonvar , _ , _]) = throwError $ TypeMismatch "variable" nonvar eval _ _ (List (Atom "hash-table-set!" : args)) = throwError $ NumArgs 3 args -eval env cont (List [Atom "hash-table-delete!", Atom var, rkey]) = do +eval env cont (List [Atom "hash-table-delete!", Atom var, rkey]) = do eval env (makeCPS env cont cpsH) rkey where cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsH e c key _ = eval e (makeCPSWArgs e c cpsEvalH $ [key]) =<< getVar e var cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsEvalH e c h (Just [key]) = do + cpsEvalH e c h (Just [key]) = do case h of HashTable ht -> do setVar env var (HashTable $ Data.Map.delete key ht) >>= eval e c other -> throwError $ TypeMismatch "hash-table" other cpsEvalH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsEvalH"-eval _ _ (List [Atom "hash-table-delete!" , nonvar , _]) = throwError $ TypeMismatch "variable" nonvar +eval _ _ (List [Atom "hash-table-delete!" , nonvar , _]) = throwError $ TypeMismatch "variable" nonvar eval _ _ (List (Atom "hash-table-delete!" : args)) = throwError $ NumArgs 2 args --- Call a function by evaluating its arguments and then --- executing it via 'apply'.+{- Call a function by evaluating its arguments and then+executing it via 'apply'. -} eval env cont (List (function : functionArgs)) = do eval env (makeCPSWArgs env cont cpsPrepArgs $ functionArgs) function where cpsPrepArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsPrepArgs e c func (Just args) = --- case (trace ("prep eval of args: " ++ show args) args) of+ cpsPrepArgs e c func (Just args) =+-- case (trace ("prep eval of args: " ++ show args) args) of case (args) of [] -> apply c func [] -- No args, immediately apply the function [a] -> eval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List []]) a- (a:as) -> eval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List as]) a+ (a : as) -> eval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List as]) a cpsPrepArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (1)"- -- Store value of previous argument, evaluate the next arg until all are done- -- parg - Previous argument that has now been evaluated- -- state - List containing the following, in order:- -- - Function to apply when args are ready- -- - List of evaluated parameters- -- - List of parameters awaiting evaluation+ {- Store value of previous argument, evaluate the next arg until all are done+ parg - Previous argument that has now been evaluated+ state - List containing the following, in order:+ - Function to apply when args are ready+ - List of evaluated parameters+ - List of parameters awaiting evaluation -} cpsEvalArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsEvalArgs e c evaledArg (Just [func, List argsEvaled, List argsRemaining]) = + cpsEvalArgs e c evaledArg (Just [func, List argsEvaled, List argsRemaining]) = case argsRemaining of [] -> apply c func (argsEvaled ++ [evaledArg]) [a] -> eval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List []]) a- (a:as) -> eval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List as]) a+ (a : as) -> eval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List as]) a cpsEvalArgs _ _ _ (Just _) = throwError $ Default "Unexpected error in function application (1)" cpsEvalArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (2)" eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm -makeFunc :: --forall (m :: * -> *).+makeFunc :: -- forall (m :: * -> *). (Monad m) => Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal makeFunc varargs env fparams fbody = return $ Func (map showVal fparams) varargs fbody env@@ -484,7 +488,7 @@ -> [LispVal] -> m LispVal makeNormalFunc = makeFunc Nothing-makeVarargs :: (Monad m) => LispVal -> Env+makeVarargs :: (Monad m) => LispVal -> Env -> [LispVal] -> [LispVal] -> m LispVal@@ -493,28 +497,28 @@ -- Call into a Scheme function apply :: LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal apply _ cont@(Continuation env ccont ncont _ ndynwind) args = do--- case (trace ("calling into continuation. dynWind = " ++ show ndynwind) ndynwind) of+-- case (trace ("calling into continuation. dynWind = " ++ show ndynwind) ndynwind) of case ndynwind of -- Call into dynWind.before if it exists... Just ([DynamicWinders beforeFunc _]) -> apply (makeCPS env cont cpsApply) beforeFunc []- _ -> doApply env cont+ _ -> doApply env cont where cpsApply :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsApply e c _ _ = doApply e c- doApply e c = - case (toInteger $ length args) of - 0 -> throwError $ NumArgs 1 [] + doApply e c =+ case (toInteger $ length args) of+ 0 -> throwError $ NumArgs 1 [] 1 -> continueEval e c $ head args _ -> -- Pass along additional arguments, so they are available to (call-with-values)- continueEval e (Continuation env ccont ncont (Just $ tail args) ndynwind) $ head args + continueEval e (Continuation env ccont ncont (Just $ tail args) ndynwind) $ head args apply cont (IOFunc func) args = do result <- func args case cont of Continuation cEnv _ _ _ _ -> continueEval cEnv cont result _ -> return result apply cont (EvalFunc func) args = do- -- An EvalFunc extends the evaluator so it needs access to the current continuation;- -- pass it as the first argument.+ {- An EvalFunc extends the evaluator so it needs access to the current continuation;+ pass it as the first argument. -} func (cont : args) apply cont (PrimitiveFunc func) args = do result <- liftThrows $ func args@@ -530,25 +534,25 @@ -- -- Continue evaluation within the body, preserving the outer continuation. --- -- This link was helpful for implementing this, and has a *lot* of other useful information:- -- http://icem-www.folkwang-hochschule.de/~finnendahl/cm_kurse/doc/schintro/schintro_73.html#SEC80+ {- This link was helpful for implementing this, and has a *lot* of other useful information:+ http://icem-www.folkwang-hochschule.de/~finnendahl/cm_kurse/doc/schintro/schintro_73.html#SEC80 -} --- -- What we are doing now is simply not saving a continuation for tail calls. For now this may- -- be good enough, although it may need to be enhanced in the future in order to properly- -- detect all tail calls. + {- What we are doing now is simply not saving a continuation for tail calls. For now this may+ be good enough, although it may need to be enhanced in the future in order to properly+ detect all tail calls. -} -- -- See: http://icem-www.folkwang-hochschule.de/~finnendahl/cm_kurse/doc/schintro/schintro_142.html#SEC294 -- evalBody evBody env = case cont of Continuation _ (Just (SchemeBody cBody)) (Just cCont) _ cDynWind -> if length cBody == 0 then continueWCont env (evBody) cCont cDynWind--- else continueWCont env (evBody) cont (trace ("cDynWind = " ++ show cDynWind) cDynWind) -- Might be a problem, not fully optimizing+-- else continueWCont env (evBody) cont (trace ("cDynWind = " ++ show cDynWind) cDynWind) -- Might be a problem, not fully optimizing else continueWCont env (evBody) cont cDynWind -- Might be a problem, not fully optimizing Continuation _ _ _ _ cDynWind -> continueWCont env (evBody) cont cDynWind- _ -> continueWCont env (evBody) cont Nothing + _ -> continueWCont env (evBody) cont Nothing -- Shortcut for calling continueEval- continueWCont cwcEnv cwcBody cwcCont cwcDynWind = + continueWCont cwcEnv cwcBody cwcCont cwcDynWind = continueEval cwcEnv (Continuation cwcEnv (Just (SchemeBody cwcBody)) (Just cwcCont) Nothing cwcDynWind) $ Nil "" bindVarArgs arg env = case arg of@@ -556,9 +560,9 @@ 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).+{- |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 extendEnv $ map (domakeFunc IOFunc) ioPrimitives ++ map (domakeFunc EvalFunc) evalFunctions@@ -567,8 +571,8 @@ -- Functions that extend the core evaluator, but that can be defined separately. ----- These functions have access to the current environment via the--- current continuation, which is passed as the first LispVal argument.+{- These functions have access to the current environment via the+current continuation, which is passed as the first LispVal argument. -} -- evalFunctions :: [(String, [LispVal] -> IOThrowsError LispVal)] evalFunctions = [@@ -578,43 +582,44 @@ , ("dynamic-wind", evalfuncDynamicWind) , ("eval", evalfuncEval) , ("load", evalfuncLoad)+ , ("load-ffi", evalfuncLoadFFI) -- Non-standard extension ]-evalfuncApply, evalfuncDynamicWind, evalfuncEval, evalfuncLoad, evalfuncCallCC, evalfuncCallWValues :: [LispVal] -> IOThrowsError LispVal+evalfuncApply, evalfuncDynamicWind, evalfuncEval, evalfuncLoad, evalfuncLoadFFI, evalfuncCallCC, evalfuncCallWValues :: [LispVal] -> IOThrowsError LispVal --- A (somewhat) simplified implementation of dynamic-wind------ The implementation must obey these 4 rules:------ 1) The dynamic extent is entered when execution of the body of the called procedure begins.--- 2) The dynamic extent is also entered when execution is not within the dynamic extent and a continuation is invoked that was captured (using call-with-current-continuation) during the dynamic extent.--- 3) It is exited when the called procedure returns.--- 4) It is also exited when execution is within the dynamic extent and a continuation is invoked that was captured while not within the dynamic extent.------ Basically (before) must be called either when thunk is called into, or when a continuation captured --- during (thunk) is called into.--- And (after) must be called either when thunk returns *or* a continuation is called into during (thunk).------ FUTURE:--- A this point dynamic-wind works well enough now to pass all tests, although I am not convinced the implementation--- is 100% correct since a stack is not directly used to hold the winders. I think there must still be edge--- cases that are not handled properly...----evalfuncDynamicWind [cont@(Continuation env _ _ _ _), beforeFunc, thunkFunc, afterFunc] = do +{-+ - A (somewhat) simplified implementation of dynamic-wind+ -+ - The implementation must obey these 4 rules:+ -+ - 1) The dynamic extent is entered when execution of the body of the called procedure begins.+ - 2) The dynamic extent is also entered when execution is not within the dynamic extent and a continuation is invoked that was captured (using call-with-current-continuation) during the dynamic extent.+ - 3) It is exited when the called procedure returns.+ - 4) It is also exited when execution is within the dynamic extent and a continuation is invoked that was captured while not within the dynamic extent.+ -+ - Basically (before) must be called either when thunk is called into, or when a continuation captured+ - during (thunk) is called into.+ - And (after) must be called either when thunk returns *or* a continuation is called into during (thunk).+ - FUTURE:+ - At this point dynamic-wind works well enough now to pass all tests, although I am not convinced the implementation+ - is 100% correct since a stack is not directly used to hold the winders. I think there must still be edge+ - cases that are not handled properly...+ -}+evalfuncDynamicWind [cont@(Continuation env _ _ _ _), beforeFunc, thunkFunc, afterFunc] = do apply (makeCPS env cont cpsThunk) beforeFunc [] where cpsThunk, cpsAfter :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsThunk e (Continuation ce cc cnc ca _ {- FUTURE: cwindrz -} ) _ _ = apply (Continuation e (Just (HaskellBody cpsAfter Nothing)) + cpsThunk e (Continuation ce cc cnc ca _ {- FUTURE: cwindrz -} ) _ _ = apply (Continuation e (Just (HaskellBody cpsAfter Nothing)) (Just (Continuation ce cc cnc ca- Nothing)) - Nothing + Nothing))+ Nothing (Just ([DynamicWinders beforeFunc afterFunc]))) -- FUTURE: append if existing winders thunkFunc []- cpsThunk _ _ _ _ = throwError $ Default "Unexpected error in cpsThunk during (dynamic-wind)" + cpsThunk _ _ _ _ = throwError $ Default "Unexpected error in cpsThunk during (dynamic-wind)" cpsAfter _ c _ _ = apply c afterFunc [] -- FUTURE: remove dynamicWinder from above from the list before calling after evalfuncDynamicWind (_ : args) = throwError $ NumArgs 3 args -- Skip over continuation argument evalfuncDynamicWind _ = throwError $ NumArgs 3 [] -evalfuncCallWValues [cont@(Continuation env _ _ _ _), producer, consumer] = do +evalfuncCallWValues [cont@(Continuation env _ _ _ _), producer, consumer] = do apply (makeCPS env cont cpsEval) producer [] -- Call into prod to get values where cpsEval :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal@@ -630,10 +635,64 @@ evalfuncLoad [cont@(Continuation env _ _ _ _), String filename] = do result <- load filename >>= liftM last . mapM (evaluate env (makeNullContinuation env)) continueEval env cont result- where evaluate env2 cont2 val2 = macroEval env2 val2 >>= eval env2 cont2+ where evaluate env2 cont2 val2 = macroEval env2 val2 >>= eval env2 cont2 evalfuncLoad (_ : args) = throwError $ NumArgs 1 args -- Skip over continuation argument evalfuncLoad _ = throwError $ NumArgs 1 [] +{-+ - |Load a Haskell function into husk using the foreign function inteface (FFI)+ -+ - Based on example code from:+ -+ - http://stackoverflow.com/questions/5521129/importing-a-known-function-from-an-already-compiled-binary-using-ghcs-api-or-hi+ - and+ - http://www.bluishcoder.co.nz/2008/11/dynamic-compilation-and-loading-of.html+ -+ -+ - TODO: pass a list of functions to import. Need to make sure this is done in an efficient way+ - (IE, result as a list that can be processed) + -}+evalfuncLoadFFI [cont@(Continuation env _ _ _ _), String targetSrcFile,+ String moduleName,+ String externalFuncName,+ String internalFuncName] = do+ result <- liftIO $ defaultRunGhc $ do+ dynflags <- GHC.getSessionDynFlags+ _ <- GHC.setSessionDynFlags dynflags+ -- let m = GHC.mkModule (GHC.thisPackage dynflags) (GHC.mkModuleName "Test")++--+{- TODO: migrate duplicate code into helper functions to drive everything+FUTURE: should be able to load multiple functions in one shot (?). -}+--+ target <- GHC.guessTarget targetSrcFile Nothing+ GHC.addTarget target+ r <- GHC.load GHC.LoadAllTargets+ case r of+ GHC.Failed -> error "Compilation failed"+ GHC.Succeeded -> do+ m <- GHC.findModule (GHC.mkModuleName moduleName) Nothing+ GHC.setContext [] [m] -- setContext [] [(m, Nothing)] -- Use setContext [] [m] for GHC<7.+ fetched <- GHC.compileExpr (moduleName ++ "." ++ externalFuncName)+ return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal)+ defineVar env internalFuncName (IOFunc result) >>= continueEval env cont++-- Overload that loads code from a compiled module+evalfuncLoadFFI [cont@(Continuation env _ _ _ _), String moduleName, String externalFuncName, String internalFuncName] = do+ result <- liftIO $ defaultRunGhc $ do+ dynflags <- GHC.getSessionDynFlags+ _ <- GHC.setSessionDynFlags dynflags+ m <- GHC.findModule (GHC.mkModuleName moduleName) Nothing+ GHC.setContext [] [m] -- setContext [] [(m, Nothing)] -- Use setContext [] [m] for GHC<7.+ fetched <- GHC.compileExpr (moduleName ++ "." ++ externalFuncName)+ return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal)+ defineVar env internalFuncName (IOFunc result) >>= continueEval env cont++evalfuncLoadFFI _ = throwError $ NumArgs 3 []++defaultRunGhc :: GHC.Ghc a -> IO a+defaultRunGhc = GHC.defaultErrorHandler DynFlags.defaultDynFlags . GHC.runGhc (Just GHC.Paths.libdir)+ -- Evaluate an expression in the current environment -- -- Assumption is any macro transform is already performed@@ -649,19 +708,19 @@ case func of PrimitiveFunc f -> do result <- liftThrows $ f [cont]- case cont of + case cont of Continuation cEnv _ _ _ _ -> continueEval cEnv cont result _ -> return result Func aparams _ _ _ ->- if (toInteger $ length aparams) == 1 - then apply cont func [cont] - else throwError $ NumArgs (toInteger $ length aparams) [cont] + if (toInteger $ length aparams) == 1+ then apply cont func [cont]+ else throwError $ NumArgs (toInteger $ length aparams) [cont] other -> throwError $ TypeMismatch "procedure" other evalfuncCallCC (_ : args) = throwError $ NumArgs 1 args -- Skip over continuation argument evalfuncCallCC _ = throwError $ NumArgs 1 [] --- I/O primitives--- Primitive functions that execute within the IO monad+{- I/O primitives+Primitive functions that execute within the IO monad -} ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)] ioPrimitives = [("open-input-file", makePort ReadMode), ("open-output-file", makePort WriteMode),@@ -671,14 +730,14 @@ ("output-port?", isOutputPort), -- The following optional procedures are NOT implemented:- -- - -- with-input-from-file- -- with-output-from-file- -- transcript-on- -- transcript-off --- -- Consideration may be given in a future release, but keep in mind- -- the impact to the other I/O functions.+ {- with-input-from-file+ with-output-from-file+ transcript-on+ transcript-off -}+ --+ {- Consideration may be given in a future release, but keep in mind+ the impact to the other I/O functions. -} -- FUTURE: not currently supported: char-ready? @@ -687,9 +746,9 @@ ("read", readProc), ("read-char", readCharProc hGetChar), ("peek-char", readCharProc hLookAhead),- ("write", writeProc (\port obj -> hPrint port obj)),+ ("write", writeProc (\ port obj -> hPrint port obj)), ("write-char", writeCharProc),- ("display", writeProc (\port obj -> case obj of+ ("display", writeProc (\ port obj -> case obj of String str -> hPutStr port str _ -> hPutStr port $ show obj)), ("read-contents", readContents),@@ -705,10 +764,10 @@ closePort _ = return $ Bool False currentInputPort, currentOutputPort :: [LispVal] -> IOThrowsError LispVal--- FUTURE: For now, these are just hardcoded to the standard i/o ports.--- a future implementation that includes with-*put-from-file--- would require a more involved implementation here as well as--- other I/O functions hooking into these instead of std*+{- FUTURE: For now, these are just hardcoded to the standard i/o ports.+a future implementation that includes with-*put-from-file+would require a more involved implementation here as well as+other I/O functions hooking into these instead of std* -} currentInputPort _ = return $ Port stdin currentOutputPort _ = return $ Port stdout @@ -722,30 +781,30 @@ readProc :: [LispVal] -> IOThrowsError LispVal readProc [] = readProc [Port stdin] readProc [Port port] = do- input <- liftIO $ try (liftIO $ hGetLine port)+ input <- liftIO $ try (liftIO $ hGetLine port) case input of Left e -> if isEOFError e then return $ EOF else throwError $ Default "I/O error reading from port" -- FUTURE: ioError e- Right inpStr -> do - liftThrows $ readExpr inpStr + Right inpStr -> do+ liftThrows $ readExpr inpStr readProc args@(_ : _) = throwError $ BadSpecialForm "" $ List args readCharProc :: (Handle -> IO Char) -> [LispVal] -> IOThrowsError LispVal readCharProc func [] = readCharProc func [Port stdin] readCharProc func [Port port] = do liftIO $ hSetBuffering port NoBuffering- input <- liftIO $ try (liftIO $ func port)+ input <- liftIO $ try (liftIO $ func port) liftIO $ hSetBuffering port LineBuffering case input of Left e -> if isEOFError e then return $ EOF else throwError $ Default "I/O error reading from port"- Right inpChr -> do - return $ Char inpChr + Right inpChr -> do+ return $ Char inpChr readCharProc _ args@(_ : _) = throwError $ BadSpecialForm "" $ List args -{-writeProc :: --forall a (m :: * -> *).+{- writeProc :: --forall a (m :: * -> *). (MonadIO m, MonadError LispError m) => (Handle -> LispVal -> IO a) -> [LispVal] -> m LispVal -} writeProc func [obj] = writeProc func [obj, Port stdout]@@ -755,7 +814,7 @@ Left _ -> throwError $ Default "I/O error writing to port" Right _ -> return $ Nil "" writeProc _ other = if length other == 2- then throwError $ TypeMismatch "(value port)" $ List other + then throwError $ TypeMismatch "(value port)" $ List other else throwError $ NumArgs 2 other writeCharProc :: [LispVal] -> IOThrowsError LispVal@@ -766,7 +825,7 @@ Left _ -> throwError $ Default "I/O error writing to port" Right _ -> return $ Nil "" writeCharProc other = if length other == 2- then throwError $ TypeMismatch "(character port)" $ List other + then throwError $ TypeMismatch "(character port)" $ List other else throwError $ NumArgs 2 other readContents :: [LispVal] -> IOThrowsError LispVal@@ -803,24 +862,24 @@ ("numerator", numNumerator), ("denominator", numDenominator), - ("exp", numExp), - ("log", numLog), - ("sin", numSin), - ("cos", numCos), - ("tan", numTan), + ("exp", numExp),+ ("log", numLog),+ ("sin", numSin),+ ("cos", numCos),+ ("tan", numTan), ("asin", numAsin),- ("acos", numAcos), + ("acos", numAcos), ("atan", numAtan), ("sqrt", numSqrt), ("expt", numExpt), ("make-rectangular", numMakeRectangular),- ("make-polar", numMakePolar), - ("real-part", numRealPart ), - ("imag-part", numImagPart), - ("magnitude", numMagnitude), - ("angle", numAngle ), + ("make-polar", numMakePolar),+ ("real-part", numRealPart ),+ ("imag-part", numImagPart),+ ("magnitude", numMagnitude),+ ("angle", numAngle ), ("exact->inexact", numExact2Inexact), ("inexact->exact", numInexact2Exact),@@ -900,10 +959,10 @@ ("boolean?", isBoolean)] -data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)+data Unpacker = forall a . Eq a => AnyUnpacker (LispVal -> ThrowsError a) unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool-unpackEquals arg1 arg2 (AnyUnpacker unpacker) = +unpackEquals arg1 arg2 (AnyUnpacker unpacker) = do unpacked1 <- unpacker arg1 unpacked2 <- unpacker arg2 return $ unpacked1 == unpacked2@@ -921,8 +980,8 @@ unaryOp _ [] = throwError $ NumArgs 1 [] unaryOp _ args@(_ : _) = throwError $ NumArgs 1 args ---numBoolBinop :: (Integer -> Integer -> Bool) -> [LispVal] -> ThrowsError LispVal---numBoolBinop = boolBinop unpackNum+{- numBoolBinop :: (Integer -> Integer -> Bool) -> [LispVal] -> ThrowsError LispVal+numBoolBinop = boolBinop unpackNum -} strBoolBinop :: (String -> String -> Bool) -> [LispVal] -> ThrowsError LispVal strBoolBinop = boolBinop unpackStr boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal@@ -935,10 +994,10 @@ unpackStr notString = throwError $ TypeMismatch "string" notString unpackBool :: LispVal -> ThrowsError Bool-unpackBool (Bool b) = return b+unpackBool (Bool b) = return b unpackBool notBool = throwError $ TypeMismatch "boolean" notBool -{- List primitives -}+-- List primitives car :: [LispVal] -> ThrowsError LispVal car [List (x : _)] = return x car [DottedList (x : _) _] = return x@@ -960,7 +1019,7 @@ cons badArgList = throwError $ NumArgs 2 badArgList equal :: [LispVal] -> ThrowsError LispVal-equal [(Vector arg1), (Vector arg2)] = eqvList equal [List $ (elems arg1), List $ (elems arg2)] +equal [(Vector arg1), (Vector arg2)] = eqvList equal [List $ (elems arg1), List $ (elems arg2)] equal [l1@(List _), l2@(List _)] = eqvList equal [l1, l2] equal [(DottedList xs x), (DottedList ys y)] = equal [List $ xs ++ [x], List $ ys ++ [y]] equal [arg1, arg2] = do@@ -970,45 +1029,45 @@ return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x) equal badArgList = throwError $ NumArgs 2 badArgList --------------- Vector Primitives --------------+-- ------------ 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 + let l = replicate (fromInteger n) a return $ Vector $ (listArray (0, length l - 1)) l-makeVector [badType] = throwError $ TypeMismatch "integer" badType +makeVector [badType] = throwError $ TypeMismatch "integer" badType makeVector badArgList = throwError $ NumArgs 1 badArgList -buildVector (o:os) = do- let lst = o:os+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 [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 [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 [(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 [badType] = throwError $ TypeMismatch "list" badType listToVector badArgList = throwError $ NumArgs 1 badArgList --------------- Hash Table Primitives --------------+-- ------------ Hash Table Primitives -------------- -- Future: support (equal?), (hash) parameters-hashTblMake, isHashTbl, hashTblExists, hashTblRef, hashTblSize, hashTbl2List, hashTblKeys, hashTblValues, hashTblCopy:: [LispVal] -> ThrowsError LispVal+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+isHashTbl _ = return $ Bool False hashTblExists [(HashTable ht), key@(_)] = do case Data.Map.lookup key ht of@@ -1021,12 +1080,12 @@ case Data.Map.lookup key ht of Just val -> return $ val Nothing -> throwError $ BadSpecialForm "Hash table does not contain key" key-hashTblRef [(HashTable ht), key@(_), Func _ _ _ _] = do +hashTblRef [(HashTable ht), key@(_), Func _ _ _ _] = do case Data.Map.lookup key ht of Just val -> return $ val Nothing -> throwError $ NotImplemented "thunk"--- FUTURE: a thunk can optionally be specified, this drives definition of /default--- Nothing -> apply thunk []+{- FUTURE: a thunk can optionally be specified, this drives definition of /default+Nothing -> apply thunk [] -} hashTblRef [badType] = throwError $ TypeMismatch "hash-table" badType hashTblRef badArgList = throwError $ NumArgs 2 badArgList @@ -1035,17 +1094,17 @@ hashTblSize badArgList = throwError $ NumArgs 1 badArgList hashTbl2List [(HashTable ht)] = do- return $ List $ map (\(k, v) -> List [k, v]) $ Data.Map.toList ht+ 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, _) -> k) $ Data.Map.toList ht+ return $ List $ map (\ (k, _) -> 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 (\(_, v) -> v) $ Data.Map.toList ht+ return $ List $ map (\ (_, v) -> v) $ Data.Map.toList ht hashTblValues [badType] = throwError $ TypeMismatch "hash-table" badType hashTblValues badArgList = throwError $ NumArgs 1 badArgList @@ -1054,11 +1113,11 @@ hashTblCopy [badType] = throwError $ TypeMismatch "hash-table" badType hashTblCopy badArgList = throwError $ NumArgs 1 badArgList --------------- String Primitives --------------+-- ------------ String Primitives -------------- buildString :: [LispVal] -> ThrowsError LispVal buildString [(Char c)] = return $ String [c]-buildString (Char c:rest) = do+buildString (Char c : rest) = do cs <- buildString rest case cs of String s -> return $ String $ [c] ++ s@@ -1071,14 +1130,14 @@ makeString [(Number n), (Char c)] = return $ doMakeString n c "" makeString badArgList = throwError $ NumArgs 1 badArgList -doMakeString :: forall a.(Num a) => a -> Char -> String -> LispVal-doMakeString n char s = - if n == 0 +doMakeString :: forall a . (Num a) => a -> Char -> String -> LispVal+doMakeString n char s =+ if n == 0 then String s else doMakeString (n - 1) char (s ++ [char]) stringLength :: [LispVal] -> ThrowsError LispVal-stringLength [String s] = return $ Number $ foldr (const (+1)) 0 s -- Could probably do 'length s' instead...+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 @@ -1088,9 +1147,9 @@ stringRef badArgList = throwError $ NumArgs 2 badArgList substring :: [LispVal] -> ThrowsError LispVal-substring [(String s), (Number start), (Number end)] = +substring [(String s), (Number start), (Number end)] = do let slength = fromInteger $ end - start- let begin = fromInteger start + let begin = fromInteger start return $ String $ (take slength . drop begin) s substring [badType] = throwError $ TypeMismatch "string number number" badType substring badArgList = throwError $ NumArgs 3 badArgList@@ -1110,13 +1169,13 @@ 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 + where strToLower str = map (toLower) str stringCIBoolBinop _ [badType] = throwError $ TypeMismatch "string string" badType stringCIBoolBinop _ 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+stringAppend (String st : sts) = do rest <- stringAppend sts case rest of String s -> return $ String $ st ++ s@@ -1135,11 +1194,11 @@ _ -> return $ Bool False stringToNumber [(String s), Number radix] = do case radix of- 2 -> stringToNumber [String $ "#b" ++ s]- 8 -> stringToNumber [String $ "#o" ++ s]+ 2 -> stringToNumber [String $ "#b" ++ s]+ 8 -> stringToNumber [String $ "#o" ++ s] 10 -> stringToNumber [String s] 16 -> stringToNumber [String $ "#x" ++ s]- _ -> throwError $ Default $ "Invalid radix: " ++ show radix + _ -> throwError $ Default $ "Invalid radix: " ++ show radix stringToNumber [badType] = throwError $ TypeMismatch "string" badType stringToNumber badArgList = throwError $ NumArgs 1 badArgList @@ -1165,7 +1224,7 @@ -- Must include lists as well since they are made up of 'chains' of pairs isDottedList ([List []]) = return $ Bool False isDottedList ([List _]) = return $ Bool True-isDottedList _ = return $ Bool False+isDottedList _ = return $ Bool False isProcedure :: [LispVal] -> ThrowsError LispVal isProcedure ([Continuation _ _ _ _ _]) = return $ Bool True@@ -1177,9 +1236,9 @@ isVector, isList :: LispVal -> ThrowsError LispVal isVector (Vector _) = return $ Bool True-isVector _ = return $ Bool False+isVector _ = return $ Bool False isList (List _) = return $ Bool True-isList _ = return $ Bool False+isList _ = return $ Bool False isNull :: [LispVal] -> ThrowsError LispVal isNull ([List []]) = return $ Bool True@@ -1216,5 +1275,3 @@ isBoolean :: [LispVal] -> ThrowsError LispVal isBoolean ([Bool _]) = return $ Bool True isBoolean _ = return $ Bool False--
hs-src/Language/Scheme/Macro.hs view
@@ -1,35 +1,39 @@-{- - - 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 Language.Scheme.Macro +{- |+Module : Language.Scheme.Macro+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution)++Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++husk scheme interpreter++A lightweight dialect of R5RS scheme.++This module 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:++* 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 Language.Scheme.Macro ( macroEval ) where@@ -37,28 +41,25 @@ import Language.Scheme.Variables import Control.Monad.Error import Data.Array---import Debug.Trace -- Only req'd to support trace, can be disabled at any time...+-- 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+{- Nice FAQ regarding macro's, points out some of the limitations of current implementation+http://community.schemewiki.org/?scheme-faq-macros -} --- |macroEval--- 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+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 -- Special case, just load up the syntax rules macroEval env (List [Atom "define-syntax", Atom keyword, syntaxRules@(List (Atom "syntax-rules" : (List _ : _)))]) = do- -- - --- --- -- FUTURE: Issue #15: 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.- -- At a minimum, should check identifiers to make sure each is an atom (see findAtom)- --- --- --- defineNamespacedVar env macroNamespace keyword syntaxRules+ {-+ - FUTURE: Issue #15: 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.+ - At a minimum, should check identifiers to make sure each is an atom (see findAtom) + -}+ _ <- defineNamespacedVar env macroNamespace keyword syntaxRules return $ Nil "" -- Sentinal value -- Inspect a list of code, and transform as necessary@@ -67,19 +68,20 @@ rest <- mapM (macroEval env) xs return $ List $ first : rest --- Inspect code for macro's------ Only a list form is required because a pattern may only consist--- of a list here. From the spec:------ "The <pattern> in a <syntax rule> is a list <pattern> that --- begins with the keyword for the macro."---+{- Inspect code for macros+ -+ - Only a list form is required because a pattern may only consist+ - of a list here. From the spec:+ -+ - "The <pattern> in a <syntax rule> is a list <pattern> that+begins with the keyword for the macro." + -+ -} macroEval env lisp@(List (Atom x : xs)) = do isDefined <- liftIO $ isNamespacedBound env macroNamespace x if isDefined then do- (List (Atom "syntax-rules" : (List identifiers : rules))) <- getNamespacedVar env macroNamespace x + (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@@ -89,20 +91,23 @@ -- No macro to process, just return code as it is... 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+{-+ - 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 (rule@(List _) : rs) input = do localEnv <- liftIO $ nullEnv -- Local environment used just for this invocation result <- matchRule env identifiers localEnv rule input- case result of + case result of Nil _ -> macroTransform env identifiers rs input _ -> return result -- Ran out of rules to match...@@ -110,7 +115,7 @@ -- Determine if the next element in a list matches 0-to-n times due to an ellipsis macroElementMatchesMany :: LispVal -> Bool-macroElementMatchesMany (List (_:ps)) = do+macroElementMatchesMany (List (_ : ps)) = do if not (null ps) then case (head ps) of Atom "..." -> True@@ -118,8 +123,8 @@ else False macroElementMatchesMany _ = False --- Given input, determine if that input matches any rules--- @return Transformed code, or Nil if no rules match+{- 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 _ identifiers localEnv (List [pattern, template]) (List inputVar) = do let is = tail inputVar@@ -128,51 +133,50 @@ (Atom l : ls) -> List [Atom l, DottedList ls d] _ -> pattern _ -> pattern- case p of + case p of List (Atom _ : ps) -> do match <- loadLocal localEnv identifiers (List ps) (List is) False False case match of Bool False -> return $ Nil ""- _ -> transformRule localEnv 0 (List []) template (List [])+ _ -> transformRule localEnv 0 (List []) template (List []) _ -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" p matchRule _ _ _ 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 - 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 +loadLocal localEnv identifiers pattern input hasEllipsis outerHasEllipsis = do case (pattern, input) of - -- For vectors, just use list match for now, since vector input matching just requires a- -- subset of that behavior. Should be OK since parser would catch problems with trying- -- to add pair syntax to a vector declaration.+ {- For vectors, just use list match for now, since vector input matching just requires a+ subset of that behavior. Should be OK since parser would catch problems with trying+ to add pair syntax to a vector declaration. -} ((Vector p), (Vector i)) -> do loadLocal localEnv identifiers (List $ elems p) (List $ elems i) False outerHasEllipsis ((DottedList ps p), (DottedList is i)) -> do- result <- loadLocal localEnv identifiers (List ps) (List is) False outerHasEllipsis+ result <- loadLocal localEnv identifiers (List ps) (List is) False outerHasEllipsis case result of Bool True -> loadLocal localEnv identifiers p i False outerHasEllipsis _ -> return $ Bool False - (List (p:ps), List (i:is)) -> do -- check first input against first pattern, recurse...+ (List (p : ps), List (i : is)) -> do -- check first input against first pattern, recurse... let localHasEllipsis = macroElementMatchesMany pattern - -- FUTURE: error if ... detected when there is an outer ... ????- -- no, this should (eventually) be allowed. See scheme-faq-macros+ {- FUTURE: error if ... detected when there is an outer ... ????+ no, this should (eventually) be allowed. See scheme-faq-macros -} - status <- checkLocal localEnv identifiers (localHasEllipsis || outerHasEllipsis) p i + status <- checkLocal localEnv identifiers (localHasEllipsis || outerHasEllipsis) p i case status of -- No match Bool False -> if localHasEllipsis- -- No match, must be finished with ...- -- Move past it, but keep the same input.+ {- 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+ loadLocal localEnv identifiers (List $ tail ps) (List (i : is)) False outerHasEllipsis else return $ Bool False -- There was a match _ -> if localHasEllipsis@@ -183,11 +187,11 @@ (List [], List []) -> return $ Bool True -- Ran out of input to process- (List (_: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- if (macroElementMatchesMany pattern) && ((length ps) == 1) + (List (_ : 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+ if (macroElementMatchesMany pattern) && ((length ps) == 1) then return $ Bool True else return $ Bool False @@ -195,15 +199,16 @@ (List [], _) -> return $ Bool False -- Check input against pattern (both should be single var)- (_, _) -> checkLocal localEnv identifiers (hasEllipsis || outerHasEllipsis) pattern input + (_, _) -> 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+{- 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 _ _ _ (Bool pattern) (Bool input) = return $ Bool $ pattern == input checkLocal _ _ _ (Number pattern) (Number input) = return $ Bool $ pattern == input@@ -212,13 +217,12 @@ checkLocal _ _ _ (Char pattern) (Char input) = return $ Bool $ pattern == input checkLocal localEnv identifiers hasEllipsis (Atom pattern) input = do if hasEllipsis- -- FUTURE: may be able to simplify both cases below by using a - -- lambda function to store the 'save' actions- --- + {- FUTURE: may be able to simplify both cases below by using a+ lambda function to store the 'save' actions -}+ -- 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, need to ensure -- input matches that literal, or that (in this case) -- the literal is missing from the input (0 match)@@ -231,15 +235,15 @@ if (pattern == inpt) then do -- Set variable in the local environment- addPatternVar isDefined $ Atom pattern+ _ <- addPatternVar isDefined $ Atom pattern return $ Bool True else return $ Bool False -- Pattern/Input cannot match because input is not an atom _ -> return $ Bool False -- No literal identifier, just load up the var- _ -> do addPatternVar isDefined input+ _ -> do _ <- addPatternVar isDefined input return $ Bool True- -- + -- -- Simple var, try to load up into macro env -- else do@@ -251,14 +255,14 @@ Atom inpt -> do -- Pattern/Input are atoms; both must match if (pattern == inpt)- then do defineVar localEnv pattern input+ then do _ <- defineVar localEnv pattern input return $ Bool True else return $ (Bool False) -- Pattern/Input cannot match because input is not an atom _ -> return $ (Bool False) -- No literal identifier, just load up the var- _ -> do defineVar localEnv pattern input+ _ -> do _ <- defineVar localEnv pattern input return $ Bool True where addPatternVar isDefined val = do@@ -269,55 +273,56 @@ _ -> throwError $ Default "Unexpected error in checkLocal (Atom)" else defineVar localEnv pattern (List [val]) -checkLocal localEnv identifiers hasEllipsis pattern@(Vector _) input@(Vector _) = +checkLocal localEnv identifiers hasEllipsis pattern@(Vector _) input@(Vector _) = loadLocal localEnv identifiers pattern input False hasEllipsis -checkLocal localEnv identifiers hasEllipsis pattern@(DottedList _ _) input@(DottedList _ _) = +checkLocal localEnv identifiers hasEllipsis pattern@(DottedList _ _) input@(DottedList _ _) = loadLocal localEnv identifiers pattern input False hasEllipsis--- throwError $ BadSpecialForm "Test" input+-- 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+ {- 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.+ {- 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 _) = +checkLocal localEnv identifiers hasEllipsis pattern@(List _) input@(List _) = loadLocal localEnv identifiers pattern input False hasEllipsis checkLocal _ _ _ _ _ = 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+{- 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+{-+ - 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 + 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 []) + 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 _] -> 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 []) + 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 _ -> transformRule localEnv (ellipsisIndex + 1) (List $ result ++ [curT]) transform (List ellipsisList)@@ -332,13 +337,13 @@ transformRule localEnv ellipsisIndex (List result) transform@(List ((Vector v) : ts)) (List ellipsisList) = do if macroElementMatchesMany transform- then do + then do -- Idea here is that we need to handle case where you have (vector ...) - EG: (#(var step) ...) curT <- transformRule localEnv (ellipsisIndex + 1) (List []) (List $ elems v) (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 []) + 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 []) List t -> transformRule localEnv (ellipsisIndex + 1) (List $ result ++ [asVector t]) transform (List ellipsisList)@@ -348,33 +353,33 @@ List l -> do transformRule localEnv ellipsisIndex (List $ result ++ [asVector l]) (List ts) (List ellipsisList) Nil _ -> return lst- _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [Vector v]), Number $ toInteger ellipsisIndex]+ _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [Vector v]), Number $ toInteger ellipsisIndex] where asVector lst = (Vector $ (listArray (0, length lst - 1)) lst) transformRule localEnv ellipsisIndex (List result) transform@(List (dl@(DottedList _ _) : ts)) (List ellipsisList) = do if macroElementMatchesMany transform- then do + 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 []) + 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...+ {- 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 _] -> 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 []) + 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) _ -> throwError $ Default "Unexpected error in transformRule" else do lst <- transformDottedList localEnv ellipsisIndex (List []) (List [dl]) (List ellipsisList) case lst of- List [Nil _, List _] -> return lst + List [Nil _, List _] -> return lst List l -> transformRule localEnv ellipsisIndex (List $ result ++ l) (List ts) (List ellipsisList) Nil _ -> return lst _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [dl]), Number $ toInteger ellipsisIndex]@@ -390,7 +395,7 @@ -- get var var <- getVar localEnv a -- ensure it is a list- case var of + 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@@ -398,7 +403,7 @@ transformRule localEnv ellipsisIndex (List result) (List $ tail ts) unused else do t <- if isDefined then do var <- getVar localEnv a- if ellipsisIndex > 0 + if ellipsisIndex > 0 then do case var of List v -> if (length v) > (ellipsisIndex - 1) then return $ v !! (ellipsisIndex - 1)@@ -425,29 +430,29 @@ transformDottedList localEnv ellipsisIndex (List result) (List (DottedList ds d : ts)) (List ellipsisList) = do lsto <- transformRule localEnv ellipsisIndex (List []) (List ds) (List ellipsisList) case lsto of- List lst -> do + 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)- -- + -- -- FUTURE: Issue #9 - 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+ {- - 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.+ {- 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] -> 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) - _ -> transformRule localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList) - _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d + String "pair" -> transformRule localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList)+ _ -> transformRule localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList)+ _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d Nil _ -> return $ List [Nil "", List ellipsisList] _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d @@ -455,43 +460,44 @@ -- 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+findAtom (Atom target) (List (Atom a : as)) = do if target == a then return $ Bool True else findAtom (Atom target) (List as) findAtom _ (List (badtype : _)) = throwError $ TypeMismatch "symbol" badtype findAtom _ _ = 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++{- 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 (p : ps) -> do _ <- initializePatternVars localEnv src identifiers p+ initializePatternVars localEnv src identifiers $ List ps List [] -> return $ Bool True _ -> return $ Bool True initializePatternVars localEnv src identifiers (DottedList ps p) = do- initializePatternVars localEnv src identifiers $ List ps+ _ <- initializePatternVars localEnv src identifiers $ List ps initializePatternVars localEnv src identifiers p initializePatternVars localEnv src identifiers (Vector v) = do initializePatternVars localEnv src identifiers $ List $ elems v -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+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@@ -503,17 +509,17 @@ -- Ignore identifiers since they are just passed along as-is _ -> return $ Bool True -initializePatternVars _ _ _ _ = - return $ Bool True +initializePatternVars _ _ _ _ =+ 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- _ -> return result+ List (p : ps) -> do result <- lookupPatternVarSrc localEnv p+ case result of+ Bool False -> lookupPatternVarSrc localEnv $ List ps+ _ -> return result List [] -> return $ Bool False _ -> return $ Bool False @@ -526,10 +532,10 @@ lookupPatternVarSrc localEnv (Vector v) = do lookupPatternVarSrc localEnv $ List $ elems v -lookupPatternVarSrc localEnv (Atom pattern) = +lookupPatternVarSrc localEnv (Atom pattern) = do isDefined <- liftIO $ isNamespacedBound localEnv "src" pattern if isDefined then getNamespacedVar localEnv "src" pattern else return $ Bool False -lookupPatternVarSrc _ _ = - return $ Bool False +lookupPatternVarSrc _ _ =+ return $ Bool False
hs-src/Language/Scheme/Numerical.hs view
@@ -1,19 +1,25 @@-{-- - husk scheme interpreter- -- - A lightweight dialect of R5RS scheme.- - Numerical tower functionality- -- - @author Justin Ethier- - - - -}+{- |+Module : Language.Scheme.Numerical+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution) +Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++husk scheme interpreter++A lightweight dialect of R5RS scheme.++This module implements the numerical tower.+-}+ module Language.Scheme.Numerical where import Language.Scheme.Types import Complex import Control.Monad.Error import Data.Char-import Numeric +import Numeric import Ratio import Text.Printf @@ -21,120 +27,120 @@ numericBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal numericBinop op aparams = mapM unpackNum aparams >>= return . Number . foldl1 op ---- Begin GenUtil - http://repetae.net/computer/haskell/GenUtil.hs+-- - 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 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 :: Monad m => (a -> a -> m a) -> [a] -> m a+foldl1M f (x : xs) = foldlM f x xs foldl1M _ _ = error "Unexpected error in foldl1M" -- end GenUtil --- FUTURE: as a general comment here, operations need to be more permissive of the--- numerical types they accept. Within reason, a user should not have to know--- what numerical type they are passing when using these functions+{- FUTURE: as a general comment here, operations need to be more permissive of the+numerical types they accept. Within reason, a user should not have to know+what numerical type they are passing when using these functions -} numAdd, numSub, numMul, numDiv :: [LispVal] -> ThrowsError LispVal numAdd [] = return $ Number 0 numAdd aparams = do- foldl1M (\a b -> doAdd =<< (numCast [a, b])) aparams+ foldl1M (\ a b -> doAdd =<< (numCast [a, b])) aparams 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 doAdd _ = throwError $ Default "Unexpected error in +"-numSub [] = throwError $ NumArgs 1 [] +numSub [] = throwError $ NumArgs 1 [] 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 aparams = do- foldl1M (\a b -> doSub =<< (numCast [a, b])) aparams+ foldl1M (\ a b -> doSub =<< (numCast [a, b])) aparams 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 doSub _ = throwError $ Default "Unexpected error in -"-numMul [] = return $ Number 1 -numMul aparams = do - foldl1M (\a b -> doMul =<< (numCast [a, b])) aparams+numMul [] = return $ Number 1+numMul aparams = do+ foldl1M (\ a b -> doMul =<< (numCast [a, b])) aparams 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 doMul _ = throwError $ Default "Unexpected error in *"-numDiv [] = throwError $ NumArgs 1 [] +numDiv [] = throwError $ NumArgs 1 [] 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 aparams = do - foldl1M (\a b -> doDiv =<< (numCast [a, b])) aparams- where doDiv (List [(Number a), (Number b)]) = if b == 0 - then throwError $ DivideByZero - else if (mod a b) == 0 +numDiv aparams = do+ foldl1M (\ a b -> doDiv =<< (numCast [a, b])) aparams+ where doDiv (List [(Number a), (Number b)]) = if b == 0+ then throwError $ DivideByZero+ else if (mod a b) == 0 then return $ Number $ div a b -- Convert to a rational if the result is not an integer else return $ Rational $ (fromInteger a) / (fromInteger b)- doDiv (List [(Float a), (Float b)]) = if b == 0.0 - then throwError $ DivideByZero + 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 + then throwError $ DivideByZero else return $ Rational $ a / b doDiv (List [(Complex a), (Complex b)]) = if b == 0- then throwError $ DivideByZero + then throwError $ DivideByZero else return $ Complex $ a / b doDiv _ = throwError $ Default "Unexpected error in /" numBoolBinopEq :: [LispVal] -> ThrowsError LispVal numBoolBinopEq [] = throwError $ NumArgs 0 []-numBoolBinopEq aparams = do - foldl1M (\a b -> doOp =<< (numCast [a, b])) aparams+numBoolBinopEq aparams = do+ foldl1M (\ a b -> doOp =<< (numCast [a, b])) aparams 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- doOp _ = throwError $ Default "Unexpected error in =" + doOp _ = throwError $ Default "Unexpected error in =" numBoolBinopGt :: [LispVal] -> ThrowsError LispVal numBoolBinopGt [] = throwError $ NumArgs 0 []-numBoolBinopGt aparams = do - foldl1M (\a b -> doOp =<< (numCast [a, b])) aparams+numBoolBinopGt aparams = do+ foldl1M (\ a b -> doOp =<< (numCast [a, b])) aparams 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 _ = throwError $ Default "Unexpected error in >" + doOp _ = throwError $ Default "Unexpected error in >" numBoolBinopGte :: [LispVal] -> ThrowsError LispVal numBoolBinopGte [] = throwError $ NumArgs 0 []-numBoolBinopGte aparams = do - foldl1M (\a b -> doOp =<< (numCast [a, b])) aparams+numBoolBinopGte aparams = do+ foldl1M (\ a b -> doOp =<< (numCast [a, b])) aparams 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 _ = throwError $ Default "Unexpected error in >=" + doOp _ = throwError $ Default "Unexpected error in >=" numBoolBinopLt :: [LispVal] -> ThrowsError LispVal numBoolBinopLt [] = throwError $ NumArgs 0 []-numBoolBinopLt aparams = do - foldl1M (\a b -> doOp =<< (numCast [a, b])) aparams+numBoolBinopLt aparams = do+ foldl1M (\ a b -> doOp =<< (numCast [a, b])) aparams 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 _ = throwError $ Default "Unexpected error in <" + doOp _ = throwError $ Default "Unexpected error in <" numBoolBinopLte :: [LispVal] -> ThrowsError LispVal numBoolBinopLte [] = throwError $ NumArgs 0 []-numBoolBinopLte aparams = do - foldl1M (\a b -> doOp =<< (numCast [a, b])) aparams+numBoolBinopLte aparams = do+ foldl1M (\ a b -> doOp =<< (numCast [a, b])) aparams 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 _ = throwError $ Default "Unexpected error in <=" + doOp _ = throwError $ Default "Unexpected error in <=" numCast :: [LispVal] -> ThrowsError LispVal numCast [a@(Number _), b@(Number _)] = return $ List [a, b]@@ -153,12 +159,12 @@ 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+numCast [a, b] = case a of+ Number _ -> doThrowError b+ Float _ -> doThrowError b Rational _ -> doThrowError b- Complex _ -> doThrowError b- _ -> doThrowError a+ Complex _ -> doThrowError b+ _ -> doThrowError a where doThrowError num = throwError $ TypeMismatch "number" num numCast _ = throwError $ Default "Unexpected error in numCast" @@ -219,7 +225,7 @@ 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@@ -227,7 +233,7 @@ 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@@ -252,24 +258,24 @@ 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 [(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 [(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 [(Float n), (Number p)] = return $ Float $ n ^ p+numExpt [(Complex n), (Number p)] = return $ Complex $ n ^ p numExpt [_, y] = throwError $ TypeMismatch "integer" y numExpt badArgList = throwError $ NumArgs 2 badArgList -{-numExpt params = do+{- 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-}+-- doExpt (List [(Complex a), (Complex b)]) = return $ Complex $ a ^ b -} numExp :: [LispVal] -> ThrowsError LispVal numExp [(Number n)] = return $ Float $ exp $ fromInteger n@@ -289,15 +295,15 @@ buildComplex :: LispVal -> LispVal -> ThrowsError LispVal-buildComplex (Number x) (Number y) = return $ Complex $ (fromInteger x) :+ (fromInteger y)-buildComplex (Number x) (Rational y) = return $ Complex $(fromInteger x) :+ (fromRational y)-buildComplex (Number x) (Float y) = return $ Complex $ (fromInteger x) :+ y-buildComplex (Rational x) (Number y) = return $ Complex $ (fromRational x) :+ (fromInteger y)+buildComplex (Number x) (Number y) = return $ Complex $ (fromInteger x) :+ (fromInteger y)+buildComplex (Number x) (Rational y) = return $ Complex $ (fromInteger x) :+ (fromRational y)+buildComplex (Number x) (Float y) = return $ Complex $ (fromInteger x) :+ y+buildComplex (Rational x) (Number y) = return $ Complex $ (fromRational x) :+ (fromInteger y) buildComplex (Rational x) (Rational y) = return $ Complex $ (fromRational x) :+ (fromRational y)-buildComplex (Rational x) (Float y) = return $ Complex $ (fromRational x) :+ y -buildComplex (Float x) (Number y) = return $ Complex $ x :+ (fromInteger y)+buildComplex (Rational x) (Float y) = return $ Complex $ (fromRational x) :+ y+buildComplex (Float x) (Number y) = return $ Complex $ x :+ (fromInteger y) buildComplex (Float x) (Rational y) = return $ Complex $ x :+ (fromRational y)-buildComplex (Float x) (Float y) = return $ Complex $ x :+ y+buildComplex (Float x) (Float y) = return $ Complex $ x :+ y buildComplex x y = throwError $ TypeMismatch "number" $ List [x, y] -- Complex number functions@@ -327,7 +333,7 @@ numImagPart badArgList = throwError $ NumArgs 1 badArgList -numNumerator, numDenominator:: [LispVal] -> ThrowsError LispVal+numNumerator, numDenominator :: [LispVal] -> ThrowsError LispVal numNumerator [(Rational r)] = return $ Number $ numerator r numNumerator [x] = throwError $ TypeMismatch "rational number" x numNumerator badArgList = throwError $ NumArgs 1 badArgList@@ -347,7 +353,7 @@ numInexact2Exact [n@(Number _)] = return n numInexact2Exact [n@(Rational _)] = return n numInexact2Exact [(Float n)] = return $ Number $ round n-numInexact2Exact [c@(Complex _)] = numRound [c] +numInexact2Exact [c@(Complex _)] = numRound [c] numInexact2Exact [badType] = throwError $ TypeMismatch "number" badType numInexact2Exact badArgList = throwError $ NumArgs 1 badArgList @@ -356,12 +362,12 @@ num2String [(Number n)] = return $ String $ show n num2String [(Number n), (Number radix)] = do case radix of- 2 -> do -- Nice tip from StackOverflow question #1959715+ 2 -> do -- Nice tip from StackOverflow question #1959715 return $ String $ showIntAtBase 2 intToDigit n ""- 8 -> return $ String $ printf "%o" n+ 8 -> return $ String $ printf "%o" n 10 -> return $ String $ printf "%d" n 16 -> return $ String $ printf "%x" n- _ -> throwError $ BadSpecialForm "Invalid radix value" $ Number radix+ _ -> 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@@ -389,7 +395,7 @@ isRational ([Number _]) = return $ Bool True isRational ([Rational _]) = return $ Bool True-isRational ([n@(Float _)]) = return $ Bool $ isFloatAnInteger n +isRational ([n@(Float _)]) = return $ Bool $ isFloatAnInteger n -- FUTURE: not quite good enough, could be represented exactly and not an integer isRational _ = return $ Bool False @@ -400,14 +406,14 @@ let numer = numerator n let denom = denominator n return $ Bool $ (numer >= denom) && ((mod numer denom) == 0)-isInteger ([n@(Float _)]) = return $ Bool $ isFloatAnInteger n +isInteger ([n@(Float _)]) = return $ Bool $ isFloatAnInteger n isInteger _ = return $ Bool False isFloatAnInteger :: LispVal -> Bool isFloatAnInteger (Float n) = (floor n) == (ceiling n)-isFloatAnInteger _ = False +isFloatAnInteger _ = False ---- end Numeric operations section ---+-- - end Numeric operations section --- unpackNum :: LispVal -> ThrowsError Integer
hs-src/Language/Scheme/Parser.hs view
@@ -1,12 +1,19 @@-{-- - husk scheme- - Parser- -- - This file contains the code for parsing scheme- -- - @author Justin Ethier- -- - -}+{- |+Module : Language.Scheme.Parser+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution)++Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++husk scheme interpreter++A lightweight dialect of R5RS scheme.++This module implements parsing of Scheme code.+-}+ module Language.Scheme.Parser where import Language.Scheme.Types import Control.Monad.Error@@ -18,22 +25,22 @@ import Text.ParserCombinators.Parsec hiding (spaces) symbol :: Parser Char-symbol = oneOf "!$%&|*+-/:<=>?@^_~" +symbol = oneOf "!$%&|*+-/:<=>?@^_~" 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+ 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 "#"+parseBool = do _ <- string "#" x <- oneOf "tf" return $ case x of 't' -> Bool True@@ -42,20 +49,20 @@ parseChar :: Parser LispVal parseChar = do- try (string "#\\")- c <- anyChar - r <- many(letter)- let pchr = c:r+ _ <- try (string "#\\")+ c <- anyChar+ r <- many (letter)+ let pchr = c : r return $ case pchr of- "space" -> Char ' '+ "space" -> Char ' ' "newline" -> Char '\n'- _ -> Char c + _ -> Char c parseOctalNumber :: Parser LispVal parseOctalNumber = do- try (string "#o")+ _ <- try (string "#o") sign <- many (oneOf "-")- num <- many1(oneOf "01234567")+ num <- many1 (oneOf "01234567") case (length sign) of 0 -> return $ Number $ fst $ Numeric.readOct num !! 0 1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ Numeric.readOct num !! 0@@ -63,9 +70,9 @@ parseBinaryNumber :: Parser LispVal parseBinaryNumber = do- try (string "#b")+ _ <- try (string "#b") sign <- many (oneOf "-")- num <- many1(oneOf "01")+ num <- many1 (oneOf "01") case (length sign) of 0 -> return $ Number $ fst $ Numeric.readInt 2 (`elem` "01") Char.digitToInt num !! 0 1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ Numeric.readInt 2 (`elem` "01") Char.digitToInt num !! 0@@ -73,18 +80,18 @@ parseHexNumber :: Parser LispVal parseHexNumber = do- try (string "#x")+ _ <- try (string "#x") sign <- many (oneOf "-")- num <- many1(digit <|> oneOf "abcdefABCDEF")+ num <- many1 (digit <|> oneOf "abcdefABCDEF") case (length sign) of- 0 -> return $ Number $ fst $ Numeric.readHex num !! 0 + 0 -> return $ Number $ fst $ Numeric.readHex num !! 0 1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ Numeric.readHex num !! 0 _ -> pzero -- |Parser for Integer, base 10 parseDecimalNumber :: Parser LispVal parseDecimalNumber = do- try (many(string "#d"))+ _ <- try (many (string "#d")) sign <- many (oneOf "-") num <- many1 (digit) if (length sign) > 1@@ -92,25 +99,25 @@ else return $ (Number . read) $ sign ++ num parseNumber :: Parser LispVal-parseNumber = parseDecimalNumber <|> - parseHexNumber <|> - parseBinaryNumber <|> - parseOctalNumber <?> +parseNumber = parseDecimalNumber <|>+ parseHexNumber <|>+ parseBinaryNumber <|>+ parseOctalNumber <?> "Unable to parse number" -{- Parser for floating points +{- Parser for floating points - -} parseRealNumber :: Parser LispVal-parseRealNumber = do +parseRealNumber = do sign <- many (oneOf "-")- num <- many1(digit)- char '.'- frac <- many1(digit)+ num <- many1 (digit)+ _ <- char '.'+ frac <- many1 (digit) let dec = num ++ "." ++ frac case (length sign) of 0 -> do let numbr = fst $ Numeric.readFloat dec !! 0--- expnt <- try (char 'e')+-- expnt <- try (char 'e') return $ Float $ numbr {- FUTURE: Issue #14: parse numbers in format #e1e10 -@@ -118,17 +125,16 @@ case expnt of -- 'e' -> return $ Float $ numbr _ -> return $ Float $ numbr--}--- return $ Float $ fst $ Numeric.readFloat dec !! 0+return $ Float $ fst $ Numeric.readFloat dec !! 0 -} 1 -> return $ Float $ (*) (-1.0) $ fst $ Numeric.readFloat dec !! 0 _ -> pzero parseRationalNumber :: Parser LispVal parseRationalNumber = do pnumerator <- parseDecimalNumber- case pnumerator of + case pnumerator of Number n -> do- char '/'+ _ <- char '/' sign <- many (oneOf "-") num <- many1 (digit) if (length sign) > 1@@ -138,39 +144,39 @@ parseComplexNumber :: Parser LispVal parseComplexNumber = do- lispreal <- (try (parseRealNumber) <|> try(parseRationalNumber) <|> parseDecimalNumber)+ lispreal <- (try (parseRealNumber) <|> try (parseRationalNumber) <|> parseDecimalNumber) let real = case lispreal of Number n -> fromInteger n Rational r -> fromRational r Float f -> f _ -> 0- char '+'- lispimag <- (try(parseRealNumber) <|> try(parseRationalNumber) <|> parseDecimalNumber)+ _ <- char '+'+ lispimag <- (try (parseRealNumber) <|> try (parseRationalNumber) <|> parseDecimalNumber) let imag = case lispimag of Number n -> fromInteger n Rational r -> fromRational r Float f -> f _ -> 0 -- Case should never be reached- char 'i'+ _ <- char 'i' return $ Complex $ real :+ imag -parseEscapedChar :: forall st.+parseEscapedChar :: forall st . GenParser Char st Char-parseEscapedChar = do - char '\\'+parseEscapedChar = do+ _ <- char '\\' c <- anyChar return $ case c of 'n' -> '\n' 't' -> '\t' 'r' -> '\r'- _ -> c+ _ -> c parseString :: Parser LispVal parseString = do- char '"'- x <- many (parseEscapedChar <|> noneOf("\""))- char '"'- return $ String x+ _ <- char '"'+ x <- many (parseEscapedChar <|> noneOf ("\""))+ _ <- char '"'+ return $ String x parseVector :: Parser LispVal parseVector = do@@ -188,73 +194,72 @@ parseQuoted :: Parser LispVal parseQuoted = do- char '\''+ _ <- char '\'' x <- parseExpr return $ List [Atom "quote", x] parseQuasiQuoted :: Parser LispVal parseQuasiQuoted = do- char '`'+ _ <- char '`' x <- parseExpr return $ List [Atom "quasiquote", x] parseUnquoted :: Parser LispVal parseUnquoted = do- try (char ',')+ _ <- try (char ',') x <- parseExpr return $ List [Atom "unquote", x] parseUnquoteSpliced :: Parser LispVal parseUnquoteSpliced = do- try (string ",@")+ _ <- try (string ",@") x <- parseExpr return $ List [Atom "unquote-splicing", x] --- Comment parser--- FUTURE: this is a hack, it should really not return anything...--- a better solution might be to use a tokenizer as a--- parser instead; need to investigate eventually.+{- Comment parser+FUTURE: this is a hack, it should really not return anything...+a better solution might be to use a tokenizer as a+parser instead; need to investigate eventually. -} parseComment :: Parser LispVal parseComment = do- char ';'- many (noneOf ("\n"))+ _ <- char ';'+ _ <- many (noneOf ("\n")) return $ Nil "" parseExpr :: Parser LispVal-parseExpr = - try(parseComplexNumber)- <|> try(parseRationalNumber)+parseExpr =+ try (parseComplexNumber)+ <|> try (parseRationalNumber) <|> parseComment- <|> try(parseRealNumber)- <|> try(parseNumber)+ <|> try (parseRealNumber)+ <|> try (parseNumber) <|> parseChar <|> parseUnquoteSpliced- <|> do try (string "#(")+ <|> do _ <- try (string "#(") x <- parseVector- char ')'+ _ <- char ')' return x <|> try (parseAtom)- <|> parseString + <|> parseString <|> parseBool <|> parseQuoted <|> parseQuasiQuoted <|> parseUnquoted- <|> do char '('+ <|> do _ <- char '(' x <- try parseList <|> parseDottedList- char ')'+ _ <- 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+ Left err -> throwError $ Parser err+ Right val -> return val readExpr :: String -> ThrowsError LispVal readExpr = readOrThrow parseExpr readExprList :: String -> ThrowsError [LispVal] readExprList = readOrThrow (endBy parseExpr spaces)-
+ hs-src/Language/Scheme/Plugins/CPUTime.hs view
@@ -0,0 +1,39 @@+{- |+Module : Language.Scheme.Plugins.CPUTime+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution)++Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++husk scheme interpreter++A lightweight dialect of R5RS scheme.++This module wraps System.CPUTime so that it can be used directly by Scheme code.++More importantly, it serves as an example of how to wrap existing Haskell code so+that it can be loaded and called by husk.++See 'examples/ffi/ffi-cputime.scm' in the husk source tree for an example of how to+call into this module from Scheme code.+-}++module Language.Scheme.Plugins.CPUTime (get, precision) where++import Language.Scheme.Types+import System.CPUTime+import Control.Monad.Error++get, precision :: [LispVal] -> IOThrowsError LispVal++-- |Wrapper for CPUTime.getCPUTime+get [] = do+ t <- liftIO $ System.CPUTime.getCPUTime+ return $ Number t+get badArgList = throwError $ NumArgs 0 badArgList++-- |Wrapper for CPUTime.cpuTimePrecision+precision [] = return $ Number $ System.CPUTime.cpuTimePrecision+precision badArgList = throwError $ NumArgs 0 badArgList
hs-src/Language/Scheme/Types.hs view
@@ -1,14 +1,22 @@-{--- - 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 : Language.Scheme.Types+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution)++Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++husk scheme interpreter++A lightweight dialect of R5RS scheme.++This module contains top-level data type definitions and their associated functions, including:+ - Scheme data types+ - Scheme errors++-}+ module Language.Scheme.Types where import Complex import Control.Monad.Error@@ -19,7 +27,7 @@ import Ratio import Text.ParserCombinators.Parsec hiding (spaces) -{- Environment management -}+-- Environment management -- |A Scheme environment containing variable bindings of form @(namespaceName, variableName), variableValue@ data Env = Environment {parentEnv :: (Maybe Env), bindings :: (IORef [((String, String), IORef LispVal)])} -- lookup via: (namespace, variable)@@ -46,8 +54,8 @@ | UnboundVar String String | DivideByZero -- ^Divide by Zero error | NotImplemented String- | InternalError String -- ^An internal error within husk; in theory user (Scheme) code- -- should never allow one of these errors to be triggered.+ | InternalError String {- ^An internal error within husk; in theory user (Scheme) code+ should never allow one of these errors to be triggered. -} | Default String -- ^Default error -- |Create a textual description for a 'LispError'@@ -74,7 +82,7 @@ trapError :: -- forall (m :: * -> *) e. (MonadError e m, Show e) =>- m String -> m String + m String -> m String trapError action = catchError action (return . show) extractValue :: ThrowsError a -> a@@ -92,67 +100,67 @@ -- |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. - -- Technically this could be a derived data type instead of being built-in to the - -- interpreter. And perhaps in the future it will be. But for now, a hash table - -- is too important of a data type to not be included.- --- -- 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 -- FUTURE: rename this to "Integer" (or "WholeNumber" or something else more meaningful)- -- ^Integer- | Float Double -- FUTURE: 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)- -- ^Primitive function- | Func {params :: [String], - vararg :: (Maybe String),- body :: [LispVal], - closure :: Env- }- -- ^Function- | IOFunc ([LispVal] -> IOThrowsError LispVal)- -- ^Primitive function within the IO monad- | EvalFunc ([LispVal] -> IOThrowsError LispVal)- -- ^Function within the IO monad with access to - -- the current environment and continuation.- | Port Handle- -- ^I/O port- | Continuation { closure :: Env -- Environment of the continuation- , currentCont :: (Maybe DeferredCode) -- Code of current continuation- , nextCont :: (Maybe LispVal) -- Code to resume after body of cont- , extraReturnArgs :: (Maybe [LispVal]) -- Extra return arguments, to support (values) and (call-with-values)- , dynamicWind :: (Maybe [DynamicWinders]) -- Functions injected by (dynamic-wind) - }- -- ^Continuation- | EOF- | Nil String- -- ^Internal use only; do not use this type directly.+ -- ^Symbol+ | List [LispVal]+ -- ^List+ | DottedList [LispVal] LispVal+ -- ^Pair+ | Vector (Array Int LispVal)+ -- ^Vector+ | HashTable (Data.Map.Map LispVal LispVal)+ {- ^Hash table.+ Technically this could be a derived data type instead of being built-in to the+ interpreter. And perhaps in the future it will be. But for now, a hash table+ is too important of a data type to not be included. -}+ --+ -- 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 {- FUTURE: rename this to "Integer" (or "WholeNumber" or something else more meaningful)+ Integer -}+ | Float Double {- FUTURE: 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)+ -- ^Primitive function+ | Func {params :: [String],+ vararg :: (Maybe String),+ body :: [LispVal],+ closure :: Env+ }+ -- ^Function+ | IOFunc ([LispVal] -> IOThrowsError LispVal)+ -- ^Primitive function within the IO monad+ | EvalFunc ([LispVal] -> IOThrowsError LispVal)+ {- ^Function within the IO monad with access to+ the current environment and continuation. -}+ | Port Handle+ -- ^I/O port+ | Continuation { closure :: Env -- Environment of the continuation+ , currentCont :: (Maybe DeferredCode) -- Code of current continuation+ , nextCont :: (Maybe LispVal) -- Code to resume after body of cont+ , extraReturnArgs :: (Maybe [LispVal]) -- Extra return arguments, to support (values) and (call-with-values)+ , dynamicWind :: (Maybe [DynamicWinders]) -- Functions injected by (dynamic-wind)+ }+ -- ^Continuation+ | EOF+ | Nil String+ -- ^Internal use only; do not use this type directly. --- |Container to hold code that is passed to a continuation for deferred execution -data DeferredCode = +-- |Container to hold code that is passed to a continuation for deferred execution+data DeferredCode = SchemeBody [LispVal] | -- ^A block of Scheme code- HaskellBody { + HaskellBody { contFunction :: (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)- , contFunctionArgs :: (Maybe [LispVal]) -- Arguments to the higher-order function + , contFunctionArgs :: (Maybe [LispVal]) -- Arguments to the higher-order function } -- ^A Haskell function -- |Container to store information from a dynamic-wind@@ -168,17 +176,17 @@ -- Make an "empty" continuation that does not contain any code makeNullContinuation :: Env -> LispVal-makeNullContinuation env = Continuation env Nothing Nothing Nothing Nothing +makeNullContinuation env = Continuation env Nothing Nothing Nothing Nothing -- Make a continuation that takes a higher-order function (written in Haskell)-makeCPS :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal]-> IOThrowsError LispVal) -> LispVal+makeCPS :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) -> LispVal makeCPS env cont@(Continuation _ _ _ _ dynWind) cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) Nothing dynWind-makeCPS env cont cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) Nothing Nothing -- This overload just here for completeness; it should never be used +makeCPS env cont cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) Nothing Nothing -- This overload just here for completeness; it should never be used -- Make a continuation that stores a higher-order function and arguments to that function makeCPSWArgs :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) -> [LispVal] -> LispVal makeCPSWArgs env cont@(Continuation _ _ _ _ dynWind) cps args = Continuation env (Just (HaskellBody cps (Just args))) (Just cont) Nothing dynWind-makeCPSWArgs env cont cps args = Continuation env (Just (HaskellBody cps (Just args))) (Just cont) Nothing Nothing -- This overload just here for completeness; it should never be used +makeCPSWArgs env cont cps args = Continuation env (Just (HaskellBody cps (Just args))) (Just cont) Nothing Nothing -- This overload just here for completeness; it should never be used instance Ord LispVal where compare (Bool a) (Bool b) = compare a b@@ -188,12 +196,12 @@ 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 (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@@ -207,16 +215,16 @@ 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 [(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 _), l2@(List _)] = 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) && +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 _ -> False@@ -254,7 +262,7 @@ showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")" showVal (PrimitiveFunc _) = "<primitive>" showVal (Continuation _ _ _ _ _) = "<continuation>"-showVal (Func {params = args, vararg = varargs, body = _, closure = _}) = +showVal (Func {params = args, vararg = varargs, body = _, closure = _}) = "(lambda (" ++ unwords (map show args) ++ (case varargs of Nothing -> ""
hs-src/Language/Scheme/Variables.hs view
@@ -1,12 +1,20 @@-{-- - husk scheme- - Variables- -- - This file contains code for working with Scheme variables- -- - @author Justin Ethier- -- - -}+{- |+Module : Language.Scheme.Variables+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution)++Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++husk scheme interpreter++A lightweight dialect of R5RS scheme.++This module contains code for working with Scheme variables.++-}+ module Language.Scheme.Variables where import Language.Scheme.Types import Control.Monad.Error@@ -63,11 +71,11 @@ -- |Set a variable in a given namespace setNamespacedVar :: Env -> String -> String -> LispVal -> IOThrowsError LispVal-setNamespacedVar envRef +setNamespacedVar envRef namespace var value = do env <- liftIO $ readIORef $ bindings envRef case lookup (namespace, var) env of- (Just a) -> do --vprime <- liftIO $ readIORef a+ (Just a) -> do -- vprime <- liftIO $ readIORef a liftIO $ writeIORef a value return value Nothing -> case parentEnv envRef of@@ -76,8 +84,8 @@ -- |Bind a variable in the given namespace defineNamespacedVar :: Env -> String -> String -> LispVal -> IOThrowsError LispVal-defineNamespacedVar envRef - namespace +defineNamespacedVar envRef+ namespace var value = do alreadyDefined <- liftIO $ isNamespacedBound envRef namespace var if alreadyDefined
hs-src/shell.hs view
@@ -1,15 +1,20 @@-{-- - 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+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution) +Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++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.+-}+ module Main where import Paths_husk_scheme import Language.Scheme.Core -- Scheme Interpreter@@ -32,14 +37,16 @@ runOne :: [String] -> IO () runOne args = do- -- Use this to suppress unwanted output.- -- Makes this unix-specific, but as of now- -- everything else is anyway, so...+ {- Use this to suppress unwanted output.+ Makes this unix-specific, but as of now+ everything else is anyway, so... -} nullIO <- openFile "/dev/null" WriteMode stdlib <- getDataFileName "stdlib.scm"- env <- primitiveBindings >>= flip extendEnv [((varNamespace, "args"), List $ map String $ drop 1 args)]- evalString env $ "(load \"" ++ stdlib ++ "\")" -- Load standard library+ env <- primitiveBindings >>= flip extendEnv+ [((varNamespace, "args"),+ List $ map String $ drop 1 args)]+ _ <- evalString env $ "(load \"" ++ stdlib ++ "\")" -- Load standard library (runIOThrows $ liftM show $ evalLisp env (List [Atom "load", String (args !! 0)])) >>= hPutStr nullIO @@ -47,19 +54,20 @@ alreadyDefined <- liftIO $ isBound env "main" let argv = List $ map String $ args if alreadyDefined- then (runIOThrows $ liftM show $ evalLisp env (List [Atom "main", List [Atom "quote", argv]])) >>= hPutStr stderr+ then (runIOThrows $ liftM show $ evalLisp env+ (List [Atom "main", List [Atom "quote", argv]])) >>= hPutStr stderr else (runIOThrows $ liftM show $ evalLisp env (Nil "")) >>= hPutStr stderr showBanner :: IO () showBanner = do- putStrLn " _ _ __ _ " + putStrLn " _ _ __ _ " putStrLn " | | | | \\\\\\ | | " putStrLn " | |__ _ _ ___| | __ \\\\\\ ___ ___| |__ ___ _ __ ___ ___ " putStrLn " | '_ \\| | | / __| |/ / //\\\\\\ / __|/ __| '_ \\ / _ \\ '_ ` _ \\ / _ \\ " putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ " putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| " putStrLn " "- putStrLn " husk Scheme Interpreter Version 2.4 "+ putStrLn " husk Scheme Interpreter Version 3.0 " putStrLn " (c) 2010-2011 Justin Ethier github.com/justinethier/husk-scheme " putStrLn " " @@ -67,9 +75,9 @@ runRepl = do stdlib <- getDataFileName "stdlib.scm" env <- primitiveBindings- evalString env $ "(load \"" ++ stdlib ++ "\")" -- Load standard library into the REPL- runInputT defaultSettings (loop env) - where + _ <- 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> "@@ -86,8 +94,8 @@ -- 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/+{- 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'])
husk-scheme.cabal view
@@ -1,9 +1,9 @@ Name: husk-scheme-Version: 2.4+Version: 3.0 Synopsis: R5RS Scheme interpreter program and library. Description: A dialect of R5RS Scheme written in Haskell. Provides advanced - features including continuations, hygienic macros, and the- full numeric tower.+ features including continuations, hygienic macros, a Haskell FFI,+ and the full numeric tower. License: MIT License-file: LICENSE Author: Justin Ethier@@ -12,24 +12,26 @@ Cabal-Version: >= 1.4 Build-Type: Simple Category: Compilers/Interpreters, Language+Tested-with: GHC == 6.12.3, GHC == 6.10.4 Extra-Source-Files: README.markdown LICENSE Data-Files: stdlib.scm Library- Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory+ Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory, ghc, ghc-paths Extensions: ExistentialQuantification Hs-Source-Dirs: hs-src Exposed-Modules: Language.Scheme.Core Language.Scheme.Types Language.Scheme.Variables+ Language.Scheme.Plugins.CPUTime Other-Modules: Language.Scheme.Macro Language.Scheme.Numerical Language.Scheme.Parser Executable huski- Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory+ Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory, ghc, ghc-paths Extensions: ExistentialQuantification Main-is: shell.hs Hs-Source-Dirs: hs-src