Change zipWith to zipWithEqual in a few places

12 files changed, 28 insertions, 21 deletions

diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs
index dca2f90c34..6a93006791 100644
--- a/compiler/GHC/Core/Coercion/Opt.hs
+++ b/compiler/GHC/Core/Coercion/Opt.hs
@@ -559,8 +559,9 @@ opt_univ env sym prov role oty1 oty2
       PluginProv _       -> prov
 
 -------------
-opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
-opt_transList is = zipWith (opt_trans is)
+opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
+opt_transList is = zipWithEqual "opt_transList" (opt_trans is)
+  -- The input lists must have identical length.
 
 opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo
 opt_trans is co1 co2
@@ -659,14 +660,12 @@ opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
 -- Eta rules
 opt_trans_rule is co1@(TyConAppCo r tc cos1) co2
   | Just cos2 <- etaTyConAppCo_maybe tc co2
-  = ASSERT( cos1 `equalLength` cos2 )
-    fireTransRule "EtaCompL" co1 co2 $
+  = fireTransRule "EtaCompL" co1 co2 $
     mkTyConAppCo r tc (opt_transList is cos1 cos2)
 
 opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)
   | Just cos1 <- etaTyConAppCo_maybe tc co1
-  = ASSERT( cos1 `equalLength` cos2 )
-    fireTransRule "EtaCompR" co1 co2 $
+  = fireTransRule "EtaCompR" co1 co2 $
     mkTyConAppCo r tc (opt_transList is cos1 cos2)
 
 opt_trans_rule is co1@(AppCo co1a co1b) co2
diff --git a/compiler/GHC/Core/Op/FloatIn.hs b/compiler/GHC/Core/Op/FloatIn.hs
index 381dd0ddba..819412161a 100644
--- a/compiler/GHC/Core/Op/FloatIn.hs
+++ b/compiler/GHC/Core/Op/FloatIn.hs
@@ -169,7 +169,9 @@ fiExpr platform to_drop ann_expr@(_,AnnApp {})
   = wrapFloats drop_here $ wrapFloats extra_drop $
     mkTicks ticks $
     mkApps (fiExpr platform fun_drop ann_fun)
-           (zipWith (fiExpr platform) arg_drops ann_args)
+           (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args)
+           -- use zipWithEqual, we should have
+           -- length ann_args = length arg_fvs = length arg_drops
   where
     (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr
     fun_ty  = exprType (deAnnotate ann_fun)
@@ -466,7 +468,8 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)
   = wrapFloats drop_here1 $
     wrapFloats drop_here2 $
     Case (fiExpr platform scrut_drops scrut) case_bndr ty
-         (zipWith fi_alt alts_drops_s alts)
+         (zipWithEqual "fiExpr" fi_alt alts_drops_s alts)
+         -- use zipWithEqual, we should have length alts_drops_s = length alts
   where
         -- Float into the scrut and alts-considered-together just like App
     [drop_here1, scrut_drops, alts_drops]
diff --git a/compiler/GHC/Core/Op/OccurAnal.hs b/compiler/GHC/Core/Op/OccurAnal.hs
index 0bc3cb720a..98ac42271d 100644
--- a/compiler/GHC/Core/Op/OccurAnal.hs
+++ b/compiler/GHC/Core/Op/OccurAnal.hs
@@ -1319,7 +1319,7 @@ mkLoopBreakerNodes :: OccEnv -> TopLevelFlag
 --   d) adjust each RHS's usage details according to
 --      the binder's (new) shotness and join-point-hood
 mkLoopBreakerNodes env lvl bndr_set body_uds details_s
