diff --git a/hs-src/Compiler/huskc.hs b/hs-src/Compiler/huskc.hs --- a/hs-src/Compiler/huskc.hs +++ b/hs-src/Compiler/huskc.hs @@ -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 diff --git a/hs-src/Interpreter/shell.hs b/hs-src/Interpreter/shell.hs --- a/hs-src/Interpreter/shell.hs +++ b/hs-src/Interpreter/shell.hs @@ -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 diff --git a/hs-src/Language/Scheme/Compiler.hs b/hs-src/Language/Scheme/Compiler.hs --- a/hs-src/Language/Scheme/Compiler.hs +++ b/hs-src/Language/Scheme/Compiler.hs @@ -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? 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 @@ -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 diff --git a/hs-src/Language/Scheme/FFI.hs b/hs-src/Language/Scheme/FFI.hs --- a/hs-src/Language/Scheme/FFI.hs +++ b/hs-src/Language/Scheme/FFI.hs @@ -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) - 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 @@ -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) diff --git a/hs-src/Language/Scheme/Macro/Matches.hs b/hs-src/Language/Scheme/Macro/Matches.hs --- a/hs-src/Language/Scheme/Macro/Matches.hs +++ b/hs-src/Language/Scheme/Macro/Matches.hs @@ -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 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 @@ -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 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 @@ -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) diff --git a/hs-src/Language/Scheme/Primitives.hs b/hs-src/Language/Scheme/Primitives.hs --- a/hs-src/Language/Scheme/Primitives.hs +++ b/hs-src/Language/Scheme/Primitives.hs @@ -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" 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 @@ -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 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 @@ -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 diff --git a/husk-scheme.cabal b/husk-scheme.cabal --- a/husk-scheme.cabal +++ b/husk-scheme.cabal @@ -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