[Git][ghc/ghc][wip/T24676] Wibbles

Simon Peyton Jones (@simonpj) gitlab at gitlab.haskell.org
Tue May 28 16:47:59 UTC 2024



Simon Peyton Jones pushed to branch wip/T24676 at Glasgow Haskell Compiler / GHC


Commits:
a55acc2d by Simon Peyton Jones at 2024-05-28T17:47:45+01:00
Wibbles

- - - - -


7 changed files:

- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -1773,7 +1773,10 @@ anyFreeKappa ty = foldQLInstVars (\_ql_inst_var -> return True) ty
 
 monomorphiseQLInstVars :: [HsExprArg 'TcpInst] -> TcRhoType -> TcM ()
 monomorphiseQLInstVars inst_args res_rho
-  = go_val_arg_ql inst_args res_rho
+  = do { traceTc "monomorphisQLInstVars" $
+           vcat [ text "inst_args:" <+> ppr inst_args
+                , text "res_rho:" <+> ppr res_rho ]
+       ; go_val_arg_ql inst_args res_rho }
   where
     go_val_arg_ql :: [HsExprArg 'TcpInst] -> TcRhoType -> TcM ()
     go_val_arg_ql inst_args rho = do { mapM_ go_arg inst_args; go_ty rho }


=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -341,7 +341,7 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl    = bind_lvl
   | otherwise                          -- No signature
   = do { (co, bndr_ty) <- case scaledThing exp_pat_ty of
              Check pat_ty    -> promoteTcType bind_lvl pat_ty
-             Infer infer_res -> assert (bind_lvl == ir_lvl infer_res) $
+             Infer infer_res -> assert (bind_lvl `sameDepthAs` ir_lvl infer_res) $
                                 -- If we were under a constructor that bumped the
                                 -- level, we'd be in checking mode (see tcConArg)
                                 -- hence this assertion


=====================================
compiler/GHC/Tc/Solver/InertSet.hs
=====================================
@@ -2091,7 +2091,7 @@ solveOneFromTheOther ct_i ct_w
   -- From here on both are Given
   -- See Note [Replacement vs keeping]
 
-  | lvl_i == lvl_w
+  | lvl_i `sameDepthAs` lvl_w
   = same_level_strategy
 
   | otherwise   -- Both are Given, levels differ
@@ -2116,8 +2116,8 @@ solveOneFromTheOther ct_i ct_w
      is_wsc_orig_w = isWantedSuperclassOrigin orig_w
 
      different_level_strategy  -- Both Given
-       | isIPLikePred pred = if lvl_w > lvl_i then KeepWork  else KeepInert
-       | otherwise         = if lvl_w > lvl_i then KeepInert else KeepWork
+       | isIPLikePred pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork  else KeepInert
+       | otherwise         = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork
        -- See Note [Replacement vs keeping] part (1)
        -- For the isIPLikePred case see Note [Shadowing of implicit parameters]
        --                               in GHC.Tc.Solver.Dict


=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -622,7 +622,7 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
        | otherwise
        = (cts, qci)
 
-    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl
+    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) `sameDepthAs` this_lvl
     -- We only want Givens from this level; see (3a) in
     -- Note [The superclass story] in GHC.Tc.Solver.Dict
 
@@ -682,9 +682,9 @@ getHasGivenEqs tclvl
 
              -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and
              -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet
-             has_ge | ge_lvl == tclvl = MaybeGivenEqs
-                    | given_eqs       = LocalGivenEqs
-                    | otherwise       = NoGivenEqs
+             has_ge | ge_lvl `sameDepthAs` tclvl = MaybeGivenEqs
+                    | given_eqs                  = LocalGivenEqs
+                    | otherwise                  = NoGivenEqs
 
        ; traceTcS "getHasGivenEqs" $
          vcat [ text "given_eqs:" <+> ppr given_eqs


=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -1802,7 +1802,7 @@ check_implic implic@(Implic { ic_tclvl = lvl
 
     check_details :: TcTyVar -> TcTyVarDetails -> Maybe SDoc
     check_details tv (SkolemTv tv_skol_info tv_lvl _)
-      | not (tv_lvl == lvl)
+      | not (tv_lvl `sameDepthAs` lvl)
       = Just (vcat [ ppr tv <+> text "has level" <+> ppr tv_lvl
                    , text "ic_lvl" <+> ppr lvl ])
       | not (skol_info `checkSkolInfoAnon` skol_info_anon)


=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1510,12 +1510,12 @@ collect_cand_qtvs orig_ty is_dep cur_lvl bound dvs ty
 
     -----------------
     go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv
-      | tcTyVarLevel tv <= cur_lvl
+      | cur_lvl `deeperThanOrSame` tcTyVarLevel tv
       = return dv   -- This variable is from an outer context; skip
                     -- See Note [Use level numbers for quantification]
 
       | case tcTyVarDetails tv of
-          SkolemTv _ lvl _ -> lvl > pushTcLevel cur_lvl
+          SkolemTv _ lvl _ -> lvl `strictlyDeeperThan` pushTcLevel cur_lvl
           _                -> False
       = return dv  -- Skip inner skolems
         -- This only happens for erroneous program with bad telescopes
@@ -1811,7 +1811,7 @@ isQuantifiableTv :: TcLevel   -- Level of the context, outside the quantificatio
                  -> Bool
 isQuantifiableTv outer_tclvl tcv
   | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separately
-  = tcTyVarLevel tcv > outer_tclvl
+  = tcTyVarLevel tcv `strictlyDeeperThan` outer_tclvl
   | otherwise
   = False
 


=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -696,7 +696,6 @@ noConcreteTyVars = emptyNameEnv
 
 data TcLevel = TcLevel Int#
              | QLInstVar
-             deriving( Eq, Ord )
   -- See Note [TcLevel invariants] for what this Int is
   -- See also Note [TcLevel assignment]
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a55acc2dbaec64fdf87b8015747f8191b6ddbe4b

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a55acc2dbaec64fdf87b8015747f8191b6ddbe4b
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/20240528/5b0ff883/attachment-0001.html>


More information about the ghc-commits mailing list