husk-scheme 3.5.3.2 → 3.5.4

raw patch · 13 files changed

+411/−104 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hs-src/Compiler/huskc.hs +3/−3
• hs-src/Interpreter/shell.hs +11/−13
• hs-src/Language/Scheme/Compiler.hs +11/−3
• hs-src/Language/Scheme/Core.hs +30/−23
• hs-src/Language/Scheme/FFI.hs +2/−0
• hs-src/Language/Scheme/Macro.hs +24/−19
• hs-src/Language/Scheme/Macro/Matches.hs +4/−3
• hs-src/Language/Scheme/Numerical.hs +54/−4
• hs-src/Language/Scheme/Parser.hs +45/−5
• hs-src/Language/Scheme/Primitives.hs +90/−5
• hs-src/Language/Scheme/Types.hs +46/−3
• hs-src/Language/Scheme/Variables.hs +87/−19
• husk-scheme.cabal +4/−4

@@ -30,7 +30,7 @@   putStrLn ""   putStrLn "!!! This version of huskc is Experimental !!!"   putStrLn ""-  putStrLn "It is recommended you consult the issue list prior to use:"+  putStrLn "You might want to consult the issue list before use:"   putStrLn "https://github.com/justinethier/husk-scheme/issues"   putStrLn "" @@ -134,8 +134,8 @@   stdlib <- getDataFileName "stdlib.scm"   result <- (runIOThrows $ liftM show $ compileSchemeFile env (stdlib) inFile)   case result of-   "" -> compileHaskellFile outExec dynamic extraArgs-   _ -> putStrLn result+   Just errMsg -> putStrLn errMsg+   _ -> compileHaskellFile outExec dynamic extraArgs  -- |Compile a scheme file to haskell compileSchemeFile :: Env -> String -> String -> IOThrowsError LispVal

@@ -16,6 +16,7 @@ import Language.Scheme.Core      -- Scheme Interpreter import Language.Scheme.Types     -- Scheme data types import Language.Scheme.Variables -- Scheme variable operations+--import Control.Monad (when) import Control.Monad.Error import System.IO import System.Environment@@ -40,19 +41,16 @@   _ <- evalString env $ "(load \"" ++ (escapeBackslashes stdlib) ++ "\")" -- Load standard library   result <- (runIOThrows $ liftM show $ evalLisp env (List [Atom "load", String (args !! 0)]))   case result of-    "" -> putStr result-    _  -> putStrLn result --  -- Call into (main) if it exists...-  alreadyDefined <- liftIO $ isBound env "main"-  let argv = List $ map String $ args-  if alreadyDefined-     then do -            mainResult <- (runIOThrows $ liftM show $ evalLisp env (List [Atom "main", List [Atom "quote", argv]]))-            case mainResult of-              "" -> putStr mainResult-              _  -> putStrLn mainResult-     else putStr "" +    Just errMsg -> putStrLn errMsg+    _  -> do +      -- Call into (main) if it exists...+      alreadyDefined <- liftIO $ isBound env "main"+      let argv = List $ map String $ args+      when alreadyDefined (do +        mainResult <- (runIOThrows $ liftM show $ evalLisp env (List [Atom "main", List [Atom "quote", argv]]))+        case mainResult of+          Just errMsg -> putStrLn errMsg+          _  -> return ())  runRepl :: IO () runRepl = do

