diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -2,7 +2,7 @@ husk is a dialect of Scheme written in Haskell that implements a subset of the [R5RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R5RS 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 R5RS standard, the intent is to develop a Scheme that is as compatible as possible with other R5RS 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 R5RS standard, the intent is to develop a Scheme that is as compatible as possible with other R5RS Schemes. Scheme is one of two main dialects of Lisp. Scheme follows a minimalist design philosophy: the core language consists of a small number of fundamental forms which may be used to implement the other built-in forms. Scheme is an excellent language for writing small, elegant programs, and may also be used to write scripts or embed scripting functionality within a larger application. @@ -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. diff --git a/hs-src/Language/Scheme/Core.hs b/hs-src/Language/Scheme/Core.hs --- a/hs-src/Language/Scheme/Core.hs +++ b/hs-src/Language/Scheme/Core.hs @@ -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 - - diff --git a/hs-src/Language/Scheme/Macro.hs b/hs-src/Language/Scheme/Macro.hs --- a/hs-src/Language/Scheme/Macro.hs +++ b/hs-src/Language/Scheme/Macro.hs @@ -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 in a is a list 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 in a is a list 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 diff --git a/hs-src/Language/Scheme/Numerical.hs b/hs-src/Language/Scheme/Numerical.hs --- a/hs-src/Language/Scheme/Numerical.hs +++ b/hs-src/Language/Scheme/Numerical.hs @@ -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 diff --git a/hs-src/Language/Scheme/Parser.hs b/hs-src/Language/Scheme/Parser.hs --- a/hs-src/Language/Scheme/Parser.hs +++ b/hs-src/Language/Scheme/Parser.hs @@ -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) - diff --git a/hs-src/Language/Scheme/Plugins/CPUTime.hs b/hs-src/Language/Scheme/Plugins/CPUTime.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Scheme/Plugins/CPUTime.hs @@ -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 diff --git a/hs-src/Language/Scheme/Types.hs b/hs-src/Language/Scheme/Types.hs --- a/hs-src/Language/Scheme/Types.hs +++ b/hs-src/Language/Scheme/Types.hs @@ -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 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 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 _) = "" showVal (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 -> "" diff --git a/hs-src/Language/Scheme/Variables.hs b/hs-src/Language/Scheme/Variables.hs --- a/hs-src/Language/Scheme/Variables.hs +++ b/hs-src/Language/Scheme/Variables.hs @@ -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 diff --git a/hs-src/shell.hs b/hs-src/shell.hs --- a/hs-src/shell.hs +++ b/hs-src/shell.hs @@ -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']) diff --git a/husk-scheme.cabal b/husk-scheme.cabal --- a/husk-scheme.cabal +++ b/husk-scheme.cabal @@ -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