[Git][ghc/ghc][master] Change zipWith to zipWithEqual in a few places
Marge Bot
gitlab at gitlab.haskell.org
Tue Apr 14 11:55:31 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
0da186c1 by Krzysztof Gogolewski at 2020-04-14T07:55:20-04:00
Change zipWith to zipWithEqual in a few places
- - - - -
12 changed files:
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/Op/FloatIn.hs
- compiler/GHC/Core/Op/OccurAnal.hs
- compiler/GHC/Core/Op/SpecConstr.hs
- compiler/GHC/Core/Op/WorkWrap/Lib.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Utils/Zonk.hs
Changes:
=====================================
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
=====================================
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]
=====================================
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
=====================================
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') }
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
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) =
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0da186c1b5a47e08e91c1c674d46c040c83932fc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0da186c1b5a47e08e91c1c674d46c040c83932fc
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200414/b60264e2/attachment-0001.html>
More information about the ghc-commits
mailing list