@@ -7,11 +7,12 @@ Stability   : experimental Portability : portable -This module contains an experimental compiler of Scheme to Haskell +This module contains an experimental Scheme to Haskell compiler.   The compiler performs the following transformations:-Scheme AST (LispVal) -> Haskell AST (HaskAST) -> Compiled Code (String) +> Scheme AST (LispVal) => Haskell AST (HaskAST) => Compiled Code (String)+ The GHC compiler is then used to create a native executable.  At present, the focus has just been on creating a compiler that will@@ -149,7 +150,10 @@  , "main :: IO () "  , "main = do "  , "  env <- primitiveBindings "- , "  (runIOThrows $ liftM show $ run env (makeNullContinuation env) (Nil \"\") Nothing) >>= putStr "+ , "  result <- (runIOThrows $ liftM show $ run env (makeNullContinuation env) (Nil \"\") Nothing) "+ , "  case result of "+ , "    Just errMsg -> putStrLn errMsg "+ , "    _ -> return () "  , " "]  -- NOTE: the following type is used for all functions generated by the compiler: @@ -209,6 +213,10 @@ -- compile _ (List [Atom "quasiquote", val]) copts = compileScalar (" return $ " ++ astToHaskellStr val) copts +compile env args@(List [Atom "expand",  _body]) copts = do+  -- TODO: check if expand has been rebound?+  val <- Language.Scheme.Macro.expand env False _body+  compileScalar (" return $ " ++ astToHaskellStr val) copts  compile env args@(List (Atom "let-syntax" : List _bindings : _body)) copts = do   -- TODO: check if let-syntax has been rebound?

@@ -12,19 +12,20 @@  module Language.Scheme.Core     (+    -- * Scheme code evaluation       evalLisp     , evalString     , evalAndPrint-    , primitiveBindings     , apply     , continueEval--- TODO: we are starting to get some cruft here with utility functions.---       they should be relocated to a new Util module...+    -- * Core data+    , primitiveBindings+    , version+    -- * Utility functions     , escapeBackslashes     , showBanner     , substr     , updateVector-    , version     ) where import qualified Language.Scheme.FFI import qualified Language.Scheme.Macro@@ -39,9 +40,11 @@ import qualified System.Exit import System.IO +-- |husk version number version :: String-version = "3.5.3.2"+version = "3.5.4" +-- |A utility function to display the husk console banner showBanner :: IO () showBanner = do   putStrLn "  _               _        __                 _                          "@@ -81,7 +84,7 @@ @ -} evalString :: Env -> String -> IO String-evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= meval env (makeNullContinuation env)+evalString env expr = runIOThrowsREPL $ liftM show $ (liftThrows $ readExpr expr) >>= meval env (makeNullContinuation env)  -- |Evaluate a string and print results to console evalAndPrint :: Env -> String -> IO ()@@ -125,13 +128,14 @@     return val -} -{- |continueEval is a support function for eval.- -- - Transformed eval section into CPS by calling into this instead of returning from eval.- - This function uses the cont argument to determine whether to keep going or to finally- - return a result.- - -}-continueEval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal+{- |A support function for eval; eval calls into this function instead of +    returning values directly. continueEval then uses the continuation +    argument to manage program control flow.+ -}+continueEval :: Env     -- ^ Current environment+             -> LispVal -- ^ Current continuation+             -> LispVal -- ^ Value of previous computation+             -> IOThrowsError LispVal -- ^ Final value of computation  {- 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,@@ -205,11 +209,7 @@ 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 _) = do-    -- TODO: Issue #35 - not good enough to just return, need to ensure only constants (?) are part-    --       of the vector-    continueEval env cont val---    throwError $ Default $ "Illegal expression (should be quoted): " ++ show val+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@@ -302,9 +302,16 @@             _ -> cpsUnquoteList e c (head unEvaled) (Just [List (tail unEvaled), List $ acc ++ [val] ])         cpsUnquoteFld _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteFld" +-- A special form to assist with debugging macros+eval env cont args@(List [Atom "expand" , _body]) = do+ bound <- liftIO $ isRecBound env "expand"+ if bound+  then prepareApply env cont args -- if bound to a variable in this scope; call into it+  else Language.Scheme.Macro.expand env False _body >>= continueEval env cont+  -- A rudimentary implementation of let-syntax eval env cont args@(List (Atom "let-syntax" : List _bindings : _body)) = do- bound <- liftIO $ isRecBound env "define-syntax"+ bound <- liftIO $ isRecBound env "let-syntax"  if bound   then prepareApply env cont args -- if bound to a variable in this scope; call into it   else do @@ -317,7 +324,7 @@      e -> continueEval bodyEnv cont e  eval env cont args@(List (Atom "letrec-syntax" : List _bindings : _body)) = do- bound <- liftIO $ isRecBound env "define-syntax"+ bound <- liftIO $ isRecBound env "letrec-syntax"  if bound   then prepareApply env cont args -- if bound to a variable in this scope; call into it   else do @@ -610,7 +617,7 @@ eval env cont args@(List (_ : _)) = mprepareApply env cont args eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm --- |A helper function for the special form (string-set!)+-- |A helper function for the special form /(string-set!)/ substr :: (LispVal, LispVal, LispVal) -> IOThrowsError LispVal  substr (String str, Char char, Number ii) = do                       return $ String $ (take (fromInteger ii) . drop 0) str ++@@ -620,7 +627,7 @@ substr (String _, c, _) = throwError $ TypeMismatch "character" c substr (s, _, _) = throwError $ TypeMismatch "string" s --- |A helper function for the special form (vector-set!)+-- |A helper function for the special form /(vector-set!)/ updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal updateVector (Vector vec) (Number idx) obj = return $ Vector $ vec // [(fromInteger idx, obj)] updateVector v _ _ = throwError $ TypeMismatch "vector" v@@ -760,7 +767,7 @@  {- |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). -}+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