-  = (final_uds, zipWith mk_lb_node details_s bndrs')
+  = (final_uds, zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')
   where
     (final_uds, bndrs')
        = tagRecBinders lvl body_uds
diff --git a/compiler/GHC/Core/Op/SpecConstr.hs b/compiler/GHC/Core/Op/SpecConstr.hs
index 0a72edce8d..ae8cd892f0 100644
--- a/compiler/GHC/Core/Op/SpecConstr.hs
+++ b/compiler/GHC/Core/Op/SpecConstr.hs
@@ -1311,7 +1311,9 @@ scExpr' env (Let (Rec prs) body)
                 -- See Note [Local recursive groups]
 
         ; let all_usg = spec_usg `combineUsage` body_usg  -- Note [spec_usg includes rhs_usg]
-              bind'   = Rec (concat (zipWith ruleInfoBinds rhs_infos specs))
+              bind'   = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs))
+                        -- zipWithEqual: length of returned [SpecInfo]
+                        -- should be the same as incoming [RhsInfo]
 
         ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
                   Let bind' body') }
diff --git a/compiler/GHC/Core/Op/WorkWrap/Lib.hs b/compiler/GHC/Core/Op/WorkWrap/Lib.hs
index 684c807d07..19e05255f2 100644
--- a/compiler/GHC/Core/Op/WorkWrap/Lib.hs
+++ b/compiler/GHC/Core/Op/WorkWrap/Lib.hs
@@ -653,8 +653,7 @@ nop_fn body = body
 addDataConStrictness :: DataCon -> [Demand] -> [Demand]
 -- See Note [Add demands for strict constructors]
 addDataConStrictness con ds
-  = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds )
-    zipWith add ds strs
+  = zipWithEqual "addDataConStrictness" add ds strs
   where
     strs = dataConRepStrictness con
     add dmd str | isMarkedStrict str = strictifyDmd dmd
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 947780bfc3..f349382f00 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -788,7 +788,7 @@ dsSyntaxExpr (SyntaxExprTc { syn_expr      = expr
   = do { fun            <- dsExpr expr
        ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
        ; core_res_wrap  <- dsHsWrapper res_wrap
-       ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
+       ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs
        ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
                       (\_ -> core_res_wrap (mkApps fun wrapped_args)) }
   where
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 346ba1efa8..e52e1d376d 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -285,7 +285,7 @@ d1 `withRolesFrom` d2
     = d1 { ifRoles = mergeRoles roles1 roles2 }
     | otherwise = d1
   where
-    mergeRoles roles1 roles2 = zipWith max roles1 roles2
+    mergeRoles roles1 roles2 = zipWithEqual "mergeRoles" max roles1 roles2
 
 isRepInjectiveIfaceDecl :: IfaceDecl -> Bool
 isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index a67207c411..7d3877749a 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -606,7 +606,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
    syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs
      where
        joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)]
-       joinOccs = zipWith joinOcc
+       joinOccs = zipWithEqual "bindLocalsAtBreakpoint" joinOcc
        joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc
 
 rttiEnvironment :: HscEnv -> IO HscEnv
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 27e73b6330..54d73d9f12 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1183,7 +1183,7 @@ gen_Show_binds get_fixity loc tycon
                  where
                    nm       = wrapOpParens (unpackFS l)
 
-             show_args               = zipWith show_arg bs_needed arg_tys
+             show_args               = zipWithEqual "gen_Show_binds" show_arg bs_needed arg_tys
              (show_arg1:show_arg2:_) = show_args
              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
 
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 74eb1cf45a..333e442803 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -2053,11 +2053,14 @@ expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)
         (t1, t2)
 
     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
-      | tc1 == tc2 =
+      | tc1 == tc2
+      , tys1 `equalLength` tys2 =
         -- Type constructors are same. They may be synonyms, but we don't
-        -- expand further.
+        -- expand further. The lengths of tys1 and tys2 must be equal;
+        -- for example, with type S a = a, we don't want
+        -- to zip (S Monad Int) and (S Bool).
         let (tys1', tys2') =
-              unzip (zipWith (\ty1 ty2 -> go ty1 ty2) tys1 tys2)
+              unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2)
          in (TyConApp tc1 tys1', TyConApp tc2 tys2')
 
     go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 8ef022edbe..7308a594e6 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -707,7 +707,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
              -- Ensure that every old binder of type `b` is linked up with its
              -- new binder which should have type `n b`
              -- See Note [GroupStmt binder map] in GHC.Hs.Expr
-             n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
+             n_bndr_ids = zipWithEqual "tcMcStmt" mk_n_bndr n_bndr_names bndr_ids
              bindersMap' = bndr_ids `zip` n_bndr_ids
 
        -- Type check the thing in the environment with
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 7fb9fa68f0..ede45e058b 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -1226,7 +1226,8 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
     zonk_args env args
       = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
            ; (env2, new_pats)     <- zonkPats env1 (map get_pat args)
-           ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) }
+           ; return (env2, zipWithEqual "zonkStmt" replace_pat
+                                        new_pats (reverse new_args_rev)) }
 
      -- these need to go backward, because if any operators are higher-rank,
      -- later operators may introduce skolems that are in scope for earlier