husk-scheme 3.11 → 3.12
raw patch · 14 files changed
+995/−87 lines, 14 filesdep +timePVP ok
version bump matches the API change (PVP)
Dependencies added: time
API changes (from Hackage documentation)
+ Language.Scheme.Core: r7rsTimeEnv :: IO Env
+ Language.Scheme.Primitives: currentTimestamp :: [LispVal] -> IOThrowsError LispVal
+ Language.Scheme.Primitives: system :: [LispVal] -> IOThrowsError LispVal
+ Language.Scheme.Types: validateFuncParams :: [LispVal] -> Maybe Integer -> IOThrowsError Bool
+ Language.Scheme.Util: strip :: String -> String
+ Language.Scheme.Variables: recExportsFromEnv :: Env -> IO [LispVal]
Files
- ChangeLog.markdown +20/−0
- hs-src/Interpreter/shell.hs +84/−31
- hs-src/Language/Scheme/Compiler.hs +24/−12
- hs-src/Language/Scheme/Compiler/Libraries.hs +2/−0
- hs-src/Language/Scheme/Compiler/Types.hs +11/−1
- hs-src/Language/Scheme/Core.hs +17/−1
- hs-src/Language/Scheme/Libraries.hs +1/−1
- hs-src/Language/Scheme/Parser.hs +30/−23
- hs-src/Language/Scheme/Primitives.hs +729/−11
- hs-src/Language/Scheme/Types.hs +31/−0
- hs-src/Language/Scheme/Util.hs +9/−5
- hs-src/Language/Scheme/Variables.hs +14/−0
- husk-scheme.cabal +2/−2
- lib/scheme/time.sld +21/−0
ChangeLog.markdown view
@@ -1,4 +1,24 @@ +v3.12+--------++Significant enhancements have been made to the huski REPL:++- Allow using huski to run Scheme scripts from the shell, as specified by SRFI 22. The script needs to start with the line `#! /usr/bin/env huski` or equivalent, and a `main` function may be defined to receive command line arguments. The `examples/scripts` directory contains example programs `cat.scm` and `sum.scm` that demonstrate how this works in practice.+- Add tab completion for Scheme variables and special forms. Tab completion will still fill in filenames when tab is pressed within double-quotes. This makes it easy to find a file in certain cases such as for a `load`.+- Accept (and ignore) inputs of just whitespace. Previously this would display a nasty error message.++This release also includes the following features:++- Added the `(scheme time)` library from R<sup>7</sup>RS.+- Added the `system` function to make system calls from a husk program. The syntax is `(system "command")`. An integer status code is returned with the same value that the executing program returned to the OS.++Bug fixes:++- Duplicate or otherwise invalid lambda parameters are not allowed, and will throw an error. For example: `(lambda (a a 1) a)`+- It is now a parse error to have a form that includes an empty car cell, for example: `'( . 1)`+- Ensure all of husk's exports are included in the Haskell API documentation.+ v3.11 --------
hs-src/Interpreter/shell.hs view
@@ -13,15 +13,17 @@ module Main where import Paths_husk_scheme-import Language.Scheme.Core -- Scheme Interpreter-import Language.Scheme.Types -- Scheme data types-import Language.Scheme.Util-import Language.Scheme.Variables -- Scheme variable operations---import Control.Monad (when)+import qualified Language.Scheme.Core as LSC -- Scheme Interpreter+import Language.Scheme.Types -- Scheme data types+import qualified Language.Scheme.Util as LSU (strip)+import qualified Language.Scheme.Variables as LSV -- Scheme variable operations import Control.Monad.Error+import qualified Data.Char as DC+import qualified Data.List as DL import System.Cmd (system) import System.Console.GetOpt-import System.Console.Haskeline+import qualified System.Console.Haskeline as HL+import qualified System.Console.Haskeline.Completion as HLC import System.Environment import System.Exit (ExitCode (..), exitWith, exitFailure) import System.IO@@ -36,11 +38,14 @@ if null nonOpts then do - showBanner+ LSC.showBanner runRepl schemeRev else runOne schemeRev nonOpts +-- -- Command line options section+--+ data Options = Options { optSchemeRev :: String -- RxRS version }@@ -78,26 +83,31 @@ putStrLn "" exitWith ExitSuccess +-- -- REPL Section+--+ flushStr :: String -> IO () flushStr str = putStr str >> hFlush stdout -- |Execute a single scheme file from the command line runOne :: String -> [String] -> IO () runOne _ args = do- env <- r5rsEnv >>= flip extendEnv- [((varNamespace, "args"),+ env <- LSC.r5rsEnv >>= flip LSV.extendEnv+ [((LSV.varNamespace, "args"), List $ map String $ drop 1 args)] - result <- (runIOThrows $ liftM show $ evalLisp env (List [Atom "load", String (args !! 0)]))+ result <- (LSC.runIOThrows $ liftM show $ + LSC.evalLisp env (List [Atom "load", String (args !! 0)])) case result of Just errMsg -> putStrLn errMsg _ -> do -- Call into (main) if it exists...- alreadyDefined <- liftIO $ isBound env "main"+ alreadyDefined <- liftIO $ LSV.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]]))+ mainResult <- (LSC.runIOThrows $ liftM show $ + LSC.evalLisp env (List [Atom "main", List [Atom "quote", argv]])) case mainResult of Just errMsg -> putStrLn errMsg _ -> return ())@@ -105,30 +115,73 @@ -- |Start the REPL (interactive interpreter) runRepl :: String -> IO () runRepl _ = do- env <- r5rsEnv+ env <- LSC.r5rsEnv - runInputT defaultSettings (loop env)+ let settings = HL.Settings (completeScheme env) Nothing True+ HL.runInputT settings (loop env) where- loop :: Env -> InputT IO ()+ loop :: Env -> HL.InputT IO () loop env = do- minput <- getInputLine "huski> "+ minput <- HL.getInputLine "huski> " case minput of Nothing -> return ()- Just "quit" -> return ()- Just "" -> loop env -- FUTURE: integrate with strip to ignore inputs of just whitespace- Just input -> do result <- liftIO (evalString env input)- if (length result) > 0- then do outputStrLn result- loop env- else loop env--- End REPL Section+ Just i -> do + case LSU.strip i of+ "quit" -> return ()+ "" -> loop env -- ignore inputs of just whitespace+ input -> do+ result <- liftIO (LSC.evalString env input)+ if (length result) > 0+ then do HL.outputStrLn result+ loop env+ else loop env --- Begin Util section, of generic functions+-- |Auto-complete using scheme symbols+completeScheme env (lnL, lnR) = do+ complete $ reverse $ readAtom lnL+ where+ complete ('"' : _) = do+ -- Special case, inside a string it seems more+ -- useful to autocomplete filenames+ liftIO $ HLC.completeFilename (lnL, lnR) -{- 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'])+ complete pre = do+ -- Get list of possible completions from ENV+ xps <- LSV.recExportsFromEnv env+ let allDefs = xps ++ specialForms+ let allDefs' = filter (\ (Atom a) -> DL.isPrefixOf pre a) allDefs+ let comps = map (\ (Atom a) -> HL.Completion a a False) allDefs' --- End Util+ -- Get unused portion of the left-hand string+ let unusedLnL = case DL.stripPrefix (reverse pre) lnL of+ Just s -> s+ Nothing -> lnL+ return (unusedLnL, comps)++ -- Not loaded into an env, so we need to list them here+ specialForms = map (\ s -> Atom s) [ + "define" + , "define-syntax" + , "expand"+ , "hash-table-delete!"+ , "hash-table-set!"+ , "if"+ , "lambda"+ , "let-syntax" + , "letrec-syntax" + , "quote"+ , "set!"+ , "set-car!"+ , "set-cdr!"+ , "string-set!"+ , "vector-set!"]++ -- Read until the end of the current symbol (atom), if there is one.+ -- There is also a special case for files if a double-quote is found.+ readAtom (c:cs)+ | c == '"' = ['"'] -- Save to indicate file completion to caller+ | c == '(' = []+ | c == '[' = []+ | DC.isSpace(c) = []+ | otherwise = (c : readAtom cs)+ readAtom [] = []
hs-src/Language/Scheme/Compiler.hs view
@@ -69,23 +69,27 @@ import Data.Word -- import Debug.Trace --- Define imports var here as an empty list.--- This list is appended to by (load-ffi) instances,--- and the imports are explicitly added later on...+-- |Perform one-time initialization of the compiler's environment initializeCompiler :: Env -> IOThrowsError [HaskAST] initializeCompiler env = do+ -- Define imports var here as an empty list.+ -- This list is appended to by (load-ffi) instances,+ -- and the imports are explicitly added later on... _ <- defineNamespacedVar env 't' {-"internal"-} "imports" $ List [] return [] --compileLisp :: Env -> String -> String -> Maybe String -> IOThrowsError [HaskAST]+-- | Compile a file containing scheme code+compileLisp + :: Env -- ^ Compiler environment + -> String -- ^ Filename+ -> String -- ^ Function entry point (code calls into this function)+ -> Maybe String -- ^ Function exit point, if any+ -> IOThrowsError [HaskAST] compileLisp env filename entryPoint exitPoint = do filename' <- LSC.findFileOrLib filename load filename' >>= compileBlock entryPoint exitPoint env []--- compileBlock------ Note: Uses explicit recursion to transform a block of code, because--- later lines may depend on previous ones++-- |Compile a list (block) of Scheme code compileBlock :: String -> Maybe String -> Env -> [HaskAST] -> [LispVal] -> IOThrowsError [HaskAST] compileBlock symThisFunc symLastFunc env result lisps = do@@ -106,13 +110,14 @@ -- TODO: could everything just be regular function calls except when a continuation is 'added to the stack' via a makeCPS(makeCPSWArgs ...) ?? I think this could be made more efficient --- Helper function to compile expressions consisting of a scalar+-- |Helper function to compile expressions consisting of a scalar compileScalar :: String -> CompOpts -> IOThrowsError [HaskAST] compileScalar val copts = do f <- return $ AstAssignM "x1" $ AstValue val c <- return $ createAstCont copts "x1" "" return [createAstFunc copts [f, c]] +-- |Compile the list of arguments for a function compileLambdaList :: [LispVal] -> IOThrowsError String compileLambdaList l = do serialized <- mapM serialize l @@ -246,6 +251,7 @@ (List [Atom "er-macro-transformer", (List (Atom "lambda" : List fparams : fbody))])]) copts = do+ _ <- validateFuncParams fparams (Just 3) compileSpecialFormBody env ast copts (\ _ -> do let fparamsStr = asts2Str fparams fbodyStr = asts2Str fbody@@ -360,6 +366,7 @@ compile env ast@(List (Atom "define" : List (Atom var : fparams) : fbody)) copts@(CompileOptions _ _ _ _) = do+ _ <- validateFuncParams fparams Nothing compileSpecialFormBody env ast copts (\ nextFunc -> do bodyEnv <- liftIO $ extendEnv env [] -- bind lambda params in the extended env@@ -386,6 +393,7 @@ compile env ast@(List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) copts@(CompileOptions _ _ _ _) = do+ _ <- validateFuncParams (fparams ++ [varargs]) Nothing compileSpecialFormBody env ast copts (\ nextFunc -> do bodyEnv <- liftIO $ extendEnv env [] -- bind lambda params in the extended env@@ -409,6 +417,7 @@ compile env ast@(List (Atom "lambda" : List fparams : fbody)) copts@(CompileOptions _ _ _ _) = do+ _ <- validateFuncParams fparams Nothing compileSpecialFormBody env ast copts (\ nextFunc -> do Atom symCallfunc <- _gensym "lambdaFuncEntryPt" compiledParams <- compileLambdaList fparams@@ -429,6 +438,7 @@ compile env ast@(List (Atom "lambda" : DottedList fparams varargs : fbody)) copts@(CompileOptions _ _ _ _) = do+ _ <- validateFuncParams (fparams ++ [varargs]) Nothing compileSpecialFormBody env ast copts (\ nextFunc -> do Atom symCallfunc <- _gensym "lambdaFuncEntryPt" compiledParams <- compileLambdaList fparams@@ -902,10 +912,12 @@ [AstValue $ " " ++ formNext ++ " env cont (" ++ val ++ ") " ++ args] return $ createAstFunc copts f +-- |Create the function entry point for a special form compileSpecialFormEntryPoint :: String -> String -> CompOpts -> IOThrowsError HaskAST compileSpecialFormEntryPoint formName formSym copts = do compileSpecialForm formName ("do " ++ formSym ++ " env cont (Nil \"\") []") copts +-- | Helper function for compiling a special form compileSpecialForm :: String -> String -> CompOpts -> IOThrowsError HaskAST compileSpecialForm formName formCode copts = do f <- return $ [@@ -923,8 +935,8 @@ True -> mfunc env ast compileApply copts False -> spForm nextFunc --- Compile an intermediate expression (such as an arg to if) and --- call into the next continuation with it's value+-- | Compile an intermediate expression (such as an arg to if) and +-- call into the next continuation with it's value compileExpr :: Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST] compileExpr env expr symThisFunc fForNextExpr = do mcompile env expr (CompileOptions symThisFunc False False fForNextExpr)
hs-src/Language/Scheme/Compiler/Libraries.hs view
@@ -111,6 +111,8 @@ -- TODO: This really should be handled by the add-module! that is executed during -- module initialization, instead of having a special case here AstValue $ " r5 <- liftIO $ r5rsEnv\n let value = LispEnv r5"+ codeToGetFromEnv (List [Atom "scheme", Atom "time", Atom "posix"]) _ = do+ AstValue $ " e <- liftIO $ r7rsTimeEnv\n let value = LispEnv e" codeToGetFromEnv name [] = do -- No code was generated because module was loaded previously, so retrieve
hs-src/Language/Scheme/Compiler/Types.hs view
@@ -64,6 +64,7 @@ -- to this function. } +-- |The default compiler options defaultCompileOptions :: String -> CompOpts defaultCompileOptions thisFunc = CompileOptions thisFunc False False Nothing @@ -170,7 +171,9 @@ asts2Str ls = do "[" ++ (joinL (map ast2Str ls) ",") ++ "]" -headerComment, headerModule, headerImports :: [String]+-- |Header comment used at the top of a Haskell program generated+-- by the compiler+headerComment:: [String] headerComment = [ "--" , "-- This file was automatically generated by the husk scheme compiler (huskc)"@@ -180,7 +183,12 @@ , "-- Version " ++ LSC.version , "--"] +-- |Main module used in a compiled Haskell program+headerModule :: [String] headerModule = ["module Main where "]++-- |Imports used for a compiled program+headerImports :: [String] headerImports = [ "Language.Scheme.Core " , "Language.Scheme.Numerical "@@ -196,6 +204,8 @@ , "Data.Word " , "System.IO "] +-- |Block of code used in the header of a Haskell program +-- generated by the compiler. header :: String -> Bool -> [String] header filepath useCompiledLibs = do let env = if useCompiledLibs
hs-src/Language/Scheme/Core.hs view
@@ -29,6 +29,7 @@ , r5rsEnv , r5rsEnv' -- , r7rsEnv+ , r7rsTimeEnv , version -- * Utility functions , findFileOrLib@@ -66,7 +67,7 @@ -- |husk version number version :: String-version = "3.11"+version = "3.12" -- |A utility function to display the husk console banner showBanner :: IO ()@@ -397,6 +398,7 @@ -- TODO: ensure fparams is 3 atoms -- TODO: now just need to figure out initial entry point to the ER func -- for now can ignore complications of an ER found during syn-rules transformation+ _ <- validateFuncParams fparams (Just 3) f <- makeNormalFunc env fparams fbody _ <- defineNamespacedVar env macroNamespace keyword $ SyntaxExplicitRenaming f continueEval env cont $ Nil "" @@ -480,6 +482,7 @@ if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it else do + _ <- validateFuncParams fparams Nothing -- Cache macro expansions within function body ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody result <- (makeNormalFunc env fparams ebody >>= defineVar env var)@@ -490,6 +493,7 @@ if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it else do + _ <- validateFuncParams (fparams ++ [varargs]) Nothing ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody result <- (makeVarargs varargs env fparams ebody >>= defineVar env var) continueEval env cont result@@ -499,6 +503,7 @@ if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it else do + _ <- validateFuncParams fparams Nothing ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody result <- makeNormalFunc env fparams ebody continueEval env cont result@@ -508,6 +513,7 @@ if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it else do + _ <- validateFuncParams (fparams ++ [varargs]) Nothing ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody result <- makeVarargs varargs env fparams ebody continueEval env cont result@@ -970,6 +976,8 @@ -- Load (r5rs base) _ <- evalString metaEnv "(add-module! '(scheme r5rs) (make-module #f (interaction-environment) '()))"+ timeEnv <- liftIO $ r7rsTimeEnv+ _ <- evalLisp' metaEnv $ List [Atom "add-module!", List [Atom "quote", List [Atom "scheme", Atom "time", Atom "posix"]], List [Atom "make-module", Bool False, LispEnv timeEnv, List [Atom "quote", List []]]] #endif return env@@ -1009,6 +1017,13 @@ "(add-module! '(scheme r5rs) (make-module #f (interaction-environment) '()))" return env +-- | Load haskell bindings used for the r7rs time library+r7rsTimeEnv :: IO Env+r7rsTimeEnv = do+ nullEnv >>= + (flip extendEnv + [ ((varNamespace, "current-second"), IOFunc currentTimestamp)])+ -- Functions that extend the core evaluator, but that can be defined separately. -- {- These functions have access to the current environment via the@@ -1334,6 +1349,7 @@ ("read-contents", readContents), ("read-all", readAll), ("find-module-file", findModuleFile),+ ("system", system), ("gensym", gensym)] -- TODO:
hs-src/Language/Scheme/Libraries.hs view
@@ -46,7 +46,7 @@ -- TODO: scheme case-lambda (r7rs) -- TODO: scheme process-context (r7rs) -- TODO: scheme repl (r7rs)--- TODO: scheme time (r7rs)+ file == "scheme/time.sld" || file == "scheme/write.sld" = do path <- liftIO $ PHS.getDataFileName $ "lib/" ++ file return $ String path
hs-src/Language/Scheme/Parser.hs view
@@ -337,29 +337,36 @@ parseDottedList :: Parser LispVal parseDottedList = do phead <- endBy parseExpr whiteSpace- ptail <- dot >> parseExpr --char '.' >> whiteSpace >> parseExpr--- return $ DottedList phead ptail- case ptail of- DottedList ls l -> return $ DottedList (phead ++ ls) l - -- Issue #41- -- Improper lists are tricky because if an improper list ends in a proper list, then it becomes proper as well.- -- The following cases handle that, as well as preserving necessary functionality when appropriate, such as for- -- unquoting.- --- -- FUTURE: I am not sure if this is complete, in fact the "unquote" seems like it could either be incorrect or- -- one special case among others. Anyway, for the 3.3 release this is good enough to pass all test- -- cases. It will be revisited later if necessary.- --- List (Atom "unquote" : _) -> return $ DottedList phead ptail - List ls -> return $ List $ phead ++ ls- {- Regarding above, see http://community.schemewiki.org/?scheme-faq-language#dottedapp- - Note, however, that most Schemes expand literal lists occurring in function applications, - e.g. (foo bar . (1 2 3)) is expanded into (foo bar 1 2 3) by the reader. It is not entirely - clear whether this is a consequence of the standard - the notation is not part of the R5RS - grammar but there is strong evidence to suggest a Scheme implementation cannot comply with - all of R5RS without performing this transformation. -}- _ -> return $ DottedList phead ptail+ case phead of+ [] -> pzero -- car is required; no match + _ -> do+ ptail <- dot >> parseExpr+ case ptail of+ DottedList ls l -> return $ DottedList (phead ++ ls) l + -- Issue #41+ -- Improper lists are tricky because if an improper list ends in a + -- proper list, then it becomes proper as well. The following cases + -- handle that, as well as preserving necessary functionality when + -- appropriate, such as for unquoting.+ --+ -- FUTURE: I am not sure if this is complete, in fact the "unquote" + -- seems like it could either be incorrect or one special case among + -- others. Anyway, for the 3.3 release this is good enough to pass all+ -- test cases. It will be revisited later if necessary.+ --+ List (Atom "unquote" : _) -> return $ DottedList phead ptail + List ls -> return $ List $ phead ++ ls+ {- Regarding above, see + http://community.schemewiki.org/?scheme-faq-language#dottedapp+ + Note, however, that most Schemes expand literal lists occurring in + function applications, e.g. (foo bar . (1 2 3)) is expanded into + (foo bar 1 2 3) by the reader. It is not entirely clear whether this + is a consequence of the standard - the notation is not part of the + R5RS grammar but there is strong evidence to suggest a Scheme + implementation cannot comply with all of R5RS without performing this+ transformation. -}+ _ -> return $ DottedList phead ptail -- |Parse a quoted expression parseQuoted :: Parser LispVal
hs-src/Language/Scheme/Primitives.hs view
@@ -122,6 +122,11 @@ -- ** Symbol generation , gensym , _gensym+ -- ** Time+ , currentTimestamp+ -- ** System+ , system+ ) where import Language.Scheme.Numerical import Language.Scheme.Parser@@ -135,9 +140,12 @@ import Data.Array import Data.Unique import qualified Data.Map+import qualified Data.Time.Clock.POSIX import Data.Word-import System.IO+import qualified System.Cmd import System.Directory (doesFileExist, removeFile)+import System.Exit (ExitCode(..))+import System.IO import System.IO.Error -- import Debug.Trace @@ -152,31 +160,87 @@ -- These primitives all execute within the IO monad --------------------------------------------------- +-- |Open the given file+--+-- LispVal Arguments:+--+-- * String - filename+--+-- Returns: Port+-- makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode makePort mode [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= makePort mode makePort _ [] = throwError $ NumArgs (Just 1) [] makePort _ args@(_ : _) = throwError $ NumArgs (Just 1) args +-- |Close the given port+--+-- Arguments:+--+-- * Port+--+-- Returns: Bool - True if the port was closed, false otherwise+-- closePort :: [LispVal] -> IOThrowsError LispVal closePort [Port port] = liftIO $ hClose port >> (return $ Bool True) 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* -}++-- |Return the current input port+--+-- LispVal Arguments: (None)+--+-- Returns: Port+--+currentInputPort :: [LispVal] -> IOThrowsError LispVal currentInputPort _ = return $ Port stdin+-- |Return the current input port+--+-- LispVal Arguments: (None)+--+-- Returns: Port+--+currentOutputPort :: [LispVal] -> IOThrowsError LispVal currentOutputPort _ = return $ Port stdout -isInputPort, isOutputPort :: [LispVal] -> IOThrowsError LispVal+-- |Determine if the given objects is an input port+--+-- LispVal Arguments:+--+-- * Port+--+-- Returns: Bool - True if an input port, false otherwise+--+isInputPort :: [LispVal] -> IOThrowsError LispVal isInputPort [Port port] = liftM Bool $ liftIO $ hIsReadable port isInputPort _ = return $ Bool False +-- |Determine if the given objects is an output port+--+-- LispVal Arguments:+--+-- * Port+--+-- Returns: Bool - True if an output port, false otherwise+--+isOutputPort :: [LispVal] -> IOThrowsError LispVal isOutputPort [Port port] = liftM Bool $ liftIO $ hIsWritable port isOutputPort _ = return $ Bool False +-- |Determine if a character is ready on the port+--+-- LispVal Arguments:+--+-- * Port+--+-- Returns: Bool+-- isCharReady :: [LispVal] -> IOThrowsError LispVal isCharReady [Port port] = do --liftM Bool $ liftIO $ hReady port result <- liftIO $ try' (liftIO $ hReady port)@@ -187,6 +251,14 @@ Right _ -> return $ Bool True isCharReady _ = return $ Bool False +-- |Read from the given port+--+-- LispVal Arguments:+--+-- * Port+--+-- Returns: LispVal+-- readProc :: [LispVal] -> IOThrowsError LispVal readProc [] = readProc [Port stdin] readProc [Port port] = do@@ -199,6 +271,14 @@ liftThrows $ readExpr inpStr readProc args@(_ : _) = throwError $ BadSpecialForm "" $ List args +-- |Read character from port+--+-- LispVal Arguments:+--+-- * Port+--+-- Returns: Char+-- readCharProc :: (Handle -> IO Char) -> [LispVal] -> IOThrowsError LispVal readCharProc func [] = readCharProc func [Port stdin] readCharProc func [Port port] = do@@ -213,6 +293,16 @@ return $ Char inpChr readCharProc _ args@(_ : _) = throwError $ BadSpecialForm "" $ List args +-- |Write to the given port+--+-- LispVal Arguments:+--+-- * LispVal+--+-- * Port (optional)+--+-- Returns: (None)+-- {- writeProc :: --forall a (m :: * -> *). (MonadIO m, MonadError LispError m) => (Handle -> LispVal -> IO a) -> [LispVal] -> m LispVal -}@@ -229,6 +319,16 @@ then throwError $ TypeMismatch "(value port)" $ List other else throwError $ NumArgs (Just 2) other +-- |Write character to the given port+--+-- Arguments:+--+-- * Char - Value to write+--+-- * Port (optional) - Port to write to, defaults to standard output+--+-- Returns: (None)+-- writeCharProc :: [LispVal] -> IOThrowsError LispVal writeCharProc [obj] = writeCharProc [obj, Port stdout] writeCharProc [obj@(Char _), Port port] = do@@ -240,7 +340,15 @@ then throwError $ TypeMismatch "(character port)" $ List other else throwError $ NumArgs (Just 2) other -fileExists, deleteFile :: [LispVal] -> IOThrowsError LispVal+-- |Determine if the given file exists+--+-- Arguments:+--+-- * String - Filename to check+--+-- Returns: Bool - True if file exists, false otherwise+--+fileExists :: [LispVal] -> IOThrowsError LispVal fileExists [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= fileExists fileExists [String filename] = do exists <- liftIO $ doesFileExist filename@@ -248,6 +356,15 @@ fileExists [] = throwError $ NumArgs (Just 1) [] fileExists args@(_ : _) = throwError $ NumArgs (Just 1) args +-- |Delete the given file+--+-- Arguments:+--+-- * String - Filename to delete+--+-- Returns: Bool - True if file was deleted, false if an error occurred+--+deleteFile :: [LispVal] -> IOThrowsError LispVal deleteFile [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= deleteFile deleteFile [String filename] = do output <- liftIO $ try' (liftIO $ removeFile filename)@@ -257,19 +374,51 @@ deleteFile [] = throwError $ NumArgs (Just 1) [] deleteFile args@(_ : _) = throwError $ NumArgs (Just 1) args +-- |Read the given file and return the raw string content +--+-- Arguments:+--+-- * String - Filename to read+--+-- Returns: String - Actual text read from the file+-- readContents :: [LispVal] -> IOThrowsError LispVal readContents [String filename] = liftM String $ liftIO $ readFile filename readContents [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= readContents readContents [] = throwError $ NumArgs (Just 1) [] readContents args@(_ : _) = throwError $ NumArgs (Just 1) args +-- |Parse the given file and return a list of scheme expressions+--+-- Arguments:+--+-- * String - Filename to read+--+-- Returns: [LispVal] - Raw contents of the file parsed as scheme code+-- load :: String -> IOThrowsError [LispVal] load filename = do result <- liftIO $ doesFileExist filename if result- then (liftIO $ readFile filename) >>= liftThrows . readExprList+ then do+ f <- liftIO $ readFile filename++ case lines f of+ -- Skip comment header for shell scripts+ -- TODO: this could be much more robust+ (('#':'!':'/' : _) : ls) -> liftThrows . readExprList $ unlines ls+ (('#':'!':' ':'/' : _) : ls) -> liftThrows . readExprList $ unlines ls+ _ -> (liftThrows . readExprList) f else throwError $ Default $ "File does not exist: " ++ filename +-- | Read the contents of the given scheme source file into a list+--+-- Arguments:+--+-- * String - Filename to read+--+-- Returns: List - Raw contents of the file parsed as scheme code+-- readAll :: [LispVal] -> IOThrowsError LispVal readAll [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= readAll readAll [String filename] = liftM List $ load filename@@ -284,6 +433,13 @@ -- |Generate a (reasonably) unique symbol, given an optional prefix. -- This function is provided even though it is not part of R5RS.+--+-- Arguments:+--+-- * String - Prefix of the unique symbol+--+-- Returns: Atom+-- gensym :: [LispVal] -> IOThrowsError LispVal gensym [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= gensym gensym [String prefix] = _gensym prefix@@ -296,6 +452,15 @@ --------------------------------------------------- -- List primitives++-- | Retrieve the first item from a list+--+-- Arguments:+--+-- * List (or DottedList)+--+-- Returns: LispVal - First item in the list+-- car :: [LispVal] -> IOThrowsError LispVal car [p@(Pointer _ _)] = derefPtr p >>= box >>= car car [List (x : _)] = return x@@ -303,6 +468,14 @@ car [badArg] = throwError $ TypeMismatch "pair" badArg car badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Return the "tail" of a list, with the first element removed+--+-- Arguments:+--+-- * List (or DottedList)+--+-- Returns: List (or DottedList)+-- cdr :: [LispVal] -> IOThrowsError LispVal cdr [p@(Pointer _ _)] = derefPtr p >>= box >>= cdr cdr [List (_ : xs)] = return $ List xs@@ -311,6 +484,16 @@ cdr [badArg] = throwError $ TypeMismatch "pair" badArg cdr badArgList = throwError $ NumArgs (Just 1) badArgList +-- | The LISP "cons" operation - create a list from two values+--+-- Arguments:+--+-- * LispVal+--+-- * LispVal+--+-- Returns: List (or DottedList) containing new value(s)+-- cons :: [LispVal] -> IOThrowsError LispVal cons [x, p@(Pointer _ _)] = do y <- derefPtr p@@ -321,6 +504,16 @@ cons [x1, x2] = return $ DottedList [x1] x2 cons badArgList = throwError $ NumArgs (Just 2) badArgList +-- | Recursively compare two LispVals for equality+--+-- Arguments:+--+-- * LispVal+--+-- * LispVal+--+-- Returns: Bool - True if equal, false otherwise+-- equal :: [LispVal] -> ThrowsError LispVal equal [(Vector arg1), (Vector arg2)] = eqvList equal [List $ (elems arg1), List $ (elems arg2)] equal [l1@(List _), l2@(List _)] = eqvList equal [l1, l2]@@ -334,7 +527,17 @@ -- ------------ Vector Primitives -------------- -makeVector, buildVector, vectorLength, vectorRef, vectorToList, listToVector :: [LispVal] -> ThrowsError LispVal+-- | Create a new vector+--+-- Arguments:+--+-- * Number - Length of the vector+--+-- * LispVal - Value to fill the vector with+--+-- Returns: Vector+--+makeVector :: [LispVal] -> ThrowsError LispVal makeVector [(Number n)] = makeVector [Number n, List []] makeVector [(Number n), a] = do let l = replicate (fromInteger n) a@@ -342,14 +545,43 @@ makeVector [badType] = throwError $ TypeMismatch "integer" badType makeVector badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Create a vector from the given lisp values+--+-- Arguments:+--+-- * LispVal (s)+--+-- Returns: Vector+--+buildVector :: [LispVal] -> ThrowsError LispVal buildVector lst@(o : os) = do return $ Vector $ (listArray (0, length lst - 1)) lst buildVector badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Determine the length of the given vector+--+-- Arguments:+--+-- * Vector+--+-- Returns: Number+--+vectorLength :: [LispVal] -> ThrowsError LispVal vectorLength [(Vector v)] = return $ Number $ toInteger $ length (elems v) vectorLength [badType] = throwError $ TypeMismatch "vector" badType vectorLength badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Retrieve the object at the given position of a vector+--+-- Arguments:+--+-- * Vector+--+-- * Number - Index of the vector to retrieve+--+-- Returns: Object at the given index+--+vectorRef :: [LispVal] -> ThrowsError LispVal vectorRef [(Vector v), (Number n)] = do let len = toInteger $ (length $ elems v) - 1 if n > len || n < 0@@ -358,16 +590,45 @@ vectorRef [badType] = throwError $ TypeMismatch "vector integer" badType vectorRef badArgList = throwError $ NumArgs (Just 2) badArgList +-- | Convert the given vector to a list+--+-- Arguments:+--+-- * Vector+--+-- Returns: List+--+vectorToList :: [LispVal] -> ThrowsError LispVal vectorToList [(Vector v)] = return $ List $ elems v vectorToList [badType] = throwError $ TypeMismatch "vector" badType vectorToList badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Convert the given list to a vector+--+-- Arguments:+--+-- * List to convert+--+-- Returns: Vector+--+listToVector :: [LispVal] -> ThrowsError LispVal listToVector [(List l)] = return $ Vector $ (listArray (0, length l - 1)) l listToVector [badType] = throwError $ TypeMismatch "list" badType listToVector badArgList = throwError $ NumArgs (Just 1) badArgList -- ------------ Bytevector Primitives ---------------makeByteVector, byteVector :: [LispVal] -> ThrowsError LispVal++-- | Create a new bytevector+--+-- Arguments:+--+-- * Number - Length of the new bytevector+--+-- * Number (optional) - Byte value to fill the bytevector with+--+-- Returns: ByteVector - A new bytevector+--+makeByteVector :: [LispVal] -> ThrowsError LispVal makeByteVector [(Number n)] = do let ls = replicate (fromInteger n) (0 :: Word8) return $ ByteVector $ BS.pack ls@@ -377,13 +638,35 @@ makeByteVector [badType] = throwError $ TypeMismatch "integer" badType makeByteVector badArgList = throwError $ NumArgs (Just 2) badArgList +-- | Create new bytevector containing the given data+--+-- Arguments:+--+-- * Objects - Objects to convert to bytes for the bytevector+--+-- Returns: ByteVector - A new bytevector+--+byteVector :: [LispVal] -> ThrowsError LispVal byteVector bs = do return $ ByteVector $ BS.pack $ map conv bs where conv (Number n) = fromInteger n :: Word8 conv n = 0 :: Word8 -byteVectorLength, byteVectorRef, byteVectorCopy, byteVectorAppend, byteVectorUtf2Str :: [LispVal] -> IOThrowsError LispVal+byteVectorCopy :: [LispVal] -> IOThrowsError LispVal++-- | Create a copy of the given bytevector+--+-- Arguments:+--+-- * ByteVector - Bytevector to copy+--+-- * Number (optional) - Start of the region to copy+--+-- * Number (optional) - End of the region to copy+--+-- Returns: ByteVector - A new bytevector containing the copied region+-- byteVectorCopy (p@(Pointer _ _) : lvs) = do bv <- derefPtr p byteVectorCopy (bv : lvs)@@ -403,6 +686,15 @@ byteVectorCopy [badType] = throwError $ TypeMismatch "bytevector" badType byteVectorCopy badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Append many bytevectors into a new bytevector+--+-- Arguments:+--+-- * ByteVector (one or more) - Bytevectors to concatenate+--+-- Returns: ByteVector - A new bytevector containing the values+--+byteVectorAppend :: [LispVal] -> IOThrowsError LispVal byteVectorAppend bs = do let acc = BS.pack [] conv :: LispVal -> IOThrowsError BSU.ByteString@@ -415,11 +707,31 @@ return $ ByteVector $ BS.concat bs' -- TODO: error handling +-- | Find the length of a bytevector+--+-- Arguments:+--+-- * ByteVector+--+-- Returns: Number - Length of the given bytevector+--+byteVectorLength :: [LispVal] -> IOThrowsError LispVal byteVectorLength [p@(Pointer _ _)] = derefPtr p >>= box >>= byteVectorLength byteVectorLength [(ByteVector bv)] = return $ Number $ toInteger $ BS.length bv byteVectorLength [badType] = throwError $ TypeMismatch "bytevector" badType byteVectorLength badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Return object at the given index of a bytevector+--+-- Arguments:+--+-- * ByteVector+--+-- * Number - Index of the bytevector to query+--+-- Returns: Object at the index+--+byteVectorRef :: [LispVal] -> IOThrowsError LispVal byteVectorRef (p@(Pointer _ _) : lvs) = do bv <- derefPtr p byteVectorRef (bv : lvs)@@ -431,6 +743,15 @@ byteVectorRef [badType] = throwError $ TypeMismatch "bytevector integer" badType byteVectorRef badArgList = throwError $ NumArgs (Just 2) badArgList +-- | Convert a bytevector to a string+--+-- Arguments:+--+-- * ByteVector+--+-- Returns: String+--+byteVectorUtf2Str :: [LispVal] -> IOThrowsError LispVal byteVectorUtf2Str [p@(Pointer _ _)] = derefPtr p >>= box >>= byteVectorUtf2Str byteVectorUtf2Str [(ByteVector bv)] = do return $ String $ BSU.toString bv @@ -438,6 +759,14 @@ byteVectorUtf2Str [badType] = throwError $ TypeMismatch "bytevector" badType byteVectorUtf2Str badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Convert a string to a bytevector+--+-- Arguments:+--+-- * String+--+-- Returns: ByteVector+-- byteVectorStr2Utf :: [LispVal] -> IOThrowsError LispVal byteVectorStr2Utf [p@(Pointer _ _)] = derefPtr p >>= box >>= byteVectorStr2Utf byteVectorStr2Utf [(String s)] = do@@ -449,7 +778,11 @@ -- ------------ Ptr Helper Primitives -------------- -wrapHashTbl, wrapLeadObj :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> IOThrowsError LispVal+-- | A helper function to allow a pure function to work with pointers, by+-- dereferencing the leading object in the argument list if it is+-- a pointer. This is a special hash-table specific function that will+-- also dereference a hash table key if it is included.+wrapHashTbl :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> IOThrowsError LispVal wrapHashTbl fnc [p@(Pointer _ _)] = do val <- derefPtr p liftThrows $ fnc [val]@@ -459,6 +792,10 @@ liftThrows $ fnc (ht : k : args) wrapHashTbl fnc args = liftThrows $ fnc args +-- | A helper function to allow a pure function to work with pointers, by+-- dereferencing the leading object in the argument list if it is+-- a pointer.+wrapLeadObj :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> IOThrowsError LispVal wrapLeadObj fnc [p@(Pointer _ _)] = do val <- derefPtr p liftThrows $ fnc [val]@@ -470,12 +807,39 @@ -- ------------ Hash Table Primitives -------------- -- Future: support (equal?), (hash) parameters-hashTblMake, isHashTbl, hashTblExists, hashTblRef, hashTblSize, hashTbl2List, hashTblKeys, hashTblValues, hashTblCopy :: [LispVal] -> ThrowsError LispVal++-- | Create a new hashtable+--+-- Arguments: (None)+--+-- Returns: HashTable+--+hashTblMake :: [LispVal] -> ThrowsError LispVal hashTblMake _ = return $ HashTable $ Data.Map.fromList [] +-- | Determine if a given object is a hashtable+--+-- Arguments:+--+-- * Object to inspect+--+-- Returns: Bool - True if arg was a hashtable, false otherwise+--+isHashTbl :: [LispVal] -> ThrowsError LispVal isHashTbl [(HashTable _)] = return $ Bool True isHashTbl _ = return $ Bool False +-- | Determine if the given key is found in the hashtable+--+-- Arguments:+--+-- * HashTable to search+--+-- * Key to search for+--+-- Returns: Bool - True if found, False otherwise+--+hashTblExists :: [LispVal] -> ThrowsError LispVal hashTblExists [(HashTable ht), key@(_)] = do case Data.Map.lookup key ht of Just _ -> return $ Bool True@@ -483,6 +847,18 @@ hashTblExists [] = throwError $ NumArgs (Just 2) [] hashTblExists args@(_ : _) = throwError $ NumArgs (Just 2) args +-- | Retrieve the value from the hashtable for the given key.+-- An error is thrown if the key is not found.+--+-- Arguments:+--+-- * HashTable to copy+--+-- * Object that is the key to query the table for+--+-- Returns: Object containing the key's value+--+hashTblRef :: [LispVal] -> ThrowsError LispVal hashTblRef [(HashTable ht), key@(_)] = do case Data.Map.lookup key ht of Just val -> return val@@ -496,25 +872,70 @@ hashTblRef [badType] = throwError $ TypeMismatch "hash-table" badType hashTblRef badArgList = throwError $ NumArgs (Just 2) badArgList +-- | Return the number of key/value associations in the hashtable+--+-- Arguments:+--+-- * HashTable+--+-- Returns: Number - number of associations+--+hashTblSize :: [LispVal] -> ThrowsError LispVal hashTblSize [(HashTable ht)] = return $ Number $ toInteger $ Data.Map.size ht hashTblSize [badType] = throwError $ TypeMismatch "hash-table" badType hashTblSize badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Create a list containing all key/value pairs in the hashtable+--+-- Arguments:+--+-- * HashTable+--+-- Returns: List of (key, value) pairs+--+hashTbl2List :: [LispVal] -> ThrowsError LispVal hashTbl2List [(HashTable ht)] = do return $ List $ map (\ (k, v) -> List [k, v]) $ Data.Map.toList ht hashTbl2List [badType] = throwError $ TypeMismatch "hash-table" badType hashTbl2List badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Create a list containing all keys in the hashtable+--+-- Arguments:+--+-- * HashTable+--+-- Returns: List containing the keys+--+hashTblKeys :: [LispVal] -> ThrowsError LispVal hashTblKeys [(HashTable ht)] = do return $ List $ map (\ (k, _) -> k) $ Data.Map.toList ht hashTblKeys [badType] = throwError $ TypeMismatch "hash-table" badType hashTblKeys badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Create a list containing all values in the hashtable+--+-- Arguments:+--+-- * HashTable+--+-- Returns: List containing the values+--+hashTblValues :: [LispVal] -> ThrowsError LispVal hashTblValues [(HashTable ht)] = do return $ List $ map (\ (_, v) -> v) $ Data.Map.toList ht hashTblValues [badType] = throwError $ TypeMismatch "hash-table" badType hashTblValues badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Create a new copy of a hashtable+--+-- Arguments:+--+-- * HashTable to copy+--+-- Returns: HashTable+--+hashTblCopy :: [LispVal] -> ThrowsError LispVal hashTblCopy [(HashTable ht)] = do return $ HashTable $ Data.Map.fromList $ Data.Map.toList ht hashTblCopy [badType] = throwError $ TypeMismatch "hash-table" badType@@ -522,6 +943,14 @@ -- ------------ String Primitives -------------- +-- | Convert a list of characters to a string+--+-- Arguments:+--+-- * Character (one or more) - Character(s) to add to the string+--+-- Returns: String - new string built from given chars+-- buildString :: [LispVal] -> ThrowsError LispVal buildString [(Char c)] = return $ String [c] buildString (Char c : rest) = do@@ -532,23 +961,53 @@ buildString [badType] = throwError $ TypeMismatch "character" badType buildString badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Make a new string+--+-- Arguments:+--+-- * Number - number of characters in the string+--+-- * Char (optional) - Character to fill in each position of string.+-- Defaults to space+--+-- Returns: String - new string+-- makeString :: [LispVal] -> ThrowsError LispVal makeString [(Number n)] = return $ doMakeString n ' ' "" makeString [(Number n), (Char c)] = return $ doMakeString n c "" makeString badArgList = throwError $ NumArgs (Just 1) badArgList +-- |Helper function doMakeString :: forall a . (Num a, Eq a) => a -> Char -> String -> LispVal doMakeString n char s = if n == 0 then String s else doMakeString (n - 1) char (s ++ [char]) +-- | Determine the length of the given string+--+-- Arguments:+--+-- * String - String to examine+--+-- Returns: Number - Length of the given string+-- stringLength :: [LispVal] -> IOThrowsError LispVal stringLength [p@(Pointer _ _)] = derefPtr p >>= box >>= stringLength 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 (Just 1) badArgList +-- | Get character at the given position of a string+--+-- Arguments:+--+-- * String - String to examine+--+-- * Number - Get the character at this position+--+-- Returns: Char+-- stringRef :: [LispVal] -> IOThrowsError LispVal stringRef [p@(Pointer _ _), k@(Number _)] = do s <- derefPtr p @@ -557,6 +1016,18 @@ stringRef [badType] = throwError $ TypeMismatch "string number" badType stringRef badArgList = throwError $ NumArgs (Just 2) badArgList +-- | Get a part of the given string+--+-- Arguments:+--+-- * String - Original string+--+-- * Number - Starting position of the substring+--+-- * Number - Ending position of the substring+--+-- Returns: String - substring of the original string+-- substring :: [LispVal] -> IOThrowsError LispVal substring (p@(Pointer _ _) : lvs) = do s <- derefPtr p@@ -568,6 +1039,16 @@ substring [badType] = throwError $ TypeMismatch "string number number" badType substring badArgList = throwError $ NumArgs (Just 3) badArgList +-- | Perform a case insensitive comparison of the given strings+--+-- Arguments:+--+-- * String - String to compare+--+-- * String - String to compare+--+-- Returns: Bool - True if strings are equal, false otherwise+-- stringCIEquals :: [LispVal] -> IOThrowsError LispVal stringCIEquals args = do List dargs <- recDerefPtrs $ List args@@ -585,6 +1066,7 @@ then ciCmp s1 s2 (idx + 1) else False +-- |Helper function stringCIBoolBinop :: ([Char] -> [Char] -> Bool) -> [LispVal] -> IOThrowsError LispVal stringCIBoolBinop op args = do List dargs <- recDerefPtrs $ List args -- Deref any pointers@@ -595,11 +1077,20 @@ badArgList -> throwError $ NumArgs (Just 2) badArgList where strToLower str = map (toLower) str +-- |Helper function charCIBoolBinop :: (Char -> Char -> Bool) -> [LispVal] -> ThrowsError LispVal charCIBoolBinop op [(Char s1), (Char s2)] = boolBinop unpackChar op [(Char $ toLower s1), (Char $ toLower s2)] charCIBoolBinop _ [badType] = throwError $ TypeMismatch "character character" badType charCIBoolBinop _ badArgList = throwError $ NumArgs (Just 2) badArgList +-- | Append all given strings together into a single string+--+-- Arguments:+--+-- * String (one or more) - String(s) to concatenate+--+-- Returns: String - all given strings appended together as a single string+-- stringAppend :: [LispVal] -> IOThrowsError LispVal stringAppend (p@(Pointer _ _) : lvs) = do s <- derefPtr p@@ -613,6 +1104,16 @@ stringAppend [badType] = throwError $ TypeMismatch "string" badType stringAppend badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Convert given string to a number+--+-- Arguments:+--+-- * String - String to convert+--+-- * Number (optional) - Number base to convert from, defaults to base 10 (decimal)+--+-- Returns: Numeric type, actual type will depend upon given string+-- stringToNumber :: [LispVal] -> IOThrowsError LispVal stringToNumber (p@(Pointer _ _) : lvs) = do s <- derefPtr p@@ -635,12 +1136,28 @@ stringToNumber [badType] = throwError $ TypeMismatch "string" badType stringToNumber badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Convert the given string to a list of chars+--+-- Arguments:+--+-- * String - string to deconstruct+--+-- Returns: List - list of characters+-- stringToList :: [LispVal] -> IOThrowsError LispVal stringToList [p@(Pointer _ _)] = derefPtr p >>= box >>= stringToList stringToList [(String s)] = return $ List $ map (Char) s stringToList [badType] = throwError $ TypeMismatch "string" badType stringToList badArgList = throwError $ NumArgs (Just 1) badArgList +-- | Convert the given list of characters to a string+--+-- Arguments:+--+-- * List - list of chars to convert+--+-- Returns: String - Resulting string+-- listToString :: [LispVal] -> IOThrowsError LispVal listToString [p@(Pointer _ _)] = derefPtr p >>= box >>= listToString listToString [(List [])] = return $ String ""@@ -649,12 +1166,28 @@ listToString [] = throwError $ NumArgs (Just 1) [] listToString args@(_ : _) = throwError $ NumArgs (Just 1) args +-- | Create a copy of the given string+--+-- Arguments:+--+-- * String - String to copy+--+-- Returns: String - New copy of the given string+-- stringCopy :: [LispVal] -> IOThrowsError LispVal stringCopy [p@(Pointer _ _)] = derefPtr p >>= box >>= stringCopy stringCopy [String s] = return $ String s stringCopy [badType] = throwError $ TypeMismatch "string" badType stringCopy badArgList = throwError $ NumArgs (Just 2) badArgList +-- | Determine if given object is an improper list+--+-- Arguments:+--+-- * Value to check+--+-- Returns: Bool - True if improper list, False otherwise+-- isDottedList :: [LispVal] -> IOThrowsError LispVal isDottedList ([p@(Pointer _ _)]) = derefPtr p >>= box >>= isDottedList isDottedList ([DottedList _ _]) = return $ Bool True@@ -663,6 +1196,14 @@ isDottedList ([List _]) = return $ Bool True isDottedList _ = return $ Bool False +-- | Determine if given object is a procedure+--+-- Arguments:+--+-- * Value to check+--+-- Returns: Bool - True if procedure, False otherwise+-- isProcedure :: [LispVal] -> ThrowsError LispVal isProcedure ([Continuation _ _ _ _ _]) = return $ Bool True isProcedure ([PrimitiveFunc _]) = return $ Bool True@@ -673,36 +1214,104 @@ isProcedure ([CustFunc _]) = return $ Bool True isProcedure _ = return $ Bool False -isVector,isByteVector, isList :: LispVal -> IOThrowsError LispVal+-- | Determine if given object is a bytevector+--+-- Arguments:+--+-- * Value to check+--+-- Returns: Bool - True if bytevector, False otherwise+--+isVector :: LispVal -> IOThrowsError LispVal isVector p@(Pointer _ _) = derefPtr p >>= isVector isVector (Vector _) = return $ Bool True isVector _ = return $ Bool False++-- | Determine if given object is a bytevector+--+-- Arguments:+--+-- * Value to check+--+-- Returns: Bool - True if bytevector, False otherwise+--+isByteVector :: LispVal -> IOThrowsError LispVal isByteVector p@(Pointer _ _) = derefPtr p >>= isVector isByteVector (ByteVector _) = return $ Bool True isByteVector _ = return $ Bool False++-- | Determine if given object is a list+--+-- Arguments:+--+-- * Value to check+--+-- Returns: Bool - True if list, False otherwise+--+isList :: LispVal -> IOThrowsError LispVal isList p@(Pointer _ _) = derefPtr p >>= isList isList (List _) = return $ Bool True isList _ = return $ Bool False +-- | Determine if given object is the null list+--+-- Arguments:+--+-- * Value to check+--+-- Returns: Bool - True if null list, False otherwise+-- isNull :: [LispVal] -> IOThrowsError LispVal isNull ([p@(Pointer _ _)]) = derefPtr p >>= box >>= isNull isNull ([List []]) = return $ Bool True isNull _ = return $ Bool False +-- | Determine if given object is the EOF marker+--+-- Arguments:+--+-- * Value to check+--+-- Returns: Bool - True if EOF, False otherwise+-- isEOFObject :: [LispVal] -> ThrowsError LispVal isEOFObject ([EOF]) = return $ Bool True isEOFObject _ = return $ Bool False +-- | Determine if given object is a symbol+--+-- Arguments:+--+-- * Value to check+--+-- Returns: Bool - True if a symbol, False otherwise+-- isSymbol :: [LispVal] -> ThrowsError LispVal isSymbol ([Atom _]) = return $ Bool True isSymbol _ = return $ Bool False +-- | Convert the given symbol to a string+--+-- Arguments:+--+-- * Atom - Symbol to convert+--+-- Returns: String+-- symbol2String :: [LispVal] -> ThrowsError LispVal symbol2String ([Atom a]) = return $ String a symbol2String [notAtom] = throwError $ TypeMismatch "symbol" notAtom symbol2String [] = throwError $ NumArgs (Just 1) [] symbol2String args@(_ : _) = throwError $ NumArgs (Just 1) args +-- | Convert a string to a symbol+--+-- Arguments:+--+-- * String (or pointer) - String to convert+--+-- Returns: Atom+-- string2Symbol :: [LispVal] -> IOThrowsError LispVal string2Symbol ([p@(Pointer _ _)]) = derefPtr p >>= box >>= string2Symbol string2Symbol ([String s]) = return $ Atom s@@ -710,18 +1319,50 @@ string2Symbol [notString] = throwError $ TypeMismatch "string" notString string2Symbol args@(_ : _) = throwError $ NumArgs (Just 1) args +-- | Convert a character to uppercase+--+-- Arguments:+--+-- * Char+--+-- Returns: Char - Character in uppercase+-- charUpper :: [LispVal] -> ThrowsError LispVal charUpper [Char c] = return $ Char $ toUpper c charUpper [notChar] = throwError $ TypeMismatch "char" notChar +-- | Convert a character to lowercase+--+-- Arguments:+--+-- * Char+--+-- Returns: Char - Character in lowercase+-- charLower :: [LispVal] -> ThrowsError LispVal charLower [Char c] = return $ Char $ toLower c charLower [notChar] = throwError $ TypeMismatch "char" notChar +-- | Convert from a charater to an integer+--+-- Arguments:+--+-- * Char+--+-- Returns: Number+-- char2Int :: [LispVal] -> ThrowsError LispVal char2Int [Char c] = return $ Number $ toInteger $ ord c char2Int [notChar] = throwError $ TypeMismatch "char" notChar +-- | Convert from an integer to a character+--+-- Arguments:+--+-- * Number+--+-- Returns: Char+-- int2Char :: [LispVal] -> ThrowsError LispVal int2Char [Number n] = return $ Char $ chr $ fromInteger n int2Char [notInt] = throwError $ TypeMismatch "integer" notInt@@ -731,15 +1372,39 @@ charPredicate pred ([Char c]) = return $ Bool $ pred c charPredicate _ _ = return $ Bool False +-- | Determine if the given value is a character+--+-- Arguments:+--+-- * LispVal to check+--+-- Returns: Bool - True if the argument is a character, False otherwise+-- isChar :: [LispVal] -> ThrowsError LispVal isChar ([Char _]) = return $ Bool True isChar _ = return $ Bool False +-- | Determine if the given value is a string+--+-- Arguments:+--+-- * LispVal to check+--+-- Returns: Bool - True if the argument is a string, False otherwise+-- isString :: [LispVal] -> IOThrowsError LispVal isString [p@(Pointer _ _)] = derefPtr p >>= box >>= isString isString ([String _]) = return $ Bool True isString _ = return $ Bool False +-- | Determine if the given value is a boolean+--+-- Arguments:+--+-- * LispVal to check+--+-- Returns: Bool - True if the argument is a boolean, False otherwise+-- isBoolean :: [LispVal] -> ThrowsError LispVal isBoolean ([Bool _]) = return $ Bool True isBoolean _ = return $ Bool False@@ -748,6 +1413,7 @@ -- Utility functions data Unpacker = forall a . Eq a => AnyUnpacker (LispVal -> ThrowsError a) +-- |Determine if two lispval's are equal unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool unpackEquals arg1 arg2 (AnyUnpacker unpacker) = do unpacked1 <- unpacker arg1@@ -755,6 +1421,7 @@ return $ unpacked1 == unpacked2 `catchError` (const $ return False) +-- |Helper function to perform a binary logic operation on two LispVal arguments. boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal boolBinop unpacker op args = if length args /= 2 then throwError $ NumArgs (Just 2) args@@ -762,35 +1429,86 @@ right <- unpacker $ args !! 1 return $ Bool $ left `op` right +-- |Perform the given function against a single LispVal argument unaryOp :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal unaryOp f [v] = f v unaryOp _ [] = throwError $ NumArgs (Just 1) [] unaryOp _ args@(_ : _) = throwError $ NumArgs (Just 1) args +-- |Same as unaryOp but in the IO monad unaryOp' :: (LispVal -> IOThrowsError LispVal) -> [LispVal] -> IOThrowsError LispVal unaryOp' f [v] = f v unaryOp' _ [] = throwError $ NumArgs (Just 1) [] unaryOp' _ args@(_ : _) = throwError $ NumArgs (Just 1) args +-- |Perform boolBinop against two string arguments strBoolBinop :: (String -> String -> Bool) -> [LispVal] -> IOThrowsError LispVal strBoolBinop fnc args = do List dargs <- recDerefPtrs $ List args -- Deref any pointers liftThrows $ boolBinop unpackStr fnc dargs +-- |Perform boolBinop against two char arguments charBoolBinop = boolBinop unpackChar++-- |Perform boolBinop against two boolean arguments boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal boolBoolBinop = boolBinop unpackBool +-- | Unpack a LispVal char+--+-- Arguments:+--+-- * Char - Character to unpack+-- unpackChar :: LispVal -> ThrowsError Char unpackChar (Char c) = return c unpackChar notChar = throwError $ TypeMismatch "character" notChar +-- | Unpack a LispVal String+--+-- Arguments:+--+-- * String - String to unpack+-- unpackStr :: LispVal -> ThrowsError String unpackStr (String s) = return s unpackStr (Number s) = return $ show s unpackStr (Bool s) = return $ show s unpackStr notString = throwError $ TypeMismatch "string" notString +-- | Unpack a LispVal boolean+--+-- Arguments:+--+-- * Bool - Boolean to unpack+-- unpackBool :: LispVal -> ThrowsError Bool unpackBool (Bool b) = return b unpackBool notBool = throwError $ TypeMismatch "boolean" notBool++-- | Return the current time, in seconds+--+-- Arguments: (None)+--+-- Returns: Current UNIX timestamp in seconds+currentTimestamp :: [LispVal] -> IOThrowsError LispVal+currentTimestamp _ = do+ cur <- liftIO $ Data.Time.Clock.POSIX.getPOSIXTime+ return $ Float $ realToFrac cur++-- | Execute a system command on the underlying OS.+--+-- Arguments:+--+-- * String - Command to execute+--+-- Returns: Integer - program return status+--+system :: [LispVal] -> IOThrowsError LispVal+system [String cmd] = do+ result <- liftIO $ System.Cmd.system cmd+ case result of+ ExitSuccess -> return $ Number 0+ ExitFailure code -> return $ Number $ toInteger code+system err = throwError $ TypeMismatch "string" $ List err+
hs-src/Language/Scheme/Types.hs view
@@ -91,6 +91,7 @@ , makeHFunc , makeNormalHFunc , makeHVarargs+ , validateFuncParams ) where import Control.Monad.Error@@ -98,6 +99,7 @@ import Data.Array import qualified Data.ByteString as BS import Data.Dynamic+import qualified Data.List as DL import Data.IORef import qualified Data.Map -- import Data.Maybe@@ -524,3 +526,32 @@ -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) -> m LispVal makeHVarargs = makeHFunc . Just . showVal++-- |Validate that function parameters consist of a list of +-- non-duplicate symbols.+validateFuncParams :: [LispVal] -> Maybe Integer -> IOThrowsError Bool+validateFuncParams ps (Just n) = do+ if length ps /= fromInteger n+ then throwError $ NumArgs (Just n) ps+ else validateFuncParams ps Nothing+validateFuncParams ps Nothing = do+ let syms = filter filterArgs ps+ if (length syms) /= (length ps)+ then throwError $ Default $ + "Invalid lambda parameter(s): " ++ (show $ List ps)+ else do+ let strs = DL.sort $ map (\ (Atom a) -> a) ps+ case dupe strs of+ Just d -> throwError $ Default $ + "Duplicate lambda parameter " ++ d+ _ -> return True+ where+ filterArgs (Atom a) = True+ filterArgs _ = False++ dupe (a : b : rest)+ | a == b = Just a+ | otherwise = dupe (b : rest)+ dupe _ = Nothing++
hs-src/Language/Scheme/Util.hs view
@@ -11,12 +11,9 @@ -} module Language.Scheme.Util- (- escapeBackslashes+ ( escapeBackslashes+ , strip ) where--- import qualified Paths_husk_scheme as PHS (getDataFileName)--- import Language.Scheme.Types--- import Language.Scheme.Variables -- |A utility function to escape backslashes in the given string escapeBackslashes :: String -> String@@ -24,3 +21,10 @@ where step x xs | x == '\\' = '\\' : '\\' : xs | otherwise = x : xs +-- | 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'])
hs-src/Language/Scheme/Variables.hs view
@@ -19,6 +19,7 @@ -- * Environments printEnv , recPrintEnv+ , recExportsFromEnv , exportsFromEnv , copyEnv , extendEnv@@ -109,6 +110,7 @@ v <- liftIO $ readIORef val return $ "[" ++ name ++ "]" ++ ": " ++ show v +-- |Recursively print an environment to string recPrintEnv :: Env -> IO String recPrintEnv env = do envStr <- liftIO $ printEnv env@@ -119,6 +121,17 @@ return $ envStr ++ "\n" ++ parEnvStr Nothing -> return envStr +-- |Recursively find all exports from the given environment+recExportsFromEnv :: Env -> IO [LispVal]+recExportsFromEnv env = do+ xs <- exportsFromEnv env++ case parentEnv env of+ Just par -> do+ pxs <- liftIO $ recExportsFromEnv par+ return $ xs ++ pxs+ Nothing -> return xs+ -- |Return a list of symbols exported from an environment exportsFromEnv :: Env -> IO [LispVal]@@ -188,6 +201,7 @@ Just p -> topmostEnv p Nothing -> return envRef +-- |Create a null environment with the given environment as its parent. nullEnvWithParent :: Env -> IO Env nullEnvWithParent p = do Environment _ binds ptrs <- nullEnv
husk-scheme.cabal view
@@ -1,5 +1,5 @@ Name: husk-scheme-Version: 3.11+Version: 3.12 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <<https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png>>@@ -61,7 +61,7 @@ default: True Library- Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, bytestring, utf8-string+ Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, bytestring, utf8-string, time, process Extensions: ExistentialQuantification Hs-Source-Dirs: hs-src Exposed-Modules: Language.Scheme.Core
+ lib/scheme/time.sld view
@@ -0,0 +1,21 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; The r7rs time library+;;;++(define-library (scheme time)+ (export+ current-second+ current-jiffy+ jiffies-per-second)+ (import + (scheme r5rs) ; TODO: use proper r7rs library for inexact->exact!!!!!+ (scheme time posix))+ (begin+ (define (jiffies-per-second) 10000)+ (define (current-jiffy)+ (inexact->exact (* (jiffies-per-second) (current-second))))))