@@ -22,7 +22,9 @@ import qualified DynFlags import qualified Unsafe.Coerce (unsafeCoerce) +-- |Load a Haskell function into husk using the GHC API. evalfuncLoadFFI :: [LispVal] -> IOThrowsError LispVal+ {-  - |Load a Haskell function into husk using the foreign function inteface (FFI)  -

@@ -15,7 +15,7 @@   - Pattern (part of a rule that matches input) - - Transform (what the macro "expands" into)+ - Transform (what the macro expands into)   - Literal Identifiers (from the macro definition) @@ -25,26 +25,26 @@  At a high level, macro transformation is broken down into the following steps: - (0) Walk the input code looking for a macro definition or macro call. If a macro call is found --- (1) Search for a rule that matches the input.-     During this process, any pattern variables in the input are loaded into a temporary environment-- (2) If a rule matches,+ (0) Walk the input code looking for a macro definition or macro call.+ + (1) If a macro call is found, search for a rule that matches the input.+     During this process any pattern variables in the input are loaded +     into a temporary environment - (3) Transcribe the rule's template by walking the template, inserting pattern variables -     and renaming free identifiers as needed.+ (2) If a rule matches, transcribe the rule's template by walking the +     template, inserting pattern variables and renaming free identifiers +     as needed. - (4) Walk the expanded code, checking for each of the cases from Macros That Work. If a + (3) Walk the expanded code, checking for each of the cases from Macros That Work. If a       case is found (such as a macro call or procedure abstraction) then the appropriate       handler will be called to deal with it. -}  module Language.Scheme.Macro     (-      macroEval+      expand+    , macroEval     , loadMacros  -    , expand     ) where import Language.Scheme.Types import Language.Scheme.Variables@@ -100,9 +100,13 @@ --needToExtendEnv (List [Atom "define-syntax", Atom _, (List (Atom "syntax-rules" : (List _ : _)))]) = True --needToExtendEnv _ = False  --- |macroEval---  Search for macros in the AST, and transform any that are found.-macroEval :: Env -> LispVal -> IOThrowsError LispVal+-- |Examines the input AST to see if it is a macro call. +--  If a macro call is found, the code is expanded.+--  Otherwise the input is returned unchanged.+macroEval :: Env        -- ^Current environment for the AST+          -> LispVal    -- ^AST to search+          -> IOThrowsError LispVal -- ^Transformed AST containing an+                                   -- expanded macro if found  {- Inspect code for macros  -@@ -551,9 +555,10 @@  -- |This function walks the given block of code using the macro expansion algorithm, --  recursively expanding macro calls as they are encountered.------ It is essentially a wrapper for the function walkExpanded which is internal to this module.-expand :: Env -> Bool -> LispVal -> IOThrowsError LispVal+expand :: Env       -- ^Environment of the code being expanded+       -> Bool      -- ^True if the macro was defined within another macro+       -> LispVal   -- ^Code to expand+       -> IOThrowsError LispVal -- ^Expanded code expand env dim code = do   renameEnv <- liftIO $ nullEnv   cleanupEnv <- liftIO $ nullEnv@@ -567,7 +572,7 @@    walkExpanded env env env renameEnv cleanupEnv dim True False (List []) code --- |Walk expanded code per Clinger+-- |Walk expanded code per Clinger's algorithm from Macros That Work walkExpanded :: Env -> Env -> Env -> Env -> Env -> Bool -> Bool -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQuoted (List result) (List (List l : ls)) = do   lst <- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True isQuoted (List []) (List l)

@@ -40,7 +40,7 @@ -- |Get an element at given location in the nested list getData :: LispVal -- ^ The nested list to read from         -> [Int]   -- ^ Location to read an element from, all numbers are 0-based-        -> LispVal -- ^ Value read, or "Nil" if none+        -> LispVal -- ^ Value read, or 'Nil' if none getData (List lData) (i:is) = do   if length lData < i      then Nil "" -- Error: there are not enough elements in the list@@ -54,8 +54,9 @@  -- |Add an element to the given nested list setData :: LispVal -- ^ The nested list to modify-        -> [Int]   -- ^ Location to insert the new element, from top-most -> leaf -                   --   (EG: [1, 2] means add to the second top-most list, at its 3rd position)+        -> [Int]   -- ^ Location to insert the new element, from top-most to the leaf.+                   --   For example [1, 2] means add to the second top-most list, at+                   --   its 3rd position.         -> LispVal -- ^ Value to insert          -> LispVal -- ^ Resulant list setData (List lData) (i:is) val = do

@@ -10,11 +10,58 @@ This module implements the numerical tower. -} -module Language.Scheme.Numerical where+module Language.Scheme.Numerical (+   numericBinop+-- , foldlM+-- , foldl1M+ , numSub+ , numMul+ , numDiv+ , numAdd+ , numBoolBinopEq+ , numBoolBinopGt+ , numBoolBinopGte+ , numBoolBinopLt+ , numBoolBinopLte+ , numCast+ , numFloor+ , numCeiling+ , numTruncate+ , numRound+ , numSin+ , numCos+ , numTan+ , numAsin + , numAcos+ , numAtan+ , numExpt+ , numSqrt+ , numExp+ , numLog+ , buildComplex+ , numMakePolar+ , numRealPart+ , numImagPart+ , numMagnitude+ , numAngle+ , numMakeRectangular+ , numDenominator+ , numNumerator+ , numInexact2Exact+ , numExact2Inexact + , num2String+ , isComplex+ , isReal + , isRational+ , isInteger+ , isNumber+ , isFloatAnInteger+ , unpackNum+) where import Language.Scheme.Types import Data.Complex import Control.Monad.Error-import Data.Char+import Data.Char hiding (isNumber) import Numeric import Data.Ratio import Text.Printf@@ -355,7 +402,7 @@ numInexact2Exact [badType] = throwError $ TypeMismatch "number" badType numInexact2Exact badArgList = throwError $ NumArgs 1 badArgList --- Convert a number to a string; radix is optional, defaults to base 10+-- |Convert a number to a string; radix is optional, defaults to base 10 num2String :: [LispVal] -> ThrowsError LispVal num2String [(Number n)] = return $ String $ show n num2String [(Number n), (Number radix)] = do@@ -407,13 +454,16 @@ isInteger ([n@(Float _)]) = return $ Bool $ isFloatAnInteger n isInteger _ = return $ Bool False +-- |A utility function to determine if given value is a floating point+--  number representing an whole number (integer). isFloatAnInteger :: LispVal -> Bool isFloatAnInteger (Float n) = (floor n) == (ceiling n) isFloatAnInteger _ = False  -- - end Numeric operations section --- -+-- |Extract an integer from the given value, throwing a type error if+--  the wrong type is passed. unpackNum :: LispVal -> ThrowsError Integer unpackNum (Number n) = return n unpackNum notNum = throwError $ TypeMismatch "number" notNum

