Resolve ghc 9.2 warnings

src/comp/AAddScheduleDefs.hs

@@ -21,7 +21,7 @@ import PreIds(id_write)
 import qualified Data.Map as M
 
 import Data.List(intersect)
-import Data.Maybe(isJust, fromJust, fromMaybe, maybeToList, mapMaybe)
+import Data.Maybe(fromJust, fromMaybe, maybeToList, mapMaybe)
 
 -- import Debug.Trace
 
@@ -110,10 +110,10 @@ aAddScheduleDefs flags pps pkg aschedinfo =
                        , isRdyId (aIfaceName m)
                        ]
          pre_en_map  = M.fromList $
-                       map (\(n,Just e) -> (n,e))
-                           (filter (isJust . snd)
-                                   [ (aIfaceName m, getMethodEnExpr m)
-                                   | m <- ifc0 ])
+                       [ (aIfaceName m, e)
+                       | m <- ifc0
+                       , (Just e) <- [getMethodEnExpr m]
+                       ]
          (rdy_map, rdy_proof_obs) =
              handleAlwaysReady (unsafeAlwaysRdy flags) pkgpos pps pre_rdy_map
          (en_map, enrdy_proof_obs) =

src/comp/ABinUtil.hs

@@ -8,8 +8,9 @@ module ABinUtil (
 
 import Data.List(nub, partition)
 import Data.Maybe(isJust, fromJust)
-import Control.Monad.State
-import ErrorTCompat
+import Control.Monad(when)
+import Control.Monad.Except(ExceptT, throwError)
+import Control.Monad.State(StateT, runStateT, lift, get, put)
 
 import Version(bscVersionStr)
 import Backend
@@ -18,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
@@ -62,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 {
@@ -125,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
@@ -201,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
@@ -471,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
@@ -493,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]

src/comp/ACheck.hs

@@ -109,7 +109,7 @@ chkAIface aa@(AIInout { aif_inout = r }) =
     tracePP "chkAIface AIInout" aa $ chkAInout r
 
 chkCond :: AType -> Bool
-chkCond t = isBit t && (let (ATBit sz) = t in (sz == 1))
+chkCond = isBit1
 
 chkAAction :: AAction -> Bool
 chkAAction aa@(ACall i m (c:es)) =
@@ -319,7 +319,8 @@ isBit (ATBit _) = True
 isBit _ = False
 
 isBit1 :: AType -> Bool
-isBit1 t = isBit t && (aSize t == 1)
+isBit1 (ATBit sz) = (sz == 1)
+isBit1 _ = False
 
 isString :: AType -> Bool
 isString (ATString _) = True

src/comp/ACleanup.hs

@@ -6,7 +6,8 @@ import DisjointTest(DisjointTestState, initDisjointTestState,
                     addADefToDisjointTestState, checkDisjointExprWithCtx)
 import Data.Maybe
 import Flags(Flags)
-import Control.Monad.State
+import Control.Monad(when)
+import Control.Monad.State(StateT, evalStateT, liftIO, get, put)
 import FStringCompat(mkFString)
 import Position(noPosition)
 import Id

src/comp/AConv.hs

@@ -2,9 +2,10 @@ module AConv (aConv, aTypeConv, isLocalAId) where
 
 import Util(itos, headOrErr, initOrErr, lastOrErr, log2, concatMapM, makePairs)
 import qualified Data.Map as M
-import Control.Monad.State hiding (forM)
-import ErrorTCompat
-import Control.Monad.Reader hiding (forM)
+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)
 import PFPrint(pfpString)
 import Position
