[Git][ghc/ghc][wip/T24676] Wibblew

[Simon Peyton Jones (@simonpj)]

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


Commits:
40498ae4 by Simon Peyton Jones at 2024-05-29T12:32:33+01:00
Wibblew

- - - - -


2 changed files:

- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Solver/Equality.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -1792,15 +1792,9 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
 ********************************************************************* -}
 
 
-anyFreeKappa :: TcType -> TcM Bool
--- True if there is a free instantiation variable (member of Delta)
--- in the argument type, after zonking
--- See Note [The fiv test in quickLookArg]
-anyFreeKappa ty = foldQLInstVars (\_ql_inst_var -> return True) ty
-
 monomorphiseQLInstVars :: [HsExprArg 'TcpInst] -> TcRhoType -> TcM ()
 monomorphiseQLInstVars inst_args res_rho
-  = do { traceTc "monomorphisQLInstVars" $
+  = do { traceTc "monomorphiseQLInstVars" $
            vcat [ text "inst_args:" <+> ppr inst_args
                 , text "res_rho:" <+> ppr res_rho ]
        ; go_val_arg_ql inst_args res_rho }
@@ -1816,45 +1810,59 @@ monomorphiseQLInstVars inst_args res_rho
     go_arg _ = return ()
 
     go_ty :: TcType -> TcM ()
-    go_ty ty = do { _ <- foldQLInstVars go_tv ty; return () }
-
-    go_tv :: TcTyVar -> TcM Bool
-    go_tv tv | isQLInstTyVar tv   -- Not filled in
-             = do { traceTc "momomorphiseQLInstVar" (ppr tv)
-                  ; monomorphiseQLInstVar tv
-                  ; return True }
-             | otherwise
-             = return False
+    go_ty ty = do { traceTc "go_ty" (ppr ty)
+                  ; unTcMUnit (foldQLInstVars go_tv ty) }
+
+    go_tv :: TcTyVar -> TcMUnit
+    go_tv tv = TCMU $ do { traceTc "momomorphiseQLInstVar" (ppr tv)
+                         ; info <- readMetaTyVar tv
+                         ; case info of
+                             Indirect ty -> go_ty ty
+                             Flexi       -> do { go_ty (tyVarKind tv)
+                                                   -- May have (a :: TYPE k), where both
+                                                   -- a and k are instantiation variables
+                                               ; monomorphiseQLInstVar tv } }
+
+newtype TcMUnit = TCMU { unTcMUnit :: TcM () }
+instance Semigroup TcMUnit where
+  TCMU ml <> TCMU mr = TCMU (ml >> mr)
+instance Monoid TcMUnit where
+  mempty = TCMU (return ())
 
-newtype TcMBool = AM { unTcMBool :: TcM Bool }
+anyFreeKappa :: TcType -> TcM Bool
+-- True if there is a free instantiation variable (member of Delta)
+-- in the argument type, after zonking
+-- See Note [The fiv test in quickLookArg]
+anyFreeKappa ty = unTcMBool (foldQLInstVars go_tv ty)
+  where
+    go_tv tv = TCMB $ do { info <- readMetaTyVar tv
+                         ; case info of
+                             Indirect ty -> anyFreeKappa ty
+                             Flexi       -> return True }
 
+newtype TcMBool = TCMB { unTcMBool :: TcM Bool }
 instance Semigroup TcMBool where
-  AM ml <> AM mr = AM (do { l <- ml; if l then return True else mr })
-
+  TCMB ml <> TCMB mr = TCMB (do { l <- ml; if l then return True else mr })
 instance Monoid TcMBool where
-  mempty = AM (return False)
+  mempty = TCMB (return False)
 
-foldQLInstVars :: (TcTyVar -> TcM Bool) -> TcType -> TcM Bool
+foldQLInstVars :: forall a. Monoid a => (TcTyVar -> a) -> TcType -> a
+{-# INLINE foldQLInstVars #-}
 foldQLInstVars check_tv ty
-  = unTcMBool (do_ty ty)
+  = do_ty ty
   where
     (do_ty, _, _, _) = foldTyCo folder ()
 
-    folder :: TyCoFolder () TcMBool
+    folder :: TyCoFolder () a
     folder = TyCoFolder { tcf_view = noView  -- See Note [Free vars and synonyms]
-               , tcf_tyvar = do_tv, tcf_covar = mempty
-               , tcf_hole = mempty, tcf_tycobinder = do_bndr }
+                        , tcf_tyvar = do_tv, tcf_covar = mempty
+                        , tcf_hole = mempty, tcf_tycobinder = do_bndr }
 
     do_bndr _ _ _ = ()
 
-    do_tv :: () -> TcTyVar -> TcMBool
-    do_tv _ tv | isQLInstTyVar tv
-             = AM (do { info <- readMetaTyVar tv
-                      ; case info of
-                          Indirect ty -> unTcMBool (do_ty ty)
-                          Flexi       -> check_tv tv })
-             | otherwise
-             = mempty
+    do_tv :: () -> TcTyVar -> a
+    do_tv _ tv | isQLInstTyVar tv = check_tv tv
+               | otherwise        = mempty
 
 ----------------
 {-


=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -1822,7 +1822,7 @@ canEqCanLHSFinish ev eq_rel swapped lhs rhs
               , text "rhs:" <+> ppr rhs ]
 
          -- Assertion: no QL instantiation tyvars
---       ; massertPpr (not (ql_inst_tv lhs)) (ppr lhs)
+       ; massertPpr (not (ql_inst_tv lhs)) (ppr lhs)
 
          -- Assertion: (TyEq:K) is already satisfied
        ; massert (canEqLHSKind lhs `eqType` typeKind rhs)



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40498ae4bd956beed115df96c85b9e447fcdb9e4
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/20240529/a2a58ba8/attachment-0001.html>