From c73048abcc7a823d5659e157570b8a2f8dea7477 Mon Sep 17 00:00:00 2001 From: Julie Schwartz Date: Fri, 4 Aug 2023 21:41:41 +1200 Subject: [PATCH] Remove unnecessary ErrorTCompat This abstraction was added to support building with GHC 7.10 (which uses Control.Monad.Except) and older versions (which still used Control.Monad.Error), without having to introduce CPP directives everywhere. Since we no longer support those earlier GHC versions, there is no need for this API. --- src/comp/ABinUtil.hs | 18 +++++++++--------- src/comp/AConv.hs | 2 +- src/comp/ASchedule.hs | 6 +++--- src/comp/Error.hs | 14 +++++++------- src/comp/ErrorMonad.hs | 2 +- src/comp/ErrorTCompat.hs | 12 ------------ src/comp/GenWrap.hs | 8 ++++---- src/comp/IInlineFmt.hs | 6 +++--- src/comp/MakeSymTab.hs | 2 +- src/comp/SimExpand.hs | 6 +++--- src/comp/TIMonad.hs | 6 +++--- src/comp/bluetcl.hs | 16 ++++++++-------- src/comp/bsc.hs | 6 +++--- src/comp/showrules.hs | 6 +++--- 14 files changed, 49 insertions(+), 61 deletions(-) delete mode 100644 src/comp/ErrorTCompat.hs diff --git a/src/comp/ABinUtil.hs b/src/comp/ABinUtil.hs index cd0bccf63..503a9cd5d 100644 --- a/src/comp/ABinUtil.hs +++ b/src/comp/ABinUtil.hs @@ -9,8 +9,8 @@ module ABinUtil ( import Data.List(nub, partition) import Data.Maybe(isJust, fromJust) import Control.Monad(when) +import Control.Monad.Except(ExceptT, throwError) import Control.Monad.State(StateT, runStateT, lift, get, put) -import ErrorTCompat import Version(bscVersionStr) import Backend @@ -19,7 +19,7 @@ import FileIOUtil(readBinaryFileCatch, readBinFilePath) import Util(fromMaybeM) import Error(internalError, EMsg, EMsgs(..), ErrMsg(..), - ErrorHandle, bsError, bsWarning, convErrorTToIO) + ErrorHandle, bsError, bsWarning, convExceptTToIO) import Id(Id, getIdString) import Position(cmdPosition, noPosition, getPosition) import PPrint @@ -63,11 +63,11 @@ type ABinMap = M.Map String FilePath -- -- When linking Verilog, we want to try reading in a .ba hierarchy, -- but fall back to using .v files if it fails. --- Therefore, ErrorT is used to catch errors. Serious failures can +-- Therefore, ExceptT is used to catch errors. Serious failures can -- still be reported immediately, via IO -- such as file version mismatch, -- or read errors, etc. -- -type M = StateT MState (ErrorT EMsgs IO) +type M = StateT MState (ExceptT EMsgs IO) -- monad state data MState = MState { @@ -126,7 +126,7 @@ putHierMap m = get >>= \s -> put (s { m_foundmod_map = m }) getABIHierarchy :: ErrorHandle -> Bool -> [String] -> (Maybe Backend) -> [String] -> String -> [(String, ABin)] -> - ErrorT EMsgs IO + ExceptT EMsgs IO (Id, HierMap, InstModMap, ForeignFuncMap, ABinMap, [String], [(String, (ABinEitherModInfo, String))]) getABIHierarchy errh be_verbose ifc_path backend prim_names topname fabis = do @@ -202,11 +202,11 @@ getABIHierarchy errh be_verbose ifc_path backend prim_names topname fabis = do -- back the abmis with just the success data types assertNoSchedErr :: [(String, (ABinEitherModInfo, String))] -> - ErrorT EMsgs IO + ExceptT EMsgs IO [(String, (ABinModInfo, String))] assertNoSchedErr modinfos_by_name = let assertOne :: (String, (ABinEitherModInfo, String)) -> - ErrorT EMsgs IO + ExceptT EMsgs IO (String, (ABinModInfo, String)) assertOne (name, (eabmi, ver)) = case eabmi of @@ -472,7 +472,7 @@ readAndCheckABin errh backend filename = do -- returns the filename and the contents readAndCheckABinPath :: ErrorHandle -> Bool -> [String] -> (Maybe Backend) -> String -> - (ErrorT EMsgs IO) (Maybe (String, ABin)) + (ExceptT EMsgs IO) (Maybe (String, ABin)) readAndCheckABinPath errh be_verbose path backend mod_name = do let binname = mod_name ++ "." ++ abinSuffix mread <- lift $ readBinFilePath errh noPosition be_verbose binname path @@ -494,7 +494,7 @@ readAndCheckABinPathCatch :: ErrorHandle -> Bool -> [String] -> (Maybe Backend) -> String -> EMsg -> IO (String, ABin) readAndCheckABinPathCatch errh be_verbose path backend mod_name errmsg = do - mabi <- convErrorTToIO errh $ + mabi <- convExceptTToIO errh $ readAndCheckABinPath errh be_verbose path backend mod_name case mabi of Nothing -> bsError errh [errmsg] diff --git a/src/comp/AConv.hs b/src/comp/AConv.hs index ef2982da5..2ea42a585 100644 --- a/src/comp/AConv.hs +++ b/src/comp/AConv.hs @@ -2,8 +2,8 @@ module AConv (aConv, aTypeConv, isLocalAId) where import Util(itos, headOrErr, initOrErr, lastOrErr, log2, concatMapM, makePairs) import qualified Data.Map as M -import ErrorTCompat import Control.Monad(when, liftM, forM, zipWithM) +import Control.Monad.Except(throwError) import Control.Monad.State(StateT, runStateT, gets, get, put) import Control.Monad.Reader(ReaderT, runReaderT, withReaderT, ask) import PPrint(ppReadable, ppString) diff --git a/src/comp/ASchedule.hs b/src/comp/ASchedule.hs index b44191390..71607f32f 100644 --- a/src/comp/ASchedule.hs +++ b/src/comp/ASchedule.hs @@ -19,8 +19,8 @@ import Prelude hiding ((<>)) import Data.List import Data.Maybe -import ErrorTCompat import Control.Monad(when, foldM) +import Control.Monad.Except(ExceptT, runExceptT, throwError) import Control.Monad.State(StateT, runStateT, lift, get, put) import System.IO.Unsafe import Debug.Trace(traceM) @@ -355,7 +355,7 @@ csGraphToSchedGraph edges = -- In order to record the warnings during scheduling, we operate on a -- state monad which stores the EMsgs. -type SM = ErrorT EMsgs (StateT SState IO) +type SM = ExceptT EMsgs (StateT SState IO) data SState = SState { sm_warnings :: [EMsg], @@ -426,7 +426,7 @@ aSchedule :: ErrorHandle -> Flags -> IO (Either AScheduleErrInfo (AScheduleInfo, APackage)) aSchedule errh flags prefix urgency_pairs pps amod = do let f = aSchedule' errh flags prefix urgency_pairs pps amod - (result, s) <- runStateT (runErrorT f) initSState + (result, s) <- runStateT (runExceptT f) initSState let processWarning e@(pos,msg) = (pos, getErrMsgTag msg, showWarningList [e]) diff --git a/src/comp/Error.hs b/src/comp/Error.hs index 048a11cfc..6c209742c 100644 --- a/src/comp/Error.hs +++ b/src/comp/Error.hs @@ -39,8 +39,8 @@ module Error( -- exit with the same code as a system call that failed exitFailWith, - -- report errors in ErrorT [EMsg] IO - convErrorTToIO, + -- report errors in ExceptT [EMsg] IO + convExceptTToIO, -- used for displaying messages as a string -- (in .ba file, in Verilog dynamic error, in Tcl) @@ -70,8 +70,8 @@ import Data.List(genericLength) import qualified Data.Set as S import System.IO(Handle, hClose, hPutStr, stderr) import System.Exit(exitWith, ExitCode(..)) -import ErrorTCompat import Control.Monad(when) +import Control.Monad.Except(ExceptT, runExceptT) import qualified Control.Exception as CE import Data.IORef import System.IO.Unsafe(unsafePerformIO) @@ -413,15 +413,15 @@ exitOK ref = do -- ------------------------- --- We can't use [EMsg] with ErrorT because it leads to overlapping +-- We can't use [EMsg] with ExceptT because it leads to overlapping -- instance problems. Instead, we will wrap it with a newtype. newtype EMsgs = EMsgs { errmsgs :: [EMsg] } -- ------------------------- -convErrorTToIO :: ErrorHandle -> ErrorT EMsgs IO a -> IO a -convErrorTToIO ref fn = - do mres <- runErrorT fn +convExceptTToIO :: ErrorHandle -> ExceptT EMsgs IO a -> IO a +convExceptTToIO ref fn = + do mres <- runExceptT fn case mres of Left msgs -> bsError ref (errmsgs msgs) Right res -> return res diff --git a/src/comp/ErrorMonad.hs b/src/comp/ErrorMonad.hs index 2e8dde519..067258384 100644 --- a/src/comp/ErrorMonad.hs +++ b/src/comp/ErrorMonad.hs @@ -2,8 +2,8 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module ErrorMonad(ErrorMonad(..), convErrorMonadToIO) where -import ErrorTCompat import Control.Monad(ap) +import Control.Monad.Except(MonadError, throwError, catchError) #if !defined(__GLASGOW_HASKELL__) || ((__GLASGOW_HASKELL__ >= 800) && (__GLASGOW_HASKELL__ < 808)) import Control.Monad.Fail(MonadFail(..)) #endif diff --git a/src/comp/ErrorTCompat.hs b/src/comp/ErrorTCompat.hs deleted file mode 100644 index b5f7d3811..000000000 --- a/src/comp/ErrorTCompat.hs +++ /dev/null @@ -1,12 +0,0 @@ -module ErrorTCompat ( - ErrorT, - runErrorT, - MonadError(..) -) where - -import Control.Monad.Except - -type ErrorT = ExceptT - -runErrorT :: ErrorT e m a -> m (Either e a) -runErrorT = runExceptT diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 93f4066dd..f2b61dc1e 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -10,8 +10,8 @@ import Prelude hiding ((<>)) #endif import Data.List(nub, (\\), find) -import ErrorTCompat import Control.Monad(when, foldM, filterM, zipWithM, mapAndUnzipM) +import Control.Monad.Except(ExceptT, runExceptT, throwError) import Control.Monad.State(StateT, runStateT, lift, gets, get, put) import PFPrint import Position(Position, noPosition, getPositionLine, cmdPosition) @@ -50,7 +50,7 @@ import GenWrapUtils -- ==================== -type GWMonad = StateT GenState (ErrorT EMsgs IO) +type GWMonad = StateT GenState (ExceptT EMsgs IO) data GenState = GenState { @@ -62,7 +62,7 @@ data GenState = GenState runGWMonad :: GWMonad a -> GenState -> IO a runGWMonad f s = do let errh = errHandle s - result <- runErrorT ((runStateT f) s) + result <- runExceptT ((runStateT f) s) case result of Right (res, _) -> return res Left msgs -> bsError errh (errmsgs msgs) @@ -77,7 +77,7 @@ runGWMonadNoFail f s = -- and we don't expect it to fail runGWMonadGetNoFail :: GWMonad a -> GenState -> IO (GenState, a) runGWMonadGetNoFail f s = - do result <- runErrorT ((runStateT f) s) + do result <- runExceptT ((runStateT f) s) case result of Right (res, s2) -> return (s2, res) Left msgs -> internalError ("runGWMonadGetNoFail: " ++ diff --git a/src/comp/IInlineFmt.hs b/src/comp/IInlineFmt.hs index c1b860fca..54c117277 100644 --- a/src/comp/IInlineFmt.hs +++ b/src/comp/IInlineFmt.hs @@ -8,7 +8,7 @@ import Id import Prim import PreIds(idActionValue_, idArrow, tmpVarIds, idAVValue_, idAVAction_, idPrimFmtConcat) import ForeignFunctions -import ErrorTCompat +import Control.Monad.Except(ExceptT, runExceptT) import Control.Monad.State import Error(EMsg, ErrorHandle, bsError) import Position(noPosition) @@ -16,7 +16,7 @@ import CType(TISort(..), StructSubType(..)) import qualified Data.Map as M -- import Debug.Trace(trace) -type F a = StateT (Int, [IDef a]) (ErrorT EMsg (IO)) +type F a = StateT (Int, [IDef a]) (ExceptT EMsg (IO)) newFFCallNo :: (F a) Integer newFFCallNo = do (n, ds) <- get @@ -37,7 +37,7 @@ iInlineFmt errh imod = do let imod_fmt = iInlineFmts imod let ffcallNo = (imod_ffcallNo imod_fmt) let ds = (imod_local_defs imod_fmt) - result <- runErrorT (runStateT (splitFmtsF imod_fmt) (ffcallNo, [])) + result <- runExceptT (runStateT (splitFmtsF imod_fmt) (ffcallNo, [])) case result of Right x@(imod', (ffcallNo', ds')) -> return (imod' {imod_local_defs = ds ++ ds', diff --git a/src/comp/MakeSymTab.hs b/src/comp/MakeSymTab.hs index 793604298..ffbc1043f 100644 --- a/src/comp/MakeSymTab.hs +++ b/src/comp/MakeSymTab.hs @@ -12,8 +12,8 @@ import Prelude hiding ((<>)) #endif import Data.List -import ErrorTCompat import Control.Monad(when) +import Control.Monad.Except(throwError) import qualified Data.Set as S import qualified Data.Map as M diff --git a/src/comp/SimExpand.hs b/src/comp/SimExpand.hs index 027996c22..bbacf1bad 100644 --- a/src/comp/SimExpand.hs +++ b/src/comp/SimExpand.hs @@ -10,7 +10,7 @@ import qualified Data.Set as S import IOUtil(progArgs) import Error (internalError, EMsg, ErrMsg(..), ErrorHandle, bsError, - convErrorTToIO) + convExceptTToIO) import Position (noPosition, getPosition) import PPrint import Flags @@ -66,11 +66,11 @@ simExpand errh flags topname fabis = do let prim_names = map sb_name primBlocks (topmodId, hiermap, instmap, ffuncmap, filemap, _, emodinfos_used_by_name) - <- convErrorTToIO errh $ + <- convExceptTToIO errh $ getABIHierarchy errh (verbose flags) (ifcPath flags) (Just Bluesim) prim_names topname fabis - modinfos_used_by_name <- convErrorTToIO errh $ + modinfos_used_by_name <- convExceptTToIO errh $ assertNoSchedErr emodinfos_used_by_name -- reject top-level modules with always_enabled ifc, if generating diff --git a/src/comp/TIMonad.hs b/src/comp/TIMonad.hs index 2651ee422..82a65564a 100644 --- a/src/comp/TIMonad.hs +++ b/src/comp/TIMonad.hs @@ -43,8 +43,8 @@ import Assump import SymTab import PreIds(idBits, idLiteral, idRealLiteral, idSizedLiteral, idStringLiteral, idNumEq) -import ErrorTCompat import Control.Monad(when) +import Control.Monad.Except(ExceptT, runExceptT, throwError, catchError) import Control.Monad.State(State, StateT, runState, runStateT, lift, gets, get, put, modify) import Data.List(partition) @@ -128,7 +128,7 @@ sizedStackModify (SizedStack size (x:rest)) f = sizedStackModify _ _ = internalError "sizedStackModify: stack underflow" -- state/error monad with bsc error messages and hidden TState -type TI = StateT TStateRecover (ErrorT EMsgs (State TStatePersistent)) +type TI = StateT TStateRecover (ExceptT EMsgs (State TStatePersistent)) -- apply the current substitution to something apSubTI :: (Types a) => a -> TI a @@ -158,7 +158,7 @@ runTI :: Flags -> Bool -> SymTab -> TI a -> (Either [EMsg] a, [WMsg]) runTI flags ai s m = (final_result, tsWarns pState) where (result, pState) = runState error_run (initPersistentState flags ai s) - error_run = (runErrorT (runStateT m initRecoverState)) + error_run = (runExceptT (runStateT m initRecoverState)) rec_errors = tsRecoveredErrors pState final_result = case result of diff --git a/src/comp/bluetcl.hs b/src/comp/bluetcl.hs index c134743ff..abb46eb99 100644 --- a/src/comp/bluetcl.hs +++ b/src/comp/bluetcl.hs @@ -47,7 +47,7 @@ import Flags(Flags(..), verbose) import FlagsDecode(defaultFlags, decodeFlags, adjustFinalFlags, updateFlags, showFlagsLst, showFlagsAllLst, getFlagValueString) import Error(internalError, EMsg, ErrMsg(..), showErrorList, - ErrorHandle, initErrorHandle, convErrorTToIO) + ErrorHandle, initErrorHandle, convExceptTToIO) import Id import PPrint import PVPrint @@ -975,7 +975,7 @@ tclModule ["load",topname] = do ": it is a primitive module") -- getABIHierarchy calls GenABin.readABinFile to read a .ba file (topmodId, hierMap, instModMap, ffuncMap, _, foreign_mods, abmis_by_name) - <- convErrorTToIO globalErrHandle $ + <- convExceptTToIO globalErrHandle $ getABIHierarchy globalErrHandle (verbose flags) (ifcPath flags) (Just gen_backend) prim_names topname [] @@ -3285,13 +3285,13 @@ data IfcField = getIfcHierarchy :: Maybe Id -> [(Id, RawIfcField)] -> Type -> IO [IfcField] getIfcHierarchy instId raw_fields tifc = do - mres <- runErrorT (mgetIfcHierarchy instId raw_fields tifc) + mres <- runExceptT (mgetIfcHierarchy instId raw_fields tifc) case mres of Right res -> return res Left msg -> internalError msg mgetIfcHierarchy :: Maybe Id -> [(Id, RawIfcField)] -> Type -> - ErrorT String IO [IfcField] + ExceptT String IO [IfcField] mgetIfcHierarchy instId raw_fields tifc = do -- use "expandSyn" to avoid getting back "Alias" as the type analysis maifc <- lift $ getTypeAnalysis' (expandSyn tifc) True @@ -3301,7 +3301,7 @@ mgetIfcHierarchy instId raw_fields tifc = do ifc_map = M.fromList raw_fields -- get the AIF for a flattened name - lookupAIF :: Id -> ErrorT String IO RawIfcField + lookupAIF :: Id -> ExceptT String IO RawIfcField lookupAIF i = case (M.lookup i ifc_map) of Just aif -> return aif @@ -3322,10 +3322,10 @@ mgetIfcHierarchy instId raw_fields tifc = do -- get the IfcField for one field getField :: Id -> (Bool, Id, Qual Type, [IfcPragma]) -> - ErrorT String IO IfcField + ExceptT String IO IfcField getField prefix (_, fId, (_ :=> t), _) = getField' prefix fId t - getField' :: Id -> Id -> Type -> ErrorT String IO IfcField + getField' :: Id -> Id -> Type -> ExceptT String IO IfcField getField' prefix fId t = do -- Function for expanding Vectors of subinterfaces -- (or pseudo-interfaces like Clock, Reset, Inout) @@ -3530,7 +3530,7 @@ getSubmodPortInfo mtifc avi = do let defl_ifc_hier = [ (Field fId inf Nothing) | (fId, inf) <- ifc_map ] in case mtifc of Just tifc -> do - mres <- runErrorT $ + mres <- runExceptT $ mgetIfcHierarchy (Just (avi_vname avi)) ifc_map tifc case mres of Right res -> return res diff --git a/src/comp/bsc.hs b/src/comp/bsc.hs index 776d65165..43db1e035 100644 --- a/src/comp/bsc.hs +++ b/src/comp/bsc.hs @@ -20,7 +20,7 @@ import Data.Maybe(isJust, isNothing {-, fromMaybe-}) import Numeric(showOct) import Control.Monad(when, unless, filterM, liftM, foldM) -import ErrorTCompat(runErrorT) +import Control.Monad.Except(runExceptT) import Control.Concurrent(forkIO) import Control.Concurrent.MVar(newEmptyMVar, putMVar, takeMVar) import qualified Control.Exception as CE @@ -1873,7 +1873,7 @@ vLink errh flags topmod_name vfilenames0 afilenames cfilenames = do -- see if .ba files exist for the top-level of this design let prim_names = map sb_name primBlocks - mhier0 <- runErrorT $ + mhier0 <- runExceptT $ getABIHierarchy errh (verbose flags) (ifcPath flags) (Just Verilog) prim_names topmod_name user_abis @@ -1881,7 +1881,7 @@ vLink errh flags topmod_name vfilenames0 afilenames cfilenames = do mhier <- case mhier0 of Left msgs -> return (Left msgs) Right (a, b, c, d, e, f, emodinfos) -> do - mres <- runErrorT (assertNoSchedErr emodinfos) + mres <- runExceptT (assertNoSchedErr emodinfos) case mres of Left msgs -> return (Left msgs) Right modinfos -> return $ diff --git a/src/comp/showrules.hs b/src/comp/showrules.hs index 792662efe..868857728 100644 --- a/src/comp/showrules.hs +++ b/src/comp/showrules.hs @@ -13,7 +13,7 @@ import Id( Id, getIdString, getIdBaseString, getIdQualString import Error(internalError, EMsg, WMsg, ErrMsg(..), ErrorHandle, initErrorHandle, exitOK, exitFail, bsErrorNoExit, bsWarning, - convErrorTToIO) + convExceptTToIO) import Util(separate, headOrErr, fromJustOrErr, unconsOrErr) import IOUtil(getEnvDef) import TopUtils(dfltBluespecDir) @@ -300,9 +300,9 @@ hmain argv = do let prim_names = map sb_name primBlocks when (verbose) $ putStrLn "Reading design data from .ba files..." (_, hier_map, inst_map, _, _, _, abemis_by_name) - <- convErrorTToIO errh $ + <- convExceptTToIO errh $ getABIHierarchy errh verbose ba_path Nothing prim_names top_mod [] - abmis_by_name <- convErrorTToIO errh $ assertNoSchedErr abemis_by_name + abmis_by_name <- convExceptTToIO errh $ assertNoSchedErr abemis_by_name -- analyze design in preparation for VCD interpretation when (verbose) $ putStrLn "Analyzing design structure..."