@@ -11,7 +11,38 @@ This module implements parsing of Scheme code. -} -module Language.Scheme.Parser where+module Language.Scheme.Parser +    (+      lispDef+    -- *Higher level parsing+    , mainParser+    , readOrThrow+    , readExpr+    , readExprList +    -- *Low level parsing+    , symbol+    , parseExpr +    , parseAtom+    , parseBool+    , parseChar+    , parseOctalNumber +    , parseBinaryNumber+    , parseHexNumber+    , parseDecimalNumber+    , parseNumber +    , parseRealNumber+    , parseRationalNumber +    , parseComplexNumber +    , parseEscapedChar +    , parseString +    , parseVector+    , parseList+    , parseDottedList+    , parseQuoted+    , parseQuasiQuoted +    , parseUnquoted +    , parseUnquoteSpliced +    )where import Language.Scheme.Types import Control.Monad.Error import qualified Data.Char as Char@@ -23,15 +54,16 @@ import Text.Parsec.Language import Text.Parsec.Prim (ParsecT) import qualified Text.Parsec.Token as P+ -- This was added by pull request #63 as part of a series of fixes -- to get husk to build on ghc 7.2.2 -- -- For now this has been removed to allow husk to support the older--- GHC 6.x.x series. But if removing this breaks things on 7.2 then --- it will force a "real" solution...+-- GHC 6.x.x series. -- --import Data.Functor.Identity (Identity) +-- |Language definition for Scheme lispDef :: LanguageDef () lispDef    = emptyDef    @@ -54,6 +86,8 @@ --parens :: ParsecT String () Identity a -> ParsecT String () Identity a parens = P.parens lexer +brackets = P.brackets lexer+ --identifier :: ParsecT String () Identity String identifier = P.identifier lexer @@ -140,8 +174,7 @@               parseOctalNumber <?>               "Unable to parse number" -{- Parser for floating points- - -}+-- |Parser a floating point number parseRealNumber :: Parser LispVal parseRealNumber = do   sign <- many (oneOf "-+")@@ -282,6 +315,7 @@   x <- parseExpr   return $ List [Atom "unquote-splicing", x] +-- |Parse an expression parseExpr :: Parser LispVal parseExpr =       try (lexeme parseComplexNumber)@@ -302,6 +336,8 @@   <|> parseUnquoted   <|> try (parens parseList)   <|> parens parseDottedList+  <|> try (brackets parseList)+  <|> brackets parseDottedList   <?> "Expression"  mainParser :: Parser LispVal@@ -311,14 +347,18 @@ -- FUTURE? (seemed to break test cases, but is supposed to be best practice?)    eof     return x +-- |Use a parser to parse the given text, throwing an error+--  if there is a problem parsing the text. readOrThrow :: Parser a -> String -> ThrowsError a readOrThrow parser input = case parse parser "lisp" input of   Left err -> throwError $ Parser err   Right val -> return val +-- |Parse an expression from a string of text readExpr :: String -> ThrowsError LispVal readExpr = readOrThrow mainParser +-- |Parse many expressions from a string of text readExprList :: String -> ThrowsError [LispVal] readExprList = readOrThrow (endBy mainParser whiteSpace) 