@@ -33,8 +34,6 @@ import VModInfo(lookupOutputClockWires, lookupOutputResetWire,
 import SignalNaming
 import InstNodes(mkInstTree)
 
-import Data.Traversable(forM)
-
 -- import Wires
 
 -- Used by commented-out makeIdMap
@@ -519,7 +518,7 @@ aExpr e@(IAps (ICon m (ICSel { })) _
                 Nothing -> internalError
                                ("aExpr: avValue_ on ICForeign without fcallNo")
                 Just val -> val
-        t@(ATBit _) = aTypeConvE e (iGetType e)
+        t = aTypeConvE e (iGetType e)
     in
         return (ATaskValue t i name isC n)
 
@@ -534,7 +533,7 @@ aExpr e@(IAps (ICon m (ICSel { })) _
                 Nothing -> internalError
                                ("aExpr: avValue_ on ICForeign without fcallNo")
                 Just val -> val
-        t@(ATBit _) = aTypeConvE e (iGetType e)
+        t = aTypeConvE e (iGetType e)
     in
         -- the value side carries no arguments
         -- the cookie "n" will connect it back up to the action side
@@ -966,4 +965,6 @@ eTrunc errh n e =
     then let e' = IAps (icSelect noPosition) [ITNum n, ITNum 0, ITNum k] [e]
          in  fst (iTransExpr errh e')
     else e
-  where ATBit k = aTypeConvE e (iGetType e)
+  where k = case aTypeConvE e (iGetType e) of
+              ATBit sz -> sz
+              _ -> internalError "AConv.eTrunc: unexpected type"

src/comp/AExpr2STP.hs

@@ -12,7 +12,9 @@ module AExpr2STP(
        checkNotEq
 ) where
 
-import Control.Monad.State
+import Control.Monad(when)
+import Control.Monad.State(StateT, runStateT, liftIO,
+                           gets, get, put, modify)
 import qualified Data.Map as M
 import qualified STP as S
 

src/comp/AExpr2Yices.hs

@@ -12,7 +12,9 @@ module AExpr2Yices(
        checkNotEq
 ) where
 
-import Control.Monad.State
+import Control.Monad(when)
+import Control.Monad.State(StateT, runStateT, liftIO,
+                           gets, get, put, modify)
 import qualified Data.Map as M
 import qualified Yices as Y
 import Data.Word(Word32)

src/comp/AOpt.hs

@@ -11,14 +11,16 @@ module AOpt(aOpt,
             ) where
 
 
-import Control.Monad.State
+import Control.Monad(when, foldM, zipWithM)
+import Control.Monad.State(State, StateT, evalState, evalStateT, liftIO,
+                           gets, get, put)
 import Data.List(sortBy, genericLength, sort, transpose, partition, groupBy, nub)
 import ListUtil(mapFst)
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Util(allSame, flattenPairs, makePairs, remOrdDup, integerToBits,
             itos, eqSnd, cmpSnd, nubByFst, map_insertManyWith,
-            headOrErr, initOrErr, lastOrErr)
+            headOrErr, initOrErr, lastOrErr, unconsOrErr)
 import IntegerUtil(integerSelect)
 import PPrint
 import IntLit
@@ -1003,10 +1005,9 @@ collIf findf v ces d =
 collIfPrim :: (AId -> AExpr) -> AExpr -> [(AExpr, AExpr)] -> AExpr -> Maybe ([(AExpr, AExpr)], AExpr)
 collIfPrim findf v ces (APrim _ _ PrimIf [_, t, e]) | t == e =
         Just $ collIf findf v ces t
-collIfPrim findf v ces (APrim _ _ PrimIf [cond, t, e]) | me /= Nothing =
+collIfPrim findf v ces (APrim _ _ PrimIf [cond, t, e])
+  | (Just cs) <- getConsts findf (== v) cond =
         Just $ collIf findf v (zip (map snd cs) (repeat t) ++ ces) e
-  where me = getConsts findf (== v) cond
-        Just cs = me
 collIfPrim findf v ces (APrim _ _ PrimCase (v':d:ces')) | v == v' =
         Just (reverse ces ++ makePairs ces', d)
 collIfPrim _ _ ces d = Nothing
@@ -1593,7 +1594,7 @@ optAndOrExpr :: AExpr -> SIO AExpr
 optAndOrExpr (APrim i t@(ATBit 1) op es)
     | (op == PrimBAnd) || (op == PrimAnd) = do
   es1 <- mapM optAndOrExpr es
-  let (e1:er1) = reverse es1
+  let (e1, er1) = unconsOrErr "AOpt.optAndOrExpr And" (reverse es1)
   es2 <- foldM testBuildAnd [e1] er1
   checkIfConst  $ case es2 of
                     [e] -> e
@@ -1603,7 +1604,7 @@ optAndOrExpr (APrim i t@(ATBit 1) op es)
 optAndOrExpr (APrim i t@(ATBit 1) op es)
     | (op == PrimBOr) || (op == PrimOr) = do
   es1 <- mapM optAndOrExpr es
-  let (e1:er1) = reverse es1
+  let (e1,er1) = unconsOrErr "AOpt.optAndOrExpr Or" (reverse es1)
   es2 <- foldM testBuildOr [e1] er1
   checkIfConst $ case es2 of
                    [e] -> e

src/comp/ARankMethCalls.hs

@@ -2,7 +2,7 @@ module ARankMethCalls(aRankMethCalls) where
 
 import Data.List
 import Data.Maybe
-import Control.Monad.State
+import Control.Monad(when)
 
 import ASyntax
 import FStringCompat

src/comp/ASchedule.hs

@@ -19,8 +19,9 @@ import Prelude hiding ((<>))
 
 import Data.List
 import Data.Maybe
-import ErrorTCompat
-import Control.Monad.State
+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)
 import qualified Data.Map as M
@@ -43,7 +44,7 @@ import Error(internalError, EMsg, WMsg, EMsgs(..), ErrMsg(..),
              showErrorList, showWarningList, getErrMsgTag)
 import ErrorMonad(ErrorMonad(..))
 import PFPrint
-import PPrint(vsep)
+import PPrint(vsep, commaSep)
 import SCC(scc,tsort)
 import Id(Id, emptyId, getIdString, getIdBaseString, getIdPosition,
           isRdyId, addToBase, mk_homeless_id, mkIdWillFire, addSuffix)
@@ -354,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],
@@ -425,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])
@@ -3141,8 +3142,7 @@ makeRuleBetweenEdges ruleBetweenMap ruleMethodUseMap ruleNames sched_id_order =
                             pairs =
                               [ (m1, m2)
                                   | let m_methods2 = M.lookup inst r2_usemap,
-                                    isJust m_methods2,
-                                    let (Just methods2) = m_methods2,
+                                    (Just methods2) <- [m_methods2],
                                     (methId1, _) <- methods1,
                                     (methId2, _) <- methods2,
                                     methId1 /= methId2,
@@ -4276,11 +4276,8 @@ verifySafeRuleActions flags userDefs rulePCConflictUseMap dtstate = do
               | otherwise = (True, Just $ text "...")
           mkArgs es
               | null es   = (False, empty)
-              | show_all  = (False, ppeCommaSep es)
+              | show_all  = (False, commaSep (map ppe es))
               | otherwise = (True, text "...")
-          ppeCommaSep xs = let (y:ys) = reverse (map ppe xs)
-                               ys' = map (<> text ",") ys
-                           in  sep $ reverse (y:ys')
           -- (method, hasCond, args, moreInfo)
           getUseInfo :: UniqueUse -> (String, Maybe Doc, Doc, Bool)
           getUseInfo u@(UUExpr (AMethCall _ i m es) _) =
@@ -4419,7 +4416,7 @@ verifyStaticScheduleOneRule errh flags gen_backend
                                 let m2 = MethodId inst methId2,
                                 -- either direction is an error
                                 let m_rs = findBetween m1 m2,
-                                isJust m_rs, let Just rs = m_rs ]
+                                (Just rs) <- [m_rs] ]
            in  if (null badPairs)
                then Nothing
                else Just (rule, badPairs)
