[Git][ghc/ghc][wip/T21623] 2 commits: Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Sep 6 13:43:05 UTC 2022
Simon Peyton Jones pushed to branch wip/T21623 at Glasgow Haskell Compiler / GHC
Commits:
1080be15 by Simon Peyton Jones at 2022-09-06T14:42:36+01:00
Wibbles
- - - - -
b8a53071 by Simon Peyton Jones at 2022-09-06T14:42:44+01:00
Update haddock
- - - - -
8 changed files:
- compiler/GHC/Builtin/Types/Prim.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Type.hs-boot
- compiler/GHC/Tc/TyCl.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/Builtin/Types/Prim.hs
=====================================
@@ -131,20 +131,24 @@ import {-# SOURCE #-} GHC.Builtin.Types
import {-# SOURCE #-} GHC.Types.TyThing( mkATyCon )
import {-# SOURCE #-} GHC.Core.Type ( mkTyConApp, getLevity )
+import GHC.Core.TyCon
+import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid
+ -- import loops which show up if you import Type instead
+
import GHC.Types.Var ( TyVarBinder, TyVar
, mkTyVar, mkTyVarBinder, mkTyVarBinders )
import GHC.Types.Name
-import GHC.Core.TyCon
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Basic( TypeOrConstraint(..) )
+
import GHC.Builtin.Uniques
import GHC.Builtin.Names
-import GHC.Data.FastString
import GHC.Utils.Misc ( changeLast )
-import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid
- -- import loops which show up if you import Type instead
+import GHC.Utils.Panic ( assertPpr )
+import GHC.Utils.Outputable
+import GHC.Data.FastString
import Data.Char
{- *********************************************************************
@@ -610,7 +614,7 @@ isArrowTyCon :: TyCon -> Bool
-- We don't bother to look for plain (->), because this function
-- should only be used after unwrapping synonyms
isArrowTyCon tc
- = assertPpr (not (isSynonymTyCon tc)) (ppr tc)
+ = assertPpr (not (isTypeSynonymTyCon tc)) (ppr tc)
getUnique tc `elem`
[fUNTyConKey, ctArrowTyConKey, ccArrowTyConKey, tcArrowTyConKey]
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -20,7 +20,6 @@ module GHC.Core.DataCon (
-- ** Equality specs
EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType,
eqSpecPair, eqSpecPreds,
- substEqSpec,
-- ** Field labels
FieldLabel(..), FieldLabelString,
@@ -787,15 +786,6 @@ eqSpecPreds :: [EqSpec] -> ThetaType
eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty
| EqSpec tv ty <- spec ]
--- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec
--- is mapped in the substitution, it is mapped to a type variable, not
--- a full type.
-substEqSpec :: Subst -> EqSpec -> EqSpec
-substEqSpec subst (EqSpec tv ty)
- = EqSpec tv' (substTy subst ty)
- where
- tv' = getTyVar (substTyVar subst tv)
-
instance Outputable EqSpec where
ppr (EqSpec tv ty) = ppr (tv, ty)
=====================================
compiler/GHC/Core/TyCo/Ppr.hs
=====================================
@@ -27,7 +27,7 @@ module GHC.Core.TyCo.Ppr
import GHC.Prelude
import {-# SOURCE #-} GHC.CoreToIface
- ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndrx
+ ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndrs
, toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX )
import {-# SOURCE #-} GHC.Core.DataCon
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -44,9 +44,9 @@ module GHC.Core.TyCo.Subst
substVarBndr, substVarBndrs,
substTyVarBndr, substTyVarBndrs,
substCoVarBndr,
- substTyVar, substTyVars, substTyCoVars,
- substTyCoBndr,
- substForAllCoBndr,
+ substTyVar, substTyVars, substTyVarToTyVar,
+ substTyCoVars,
+ substTyCoBndr, substForAllCoBndr,
substVarBndrUsing, substForAllCoBndrUsing,
checkValidSubst, isValidTCvSubst,
) where
@@ -54,7 +54,7 @@ module GHC.Core.TyCo.Subst
import GHC.Prelude
import {-# SOURCE #-} GHC.Core.Type
- ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp )
+ ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp, getTyVar_maybe )
import {-# SOURCE #-} GHC.Core.Coercion
( mkCoVarCo, mkKindCo, mkSelCo, mkTransCo
, mkNomReflCo, mkSubCo, mkSymCo
@@ -815,6 +815,16 @@ substTyVar (Subst _ _ tenv _) tv
Just ty -> ty
Nothing -> TyVarTy tv
+substTyVarToTyVar :: Subst -> TyVar -> TyVar
+-- Apply the substitution, expecing the result to be a TyVarTy
+substTyVarToTyVar (Subst _ _ tenv _) tv
+ = assert (isTyVar tv) $
+ case lookupVarEnv tenv tv of
+ Just ty -> case getTyVar_maybe ty of
+ Just tv -> tv
+ Nothing -> pprPanic "substTyVarToTyVar" (ppr tv $$ ppr ty)
+ Nothing -> tv
+
substTyVars :: Subst -> [TyVar] -> [Type]
substTyVars subst = map $ substTyVar subst
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -219,7 +219,7 @@ module GHC.Core.Type (
substCoUnchecked, substCoWithUnchecked,
substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,
substVarBndr, substVarBndrs,
- substTyCoBndr,
+ substTyCoBndr, substTyVarToTyVar,
cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,
-- * Tidying type related things up for printing
@@ -1032,7 +1032,7 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar
-- | Attempts to obtain the type variable underlying a 'Type', and panics with the
-- given message if this is not a type variable type. See also 'getTyVar_maybe'
-getTyVar :: Type -> TyVar
+getTyVar :: HasDebugCallStack => Type -> TyVar
getTyVar ty = case getTyVar_maybe ty of
Just tv -> tv
Nothing -> pprPanic "getTyVar" (ppr ty)
=====================================
compiler/GHC/Core/Type.hs-boot
=====================================
@@ -6,7 +6,7 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Core.TyCon
import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Coercion )
import GHC.Utils.Misc
-import GHC.Types.Var( FunTyFlag )
+import GHC.Types.Var( FunTyFlag, TyVar )
import GHC.Types.Basic( TypeOrConstraint )
isPredTy :: HasDebugCallStack => Type -> Bool
@@ -30,6 +30,7 @@ isLiftedTypeKind :: Type -> Bool
splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
tyConAppTyCon_maybe :: Type -> Maybe TyCon
+getTyVar_maybe :: Type -> Maybe TyVar
getLevity :: HasDebugCallStack => Type -> Type
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -3831,10 +3831,12 @@ rejigConRes tc_tvbndrs res_tmpl dc_tvbndrs res_ty
-- since the dcUserTyVarBinders invariant guarantees that the
-- substitution has *all* the tyvars in its domain.
-- See Note [DataCon user type variable binders] in GHC.Core.DataCon.
- subst_user_tvs = mapVarBndrs (getTyVar . substTyVar arg_subst)
+ subst_user_tvs = mapVarBndrs (substTyVarToTyVar arg_subst)
substed_tvbndrs = subst_user_tvs dc_tvbndrs
- substed_eqs = map (substEqSpec arg_subst) raw_eqs
+ substed_eqs = [ mkEqSpec (substTyVarToTyVar subst tv)
+ (substTy subst ty)
+ | (tv,ty) <- raw_eqs ]
in
(univ_tvs, substed_ex_tvs, substed_tvbndrs, substed_eqs, arg_subst)
@@ -4000,7 +4002,7 @@ mkGADTVars :: [TyVar] -- ^ The tycon vars
-> Subst -- ^ The matching between the template result type
-- and the actual result type
-> ( [TyVar]
- , [EqSpec]
+ , [(TyVar,Type)] -- The un-substituted eq-spec
, Subst ) -- ^ The univ. variables, the GADT equalities,
-- and a subst to apply to the GADT equalities
-- and existentials.
@@ -4011,13 +4013,13 @@ mkGADTVars tmpl_tvs dc_tvs subst
`unionInScope` getSubstInScope subst
empty_subst = mkEmptySubst in_scope
- choose :: [TyVar] -- accumulator of univ tvs, reversed
- -> [EqSpec] -- accumulator of GADT equalities, reversed
+ choose :: [TyVar] -- accumulator of univ tvs, reversed
+ -> [(TyVar,Type)] -- accumulator of GADT equalities, reversed
-> Subst -- template substitution
-> Subst -- res. substitution
-> [TyVar] -- template tvs (the univ tvs passed in)
-> ( [TyVar] -- the univ_tvs
- , [EqSpec] -- GADT equalities
+ , [(TyVar,Type)] -- GADT equalities
, Subst ) -- a substitution to fix kinds in ex_tvs
choose univs eqs _t_sub r_sub []
@@ -4049,7 +4051,7 @@ mkGADTVars tmpl_tvs dc_tvs subst
tv_kind' = substTy t_sub tv_kind
t_tv' = setTyVarKind t_tv tv_kind'
eqs' | isConstraintLikeKind (typeKind tv_kind') = eqs
- | otherwise = mkEqSpec t_tv' r_ty : eqs
+ | otherwise = (t_tv', r_ty) : eqs
| otherwise
= pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit d9f258ff173f5294661603128ac1c6bbb3a71b5f
+Subproject commit 65570f984d536bef4e250680d2663b858a6f7838
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/424ba7535cc035375934063481d8647f07351e74...b8a53071d33b76922588cc890c347167f2889de5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/424ba7535cc035375934063481d8647f07351e74...b8a53071d33b76922588cc890c347167f2889de5
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/20220906/2c7c5c7c/attachment-0001.html>
More information about the ghc-commits
mailing list