[Git][ghc/ghc][wip/T22194-flags] Fix isConcreteTyCon

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T22194-flags at Glasgow Haskell Compiler / GHC


Commits:
a9ee8966 by Simon Peyton Jones at 2023-03-15T11:14:38+00:00
Fix isConcreteTyCon

Adds a synIsConcrete to SynonymTyCon

- - - - -


2 changed files:

- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Type.hs


Changes:

=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -833,11 +833,15 @@ data TyConDetails =
                                  --          any type synonym families (data families
                                  --          are fine), again after expanding any
                                  --          nested synonyms
-        synIsForgetful :: Bool   -- True <=  at least one argument is not mentioned
+
+        synIsForgetful :: Bool,  -- True <=  at least one argument is not mentioned
                                  --          in the RHS (or is mentioned only under
                                  --          forgetful synonyms)
                                  -- Test is conservative, so True does not guarantee
                                  -- forgetfulness.
+
+        synIsConcrete :: Bool    -- True <= If 'tys' are concrete then the expansion
+                                 --         of (S tys) is concrete
     }
 
   -- | Represents families (both type and data)
@@ -1873,13 +1877,17 @@ mkPrimTyCon name binders res_kind roles
 
 -- | Create a type synonym 'TyCon'
 mkSynonymTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind
-               -> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon
-mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful
+               -> [Role] -> Type
+               -> Bool -> Bool -> Bool -> Bool
+               -> TyCon
+mkSynonymTyCon name binders res_kind roles rhs is_tau
+               is_fam_free is_forgetful is_concrete
   = mkTyCon name binders res_kind roles $
     SynonymTyCon { synTcRhs       = rhs
                  , synIsTau       = is_tau
                  , synIsFamFree   = is_fam_free
-                 , synIsForgetful = is_forgetful }
+                 , synIsForgetful = is_forgetful
+                 , synIsConcrete  = is_concrete }
 
 -- | Create a type family 'TyCon'
 mkFamilyTyCon :: Name -> [TyConBinder] -> Kind  -- ^ /result/ kind
@@ -2353,29 +2361,23 @@ tcHasFixedRuntimeRep tc@(TyCon { tyConDetails = details })
   | TcTyCon{}         <- details = False
   | PromotedDataCon{} <- details = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc)
 
--- | Is this 'TyCon' concrete (i.e. not a synonym/type family)?
---
+-- | Is this 'TyCon' concrete?
+-- More specifically, if 'tys' are all concrete, is (T tys) concrete?
+--      (for synonyms this requires us to look at the RHS)
 -- Used for representation polymorphism checks.
+-- See Note [Concrete types] in GHC.Tc.Utils.Concrete
 isConcreteTyCon :: TyCon -> Bool
-isConcreteTyCon = isConcreteTyConFlavour . tyConFlavour
+isConcreteTyCon tc@(TyCon { tyConDetails = details })
+  = case details of
+      AlgTyCon {}        -> True   -- Includes AbstractTyCon
+      PrimTyCon {}       -> True
+      PromotedDataCon {} -> True
+      FamilyTyCon {}     -> False
 
--- | Is this 'TyConFlavour' concrete (i.e. not a synonym/type family)?
---
--- Used for representation polymorphism checks.
-isConcreteTyConFlavour :: TyConFlavour -> Bool
-isConcreteTyConFlavour = \case
-  ClassFlavour             -> True
-  TupleFlavour {}          -> True
-  SumFlavour               -> True
-  DataTypeFlavour          -> True
-  NewtypeFlavour           -> True
-  AbstractTypeFlavour      -> True  -- See Note [Concrete types] in GHC.Tc.Utils.Concrete
-  DataFamilyFlavour {}     -> False
-  OpenTypeFamilyFlavour {} -> False
-  ClosedTypeFamilyFlavour  -> False
-  TypeSynonymFlavour       -> False
-  BuiltInTypeFlavour       -> True
-  PromotedDataConFlavour   -> True
+      SynonymTyCon { synIsConcrete = is_conc } -> is_conc
+
+      TcTyCon {} -> pprPanic "isConcreteTyCon" (ppr tc)
+                    -- isConcreteTyCon is only used on "real" tycons
 
 {-
 -----------------------------------------------


=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -2204,15 +2204,20 @@ buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind   -- ^ /result/ kind
 -- This function is here because here is where we have
 --   isFamFree and isTauTy
 buildSynTyCon name binders res_kind roles rhs
-  = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful
+  = mkSynonymTyCon name binders res_kind roles rhs
+                   is_tau is_fam_free is_forgetful is_concrete
   where
     is_tau       = isTauTy rhs
     is_fam_free  = isFamFreeTy rhs
-    is_forgetful = any (not . (`elemVarSet` tyCoVarsOfType rhs) . binderVar) binders ||
-                   uniqSetAny isForgetfulSynTyCon (tyConsOfType rhs)
+    is_concrete  = uniqSetAll isConcreteTyCon rhs_tycons
+    is_forgetful = not (all ((`elemVarSet` rhs_tyvars) . binderVar) binders) ||
+                   uniqSetAny isForgetfulSynTyCon rhs_tycons
          -- NB: This is allowed to be conservative, returning True more often
          -- than it should. See comments on GHC.Core.TyCon.isForgetfulSynTyCon
 
+    rhs_tycons = tyConsOfType   rhs
+    rhs_tyvars = tyCoVarsOfType rhs
+
 {-
 ************************************************************************
 *                                                                      *
@@ -2767,10 +2772,9 @@ isFixedRuntimeRepKind k
 isConcrete :: Type -> Bool
 isConcrete = go
   where
-    go ty | Just ty' <- coreView ty = go ty'
     go (TyVarTy tv)        = isConcreteTyVar tv
     go (AppTy ty1 ty2)     = go ty1 && go ty2
-    go (TyConApp tc tys)
+    go (TyConApp tc tys)  -- Works for synonyms too
       | isConcreteTyCon tc = all go tys
       | otherwise          = False
     go ForAllTy{}          = False



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9ee8966e590a8d80d5d968558e4f11813d7f140
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/20230315/a108a096/attachment-0001.html>