@@ -4526,8 +4523,7 @@ verifyStaticScheduleTwoRules errh flags gen_backend moduleId
                             pairs =
                               [ (m1, m2)
                                   | let m_methods2 = M.lookup inst r2_usemap,
-                                    isJust m_methods2,
-                                    let (Just methods2) = m_methods2,
+                                    (Just methods2) <- [m_methods2],
                                     (methId1, _) <- methods1,
                                     (methId2, _) <- methods2,
                                     methId1 /= methId2,
@@ -5200,8 +5196,7 @@ addAllMEAssumps pragmas rules =
 addMEAssumps :: [ASchedulePragma] -> ARule -> ARuleId -> [(ARule,(ARuleId,[ARuleId]))]
 addMEAssumps pragmas r@(ARule { arule_id = rid }) new_id = rs
   where me_pairs = extractMEPairsSP pragmas
-        getRule ids = l
-          where (l:_) = ids
+        getRule ids = headOrErr "addMEAssumps getRule" ids
         check_pairs :: [(ARuleId, [([ARuleId],[ARuleId])])]
         check_pairs = [ ((getRule (as ++ bs)), [(as, bs)]) | (as, bs) <- me_pairs ]
         check_map = M.fromListWith (++) check_pairs

src/comp/AState.hs

@@ -917,7 +917,10 @@ mkBlob mMap omMultMap (method@(MethodId obj met), usedPorts) =
 
       -- The list of converted uses per port
       -- (This intermediate step is exposed to make "u" available to "uExp".)
-      uses@(((u, _):_):_) = map (map cvt) portUses
+      uses = map (map cvt) portUses
+      u = case uses of
+            (((uu, _):_):_) -> uu
+            _ -> internalError "AState.mkBlob: u"
 
       -- Complete the conversion to make a list of MethPortBlob
       meth_port_blobs :: [MethPortBlob]

src/comp/ASyntax.hs

@@ -1600,10 +1600,8 @@ ppeString ds ec =
 
 instance (PPrintExpand a) => PPrintExpand [a] where
     pPrintExpand _ d _ [] = text "[]"
-    pPrintExpand m d _ xs = let (y:ys) = reverse (map (pPrintExpand m d defContext) xs)
-                                ys' = map (<> text ",") ys
-                                xs' = reverse (y:ys')
-                            in  text "[" <> sep xs' <> text "]"
+    pPrintExpand m d _ xs = let xs' = map (pPrintExpand m d defContext) xs
+                            in  text "[" <> commaSep xs' <> text "]"
 
 ppeAPackage :: Int -> PDetail -> APackage -> Doc
 ppeAPackage lim d apkg@(APackage { apkg_local_defs = ds }) =

src/comp/AUses.hs

@@ -78,7 +78,8 @@ import PVPrint
 import ErrorUtil(internalError)
 import Prim
 import IntLit
-import Control.Monad.State.Strict
+import Control.Monad(liftM, mapAndUnzipM)
+import Control.Monad.State.Strict(State, runState, get, put)
 -- import Debug.Trace