[Git][ghc/ghc][wip/T20666] Wibbles

[Simon Peyton Jones (@simonpj)]

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


Commits:
79de4414 by Simon Peyton Jones at 2022-12-21T17:48:24+00:00
Wibbles

- - - - -


1 changed file:

- compiler/GHC/Tc/Validity.hs


Changes:

=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -2801,23 +2801,45 @@ checkTyConTelescope tc
 ************************************************************************
 -}
 
+data PatersonSize
+  = PS_HasTyFam TyCon   -- Mentions a type family; infinite size
+
+  | PS_Vanilla { ps_tvs :: [TyVar]  -- Free tyvars, including repetitions;
+               , ps_size :: Int     -- Number of type constructors and variables
+    }
+  -- Always after expanding synonyms
+  -- Always ignore coercions (not user written)
+  -- ToDo: ignore invisible arguments?
+
+pSizeOne :: PatersonSize
+pSizeOne = PS_Vanilla { ps_tvs = [], ps_size = 1 }
+
+addPSize :: PatersonSize -> PatersonSize -> PatersonSize
+addPSize ps1@(PS_HasTyFam {}) _ = ps1
+addPSize _ ps2@(PS_HasTyFam {}) = ps2
+addPSize (PS_Vanilla { ps_tvs = tvs1, ps_size = s1 })
+         (PS_Vanilla { ps_tvs = tvs2, ps_size = s2 })
+  = PS_Vanilla { ps_tvs = tvs1 ++ tvs2, ps_size = s1 + s2 })
+
 -- Free variables of a type, retaining repetitions, and expanding synonyms
 -- This ignores coercions, as coercions aren't user-written
-fvType :: Type -> [TyCoVar]
-fvType ty | Just exp_ty <- coreView ty = fvType exp_ty
-fvType (TyVarTy tv)          = [tv]
-fvType (TyConApp _ tys)      = fvTypes tys
-fvType (LitTy {})            = []
-fvType (AppTy fun arg)       = fvType fun ++ fvType arg
-fvType (FunTy _ w arg res)   = fvType w ++ fvType arg ++ fvType res
-fvType (ForAllTy (Bndr tv _) ty)
-  = fvType (tyVarKind tv) ++
-    filter (/= tv) (fvType ty)
-fvType (CastTy ty _)         = fvType ty
-fvType (CoercionTy {})       = []
-
-fvTypes :: [Type] -> [TyVar]
-fvTypes tys                = concatMap fvType tys
+sizeType :: VarSet -> Type -> PatersonSize
+sizeType bvs ty | Just exp_ty <- coreView ty = sizeType bvs exp_ty
+sizeType bvs (TyVarTy tv)
+  | tv `elemVarSet` bvs            = pSizeOne
+  | otherwise                      = PS_Vanilla { ps_tvs = [tv], ps_size = 1 }
+sizeType bvs (LitTy {})            = pSizeOne
+sizeType bvs (TyConApp _ tys)      = sizeTypes tys
+sizeType bvs (AppTy fun arg)       = sizeType fun `addPSize` sizeType arg
+sizeType bvs (FunTy _ w arg res)   = sizeType w `addPSize` sizeType arg `addPSize` sizeType res
+sizeType bvs (ForAllTy (Bndr tv _) ty)
+  = sizeType bvs (tyVarKind tv) `addPSize`
+    sizeType (bvs `extendVarSet` tv) (sizeType bvs ty)
+sizeType bvs (CastTy ty _)         = sizeType bvs ty
+sizeType bvs (CoercionTy {})       = pSizeOne
+
+sizeTypes :: [Type] -> [TyVar]
+sizeTypes tys                = concatMap sizeType tys
 
 sizeType :: Type -> Int
 -- Size of a type: the number of variables and constructors



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/79de441448e53586fc88bfbbb55749fcd439eae3
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/20221221/3119b893/attachment-0001.html>