husk-scheme 3.18 → 3.19

raw patch · 9 files changed

+202/−75 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• AUTHORS +1/−0
• ChangeLog.markdown +26/−0
• hs-src/Compiler/huskc.hs +1/−1
• hs-src/Language/Scheme/Core.hs +99/−54
• hs-src/Language/Scheme/Macro.hs +4/−1
• hs-src/Language/Scheme/Primitives.hs +34/−7
• hs-src/Language/Scheme/Types.hs +28/−11
• hs-src/Language/Scheme/Util.hs +8/−0
• husk-scheme.cabal +1/−1

@@ -12,6 +12,7 @@   Satoshi Egi <egi@egison.org>   Douglas Huff <https://github.com/jrmithdobbs>   Bastian Holst <https://github.com/bholst>+  Dan Cecile <https://github.com/dcecile>  References:   Write Yourself a Scheme in 48 Hours <http://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours>

@@ -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 -------- 

@@ -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 

@@ -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]

@@ -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

@@ -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

@@ -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

@@ -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) 

@@ -1,5 +1,5 @@ Name:                husk-scheme-Version:             3.18+Version:             3.19 Synopsis:            R5RS Scheme interpreter, compiler, and library. Description:            <<https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png>>