@@ -1,3 +1,5 @@+{-# Language ExistentialQuantification #-}+ {- | Module      : Language.Scheme.Primitives Copyright   : Justin Ethier@@ -7,15 +9,97 @@ Stability   : experimental Portability : portable -This module contains Primitive functions written in Haskell.+This module contains primitive functions written in Haskell.+Most of these map directly to an equivalent Scheme function.+ -} -module Language.Scheme.Primitives where+module Language.Scheme.Primitives (+ -- * Pure functions+ -- ** List+   car+ , cdr + , cons+ , equal + -- ** Vector+ , buildVector + , vectorLength + , vectorRef + , vectorToList + , listToVector+ , makeVector+ -- ** Hash Table+ , hashTblExists + , hashTblRef+ , hashTblSize + , hashTbl2List+ , hashTblKeys+ , hashTblValues + , hashTblCopy+ , hashTblMake+ -- ** String+ , buildString+ , makeString+ , doMakeString+ , stringLength+ , stringRef+ , substring+ , stringCIEquals + , stringCIBoolBinop + , stringAppend + , stringToNumber+ , stringToList + , listToString+ , stringCopy + , symbol2String + , string2Symbol+ --data Unpacker = forall a . Eq a => AnyUnpacker (LispVal -> ThrowsError a)+ -- ** Predicate+ , isHashTbl+ , isChar + , isString + , isBoolean + , isDottedList + , isProcedure + , isList + , isVector + , isNull + , isEOFObject + , isSymbol + -- ** Utility functions+ , unpackEquals + , boolBinop + , unaryOp + , strBoolBinop + , boolBoolBinop+ , unpackStr + , unpackBool+ -- * Impure functions+ -- |All of these functions must be executed within the IO monad.+ + -- ** Input / Output + , makePort + , closePort+ , currentOutputPort + , currentInputPort + , isOutputPort + , isInputPort+ , readProc + , readCharProc + , writeProc + , writeCharProc+ , readContents+ , load+ , readAll+ -- ** Symbol generation+ , gensym+ , _gensym+ ) where import Language.Scheme.Numerical import Language.Scheme.Parser import Language.Scheme.Types import Control.Monad.Error-import Data.Char+import Data.Char hiding (isSymbol) import Data.Array import Data.Unique import qualified Data.Map@@ -118,13 +202,14 @@ readAll [] = throwError $ NumArgs 1 [] readAll args@(_ : _) = throwError $ NumArgs 1 args --- Version of gensym that can be conveniently called from Haskell+-- |Version of gensym that can be conveniently called from Haskell. _gensym :: String -> IOThrowsError LispVal _gensym prefix = do     u <- liftIO $ newUnique     return $ Atom $ prefix ++ (show $ Number $ toInteger $ hashUnique u) --- Non-standard function, generate a (reasonably) unique symbol given an optional prefix+-- |Generate a (reasonably) unique symbol, given an optional prefix.+--  This function is provided even though it is not part of R5RS. gensym :: [LispVal] -> IOThrowsError LispVal gensym [String prefix] = _gensym prefix gensym [] = _gensym " g"

@@ -11,7 +11,39 @@  -} -module Language.Scheme.Types where+module Language.Scheme.Types+{-    (+      Env+--    , Environment+    , parentEnv+    , bindings+    , nullEnv +    , macroNamespace+    , varNamespace+    , LispError+    , ThrowsError +    , trapError+    , extractValue +    , IOThrowsError +    , liftThrows +    , runIOThrowsREPL +    , runIOThrows +    , LispVal+    , DeferredCode+    , DynamicWinders   +    , before +    , after +    , showDWVal +    , makeNullContinuation +    , makeCPS +    , makeCPSWArgs +    , eqv +    , eqvList+    , eqVal +    , showVal+    , unwordsList+    ) -}+ where import Data.Complex import Control.Monad.Error import Data.Array@@ -92,8 +124,19 @@ liftThrows (Left err) = throwError err liftThrows (Right val) = return val -runIOThrows :: IOThrowsError String -> IO String-runIOThrows action = runErrorT (trapError action) >>= return . extractValue+-- |Execute an IO action and return result or an error message.+--  This is intended for use by a REPL, where a result is always+--  needed regardless of type.+runIOThrowsREPL :: IOThrowsError String -> IO String+runIOThrowsREPL action = runErrorT (trapError action) >>= return . extractValue++-- |Execute an IO action and return error or Nothing if no error was thrown.+runIOThrows :: IOThrowsError String -> IO (Maybe String)+runIOThrows action = do+    runState <- runErrorT action+    case runState of+        Left err -> return $ Just (show err)+        Right _ -> return $ Nothing  -- |Scheme data types data LispVal = Atom String

@@ -7,11 +7,32 @@ Stability   : experimental Portability : portable -This module contains code for working with Scheme variables.+This module contains code for working with Scheme variables,+and the environments that contain them.  -} -module Language.Scheme.Variables where+module Language.Scheme.Variables +    (+    -- * Environments+      printEnv+    , copyEnv+    , extendEnv+    , findNamespacedEnv+    -- * Getters+    , getVar+    , getNamespacedVar +    -- * Setters+    , defineVar+    , setVar+    , setNamespacedVar+    , defineNamespacedVar+    -- * Predicates+    , isBound+    , isRecBound+    , isNamespacedBound+    , isNamespacedRecBound +    ) where import Language.Scheme.Types import Control.Monad.Error import Data.IORef@@ -51,7 +72,8 @@ -}  -- |Show the contents of an environment-printEnv :: Env -> IO String+printEnv :: Env         -- ^Environment+         -> IO String   -- ^Contents of the env as a string printEnv env = do   binds <- liftIO $ readIORef $ bindings env   l <- mapM showVar $ Data.Map.toList binds @@ -62,7 +84,8 @@     return $ name ++ ": " ++ show v  -- |Create a deep copy of an environment-copyEnv :: Env -> IO Env+copyEnv :: Env      -- ^ Source environment+        -> IO Env   -- ^ A copy of the source environment copyEnv env = do   binds <- liftIO $ readIORef $ bindings env --  bindingList <- mapM addBinding binds >>= newIORef@@ -77,15 +100,22 @@ -- |Extend given environment by binding a series of values to a new environment.  -- TODO: should be able to use Data.Map.fromList to ease construction of new Env-extendEnv :: Env -> [((String, String), LispVal)] -> IO Env+extendEnv :: Env -- ^ Environment +          -> [((String, String), LispVal)] -- ^ Extensions to the environment+          -> IO Env -- ^ Extended environment extendEnv envRef abindings = do bindinglistT <- (mapM addBinding abindings) -- >>= newIORef                                 bindinglist <- newIORef $ Data.Map.fromList bindinglistT                                 return $ Environment (Just envRef) bindinglist  where addBinding ((namespace, name), val) = do ref <- newIORef val                                                 return ((namespace, name), ref) --- Recursively search environments to find one that contains var-findNamespacedEnv :: Env -> String -> String -> IO (Maybe Env)+-- |Recursively search environments to find one that contains the given variable.+findNamespacedEnv +    :: Env      -- ^Environment to begin the search; +                --  parent env's will be searched as well.+    -> String   -- ^Namespace+    -> String   -- ^Variable+    -> IO (Maybe Env) -- ^Environment, or Nothing if there was no match. findNamespacedEnv envRef namespace var = do   found <- liftIO $ isNamespacedBound envRef namespace var   if found@@ -95,20 +125,34 @@                Nothing -> return Nothing  -- |Determine if a variable is bound in the default namespace-isBound :: Env -> String -> IO Bool+isBound :: Env      -- ^ Environment+        -> String   -- ^ Variable+        -> IO Bool  -- ^ True if the variable is bound isBound envRef var = isNamespacedBound envRef varNamespace var --- |Determine if a variable is bound in the default namespace, in this env or a parent-isRecBound :: Env -> String -> IO Bool+-- |Determine if a variable is bound in the default namespace, +--  in this environment or one of its parents.+isRecBound :: Env      -- ^ Environment+           -> String   -- ^ Variable+           -> IO Bool  -- ^ True if the variable is bound isRecBound envRef var = isNamespacedRecBound envRef varNamespace var  -- |Determine if a variable is bound in a given namespace-isNamespacedBound :: Env -> String -> String -> IO Bool+isNamespacedBound +    :: Env      -- ^ Environment+    -> String   -- ^ Namespace+    -> String   -- ^ Variable+    -> IO Bool  -- ^ True if the variable is bound isNamespacedBound envRef namespace var =      (readIORef $ bindings envRef) >>= return . Data.Map.member (namespace, var) --- TODO: should isNamespacedBound be replaced with this? Probably, but one step at a time...-isNamespacedRecBound :: Env -> String -> String -> IO Bool+-- |Determine if a variable is bound in a given namespace+--  or a parent of the given environment.+isNamespacedRecBound +    :: Env      -- ^ Environment+    -> String   -- ^ Namespace+    -> String   -- ^ Variable+    -> IO Bool  -- ^ True if the variable is bound isNamespacedRecBound envRef namespace var = do   env <- findNamespacedEnv envRef namespace var   case env of@@ -116,11 +160,16 @@     Nothing -> return False  -- |Retrieve the value of a variable defined in the default namespace-getVar :: Env -> String -> IOThrowsError LispVal+getVar :: Env       -- ^ Environment+       -> String    -- ^ Variable+       -> IOThrowsError LispVal -- ^ Contents of the variable getVar envRef var = getNamespacedVar envRef varNamespace var  -- |Retrieve the value of a variable defined in a given namespace-getNamespacedVar :: Env -> String -> String -> IOThrowsError LispVal+getNamespacedVar :: Env     -- ^ Environment+                 -> String  -- ^ Namespace+                 -> String  -- ^ Variable+                 -> IOThrowsError LispVal -- ^ Contents of the variable getNamespacedVar envRef                  namespace                  var = do binds <- liftIO $ readIORef $ bindings envRef@@ -132,14 +181,28 @@   -- |Set a variable in the default namespace-setVar, defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal+setVar+    :: Env      -- ^ Environment+    -> String   -- ^ Variable+    -> LispVal  -- ^ Value+    -> IOThrowsError LispVal -- ^ Value setVar envRef var value = setNamespacedVar envRef varNamespace var value --- ^Bind a variable in the default namespace+-- |Bind a variable in the default namespace+defineVar+    :: Env      -- ^ Environment+    -> String   -- ^ Variable+    -> LispVal  -- ^ Value+    -> IOThrowsError LispVal -- ^ Value defineVar envRef var value = defineNamespacedVar envRef varNamespace var value  -- |Set a variable in a given namespace-setNamespacedVar :: Env -> String -> String -> LispVal -> IOThrowsError LispVal+setNamespacedVar +    :: Env      -- ^ Environment +    -> String   -- ^ Namespace+    -> String   -- ^ Variable+    -> LispVal  -- ^ Value+    -> IOThrowsError LispVal   -- ^ Value setNamespacedVar envRef                  namespace                  var value = do env <- liftIO $ readIORef $ bindings envRef@@ -152,7 +215,12 @@                                               Nothing -> throwError $ UnboundVar "Setting an unbound variable: " var  -- |Bind a variable in the given namespace-defineNamespacedVar :: Env -> String -> String -> LispVal -> IOThrowsError LispVal+defineNamespacedVar+    :: Env      -- ^ Environment +    -> String   -- ^ Namespace+    -> String   -- ^ Variable+    -> LispVal  -- ^ Value+    -> IOThrowsError LispVal   -- ^ Value defineNamespacedVar envRef                     namespace                     var value = do

@@ -1,5 +1,5 @@ Name:                husk-scheme-Version:             3.5.3.2+Version:             3.5.4 Synopsis:            R5RS Scheme interpreter, compiler, and library. Description:         A dialect of R5RS Scheme written in Haskell. Provides advanced                       features including continuations, hygienic macros, a Haskell FFI,@@ -24,7 +24,7 @@  Library   Build-Depends:   base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, ghc, ghc-paths-  Extensions:      ExistentialQuantification CPP CPP+  Extensions:      ExistentialQuantification   Hs-Source-Dirs:  hs-src   Exposed-Modules: Language.Scheme.Core                    Language.Scheme.Types@@ -41,12 +41,12 @@  Executable         huski   Build-Depends:   husk-scheme, base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, ghc, ghc-paths-  Extensions:      ExistentialQuantification CPP CPP+  Extensions:      ExistentialQuantification   Main-is:         shell.hs   Hs-Source-Dirs:  hs-src/Interpreter  Executable huskc   Build-Depends: husk-scheme, base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, ghc, ghc-paths, process, filepath-  Extensions: ExistentialQuantification CPP CPP+  Extensions:      ExistentialQuantification   Main-is: huskc.hs   Hs-Source-Dirs: hs-src/Compiler