diff --git a/ChangeLog.markdown b/ChangeLog.markdown --- a/ChangeLog.markdown +++ b/ChangeLog.markdown @@ -1,7 +1,21 @@ +v3.19.4 +-------- + +Bug fixes: + +- Incorporated fixes to allow husk to build with newer versions of GHC 8. + +v3.19.4 +-------- + +Bug fixes: + +- Import `(scheme)` in SRFI 1, to prevent problems with missing the `receive` macro in compiled programs. + v3.19.3 -------- -Big Fixes: +Bug Fixes: - Fixed compilation errors in `FFI.hs`. 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 @@ -16,7 +16,7 @@ import qualified Language.Scheme.Core import Language.Scheme.Types -- Scheme data types import Language.Scheme.Variables -- Scheme variable operations -import Control.Monad.Error +import Control.Monad.Except import Data.Maybe (fromMaybe) import System.Console.GetOpt import System.FilePath (dropExtension) diff --git a/hs-src/Interpreter/shell.hs b/hs-src/Interpreter/shell.hs --- a/hs-src/Interpreter/shell.hs +++ b/hs-src/Interpreter/shell.hs @@ -16,7 +16,7 @@ import Language.Scheme.Types -- Scheme data types import qualified Language.Scheme.Util as LSU (countAllLetters, countLetters, strip) import qualified Language.Scheme.Variables as LSV -- Scheme variable operations -import Control.Monad.Error +import Control.Monad.Except import qualified Data.Char as DC import qualified Data.List as DL import Data.Maybe (fromMaybe) diff --git a/hs-src/Language/Scheme/Compiler.hs b/hs-src/Language/Scheme/Compiler.hs --- a/hs-src/Language/Scheme/Compiler.hs +++ b/hs-src/Language/Scheme/Compiler.hs @@ -58,7 +58,7 @@ import Language.Scheme.Primitives import Language.Scheme.Types import Language.Scheme.Variables -import Control.Monad.Error +import Control.Monad.Except import qualified Data.List import Data.Maybe (fromMaybe) @@ -1089,8 +1089,8 @@ compileSpecialFormBody :: Env -> LispVal -> CompOpts - -> (Maybe String -> ErrorT LispError IO [HaskAST]) - -> ErrorT LispError IO [HaskAST] + -> (Maybe String -> ExceptT LispError IO [HaskAST]) + -> ExceptT LispError IO [HaskAST] compileSpecialFormBody env ast@(List (Atom fnc : _)) copts@(CompileOptions _ _ _ nextFunc) diff --git a/hs-src/Language/Scheme/Compiler/Libraries.hs b/hs-src/Language/Scheme/Compiler/Libraries.hs --- a/hs-src/Language/Scheme/Compiler/Libraries.hs +++ b/hs-src/Language/Scheme/Compiler/Libraries.hs @@ -22,7 +22,7 @@ import Language.Scheme.Primitives import Language.Scheme.Types import Language.Scheme.Variables -import Control.Monad.Error +import Control.Monad.Except -- |Import all given modules and generate code for them importAll @@ -59,7 +59,7 @@ -> LispVal -> CompLibOpts -> CompOpts - -> ErrorT LispError IO [HaskAST] + -> ExceptT LispError IO [HaskAST] _importAll env metaEnv m lopts copts = do -- Resolve import resolved <- LSC.evalLisp metaEnv $ @@ -78,7 +78,7 @@ -> [LispVal] -> CompLibOpts -> CompOpts - -> ErrorT LispError IO [HaskAST] + -> ExceptT LispError IO [HaskAST] importModule env metaEnv moduleName imports lopts (CompileOptions thisFunc _ _ lastFunc) = do Atom symImport <- _gensym "importFnc" @@ -210,7 +210,7 @@ -> LispVal -> CompLibOpts -> CompOpts - -> ErrorT LispError IO [HaskAST] + -> ExceptT LispError IO [HaskAST] compileModule env metaEnv name _mod lopts (CompileOptions thisFunc _ _ lastFunc) = do -- TODO: set mod meta-data to avoid cyclic references @@ -263,7 +263,7 @@ -> LispVal -> CompLibOpts -> CompOpts - -> ErrorT LispError IO [HaskAST] + -> ExceptT LispError IO [HaskAST] cmpSubMod env metaEnv (List ((List (Atom "import-immutable" : modules)) : ls)) lopts copts = do -- Punt on this for now, although the meta-lang does the same thing @@ -293,7 +293,7 @@ -> LispVal -> CompLibOpts -> CompOpts - -> ErrorT LispError IO [HaskAST] + -> ExceptT LispError IO [HaskAST] cmpModExpr env metaEnv name (List ((List (Atom "include" : files)) : ls)) lopts@(CompileLibraryOptions _ compileLisp) (CompileOptions thisFunc _ _ lastFunc) = do @@ -350,10 +350,10 @@ -> t3 -> [t2] -> (t3 - -> t2 -> String -> Maybe String -> ErrorT LispError IO [HaskAST]) + -> t2 -> String -> Maybe String -> ExceptT LispError IO [HaskAST]) -> t1 -> CompOpts - -> ErrorT LispError IO [HaskAST] + -> ExceptT LispError IO [HaskAST] includeAll _ dir [file] include _ --lopts (CompileOptions thisFunc _ _ lastFunc) = do include dir file thisFunc lastFunc 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 @@ -62,7 +62,7 @@ import Language.Scheme.Types import Language.Scheme.Util import Language.Scheme.Variables -import Control.Monad.Error +import Control.Monad.Except import Data.Array import qualified Data.ByteString as BS import qualified Data.Map @@ -88,7 +88,7 @@ putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| " putStrLn " " putStrLn " http://justinethier.github.io/husk-scheme " - putStrLn " (c) 2010-2016 Justin Ethier " + putStrLn " (c) 2010-2021 Justin Ethier " putStrLn $ " Version " ++ (DV.showVersion PHS.version) ++ " " putStrLn " " @@ -121,7 +121,7 @@ -- libraries. If the file is not found in the current directory but exists -- as a husk library, return the full path to the file in the library. -- Otherwise just return the given filename. -findFileOrLib :: String -> ErrorT LispError IO String +findFileOrLib :: String -> ExceptT LispError IO String findFileOrLib filename = do fileAsLib <- liftIO $ getDataFileFullPath $ "lib/" ++ filename exists <- fileExists [String filename] @@ -162,7 +162,7 @@ -- of just using show directly. showLispError :: LispError -> IO String showLispError (NumArgs n lvs) = do - lvs' <- runErrorT $ mapM recDerefPtrs lvs + lvs' <- runExceptT $ mapM recDerefPtrs lvs case lvs' of Left _ -> return $ show $ NumArgs n lvs Right vals -> return $ show $ NumArgs n vals @@ -178,7 +178,7 @@ Right val -> showLispError $ BadSpecialForm str val showLispError (ErrorWithCallHist err hist) = do err' <- showLispError err - hist' <- runErrorT $ mapM recDerefPtrs hist + hist' <- runExceptT $ mapM recDerefPtrs hist case hist' of Left _ -> return $ showCallHistory err' hist Right vals -> return $ showCallHistory err' vals @@ -189,7 +189,7 @@ -- needed regardless of type. runIOThrowsREPL :: IOThrowsError String -> IO String runIOThrowsREPL action = do - runState <- runErrorT action + runState <- runExceptT action case runState of Left err -> showLispError err Right val -> return val @@ -197,7 +197,7 @@ -- |Execute an IO action and return error or Nothing if no error was thrown. runIOThrows :: IOThrowsError String -> IO (Maybe String) runIOThrows action = do - runState <- runErrorT action + runState <- runExceptT action case runState of Left err -> do disp <- showLispError err @@ -243,7 +243,7 @@ -- Right val -> putStrLn $ show val -- @ evalLisp' :: Env -> LispVal -> IO (ThrowsError LispVal) -evalLisp' env lisp = runErrorT (evalLisp env lisp) +evalLisp' env lisp = runExceptT (evalLisp env lisp) -- |A wrapper for macroEval and eval meval, mprepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal @@ -871,7 +871,7 @@ -- |Helper function to perform CPS for vector-set! and similar forms createObjSetCPS :: String -> LispVal - -> (LispVal -> LispVal -> LispVal -> ErrorT LispError IO LispVal) + -> (LispVal -> LispVal -> LispVal -> ExceptT LispError IO LispVal) -> Env -> LispVal -> LispVal @@ -1349,7 +1349,7 @@ evalfuncImport _ = throwError $ InternalError "" -- |Load import into the main environment -bootstrapImport :: [LispVal] -> ErrorT LispError IO LispVal +bootstrapImport :: [LispVal] -> ExceptT LispError IO LispVal bootstrapImport [cont@(Continuation {contClosure = env})] = do LispEnv me <- getVar env "*meta-env*" ri <- getNamespacedVar me macroNamespace "repl-import" diff --git a/hs-src/Language/Scheme/Environments.hs b/hs-src/Language/Scheme/Environments.hs --- a/hs-src/Language/Scheme/Environments.hs +++ b/hs-src/Language/Scheme/Environments.hs @@ -20,7 +20,7 @@ import Language.Scheme.Primitives import Language.Scheme.Types import Language.Scheme.Variables -import Control.Monad.Error +import Control.Monad.Except import qualified Data.Char import System.IO diff --git a/hs-src/Language/Scheme/Libraries.hs b/hs-src/Language/Scheme/Libraries.hs --- a/hs-src/Language/Scheme/Libraries.hs +++ b/hs-src/Language/Scheme/Libraries.hs @@ -19,7 +19,7 @@ ) where import Language.Scheme.Types import Language.Scheme.Variables -import Control.Monad.Error +import Control.Monad.Except -- |Get the full path to a module file findModuleFile 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 @@ -52,7 +52,7 @@ import Language.Scheme.Macro.ExplicitRenaming import qualified Language.Scheme.Macro.Matches as Matches import Language.Scheme.Primitives (_gensym) -import Control.Monad.Error +import Control.Monad.Except import Data.Array -- import Debug.Trace -- Only req'd to support trace, can be disabled at any time... @@ -138,7 +138,7 @@ _macroEval :: Env -> LispVal -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal) - -> ErrorT LispError IO LispVal + -> ExceptT LispError IO LispVal _macroEval env lisp@(List (Atom x : _)) apply = do -- Note: If there is a procedure of the same name it will be shadowed by the macro. var <- getNamespacedVar' env macroNamespace x diff --git a/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs b/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs --- a/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs +++ b/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs @@ -27,7 +27,7 @@ import Language.Scheme.Types import Language.Scheme.Variables import Language.Scheme.Primitives (_gensym) -import Control.Monad.Error +import Control.Monad.Except -- import Debug.Trace -- |Handle an explicit renaming macro diff --git a/hs-src/Language/Scheme/Numerical.hs b/hs-src/Language/Scheme/Numerical.hs --- a/hs-src/Language/Scheme/Numerical.hs +++ b/hs-src/Language/Scheme/Numerical.hs @@ -71,7 +71,7 @@ ) where import Language.Scheme.Types -import Control.Monad.Error +import Control.Monad.Except import Data.Char hiding (isNumber) import Data.Complex import Data.Fixed @@ -180,7 +180,7 @@ -> LispVal -> Either LispError LispVal) -> LispVal -> [LispVal] -> Either LispError LispVal numBoolBinopCompare cmp n1 (n2 : ns) = do - List [n1', n2'] <- numCast [n1, n2] + (n1', n2') <- numCast' (n1, n2) result <- cmp n1' n2' case result of Bool True -> numBoolBinopCompare cmp n2' ns @@ -244,30 +244,36 @@ cmp _ _ = throwError $ Default "Unexpected error in <=" -- |Accept two numbers and cast one of them to the appropriate type, if necessary -numCast :: [LispVal] -> ThrowsError LispVal -numCast [a@(Number _), b@(Number _)] = return $ List [a, b] -numCast [a@(Float _), b@(Float _)] = return $ List [a, b] -numCast [a@(Rational _), b@(Rational _)] = return $ List [a, b] -numCast [a@(Complex _), b@(Complex _)] = return $ List [a, b] -numCast [(Number a), b@(Float _)] = return $ List [Float $ fromInteger a, b] -numCast [(Number a), b@(Rational _)] = return $ List [Rational $ fromInteger a, b] -numCast [(Number a), b@(Complex _)] = return $ List [Complex $ fromInteger a, b] -numCast [a@(Float _), (Number b)] = return $ List [a, Float $ fromInteger b] -numCast [a@(Float _), (Rational b)] = return $ List [a, Float $ fromRational b] -numCast [(Float a), b@(Complex _)] = return $ List [Complex $ a :+ 0, b] -numCast [a@(Rational _), (Number b)] = return $ List [a, Rational $ fromInteger b] -numCast [(Rational a), b@(Float _)] = return $ List [Float $ fromRational a, b] -numCast [(Rational a), b@(Complex _)] = return $ List [Complex $ (fromInteger $ numerator a) / (fromInteger $ denominator a), b] -numCast [a@(Complex _), (Number b)] = return $ List [a, Complex $ fromInteger b] -numCast [a@(Complex _), (Float b)] = return $ List [a, Complex $ b :+ 0] -numCast [a@(Complex _), (Rational b)] = return $ List [a, Complex $ (fromInteger $ numerator b) / (fromInteger $ denominator b)] -numCast [a, b] = case a of +numCast' :: (LispVal, LispVal) -> ThrowsError (LispVal, LispVal) +numCast' (a@(Number _), b@(Number _)) = return $ (a, b) +numCast' (a@(Float _), b@(Float _)) = return $ (a, b) +numCast' (a@(Rational _), b@(Rational _)) = return $ (a, b) +numCast' (a@(Complex _), b@(Complex _)) = return $ (a, b) +numCast' ((Number a), b@(Float _)) = return $ (Float $ fromInteger a, b) +numCast' ((Number a), b@(Rational _)) = return $ (Rational $ fromInteger a, b) +numCast' ((Number a), b@(Complex _)) = return $ (Complex $ fromInteger a, b) +numCast' (a@(Float _), (Number b)) = return $ (a, Float $ fromInteger b) +numCast' (a@(Float _), (Rational b)) = return $ (a, Float $ fromRational b) +numCast' ((Float a), b@(Complex _)) = return $ (Complex $ a :+ 0, b) +numCast' (a@(Rational _), (Number b)) = return $ (a, Rational $ fromInteger b) +numCast' ((Rational a), b@(Float _)) = return $ (Float $ fromRational a, b) +numCast' ((Rational a), b@(Complex _)) = return $ (Complex $ (fromInteger $ numerator a) / (fromInteger $ denominator a), b) +numCast' (a@(Complex _), (Number b)) = return $ (a, Complex $ fromInteger b) +numCast' (a@(Complex _), (Float b)) = return $ (a, Complex $ b :+ 0) +numCast' (a@(Complex _), (Rational b)) = return $ (a, Complex $ (fromInteger $ numerator b) / (fromInteger $ denominator b)) +numCast' (a, b) = case a of Number _ -> doThrowError b Float _ -> doThrowError b Rational _ -> doThrowError b Complex _ -> doThrowError b _ -> doThrowError a where doThrowError num = throwError $ TypeMismatch "number" num + +-- |Accept two numbers and cast one of them to the appropriate type, if necessary +numCast :: [LispVal] -> ThrowsError LispVal +numCast [a, b] = do + (a', b') <- numCast' (a, b) + pure $ List [a', b'] numCast _ = throwError $ Default "Unexpected error in numCast" -- |Convert the given number to a rational diff --git a/hs-src/Language/Scheme/Parser.hs b/hs-src/Language/Scheme/Parser.hs --- a/hs-src/Language/Scheme/Parser.hs +++ b/hs-src/Language/Scheme/Parser.hs @@ -46,7 +46,7 @@ , parseUnquoteSpliced ) where import Language.Scheme.Types -import Control.Monad.Error +import Control.Monad.Except import Data.Array import qualified Data.ByteString as BS import qualified Data.Char as DC @@ -319,7 +319,7 @@ _ -> return c -- |Parse a hexidecimal scalar -parseHexScalar :: Monad m => String -> m Char +parseHexScalar :: String -> GenParser Char st Char parseHexScalar num = do let ns = Numeric.readHex num case ns of diff --git a/hs-src/Language/Scheme/Plugins/CPUTime.hs b/hs-src/Language/Scheme/Plugins/CPUTime.hs --- a/hs-src/Language/Scheme/Plugins/CPUTime.hs +++ b/hs-src/Language/Scheme/Plugins/CPUTime.hs @@ -20,7 +20,7 @@ import Language.Scheme.Types import System.CPUTime -import Control.Monad.Error +import Control.Monad.Except -- |Wrapper for CPUTime.getCPUTime get :: [LispVal] -> IOThrowsError LispVal 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 @@ -161,7 +161,7 @@ import Language.Scheme.Types import Language.Scheme.Variables --import qualified Control.Exception -import Control.Monad.Error +import Control.Monad.Except import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as BSU import Data.Char hiding (isSymbol) @@ -559,7 +559,7 @@ (MonadIO m, MonadError LispError m) => (Handle -> LispVal -> IO a) -> [LispVal] -> m LispVal -} writeProc :: (Handle -> LispVal -> IO a) - -> [LispVal] -> ErrorT LispError IO LispVal + -> [LispVal] -> ExceptT LispError IO LispVal writeProc func [obj] = do dobj <- recDerefPtrs obj -- Last opportunity to do this before writing writeProc func [dobj, Port stdout Nothing] 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 @@ -96,7 +96,7 @@ , validateFuncParams ) where -import Control.Monad.Error +import Control.Monad.Except import Data.Complex import Data.Array import qualified Data.ByteString as BS @@ -165,9 +165,6 @@ 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 @@ -183,7 +180,7 @@ type ThrowsError = Either LispError -- |Container used to provide error handling in the IO monad -type IOThrowsError = ErrorT LispError IO +type IOThrowsError = ExceptT LispError IO -- |Lift a ThrowsError into the IO monad liftThrows :: ThrowsError a -> IOThrowsError a diff --git a/hs-src/Language/Scheme/Variables.hs b/hs-src/Language/Scheme/Variables.hs --- a/hs-src/Language/Scheme/Variables.hs +++ b/hs-src/Language/Scheme/Variables.hs @@ -54,7 +54,7 @@ , recDerefToFnc ) where import Language.Scheme.Types -import Control.Monad.Error +import Control.Monad.Except import Data.Array import Data.IORef import qualified Data.Map 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.19.3 +Version: 3.20 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <> @@ -41,7 +41,7 @@ Maintainer: Justin Ethier Homepage: http://justinethier.github.com/husk-scheme Bug-Reports: http://github.com/justinethier/husk-scheme/issues -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 Build-Type: Simple Category: Compilers/Interpreters, Language Tested-with: GHC == 7.2.2, GHC == 7.0.2, GHC == 6.12.3, GHC == 6.10.4 @@ -73,8 +73,9 @@ default: True Library + Default-Language: Haskell2010 Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, bytestring, utf8-string, time, process, knob - Extensions: ExistentialQuantification + Default-Extensions: ExistentialQuantification Hs-Source-Dirs: hs-src Exposed-Modules: Language.Scheme.Core Language.Scheme.Environments @@ -109,15 +110,18 @@ cpp-options: -DUsePointers Executable huski + Default-Language: Haskell2010 Build-Depends: husk-scheme, base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, process if flag(useffi) Build-Depends: ghc, ghc-paths cpp-options: -DUseFfi - Extensions: ExistentialQuantification + Default-Extensions: ExistentialQuantification Main-is: shell.hs Hs-Source-Dirs: hs-src/Interpreter + Other-Modules: Paths_husk_scheme Executable huskc + Default-Language: Haskell2010 Build-Depends: husk-scheme, base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, ghc-paths, process, filepath if flag(usedebug) cpp-options: -DUseDebug @@ -126,6 +130,7 @@ cpp-options: -DUseFfi if flag(useptrs) cpp-options: -DUsePointers - Extensions: ExistentialQuantification + Default-Extensions: ExistentialQuantification Main-is: huskc.hs Hs-Source-Dirs: hs-src/Compiler + Other-Modules: Paths_husk_scheme diff --git a/lib/srfi/1.sld b/lib/srfi/1.sld --- a/lib/srfi/1.sld +++ b/lib/srfi/1.sld @@ -1,5 +1,6 @@ (define-library (srfi 1) (export-all) - (import (scheme base) + (import (scheme) + (scheme base) (scheme cxr)) (include "srfi-1.scm"))