diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -12,6 +12,7 @@ Satoshi Egi Douglas Huff Bastian Holst + Dan Cecile References: Write Yourself a Scheme in 48 Hours diff --git a/ChangeLog.markdown b/ChangeLog.markdown --- a/ChangeLog.markdown +++ b/ChangeLog.markdown @@ -1,3 +1,29 @@ +v3.19 +-------- + +New Features: + +- Added support for displaying call history when an error is thrown: + + huski> ((lambda () (vector-length "v"))) + Invalid type: expected vector, found "v" + + Call History: + #0: (vector-length "v") + #1: ((lambda () (vector-length "v"))) + + Sorry this took so long, as it should be a tremendous help for debugging! +- Print the number of received arguments when displaying an "incorrect number of arguments" error message. Also unbox any objects before displaying the error message. +- Allow `read-all` to read from `stdin` when no arguments are received. + +Big Fixes: + +- Fixed bugs in `open-input-string` and `open-byte-vector` that prevented a variable being passed as the "input" argument. Thanks to Dan Cecile for the bug report! +- Fixed a bug that could cause an infinite loop during macro expansion. Thanks to Dan Cecile for this report as well. +- Return the empty string from `string-append` if no arguments are received, instead of throwing an error. +- Throw an error when a function that takes a variable number of arguments is called without the minimum number of required arguments. For example `(map list)` should throw an error because at least 2 arguments are required. +- Use `System.Process` instead of deprecated `System.Cmd`. + v3.18 -------- 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 @@ -18,12 +18,12 @@ import Language.Scheme.Variables -- Scheme variable operations import Control.Monad.Error import Data.Maybe (fromMaybe) -import System.Cmd (system) import System.Console.GetOpt import System.FilePath (dropExtension) import System.Environment import System.Exit (ExitCode (..), exitSuccess, exitWith) import System.IO +import System.Process (system) main :: IO () main = do 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 @@ -43,6 +43,9 @@ , updateList , updateVector , updateByteVector + -- * Error handling + , addToCallHistory + , throwErrorWithCallHistory -- * Internal use only , meval ) where @@ -62,7 +65,7 @@ import Data.Array import qualified Data.ByteString as BS import qualified Data.Map -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Version as DV import Data.Word import qualified System.Exit @@ -84,7 +87,7 @@ putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| " putStrLn " " putStrLn " http://justinethier.github.io/husk-scheme " - putStrLn " (c) 2010-2014 Justin Ethier " + putStrLn " (c) 2010-2015 Justin Ethier " putStrLn $ " Version " ++ (DV.showVersion PHS.version) ++ " " putStrLn " " @@ -157,6 +160,11 @@ -- |This is the recommended function to use to display a lisp error, instead -- of just using show directly. showLispError :: LispError -> IO String +showLispError (NumArgs n lvs) = do + lvs' <- runErrorT $ mapM recDerefPtrs lvs + case lvs' of + Left _ -> return $ show $ NumArgs n lvs + Right vals -> return $ show $ NumArgs n vals showLispError (TypeMismatch str p@(Pointer _ e)) = do lv' <- evalLisp' e p case lv' of @@ -167,6 +175,12 @@ case lv' of Left _ -> showLispError $ BadSpecialForm str $ Atom $ show p Right val -> showLispError $ BadSpecialForm str val +showLispError (ErrorWithCallHist err hist) = do + err' <- showLispError err + hist' <- runErrorT $ mapM recDerefPtrs hist + case hist' of + Left _ -> return $ showCallHistory err' hist + Right vals -> return $ showCallHistory err' vals showLispError err = return $ show err -- |Execute an IO action and return result or an error message. @@ -285,7 +299,7 @@ cEnv (Just (HaskellBody func funcArgs)) (Just nCont@(Continuation {})) - _) + _ _) val xargs = do let args = case funcArgs of @@ -305,7 +319,7 @@ - NOTE: We use 'eval' below instead of 'meval' because macros are already expanded when - a function is loaded the first time, so there is no need to test for this again here. -} -continueEval _ (Continuation cEnv (Just (SchemeBody cBody)) (Just cCont) dynWind) val extraArgs = do +continueEval _ (Continuation cEnv (Just (SchemeBody cBody)) (Just cCont) dynWind callHist) val extraArgs = do -- case (trace ("cBody = " ++ show cBody) cBody) of case cBody of [] -> do @@ -314,13 +328,13 @@ -- Pass extra args along if last expression of a function, to support (call-with-values) continueEval nEnv cCont val extraArgs _ -> return val - (lv : lvs) -> eval cEnv (Continuation cEnv (Just (SchemeBody lvs)) (Just cCont) dynWind) lv + (lv : lvs) -> eval cEnv (Continuation cEnv (Just (SchemeBody lvs)) (Just cCont) dynWind callHist) lv -- No current continuation, but a next cont is available; call into it -continueEval _ (Continuation cEnv Nothing (Just cCont) _) val xargs = continueEval cEnv cCont val xargs +continueEval _ (Continuation cEnv Nothing (Just cCont) _ _) val xargs = continueEval cEnv cCont val xargs -- There is no continuation code, just return value -continueEval _ (Continuation _ Nothing Nothing _) val _ = return val +continueEval _ (Continuation _ Nothing Nothing _ _) val _ = return val continueEval _ _ _ _ = throwError $ Default "Internal error in continueEval" {- |Core eval function @@ -398,7 +412,7 @@ -- Expand whole body as a single continuous macro, to ensure hygiene expanded <- Language.Scheme.Macro.expand bodyEnv False (List _body) apply case expanded of - List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing) (Nil "") Nothing + List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing []) (Nil "") Nothing e -> continueEval bodyEnv cont e Nothing eval env cont args@(List (Atom "letrec-syntax" : List _bindings : _body)) = do @@ -415,7 +429,7 @@ -- Expand whole body as a single continuous macro, to ensure hygiene expanded <- Language.Scheme.Macro.expand bodyEnv False (List _body) apply case expanded of - List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing) (Nil "") Nothing + List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing []) (Nil "") Nothing e -> continueEval bodyEnv cont e Nothing -- A non-standard way to rebind a macro to another keyword @@ -880,18 +894,22 @@ cpsIndex :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsIndex e c idx _ = meval e (makeCPSWArgs e c cpsGetVar [idx]) object - {- Prepare for apply by evaluating each function argument, and then execute the function via 'apply' -} prepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal -prepareApply env cont (List (function : functionArgs)) = do - eval env (makeCPSWArgs env cont cpsPrepArgs functionArgs) function - where cpsPrepArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal +prepareApply env (Continuation clo cc nc dw cstk) fnc@(List (function : functionArgs)) = do + eval env + (makeCPSWArgs env (Continuation clo cc nc dw $! addToCallHistory fnc cstk) + cpsPrepArgs functionArgs) + function + where + cpsPrepArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsPrepArgs e c func args' = do -- case (trace ("prep eval of args: " ++ show args) args) of let args = case args' of Just as -> as Nothing -> [] + --case (trace ("stack: " ++ (show fnc) ++ " " ++ (show cstk)) args) of case args of [] -> apply c func [] -- No args, immediately apply the function [a] -> meval env (makeCPSWArgs e c cpsEvalArgs [func, List [], List []]) a @@ -918,7 +936,7 @@ -> LispVal -- ^ Function or continuation to execute -> [LispVal] -- ^ Arguments -> IOThrowsError LispVal -- ^ Final value of computation -apply _ cont@(Continuation env _ _ ndynwind) args = do +apply _ cont@(Continuation env _ _ ndynwind _) args = do -- case (trace ("calling into continuation. dynWind = " ++ show ndynwind) ndynwind) of case ndynwind of -- Call into dynWind.before if it exists... @@ -933,17 +951,25 @@ 1 -> continueEval e c (head args) Nothing _ -> -- Pass along additional arguments, so they are available to (call-with-values) continueEval e cont (head args) (Just $ tail args) -apply cont (IOFunc func) args = do - result <- func args +apply cont (IOFunc f) args = do + result <- exec f case cont of - Continuation cEnv _ _ _ -> continueEval cEnv cont result Nothing + Continuation {contClosure = cEnv} -> continueEval cEnv cont result Nothing _ -> return result -apply cont (CustFunc func) args = do + where + exec func = do + func args + `catchError` throwErrorWithCallHistory cont +apply cont (CustFunc f) args = do List dargs <- recDerefPtrs $ List args -- Deref any pointers - result <- func dargs + result <- exec f dargs case cont of - Continuation cEnv _ _ _ -> continueEval cEnv cont result Nothing + Continuation {contClosure = cEnv} -> continueEval cEnv cont result Nothing _ -> return result + where + exec func fargs = do + func fargs + `catchError` throwErrorWithCallHistory cont apply cont (EvalFunc func) args = do -- An EvalFunc extends the evaluator so it needs access to the current -- continuation, so pass it as the first argument. @@ -952,12 +978,17 @@ -- OK not to deref ptrs here because primitives only operate on -- non-objects, and the error handler execs in the I/O monad and -- handles ptrs just fine - result <- liftThrows $ func args + result <- exec args case cont of - Continuation cEnv _ _ _ -> continueEval cEnv cont result Nothing + Continuation {contClosure = cEnv} -> continueEval cEnv cont result Nothing _ -> return result + where + exec fargs = do + liftThrows $ func fargs + `catchError` throwErrorWithCallHistory cont apply cont (Func aparams avarargs abody aclosure) args = - if num aparams /= num args && isNothing avarargs + if (num aparams /= num args && isNothing avarargs) || + (num aparams > num args && isJust avarargs) then throwError $ NumArgs (Just (num aparams)) args else liftIO (extendEnv aclosure $ zip (map ((,) varNamespace) aparams) args) >>= bindVarArgs avarargs >>= (evalBody abody) where remainingArgs = drop (length aparams) args @@ -975,22 +1006,23 @@ -- See: http://icem-www.folkwang-hochschule.de/~finnendahl/cm_kurse/doc/schintro/schintro_142.html#SEC294 -- evalBody evBody env = case cont of - Continuation _ (Just (SchemeBody cBody)) (Just cCont) cDynWind -> if null cBody - then continueWCont env evBody cCont cDynWind + Continuation _ (Just (SchemeBody cBody)) (Just cCont) cDynWind cStack -> if null cBody + then continueWCont env evBody cCont cDynWind cStack -- else continueWCont env (evBody) cont (trace ("cDynWind = " ++ show cDynWind) cDynWind) -- Might be a problem, not fully optimizing - else continueWCont env evBody cont cDynWind -- Might be a problem, not fully optimizing - Continuation _ _ _ cDynWind -> continueWCont env evBody cont cDynWind - _ -> continueWCont env evBody cont Nothing + else continueWCont env evBody cont cDynWind cStack -- Might be a problem, not fully optimizing + Continuation _ _ _ cDynWind cStack -> continueWCont env evBody cont cDynWind cStack + _ -> continueWCont env evBody cont Nothing [] -- Shortcut for calling continueEval - continueWCont cwcEnv cwcBody cwcCont cwcDynWind = - continueEval cwcEnv (Continuation cwcEnv (Just (SchemeBody cwcBody)) (Just cwcCont) cwcDynWind) (Nil "") Nothing + continueWCont cwcEnv cwcBody cwcCont cwcDynWind cStack = + continueEval cwcEnv (Continuation cwcEnv (Just (SchemeBody cwcBody)) (Just cwcCont) cwcDynWind cStack) (Nil "") Nothing bindVarArgs arg env = case arg of Just argName -> liftIO $ extendEnv env [((varNamespace, argName), List remainingArgs)] Nothing -> return env apply cont (HFunc aparams avarargs abody aclosure) args = - if num aparams /= num args && isNothing avarargs + if (num aparams /= num args && isNothing avarargs) || + (num aparams > num args && isJust avarargs) then throwError $ NumArgs (Just (num aparams)) args else liftIO (extendEnv aclosure $ zip (map ((,) varNamespace) aparams) args) >>= bindVarArgs avarargs >>= (evalBody abody) where remainingArgs = drop (length aparams) args @@ -1184,15 +1216,16 @@ - is 100% correct since a stack is not directly used to hold the winders. I think there must still be edge - cases that are not handled properly... -} -evalfuncDynamicWind [cont@(Continuation env _ _ _), beforeFunc, thunkFunc, afterFunc] = do +evalfuncDynamicWind [cont@(Continuation {contClosure = env}), beforeFunc, thunkFunc, afterFunc] = do apply (makeCPS env cont cpsThunk) beforeFunc [] where cpsThunk, cpsAfter :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsThunk e (Continuation ce cc cnc _ {- FUTURE: cwindrz -} ) _ _ = apply (Continuation e (Just (HaskellBody cpsAfter Nothing)) - (Just (Continuation ce cc cnc - Nothing)) - (Just [DynamicWinders beforeFunc afterFunc])) -- FUTURE: append if existing winders - thunkFunc [] + cpsThunk e (Continuation ce cc cnc _ cs) _ _ = + apply (Continuation e (Just (HaskellBody cpsAfter Nothing)) + (Just (Continuation ce cc cnc Nothing cs)) + (Just [DynamicWinders beforeFunc afterFunc]) + []) -- FUTURE: append if existing winders + thunkFunc [] cpsThunk _ _ _ _ = throwError $ Default "Unexpected error in cpsThunk during (dynamic-wind)" cpsAfter _ c value _ = do let cpsRetVals :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal @@ -1208,25 +1241,25 @@ [Bool False] -> evalfuncExitFail args _ -> evalfuncExitSuccess args where - unchain c@(Continuation _ _ cn _) = do + unchain c@(Continuation {nextCont = cn}) = do case cn of (Just c'@(Continuation {})) -> do _ <- execAfters c unchain c' _ -> execAfters c unchain _ = return [] - execAfters (Continuation e _ _ (Just dynamicWinders)) = do + execAfters (Continuation e _ _ (Just dynamicWinders) _) = do mapM (\ (DynamicWinders _ afterFunc) -> apply (makeNullContinuation e) afterFunc []) dynamicWinders execAfters _ = return [] evalfuncExit args = throwError $ InternalError $ "Invalid arguments to exit: " ++ show args -evalfuncCallWValues [cont@(Continuation env _ _ _), producer, consumer] = do +evalfuncCallWValues [cont@(Continuation {contClosure = env}), producer, consumer] = do apply (makeCPS env cont cpsEval) producer [] -- Call into prod to get values where cpsEval :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsEval _ c@(Continuation _ _ _ _) value (Just xargs) = apply c consumer (value : xargs) + cpsEval _ c@(Continuation {}) value (Just xargs) = apply c consumer (value : xargs) cpsEval _ c value _ = apply c consumer [value] evalfuncCallWValues (_ : args) = throwError $ NumArgs (Just 2) args -- Skip over continuation argument evalfuncCallWValues _ = throwError $ NumArgs (Just 2) [] @@ -1250,28 +1283,28 @@ evalfuncApply _ = throwError $ NumArgs (Just 2) [] -evalfuncMakeEnv (cont@(Continuation env _ _ _) : _) = do +evalfuncMakeEnv (cont@(Continuation {contClosure = env}) : _) = do e <- liftIO nullEnv continueEval env cont (LispEnv e) Nothing evalfuncMakeEnv _ = throwError $ NumArgs (Just 1) [] -evalfuncNullEnv [cont@(Continuation env _ _ _), Number _] = do +evalfuncNullEnv [cont@(Continuation {contClosure = env}), Number _] = do nilEnv <- liftIO primitiveBindings continueEval env cont (LispEnv nilEnv) Nothing evalfuncNullEnv (_ : args) = throwError $ NumArgs (Just 1) args -- Skip over continuation argument evalfuncNullEnv _ = throwError $ NumArgs (Just 1) [] -evalfuncInteractionEnv (cont@(Continuation env _ _ _) : _) = do +evalfuncInteractionEnv (cont@(Continuation {contClosure = env}) : _) = do continueEval env cont (LispEnv env) Nothing evalfuncInteractionEnv _ = throwError $ InternalError "" -evalfuncUseParentEnv ((Continuation env a b c) : _) = do +evalfuncUseParentEnv ((Continuation env a b c d) : _) = do let parEnv = fromMaybe env (parentEnv env) - continueEval parEnv (Continuation parEnv a b c) (LispEnv parEnv) Nothing + continueEval parEnv (Continuation parEnv a b c d) (LispEnv parEnv) Nothing evalfuncUseParentEnv _ = throwError $ InternalError "" evalfuncImport [ - cont@(Continuation env a b c), + cont@(Continuation env a b c d), toEnv, LispEnv fromEnv, imports, @@ -1305,7 +1338,7 @@ newEnv <- liftIO $ importEnv toEnv' fromEnv continueEval env - (Continuation env a b c) + (Continuation env a b c d) (LispEnv newEnv) Nothing @@ -1316,7 +1349,7 @@ -- |Load import into the main environment bootstrapImport :: [LispVal] -> ErrorT LispError IO LispVal -bootstrapImport [cont@(Continuation env _ _ _)] = do +bootstrapImport [cont@(Continuation {contClosure = env})] = do LispEnv me <- getVar env "*meta-env*" ri <- getNamespacedVar me macroNamespace "repl-import" renv <- defineNamespacedVar env macroNamespace "import" ri @@ -1327,10 +1360,10 @@ lv <- derefPtr p evalfuncLoad (cont : lv : lvs) -evalfuncLoad [(Continuation _ a b c), String filename, LispEnv env] = do - evalfuncLoad [Continuation env a b c, String filename] +evalfuncLoad [(Continuation _ a b c d), String filename, LispEnv env] = do + evalfuncLoad [Continuation env a b c d, String filename] -evalfuncLoad [cont@(Continuation env _ _ _), String filename] = do +evalfuncLoad [cont@(Continuation {contClosure = env}), String filename] = do filename' <- findFileOrLib filename results <- load filename' >>= mapM (meval env (makeNullContinuation env)) if not (null results) @@ -1342,7 +1375,7 @@ evalfuncLoad _ = throwError $ NumArgs (Just 1) [] -- |Evaluate an expression. -evalfuncEval [cont@(Continuation env _ _ _), val] = do -- Current env +evalfuncEval [cont@(Continuation {contClosure = env}), val] = do -- Current env v <- derefPtr val -- Must deref ptrs for macro subsystem meval env cont v evalfuncEval [cont@(Continuation {}), val, LispEnv env] = do -- Env parameter @@ -1357,7 +1390,7 @@ PrimitiveFunc f -> do result <- liftThrows $ f [cont] case cont of - Continuation cEnv _ _ _ -> continueEval cEnv cont result Nothing + Continuation {contClosure = cEnv} -> continueEval cEnv cont result Nothing _ -> return result Func _ (Just _) _ _ -> apply cont func [cont] -- Variable # of args (pair). Just call into cont Func aparams _ _ _ -> @@ -1407,3 +1440,15 @@ , ("exit-fail", evalfuncExitFail) , ("exit-success", evalfuncExitSuccess) ] + +-- | Rethrow given error with call history, if available +throwErrorWithCallHistory :: LispVal -> LispError -> IOThrowsError LispVal +throwErrorWithCallHistory (Continuation {contCallHist=cstk}) e = do + throwError $ ErrorWithCallHist e cstk +throwErrorWithCallHistory _ e = throwError e + +-- | Add a function to the call history +addToCallHistory :: LispVal -> [LispVal] -> [LispVal] +addToCallHistory f history + | null history = [f] + | otherwise = (lastN' 9 history) ++ [f] 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 @@ -1537,7 +1537,10 @@ getOrigName renameEnv a = do v <- getVar' renameEnv a case v of - Just (Atom a') -> getOrigName renameEnv a' + Just (Atom a') -> + if a == a' + then return a' + else getOrigName renameEnv a' _ -> return a -- |Determine if the given identifier is lexically defined 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 @@ -173,12 +173,12 @@ import qualified Data.Time.Clock.POSIX import Data.Unique import Data.Word -import qualified System.Cmd import System.Directory (doesFileExist, removeFile) import qualified System.Environment as SE import System.Exit (ExitCode(..)) import System.IO import System.IO.Error +import qualified System.Process --import System.Process (readProcess) --import Debug.Trace @@ -221,6 +221,7 @@ Nothing -> WriteMode _ -> ReadMode bs <- case buf of +-- Just (p@(Pointer {})] = recDerefPtrs p >>= box >>= openInputString Just (String s)-> return $ BSU.fromString s Just (ByteVector bv)-> return bv Just err -> throwError $ TypeMismatch "string or bytevector" err @@ -239,8 +240,9 @@ -- |Create a new input string buffer openInputString :: [LispVal] -> IOThrowsError LispVal +openInputString [p@(Pointer {})] = recDerefPtrs p >>= box >>= openInputString openInputString [buf@(String _)] = makeBufferPort (Just buf) -openInputString args = if length args == 2 +openInputString args = if length args == 1 then throwError $ TypeMismatch "(string)" $ List args else throwError $ NumArgs (Just 1) args @@ -250,8 +252,9 @@ -- |Create a new input bytevector buffer openInputByteVector :: [LispVal] -> IOThrowsError LispVal +openInputByteVector [p@(Pointer {})] = recDerefPtrs p >>= box >>= openInputByteVector openInputByteVector [buf@(ByteVector _)] = makeBufferPort (Just buf) -openInputByteVector args = if length args == 2 +openInputByteVector args = if length args == 1 then throwError $ TypeMismatch "(bytevector)" $ List args else throwError $ NumArgs (Just 1) args @@ -262,6 +265,7 @@ -- |Get string written to string-output-port getOutputString :: [LispVal] -> IOThrowsError LispVal +getOutputString [p@(Pointer {})] = recDerefPtrs p >>= box >>= getOutputString getOutputString [p@(Port port _)] = do o <- liftIO $ hIsOpen port if o then do @@ -273,6 +277,7 @@ -- |Get bytevector written to bytevector-output-port getOutputByteVector :: [LispVal] -> IOThrowsError LispVal +getOutputByteVector [p@(Pointer {})] = recDerefPtrs p >>= box >>= getOutputByteVector getOutputByteVector [p@(Port port _)] = do o <- liftIO $ hIsOpen port if o then do bytes <- getBufferFromPort p @@ -290,6 +295,7 @@ -- Returns: Bool - True if the port was closed, false otherwise -- closePort :: [LispVal] -> IOThrowsError LispVal +closePort [p@(Pointer {})] = recDerefPtrs p >>= box >>= closePort closePort [Port port _] = liftIO $ hClose port >> (return $ Bool True) closePort _ = return $ Bool False @@ -319,6 +325,7 @@ -- | Flush the given output port flushOutputPort :: [LispVal] -> IOThrowsError LispVal flushOutputPort [] = liftIO $ hFlush stdout >> (return $ Bool True) +flushOutputPort [p@(Pointer {})] = recDerefPtrs p >>= box >>= flushOutputPort flushOutputPort [p@(Port _ _)] = withOpenPort p $ \port -> liftIO $ hFlush port >> (return $ Bool True) flushOutputPort _ = return $ Bool False @@ -331,6 +338,7 @@ -- -- Returns: Bool isTextPort :: [LispVal] -> IOThrowsError LispVal +isTextPort [p@(Pointer {})] = recDerefPtrs p >>= box >>= isTextPort isTextPort [Port port _] = do val <- liftIO $ isTextPort' port return $ Bool val @@ -344,6 +352,7 @@ -- -- Returns: Bool isBinaryPort :: [LispVal] -> IOThrowsError LispVal +isBinaryPort [p@(Pointer {})] = recDerefPtrs p >>= box >>= isBinaryPort isBinaryPort [Port port _] = do val <- liftIO $ isTextPort' port return $ Bool $ not val @@ -365,6 +374,7 @@ -- -- Returns: Bool isInputPortOpen :: [LispVal] -> IOThrowsError LispVal +isInputPortOpen [p@(Pointer {})] = recDerefPtrs p >>= box >>= isInputPortOpen isInputPortOpen [p@(Port _ _)] = do withOpenPort p $ \port -> do r <- liftIO $ hIsReadable port @@ -374,6 +384,9 @@ -- | Helper function to ensure a port is open, to prevent Haskell errors withOpenPort :: LispVal -> (Handle -> IOThrowsError LispVal) -> IOThrowsError LispVal +withOpenPort p@(Pointer {}) proc = do + obj <- recDerefPtrs p + withOpenPort obj proc withOpenPort (Port port _) proc = do o <- liftIO $ hIsOpen port if o then proc port @@ -388,6 +401,7 @@ -- -- Returns: Bool isOutputPortOpen :: [LispVal] -> IOThrowsError LispVal +isOutputPortOpen [p@(Pointer {})] = recDerefPtrs p >>= box >>= isOutputPortOpen isOutputPortOpen [p@(Port _ _)] = do withOpenPort p $ \port -> do w <- liftIO $ hIsWritable port @@ -404,6 +418,7 @@ -- Returns: Bool - True if an input port, false otherwise -- isInputPort :: [LispVal] -> IOThrowsError LispVal +isInputPort [p@(Pointer {})] = recDerefPtrs p >>= box >>= isInputPort isInputPort [p@(Port _ _)] = withOpenPort p $ \port -> liftM Bool $ liftIO $ hIsReadable port isInputPort _ = return $ Bool False @@ -417,6 +432,7 @@ -- Returns: Bool - True if an output port, false otherwise -- isOutputPort :: [LispVal] -> IOThrowsError LispVal +isOutputPort [p@(Pointer {})] = recDerefPtrs p >>= box >>= isOutputPort isOutputPort [p@(Port _ _)] = withOpenPort p $ \port -> liftM Bool $ liftIO $ hIsWritable port isOutputPort _ = return $ Bool False @@ -430,6 +446,7 @@ -- Returns: Bool -- isCharReady :: [LispVal] -> IOThrowsError LispVal +isCharReady [p@(Pointer {})] = recDerefPtrs p >>= box >>= isCharReady isCharReady [Port port _] = do --liftM Bool $ liftIO $ hReady port result <- liftIO $ try' (liftIO $ hReady port) case result of @@ -449,6 +466,7 @@ -- readProc :: Bool -> [LispVal] -> IOThrowsError LispVal readProc mode [] = readProc mode [Port stdin Nothing] +readProc mode [p@(Pointer {})] = recDerefPtrs p >>= box >>= readProc mode readProc mode [Port port _] = do input <- liftIO $ try' (liftIO $ hGetLine port) case input of @@ -460,7 +478,9 @@ case mode of True -> readExpr inpStr _ -> return $ String inpStr -readProc _ args@(_ : _) = throwError $ BadSpecialForm "" $ List args +readProc _ args = if length args == 1 + then throwError $ TypeMismatch "port" $ List args + else throwError $ NumArgs (Just 1) args -- |Read character from port -- @@ -471,6 +491,7 @@ -- Returns: Char -- readCharProc :: (Handle -> IO Char) -> [LispVal] -> IOThrowsError LispVal +readCharProc func [p@(Pointer {})] = recDerefPtrs p >>= box >>= readCharProc func readCharProc func [] = readCharProc func [Port stdin Nothing] readCharProc func [p@(Port _ _)] = do withOpenPort p $ \port -> do @@ -483,7 +504,9 @@ else throwError $ Default "I/O error reading from port" Right inpChr -> do return $ Char inpChr -readCharProc _ args@(_ : _) = throwError $ BadSpecialForm "" $ List args +readCharProc _ args = if length args == 1 + then throwError $ TypeMismatch "port" $ List args + else throwError $ NumArgs (Just 1) args -- | Read a byte vector from the given port -- @@ -697,7 +720,10 @@ readAll :: [LispVal] -> IOThrowsError LispVal readAll [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= readAll readAll [String filename] = liftM List $ load filename -readAll [] = throwError $ NumArgs (Just 1) [] +readAll [] = do -- read from stdin + input <- liftIO $ getContents + lisp <- (liftThrows . readExprList) input + return $ List lisp readAll args@(_ : _) = throwError $ NumArgs (Just 1) args -- |Version of gensym that can be conveniently called from Haskell. @@ -1447,6 +1473,7 @@ case rest of String s -> return $ String $ st ++ s other -> throwError $ TypeMismatch "string" other +stringAppend [] = return $ String "" stringAppend [badType] = throwError $ TypeMismatch "string" badType stringAppend badArgList = throwError $ NumArgs (Just 1) badArgList @@ -1995,7 +2022,7 @@ -- system :: [LispVal] -> IOThrowsError LispVal system [String cmd] = do - result <- liftIO $ System.Cmd.system cmd + result <- liftIO $ System.Process.system cmd case result of ExitSuccess -> return $ Number 0 ExitFailure code -> return $ Number $ toInteger code 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 @@ -23,6 +23,7 @@ , ThrowsError , IOThrowsError , liftThrows + , showCallHistory -- * Types and related functions , LispVal ( Atom @@ -62,6 +63,7 @@ , currentCont , nextCont , dynamicWind + , contCallHist , Syntax , synClosure , synRenameClosure @@ -133,36 +135,50 @@ | TypeMismatch String LispVal -- ^Type error | Parser ParseError -- ^Parsing error | BadSpecialForm String LispVal -- ^Invalid special (built-in) form --- | NotFunction String String | UnboundVar String String -- ^ A referenced variable has not been declared | DivideByZero -- ^Divide by Zero error | NotImplemented String -- ^ Feature is not implemented | InternalError String {- ^An internal error within husk; in theory user (Scheme) code should never allow one of these errors to be triggered. -} | Default String -- ^Default error + | ErrorWithCallHist LispError [LispVal] -- |Create a textual description for a 'LispError' showError :: LispError -> String showError (NumArgs (Just expected) found) = "Expected " ++ show expected - ++ " args; found values " ++ unwordsList found -showError (NumArgs Nothing found) = "Incorrect number of args; " ++ - " found values " ++ unwordsList found + ++ " args but found " + ++ (show $ length found) + ++ " values: " ++ unwordsList found +showError (NumArgs Nothing found) = "Incorrect number of args, " + ++ " found " + ++ (show $ length found) + ++ " values: " ++ unwordsList found showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ show found showError (Parser parseErr) = "Parse error at " ++ ": " ++ show parseErr showError (BadSpecialForm message form) = message ++ ": " ++ show form --- showError (NotFunction message func) = message ++ ": " ++ show func showError (UnboundVar message varname) = message ++ ": " ++ varname showError (DivideByZero) = "Division by zero" showError (NotImplemented message) = "Not implemented: " ++ message showError (InternalError message) = "An internal error occurred: " ++ message showError (Default message) = "Error: " ++ message +showError (ErrorWithCallHist err stack) = showCallHistory (show err) stack instance Show LispError where show = showError instance Error LispError where noMsg = Default "An error has occurred" strMsg = Default +-- |Display call history for an error +showCallHistory :: String -> [LispVal] -> String +showCallHistory message hist = do + let nums :: [Int] + nums = [0..] + ns = take (length hist) nums + message ++ "\n\nCall History:\n" ++ + (unlines $ map (\(n, s) -> ('#' : show n) ++ ": " ++ show s) + (zip ns $ reverse hist)) + -- |Container used by operations that could throw an error type ThrowsError = Either LispError @@ -243,6 +259,7 @@ , currentCont :: (Maybe DeferredCode) -- Code of current continuation , nextCont :: (Maybe LispVal) -- Code to resume after body of cont , dynamicWind :: (Maybe [DynamicWinders]) -- Functions injected by (dynamic-wind) + , contCallHist :: [LispVal] -- Active call history } -- ^Continuation | Syntax { synClosure :: Maybe Env -- ^ Code env in effect at definition time, if applicable @@ -307,7 +324,7 @@ -- |Make an /empty/ continuation that does not contain any code makeNullContinuation :: Env -> LispVal -makeNullContinuation env = Continuation env Nothing Nothing Nothing +makeNullContinuation env = Continuation env Nothing Nothing Nothing [] -- |Make a continuation that takes a higher-order function (written in Haskell) makeCPS :: Env @@ -318,8 +335,8 @@ -- ^ Haskell function -> LispVal -- ^ The Haskell function packaged as a LispVal -makeCPS env cont@(Continuation _ _ _ dynWind) cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) dynWind -makeCPS env cont cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) Nothing -- This overload just here for completeness; it should never be used +makeCPS env cont@(Continuation {contCallHist=hist}) cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) (dynamicWind cont) hist +makeCPS env cont cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) Nothing [] -- This overload just here for completeness; it should never be used -- |Make a continuation that stores a higher-order function and arguments to that function makeCPSWArgs :: Env @@ -332,17 +349,17 @@ -- ^ Arguments to the function -> LispVal -- ^ The Haskell function packaged as a LispVal -makeCPSWArgs env cont@(Continuation {dynamicWind=dynWind}) cps args = +makeCPSWArgs env cont@(Continuation {dynamicWind=dynWind,contCallHist=hist}) cps args = Continuation env (Just (HaskellBody cps (Just args))) - (Just cont) dynWind + (Just cont) dynWind hist makeCPSWArgs env cont cps args = -- This overload just here for completeness; it should never be used Continuation env (Just (HaskellBody cps (Just args))) - (Just cont) Nothing + (Just cont) Nothing [] instance Ord LispVal where compare (Bool a) (Bool b) = compare a b diff --git a/hs-src/Language/Scheme/Util.hs b/hs-src/Language/Scheme/Util.hs --- a/hs-src/Language/Scheme/Util.hs +++ b/hs-src/Language/Scheme/Util.hs @@ -14,9 +14,12 @@ ( countAllLetters , countLetters , escapeBackslashes + , lastN' , strip ) where +import qualified Data.List as DL + -- |A utility function to escape backslashes in the given string escapeBackslashes :: String -> String escapeBackslashes = foldr step [] @@ -38,4 +41,9 @@ -- |Count occurences of a letter in a string countLetters :: Char -> String -> Int countLetters c str = length $ filter (== c) str + +-- | Take last n elements of a list, from: +-- http://stackoverflow.com/q/17252851/101258 +lastN' :: Int -> [a] -> [a] +lastN' n xs = DL.foldl' (const .drop 1) xs (drop n xs) 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.18 +Version: 3.19 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <>