diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-03-02 11:43:03 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-03-16 23:53:24 -0400 |
| commit | 18a346a4b5a02b8c62e8eedb91b35c2d8e754b96 (patch) | |
| tree | 59121ffd5a46c1987a184db3842a3089f6250d11 /compiler/GHC | |
| parent | 818b3c38e7548f4720815f76969238d82c9650f7 (diff) | |
| download | haskell-18a346a4b5a02b8c62e8eedb91b35c2d8e754b96.tar.gz | |
Modules: Core (#13009)
Update submodule: haddock
Diffstat (limited to 'compiler/GHC')
123 files changed, 22901 insertions, 381 deletions
diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs index 79b0bc2766..c781a3a6d1 100644 --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -27,7 +27,7 @@ import GHC.Driver.Types import Name import NameSet import Literal -import TyCon +import GHC.Core.TyCon import FastString import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Runtime.Heap.Layout diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs index 80a259d94d..1c2a89b02b 100644 --- a/compiler/GHC/ByteCode/InfoTable.hs +++ b/compiler/GHC/ByteCode/InfoTable.hs @@ -17,8 +17,8 @@ import GHC.Driver.Session import GHC.Driver.Types import Name ( Name, getName ) import NameEnv -import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) -import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) +import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) +import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import GHC.Types.RepType import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs index bff6bb5df0..8643752e2b 100644 --- a/compiler/GHC/ByteCode/Instr.hs +++ b/compiler/GHC/ByteCode/Instr.hs @@ -25,7 +25,7 @@ import Unique import Id import GHC.Core import Literal -import DataCon +import GHC.Core.DataCon import VarSet import PrimOp import GHC.Runtime.Heap.Layout diff --git a/compiler/GHC/ByteCode/Types.hs b/compiler/GHC/ByteCode/Types.hs index ce80c53279..491c4f99f9 100644 --- a/compiler/GHC/ByteCode/Types.hs +++ b/compiler/GHC/ByteCode/Types.hs @@ -22,7 +22,7 @@ import NameEnv import Outputable import PrimOp import SizedSeq -import Type +import GHC.Core.Type import SrcLoc import GHCi.BreakArray import GHCi.RemoteTypes diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs index 5a34ae45e2..53a1f095f8 100644 --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -72,7 +72,7 @@ module GHC.Cmm.Utils( import GhcPrelude -import TyCon ( PrimRep(..), PrimElemRep(..) ) +import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) ) import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 ) import GHC.Runtime.Heap.Layout diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 7fe26e0f39..b4af2b2eea 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -104,13 +104,13 @@ import GhcPrelude import CostCentre import VarEnv( InScopeSet ) import Var -import Type -import Coercion +import GHC.Core.Type +import GHC.Core.Coercion import Name import NameSet import NameEnv( NameEnv, emptyNameEnv ) import Literal -import DataCon +import GHC.Core.DataCon import Module import BasicTypes import GHC.Driver.Session diff --git a/compiler/GHC/Core/Arity.hs b/compiler/GHC/Core/Arity.hs index 73122bef30..df16701396 100644 --- a/compiler/GHC/Core/Arity.hs +++ b/compiler/GHC/Core/Arity.hs @@ -31,10 +31,10 @@ import Demand import Var import VarEnv import Id -import Type -import TyCon ( initRecTc, checkRecTc ) -import Predicate ( isDictTy ) -import Coercion +import GHC.Core.Type as Type +import GHC.Core.TyCon ( initRecTc, checkRecTc ) +import GHC.Core.Predicate ( isDictTy ) +import GHC.Core.Coercion as Coercion import BasicTypes import Unique import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt ) @@ -130,7 +130,7 @@ typeArity ty | Just (tc,tys) <- splitTyConApp_maybe ty , Just (ty', _) <- instNewTyCon_maybe tc tys , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] - -- in TyCon + -- in GHC.Core.TyCon -- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes -- -- See Note [Newtype classes and eta expansion] -- (no longer required) diff --git a/compiler/GHC/Core/Class.hs b/compiler/GHC/Core/Class.hs new file mode 100644 index 0000000000..5020ce6617 --- /dev/null +++ b/compiler/GHC/Core/Class.hs @@ -0,0 +1,360 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +-- The @Class@ datatype + +{-# LANGUAGE CPP #-} + +module GHC.Core.Class ( + Class, + ClassOpItem, + ClassATItem(..), + ClassMinimalDef, + DefMethInfo, pprDefMethInfo, + + FunDep, pprFundeps, pprFunDep, + + mkClass, mkAbstractClass, classTyVars, classArity, + classKey, className, classATs, classATItems, classTyCon, classMethods, + classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, + classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds, + isAbstractClass, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) +import Var +import Name +import BasicTypes +import Unique +import Util +import SrcLoc +import Outputable +import BooleanFormula (BooleanFormula, mkTrue) + +import qualified Data.Data as Data + +{- +************************************************************************ +* * +\subsection[Class-basic]{@Class@: basic definition} +* * +************************************************************************ + +A @Class@ corresponds to a Greek kappa in the static semantics: +-} + +data Class + = Class { + classTyCon :: TyCon, -- The data type constructor for + -- dictionaries of this class + -- See Note [ATyCon for classes] in GHC.Core.TyCo.Rep + + className :: Name, -- Just the cached name of the TyCon + classKey :: Unique, -- Cached unique of TyCon + + classTyVars :: [TyVar], -- The class kind and type variables; + -- identical to those of the TyCon + -- If you want visibility info, look at the classTyCon + -- This field is redundant because it's duplicated in the + -- classTyCon, but classTyVars is used quite often, so maybe + -- it's a bit faster to cache it here + + classFunDeps :: [FunDep TyVar], -- The functional dependencies + + classBody :: ClassBody -- Superclasses, ATs, methods + + } + +-- | e.g. +-- +-- > class C a b c | a b -> c, a c -> b where... +-- +-- Here fun-deps are [([a,b],[c]), ([a,c],[b])] +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'', + +-- For details on above see note [Api annotations] in ApiAnnotation +type FunDep a = ([a],[a]) + +type ClassOpItem = (Id, DefMethInfo) + -- Selector function; contains unfolding + -- Default-method info + +type DefMethInfo = Maybe (Name, DefMethSpec Type) + -- Nothing No default method + -- Just ($dm, VanillaDM) A polymorphic default method, name $dm + -- Just ($gm, GenericDM ty) A generic default method, name $gm, type ty + -- The generic dm type is *not* quantified + -- over the class variables; ie has the + -- class variables free + +data ClassATItem + = ATI TyCon -- See Note [Associated type tyvar names] + (Maybe (Type, SrcSpan)) + -- Default associated type (if any) from this template + -- Note [Associated type defaults] + +type ClassMinimalDef = BooleanFormula Name -- Required methods + +data ClassBody + = AbstractClass + | ConcreteClass { + -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) + -- We need value-level selectors for both the dictionary + -- superclasses and the equality superclasses + cls_sc_theta :: [PredType], -- Immediate superclasses, + cls_sc_sel_ids :: [Id], -- Selector functions to extract the + -- superclasses from a + -- dictionary of this class + -- Associated types + cls_ats :: [ClassATItem], -- Associated type families + + -- Class operations (methods, not superclasses) + cls_ops :: [ClassOpItem], -- Ordered by tag + + -- Minimal complete definition + cls_min_def :: ClassMinimalDef + } + -- TODO: maybe super classes should be allowed in abstract class definitions + +classMinimalDef :: Class -> ClassMinimalDef +classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d +classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction + +{- +Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following is an example of associated type defaults: + class C a where + data D a r + + type F x a b :: * + type F p q r = (p,q)->r -- Default + +Note that + + * The TyCons for the associated types *share type variables* with the + class, so that we can tell which argument positions should be + instantiated in an instance decl. (The first for 'D', the second + for 'F'.) + + * We can have default definitions only for *type* families, + not data families + + * In the default decl, the "patterns" should all be type variables, + but (in the source language) they don't need to be the same as in + the 'type' decl signature or the class. It's more like a + free-standing 'type instance' declaration. + + * HOWEVER, in the internal ClassATItem we rename the RHS to match the + tyConTyVars of the family TyCon. So in the example above we'd get + a ClassATItem of + ATI F ((x,a) -> b) + So the tyConTyVars of the family TyCon bind the free vars of + the default Type rhs + +The @mkClass@ function fills in the indirect superclasses. + +The SrcSpan is for the entire original declaration. +-} + +mkClass :: Name -> [TyVar] + -> [FunDep TyVar] + -> [PredType] -> [Id] + -> [ClassATItem] + -> [ClassOpItem] + -> ClassMinimalDef + -> TyCon + -> Class + +mkClass cls_name tyvars fds super_classes superdict_sels at_stuff + op_stuff mindef tycon + = Class { classKey = nameUnique cls_name, + className = cls_name, + -- NB: tyConName tycon = cls_name, + -- But it takes a module loop to assert it here + classTyVars = tyvars, + classFunDeps = fds, + classBody = ConcreteClass { + cls_sc_theta = super_classes, + cls_sc_sel_ids = superdict_sels, + cls_ats = at_stuff, + cls_ops = op_stuff, + cls_min_def = mindef + }, + classTyCon = tycon } + +mkAbstractClass :: Name -> [TyVar] + -> [FunDep TyVar] + -> TyCon + -> Class + +mkAbstractClass cls_name tyvars fds tycon + = Class { classKey = nameUnique cls_name, + className = cls_name, + -- NB: tyConName tycon = cls_name, + -- But it takes a module loop to assert it here + classTyVars = tyvars, + classFunDeps = fds, + classBody = AbstractClass, + classTyCon = tycon } + +{- +Note [Associated type tyvar names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The TyCon of an associated type should use the same variable names as its +parent class. Thus + class C a b where + type F b x a :: * +We make F use the same Name for 'a' as C does, and similarly 'b'. + +The reason for this is when checking instances it's easier to match +them up, to ensure they match. Eg + instance C Int [d] where + type F [d] x Int = .... +we should make sure that the first and third args match the instance +header. + +Having the same variables for class and tycon is also used in checkValidRoles +(in TcTyClsDecls) when checking a class's roles. + + +************************************************************************ +* * +\subsection[Class-selectors]{@Class@: simple selectors} +* * +************************************************************************ + +The rest of these functions are just simple selectors. +-} + +classArity :: Class -> Arity +classArity clas = length (classTyVars clas) + -- Could memoise this + +classAllSelIds :: Class -> [Id] +-- Both superclass-dictionary and method selectors +classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) + = sc_sels ++ classMethods c +classAllSelIds c = ASSERT( null (classMethods c) ) [] + +classSCSelIds :: Class -> [Id] +-- Both superclass-dictionary and method selectors +classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) + = sc_sels +classSCSelIds c = ASSERT( null (classMethods c) ) [] + +classSCSelId :: Class -> Int -> Id +-- Get the n'th superclass selector Id +-- where n is 0-indexed, and counts +-- *all* superclasses including equalities +classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n + = ASSERT( n >= 0 && lengthExceeds sc_sels n ) + sc_sels !! n +classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n) + +classMethods :: Class -> [Id] +classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } }) + = [op_sel | (op_sel, _) <- op_stuff] +classMethods _ = [] + +classOpItems :: Class -> [ClassOpItem] +classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }}) + = op_stuff +classOpItems _ = [] + +classATs :: Class -> [TyCon] +classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } }) + = [tc | ATI tc _ <- at_stuff] +classATs _ = [] + +classATItems :: Class -> [ClassATItem] +classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }}) + = at_stuff +classATItems _ = [] + +classSCTheta :: Class -> [PredType] +classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }}) + = theta_stuff +classSCTheta _ = [] + +classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) +classTvsFds c = (classTyVars c, classFunDeps c) + +classHasFds :: Class -> Bool +classHasFds (Class { classFunDeps = fds }) = not (null fds) + +classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem]) +classBigSig (Class {classTyVars = tyvars, + classBody = AbstractClass}) + = (tyvars, [], [], []) +classBigSig (Class {classTyVars = tyvars, + classBody = ConcreteClass { + cls_sc_theta = sc_theta, + cls_sc_sel_ids = sc_sels, + cls_ops = op_stuff + }}) + = (tyvars, sc_theta, sc_sels, op_stuff) + +classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem]) +classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, + classBody = AbstractClass}) + = (tyvars, fundeps, [], [], [], []) +classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, + classBody = ConcreteClass { + cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels, + cls_ats = ats, cls_ops = op_stuff + }}) + = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) + +isAbstractClass :: Class -> Bool +isAbstractClass Class{ classBody = AbstractClass } = True +isAbstractClass _ = False + +{- +************************************************************************ +* * +\subsection[Class-instances]{Instance declarations for @Class@} +* * +************************************************************************ + +We compare @Classes@ by their keys (which include @Uniques@). +-} + +instance Eq Class where + c1 == c2 = classKey c1 == classKey c2 + c1 /= c2 = classKey c1 /= classKey c2 + +instance Uniquable Class where + getUnique c = classKey c + +instance NamedThing Class where + getName clas = className clas + +instance Outputable Class where + ppr c = ppr (getName c) + +pprDefMethInfo :: DefMethInfo -> SDoc +pprDefMethInfo Nothing = empty -- No default method +pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n +pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method" + <+> ppr n <+> dcolon <+> pprType ty + +pprFundeps :: Outputable a => [FunDep a] -> SDoc +pprFundeps [] = empty +pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) + +pprFunDep :: Outputable a => FunDep a -> SDoc +pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs] + +instance Data.Data Class where + -- don't traverse? + toConstr _ = abstractConstr "Class" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Class" diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs new file mode 100644 index 0000000000..3e59a6ef85 --- /dev/null +++ b/compiler/GHC/Core/Coercion.hs @@ -0,0 +1,2906 @@ +{- +(c) The University of Glasgow 2006 +-} + +{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts, BangPatterns, + ScopedTypeVariables #-} + +-- | Module for (a) type kinds and (b) type coercions, +-- as used in System FC. See 'GHC.Core.Expr' for +-- more on System FC and how coercions fit into it. +-- +module GHC.Core.Coercion ( + -- * Main data type + Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR, + UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar, + LeftOrRight(..), + Var, CoVar, TyCoVar, + Role(..), ltRole, + + -- ** Functions over coercions + coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole, + coercionType, mkCoercionType, + coercionKind, coercionLKind, coercionRKind,coercionKinds, + coercionRole, coercionKindRole, + + -- ** Constructing coercions + mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo, + mkCoVarCo, mkCoVarCos, + mkAxInstCo, mkUnbranchedAxInstCo, + mkAxInstRHS, mkUnbranchedAxInstRHS, + mkAxInstLHS, mkUnbranchedAxInstLHS, + mkPiCo, mkPiCos, mkCoCast, + mkSymCo, mkTransCo, mkTransMCo, + mkNthCo, nthCoRole, mkLRCo, + mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, + mkForAllCo, mkForAllCos, mkHomoForAllCos, + mkPhantomCo, + mkHoleCo, mkUnivCo, mkSubCo, + mkAxiomInstCo, mkProofIrrelCo, + downgradeRole, mkAxiomRuleCo, + mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, + mkKindCo, castCoercionKind, castCoercionKindI, + + mkHeteroCoercionType, + mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, + mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, + + -- ** Decomposition + instNewTyCon_maybe, + + NormaliseStepper, NormaliseStepResult(..), composeSteppers, + mapStepResult, unwrapNewTypeStepper, + topNormaliseNewType_maybe, topNormaliseTypeX, + + decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, + splitTyConAppCo_maybe, + splitAppCo_maybe, + splitFunCo_maybe, + splitForAllCo_maybe, + splitForAllCo_ty_maybe, splitForAllCo_co_maybe, + + nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, + + pickLR, + + isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, + isReflCoVar_maybe, isGReflMCo, coToMCo, + + -- ** Coercion variables + mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, + isCoVar_maybe, + + -- ** Free variables + tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, + tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, + coercionSize, + + -- ** Substitution + CvSubstEnv, emptyCvSubstEnv, + lookupCoVar, + substCo, substCos, substCoVar, substCoVars, substCoWith, + substCoVarBndr, + extendTvSubstAndInScope, getCvSubstEnv, + + -- ** Lifting + liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, + emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, + liftCoSubstVarBndrUsing, isMappedByLC, + + mkSubstLiftingContext, zapLiftingContext, + substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet, + + LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, + substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, + + -- ** Comparison + eqCoercion, eqCoercionX, + + -- ** Forcing evaluation of coercions + seqCo, + + -- * Pretty-printing + pprCo, pprParendCo, + pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS, + pprCoAxBranchUser, tidyCoAxBndrsForUser, + etaExpandCoAxBranch, + + -- * Tidying + tidyCo, tidyCos, + + -- * Other + promoteCoercion, buildCoercion, + + simplifyArgsWorker + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs) + +import GhcPrelude + +import GHC.Iface.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Tidy +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import Var +import VarEnv +import VarSet +import Name hiding ( varName ) +import Util +import BasicTypes +import Outputable +import Unique +import Pair +import SrcLoc +import PrelNames +import TysPrim +import ListSetOps +import Maybes +import UniqFM + +import Control.Monad (foldM, zipWithM) +import Data.Function ( on ) +import Data.Char( isDigit ) + +{- +%************************************************************************ +%* * + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. See + -- See [Coercion axioms applied to coercions] in GHC.Core.TyCo.Rep + +\subsection{Coercion variables} +%* * +%************************************************************************ +-} + +coVarName :: CoVar -> Name +coVarName = varName + +setCoVarUnique :: CoVar -> Unique -> CoVar +setCoVarUnique = setVarUnique + +setCoVarName :: CoVar -> Name -> CoVar +setCoVarName = setVarName + +{- +%************************************************************************ +%* * + Pretty-printing CoAxioms +%* * +%************************************************************************ + +Defined here to avoid module loops. CoAxiom is loaded very early on. + +-} + +etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type) +-- Return the (tvs,lhs,rhs) after eta-expanding, +-- to the way in which the axiom was originally written +-- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom +etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + -- ToDo: what about eta_cvs? + = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys) + where + eta_tys = mkTyVarTys eta_tvs + +pprCoAxiom :: CoAxiom br -> SDoc +-- Used in debug-printing only +pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) + = hang (text "axiom" <+> ppr ax <+> dcolon) + 2 (vcat (map (pprCoAxBranchUser tc) (fromBranches branches))) + +pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc +-- Used when printing injectivity errors (FamInst.reportInjectivityErrors) +-- and inaccessible branches (TcValidity.inaccessibleCoAxBranch) +-- This happens in error messages: don't print the RHS of a data +-- family axiom, which is meaningless to a user +pprCoAxBranchUser tc br + | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br + | otherwise = pprCoAxBranch tc br + +pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc +-- Print the family-instance equation when reporting +-- a conflict between equations (FamInst.conflictInstErr) +-- For type families the RHS is important; for data families not so. +-- Indeed for data families the RHS is a mysterious internal +-- type constructor, so we suppress it (#14179) +-- See FamInstEnv Note [Family instance overlap conflicts] +pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs + where + pp_rhs _ _ = empty + +pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc +pprCoAxBranch = ppr_co_ax_branch ppr_rhs + where + ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs + +ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) + -> TyCon -> CoAxBranch -> SDoc +ppr_co_ax_branch ppr_rhs fam_tc branch + = foldr1 (flip hangNotEmpty 2) + [ pprUserForAll (mkTyCoVarBinders Inferred bndrs') + -- See Note [Printing foralls in type family instances] in GHC.Iface.Type + , pp_lhs <+> ppr_rhs tidy_env ee_rhs + , text "-- Defined" <+> pp_loc ] + where + loc = coAxBranchSpan branch + pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc) + | otherwise = text "in" <+> ppr loc + + -- Eta-expand LHS and RHS types, because sometimes data family + -- instances are eta-reduced. + -- See Note [Eta reduction for data families] in GHC.Core.FamInstEnv. + (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch + + pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) + (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs) + + (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs + +tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +-- Tidy wildcards "_1", "_2" to "_", and do not return them +-- in the list of binders to be printed +-- This is so that in error messages we see +-- forall a. F _ [a] _ = ... +-- rather than +-- forall a _1 _2. F _1 [a] _2 = ... +-- +-- This is a rather disgusting function +tidyCoAxBndrsForUser init_env tcvs + = (tidy_env, reverse tidy_bndrs) + where + (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs + + tidy_one (env@(occ_env, subst), rev_bndrs') bndr + | is_wildcard bndr = (env_wild, rev_bndrs') + | otherwise = (env', bndr' : rev_bndrs') + where + (env', bndr') = tidyVarBndr env bndr + env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) + wild_bndr = setVarName bndr $ + tidyNameOcc (varName bndr) (mkTyVarOcc "_") + -- Tidy the binder to "_" + + is_wildcard :: Var -> Bool + is_wildcard tv = case occNameString (getOccName tv) of + ('_' : rest) -> all isDigit rest + _ -> False + +{- +%************************************************************************ +%* * + Destructing coercions +%* * +%************************************************************************ + +Note [Function coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Remember that + (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep + +Hence + FunCo r co1 co2 :: (s1->t1) ~r (s2->t2) +is short for + TyConAppCo (->) co_rep1 co_rep2 co1 co2 +where co_rep1, co_rep2 are the coercions on the representations. +-} + + +-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into +-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: +-- +-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c] +decomposeCo :: Arity -> Coercion + -> [Role] -- the roles of the output coercions + -- this must have at least as many + -- entries as the Arity provided + -> [Coercion] +decomposeCo arity co rs + = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ] + -- Remember, Nth is zero-indexed + +decomposeFunCo :: HasDebugCallStack + => Role -- Role of the input coercion + -> Coercion -- Input coercion + -> (Coercion, Coercion) +-- Expects co :: (s1 -> t1) ~ (s2 -> t2) +-- Returns (co1 :: s1~s2, co2 :: t1~t2) +-- See Note [Function coercions] for the "2" and "3" +decomposeFunCo r co = ASSERT2( all_ok, ppr co ) + (mkNthCo r 2 co, mkNthCo r 3 co) + where + Pair s1t1 s2t2 = coercionKind co + all_ok = isFunTy s1t1 && isFunTy s2t2 + +{- Note [Pushing a coercion into a pi-type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have this: + (f |> co) t1 .. tn +Then we want to push the coercion into the arguments, so as to make +progress. For example of why you might want to do so, see Note +[Respecting definitional equality] in GHC.Core.TyCo.Rep. + +This is done by decomposePiCos. Specifically, if + decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor) +then + (f |> co) t1 .. tn = (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn + +Notes: + +* k can be smaller than n! That is decomposePiCos can return *fewer* + coercions than there are arguments (ie k < n), if the kind provided + doesn't have enough binders. + +* If there is a type error, we might see + (f |> co) t1 + where co :: (forall a. ty) ~ (ty1 -> ty2) + Here 'co' is insoluble, but we don't want to crash in decoposePiCos. + So decomposePiCos carefully tests both sides of the coercion to check + they are both foralls or both arrows. Not doing this caused #15343. +-} + +decomposePiCos :: HasDebugCallStack + => CoercionN -> Pair Type -- Coercion and its kind + -> [Type] + -> ([CoercionN], CoercionN) +-- See Note [Pushing a coercion into a pi-type] +decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args + = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args + where + orig_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co + + go :: [CoercionN] -- accumulator for argument coercions, reversed + -> (TCvSubst,Kind) -- Lhs kind of coercion + -> CoercionN -- coercion originally applied to the function + -> (TCvSubst,Kind) -- Rhs kind of coercion + -> [Type] -- Arguments to that function + -> ([CoercionN], Coercion) + -- Invariant: co :: subst1(k2) ~ subst2(k2) + + go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys) + | Just (a, t1) <- splitForAllTy_maybe k1 + , Just (b, t2) <- splitForAllTy_maybe k2 + -- know co :: (forall a:s1.t1) ~ (forall b:s2.t2) + -- function :: forall a:s1.t1 (the function is not passed to decomposePiCos) + -- a :: s1 + -- b :: s2 + -- ty :: s2 + -- need arg_co :: s2 ~ s1 + -- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b] + = let arg_co = mkNthCo Nominal 0 (mkSymCo co) + res_co = mkInstCo co (mkGReflLeftCo Nominal ty arg_co) + subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co) + subst2' = extendTCvSubst subst2 b ty + in + go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys + + | Just (_s1, t1) <- splitFunTy_maybe k1 + , Just (_s2, t2) <- splitFunTy_maybe k2 + -- know co :: (s1 -> t1) ~ (s2 -> t2) + -- function :: s1 -> t1 + -- ty :: s2 + -- need arg_co :: s2 ~ s1 + -- res_co :: t1 ~ t2 + = let (sym_arg_co, res_co) = decomposeFunCo Nominal co + arg_co = mkSymCo sym_arg_co + in + go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys + + | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2) + = go acc_arg_cos (zapTCvSubst subst1, substTy subst1 k1) + co + (zapTCvSubst subst2, substTy subst1 k2) + (ty:tys) + + -- tys might not be empty, if the left-hand type of the original coercion + -- didn't have enough binders + go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co) + +-- | Attempts to obtain the type variable underlying a 'Coercion' +getCoVar_maybe :: Coercion -> Maybe CoVar +getCoVar_maybe (CoVarCo cv) = Just cv +getCoVar_maybe _ = Nothing + +-- | Attempts to tease a coercion apart into a type constructor and the application +-- of a number of coercion arguments to that constructor +splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) +splitTyConAppCo_maybe co + | Just (ty, r) <- isReflCo_maybe co + = do { (tc, tys) <- splitTyConApp_maybe ty + ; let args = zipWith mkReflCo (tyConRolesX r tc) tys + ; return (tc, args) } +splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos) +splitTyConAppCo_maybe (FunCo _ arg res) = Just (funTyCon, cos) + where cos = [mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res] +splitTyConAppCo_maybe _ = Nothing + +-- first result has role equal to input; third result is Nominal +splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +-- ^ Attempt to take a coercion application apart. +splitAppCo_maybe (AppCo co arg) = Just (co, arg) +splitAppCo_maybe (TyConAppCo r tc args) + | args `lengthExceeds` tyConArity tc + , Just (args', arg') <- snocView args + = Just ( mkTyConAppCo r tc args', arg' ) + + | not (mustBeSaturated tc) + -- Never create unsaturated type family apps! + , Just (args', arg') <- snocView args + , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg' + = Just ( mkTyConAppCo r tc args', arg'' ) + -- Use mkTyConAppCo to preserve the invariant + -- that identity coercions are always represented by Refl + +splitAppCo_maybe co + | Just (ty, r) <- isReflCo_maybe co + , Just (ty1, ty2) <- splitAppTy_maybe ty + = Just (mkReflCo r ty1, mkNomReflCo ty2) +splitAppCo_maybe _ = Nothing + +splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +splitFunCo_maybe (FunCo _ arg res) = Just (arg, res) +splitFunCo_maybe _ = Nothing + +splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion) +splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co) +splitForAllCo_maybe _ = Nothing + +-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder +splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +splitForAllCo_ty_maybe (ForAllCo tv k_co co) + | isTyVar tv = Just (tv, k_co, co) +splitForAllCo_ty_maybe _ = Nothing + +-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder +splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) +splitForAllCo_co_maybe (ForAllCo cv k_co co) + | isCoVar cv = Just (cv, k_co, co) +splitForAllCo_co_maybe _ = Nothing + +------------------------------------------------------- +-- and some coercion kind stuff + +coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type +coVarLType cv | (_, _, ty1, _, _) <- coVarKindsTypesRole cv = ty1 +coVarRType cv | (_, _, _, ty2, _) <- coVarKindsTypesRole cv = ty2 + +coVarTypes :: HasDebugCallStack => CoVar -> Pair Type +coVarTypes cv + | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv + = Pair ty1 ty2 + +coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role) +coVarKindsTypesRole cv + | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv) + = (k1, k2, ty1, ty2, eqTyConRole tc) + | otherwise + = pprPanic "coVarKindsTypesRole, non coercion variable" + (ppr cv $$ ppr (varType cv)) + +coVarKind :: CoVar -> Type +coVarKind cv + = ASSERT( isCoVar cv ) + varType cv + +coVarRole :: CoVar -> Role +coVarRole cv + = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of + Just tc0 -> tc0 + Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv)) + +eqTyConRole :: TyCon -> Role +-- Given (~#) or (~R#) return the Nominal or Representational respectively +eqTyConRole tc + | tc `hasKey` eqPrimTyConKey + = Nominal + | tc `hasKey` eqReprPrimTyConKey + = Representational + | otherwise + = pprPanic "eqTyConRole: unknown tycon" (ppr tc) + +-- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@, +-- produce a coercion @rep_co :: r1 ~ r2@. +mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion +mkRuntimeRepCo co + = mkNthCo Nominal 0 kind_co + where + kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 + -- (up to silliness with Constraint) + +isReflCoVar_maybe :: Var -> Maybe Coercion +-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t) +-- Works on all kinds of Vars, not just CoVars +isReflCoVar_maybe cv + | isCoVar cv + , Pair ty1 ty2 <- coVarTypes cv + , ty1 `eqType` ty2 + = Just (mkReflCo (coVarRole cv) ty1) + | otherwise + = Nothing + +-- | Tests if this coercion is obviously a generalized reflexive coercion. +-- Guaranteed to work very quickly. +isGReflCo :: Coercion -> Bool +isGReflCo (GRefl{}) = True +isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl +isGReflCo _ = False + +-- | Tests if this MCoercion is obviously generalized reflexive +-- Guaranteed to work very quickly. +isGReflMCo :: MCoercion -> Bool +isGReflMCo MRefl = True +isGReflMCo (MCo co) | isGReflCo co = True +isGReflMCo _ = False + +-- | Tests if this coercion is obviously reflexive. Guaranteed to work +-- very quickly. Sometimes a coercion can be reflexive, but not obviously +-- so. c.f. 'isReflexiveCo' +isReflCo :: Coercion -> Bool +isReflCo (Refl{}) = True +isReflCo (GRefl _ _ mco) | isGReflMCo mco = True +isReflCo _ = False + +-- | Returns the type coerced if this coercion is a generalized reflexive +-- coercion. Guaranteed to work very quickly. +isGReflCo_maybe :: Coercion -> Maybe (Type, Role) +isGReflCo_maybe (GRefl r ty _) = Just (ty, r) +isGReflCo_maybe (Refl ty) = Just (ty, Nominal) +isGReflCo_maybe _ = Nothing + +-- | Returns the type coerced if this coercion is reflexive. Guaranteed +-- to work very quickly. Sometimes a coercion can be reflexive, but not +-- obviously so. c.f. 'isReflexiveCo_maybe' +isReflCo_maybe :: Coercion -> Maybe (Type, Role) +isReflCo_maybe (Refl ty) = Just (ty, Nominal) +isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflCo_maybe _ = Nothing + +-- | Slowly checks if the coercion is reflexive. Don't call this in a loop, +-- as it walks over the entire coercion. +isReflexiveCo :: Coercion -> Bool +isReflexiveCo = isJust . isReflexiveCo_maybe + +-- | Extracts the coerced type from a reflexive coercion. This potentially +-- walks over the entire coercion, so avoid doing this in a loop. +isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) +isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal) +isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflexiveCo_maybe co + | ty1 `eqType` ty2 + = Just (ty1, r) + | otherwise + = Nothing + where (Pair ty1 ty2, r) = coercionKindRole co + +coToMCo :: Coercion -> MCoercion +coToMCo c = if isReflCo c + then MRefl + else MCo c + +{- +%************************************************************************ +%* * + Building coercions +%* * +%************************************************************************ + +These "smart constructors" maintain the invariants listed in the definition +of Coercion, and they perform very basic optimizations. + +Note [Role twiddling functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a plethora of functions for twiddling roles: + +mkSubCo: Requires a nominal input coercion and always produces a +representational output. This is used when you (the programmer) are sure you +know exactly that role you have and what you want. + +downgradeRole_maybe: This function takes both the input role and the output role +as parameters. (The *output* role comes first!) It can only *downgrade* a +role -- that is, change it from N to R or P, or from R to P. This one-way +behavior is why there is the "_maybe". If an upgrade is requested, this +function produces Nothing. This is used when you need to change the role of a +coercion, but you're not sure (as you're writing the code) of which roles are +involved. + +This function could have been written using coercionRole to ascertain the role +of the input. But, that function is recursive, and the caller of downgradeRole_maybe +often knows the input role. So, this is more efficient. + +downgradeRole: This is just like downgradeRole_maybe, but it panics if the +conversion isn't a downgrade. + +setNominalRole_maybe: This is the only function that can *upgrade* a coercion. +The result (if it exists) is always Nominal. The input can be at any role. It +works on a "best effort" basis, as it should never be strictly necessary to +upgrade a coercion during compilation. It is currently only used within GHC in +splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second +coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable +that splitAppCo_maybe is operating over a TyConAppCo that uses a +representational coercion. Hence the need for setNominalRole_maybe. +splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, +it is not absolutely critical that setNominalRole_maybe be complete. + +Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom +UnivCos are perfectly type-safe, whereas representational and nominal ones are +not. (Nominal ones are no worse than representational ones, so this function *will* +change a UnivCo Representational to a UnivCo Nominal.) + +Conal Elliott also came across a need for this function while working with the +GHC API, as he was decomposing Core casts. The Core casts use representational +coercions, as they must, but his use case required nominal coercions (he was +building a GADT). So, that's why this function is exported from this module. + +One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as +appropriate? I (Richard E.) have decided not to do this, because upgrading a +role is bizarre and a caller should have to ask for this behavior explicitly. + +-} + +-- | Make a generalized reflexive coercion +mkGReflCo :: Role -> Type -> MCoercionN -> Coercion +mkGReflCo r ty mco + | isGReflMCo mco = if r == Nominal then Refl ty + else GRefl r ty MRefl + | otherwise = GRefl r ty mco + +-- | Make a reflexive coercion +mkReflCo :: Role -> Type -> Coercion +mkReflCo Nominal ty = Refl ty +mkReflCo r ty = GRefl r ty MRefl + +-- | Make a representational reflexive coercion +mkRepReflCo :: Type -> Coercion +mkRepReflCo ty = GRefl Representational ty MRefl + +-- | Make a nominal reflexive coercion +mkNomReflCo :: Type -> Coercion +mkNomReflCo = Refl + +-- | Apply a type constructor to a list of coercions. It is the +-- caller's responsibility to get the roles correct on argument coercions. +mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion +mkTyConAppCo r tc cos + | tc `hasKey` funTyConKey + , [_rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions] + = -- (a :: TYPE ra) -> (b :: TYPE rb) ~ (c :: TYPE rc) -> (d :: TYPE rd) + -- rep1 :: ra ~ rc rep2 :: rb ~ rd + -- co1 :: a ~ c co2 :: b ~ d + mkFunCo r co1 co2 + + -- Expand type synonyms + | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos + = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos + + | Just tys_roles <- traverse isReflCo_maybe cos + = mkReflCo r (mkTyConApp tc (map fst tys_roles)) + -- See Note [Refl invariant] + + | otherwise = TyConAppCo r tc cos + +-- | Build a function 'Coercion' from two other 'Coercion's. That is, +-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@. +mkFunCo :: Role -> Coercion -> Coercion -> Coercion +mkFunCo r co1 co2 + -- See Note [Refl invariant] + | Just (ty1, _) <- isReflCo_maybe co1 + , Just (ty2, _) <- isReflCo_maybe co2 + = mkReflCo r (mkVisFunTy ty1 ty2) + | otherwise = FunCo r co1 co2 + +-- | Apply a 'Coercion' to another 'Coercion'. +-- The second coercion must be Nominal, unless the first is Phantom. +-- If the first is Phantom, then the second can be either Phantom or Nominal. +mkAppCo :: Coercion -- ^ :: t1 ~r t2 + -> Coercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 + -> Coercion -- ^ :: t1 s1 ~r t2 s2 +mkAppCo co arg + | Just (ty1, r) <- isReflCo_maybe co + , Just (ty2, _) <- isReflCo_maybe arg + = mkReflCo r (mkAppTy ty1 ty2) + + | Just (ty1, r) <- isReflCo_maybe co + , Just (tc, tys) <- splitTyConApp_maybe ty1 + -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102) + = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) + where + zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg] + zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys + zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... + +mkAppCo (TyConAppCo r tc args) arg + = case r of + Nominal -> mkTyConAppCo Nominal tc (args ++ [arg]) + Representational -> mkTyConAppCo Representational tc (args ++ [arg']) + where new_role = (tyConRolesRepresentational tc) !! (length args) + arg' = downgradeRole new_role Nominal arg + Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) +mkAppCo co arg = AppCo co arg +-- Note, mkAppCo is careful to maintain invariants regarding +-- where Refl constructors appear; see the comments in the definition +-- of Coercion and the Note [Refl invariant] in GHC.Core.TyCo.Rep. + +-- | Applies multiple 'Coercion's to another 'Coercion', from left to right. +-- See also 'mkAppCo'. +mkAppCos :: Coercion + -> [Coercion] + -> Coercion +mkAppCos co1 cos = foldl' mkAppCo co1 cos + +{- Note [Unused coercion variable in ForAllCo] + +See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep for the +motivation for checking coercion variable in types. +To lift the design choice to (ForAllCo cv kind_co body_co), we have two options: + +(1) In mkForAllCo, we check whether cv is a coercion variable + and whether it is not used in body_co. If so we construct a FunCo. +(2) We don't do this check in mkForAllCo. + In coercionKind, we use mkTyCoForAllTy to perform the check and construct + a FunTy when necessary. + +We chose (2) for two reasons: + +* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not + make a difference. +* even if cv occurs in body_co, it is possible that cv does not occur in the kind + of body_co. Therefore the check in coercionKind is inevitable. + +The last wrinkle is that there are restrictions around the use of the cv in the +coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that +we cannot prove that the type system is consistent with unrestricted use of this +cv; the consistency proof uses an untyped rewrite relation that works over types +with all coercions and casts removed. So, we can allow the cv to appear only in +positions that are erased. As an approximation of this (and keeping close to the +published theory), we currently allow the cv only within the type in a Refl node +and under a GRefl node (including in the Coercion stored in a GRefl). It's +possible other places are OK, too, but this is a safe approximation. + +Sadly, with heterogeneous equality, this restriction might be able to be violated; +Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst +function might create an invalid coercion. Because a violation of the +restriction might lead to a program that "goes wrong", it is checked all the time, +even in a production compiler and without -dcore-list. We *have* proved that the +problem does not occur with homogeneous equality, so this check can be dropped +once ~# is made to be homogeneous. +-} + + +-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion. +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +-- See Note [Unused coercion variable in ForAllCo] +mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion +mkForAllCo v kind_co co + | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True + , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True + , Just (ty, r) <- isReflCo_maybe co + , isGReflCo kind_co + = mkReflCo r (mkTyCoInvForAllTy v ty) + | otherwise + = ForAllCo v kind_co co + +-- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious +-- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'. +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion +mkForAllCo_NoRefl v kind_co co + | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True + , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True + , ASSERT( not (isReflCo co)) True + , isCoVar v + , not (v `elemVarSet` tyCoVarsOfCo co) + = FunCo (coercionRole co) kind_co co + | otherwise + = ForAllCo v kind_co co + +-- | Make nested ForAllCos +mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion +mkForAllCos bndrs co + | Just (ty, r ) <- isReflCo_maybe co + = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in + foldl' (flip $ uncurry mkForAllCo_NoRefl) + (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty)) + non_refls_rev'd + | otherwise + = foldr (uncurry mkForAllCo_NoRefl) co bndrs + +-- | Make a Coercion quantified over a type/coercion variable; +-- the variable has the same type in both sides of the coercion +mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion +mkHomoForAllCos vs co + | Just (ty, r) <- isReflCo_maybe co + = mkReflCo r (mkTyCoInvForAllTys vs ty) + | otherwise + = mkHomoForAllCos_NoRefl vs co + +-- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious +-- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'. +mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion +mkHomoForAllCos_NoRefl vs orig_co + = ASSERT( not (isReflCo orig_co)) + foldr go orig_co vs + where + go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co + +mkCoVarCo :: CoVar -> Coercion +-- cv :: s ~# t +-- See Note [mkCoVarCo] +mkCoVarCo cv = CoVarCo cv + +mkCoVarCos :: [CoVar] -> [Coercion] +mkCoVarCos = map mkCoVarCo + +{- Note [mkCoVarCo] +~~~~~~~~~~~~~~~~~~~ +In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is +valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but +it's a relatively expensive test and perhaps better done in +optCoercion. Not a big deal either way. +-} + +-- | Extract a covar, if possible. This check is dirty. Be ashamed +-- of yourself. (It's dirty because it cares about the structure of +-- a coercion, which is morally reprehensible.) +isCoVar_maybe :: Coercion -> Maybe CoVar +isCoVar_maybe (CoVarCo cv) = Just cv +isCoVar_maybe _ = Nothing + +mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion] + -> Coercion +-- mkAxInstCo can legitimately be called over-staturated; +-- i.e. with more type arguments than the coercion requires +mkAxInstCo role ax index tys cos + | arity == n_tys = downgradeRole role ax_role $ + mkAxiomInstCo ax_br index (rtys `chkAppend` cos) + | otherwise = ASSERT( arity < n_tys ) + downgradeRole role ax_role $ + mkAppCos (mkAxiomInstCo ax_br index + (ax_args `chkAppend` cos)) + leftover_args + where + n_tys = length tys + ax_br = toBranchedAxiom ax + branch = coAxiomNthBranch ax_br index + tvs = coAxBranchTyVars branch + arity = length tvs + arg_roles = coAxBranchRoles branch + rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys + (ax_args, leftover_args) + = splitAt arity rtys + ax_role = coAxiomRole ax + +-- worker function +mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion +mkAxiomInstCo ax index args + = ASSERT( args `lengthIs` coAxiomArity ax index ) + AxiomInstCo ax index args + +-- to be used only with unbranched axioms +mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched + -> [Type] -> [Coercion] -> Coercion +mkUnbranchedAxInstCo role ax tys cos + = mkAxInstCo role ax 0 tys cos + +mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +-- Instantiate the axiom with specified types, +-- returning the instantiated RHS +-- A companion to mkAxInstCo: +-- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) +mkAxInstRHS ax index tys cos + = ASSERT( tvs `equalLength` tys1 ) + mkAppTys rhs' tys2 + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + rhs' = substTyWith tvs tys1 $ + substTyWithCoVars cvs cos $ + coAxBranchRHS branch + +mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 + +-- | Return the left-hand type of the axiom, when the axiom is instantiated +-- at the types given. +mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +mkAxInstLHS ax index tys cos + = ASSERT( tvs `equalLength` tys1 ) + mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + lhs_tys = substTysWith tvs tys1 $ + substTysWithCoVars cvs cos $ + coAxBranchLHS branch + fam_tc = coAxiomTyCon ax + +-- | Instantiate the left-hand side of an unbranched axiom +mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0 + +-- | Make a coercion from a coercion hole +mkHoleCo :: CoercionHole -> Coercion +mkHoleCo h = HoleCo h + +-- | Make a universal coercion between two arbitrary types. +mkUnivCo :: UnivCoProvenance + -> Role -- ^ role of the built coercion, "r" + -> Type -- ^ t1 :: k1 + -> Type -- ^ t2 :: k2 + -> Coercion -- ^ :: t1 ~r t2 +mkUnivCo prov role ty1 ty2 + | ty1 `eqType` ty2 = mkReflCo role ty1 + | otherwise = UnivCo prov role ty1 ty2 + +-- | Create a symmetric version of the given 'Coercion' that asserts +-- equality between the same types but in the other "direction", so +-- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. +mkSymCo :: Coercion -> Coercion + +-- Do a few simple optimizations, but don't bother pushing occurrences +-- of symmetry to the leaves; the optimizer will take care of that. +mkSymCo co | isReflCo co = co +mkSymCo (SymCo co) = co +mkSymCo (SubCo (SymCo co)) = SubCo co +mkSymCo co = SymCo co + +-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. +-- (co1 ; co2) +mkTransCo :: Coercion -> Coercion -> Coercion +mkTransCo co1 co2 | isReflCo co1 = co2 + | isReflCo co2 = co1 +mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2)) + = GRefl r t1 (MCo $ mkTransCo co1 co2) +mkTransCo co1 co2 = TransCo co1 co2 + +-- | Compose two MCoercions via transitivity +mkTransMCo :: MCoercion -> MCoercion -> MCoercion +mkTransMCo MRefl co2 = co2 +mkTransMCo co1 MRefl = co1 +mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2) + +mkNthCo :: HasDebugCallStack + => Role -- The role of the coercion you're creating + -> Int -- Zero-indexed + -> Coercion + -> Coercion +mkNthCo r n co + = ASSERT2( good_call, bad_call_msg ) + go r n co + where + Pair ty1 ty2 = coercionKind co + + go r 0 co + | Just (ty, _) <- isReflCo_maybe co + , Just (tv, _) <- splitForAllTy_maybe ty + = -- works for both tyvar and covar + ASSERT( r == Nominal ) + mkNomReflCo (varType tv) + + go r n co + | Just (ty, r0) <- isReflCo_maybe co + , let tc = tyConAppTyCon ty + = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty ) + ASSERT( nthRole r0 tc n == r ) + mkReflCo r (tyConAppArgN n ty) + where ok_tc_app :: Type -> Int -> Bool + ok_tc_app ty n + | Just (_, tys) <- splitTyConApp_maybe ty + = tys `lengthExceeds` n + | isForAllTy ty -- nth:0 pulls out a kind coercion from a hetero forall + = n == 0 + | otherwise + = False + + go r 0 (ForAllCo _ kind_co _) + = ASSERT( r == Nominal ) + kind_co + -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) + -- then (nth 0 co :: k1 ~N k2) + -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) + -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) + + go r n co@(FunCo r0 arg res) + -- See Note [Function coercions] + -- If FunCo _ arg_co res_co :: (s1:TYPE sk1 -> s2:TYPE sk2) + -- ~ (t1:TYPE tk1 -> t2:TYPE tk2) + -- Then we want to behave as if co was + -- TyConAppCo argk_co resk_co arg_co res_co + -- where + -- argk_co :: sk1 ~ tk1 = mkNthCo 0 (mkKindCo arg_co) + -- resk_co :: sk2 ~ tk2 = mkNthCo 0 (mkKindCo res_co) + -- i.e. mkRuntimeRepCo + = case n of + 0 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg + 1 -> ASSERT( r == Nominal ) mkRuntimeRepCo res + 2 -> ASSERT( r == r0 ) arg + 3 -> ASSERT( r == r0 ) res + _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co) + + go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n + , (vcat [ ppr tc + , ppr arg_cos + , ppr r0 + , ppr n + , ppr r ]) ) + arg_cos `getNth` n + + go r n co = + NthCo r n co + + -- Assertion checking + bad_call_msg = vcat [ text "Coercion =" <+> ppr co + , text "LHS ty =" <+> ppr ty1 + , text "RHS ty =" <+> ppr ty2 + , text "n =" <+> ppr n, text "r =" <+> ppr r + , text "coercion role =" <+> ppr (coercionRole co) ] + good_call + -- If the Coercion passed in is between forall-types, then the Int must + -- be 0 and the role must be Nominal. + | Just (_tv1, _) <- splitForAllTy_maybe ty1 + , Just (_tv2, _) <- splitForAllTy_maybe ty2 + = n == 0 && r == Nominal + + -- If the Coercion passed in is between T tys and T tys', then the Int + -- must be less than the length of tys/tys' (which must be the same + -- lengths). + -- + -- If the role of the Coercion is nominal, then the role passed in must + -- be nominal. If the role of the Coercion is representational, then the + -- role passed in must be tyConRolesRepresentational T !! n. If the role + -- of the Coercion is Phantom, then the role passed in must be Phantom. + -- + -- See also Note [NthCo Cached Roles] if you're wondering why it's + -- blaringly obvious that we should be *computing* this role instead of + -- passing it in. + | Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , tc1 == tc2 + = let len1 = length tys1 + len2 = length tys2 + good_role = case coercionRole co of + Nominal -> r == Nominal + Representational -> r == (tyConRolesRepresentational tc1 !! n) + Phantom -> r == Phantom + in len1 == len2 && n < len1 && good_role + + | otherwise + = True + + + +-- | If you're about to call @mkNthCo r n co@, then @r@ should be +-- whatever @nthCoRole n co@ returns. +nthCoRole :: Int -> Coercion -> Role +nthCoRole n co + | Just (tc, _) <- splitTyConApp_maybe lty + = nthRole r tc n + + | Just _ <- splitForAllTy_maybe lty + = Nominal + + | otherwise + = pprPanic "nthCoRole" (ppr co) + + where + lty = coercionLKind co + r = coercionRole co + +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkLRCo lr co + | Just (ty, eq) <- isReflCo_maybe co + = mkReflCo eq (pickLR lr (splitAppTy ty)) + | otherwise + = LRCo lr co + +-- | Instantiates a 'Coercion'. +mkInstCo :: Coercion -> Coercion -> Coercion +mkInstCo (ForAllCo tcv _kind_co body_co) co + | Just (arg, _) <- isReflCo_maybe co + -- works for both tyvar and covar + = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co +mkInstCo co arg = InstCo co arg + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- produces @co' :: ty ~r (ty |> co)@ +mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion +mkGReflRightCo r ty co + | isGReflCo co = mkReflCo r ty + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = GRefl r ty (MCo co) + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- produces @co' :: (ty |> co) ~r ty@ +mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion +mkGReflLeftCo r ty co + | isGReflCo co = mkReflCo r ty + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = mkSymCo $ GRefl r ty (MCo co) + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@, +-- produces @co' :: (ty |> co) ~r ty' +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceLeftCo r ty co co2 + | isGReflCo co = co2 + | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2 + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@, +-- produces @co' :: ty' ~r (ty |> co) +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceRightCo r ty co co2 + | isGReflCo co = co2 + | otherwise = co2 `mkTransCo` GRefl r ty (MCo co) + +-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@. +mkKindCo :: Coercion -> Coercion +mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty) +mkKindCo (GRefl _ _ (MCo co)) = co +mkKindCo (UnivCo (PhantomProv h) _ _ _) = h +mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h +mkKindCo co + | Pair ty1 ty2 <- coercionKind co + -- generally, calling coercionKind during coercion creation is a bad idea, + -- as it can lead to exponential behavior. But, we don't have nested mkKindCos, + -- so it's OK here. + , let tk1 = typeKind ty1 + tk2 = typeKind ty2 + , tk1 `eqType` tk2 + = Refl tk1 + | otherwise + = KindCo co + +mkSubCo :: Coercion -> Coercion +-- Input coercion is Nominal, result is Representational +-- see also Note [Role twiddling functions] +mkSubCo (Refl ty) = GRefl Representational ty MRefl +mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co +mkSubCo (TyConAppCo Nominal tc cos) + = TyConAppCo Representational tc (applyRoles tc cos) +mkSubCo (FunCo Nominal arg res) + = FunCo Representational + (downgradeRole Representational Nominal arg) + (downgradeRole Representational Nominal res) +mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) + SubCo co + +-- | Changes a role, but only a downgrade. See Note [Role twiddling functions] +downgradeRole_maybe :: Role -- ^ desired role + -> Role -- ^ current role + -> Coercion -> Maybe Coercion +-- In (downgradeRole_maybe dr cr co) it's a precondition that +-- cr = coercionRole co + +downgradeRole_maybe Nominal Nominal co = Just co +downgradeRole_maybe Nominal _ _ = Nothing + +downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) +downgradeRole_maybe Representational Representational co = Just co +downgradeRole_maybe Representational Phantom _ = Nothing + +downgradeRole_maybe Phantom Phantom co = Just co +downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) + +-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. +-- See Note [Role twiddling functions] +downgradeRole :: Role -- desired role + -> Role -- current role + -> Coercion -> Coercion +downgradeRole r1 r2 co + = case downgradeRole_maybe r1 r2 co of + Just co' -> co' + Nothing -> pprPanic "downgradeRole" (ppr co) + +mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion +mkAxiomRuleCo = AxiomRuleCo + +-- | Make a "coercion between coercions". +mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" + -> Coercion -- ^ :: phi1 ~N phi2 + -> Coercion -- ^ g1 :: phi1 + -> Coercion -- ^ g2 :: phi2 + -> Coercion -- ^ :: g1 ~r g2 + +-- if the two coercion prove the same fact, I just don't care what +-- the individual coercions are. +mkProofIrrelCo r co g _ | isGReflCo co = mkReflCo r (mkCoercionTy g) + -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@ +mkProofIrrelCo r kco g1 g2 = mkUnivCo (ProofIrrelProv kco) r + (mkCoercionTy g1) (mkCoercionTy g2) + +{- +%************************************************************************ +%* * + Roles +%* * +%************************************************************************ +-} + +-- | Converts a coercion to be nominal, if possible. +-- See Note [Role twiddling functions] +setNominalRole_maybe :: Role -- of input coercion + -> Coercion -> Maybe Coercion +setNominalRole_maybe r co + | r == Nominal = Just co + | otherwise = setNominalRole_maybe_helper co + where + setNominalRole_maybe_helper (SubCo co) = Just co + setNominalRole_maybe_helper co@(Refl _) = Just co + setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co + setNominalRole_maybe_helper (TyConAppCo Representational tc cos) + = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos + ; return $ TyConAppCo Nominal tc cos' } + setNominalRole_maybe_helper (FunCo Representational co1 co2) + = do { co1' <- setNominalRole_maybe Representational co1 + ; co2' <- setNominalRole_maybe Representational co2 + ; return $ FunCo Nominal co1' co2' + } + setNominalRole_maybe_helper (SymCo co) + = SymCo <$> setNominalRole_maybe_helper co + setNominalRole_maybe_helper (TransCo co1 co2) + = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2 + setNominalRole_maybe_helper (AppCo co1 co2) + = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2 + setNominalRole_maybe_helper (ForAllCo tv kind_co co) + = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co + setNominalRole_maybe_helper (NthCo _r n co) + -- NB, this case recurses via setNominalRole_maybe, not + -- setNominalRole_maybe_helper! + = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co + setNominalRole_maybe_helper (InstCo co arg) + = InstCo <$> setNominalRole_maybe_helper co <*> pure arg + setNominalRole_maybe_helper (UnivCo prov _ co1 co2) + | case prov of PhantomProv _ -> False -- should always be phantom + ProofIrrelProv _ -> True -- it's always safe + PluginProv _ -> False -- who knows? This choice is conservative. + = Just $ UnivCo prov Nominal co1 co2 + setNominalRole_maybe_helper _ = Nothing + +-- | Make a phantom coercion between two types. The coercion passed +-- in must be a nominal coercion between the kinds of the +-- types. +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkPhantomCo h t1 t2 + = mkUnivCo (PhantomProv h) Phantom t1 t2 + +-- takes any coercion and turns it into a Phantom coercion +toPhantomCo :: Coercion -> Coercion +toPhantomCo co + = mkPhantomCo (mkKindCo co) ty1 ty2 + where Pair ty1 ty2 = coercionKind co + +-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational +applyRoles :: TyCon -> [Coercion] -> [Coercion] +applyRoles tc cos + = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos + +-- the Role parameter is the Role of the TyConAppCo +-- defined here because this is intimately concerned with the implementation +-- of TyConAppCo +-- Always returns an infinite list (with a infinite tail of Nominal) +tyConRolesX :: Role -> TyCon -> [Role] +tyConRolesX Representational tc = tyConRolesRepresentational tc +tyConRolesX role _ = repeat role + +-- Returns the roles of the parameters of a tycon, with an infinite tail +-- of Nominal +tyConRolesRepresentational :: TyCon -> [Role] +tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal + +nthRole :: Role -> TyCon -> Int -> Role +nthRole Nominal _ _ = Nominal +nthRole Phantom _ _ = Phantom +nthRole Representational tc n + = (tyConRolesRepresentational tc) `getNth` n + +ltRole :: Role -> Role -> Bool +-- Is one role "less" than another? +-- Nominal < Representational < Phantom +ltRole Phantom _ = False +ltRole Representational Phantom = True +ltRole Representational _ = False +ltRole Nominal Nominal = False +ltRole Nominal _ = True + +------------------------------- + +-- | like mkKindCo, but aggressively & recursively optimizes to avoid using +-- a KindCo constructor. The output role is nominal. +promoteCoercion :: Coercion -> CoercionN + +-- First cases handles anything that should yield refl. +promoteCoercion co = case co of + + _ | ki1 `eqType` ki2 + -> mkNomReflCo (typeKind ty1) + -- no later branch should return refl + -- The ASSERT( False )s throughout + -- are these cases explicitly, but they should never fire. + + Refl _ -> ASSERT( False ) + mkNomReflCo ki1 + + GRefl _ _ MRefl -> ASSERT( False ) + mkNomReflCo ki1 + + GRefl _ _ (MCo co) -> co + + TyConAppCo _ tc args + | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args + -> co' + | otherwise + -> mkKindCo co + + AppCo co1 arg + | Just co' <- instCoercion (coercionKind (mkKindCo co1)) + (promoteCoercion co1) arg + -> co' + | otherwise + -> mkKindCo co + + ForAllCo tv _ g + | isTyVar tv + -> promoteCoercion g + + ForAllCo _ _ _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.Type + + FunCo _ _ _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + + CoVarCo {} -> mkKindCo co + HoleCo {} -> mkKindCo co + AxiomInstCo {} -> mkKindCo co + AxiomRuleCo {} -> mkKindCo co + + UnivCo (PhantomProv kco) _ _ _ -> kco + UnivCo (ProofIrrelProv kco) _ _ _ -> kco + UnivCo (PluginProv _) _ _ _ -> mkKindCo co + + SymCo g + -> mkSymCo (promoteCoercion g) + + TransCo co1 co2 + -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) + + NthCo _ n co1 + | Just (_, args) <- splitTyConAppCo_maybe co1 + , args `lengthExceeds` n + -> promoteCoercion (args !! n) + + | Just _ <- splitForAllCo_maybe co + , n == 0 + -> ASSERT( False ) mkNomReflCo liftedTypeKind + + | otherwise + -> mkKindCo co + + LRCo lr co1 + | Just (lco, rco) <- splitAppCo_maybe co1 + -> case lr of + CLeft -> promoteCoercion lco + CRight -> promoteCoercion rco + + | otherwise + -> mkKindCo co + + InstCo g _ + | isForAllTy_ty ty1 + -> ASSERT( isForAllTy_ty ty2 ) + promoteCoercion g + | otherwise + -> ASSERT( False) + mkNomReflCo liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.Type + + KindCo _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + + SubCo g + -> promoteCoercion g + + where + Pair ty1 ty2 = coercionKind co + ki1 = typeKind ty1 + ki2 = typeKind ty2 + +-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@, +-- where @g' = promoteCoercion (h w)@. +-- fails if this is not possible, if @g@ coerces between a forall and an -> +-- or if second parameter has a representational role and can't be used +-- with an InstCo. +instCoercion :: Pair Type -- g :: lty ~ rty + -> CoercionN -- ^ must be nominal + -> Coercion + -> Maybe CoercionN +instCoercion (Pair lty rty) g w + | (isForAllTy_ty lty && isForAllTy_ty rty) + || (isForAllTy_co lty && isForAllTy_co rty) + , Just w' <- setNominalRole_maybe (coercionRole w) w + -- g :: (forall t1. t2) ~ (forall t1. t3) + -- w :: s1 ~ s2 + -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2] + = Just $ mkInstCo g w' + | isFunTy lty && isFunTy rty + -- g :: (t1 -> t2) ~ (t3 -> t4) + -- returns t2 ~ t4 + = Just $ mkNthCo Nominal 3 g -- extract result type, which is the 4th argument to (->) + | otherwise -- one forall, one funty... + = Nothing + +-- | Repeated use of 'instCoercion' +instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN +instCoercions g ws + = let arg_ty_pairs = map coercionKind ws in + snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws) + where + go :: (Pair Type, Coercion) -> (Pair Type, Coercion) + -> Maybe (Pair Type, Coercion) + go (g_tys, g) (w_tys, w) + = do { g' <- instCoercion g_tys g w + ; return (piResultTy <$> g_tys <*> w_tys, g') } + +-- | Creates a new coercion with both of its types casted by different casts +-- @castCoercionKind g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +castCoercionKind :: Coercion -> Role -> Type -> Type + -> CoercionN -> CoercionN -> Coercion +castCoercionKind g r t1 t2 h1 h2 + = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) + +-- | Creates a new coercion with both of its types casted by different casts +-- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +-- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for) +-- Use @castCoercionKind@ instead if @t1@, @t2@, and @r@ are known beforehand. +castCoercionKindI :: Coercion -> CoercionN -> CoercionN -> Coercion +castCoercionKindI g h1 h2 + = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) + where (Pair t1 t2, r) = coercionKindRole g + +-- See note [Newtype coercions] in GHC.Core.TyCon + +mkPiCos :: Role -> [Var] -> Coercion -> Coercion +mkPiCos r vs co = foldr (mkPiCo r) co vs + +-- | Make a forall 'Coercion', where both types related by the coercion +-- are quantified over the same variable. +mkPiCo :: Role -> Var -> Coercion -> Coercion +mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co + | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) ) + -- We didn't call mkForAllCo here because if v does not appear + -- in co, the argement coercion will be nominal. But here we + -- want it to be r. It is only called in 'mkPiCos', which is + -- only used in SimplUtils, where we are sure for + -- now (Aug 2018) v won't occur in co. + mkFunCo r (mkReflCo r (varType v)) co + | otherwise = mkFunCo r (mkReflCo r (varType v)) co + +-- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 +-- The first coercion might be lifted or unlifted; thus the ~? above +-- Lifted and unlifted equalities take different numbers of arguments, +-- so we have to make sure to supply the right parameter to decomposeCo. +-- Also, note that the role of the first coercion is the same as the role of +-- the equalities related by the second coercion. The second coercion is +-- itself always representational. +mkCoCast :: Coercion -> CoercionR -> Coercion +mkCoCast c g + | (g2:g1:_) <- reverse co_list + = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 + + | otherwise + = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g)) + where + -- g :: (s1 ~# t1) ~# (s2 ~# t2) + -- g1 :: s1 ~# s2 + -- g2 :: t1 ~# t2 + (tc, _) = splitTyConApp (coercionLKind g) + co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc) + +{- +%************************************************************************ +%* * + Newtypes +%* * +%************************************************************************ +-} + +-- | If @co :: T ts ~ rep_ty@ then: +-- +-- > instNewTyCon_maybe T ts = Just (rep_ty, co) +-- +-- Checks for a newtype, and for being saturated +instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) +instNewTyCon_maybe tc tys + | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype + , tvs `leLength` tys -- Check saturated enough + = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Type normalisation +* * +************************************************************************ +-} + +-- | A function to check if we can reduce a type by one step. Used +-- with 'topNormaliseTypeX'. +type NormaliseStepper ev = RecTcChecker + -> TyCon -- tc + -> [Type] -- tys + -> NormaliseStepResult ev + +-- | The result of stepping in a normalisation function. +-- See 'topNormaliseTypeX'. +data NormaliseStepResult ev + = NS_Done -- ^ Nothing more to do + | NS_Abort -- ^ Utter failure. The outer function should fail too. + | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; + -- ^ ev is evidence; + -- Usually a co :: old type ~ new type + +mapStepResult :: (ev1 -> ev2) + -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 +mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev) +mapStepResult _ NS_Done = NS_Done +mapStepResult _ NS_Abort = NS_Abort + +-- | Try one stepper and then try the next, if the first doesn't make +-- progress. +-- So if it returns NS_Done, it means that both steppers are satisfied +composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev + -> NormaliseStepper ev +composeSteppers step1 step2 rec_nts tc tys + = case step1 rec_nts tc tys of + success@(NS_Step {}) -> success + NS_Done -> step2 rec_nts tc tys + NS_Abort -> NS_Abort + +-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into +-- a loop. If it would fall into a loop, it produces 'NS_Abort'. +unwrapNewTypeStepper :: NormaliseStepper Coercion +unwrapNewTypeStepper rec_nts tc tys + | Just (ty', co) <- instNewTyCon_maybe tc tys + = case checkRecTc rec_nts tc of + Just rec_nts' -> NS_Step rec_nts' ty' co + Nothing -> NS_Abort + + | otherwise + = NS_Done + +-- | A general function for normalising the top-level of a type. It continues +-- to use the provided 'NormaliseStepper' until that function fails, and then +-- this function returns. The roles of the coercions produced by the +-- 'NormaliseStepper' must all be the same, which is the role returned from +-- the call to 'topNormaliseTypeX'. +-- +-- Typically ev is Coercion. +-- +-- If topNormaliseTypeX step plus ty = Just (ev, ty') +-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty' +-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn +-- If it returns Nothing then no newtype unwrapping could happen +topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev) + -> Type -> Maybe (ev, Type) +topNormaliseTypeX stepper plus ty + | Just (tc, tys) <- splitTyConApp_maybe ty + , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys + = go rec_nts ev ty' + | otherwise + = Nothing + where + go rec_nts ev ty + | Just (tc, tys) <- splitTyConApp_maybe ty + = case stepper rec_nts tc tys of + NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty' + NS_Done -> Just (ev, ty) + NS_Abort -> Nothing + + | otherwise + = Just (ev, ty) + +topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) +-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. +-- This function strips off @newtype@ layers enough to reveal something that isn't +-- a @newtype@. Specifically, here's the invariant: +-- +-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') +-- +-- then (a) @co : ty0 ~ ty'@. +-- (b) ty' is not a newtype. +-- +-- The function returns @Nothing@ for non-@newtypes@, +-- or unsaturated applications +-- +-- This function does *not* look through type families, because it has no access to +-- the type family environment. If you do have that at hand, consider to use +-- topNormaliseType_maybe, which should be a drop-in replacement for +-- topNormaliseNewType_maybe +-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty' +topNormaliseNewType_maybe ty + = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty + +{- +%************************************************************************ +%* * + Comparison of coercions +%* * +%************************************************************************ +-} + +-- | Syntactic equality of coercions +eqCoercion :: Coercion -> Coercion -> Bool +eqCoercion = eqType `on` coercionType + +-- | Compare two 'Coercion's, with respect to an RnEnv2 +eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool +eqCoercionX env = eqTypeX env `on` coercionType + +{- +%************************************************************************ +%* * + "Lifting" substitution + [(TyCoVar,Coercion)] -> Type -> Coercion +%* * +%************************************************************************ + +Note [Lifting coercions over types: liftCoSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The KPUSH rule deals with this situation + data T a = K (a -> Maybe a) + g :: T t1 ~ T t2 + x :: t1 -> Maybe t1 + + case (K @t1 x) |> g of + K (y:t2 -> Maybe t2) -> rhs + +We want to push the coercion inside the constructor application. +So we do this + + g' :: t1~t2 = Nth 0 g + + case K @t2 (x |> g' -> Maybe g') of + K (y:t2 -> Maybe t2) -> rhs + +The crucial operation is that we + * take the type of K's argument: a -> Maybe a + * and substitute g' for a +thus giving *coercion*. This is what liftCoSubst does. + +In the presence of kind coercions, this is a bit +of a hairy operation. So, we refer you to the paper introducing kind coercions, +available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf + +Note [extendLiftingContextEx] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider we have datatype + K :: \/k. \/a::k. P -> T k -- P be some type + g :: T k1 ~ T k2 + + case (K @k1 @t1 x) |> g of + K y -> rhs + +We want to push the coercion inside the constructor application. +We first get the coercion mapped by the universal type variable k: + lc = k |-> Nth 0 g :: k1~k2 + +Here, the important point is that the kind of a is coerced, and P might be +dependent on the existential type variable a. +Thus we first get the coercion of a's kind + g2 = liftCoSubst lc k :: k1 ~ k2 + +Then we store a new mapping into the lifting context + lc2 = a |-> (t1 ~ t1 |> g2), lc + +So later when we can correctly deal with the argument type P + liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)] + +This is exactly what extendLiftingContextEx does. +* For each (tyvar:k, ty) pair, we product the mapping + tyvar |-> (ty ~ ty |> (liftCoSubst lc k)) +* For each (covar:s1~s2, ty) pair, we produce the mapping + covar |-> (co ~ co') + co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2' + +This follows the lifting context extension definition in the +"FC with Explicit Kind Equality" paper. +-} + +-- ---------------------------------------------------- +-- See Note [Lifting coercions over types: liftCoSubst] +-- ---------------------------------------------------- + +data LiftingContext = LC TCvSubst LiftCoEnv + -- in optCoercion, we need to lift when optimizing InstCo. + -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt + -- We thus propagate the substitution from GHC.Core.Coercion.Opt here. + +instance Outputable LiftingContext where + ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) + +type LiftCoEnv = VarEnv Coercion + -- Maps *type variables* to *coercions*. + -- That's the whole point of this function! + -- Also maps coercion variables to ProofIrrelCos. + +-- like liftCoSubstWith, but allows for existentially-bound types as well +liftCoSubstWithEx :: Role -- desired role for output coercion + -> [TyVar] -- universally quantified tyvars + -> [Coercion] -- coercions to substitute for those + -> [TyCoVar] -- existentially quantified tycovars + -> [Type] -- types and coercions to be bound to ex vars + -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args) +liftCoSubstWithEx role univs omegas exs rhos + = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas) + psi = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos) + in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs)) + +liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion +liftCoSubstWith r tvs cos ty + = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty + +-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) +-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where +-- @lc_left@ is a substitution mapping type variables to the left-hand +-- types of the mapped coercions in @lc@, and similar for @lc_right@. +liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion +liftCoSubst r lc@(LC subst env) ty + | isEmptyVarEnv env = mkReflCo r (substTy subst ty) + | otherwise = ty_co_subst lc r ty + +emptyLiftingContext :: InScopeSet -> LiftingContext +emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv + +mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext +mkLiftingContext pairs + = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) + (mkVarEnv pairs) + +mkSubstLiftingContext :: TCvSubst -> LiftingContext +mkSubstLiftingContext subst = LC subst emptyVarEnv + +-- | Extend a lifting context with a new mapping. +extendLiftingContext :: LiftingContext -- ^ original LC + -> TyCoVar -- ^ new variable to map... + -> Coercion -- ^ ...to this lifted version + -> LiftingContext + -- mappings to reflexive coercions are just substitutions +extendLiftingContext (LC subst env) tv arg + | Just (ty, _) <- isReflCo_maybe arg + = LC (extendTCvSubst subst tv ty) env + | otherwise + = LC subst (extendVarEnv env tv arg) + +-- | Extend a lifting context with a new mapping, and extend the in-scope set +extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC + -> TyCoVar -- ^ new variable to map... + -> Coercion -- ^ to this coercion + -> LiftingContext +extendLiftingContextAndInScope (LC subst env) tv co + = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co + +-- | Extend a lifting context with existential-variable bindings. +-- See Note [extendLiftingContextEx] +extendLiftingContextEx :: LiftingContext -- ^ original lifting context + -> [(TyCoVar,Type)] -- ^ ex. var / value pairs + -> LiftingContext +-- Note that this is more involved than extendLiftingContext. That function +-- takes a coercion to extend with, so it's assumed that the caller has taken +-- into account any of the kind-changing stuff worried about here. +extendLiftingContextEx lc [] = lc +extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) +-- This function adds bindings for *Nominal* coercions. Why? Because it +-- works with existentially bound variables, which are considered to have +-- nominal roles. + | isTyVar v + = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) + (extendVarEnv env v $ + mkGReflRightCo Nominal + ty + (ty_co_subst lc Nominal (tyVarKind v))) + in extendLiftingContextEx lc' rest + | CoercionTy co <- ty + = -- co :: s1 ~r s2 + -- lift_s1 :: s1 ~r s1' + -- lift_s2 :: s2 ~r s2' + -- kco :: (s1 ~r s2) ~N (s1' ~r s2') + ASSERT( isCoVar v ) + let (_, _, s1, s2, r) = coVarKindsTypesRole v + lift_s1 = ty_co_subst lc r s1 + lift_s2 = ty_co_subst lc r s2 + kco = mkTyConAppCo Nominal (equalityTyCon r) + [ mkKindCo lift_s1, mkKindCo lift_s2 + , lift_s1 , lift_s2 ] + lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co) + (extendVarEnv env v + (mkProofIrrelCo Nominal kco co $ + (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) + in extendLiftingContextEx lc' rest + | otherwise + = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty) + + +-- | Erase the environments in a lifting context +zapLiftingContext :: LiftingContext -> LiftingContext +zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv + +-- | Like 'substForAllCoBndr', but works on a lifting context +substForAllCoBndrUsingLC :: Bool + -> (Coercion -> Coercion) + -> LiftingContext -> TyCoVar -> Coercion + -> (LiftingContext, TyCoVar, Coercion) +substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co + = (LC subst' lc_env, tv', co') + where + (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co + +-- | The \"lifting\" operation which substitutes coercions for type +-- variables in a type to produce a coercion. +-- +-- For the inverse operation, see 'liftCoMatch' +ty_co_subst :: LiftingContext -> Role -> Type -> Coercion +ty_co_subst lc role ty + = go role ty + where + go :: Role -> Type -> Coercion + go r ty | Just ty' <- coreView ty + = go r ty' + go Phantom ty = lift_phantom ty + go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $ + liftCoSubstTyVar lc r tv + go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) + go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) + go r (FunTy _ ty1 ty2) = mkFunCo r (go r ty1) (go r ty2) + go r t@(ForAllTy (Bndr v _) ty) + = let (lc', v', h) = liftCoSubstVarBndr lc v + body_co = ty_co_subst lc' r ty in + if isTyVar v' || almostDevoidCoVarOfCo v' body_co + -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo + -- imposes an extra restriction on where a covar can appear. See last + -- wrinkle in Note [Unused coercion variable in ForAllCo]. + -- We specifically check for this and panic because we know that + -- there's a hole in the type system here, and we'd rather panic than + -- fall into it. + then mkForAllCo v' h body_co + else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t) + go r ty@(LitTy {}) = ASSERT( r == Nominal ) + mkNomReflCo ty + go r (CastTy ty co) = castCoercionKindI (go r ty) (substLeftCo lc co) + (substRightCo lc co) + go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) + (substRightCo lc co) + where kco = go Nominal (coercionType co) + + lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty)) + (substTy (lcSubstLeft lc) ty) + (substTy (lcSubstRight lc) ty) + +{- +Note [liftCoSubstTyVar] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This function can fail if a coercion in the environment is of too low a role. + +liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and +also in matchAxiom in GHC.Core.Coercion.Opt. From liftCoSubst, the so-called lifting +lemma guarantees that the roles work out. If we fail in this +case, we really should panic -- something is deeply wrong. But, in matchAxiom, +failing is fine. matchAxiom is trying to find a set of coercions +that match, but it may fail, and this is healthy behavior. +-} + +-- See Note [liftCoSubstTyVar] +liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion +liftCoSubstTyVar (LC subst env) r v + | Just co_arg <- lookupVarEnv env v + = downgradeRole_maybe r (coercionRole co_arg) co_arg + + | otherwise + = Just $ mkReflCo r (substTyVar subst v) + +{- Note [liftCoSubstVarBndr] + +callback: + We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in + FamInstEnv, therefore the input arg 'fun' returns a pair with polymorphic type + in snd. + However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and + ignore the fourth component of the return value. + +liftCoSubstTyVarBndrUsing: + Given + forall tv:k. t + We want to get + forall (tv:k1) (kind_co :: k1 ~ k2) body_co + + We lift the kind k to get the kind_co + kind_co = ty_co_subst k :: k1 ~ k2 + + Now in the LiftingContext, we add the new mapping + tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2) + +liftCoSubstCoVarBndrUsing: + Given + forall cv:(s1 ~ s2). t + We want to get + forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co + + We lift s1 and s2 respectively to get + eta1 :: s1' ~ t1 + eta2 :: s2' ~ t2 + And + kind_co = TyConAppCo Nominal (~#) eta1 eta2 + + Now in the liftingContext, we add the new mapping + cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2) +-} + +-- See Note [liftCoSubstVarBndr] +liftCoSubstVarBndr :: LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, Coercion) +liftCoSubstVarBndr lc tv + = let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in + (lc', tv', h) + where + callback lc' ty' = (ty_co_subst lc' Nominal ty', ()) + +-- the callback must produce a nominal coercion +liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, CoercionN, a) +liftCoSubstVarBndrUsing fun lc old_var + | isTyVar old_var + = liftCoSubstTyVarBndrUsing fun lc old_var + | otherwise + = liftCoSubstCoVarBndrUsing fun lc old_var + +-- Works for tyvar binder +liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> TyVar + -> (LiftingContext, TyVar, CoercionN, a) +liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var + = ASSERT( isTyVar old_var ) + ( LC (subst `extendTCvInScope` new_var) new_cenv + , new_var, eta, stuff ) + where + old_kind = tyVarKind old_var + (eta, stuff) = fun lc old_kind + k1 = coercionLKind eta + new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + + lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta + -- :: new_var ~ new_var |> eta + new_cenv = extendVarEnv cenv old_var lifted + +-- Works for covar binder +liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> CoVar + -> (LiftingContext, CoVar, CoercionN, a) +liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var + = ASSERT( isCoVar old_var ) + ( LC (subst `extendTCvInScope` new_var) new_cenv + , new_var, kind_co, stuff ) + where + old_kind = coVarKind old_var + (eta, stuff) = fun lc old_kind + k1 = coercionLKind eta + new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + + -- old_var :: s1 ~r s2 + -- eta :: (s1' ~r s2') ~N (t1 ~r t2) + -- eta1 :: s1' ~r t1 + -- eta2 :: s2' ~r t2 + -- co1 :: s1' ~r s2' + -- co2 :: t1 ~r t2 + -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2) + -- lifted :: co1 ~N co2 + + role = coVarRole old_var + eta' = downgradeRole role Nominal eta + eta1 = mkNthCo role 2 eta' + eta2 = mkNthCo role 3 eta' + + co1 = mkCoVarCo new_var + co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 + kind_co = mkTyConAppCo Nominal (equalityTyCon role) + [ mkKindCo co1, mkKindCo co2 + , co1 , co2 ] + lifted = mkProofIrrelCo Nominal kind_co co1 co2 + + new_cenv = extendVarEnv cenv old_var lifted + +-- | Is a var in the domain of a lifting context? +isMappedByLC :: TyCoVar -> LiftingContext -> Bool +isMappedByLC tv (LC _ env) = tv `elemVarEnv` env + +-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1 +-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1 +substLeftCo :: LiftingContext -> Coercion -> Coercion +substLeftCo lc co + = substCo (lcSubstLeft lc) co + +-- Ditto, but for t2 and g2 +substRightCo :: LiftingContext -> Coercion -> Coercion +substRightCo lc co + = substCo (lcSubstRight lc) co + +-- | Apply "sym" to all coercions in a 'LiftCoEnv' +swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv +swapLiftCoEnv = mapVarEnv mkSymCo + +lcSubstLeft :: LiftingContext -> TCvSubst +lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env + +lcSubstRight :: LiftingContext -> TCvSubst +lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env + +liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstLeft = liftEnvSubst pFst + +liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstRight = liftEnvSubst pSnd + +liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubst selector subst lc_env + = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst + where + pairs = nonDetUFMToList lc_env + -- It's OK to use nonDetUFMToList here because we + -- immediately forget the ordering by creating + -- a VarEnv + (tpairs, cpairs) = partitionWith ty_or_co pairs + tenv = mkVarEnv_Directly tpairs + cenv = mkVarEnv_Directly cpairs + + ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion) + ty_or_co (u, co) + | Just equality_co <- isCoercionTy_maybe equality_ty + = Right (u, equality_co) + | otherwise + = Left (u, equality_ty) + where + equality_ty = selector (coercionKind co) + +-- | Extract the underlying substitution from the LiftingContext +lcTCvSubst :: LiftingContext -> TCvSubst +lcTCvSubst (LC subst _) = subst + +-- | Get the 'InScopeSet' from a 'LiftingContext' +lcInScopeSet :: LiftingContext -> InScopeSet +lcInScopeSet (LC subst _) = getTCvInScope subst + +{- +%************************************************************************ +%* * + Sequencing on coercions +%* * +%************************************************************************ +-} + +seqMCo :: MCoercion -> () +seqMCo MRefl = () +seqMCo (MCo co) = seqCo co + +seqCo :: Coercion -> () +seqCo (Refl ty) = seqType ty +seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco +seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos +seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (ForAllCo tv k co) = seqType (varType tv) `seq` seqCo k + `seq` seqCo co +seqCo (FunCo r co1 co2) = r `seq` seqCo co1 `seq` seqCo co2 +seqCo (CoVarCo cv) = cv `seq` () +seqCo (HoleCo h) = coHoleCoVar h `seq` () +seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos +seqCo (UnivCo p r t1 t2) + = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 +seqCo (SymCo co) = seqCo co +seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (NthCo r n co) = r `seq` n `seq` seqCo co +seqCo (LRCo lr co) = lr `seq` seqCo co +seqCo (InstCo co arg) = seqCo co `seq` seqCo arg +seqCo (KindCo co) = seqCo co +seqCo (SubCo co) = seqCo co +seqCo (AxiomRuleCo _ cs) = seqCos cs + +seqProv :: UnivCoProvenance -> () +seqProv (PhantomProv co) = seqCo co +seqProv (ProofIrrelProv co) = seqCo co +seqProv (PluginProv _) = () + +seqCos :: [Coercion] -> () +seqCos [] = () +seqCos (co:cos) = seqCo co `seq` seqCos cos + +{- +%************************************************************************ +%* * + The kind of a type, and of a coercion +%* * +%************************************************************************ +-} + +-- | Apply 'coercionKind' to multiple 'Coercion's +coercionKinds :: [Coercion] -> Pair [Type] +coercionKinds tys = sequenceA $ map coercionKind tys + +-- | Get a coercion's kind and role. +coercionKindRole :: Coercion -> (Pair Type, Role) +coercionKindRole co = (coercionKind co, coercionRole co) + +coercionType :: Coercion -> Type +coercionType co = case coercionKindRole co of + (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 + +------------------ +-- | If it is the case that +-- +-- > c :: (t1 ~ t2) +-- +-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. + +coercionKind :: Coercion -> Pair Type +coercionKind co = Pair (coercionLKind co) (coercionRKind co) + +coercionLKind :: Coercion -> Type +coercionLKind co + = go co + where + go (Refl ty) = ty + go (GRefl _ ty _) = ty + go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) + go (AppCo co1 co2) = mkAppTy (go co1) (go co2) + go (ForAllCo tv1 _ co1) = mkTyCoInvForAllTy tv1 (go co1) + go (FunCo _ co1 co2) = mkVisFunTy (go co1) (go co2) + go (CoVarCo cv) = coVarLType cv + go (HoleCo h) = coVarLType (coHoleCoVar h) + go (UnivCo _ _ ty1 _) = ty1 + go (SymCo co) = coercionRKind co + go (TransCo co1 _) = go co1 + go (LRCo lr co) = pickLR lr (splitAppTy (go co)) + go (InstCo aco arg) = go_app aco [go arg] + go (KindCo co) = typeKind (go co) + go (SubCo co) = go co + go (NthCo _ d co) = go_nth d (go co) + go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) + go (AxiomRuleCo ax cos) = pFst $ expectJust "coercionKind" $ + coaxrProves ax $ map coercionKind cos + + go_ax_inst ax ind tys + | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs } <- coAxiomNthBranch ax ind + , let (tys1, cotys1) = splitAtList tvs tys + cos1 = map stripCoercionTy cotys1 + = ASSERT( tys `equalLength` (tvs ++ cvs) ) + -- Invariant of AxiomInstCo: cos should + -- exactly saturate the axiom branch + substTyWith tvs tys1 $ + substTyWithCoVars cvs cos1 $ + mkTyConApp (coAxiomTyCon ax) lhs + + go_app :: Coercion -> [Type] -> Type + -- Collect up all the arguments and apply all at once + -- See Note [Nested InstCos] + go_app (InstCo co arg) args = go_app co (go arg:args) + go_app co args = piResultTys (go co) args + +go_nth :: Int -> Type -> Type +go_nth d ty + | Just args <- tyConAppArgs_maybe ty + = ASSERT( args `lengthExceeds` d ) + args `getNth` d + + | d == 0 + , Just (tv,_) <- splitForAllTy_maybe ty + = tyVarKind tv + + | otherwise + = pprPanic "coercionLKind:nth" (ppr d <+> ppr ty) + +coercionRKind :: Coercion -> Type +coercionRKind co + = go co + where + go (Refl ty) = ty + go (GRefl _ ty MRefl) = ty + go (GRefl _ ty (MCo co1)) = mkCastTy ty co1 + go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) + go (AppCo co1 co2) = mkAppTy (go co1) (go co2) + go (CoVarCo cv) = coVarRType cv + go (HoleCo h) = coVarRType (coHoleCoVar h) + go (FunCo _ co1 co2) = mkVisFunTy (go co1) (go co2) + go (UnivCo _ _ _ ty2) = ty2 + go (SymCo co) = coercionLKind co + go (TransCo _ co2) = go co2 + go (LRCo lr co) = pickLR lr (splitAppTy (go co)) + go (InstCo aco arg) = go_app aco [go arg] + go (KindCo co) = typeKind (go co) + go (SubCo co) = go co + go (NthCo _ d co) = go_nth d (go co) + go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) + go (AxiomRuleCo ax cos) = pSnd $ expectJust "coercionKind" $ + coaxrProves ax $ map coercionKind cos + + go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar + | isGReflCo k_co = mkTyCoInvForAllTy tv1 (go co1) + -- kind_co always has kind @Type@, thus @isGReflCo@ + | otherwise = go_forall empty_subst co + where + empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co) + + go_ax_inst ax ind tys + | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_rhs = rhs } <- coAxiomNthBranch ax ind + , let (tys2, cotys2) = splitAtList tvs tys + cos2 = map stripCoercionTy cotys2 + = ASSERT( tys `equalLength` (tvs ++ cvs) ) + -- Invariant of AxiomInstCo: cos should + -- exactly saturate the axiom branch + substTyWith tvs tys2 $ + substTyWithCoVars cvs cos2 rhs + + go_app :: Coercion -> [Type] -> Type + -- Collect up all the arguments and apply all at once + -- See Note [Nested InstCos] + go_app (InstCo co arg) args = go_app co (go arg:args) + go_app co args = piResultTys (go co) args + + go_forall subst (ForAllCo tv1 k_co co) + -- See Note [Nested ForAllCos] + | isTyVar tv1 + = mkInvForAllTy tv2 (go_forall subst' co) + where + k2 = coercionRKind k_co + tv2 = setTyVarKind tv1 (substTy subst k2) + subst' | isGReflCo k_co = extendTCvInScope subst tv1 + -- kind_co always has kind @Type@, thus @isGReflCo@ + | otherwise = extendTvSubst (extendTCvInScope subst tv2) tv1 $ + TyVarTy tv2 `mkCastTy` mkSymCo k_co + + go_forall subst (ForAllCo cv1 k_co co) + | isCoVar cv1 + = mkTyCoInvForAllTy cv2 (go_forall subst' co) + where + k2 = coercionRKind k_co + r = coVarRole cv1 + eta1 = mkNthCo r 2 (downgradeRole r Nominal k_co) + eta2 = mkNthCo r 3 (downgradeRole r Nominal k_co) + + -- k_co :: (t1 ~r t2) ~N (s1 ~r s2) + -- k1 = t1 ~r t2 + -- k2 = s1 ~r s2 + -- cv1 :: t1 ~r t2 + -- cv2 :: s1 ~r s2 + -- eta1 :: t1 ~r s1 + -- eta2 :: t2 ~r s2 + -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2 + + cv2 = setVarType cv1 (substTy subst k2) + n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) + subst' | isReflCo k_co = extendTCvInScope subst cv1 + | otherwise = extendCvSubst (extendTCvInScope subst cv2) + cv1 n_subst + + go_forall subst other_co + -- when other_co is not a ForAllCo + = substTy subst (go other_co) + +{- + +Note [Nested ForAllCos] +~~~~~~~~~~~~~~~~~~~~~~~ + +Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an +co)...) )`. We do not want to perform `n` single-type-variable +substitutions over the kind of `co`; rather we want to do one substitution +which substitutes for all of `a1`, `a2` ... simultaneously. If we do one +at a time we get the performance hole reported in #11735. + +Solution: gather up the type variables for nested `ForAllCos`, and +substitute for them all at once. Remarkably, for #11735 this single +change reduces /total/ compile time by a factor of more than ten. + +-} + +-- | Retrieve the role from a coercion. +coercionRole :: Coercion -> Role +coercionRole = go + where + go (Refl _) = Nominal + go (GRefl r _ _) = r + go (TyConAppCo r _ _) = r + go (AppCo co1 _) = go co1 + go (ForAllCo _ _ co) = go co + go (FunCo r _ _) = r + go (CoVarCo cv) = coVarRole cv + go (HoleCo h) = coVarRole (coHoleCoVar h) + go (AxiomInstCo ax _ _) = coAxiomRole ax + go (UnivCo _ r _ _) = r + go (SymCo co) = go co + go (TransCo co1 _co2) = go co1 + go (NthCo r _d _co) = r + go (LRCo {}) = Nominal + go (InstCo co _) = go co + go (KindCo {}) = Nominal + go (SubCo _) = Representational + go (AxiomRuleCo ax _) = coaxrRole ax + +{- +Note [Nested InstCos] +~~~~~~~~~~~~~~~~~~~~~ +In #5631 we found that 70% of the entire compilation time was +being spent in coercionKind! The reason was that we had + (g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos +where + g :: forall a1 a2 .. a100. phi +If we deal with the InstCos one at a time, we'll do this: + 1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi' + 2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst +But this is a *quadratic* algorithm, and the blew up #5631. +So it's very important to do the substitution simultaneously; +cf Type.piResultTys (which in fact we call here). + +-} + +-- | Makes a coercion type from two types: the types whose equality +-- is proven by the relevant 'Coercion' +mkCoercionType :: Role -> Type -> Type -> Type +mkCoercionType Nominal = mkPrimEqPred +mkCoercionType Representational = mkReprPrimEqPred +mkCoercionType Phantom = \ty1 ty2 -> + let ki1 = typeKind ty1 + ki2 = typeKind ty2 + in + TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] + +mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type +mkHeteroCoercionType Nominal = mkHeteroPrimEqPred +mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred +mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType" + +-- | Creates a primitive type equality predicate. +-- Invariant: the types are not Coercions +mkPrimEqPred :: Type -> Type -> Type +mkPrimEqPred ty1 ty2 + = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Makes a lifted equality predicate at the given role +mkPrimEqPredRole :: Role -> Type -> Type -> PredType +mkPrimEqPredRole Nominal = mkPrimEqPred +mkPrimEqPredRole Representational = mkReprPrimEqPred +mkPrimEqPredRole Phantom = panic "mkPrimEqPredRole phantom" + +-- | Creates a primitive type equality predicate with explicit kinds +mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type +mkHeteroPrimEqPred k1 k2 ty1 ty2 = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] + +-- | Creates a primitive representational type equality predicate +-- with explicit kinds +mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type +mkHeteroReprPrimEqPred k1 k2 ty1 ty2 + = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] + +mkReprPrimEqPred :: Type -> Type -> Type +mkReprPrimEqPred ty1 ty2 + = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Assuming that two types are the same, ignoring coercions, find +-- a nominal coercion between the types. This is useful when optimizing +-- transitivity over coercion applications, where splitting two +-- AppCos might yield different kinds. See Note [EtaAppCo] in +-- GHC.Core.Coercion.Opt. +buildCoercion :: Type -> Type -> CoercionN +buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 + where + go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 + | Just ty2' <- coreView ty2 = go ty1 ty2' + + go (CastTy ty1 co) ty2 + = let co' = go ty1 ty2 + r = coercionRole co' + in mkCoherenceLeftCo r ty1 co co' + + go ty1 (CastTy ty2 co) + = let co' = go ty1 ty2 + r = coercionRole co' + in mkCoherenceRightCo r ty2 co co' + + go ty1@(TyVarTy tv1) _tyvarty + = ASSERT( case _tyvarty of + { TyVarTy tv2 -> tv1 == tv2 + ; _ -> False } ) + mkNomReflCo ty1 + + go (FunTy { ft_arg = arg1, ft_res = res1 }) + (FunTy { ft_arg = arg2, ft_res = res2 }) + = mkFunCo Nominal (go arg1 arg2) (go res1 res2) + + go (TyConApp tc1 args1) (TyConApp tc2 args2) + = ASSERT( tc1 == tc2 ) + mkTyConAppCo Nominal tc1 (zipWith go args1 args2) + + go (AppTy ty1a ty1b) ty2 + | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 + = mkAppCo (go ty1a ty2a) (go ty1b ty2b) + + go ty1 (AppTy ty2a ty2b) + | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + = mkAppCo (go ty1a ty2a) (go ty1b ty2b) + + go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) + | isTyVar tv1 + = ASSERT( isTyVar tv2 ) + mkForAllCo tv1 kind_co (go ty1 ty2') + where kind_co = go (tyVarKind tv1) (tyVarKind tv2) + in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co + ty2' = substTyWithInScope in_scope [tv2] + [mkTyVarTy tv1 `mkCastTy` kind_co] + ty2 + + go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2) + = ASSERT( isCoVar cv1 && isCoVar cv2 ) + mkForAllCo cv1 kind_co (go ty1 ty2') + where s1 = varType cv1 + s2 = varType cv2 + kind_co = go s1 s2 + + -- s1 = t1 ~r t2 + -- s2 = t3 ~r t4 + -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4) + -- eta1 :: t1 ~r t3 + -- eta2 :: t2 ~r t4 + + r = coVarRole cv1 + kind_co' = downgradeRole r Nominal kind_co + eta1 = mkNthCo r 2 kind_co' + eta2 = mkNthCo r 3 kind_co' + + subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co + ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` + mkCoVarCo cv1 `mkTransCo` + eta2) + ty2 + + go ty1@(LitTy lit1) _lit2 + = ASSERT( case _lit2 of + { LitTy lit2 -> lit1 == lit2 + ; _ -> False } ) + mkNomReflCo ty1 + + go (CoercionTy co1) (CoercionTy co2) + = mkProofIrrelCo Nominal kind_co co1 co2 + where + kind_co = go (coercionType co1) (coercionType co2) + + go ty1 ty2 + = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2 + , ppr ty1, ppr ty2 ]) + +{- +%************************************************************************ +%* * + Simplifying types +%* * +%************************************************************************ + +The function below morally belongs in TcFlatten, but it is used also in +FamInstEnv, and so lives here. + +Note [simplifyArgsWorker] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant (F2) of Note [Flattening] says that flattening is homogeneous. +This causes some trouble when flattening a function applied to a telescope +of arguments, perhaps with dependency. For example, suppose + + type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k] + +and we wish to flatten the args of (with kind applications explicit) + + F a b (Just a c) (Right a b d) False + +where all variables are skolems and + + a :: Type + b :: Type + c :: a + d :: k + + [G] aco :: a ~ fa + [G] bco :: b ~ fb + [G] cco :: c ~ fc + [G] dco :: d ~ fd + +The first step is to flatten all the arguments. This is done before calling +simplifyArgsWorker. We start from + + a + b + Just a c + Right a b d + False + +and get + + (fa, co1 :: fa ~ a) + (fb, co2 :: fb ~ b) + (Just fa (fc |> aco) |> co6, co3 :: (Just fa (fc |> aco) |> co6) ~ (Just a c)) + (Right fa fb (fd |> bco) |> co7, co4 :: (Right fa fb (fd |> bco) |> co7) ~ (Right a b d)) + (False, co5 :: False ~ False) + +where + co6 :: Maybe fa ~ Maybe a + co7 :: Either fa fb ~ Either a b + +We now process the flattened args in left-to-right order. The first two args +need no further processing. But now consider the third argument. Let f3 = the flattened +result, Just fa (fc |> aco) |> co6. +This f3 flattened argument has kind (Maybe a), due to +(F2). And yet, when we build the application (F fa fb ...), we need this +argument to have kind (Maybe fa), not (Maybe a). We must cast this argument. +The coercion to use is +determined by the kind of F: we see in F's kind that the third argument has +kind Maybe j. Critically, we also know that the argument corresponding to j +(in our example, a) flattened with a coercion co1. We can thus know the +coercion needed for the 3rd argument is (Maybe (sym co1)), thus building +(f3 |> Maybe (sym co1)) + +More generally, we must use the Lifting Lemma, as implemented in +Coercion.liftCoSubst. As we work left-to-right, any variable that is a +dependent parameter (j and k, in our example) gets mapped in a lifting context +to the coercion that is output from flattening the corresponding argument (co1 +and co2, in our example). Then, after flattening later arguments, we lift the +kind of these arguments in the lifting context that we've be building up. +This coercion is then used to keep the result of flattening well-kinded. + +Working through our example, this is what happens: + + 1. Extend the (empty) LC with [j |-> co1]. No new casting must be done, + because the binder associated with the first argument has a closed type (no + variables). + + 2. Extend the LC with [k |-> co2]. No casting to do. + + 3. Lifting the kind (Maybe j) with our LC + yields co8 :: Maybe fa ~ Maybe a. Use (f3 |> sym co8) as the argument to + F. + + 4. Lifting the kind (Either j k) with our LC + yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym co9) as the 4th + argument to F, where f4 is the flattened form of argument 4, written above. + + 5. We lift Bool with our LC, getting <Bool>; + casting has no effect. + +We're now almost done, but the new application (F fa fb (f3 |> sym co8) (f4 > sym co9) False) +has the wrong kind. Its kind is [fb], instead of the original [b]. +So we must use our LC one last time to lift the result kind [k], +getting res_co :: [fb] ~ [b], and we cast our result. + +Accordingly, the final result is + + F fa fb (Just fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco))) + (Right fa fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco))) + False + |> [sym bco] + +The res_co (in this case, [sym bco]) +is returned as the third return value from simplifyArgsWorker. + +Note [Last case in simplifyArgsWorker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In writing simplifyArgsWorker's `go`, we know here that args cannot be empty, +because that case is first. We've run out of +binders. But perhaps inner_ki is a tyvar that has been instantiated with a +Π-type. + +Here is an example. + + a :: forall (k :: Type). k -> k + type family Star + Proxy :: forall j. j -> Type + axStar :: Star ~ Type + type family NoWay :: Bool + axNoWay :: NoWay ~ False + bo :: Type + [G] bc :: bo ~ Bool (in inert set) + + co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star) + co = forall (j :: sym axStar). (<j> -> sym axStar) + + We are flattening: + a (forall (j :: Star). (j |> axStar) -> Star) -- 1 + (Proxy |> co) -- 2 + (bo |> sym axStar) -- 3 + (NoWay |> sym bc) -- 4 + :: Star + +First, we flatten all the arguments (before simplifyArgsWorker), like so: + + (forall j. j -> Type, co1 :: (forall j. j -> Type) ~ + (forall (j :: Star). (j |> axStar) -> Star)) -- 1 + (Proxy |> co, co2 :: (Proxy |> co) ~ (Proxy |> co)) -- 2 + (Bool |> sym axStar, co3 :: (Bool |> sym axStar) ~ (bo |> sym axStar)) -- 3 + (False |> sym bc, co4 :: (False |> sym bc) ~ (NoWay |> sym bc)) -- 4 + +Then we do the process described in Note [simplifyArgsWorker]. + +1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we + don't use it. But we do build a lifting context [k -> co1] (where co1 is a + result of flattening an argument, written above). + +2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1). + This is not a dependent argument, so we don't extend the lifting context. + +Now we need to deal with argument (3). +The way we normally proceed is to lift the kind of the binder, to see whether +it's dependent. +But here, the remainder of the kind of `a` that we're left with +after processing two arguments is just `k`. + +The way forward is look up k in the lifting context, getting co1. If we're at +all well-typed, co1 will be a coercion between Π-types, with at least one binder. +So, let's +decompose co1 with decomposePiCos. This decomposition needs arguments to use +to instantiate any kind parameters. Look at the type of co1. If we just +decomposed it, we would end up with coercions whose types include j, which is +out of scope here. Accordingly, decomposePiCos takes a list of types whose +kinds are the *right-hand* types in the decomposed coercion. (See comments on +decomposePiCos.) Because the flattened types have unflattened kinds (because +flattening is homogeneous), passing the list of flattened types to decomposePiCos +just won't do: later arguments' kinds won't be as expected. So we need to get +the *unflattened* types to pass to decomposePiCos. We can do this easily enough +by taking the kind of the argument coercions, passed in originally. + +(Alternative 1: We could re-engineer decomposePiCos to deal with this situation. +But that function is already gnarly, and taking the right-hand types is correct +at its other call sites, which are much more common than this one.) + +(Alternative 2: We could avoid calling decomposePiCos entirely, integrating its +behavior into simplifyArgsWorker. This would work, I think, but then all of the +complication of decomposePiCos would end up layered on top of all the complication +here. Please, no.) + +(Alternative 3: We could pass the unflattened arguments into simplifyArgsWorker +so that we don't have to recreate them. But that would complicate the interface +of this function to handle a very dark, dark corner case. Better to keep our +demons to ourselves here instead of exposing them to callers. This decision is +easily reversed if there is ever any performance trouble due to the call of +coercionKind.) + +So we now call + + decomposePiCos co1 + (Pair (forall j. j -> Type) (forall (j :: Star). (j |> axStar) -> Star)) + [bo |> sym axStar, NoWay |> sym bc] + +to get + + co5 :: Star ~ Type + co6 :: (j |> axStar) ~ (j |> co5), substituted to + (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co5) + == bo ~ bo + res_co :: Type ~ Star + +We then use these casts on (the flattened) (3) and (4) to get + + (Bool |> sym axStar |> co5 :: Type) -- (C3) + (False |> sym bc |> co6 :: bo) -- (C4) + +We can simplify to + + Bool -- (C3) + (False |> sym bc :: bo) -- (C4) + +Of course, we still must do the processing in Note [simplifyArgsWorker] to finish +the job. We thus want to recur. Our new function kind is the left-hand type of +co1 (gotten, recall, by lifting the variable k that was the return kind of the +original function). Why the left-hand type (as opposed to the right-hand type)? +Because we have casted all the arguments according to decomposePiCos, which gets +us from the right-hand type to the left-hand one. We thus recur with that new +function kind, zapping our lifting context, because we have essentially applied +it. + +This recursive call returns ([Bool, False], [...], Refl). The Bool and False +are the correct arguments we wish to return. But we must be careful about the +result coercion: our new, flattened application will have kind Type, but we +want to make sure that the result coercion casts this back to Star. (Why? +Because we started with an application of kind Star, and flattening is homogeneous.) + +So, we have to twiddle the result coercion appropriately. + +Let's check whether this is well-typed. We know + + a :: forall (k :: Type). k -> k + + a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type + + a (forall j. j -> Type) + Proxy + :: forall j. j -> Type + + a (forall j. j -> Type) + Proxy + Bool + :: Bool -> Type + + a (forall j. j -> Type) + Proxy + Bool + False + :: Type + + a (forall j. j -> Type) + Proxy + Bool + False + |> res_co + :: Star + +as desired. + +Whew. + +Historical note: I (Richard E) once thought that the final part of the kind +had to be a variable k (as in the example above). But it might not be: it could +be an application of a variable. Here is the example: + + let f :: forall (a :: Type) (b :: a -> Type). b (Any @a) + k :: Type + x :: k + + flatten (f @Type @((->) k) x) + +After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)` +is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded. + +-} + + +-- This is shared between the flattener and the normaliser in GHC.Core.FamInstEnv. +-- See Note [simplifyArgsWorker] +{-# INLINE simplifyArgsWorker #-} +simplifyArgsWorker :: [TyCoBinder] -> Kind + -- the binders & result kind (not a Π-type) of the function applied to the args + -- list of binders can be shorter or longer than the list of args + -> TyCoVarSet -- free vars of the args + -> [Role] -- list of roles, r + -> [(Type, Coercion)] -- flattened type arguments, arg + -- each comes with the coercion used to flatten it, + -- with co :: flattened_type ~ original_type + -> ([Type], [Coercion], CoercionN) +-- Returns (xis, cos, res_co), where each co :: xi ~ arg, +-- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args +-- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in), +-- then (f orig_tys) is well kinded. Note that (f flattened_tys) might *not* be well-kinded. +-- Massaging the flattened_tys in order to make (f flattened_tys) well-kinded is what this +-- function is all about. That is, (f xis), where xis are the returned arguments, *is* +-- well kinded. +simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs + orig_roles orig_simplified_args + = go [] [] orig_lc orig_ki_binders orig_inner_ki orig_roles orig_simplified_args + where + orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs + + go :: [Type] -- Xis accumulator, in reverse order + -> [Coercion] -- Coercions accumulator, in reverse order + -- These are in 1-to-1 correspondence + -> LiftingContext -- mapping from tyvars to flattening coercions + -> [TyCoBinder] -- Unsubsted binders of function's kind + -> Kind -- Unsubsted result kind of function (not a Pi-type) + -> [Role] -- Roles at which to flatten these ... + -> [(Type, Coercion)] -- flattened arguments, with their flattening coercions + -> ([Type], [Coercion], CoercionN) + go acc_xis acc_cos lc binders inner_ki _ [] + = (reverse acc_xis, reverse acc_cos, kind_co) + where + final_kind = mkPiTys binders inner_ki + kind_co = liftCoSubst Nominal lc final_kind + + go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args) + = -- By Note [Flattening] in TcFlatten invariant (F2), + -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be + -- used as an argument to a function whose kind is different, if + -- earlier arguments have been flattened to new types. We thus + -- need a coercion (kind_co :: old_kind ~ new_kind). + -- + -- The bangs here have been observed to improve performance + -- significantly in optimized builds. + let kind_co = mkSymCo $ + liftCoSubst Nominal lc (tyCoBinderType binder) + !casted_xi = xi `mkCastTy` kind_co + casted_co = mkCoherenceLeftCo role xi kind_co co + + -- now, extend the lifting context with the new binding + !new_lc | Just tv <- tyCoBinderVar_maybe binder + = extendLiftingContextAndInScope lc tv casted_co + | otherwise + = lc + in + go (casted_xi : acc_xis) + (casted_co : acc_cos) + new_lc + binders + inner_ki + roles + args + + + -- See Note [Last case in simplifyArgsWorker] + go acc_xis acc_cos lc [] inner_ki roles args + = let co1 = liftCoSubst Nominal lc inner_ki + co1_kind = coercionKind co1 + unflattened_tys = map (coercionRKind . snd) args + (arg_cos, res_co) = decomposePiCos co1 co1_kind unflattened_tys + casted_args = ASSERT2( equalLength args arg_cos + , ppr args $$ ppr arg_cos ) + [ (casted_xi, casted_co) + | ((xi, co), arg_co, role) <- zip3 args arg_cos roles + , let casted_xi = xi `mkCastTy` arg_co + casted_co = mkCoherenceLeftCo role xi arg_co co ] + -- In general decomposePiCos can return fewer cos than tys, + -- but not here; because we're well typed, there will be enough + -- binders. Note that decomposePiCos does substitutions, so even + -- if the original substitution results in something ending with + -- ... -> k, that k will be substituted to perhaps reveal more + -- binders. + zapped_lc = zapLiftingContext lc + Pair flattened_kind _ = co1_kind + (bndrs, new_inner) = splitPiTys flattened_kind + + (xis_out, cos_out, res_co_out) + = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args + in + (xis_out, cos_out, res_co_out `mkTransCo` res_co) + + go _ _ _ _ _ _ _ = panic + "simplifyArgsWorker wandered into deeper water than usual" + -- This debug information is commented out because leaving it in + -- causes a ~2% increase in allocations in T9872d. + -- That's independent of the analogous case in flatten_args_fast + -- in TcFlatten: + -- each of these causes a 2% increase on its own, so commenting them + -- both out gives a 4% decrease in T9872d. + {- + + (vcat [ppr orig_binders, + ppr orig_inner_ki, + ppr (take 10 orig_roles), -- often infinite! + ppr orig_tys]) + -} diff --git a/compiler/GHC/Core/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot new file mode 100644 index 0000000000..8354cf1ad4 --- /dev/null +++ b/compiler/GHC/Core/Coercion.hs-boot @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Core.Coercion where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep +import {-# SOURCE #-} GHC.Core.TyCon + +import BasicTypes ( LeftOrRight ) +import GHC.Core.Coercion.Axiom +import Var +import Pair +import Util + +mkReflCo :: Role -> Type -> Coercion +mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion +mkAppCo :: Coercion -> Coercion -> Coercion +mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion +mkFunCo :: Role -> Coercion -> Coercion -> Coercion +mkCoVarCo :: CoVar -> Coercion +mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion +mkSymCo :: Coercion -> Coercion +mkTransCo :: Coercion -> Coercion -> Coercion +mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkInstCo :: Coercion -> Coercion -> Coercion +mkGReflCo :: Role -> Type -> MCoercionN -> Coercion +mkNomReflCo :: Type -> Coercion +mkKindCo :: Coercion -> Coercion +mkSubCo :: Coercion -> Coercion +mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion +mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion + +isGReflCo :: Coercion -> Bool +isReflCo :: Coercion -> Bool +isReflexiveCo :: Coercion -> Bool +decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion) +coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role) +coVarRole :: CoVar -> Role + +mkCoercionType :: Role -> Type -> Type -> Type + +data LiftingContext +liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion +seqCo :: Coercion -> () + +coercionKind :: Coercion -> Pair Type +coercionLKind :: Coercion -> Type +coercionRKind :: Coercion -> Type +coercionType :: Coercion -> Type diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs new file mode 100644 index 0000000000..c6861d8590 --- /dev/null +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -0,0 +1,565 @@ +-- (c) The University of Glasgow 2012 + +{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures, + ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-} + +-- | Module for coercion axioms, used to represent type family instances +-- and newtypes + +module GHC.Core.Coercion.Axiom ( + BranchFlag, Branched, Unbranched, BranchIndex, Branches(..), + manyBranches, unbranched, + fromBranches, numBranches, + mapAccumBranches, + + CoAxiom(..), CoAxBranch(..), + + toBranchedAxiom, toUnbranchedAxiom, + coAxiomName, coAxiomArity, coAxiomBranches, + coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, + coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, + coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars, + coAxBranchRoles, + coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, + placeHolderIncomps, + + Role(..), fsFromRole, + + CoAxiomRule(..), TypeEqn, + BuiltInSynFamily(..) + ) where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import Outputable +import FastString +import Name +import Unique +import Var +import Util +import Binary +import Pair +import BasicTypes +import Data.Typeable ( Typeable ) +import SrcLoc +import qualified Data.Data as Data +import Data.Array +import Data.List ( mapAccumL ) + +#include "HsVersions.h" + +{- +Note [Coercion axiom branches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In order to allow closed type families, an axiom needs to contain an +ordered list of alternatives, called branches. The kind of the coercion built +from an axiom is determined by which index is used when building the coercion +from the axiom. + +For example, consider the axiom derived from the following declaration: + +type family F a where + F [Int] = Bool + F [a] = Double + F (a b) = Char + +This will give rise to this axiom: + +axF :: { F [Int] ~ Bool + ; forall (a :: *). F [a] ~ Double + ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char + } + +The axiom is used with the AxiomInstCo constructor of Coercion. If we wish +to have a coercion showing that F (Maybe Int) ~ Char, it will look like + +axF[2] <*> <Maybe> <Int> :: F (Maybe Int) ~ Char +-- or, written using concrete-ish syntax -- +AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int] + +Note that the index is 0-based. + +For type-checking, it is also necessary to check that no previous pattern +can unify with the supplied arguments. After all, it is possible that some +of the type arguments are lambda-bound type variables whose instantiation may +cause an earlier match among the branches. We wish to prohibit this behavior, +so the type checker rules out the choice of a branch where a previous branch +can unify. See also [Apartness] in GHC.Core.FamInstEnv. + +For example, the following is malformed, where 'a' is a lambda-bound type +variable: + +axF[2] <*> <a> <Bool> :: F (a Bool) ~ Char + +Why? Because a might be instantiated with [], meaning that branch 1 should +apply, not branch 2. This is a vital consistency check; without it, we could +derive Int ~ Bool, and that is a Bad Thing. + +Note [Branched axioms] +~~~~~~~~~~~~~~~~~~~~~~ +Although a CoAxiom has the capacity to store many branches, in certain cases, +we want only one. These cases are in data/newtype family instances, newtype +coercions, and type family instances. +Furthermore, these unbranched axioms are used in a +variety of places throughout GHC, and it would difficult to generalize all of +that code to deal with branched axioms, especially when the code can be sure +of the fact that an axiom is indeed a singleton. At the same time, it seems +dangerous to assume singlehood in various places through GHC. + +The solution to this is to label a CoAxiom with a phantom type variable +declaring whether it is known to be a singleton or not. The branches +are stored using a special datatype, declared below, that ensures that the +type variable is accurate. + +************************************************************************ +* * + Branches +* * +************************************************************************ +-} + +type BranchIndex = Int -- The index of the branch in the list of branches + -- Counting from zero + +-- promoted data type +data BranchFlag = Branched | Unbranched +type Branched = 'Branched +type Unbranched = 'Unbranched +-- By using type synonyms for the promoted constructors, we avoid needing +-- DataKinds and the promotion quote in client modules. This also means that +-- we don't need to export the term-level constructors, which should never be used. + +newtype Branches (br :: BranchFlag) + = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch } +type role Branches nominal + +manyBranches :: [CoAxBranch] -> Branches Branched +manyBranches brs = ASSERT( snd bnds >= fst bnds ) + MkBranches (listArray bnds brs) + where + bnds = (0, length brs - 1) + +unbranched :: CoAxBranch -> Branches Unbranched +unbranched br = MkBranches (listArray (0, 0) [br]) + +toBranched :: Branches br -> Branches Branched +toBranched = MkBranches . unMkBranches + +toUnbranched :: Branches br -> Branches Unbranched +toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) ) + MkBranches arr + +fromBranches :: Branches br -> [CoAxBranch] +fromBranches = elems . unMkBranches + +branchesNth :: Branches br -> BranchIndex -> CoAxBranch +branchesNth (MkBranches arr) n = arr ! n + +numBranches :: Branches br -> Int +numBranches (MkBranches arr) = snd (bounds arr) + 1 + +-- | The @[CoAxBranch]@ passed into the mapping function is a list of +-- all previous branches, reversed +mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch) + -> Branches br -> Branches br +mapAccumBranches f (MkBranches arr) + = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr))) + where + go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) + go prev_branches cur_branch = ( cur_branch : prev_branches + , f prev_branches cur_branch ) + + +{- +************************************************************************ +* * + Coercion axioms +* * +************************************************************************ + +Note [Storing compatibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During axiom application, we need to be aware of which branches are compatible +with which others. The full explanation is in Note [Compatibility] in +FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on +the unification algorithm.) Although we could theoretically compute +compatibility on the fly, this is silly, so we store it in a CoAxiom. + +Specifically, each branch refers to all other branches with which it is +incompatible. This list might well be empty, and it will always be for the +first branch of any axiom. + +CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk +stored in cab_incomps. The incompatibilities are properly a property of the +axiom as a whole, and they are computed only when the final axiom is built. + +During serialization, the list is converted into a list of the indices +of the branches. +-} + +-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data CoAxiom br + = CoAxiom -- Type equality axiom. + { co_ax_unique :: Unique -- Unique identifier + , co_ax_name :: Name -- Name for pretty-printing + , co_ax_role :: Role -- Role of the axiom's equality + , co_ax_tc :: TyCon -- The head of the LHS patterns + -- e.g. the newtype or family tycon + , co_ax_branches :: Branches br -- The branches that form this axiom + , co_ax_implicit :: Bool -- True <=> the axiom is "implicit" + -- See Note [Implicit axioms] + -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. + } + +data CoAxBranch + = CoAxBranch + { cab_loc :: SrcSpan -- Location of the defining equation + -- See Note [CoAxiom locations] + , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh + , cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars + -- See Note [CoAxBranch type variables] + -- cab_tvs and cab_lhs may be eta-reduded; see + -- Note [Eta reduction for data families] + , cab_cvs :: [CoVar] -- Bound coercion variables + -- Always empty, for now. + -- See Note [Constraints in patterns] + -- in TcTyClsDecls + , cab_roles :: [Role] -- See Note [CoAxBranch roles] + , cab_lhs :: [Type] -- Type patterns to match against + , cab_rhs :: Type -- Right-hand side of the equality + , cab_incomps :: [CoAxBranch] -- The previous incompatible branches + -- See Note [Storing compatibility] + } + deriving Data.Data + +toBranchedAxiom :: CoAxiom br -> CoAxiom Branched +toBranchedAxiom (CoAxiom unique name role tc branches implicit) + = CoAxiom unique name role tc (toBranched branches) implicit + +toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched +toUnbranchedAxiom (CoAxiom unique name role tc branches implicit) + = CoAxiom unique name role tc (toUnbranched branches) implicit + +coAxiomNumPats :: CoAxiom br -> Int +coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) + +coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch +coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index + = branchesNth bs index + +coAxiomArity :: CoAxiom br -> BranchIndex -> Arity +coAxiomArity ax index + = length tvs + length cvs + where + CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index + +coAxiomName :: CoAxiom br -> Name +coAxiomName = co_ax_name + +coAxiomRole :: CoAxiom br -> Role +coAxiomRole = co_ax_role + +coAxiomBranches :: CoAxiom br -> Branches br +coAxiomBranches = co_ax_branches + +coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch +coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr }) + | snd (bounds arr) == 0 + = Just $ arr ! 0 + | otherwise + = Nothing + +coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch +coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr }) + = arr ! 0 + +coAxiomTyCon :: CoAxiom br -> TyCon +coAxiomTyCon = co_ax_tc + +coAxBranchTyVars :: CoAxBranch -> [TyVar] +coAxBranchTyVars = cab_tvs + +coAxBranchCoVars :: CoAxBranch -> [CoVar] +coAxBranchCoVars = cab_cvs + +coAxBranchLHS :: CoAxBranch -> [Type] +coAxBranchLHS = cab_lhs + +coAxBranchRHS :: CoAxBranch -> Type +coAxBranchRHS = cab_rhs + +coAxBranchRoles :: CoAxBranch -> [Role] +coAxBranchRoles = cab_roles + +coAxBranchSpan :: CoAxBranch -> SrcSpan +coAxBranchSpan = cab_loc + +isImplicitCoAxiom :: CoAxiom br -> Bool +isImplicitCoAxiom = co_ax_implicit + +coAxBranchIncomps :: CoAxBranch -> [CoAxBranch] +coAxBranchIncomps = cab_incomps + +-- See Note [Compatibility checking] in GHC.Core.FamInstEnv +placeHolderIncomps :: [CoAxBranch] +placeHolderIncomps = panic "placeHolderIncomps" + +{- +Note [CoAxBranch type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of a CoAxBranch of an associated type-family instance, +we use the *same* type variables (where possible) as the +enclosing class or instance. Consider + + instance C Int [z] where + type F Int [z] = ... -- Second param must be [z] + +In the CoAxBranch in the instance decl (F Int [z]) we use the +same 'z', so that it's easy to check that that type is the same +as that in the instance header. + +So, unlike FamInsts, there is no expectation that the cab_tvs +are fresh wrt each other, or any other CoAxBranch. + +Note [CoAxBranch roles] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code: + + newtype Age = MkAge Int + newtype Wrap a = MkWrap a + + convert :: Wrap Age -> Int + convert (MkWrap (MkAge i)) = i + +We want this to compile to: + + NTCo:Wrap :: forall a. Wrap a ~R a + NTCo:Age :: Age ~R Int + convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0]) + +But, note that NTCo:Age is at role R. Thus, we need to be able to pass +coercions at role R into axioms. However, we don't *always* want to be able to +do this, as it would be disastrous with type families. The solution is to +annotate the arguments to the axiom with roles, much like we annotate tycon +tyvars. Where do these roles get set? Newtype axioms inherit their roles from +the newtype tycon; family axioms are all at role N. + +Note [CoAxiom locations] +~~~~~~~~~~~~~~~~~~~~~~~~ +The source location of a CoAxiom is stored in two places in the +datatype tree. + * The first is in the location info buried in the Name of the + CoAxiom. This span includes all of the branches of a branched + CoAxiom. + * The second is in the cab_loc fields of the CoAxBranches. + +In the case of a single branch, we can extract the source location of +the branch from the name of the CoAxiom. In other cases, we need an +explicit SrcSpan to correctly store the location of the equation +giving rise to the FamInstBranch. + +Note [Implicit axioms] +~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Implicit TyThings] in GHC.Driver.Types +* A CoAxiom arising from data/type family instances is not "implicit". + That is, it has its own IfaceAxiom declaration in an interface file + +* The CoAxiom arising from a newtype declaration *is* "implicit". + That is, it does not have its own IfaceAxiom declaration in an + interface file; instead the CoAxiom is generated by type-checking + the newtype declaration + +Note [Eta reduction for data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + data family T a b :: * + newtype instance T Int a = MkT (IO a) deriving( Monad ) +We'd like this to work. + +From the 'newtype instance' you might think we'd get: + newtype TInt a = MkT (IO a) + axiom ax1 a :: T Int a ~ TInt a -- The newtype-instance part + axiom ax2 a :: TInt a ~ IO a -- The newtype part + +But now what can we do? We have this problem + Given: d :: Monad IO + Wanted: d' :: Monad (T Int) = d |> ???? +What coercion can we use for the ??? + +Solution: eta-reduce both axioms, thus: + axiom ax1 :: T Int ~ TInt + axiom ax2 :: TInt ~ IO +Now + d' = d |> Monad (sym (ax2 ; ax1)) + +----- Bottom line ------ + +For a CoAxBranch for a data family instance with representation +TyCon rep_tc: + + - cab_tvs (of its CoAxiom) may be shorter + than tyConTyVars of rep_tc. + + - cab_lhs may be shorter than tyConArity of the family tycon + i.e. LHS is unsaturated + + - cab_rhs will be (rep_tc cab_tvs) + i.e. RHS is un-saturated + + - This eta reduction happens for data instances as well + as newtype instances. Here we want to eta-reduce the data family axiom. + + - This eta-reduction is done in TcInstDcls.tcDataFamInstDecl. + +But for a /type/ family + - cab_lhs has the exact arity of the family tycon + +There are certain situations (e.g., pretty-printing) where it is necessary to +deal with eta-expanded data family instances. For these situations, the +cab_eta_tvs field records the stuff that has been eta-reduced away. +So if we have + axiom forall a b. F [a->b] = D b a +and cab_eta_tvs is [p,q], then the original user-written definition +looked like + axiom forall a b p q. F [a->b] p q = D b a p q +(See #9692, #14179, and #15845 for examples of what can go wrong if +we don't eta-expand when showing things to the user.) + +(See also Note [Newtype eta] in GHC.Core.TyCon. This is notionally separate +and deals with the axiom connecting a newtype with its representation +type; but it too is eta-reduced.) +-} + +instance Eq (CoAxiom br) where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable (CoAxiom br) where + getUnique = co_ax_unique + +instance Outputable (CoAxiom br) where + ppr = ppr . getName + +instance NamedThing (CoAxiom br) where + getName = co_ax_name + +instance Typeable br => Data.Data (CoAxiom br) where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiom" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiom" + +instance Outputable CoAxBranch where + ppr (CoAxBranch { cab_loc = loc + , cab_lhs = lhs + , cab_rhs = rhs }) = + text "CoAxBranch" <+> parens (ppr loc) <> colon + <+> brackets (fsep (punctuate comma (map pprType lhs))) + <+> text "=>" <+> pprType rhs + +{- +************************************************************************ +* * + Roles +* * +************************************************************************ + +Roles are defined here to avoid circular dependencies. +-} + +-- See Note [Roles] in GHC.Core.Coercion +-- defined here to avoid cyclic dependency with GHC.Core.Coercion +-- +-- Order of constructors matters: the Ord instance coincides with the *super*typing +-- relation on roles. +data Role = Nominal | Representational | Phantom + deriving (Eq, Ord, Data.Data) + +-- These names are slurped into the parser code. Changing these strings +-- will change the **surface syntax** that GHC accepts! If you want to +-- change only the pretty-printing, do some replumbing. See +-- mkRoleAnnotDecl in RdrHsSyn +fsFromRole :: Role -> FastString +fsFromRole Nominal = fsLit "nominal" +fsFromRole Representational = fsLit "representational" +fsFromRole Phantom = fsLit "phantom" + +instance Outputable Role where + ppr = ftext . fsFromRole + +instance Binary Role where + put_ bh Nominal = putByte bh 1 + put_ bh Representational = putByte bh 2 + put_ bh Phantom = putByte bh 3 + + get bh = do tag <- getByte bh + case tag of 1 -> return Nominal + 2 -> return Representational + 3 -> return Phantom + _ -> panic ("get Role " ++ show tag) + +{- +************************************************************************ +* * + CoAxiomRule + Rules for building Evidence +* * +************************************************************************ + +Conditional axioms. The general idea is that a `CoAxiomRule` looks like this: + + forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2 + +My intention is to reuse these for both (~) and (~#). +The short-term plan is to use this datatype to represent the type-nat axioms. +In the longer run, it may be good to unify this and `CoAxiom`, +as `CoAxiom` is the special case when there are no assumptions. +-} + +-- | A more explicit representation for `t1 ~ t2`. +type TypeEqn = Pair Type + +-- | For now, we work only with nominal equality. +data CoAxiomRule = CoAxiomRule + { coaxrName :: FastString + , coaxrAsmpRoles :: [Role] -- roles of parameter equations + , coaxrRole :: Role -- role of resulting equation + , coaxrProves :: [TypeEqn] -> Maybe TypeEqn + -- ^ coaxrProves returns @Nothing@ when it doesn't like + -- the supplied arguments. When this happens in a coercion + -- that means that the coercion is ill-formed, and Core Lint + -- checks for that. + } + +instance Data.Data CoAxiomRule where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiomRule" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiomRule" + +instance Uniquable CoAxiomRule where + getUnique = getUnique . coaxrName + +instance Eq CoAxiomRule where + x == y = coaxrName x == coaxrName y + +instance Ord CoAxiomRule where + compare x y = compare (coaxrName x) (coaxrName y) + +instance Outputable CoAxiomRule where + ppr = ppr . coaxrName + + +-- Type checking of built-in families +data BuiltInSynFamily = BuiltInSynFamily + { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) + , sfInteractTop :: [Type] -> Type -> [TypeEqn] + , sfInteractInert :: [Type] -> Type -> + [Type] -> Type -> [TypeEqn] + } diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs new file mode 100644 index 0000000000..685d3a278c --- /dev/null +++ b/compiler/GHC/Core/Coercion/Opt.hs @@ -0,0 +1,1206 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP #-} + +module GHC.Core.Coercion.Opt ( optCoercion, checkAxInstCo ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Driver.Session +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst +import GHC.Core.Coercion +import GHC.Core.Type as Type hiding( substTyVarBndr, substTy ) +import TcType ( exactTyCoVarsOfType ) +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import VarSet +import VarEnv +import Outputable +import GHC.Core.FamInstEnv ( flattenTys ) +import Pair +import ListSetOps ( getNth ) +import Util +import GHC.Core.Unify +import GHC.Core.InstEnv +import Control.Monad ( zipWithM ) + +{- +%************************************************************************ +%* * + Optimising coercions +%* * +%************************************************************************ + +Note [Optimising coercion optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Looking up a coercion's role or kind is linear in the size of the +coercion. Thus, doing this repeatedly during the recursive descent +of coercion optimisation is disastrous. We must be careful to avoid +doing this if at all possible. + +Because it is generally easy to know a coercion's components' roles +from the role of the outer coercion, we pass down the known role of +the input in the algorithm below. We also keep functions opt_co2 +and opt_co3 separate from opt_co4, so that the former two do Phantom +checks that opt_co4 can avoid. This is a big win because Phantom coercions +rarely appear within non-phantom coercions -- only in some TyConAppCos +and some AxiomInstCos. We handle these cases specially by calling +opt_co2. + +Note [Optimising InstCo] +~~~~~~~~~~~~~~~~~~~~~~~~ +(1) tv is a type variable +When we have (InstCo (ForAllCo tv h g) g2), we want to optimise. + +Let's look at the typing rules. + +h : k1 ~ k2 +tv:k1 |- g : t1 ~ t2 +----------------------------- +ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h]) + +g1 : (all tv:k1.t1') ~ (all tv:k2.t2') +g2 : s1 ~ s2 +-------------------- +InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] + +We thus want some coercion proving this: + + (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h]) + +If we substitute the *type* tv for the *coercion* +(g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly. +This is bizarre, +though, because we're substituting a type variable with a coercion. However, +this operation already exists: it's called *lifting*, and defined in GHC.Core.Coercion. +We just need to enhance the lifting operation to be able to deal with +an ambient substitution, which is why a LiftingContext stores a TCvSubst. + +(2) cv is a coercion variable +Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise. + +h : (t1 ~r t2) ~N (t3 ~r t4) +cv : t1 ~r t2 |- g : t1' ~r2 t2' +n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3 +n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4 +------------------------------------------------ +ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2 + (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2]) + +g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2') +g2 : h1 ~N h2 +h1 : t1 ~r t2 +h2 : t3 ~r t4 +------------------------------------------------ +InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2] + +We thus want some coercion proving this: + + t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2] + +So we substitute the coercion variable c for the coercion +(h1 ~N (n1; h2; sym n2)) in g. +-} + +optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo +-- ^ optCoercion applies a substitution to a coercion, +-- *and* optimises it to reduce its size +optCoercion dflags env co + | hasNoOptCoercion dflags = substCo env co + | otherwise = optCoercion' env co + +optCoercion' :: TCvSubst -> Coercion -> NormalCo +optCoercion' env co + | debugIsOn + = let out_co = opt_co1 lc False co + (Pair in_ty1 in_ty2, in_role) = coercionKindRole co + (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co + in + ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 && + substTyUnchecked env in_ty2 `eqType` out_ty2 && + in_role == out_role + , text "optCoercion changed types!" + $$ hang (text "in_co:") 2 (ppr co) + $$ hang (text "in_ty1:") 2 (ppr in_ty1) + $$ hang (text "in_ty2:") 2 (ppr in_ty2) + $$ hang (text "out_co:") 2 (ppr out_co) + $$ hang (text "out_ty1:") 2 (ppr out_ty1) + $$ hang (text "out_ty2:") 2 (ppr out_ty2) + $$ hang (text "subst:") 2 (ppr env) ) + out_co + + | otherwise = opt_co1 lc False co + where + lc = mkSubstLiftingContext env + +type NormalCo = Coercion + -- Invariants: + -- * The substitution has been fully applied + -- * For trans coercions (co1 `trans` co2) + -- co1 is not a trans, and neither co1 nor co2 is identity + +type NormalNonIdCo = NormalCo -- Extra invariant: not the identity + +-- | Do we apply a @sym@ to the result? +type SymFlag = Bool + +-- | Do we force the result to be representational? +type ReprFlag = Bool + +-- | Optimize a coercion, making no assumptions. All coercions in +-- the lifting context are already optimized (and sym'd if nec'y) +opt_co1 :: LiftingContext + -> SymFlag + -> Coercion -> NormalCo +opt_co1 env sym co = opt_co2 env sym (coercionRole co) co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's role. No other assumptions. +opt_co2 :: LiftingContext + -> SymFlag + -> Role -- ^ The role of the input coercion + -> Coercion -> NormalCo +opt_co2 env sym Phantom co = opt_phantom env sym co +opt_co2 env sym r co = opt_co3 env sym Nothing r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's non-Phantom role. +opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo +opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co +opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True r co + -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore +opt_co3 env sym _ r co = opt_co4_wrap env sym False r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a non-phantom coercion. +opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo + +opt_co4_wrap = opt_co4 +{- +opt_co4_wrap env sym rep r co + = pprTrace "opt_co4_wrap {" + ( vcat [ text "Sym:" <+> ppr sym + , text "Rep:" <+> ppr rep + , text "Role:" <+> ppr r + , text "Co:" <+> ppr co ]) $ + ASSERT( r == coercionRole co ) + let result = opt_co4 env sym rep r co in + pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ + result +-} + +opt_co4 env _ rep r (Refl ty) + = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr Nominal $$ + text "Type:" <+> ppr ty ) + liftCoSubst (chooseRole rep r) env ty + +opt_co4 env _ rep r (GRefl _r ty MRefl) + = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr ty ) + liftCoSubst (chooseRole rep r) env ty + +opt_co4 env sym rep r (GRefl _r ty (MCo co)) + = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr ty ) + if isGReflCo co || isGReflCo co' + then liftCoSubst r' env ty + else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty) + where + r' = chooseRole rep r + ty' = substTy (lcSubstLeft env) ty + co' = opt_co4 env False False Nominal co + +opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co + -- surprisingly, we don't have to do anything to the env here. This is + -- because any "lifting" substitutions in the env are tied to ForAllCos, + -- which treat their left and right sides differently. We don't want to + -- exchange them. + +opt_co4 env sym rep r g@(TyConAppCo _r tc cos) + = ASSERT( r == _r ) + case (rep, r) of + (True, Nominal) -> + mkTyConAppCo Representational tc + (zipWith3 (opt_co3 env sym) + (map Just (tyConRolesRepresentational tc)) + (repeat Nominal) + cos) + (False, Nominal) -> + mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos) + (_, Representational) -> + -- must use opt_co2 here, because some roles may be P + -- See Note [Optimising coercion optimisation] + mkTyConAppCo r tc (zipWith (opt_co2 env sym) + (tyConRolesRepresentational tc) -- the current roles + cos) + (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) + +opt_co4 env sym rep r (AppCo co1 co2) + = mkAppCo (opt_co4_wrap env sym rep r co1) + (opt_co4_wrap env sym False Nominal co2) + +opt_co4 env sym rep r (ForAllCo tv k_co co) + = case optForAllCoBndr env sym tv k_co of + (env', tv', k_co') -> mkForAllCo tv' k_co' $ + opt_co4_wrap env' sym rep r co + -- Use the "mk" functions to check for nested Refls + +opt_co4 env sym rep r (FunCo _r co1 co2) + = ASSERT( r == _r ) + if rep + then mkFunCo Representational co1' co2' + else mkFunCo r co1' co2' + where + co1' = opt_co4_wrap env sym rep r co1 + co2' = opt_co4_wrap env sym rep r co2 + +opt_co4 env sym rep r (CoVarCo cv) + | Just co <- lookupCoVar (lcTCvSubst env) cv + = opt_co4_wrap (zapLiftingContext env) sym rep r co + + | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] + = mkReflCo (chooseRole rep r) ty1 + + | otherwise + = ASSERT( isCoVar cv1 ) + wrapRole rep r $ wrapSym sym $ + CoVarCo cv1 + + where + Pair ty1 ty2 = coVarTypes cv1 + + cv1 = case lookupInScope (lcInScopeSet env) cv of + Just cv1 -> cv1 + Nothing -> WARN( True, text "opt_co: not in scope:" + <+> ppr cv $$ ppr env) + cv + -- cv1 might have a substituted kind! + +opt_co4 _ _ _ _ (HoleCo h) + = pprPanic "opt_univ fell into a hole" (ppr h) + +opt_co4 env sym rep r (AxiomInstCo con ind cos) + -- Do *not* push sym inside top-level axioms + -- e.g. if g is a top-level axiom + -- g a : f a ~ a + -- then (sym (g ty)) /= g (sym ty) !! + = ASSERT( r == coAxiomRole con ) + wrapRole rep (coAxiomRole con) $ + wrapSym sym $ + -- some sub-cos might be P: use opt_co2 + -- See Note [Optimising coercion optimisation] + AxiomInstCo con ind (zipWith (opt_co2 env False) + (coAxBranchRoles (coAxiomNthBranch con ind)) + cos) + -- Note that the_co does *not* have sym pushed into it + +opt_co4 env sym rep r (UnivCo prov _r t1 t2) + = ASSERT( r == _r ) + opt_univ env sym prov (chooseRole rep r) t1 t2 + +opt_co4 env sym rep r (TransCo co1 co2) + -- sym (g `o` h) = sym h `o` sym g + | sym = opt_trans in_scope co2' co1' + | otherwise = opt_trans in_scope co1' co2' + where + co1' = opt_co4_wrap env sym rep r co1 + co2' = opt_co4_wrap env sym rep r co2 + in_scope = lcInScopeSet env + +opt_co4 env _sym rep r (NthCo _r n co) + | Just (ty, _) <- isReflCo_maybe co + , Just (_tc, args) <- ASSERT( r == _r ) + splitTyConApp_maybe ty + = liftCoSubst (chooseRole rep r) env (args `getNth` n) + | Just (ty, _) <- isReflCo_maybe co + , n == 0 + , Just (tv, _) <- splitForAllTy_maybe ty + -- works for both tyvar and covar + = liftCoSubst (chooseRole rep r) env (varType tv) + +opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos)) + = ASSERT( r == r1 ) + opt_co4_wrap env sym rep r (cos `getNth` n) + +opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _)) + -- works for both tyvar and covar + = ASSERT( r == _r ) + ASSERT( n == 0 ) + opt_co4_wrap env sym rep Nominal eta + +opt_co4 env sym rep r (NthCo _r n co) + | TyConAppCo _ _ cos <- co' + , let nth_co = cos `getNth` n + = if rep && (r == Nominal) + -- keep propagating the SubCo + then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co + else nth_co + + | ForAllCo _ eta _ <- co' + = if rep + then opt_co4_wrap (zapLiftingContext env) False True Nominal eta + else eta + + | otherwise + = wrapRole rep r $ NthCo r n co' + where + co' = opt_co1 env sym co + +opt_co4 env sym rep r (LRCo lr co) + | Just pr_co <- splitAppCo_maybe co + = ASSERT( r == Nominal ) + opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co) + | Just pr_co <- splitAppCo_maybe co' + = ASSERT( r == Nominal ) + if rep + then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) + else pick_lr lr pr_co + | otherwise + = wrapRole rep Nominal $ LRCo lr co' + where + co' = opt_co4_wrap env sym False Nominal co + + pick_lr CLeft (l, _) = l + pick_lr CRight (_, r) = r + +-- See Note [Optimising InstCo] +opt_co4 env sym rep r (InstCo co1 arg) + -- forall over type... + | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1 + = opt_co4_wrap (extendLiftingContext env tv + (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg)) + -- mkSymCo kind_co :: k1 ~ k2 + -- sym_arg :: (t1 :: k1) ~ (t2 :: k2) + -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1) + sym rep r co_body + + -- forall over coercion... + | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1 + , CoercionTy h1 <- t1 + , CoercionTy h2 <- t2 + = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2 + in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body + + -- See if it is a forall after optimization + -- If so, do an inefficient one-variable substitution, then re-optimize + + -- forall over type... + | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1' + = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' + (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg')) + False False r' co_body' + + -- forall over coercion... + | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1' + , CoercionTy h1' <- t1' + , CoercionTy h2' <- t2' + = let new_co = mk_new_co cv' kind_co' h1' h2' + in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co) + False False r' co_body' + + | otherwise = InstCo co1' arg' + where + co1' = opt_co4_wrap env sym rep r co1 + r' = chooseRole rep r + arg' = opt_co4_wrap env sym False Nominal arg + sym_arg = wrapSym sym arg' + + -- Performance note: don't be alarmed by the two calls to coercionKind + -- here, as only one call to coercionKind is actually demanded per guard. + -- t1/t2 are used when checking if co1 is a forall, and t1'/t2' are used + -- when checking if co1' (i.e., co1 post-optimization) is a forall. + -- + -- t1/t2 must come from sym_arg, not arg', since it's possible that arg' + -- might have an extra Sym at the front (after being optimized) that co1 + -- lacks, so we need to use sym_arg to balance the number of Syms. (#15725) + Pair t1 t2 = coercionKind sym_arg + Pair t1' t2' = coercionKind arg' + + mk_new_co cv kind_co h1 h2 + = let -- h1 :: (t1 ~ t2) + -- h2 :: (t3 ~ t4) + -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4) + -- n1 :: t1 ~ t3 + -- n2 :: t2 ~ t4 + -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2) + r2 = coVarRole cv + kind_co' = downgradeRole r2 Nominal kind_co + n1 = mkNthCo r2 2 kind_co' + n2 = mkNthCo r2 3 kind_co' + in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1 + (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) + +opt_co4 env sym _rep r (KindCo co) + = ASSERT( r == Nominal ) + let kco' = promoteCoercion co in + case kco' of + KindCo co' -> promoteCoercion (opt_co1 env sym co') + _ -> opt_co4_wrap env sym False Nominal kco' + -- This might be able to be optimized more to do the promotion + -- and substitution/optimization at the same time + +opt_co4 env sym _ r (SubCo co) + = ASSERT( r == Representational ) + opt_co4_wrap env sym True Nominal co + +-- This could perhaps be optimized more. +opt_co4 env sym rep r (AxiomRuleCo co cs) + = ASSERT( r == coaxrRole co ) + wrapRole rep r $ + wrapSym sym $ + AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) + +{- Note [Optimise CoVarCo to Refl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have (c :: t~t) we can optimise it to Refl. That increases the +chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t) + +We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo] +in GHC.Core.Coercion. +-} + +------------- +-- | Optimize a phantom coercion. The input coercion may not necessarily +-- be a phantom, but the output sure will be. +opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo +opt_phantom env sym co + = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 + where + Pair ty1 ty2 = coercionKind co + +{- Note [Differing kinds] + ~~~~~~~~~~~~~~~~~~~~~~ +The two types may not have the same kind (although that would be very unusual). +But even if they have the same kind, and the same type constructor, the number +of arguments in a `CoTyConApp` can differ. Consider + + Any :: forall k. k + + Any * Int :: * + Any (*->*) Maybe Int :: * + +Hence the need to compare argument lengths; see #13658 + -} + +opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role + -> Type -> Type -> Coercion +opt_univ env sym (PhantomProv h) _r ty1 ty2 + | sym = mkPhantomCo h' ty2' ty1' + | otherwise = mkPhantomCo h' ty1' ty2' + where + h' = opt_co4 env sym False Nominal h + ty1' = substTy (lcSubstLeft env) ty1 + ty2' = substTy (lcSubstRight env) ty2 + +opt_univ env sym prov role oty1 oty2 + | Just (tc1, tys1) <- splitTyConApp_maybe oty1 + , Just (tc2, tys2) <- splitTyConApp_maybe oty2 + , tc1 == tc2 + , equalLength tys1 tys2 -- see Note [Differing kinds] + -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); + -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps + = let roles = tyConRolesX role tc1 + arg_cos = zipWith3 (mkUnivCo prov') roles tys1 tys2 + arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos + in + mkTyConAppCo role tc1 arg_cos' + + -- can't optimize the AppTy case because we can't build the kind coercions. + + | Just (tv1, ty1) <- splitForAllTy_ty_maybe oty1 + , Just (tv2, ty2) <- splitForAllTy_ty_maybe oty2 + -- NB: prov isn't interesting here either + = let k1 = tyVarKind tv1 + k2 = tyVarKind tv2 + eta = mkUnivCo prov' Nominal k1 k2 + -- eta gets opt'ed soon, but not yet. + ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2 + + (env', tv1', eta') = optForAllCoBndr env sym tv1 eta + in + mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2') + + | Just (cv1, ty1) <- splitForAllTy_co_maybe oty1 + , Just (cv2, ty2) <- splitForAllTy_co_maybe oty2 + -- NB: prov isn't interesting here either + = let k1 = varType cv1 + k2 = varType cv2 + r' = coVarRole cv1 + eta = mkUnivCo prov' Nominal k1 k2 + eta_d = downgradeRole r' Nominal eta + -- eta gets opt'ed soon, but not yet. + n_co = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo` + (mkCoVarCo cv1) `mkTransCo` + (mkNthCo r' 3 eta_d) + ty2' = substTyWithCoVars [cv2] [n_co] ty2 + + (env', cv1', eta') = optForAllCoBndr env sym cv1 eta + in + mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2') + + | otherwise + = let ty1 = substTyUnchecked (lcSubstLeft env) oty1 + ty2 = substTyUnchecked (lcSubstRight env) oty2 + (a, b) | sym = (ty2, ty1) + | otherwise = (ty1, ty2) + in + mkUnivCo prov' role a b + + where + prov' = case prov of + PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco + ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco + PluginProv _ -> prov + +------------- +opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList is = zipWith (opt_trans is) + +opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo +opt_trans is co1 co2 + | isReflCo co1 = co2 + -- optimize when co1 is a Refl Co + | otherwise = opt_trans1 is co1 co2 + +opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo +-- First arg is not the identity +opt_trans1 is co1 co2 + | isReflCo co2 = co1 + -- optimize when co2 is a Refl Co + | otherwise = opt_trans2 is co1 co2 + +opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo +-- Neither arg is the identity +opt_trans2 is (TransCo co1a co1b) co2 + -- Don't know whether the sub-coercions are the identity + = opt_trans is co1a (opt_trans is co1b co2) + +opt_trans2 is co1 co2 + | Just co <- opt_trans_rule is co1 co2 + = co + +opt_trans2 is co1 (TransCo co2a co2b) + | Just co1_2a <- opt_trans_rule is co1 co2a + = if isReflCo co1_2a + then co2b + else opt_trans1 is co1_2a co2b + +opt_trans2 _ co1 co2 + = mkTransCo co1 co2 + +------ +-- Optimize coercions with a top-level use of transitivity. +opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo + +opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2)) + = ASSERT( r1 == r2 ) + fireTransRule "GRefl" in_co1 in_co2 $ + mkGReflRightCo r1 t1 (opt_trans is co1 co2) + +-- Push transitivity through matching destructors +opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2) + | d1 == d2 + , coercionRole co1 == coercionRole co2 + , co1 `compatible_co` co2 + = ASSERT( r1 == r2 ) + fireTransRule "PushNth" in_co1 in_co2 $ + mkNthCo r1 d1 (opt_trans is co1 co2) + +opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) + | d1 == d2 + , co1 `compatible_co` co2 + = fireTransRule "PushLR" in_co1 in_co2 $ + mkLRCo d1 (opt_trans is co1 co2) + +-- Push transitivity inside instantiation +opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) + | ty1 `eqCoercion` ty2 + , co1 `compatible_co` co2 + = fireTransRule "TrPushInst" in_co1 in_co2 $ + mkInstCo (opt_trans is co1 co2) ty1 + +opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) + in_co2@(UnivCo p2 r2 _tyl2 tyr2) + | Just prov' <- opt_trans_prov p1 p2 + = ASSERT( r1 == r2 ) + fireTransRule "UnivCo" in_co1 in_co2 $ + mkUnivCo prov' r1 tyl1 tyr2 + where + -- if the provenances are different, opt'ing will be very confusing + opt_trans_prov (PhantomProv kco1) (PhantomProv kco2) + = Just $ PhantomProv $ opt_trans is kco1 kco2 + opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2) + = Just $ ProofIrrelProv $ opt_trans is kco1 kco2 + opt_trans_prov (PluginProv str1) (PluginProv str2) | str1 == str2 = Just p1 + opt_trans_prov _ _ = Nothing + +-- Push transitivity down through matching top-level constructors. +opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) + | tc1 == tc2 + = ASSERT( r1 == r2 ) + fireTransRule "PushTyConApp" in_co1 in_co2 $ + mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) + +opt_trans_rule is in_co1@(FunCo r1 co1a co1b) in_co2@(FunCo r2 co2a co2b) + = ASSERT( r1 == r2 ) -- Just like the TyConAppCo/TyConAppCo case + fireTransRule "PushFun" in_co1 in_co2 $ + mkFunCo r1 (opt_trans is co1a co2a) (opt_trans is co1b co2b) + +opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) + -- Must call opt_trans_rule_app; see Note [EtaAppCo] + = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b] + +-- Eta rules +opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 + | Just cos2 <- etaTyConAppCo_maybe tc co2 + = ASSERT( cos1 `equalLength` cos2 ) + fireTransRule "EtaCompL" co1 co2 $ + mkTyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) + | Just cos1 <- etaTyConAppCo_maybe tc co1 + = ASSERT( cos1 `equalLength` cos2 ) + fireTransRule "EtaCompR" co1 co2 $ + mkTyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1@(AppCo co1a co1b) co2 + | Just (co2a,co2b) <- etaAppCo_maybe co2 + = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + +opt_trans_rule is co1 co2@(AppCo co2a co2b) + | Just (co1a,co1b) <- etaAppCo_maybe co1 + = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + +-- Push transitivity inside forall +-- forall over types. +opt_trans_rule is co1 co2 + | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1 + , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2 + = push_trans tv1 eta1 r1 tv2 eta2 r2 + + | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2 + , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1 + = push_trans tv1 eta1 r1 tv2 eta2 r2 + + where + push_trans tv1 eta1 r1 tv2 eta2 r2 + -- Given: + -- co1 = /\ tv1 : eta1. r1 + -- co2 = /\ tv2 : eta2. r2 + -- Wanted: + -- /\tv1 : (eta1;eta2). (r1; r2[tv2 |-> tv1 |> eta1]) + = fireTransRule "EtaAllTy_ty" co1 co2 $ + mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` tv1 + r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2 + +-- Push transitivity inside forall +-- forall over coercions. +opt_trans_rule is co1 co2 + | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1 + , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2 + = push_trans cv1 eta1 r1 cv2 eta2 r2 + + | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2 + , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1 + = push_trans cv1 eta1 r1 cv2 eta2 r2 + + where + push_trans cv1 eta1 r1 cv2 eta2 r2 + -- Given: + -- co1 = /\ cv1 : eta1. r1 + -- co2 = /\ cv2 : eta2. r2 + -- Wanted: + -- n1 = nth 2 eta1 + -- n2 = nth 3 eta1 + -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2]) + = fireTransRule "EtaAllTy_co" co1 co2 $ + mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` cv1 + role = coVarRole cv1 + eta1' = downgradeRole role Nominal eta1 + n1 = mkNthCo role 2 eta1' + n2 = mkNthCo role 3 eta1' + r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo` + (mkCoVarCo cv1) `mkTransCo` n2]) + r2 + +-- Push transitivity inside axioms +opt_trans_rule is co1 co2 + + -- See Note [Why call checkAxInstCo during optimisation] + -- TrPushSymAxR + | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe + , True <- sym + , Just cos2 <- matchAxiom sym con ind co2 + , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst + + -- TrPushAxR + | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe + , False <- sym + , Just cos2 <- matchAxiom sym con ind co2 + , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushAxR" co1 co2 newAxInst + + -- TrPushSymAxL + | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe + , True <- sym + , Just cos1 <- matchAxiom (not sym) con ind co1 + , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst + + -- TrPushAxL + | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe + , False <- sym + , Just cos1 <- matchAxiom (not sym) con ind co1 + , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushAxL" co1 co2 newAxInst + + -- TrPushAxSym/TrPushSymAx + | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe + , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe + , con1 == con2 + , ind1 == ind2 + , sym1 == not sym2 + , let branch = coAxiomNthBranch con1 ind1 + qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch + lhs = coAxNthLHS con1 ind1 + rhs = coAxBranchRHS branch + pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs) + , all (`elemVarSet` pivot_tvs) qtvs + = fireTransRule "TrPushAxSym" co1 co2 $ + if sym2 + -- TrPushAxSym + then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs + -- TrPushSymAx + else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs + where + co1_is_axiom_maybe = isAxiom_maybe co1 + co2_is_axiom_maybe = isAxiom_maybe co2 + role = coercionRole co1 -- should be the same as coercionRole co2! + +opt_trans_rule _ co1 co2 -- Identity rule + | let ty1 = coercionLKind co1 + r = coercionRole co1 + ty2 = coercionRKind co2 + , ty1 `eqType` ty2 + = fireTransRule "RedTypeDirRefl" co1 co2 $ + mkReflCo r ty2 + +opt_trans_rule _ _ _ = Nothing + +-- See Note [EtaAppCo] +opt_trans_rule_app :: InScopeSet + -> Coercion -- original left-hand coercion (printing only) + -> Coercion -- original right-hand coercion (printing only) + -> Coercion -- left-hand coercion "function" + -> [Coercion] -- left-hand coercion "args" + -> Coercion -- right-hand coercion "function" + -> [Coercion] -- right-hand coercion "args" + -> Maybe Coercion +opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs + | AppCo co1aa co1ab <- co1a + , Just (co2aa, co2ab) <- etaAppCo_maybe co2a + = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + + | AppCo co2aa co2ab <- co2a + , Just (co1aa, co1ab) <- etaAppCo_maybe co1a + = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + + | otherwise + = ASSERT( co1bs `equalLength` co2bs ) + fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $ + let rt1a = coercionRKind co1a + + lt2a = coercionLKind co2a + rt2a = coercionRole co2a + + rt1bs = map coercionRKind co1bs + lt2bs = map coercionLKind co2bs + rt2bs = map coercionRole co2bs + + kcoa = mkKindCo $ buildCoercion lt2a rt1a + kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs + + co2a' = mkCoherenceLeftCo rt2a lt2a kcoa co2a + co2bs' = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs + co2bs'' = zipWith mkTransCo co2bs' co2bs + in + mkAppCos (opt_trans is co1a co2a') + (zipWith (opt_trans is) co1bs co2bs'') + +fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion +fireTransRule _rule _co1 _co2 res + = Just res + +{- +Note [Conflict checking with AxiomInstCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following type family and axiom: + +type family Equal (a :: k) (b :: k) :: Bool +type instance where + Equal a a = True + Equal a b = False +-- +Equal :: forall k::*. k -> k -> Bool +axEqual :: { forall k::*. forall a::k. Equal k a a ~ True + ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False } + +We wish to disallow (axEqual[1] <*> <Int> <Int). (Recall that the index is +0-based, so this is the second branch of the axiom.) The problem is that, on +the surface, it seems that (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~ +False) and that all is OK. But, all is not OK: we want to use the first branch +of the axiom in this case, not the second. The problem is that the parameters +of the first branch can unify with the supplied coercions, thus meaning that +the first branch should be taken. See also Note [Apartness] in +types/FamInstEnv.hs. + +Note [Why call checkAxInstCo during optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible that otherwise-good-looking optimisations meet with disaster +in the presence of axioms with multiple equations. Consider + +type family Equal (a :: *) (b :: *) :: Bool where + Equal a a = True + Equal a b = False +type family Id (a :: *) :: * where + Id a = a + +axEq :: { [a::*]. Equal a a ~ True + ; [a::*, b::*]. Equal a b ~ False } +axId :: [a::*]. Id a ~ a + +co1 = Equal (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ Equal Int Bool +co2 = axEq[1] <Int> <Bool> + :: Equal Int Bool ~ False + +We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that +co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what +happens when we push the coercions inside? We get + +co3 = axEq[1] (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ False + +which is bogus! This is because the type system isn't smart enough to know +that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type +families. At the time of writing, I (Richard Eisenberg) couldn't think of +a way of detecting this any more efficient than just building the optimised +coercion and checking. + +Note [EtaAppCo] +~~~~~~~~~~~~~~~ +Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd +like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that +the resultant coercions might not be well kinded. Here is an example (things +labeled with x don't matter in this example): + + k1 :: Type + k2 :: Type + + a :: k1 -> Type + b :: k1 + + h :: k1 ~ k2 + + co1a :: x1 ~ (a |> (h -> <Type>) + co1b :: x2 ~ (b |> h) + + co2a :: a ~ x3 + co2b :: b ~ x4 + +First, convince yourself of the following: + + co1a co1b :: x1 x2 ~ (a |> (h -> <Type>)) (b |> h) + co2a co2b :: a b ~ x3 x4 + + (a |> (h -> <Type>)) (b |> h) `eqType` a b + +That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep, +where we ignore coercions in types as long as two types' kinds are the same. +In our case, we meet this last condition, because + + (a |> (h -> <Type>)) (b |> h) :: Type + and + a b :: Type + +So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the +suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the +kinds don't match up. + +The solution here is to twiddle the kinds in the output coercions. First, we +need to find coercions + + ak :: kind(a |> (h -> <Type>)) ~ kind(a) + bk :: kind(b |> h) ~ kind(b) + +This can be done with mkKindCo and buildCoercion. The latter assumes two +types are identical modulo casts and builds a coercion between them. + +Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the +output coercions. These are well-kinded. + +Also, note that all of this is done after accumulated any nested AppCo +parameters. This step is to avoid quadratic behavior in calling coercionKind. + +The problem described here was first found in dependent/should_compile/dynamic-paper. + +-} + +-- | Check to make sure that an AxInstCo is internally consistent. +-- Returns the conflicting branch, if it exists +-- See Note [Conflict checking with AxiomInstCo] +checkAxInstCo :: Coercion -> Maybe CoAxBranch +-- defined here to avoid dependencies in GHC.Core.Coercion +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +checkAxInstCo (AxiomInstCo ax ind cos) + = let branch = coAxiomNthBranch ax ind + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + incomps = coAxBranchIncomps branch + (tys, cotys) = splitAtList tvs (map coercionLKind cos) + co_args = map stripCoercionTy cotys + subst = zipTvSubst tvs tys `composeTCvSubst` + zipCvSubst cvs co_args + target = Type.substTys subst (coAxBranchLHS branch) + in_scope = mkInScopeSet $ + unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps) + flattened_target = flattenTys in_scope target in + check_no_conflict flattened_target incomps + where + check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch + check_no_conflict _ [] = Nothing + check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) + -- See Note [Apartness] in GHC.Core.FamInstEnv + | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp + = check_no_conflict flat rest + | otherwise + = Just b +checkAxInstCo _ = Nothing + + +----------- +wrapSym :: SymFlag -> Coercion -> Coercion +wrapSym sym co | sym = mkSymCo co + | otherwise = co + +-- | Conditionally set a role to be representational +wrapRole :: ReprFlag + -> Role -- ^ current role + -> Coercion -> Coercion +wrapRole False _ = id +wrapRole True current = downgradeRole Representational current + +-- | If we require a representational role, return that. Otherwise, +-- return the "default" role provided. +chooseRole :: ReprFlag + -> Role -- ^ "default" role + -> Role +chooseRole True _ = Representational +chooseRole _ r = r + +----------- +isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) +isAxiom_maybe (SymCo co) + | Just (sym, con, ind, cos) <- isAxiom_maybe co + = Just (not sym, con, ind, cos) +isAxiom_maybe (AxiomInstCo con ind cos) + = Just (False, con, ind, cos) +isAxiom_maybe _ = Nothing + +matchAxiom :: Bool -- True = match LHS, False = match RHS + -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion] +matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co + | CoAxBranch { cab_tvs = qtvs + , cab_cvs = [] -- can't infer these, so fail if there are any + , cab_roles = roles + , cab_lhs = lhs + , cab_rhs = rhs } <- coAxiomNthBranch ax ind + , Just subst <- liftCoMatch (mkVarSet qtvs) + (if sym then (mkTyConApp tc lhs) else rhs) + co + , all (`isMappedByLC` subst) qtvs + = zipWithM (liftCoSubstTyVar subst) roles qtvs + + | otherwise + = Nothing + +------------- +compatible_co :: Coercion -> Coercion -> Bool +-- Check whether (co1 . co2) will be well-kinded +compatible_co co1 co2 + = x1 `eqType` x2 + where + x1 = coercionRKind co1 + x2 = coercionLKind co2 + +------------- +{- +etaForAllCo +~~~~~~~~~~~~~~~~~ +(1) etaForAllCo_ty_maybe +Suppose we have + + g : all a1:k1.t1 ~ all a2:k2.t2 + +but g is *not* a ForAllCo. We want to eta-expand it. So, we do this: + + g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g)) + +Call the kind coercion h1 and the body coercion h2. We can see that + + h2 : t1 ~ t2[a2 |-> (a1 |> h1)] + +According to the typing rule for ForAllCo, we get that + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1]) + +or + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) + +as desired. + +(2) etaForAllCo_co_maybe +Suppose we have + + g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2 + +Similarly, we do this + + g' = all c1:h1. h2 + : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)] + [c1 |-> eta1;c1;sym eta2] + +Here, + + h1 = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4) + eta1 = mkNthCo r 2 h1 :: (s1 ~ s3) + eta2 = mkNthCo r 3 h1 :: (s2 ~ s4) + h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) +-} +etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +-- Try to make the coercion be of form (forall tv:kind_co. co) +etaForAllCo_ty_maybe co + | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co + = Just (tv, kind_co, r) + + | Pair ty1 ty2 <- coercionKind co + , Just (tv1, _) <- splitForAllTy_ty_maybe ty1 + , isForAllTy_ty ty2 + , let kind_co = mkNthCo Nominal 0 co + = Just ( tv1, kind_co + , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) + + | otherwise + = Nothing + +etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) +-- Try to make the coercion be of form (forall cv:kind_co. co) +etaForAllCo_co_maybe co + | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co + = Just (cv, kind_co, r) + + | Pair ty1 ty2 <- coercionKind co + , Just (cv1, _) <- splitForAllTy_co_maybe ty1 + , isForAllTy_co ty2 + = let kind_co = mkNthCo Nominal 0 co + r = coVarRole cv1 + l_co = mkCoVarCo cv1 + kind_co' = downgradeRole r Nominal kind_co + r_co = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo` + l_co `mkTransCo` + (mkNthCo r 3 kind_co') + in Just ( cv1, kind_co + , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) + + | otherwise + = Nothing + +etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) +-- If possible, split a coercion +-- g :: t1a t1b ~ t2a t2b +-- into a pair of coercions (left g, right g) +etaAppCo_maybe co + | Just (co1,co2) <- splitAppCo_maybe co + = Just (co1,co2) + | (Pair ty1 ty2, Nominal) <- coercionKindRole co + , Just (_,t1) <- splitAppTy_maybe ty1 + , Just (_,t2) <- splitAppTy_maybe ty2 + , let isco1 = isCoercionTy t1 + , let isco2 = isCoercionTy t2 + , isco1 == isco2 + = Just (LRCo CLeft co, LRCo CRight co) + | otherwise + = Nothing + +etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] +-- If possible, split a coercion +-- g :: T s1 .. sn ~ T t1 .. tn +-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] +etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) + = ASSERT( tc == tc2 ) Just cos2 + +etaTyConAppCo_maybe tc co + | not (mustBeSaturated tc) + , (Pair ty1 ty2, r) <- coercionKindRole co + , Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , tc1 == tc2 + , isInjectiveTyCon tc r -- See Note [NthCo and newtypes] in GHC.Core.TyCo.Rep + , let n = length tys1 + , tys2 `lengthIs` n -- This can fail in an erroneous program + -- E.g. T a ~# T a b + -- #14607 + = ASSERT( tc == tc1 ) + Just (decomposeCo n co (tyConRolesX r tc1)) + -- NB: n might be <> tyConArity tc + -- e.g. data family T a :: * -> * + -- g :: T a b ~ T c d + + | otherwise + = Nothing + +{- +Note [Eta for AppCo] +~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: s1 t1 ~ s2 t2 + +Then we can't necessarily make + left g :: s1 ~ s2 + right g :: t1 ~ t2 +because it's possible that + s1 :: * -> * t1 :: * + s2 :: (*->*) -> * t2 :: * -> * +and in that case (left g) does not have the same +kind on either side. + +It's enough to check that + kind t1 = kind t2 +because if g is well-kinded then + kind (s1 t2) = kind (s2 t2) +and these two imply + kind s1 = kind s2 + +-} + +optForAllCoBndr :: LiftingContext -> Bool + -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion) +optForAllCoBndr env sym + = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs new file mode 100644 index 0000000000..14e859acd6 --- /dev/null +++ b/compiler/GHC/Core/ConLike.hs @@ -0,0 +1,196 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[ConLike]{@ConLike@: Constructor-like things} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.ConLike ( + ConLike(..) + , conLikeArity + , conLikeFieldLabels + , conLikeInstOrigArgTys + , conLikeExTyCoVars + , conLikeName + , conLikeStupidTheta + , conLikeWrapId_maybe + , conLikeImplBangs + , conLikeFullSig + , conLikeResTy + , conLikeFieldType + , conLikesWithFields + , conLikeIsInfix + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core.DataCon +import GHC.Core.PatSyn +import Outputable +import Unique +import Util +import Name +import BasicTypes +import GHC.Core.TyCo.Rep (Type, ThetaType) +import Var +import GHC.Core.Type(mkTyConApp) + +import qualified Data.Data as Data + +{- +************************************************************************ +* * +\subsection{Constructor-like things} +* * +************************************************************************ +-} + +-- | A constructor-like thing +data ConLike = RealDataCon DataCon + | PatSynCon PatSyn + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq ConLike where + (==) = eqConLike + +eqConLike :: ConLike -> ConLike -> Bool +eqConLike x y = getUnique x == getUnique y + +-- There used to be an Ord ConLike instance here that used Unique for ordering. +-- It was intentionally removed to prevent determinism problems. +-- See Note [Unique Determinism] in Unique. + +instance Uniquable ConLike where + getUnique (RealDataCon dc) = getUnique dc + getUnique (PatSynCon ps) = getUnique ps + +instance NamedThing ConLike where + getName (RealDataCon dc) = getName dc + getName (PatSynCon ps) = getName ps + +instance Outputable ConLike where + ppr (RealDataCon dc) = ppr dc + ppr (PatSynCon ps) = ppr ps + +instance OutputableBndr ConLike where + pprInfixOcc (RealDataCon dc) = pprInfixOcc dc + pprInfixOcc (PatSynCon ps) = pprInfixOcc ps + pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc + pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps + +instance Data.Data ConLike where + -- don't traverse? + toConstr _ = abstractConstr "ConLike" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ConLike" + +-- | Number of arguments +conLikeArity :: ConLike -> Arity +conLikeArity (RealDataCon data_con) = dataConSourceArity data_con +conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn + +-- | Names of fields used for selectors +conLikeFieldLabels :: ConLike -> [FieldLabel] +conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con +conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn + +-- | Returns just the instantiated /value/ argument types of a 'ConLike', +-- (excluding dictionary args) +conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type] +conLikeInstOrigArgTys (RealDataCon data_con) tys = + dataConInstOrigArgTys data_con tys +conLikeInstOrigArgTys (PatSynCon pat_syn) tys = + patSynInstArgTys pat_syn tys + +-- | Existentially quantified type/coercion variables +conLikeExTyCoVars :: ConLike -> [TyCoVar] +conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1 +conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1 + +conLikeName :: ConLike -> Name +conLikeName (RealDataCon data_con) = dataConName data_con +conLikeName (PatSynCon pat_syn) = patSynName pat_syn + +-- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... +-- It is empty for `PatSynCon` as they do not allow such contexts. +conLikeStupidTheta :: ConLike -> ThetaType +conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con +conLikeStupidTheta (PatSynCon {}) = [] + +-- | Returns the `Id` of the wrapper. This is also known as the builder in +-- some contexts. The value is Nothing only in the case of unidirectional +-- pattern synonyms. +conLikeWrapId_maybe :: ConLike -> Maybe Id +conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con +conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> patSynBuilder pat_syn + +-- | Returns the strictness information for each constructor +conLikeImplBangs :: ConLike -> [HsImplBang] +conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con +conLikeImplBangs (PatSynCon pat_syn) = + replicate (patSynArity pat_syn) HsLazy + +-- | Returns the type of the whole pattern +conLikeResTy :: ConLike -> [Type] -> Type +conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys +conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys + +-- | The \"full signature\" of the 'ConLike' returns, in order: +-- +-- 1) The universally quantified type variables +-- +-- 2) The existentially quantified type/coercion variables +-- +-- 3) The equality specification +-- +-- 4) The provided theta (the constraints provided by a match) +-- +-- 5) The required theta (the constraints required for a match) +-- +-- 6) The original argument types (i.e. before +-- any change of the representation of the type) +-- +-- 7) The original result type +conLikeFullSig :: ConLike + -> ([TyVar], [TyCoVar], [EqSpec] + -- Why tyvars for universal but tycovars for existential? + -- See Note [Existential coercion variables] in GHC.Core.DataCon + , ThetaType, ThetaType, [Type], Type) +conLikeFullSig (RealDataCon con) = + let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con + -- Required theta is empty as normal data cons require no additional + -- constraints for a match + in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty) +conLikeFullSig (PatSynCon pat_syn) = + let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn + -- eqSpec is empty + in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty) + +-- | Extract the type for any given labelled field of the 'ConLike' +conLikeFieldType :: ConLike -> FieldLabelString -> Type +conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label +conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label + + +-- | The ConLikes that have *all* the given fields +conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike] +conLikesWithFields con_likes lbls = filter has_flds con_likes + where has_flds dc = all (has_fld dc) lbls + has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) + +conLikeIsInfix :: ConLike -> Bool +conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc +conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps diff --git a/compiler/GHC/Core/ConLike.hs-boot b/compiler/GHC/Core/ConLike.hs-boot new file mode 100644 index 0000000000..8b007a2e0d --- /dev/null +++ b/compiler/GHC/Core/ConLike.hs-boot @@ -0,0 +1,9 @@ +module GHC.Core.ConLike where +import {-# SOURCE #-} GHC.Core.DataCon (DataCon) +import {-# SOURCE #-} GHC.Core.PatSyn (PatSyn) +import Name ( Name ) + +data ConLike = RealDataCon DataCon + | PatSynCon PatSyn + +conLikeName :: ConLike -> Name diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs new file mode 100644 index 0000000000..5b3501b3a9 --- /dev/null +++ b/compiler/GHC/Core/DataCon.hs @@ -0,0 +1,1468 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[DataCon]{@DataCon@: Data Constructors} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module GHC.Core.DataCon ( + -- * Main data types + DataCon, DataConRep(..), + SrcStrictness(..), SrcUnpackedness(..), + HsSrcBang(..), HsImplBang(..), + StrictnessMark(..), + ConTag, + + -- ** Equality specs + EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, + eqSpecPair, eqSpecPreds, + substEqSpec, filterEqSpec, + + -- ** Field labels + FieldLbl(..), FieldLabel, FieldLabelString, + + -- ** Type construction + mkDataCon, fIRST_TAG, + + -- ** Type deconstruction + dataConRepType, dataConInstSig, dataConFullSig, + dataConName, dataConIdentity, dataConTag, dataConTagZ, + dataConTyCon, dataConOrigTyCon, + dataConUserType, + dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, + dataConUserTyVars, dataConUserTyVarBinders, + dataConEqSpec, dataConTheta, + dataConStupidTheta, + dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, + dataConInstOrigArgTys, dataConRepArgTys, + dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, + dataConSrcBangs, + dataConSourceArity, dataConRepArity, + dataConIsInfix, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, + dataConImplicitTyThings, + dataConRepStrictness, dataConImplBangs, dataConBoxer, + + splitDataProductType_maybe, + + -- ** Predicates on DataCons + isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, + isUnboxedSumCon, + isVanillaDataCon, classDataCon, dataConCannotMatch, + dataConUserTyVarsArePermuted, + isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, + specialPromotedDc, + + -- ** Promotion related functions + promoteDataCon + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} MkId( DataConBoxer ) +import GHC.Core.Type as Type +import GHC.Core.Coercion +import GHC.Core.Unify +import GHC.Core.TyCon +import FieldLabel +import GHC.Core.Class +import Name +import PrelNames +import GHC.Core.Predicate +import Var +import Outputable +import Util +import BasicTypes +import FastString +import Module +import Binary +import UniqSet +import Unique( mkAlphaTyVarUnique ) + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Data as Data +import Data.Char +import Data.List( find ) + +{- +Data constructor representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following Haskell data type declaration + + data T = T !Int ![Int] + +Using the strictness annotations, GHC will represent this as + + data T = T Int# [Int] + +That is, the Int has been unboxed. Furthermore, the Haskell source construction + + T e1 e2 + +is translated to + + case e1 of { I# x -> + case e2 of { r -> + T x r }} + +That is, the first argument is unboxed, and the second is evaluated. Finally, +pattern matching is translated too: + + case e of { T a b -> ... } + +becomes + + case e of { T a' b -> let a = I# a' in ... } + +To keep ourselves sane, we name the different versions of the data constructor +differently, as follows. + + +Note [Data Constructor Naming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each data constructor C has two, and possibly up to four, Names associated with it: + + OccName Name space Name of Notes + --------------------------------------------------------------------------- + The "data con itself" C DataName DataCon In dom( GlobalRdrEnv ) + The "worker data con" C VarName Id The worker + The "wrapper data con" $WC VarName Id The wrapper + The "newtype coercion" :CoT TcClsName TyCon + +EVERY data constructor (incl for newtypes) has the former two (the +data con itself, and its worker. But only some data constructors have a +wrapper (see Note [The need for a wrapper]). + +Each of these three has a distinct Unique. The "data con itself" name +appears in the output of the renamer, and names the Haskell-source +data constructor. The type checker translates it into either the wrapper Id +(if it exists) or worker Id (otherwise). + +The data con has one or two Ids associated with it: + +The "worker Id", is the actual data constructor. +* Every data constructor (newtype or data type) has a worker + +* The worker is very like a primop, in that it has no binding. + +* For a *data* type, the worker *is* the data constructor; + it has no unfolding + +* For a *newtype*, the worker has a compulsory unfolding which + does a cast, e.g. + newtype T = MkT Int + The worker for MkT has unfolding + \\(x:Int). x `cast` sym CoT + Here CoT is the type constructor, witnessing the FC axiom + axiom CoT : T = Int + +The "wrapper Id", \$WC, goes as follows + +* Its type is exactly what it looks like in the source program. + +* It is an ordinary function, and it gets a top-level binding + like any other function. + +* The wrapper Id isn't generated for a data type if there is + nothing for the wrapper to do. That is, if its defn would be + \$wC = C + +Note [Data constructor workers and wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Algebraic data types + - Always have a worker, with no unfolding + - May or may not have a wrapper; see Note [The need for a wrapper] + +* Newtypes + - Always have a worker, which has a compulsory unfolding (just a cast) + - May or may not have a wrapper; see Note [The need for a wrapper] + +* INVARIANT: the dictionary constructor for a class + never has a wrapper. + +* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments + +* The wrapper (if it exists) takes dcOrigArgTys as its arguments + The worker takes dataConRepArgTys as its arguments + If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys + +* The 'NoDataConRep' case of DataConRep is important. Not only is it + efficient, but it also ensures that the wrapper is replaced by the + worker (because it *is* the worker) even when there are no + args. E.g. in + f (:) x + the (:) *is* the worker. This is really important in rule matching, + (We could match on the wrappers, but that makes it less likely that + rules will match when we bring bits of unfoldings together.) + +Note [The need for a wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why might the wrapper have anything to do? The full story is +in wrapper_reqd in MkId.mkDataConRep. + +* Unboxing strict fields (with -funbox-strict-fields) + data T = MkT !(Int,Int) + \$wMkT :: (Int,Int) -> T + \$wMkT (x,y) = MkT x y + Notice that the worker has two fields where the wapper has + just one. That is, the worker has type + MkT :: Int -> Int -> T + +* Equality constraints for GADTs + data T a where { MkT :: a -> T [a] } + + The worker gets a type with explicit equality + constraints, thus: + MkT :: forall a b. (a=[b]) => b -> T a + + The wrapper has the programmer-specified type: + \$wMkT :: a -> T [a] + \$wMkT a x = MkT [a] a [a] x + The third argument is a coercion + [a] :: [a]~[a] + +* Data family instances may do a cast on the result + +* Type variables may be permuted; see MkId + Note [Data con wrappers and GADT syntax] + + +Note [The stupid context] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Data types can have a context: + + data (Eq a, Ord b) => T a b = T1 a b | T2 a + +and that makes the constructors have a context too +(notice that T2's context is "thinned"): + + T1 :: (Eq a, Ord b) => a -> b -> T a b + T2 :: (Eq a) => a -> T a b + +Furthermore, this context pops up when pattern matching +(though GHC hasn't implemented this, but it is in H98, and +I've fixed GHC so that it now does): + + f (T2 x) = x +gets inferred type + f :: Eq a => T a b -> a + +I say the context is "stupid" because the dictionaries passed +are immediately discarded -- they do nothing and have no benefit. +It's a flaw in the language. + + Up to now [March 2002] I have put this stupid context into the + type of the "wrapper" constructors functions, T1 and T2, but + that turned out to be jolly inconvenient for generics, and + record update, and other functions that build values of type T + (because they don't have suitable dictionaries available). + + So now I've taken the stupid context out. I simply deal with + it separately in the type checker on occurrences of a + constructor, either in an expression or in a pattern. + + [May 2003: actually I think this decision could easily be + reversed now, and probably should be. Generics could be + disabled for types with a stupid context; record updates now + (H98) needs the context too; etc. It's an unforced change, so + I'm leaving it for now --- but it does seem odd that the + wrapper doesn't include the stupid context.] + +[July 04] With the advent of generalised data types, it's less obvious +what the "stupid context" is. Consider + C :: forall a. Ord a => a -> a -> T (Foo a) +Does the C constructor in Core contain the Ord dictionary? Yes, it must: + + f :: T b -> Ordering + f = /\b. \x:T b. + case x of + C a (d:Ord a) (p:a) (q:a) -> compare d p q + +Note that (Foo a) might not be an instance of Ord. + +************************************************************************ +* * +\subsection{Data constructors} +* * +************************************************************************ +-} + +-- | A data constructor +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', +-- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma' + +-- For details on above see note [Api annotations] in ApiAnnotation +data DataCon + = MkData { + dcName :: Name, -- This is the name of the *source data con* + -- (see "Note [Data Constructor Naming]" above) + dcUnique :: Unique, -- Cached from Name + dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's + + -- Running example: + -- + -- *** As declared by the user + -- data T a b c where + -- MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c + + -- *** As represented internally + -- data T a b c where + -- MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x) + -- => x -> y -> T a b c + -- + -- The next six fields express the type of the constructor, in pieces + -- e.g. + -- + -- dcUnivTyVars = [a,b,c] + -- dcExTyCoVars = [x,y] + -- dcUserTyVarBinders = [c,y,x,b] + -- dcEqSpec = [a~(x,y)] + -- dcOtherTheta = [x~y, Ord x] + -- dcOrigArgTys = [x,y] + -- dcRepTyCon = T + + -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE + -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously, + -- vanilla datacons guaranteed to have the same type variables as their + -- parent TyCon, but that seems ugly.) They can be different in the case + -- where a GADT constructor uses different names for the universal + -- tyvars than does the tycon. For example: + -- + -- data H a where + -- MkH :: b -> H b + -- + -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH + -- will be [b]. + + dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor + -- Its type is of form + -- forall a1..an . t1 -> ... tm -> T a1..an + -- No existentials, no coercions, nothing. + -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = [] + -- NB 1: newtypes always have a vanilla data con + -- NB 2: a vanilla constructor can still be declared in GADT-style + -- syntax, provided its type looks like the above. + -- The declaration format is held in the TyCon (algTcGadtSyntax) + + -- Universally-quantified type vars [a,b,c] + -- INVARIANT: length matches arity of the dcRepTyCon + -- INVARIANT: result type of data con worker is exactly (T a b c) + -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with + -- the tyConTyVars of the parent TyCon + dcUnivTyVars :: [TyVar], + + -- Existentially-quantified type and coercion vars [x,y] + -- For an example involving coercion variables, + -- Why tycovars? See Note [Existential coercion variables] + dcExTyCoVars :: [TyCoVar], + + -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames + -- Reason: less confusing, and easier to generate Iface syntax + + -- The type/coercion vars in the order the user wrote them [c,y,x,b] + -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set + -- of tyvars (*not* covars) of dcExTyCoVars unioned with the + -- set of dcUnivTyVars whose tyvars do not appear in dcEqSpec + -- See Note [DataCon user type variable binders] + dcUserTyVarBinders :: [TyVarBinder], + + dcEqSpec :: [EqSpec], -- Equalities derived from the result type, + -- _as written by the programmer_. + -- Only non-dependent GADT equalities (dependent + -- GADT equalities are in the covars of + -- dcExTyCoVars). + + -- This field allows us to move conveniently between the two ways + -- of representing a GADT constructor's type: + -- MkT :: forall a b. (a ~ [b]) => b -> T a + -- MkT :: forall b. b -> T [b] + -- Each equality is of the form (a ~ ty), where 'a' is one of + -- the universally quantified type variables + + -- The next two fields give the type context of the data constructor + -- (aside from the GADT constraints, + -- which are given by the dcExpSpec) + -- In GADT form, this is *exactly* what the programmer writes, even if + -- the context constrains only universally quantified variables + -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b + dcOtherTheta :: ThetaType, -- The other constraints in the data con's type + -- other than those in the dcEqSpec + + dcStupidTheta :: ThetaType, -- The context of the data type declaration + -- data Eq a => T a = ... + -- or, rather, a "thinned" version thereof + -- "Thinned", because the Report says + -- to eliminate any constraints that don't mention + -- tyvars free in the arg types for this constructor + -- + -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars + -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon + -- + -- "Stupid", because the dictionaries aren't used for anything. + -- Indeed, [as of March 02] they are no longer in the type of + -- the wrapper Id, because that makes it harder to use the wrap-id + -- to rebuild values after record selection or in generics. + + dcOrigArgTys :: [Type], -- Original argument types + -- (before unboxing and flattening of strict fields) + dcOrigResTy :: Type, -- Original result type, as seen by the user + -- NB: for a data instance, the original user result type may + -- differ from the DataCon's representation TyCon. Example + -- data instance T [a] where MkT :: a -> T [a] + -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 + + -- Now the strictness annotations and field labels of the constructor + dcSrcBangs :: [HsSrcBang], + -- See Note [Bangs on data constructor arguments] + -- + -- The [HsSrcBang] as written by the programmer. + -- + -- Matches 1-1 with dcOrigArgTys + -- Hence length = dataConSourceArity dataCon + + dcFields :: [FieldLabel], + -- Field labels for this constructor, in the + -- same order as the dcOrigArgTys; + -- length = 0 (if not a record) or dataConSourceArity. + + -- The curried worker function that corresponds to the constructor: + -- It doesn't have an unfolding; the code generator saturates these Ids + -- and allocates a real constructor when it finds one. + dcWorkId :: Id, + + -- Constructor representation + dcRep :: DataConRep, + + -- Cached; see Note [DataCon arities] + -- INVARIANT: dcRepArity == length dataConRepArgTys + count isCoVar (dcExTyCoVars) + -- INVARIANT: dcSourceArity == length dcOrigArgTys + dcRepArity :: Arity, + dcSourceArity :: Arity, + + -- Result type of constructor is T t1..tn + dcRepTyCon :: TyCon, -- Result tycon, T + + dcRepType :: Type, -- Type of the constructor + -- forall a x y. (a~(x,y), x~y, Ord x) => + -- x -> y -> T a + -- (this is *not* of the constructor wrapper Id: + -- see Note [Data con representation] below) + -- Notice that the existential type parameters come *second*. + -- Reason: in a case expression we may find: + -- case (e :: T t) of + -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... + -- It's convenient to apply the rep-type of MkT to 't', to get + -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t + -- and use that to check the pattern. Mind you, this is really only + -- used in GHC.Core.Lint. + + + dcInfix :: Bool, -- True <=> declared infix + -- Used for Template Haskell and 'deriving' only + -- The actual fixity is stored elsewhere + + dcPromoted :: TyCon -- The promoted TyCon + -- See Note [Promoted data constructors] in GHC.Core.TyCon + } + + +{- Note [TyVarBinders in DataCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the TyVarBinders in a DataCon and PatSyn: + + * Each argument flag is Inferred or Specified. + None are Required. (A DataCon is a term-level function; see + Note [No Required TyCoBinder in terms] in GHC.Core.TyCo.Rep.) + +Why do we need the TyVarBinders, rather than just the TyVars? So that +we can construct the right type for the DataCon with its foralls +attributed the correct visibility. That in turn governs whether you +can use visible type application at a call of the data constructor. + +See also [DataCon user type variable binders] for an extended discussion on the +order in which TyVarBinders appear in a DataCon. + +Note [Existential coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For now (Aug 2018) we can't write coercion quantifications in source Haskell, but +we can in Core. Consider having: + + data T :: forall k. k -> k -> Constraint where + MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co)) + => T k a b + + dcUnivTyVars = [k,a,b] + dcExTyCoVars = [k',c,co] + dcUserTyVarBinders = [k,a,k',c] + dcEqSpec = [b~(c|>co)] + dcOtherTheta = [] + dcOrigArgTys = [] + dcRepTyCon = T + + Function call 'dataConKindEqSpec' returns [k'~k] + +Note [DataCon arities] +~~~~~~~~~~~~~~~~~~~~~~ +dcSourceArity does not take constraints into account, +but dcRepArity does. For example: + MkT :: Ord a => a -> T a + dcSourceArity = 1 + dcRepArity = 2 + +Note [DataCon user type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In System FC, data constructor type signatures always quantify over all of +their universal type variables, followed by their existential type variables. +Normally, this isn't a problem, as most datatypes naturally quantify their type +variables in this order anyway. For example: + + data T a b = forall c. MkT b c + +Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`, +where k, a, and b are universal and c is existential. (The inferred variable k +isn't available for TypeApplications, hence why it's in braces.) This is a +perfectly reasonable order to use, as the syntax of H98-style datatypes +(+ ExistentialQuantification) suggests it. + +Things become more complicated when GADT syntax enters the picture. Consider +this example: + + data X a where + MkX :: forall b a. b -> Proxy a -> X a + +If we adopt the earlier approach of quantifying all the universal variables +followed by all the existential ones, GHC would come up with this type +signature for MkX: + + MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a + +But this is not what we want at all! After all, if a user were to use +TypeApplications on MkX, they would expect to instantiate `b` before `a`, +as that's the order in which they were written in the `forall`. (See #11721.) +Instead, we'd like GHC to come up with this type signature: + + MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a + +In fact, even if we left off the explicit forall: + + data X a where + MkX :: b -> Proxy a -> X a + +Then a user should still expect `b` to be quantified before `a`, since +according to the rules of TypeApplications, in the absence of `forall` GHC +performs a stable topological sort on the type variables in the user-written +type signature, which would place `b` before `a`. + +But as noted above, enacting this behavior is not entirely trivial, as System +FC demands the variables go in universal-then-existential order under the hood. +Our solution is thus to equip DataCon with two different sets of type +variables: + +* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential + type/coercion variables, respectively. Their order is irrelevant for the + purposes of TypeApplications, and as a consequence, they do not come equipped + with visibilities (that is, they are TyVars/TyCoVars instead of + TyCoVarBinders). +* dcUserTyVarBinders, for the type variables binders in the order in which they + originally arose in the user-written type signature. Their order *does* matter + for TypeApplications, so they are full TyVarBinders, complete with + visibilities. + +This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders +consists precisely of: + +* The set of tyvars in dcUnivTyVars whose type variables do not appear in + dcEqSpec, unioned with: +* The set of tyvars (*not* covars) in dcExTyCoVars + No covars here because because they're not user-written + +The word "set" is used above because the order in which the tyvars appear in +dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or +dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of +(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the +ordering, they in fact share the same type variables (with the same Uniques). We +sometimes refer to this as "the dcUserTyVarBinders invariant". + +dcUserTyVarBinders, as the name suggests, is the one that users will see most of +the time. It's used when computing the type signature of a data constructor (see +dataConUserType), and as a result, it's what matters from a TypeApplications +perspective. +-} + +-- | Data Constructor Representation +-- See Note [Data constructor workers and wrappers] +data DataConRep + = -- NoDataConRep means that the data con has no wrapper + NoDataConRep + + -- DCR means that the data con has a wrapper + | DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens, + -- and constructs the representation + + , dcr_boxer :: DataConBoxer + + , dcr_arg_tys :: [Type] -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* all evidence args + + , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys + -- See also Note [Data-con worker strictness] in MkId.hs + + , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) + -- about the original arguments; 1-1 with orig_arg_tys + -- See Note [Bangs on data constructor arguments] + + } + +------------------------- + +-- | Haskell Source Bang +-- +-- Bangs on data constructor arguments as the user wrote them in the +-- source code. +-- +-- @(HsSrcBang _ SrcUnpack SrcLazy)@ and +-- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we +-- emit a warning (in checkValidDataCon) and treat it like +-- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ +data HsSrcBang = + HsSrcBang SourceText -- Note [Pragma source text] in BasicTypes + SrcUnpackedness + SrcStrictness + deriving Data.Data + +-- | Haskell Implementation Bang +-- +-- Bangs of data constructor arguments as generated by the compiler +-- after consulting HsSrcBang, flags, etc. +data HsImplBang + = HsLazy -- ^ Lazy field, or one with an unlifted type + | HsStrict -- ^ Strict but not unpacked field + | HsUnpack (Maybe Coercion) + -- ^ Strict and unpacked field + -- co :: arg-ty ~ product-ty HsBang + deriving Data.Data + +-- | Source Strictness +-- +-- What strictness annotation the user wrote +data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' + | SrcStrict -- ^ Strict, ie '!' + | NoSrcStrict -- ^ no strictness annotation + deriving (Eq, Data.Data) + +-- | Source Unpackedness +-- +-- What unpackedness the user requested +data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified + | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified + | NoSrcUnpack -- ^ no unpack pragma + deriving (Eq, Data.Data) + + + +------------------------- +-- StrictnessMark is internal only, used to indicate strictness +-- of the DataCon *worker* fields +data StrictnessMark = MarkedStrict | NotMarkedStrict + +-- | An 'EqSpec' is a tyvar/type pair representing an equality made in +-- rejigging a GADT constructor +data EqSpec = EqSpec TyVar + Type + +-- | Make a non-dependent 'EqSpec' +mkEqSpec :: TyVar -> Type -> EqSpec +mkEqSpec tv ty = EqSpec tv ty + +eqSpecTyVar :: EqSpec -> TyVar +eqSpecTyVar (EqSpec tv _) = tv + +eqSpecType :: EqSpec -> Type +eqSpecType (EqSpec _ ty) = ty + +eqSpecPair :: EqSpec -> (TyVar, Type) +eqSpecPair (EqSpec tv ty) = (tv, ty) + +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 :: TCvSubst -> EqSpec -> EqSpec +substEqSpec subst (EqSpec tv ty) + = EqSpec tv' (substTy subst ty) + where + tv' = getTyVar "substEqSpec" (substTyVar subst tv) + +-- | Filter out any 'TyVar's mentioned in an 'EqSpec'. +filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar] +filterEqSpec eq_spec + = filter not_in_eq_spec + where + not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec + +instance Outputable EqSpec where + ppr (EqSpec tv ty) = ppr (tv, ty) + +{- Note [Bangs on data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Int {-# UNPACK #-} !Int Bool + +When compiling the module, GHC will decide how to represent +MkT, depending on the optimisation level, and settings of +flags like -funbox-small-strict-fields. + +Terminology: + * HsSrcBang: What the user wrote + Constructors: HsSrcBang + + * HsImplBang: What GHC decided + Constructors: HsLazy, HsStrict, HsUnpack + +* If T was defined in this module, MkT's dcSrcBangs field + records the [HsSrcBang] of what the user wrote; in the example + [ HsSrcBang _ NoSrcUnpack SrcStrict + , HsSrcBang _ SrcUnpack SrcStrict + , HsSrcBang _ NoSrcUnpack NoSrcStrictness] + +* However, if T was defined in an imported module, the importing module + must follow the decisions made in the original module, regardless of + the flag settings in the importing module. + Also see Note [Bangs on imported data constructors] in MkId + +* The dcr_bangs field of the dcRep field records the [HsImplBang] + If T was defined in this module, Without -O the dcr_bangs might be + [HsStrict, HsStrict, HsLazy] + With -O it might be + [HsStrict, HsUnpack _, HsLazy] + With -funbox-small-strict-fields it might be + [HsUnpack, HsUnpack _, HsLazy] + With -XStrictData it might be + [HsStrict, HsUnpack _, HsStrict] + +Note [Data con representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The dcRepType field contains the type of the representation of a constructor +This may differ from the type of the constructor *Id* (built +by MkId.mkDataConId) for two reasons: + a) the constructor Id may be overloaded, but the dictionary isn't stored + e.g. data Eq a => T a = MkT a a + + b) the constructor may store an unboxed version of a strict field. + +Here's an example illustrating both: + data Ord a => T a = MkT Int! a +Here + T :: Ord a => Int -> a -> T a +but the rep type is + Trep :: Int# -> a -> T a +Actually, the unboxed part isn't implemented yet! + + + +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq DataCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable DataCon where + getUnique = dcUnique + +instance NamedThing DataCon where + getName = dcName + +instance Outputable DataCon where + ppr con = ppr (dataConName con) + +instance OutputableBndr DataCon where + pprInfixOcc con = pprInfixName (dataConName con) + pprPrefixOcc con = pprPrefixName (dataConName con) + +instance Data.Data DataCon where + -- don't traverse? + toConstr _ = abstractConstr "DataCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "DataCon" + +instance Outputable HsSrcBang where + ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark + +instance Outputable HsImplBang where + ppr HsLazy = text "Lazy" + ppr (HsUnpack Nothing) = text "Unpacked" + ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) + ppr HsStrict = text "StrictNotUnpacked" + +instance Outputable SrcStrictness where + ppr SrcLazy = char '~' + ppr SrcStrict = char '!' + ppr NoSrcStrict = empty + +instance Outputable SrcUnpackedness where + ppr SrcUnpack = text "{-# UNPACK #-}" + ppr SrcNoUnpack = text "{-# NOUNPACK #-}" + ppr NoSrcUnpack = empty + +instance Outputable StrictnessMark where + ppr MarkedStrict = text "!" + ppr NotMarkedStrict = empty + +instance Binary SrcStrictness where + put_ bh SrcLazy = putByte bh 0 + put_ bh SrcStrict = putByte bh 1 + put_ bh NoSrcStrict = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcLazy + 1 -> return SrcStrict + _ -> return NoSrcStrict + +instance Binary SrcUnpackedness where + put_ bh SrcNoUnpack = putByte bh 0 + put_ bh SrcUnpack = putByte bh 1 + put_ bh NoSrcUnpack = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcNoUnpack + 1 -> return SrcUnpack + _ -> return NoSrcUnpack + +-- | Compare strictness annotations +eqHsBang :: HsImplBang -> HsImplBang -> Bool +eqHsBang HsLazy HsLazy = True +eqHsBang HsStrict HsStrict = True +eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True +eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) + = eqType (coercionType c1) (coercionType c2) +eqHsBang _ _ = False + +isBanged :: HsImplBang -> Bool +isBanged (HsUnpack {}) = True +isBanged (HsStrict {}) = True +isBanged HsLazy = False + +isSrcStrict :: SrcStrictness -> Bool +isSrcStrict SrcStrict = True +isSrcStrict _ = False + +isSrcUnpacked :: SrcUnpackedness -> Bool +isSrcUnpacked SrcUnpack = True +isSrcUnpacked _ = False + +isMarkedStrict :: StrictnessMark -> Bool +isMarkedStrict NotMarkedStrict = False +isMarkedStrict _ = True -- All others are strict + +{- ********************************************************************* +* * +\subsection{Construction} +* * +********************************************************************* -} + +-- | Build a new data constructor +mkDataCon :: Name + -> Bool -- ^ Is the constructor declared infix? + -> TyConRepName -- ^ TyConRepName for the promoted TyCon + -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user + -> [FieldLabel] -- ^ Field labels for the constructor, + -- if it is a record, otherwise empty + -> [TyVar] -- ^ Universals. + -> [TyCoVar] -- ^ Existentials. + -> [TyVarBinder] -- ^ User-written 'TyVarBinder's. + -- These must be Inferred/Specified. + -- See @Note [TyVarBinders in DataCons]@ + -> [EqSpec] -- ^ GADT equalities + -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper + -> [KnotTied Type] -- ^ Original argument types + -> KnotTied Type -- ^ Original result type + -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo' + -> KnotTied TyCon -- ^ Representation type constructor + -> ConTag -- ^ Constructor tag + -> ThetaType -- ^ The "stupid theta", context of the data + -- declaration e.g. @data Eq a => T a ...@ + -> Id -- ^ Worker Id + -> DataConRep -- ^ Representation + -> DataCon + -- Can get the tag from the TyCon + +mkDataCon name declared_infix prom_info + arg_stricts -- Must match orig_arg_tys 1-1 + fields + univ_tvs ex_tvs user_tvbs + eq_spec theta + orig_arg_tys orig_res_ty rep_info rep_tycon tag + stupid_theta work_id rep +-- Warning: mkDataCon is not a good place to check certain invariants. +-- If the programmer writes the wrong result type in the decl, thus: +-- data T a where { MkT :: S } +-- then it's possible that the univ_tvs may hit an assertion failure +-- if you pull on univ_tvs. This case is checked by checkValidDataCon, +-- so the error is detected properly... it's just that assertions here +-- are a little dodgy. + + = con + where + is_vanilla = null ex_tvs && null eq_spec && null theta + + con = MkData {dcName = name, dcUnique = nameUnique name, + dcVanilla = is_vanilla, dcInfix = declared_infix, + dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs, + dcUserTyVarBinders = user_tvbs, + dcEqSpec = eq_spec, + dcOtherTheta = theta, + dcStupidTheta = stupid_theta, + dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, + dcRepTyCon = rep_tycon, + dcSrcBangs = arg_stricts, + dcFields = fields, dcTag = tag, dcRepType = rep_ty, + dcWorkId = work_id, + dcRep = rep, + dcSourceArity = length orig_arg_tys, + dcRepArity = length rep_arg_tys + count isCoVar ex_tvs, + dcPromoted = promoted } + + -- The 'arg_stricts' passed to mkDataCon are simply those for the + -- source-language arguments. We add extra ones for the + -- dictionary arguments right here. + + rep_arg_tys = dataConRepArgTys con + + rep_ty = + case rep of + -- If the DataCon has no wrapper, then the worker's type *is* the + -- user-facing type, so we can simply use dataConUserType. + NoDataConRep -> dataConUserType con + -- If the DataCon has a wrapper, then the worker's type is never seen + -- by the user. The visibilities we pick do not matter here. + DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ + mkVisFunTys rep_arg_tys $ + mkTyConApp rep_tycon (mkTyVarTys univ_tvs) + + -- See Note [Promoted data constructors] in GHC.Core.TyCon + prom_tv_bndrs = [ mkNamedTyConBinder vis tv + | Bndr tv vis <- user_tvbs ] + + fresh_names = freshNames (map getName user_tvbs) + -- fresh_names: make sure that the "anonymous" tyvars don't + -- clash in name or unique with the universal/existential ones. + -- Tiresome! And unnecessary because these tyvars are never looked at + prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t) + {- Invisible -} | (n,t) <- fresh_names `zip` theta ] + prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t) + {- Visible -} | (n,t) <- dropList theta fresh_names `zip` orig_arg_tys ] + prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs + prom_res_kind = orig_res_ty + promoted = mkPromotedDataCon con name prom_info prom_bndrs + prom_res_kind roles rep_info + + roles = map (\tv -> if isTyVar tv then Nominal else Phantom) + (univ_tvs ++ ex_tvs) + ++ map (const Representational) (theta ++ orig_arg_tys) + +freshNames :: [Name] -> [Name] +-- Make an infinite list of Names whose Uniques and OccNames +-- differ from those in the 'avoid' list +freshNames avoids + = [ mkSystemName uniq occ + | n <- [0..] + , let uniq = mkAlphaTyVarUnique n + occ = mkTyVarOccFS (mkFastString ('x' : show n)) + + , not (uniq `elementOfUniqSet` avoid_uniqs) + , not (occ `elemOccSet` avoid_occs) ] + + where + avoid_uniqs :: UniqSet Unique + avoid_uniqs = mkUniqSet (map getUnique avoids) + + avoid_occs :: OccSet + avoid_occs = mkOccSet (map getOccName avoids) + +-- | The 'Name' of the 'DataCon', giving it a unique, rooted identification +dataConName :: DataCon -> Name +dataConName = dcName + +-- | The tag used for ordering 'DataCon's +dataConTag :: DataCon -> ConTag +dataConTag = dcTag + +dataConTagZ :: DataCon -> ConTagZ +dataConTagZ con = dataConTag con - fIRST_TAG + +-- | The type constructor that we are building via this data constructor +dataConTyCon :: DataCon -> TyCon +dataConTyCon = dcRepTyCon + +-- | The original type constructor used in the definition of this data +-- constructor. In case of a data family instance, that will be the family +-- type constructor. +dataConOrigTyCon :: DataCon -> TyCon +dataConOrigTyCon dc + | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc + | otherwise = dcRepTyCon dc + +-- | The representation type of the data constructor, i.e. the sort +-- type that will represent values of this type at runtime +dataConRepType :: DataCon -> Type +dataConRepType = dcRepType + +-- | Should the 'DataCon' be presented infix? +dataConIsInfix :: DataCon -> Bool +dataConIsInfix = dcInfix + +-- | The universally-quantified type variables of the constructor +dataConUnivTyVars :: DataCon -> [TyVar] +dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs + +-- | The existentially-quantified type/coercion variables of the constructor +-- including dependent (kind-) GADT equalities +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs + +-- | Both the universal and existential type/coercion variables of the constructor +dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar] +dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs }) + = univ_tvs ++ ex_tvs + +-- See Note [DataCon user type variable binders] +-- | The type variables of the constructor, in the order the user wrote them +dataConUserTyVars :: DataCon -> [TyVar] +dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs + +-- See Note [DataCon user type variable binders] +-- | 'TyCoVarBinder's for the type variables of the constructor, in the order the +-- user wrote them +dataConUserTyVarBinders :: DataCon -> [TyVarBinder] +dataConUserTyVarBinders = dcUserTyVarBinders + +-- | Equalities derived from the result type of the data constructor, as written +-- by the programmer in any GADT declaration. This includes *all* GADT-like +-- equalities, including those written in by hand by the programmer. +dataConEqSpec :: DataCon -> [EqSpec] +dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = dataConKindEqSpec con + ++ eq_spec ++ + [ spec -- heterogeneous equality + | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta + , tc `hasKey` heqTyConKey + , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of + (Just tv1, _) -> [mkEqSpec tv1 ty2] + (_, Just tv2) -> [mkEqSpec tv2 ty1] + _ -> [] + ] ++ + [ spec -- homogeneous equality + | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta + , tc `hasKey` eqTyConKey + , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of + (Just tv1, _) -> [mkEqSpec tv1 ty2] + (_, Just tv2) -> [mkEqSpec tv2 ty1] + _ -> [] + ] + +-- | Dependent (kind-level) equalities in a constructor. +-- There are extracted from the existential variables. +-- See Note [Existential coercion variables] +dataConKindEqSpec :: DataCon -> [EqSpec] +dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs}) + -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future), + -- which are frequently used functions. + -- For now (Aug 2018) this function always return empty set as we don't really + -- have coercion variables. + -- In the future when we do, we might want to cache this information in DataCon + -- so it won't be computed every time when aforementioned functions are called. + = [ EqSpec tv ty + | cv <- ex_tcvs + , isCoVar cv + , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv + tv = getTyVar "dataConKindEqSpec" ty1 + ] + +-- | The *full* constraints on the constructor type, including dependent GADT +-- equalities. +dataConTheta :: DataCon -> ThetaType +dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta + +-- | Get the Id of the 'DataCon' worker: a function that is the "actual" +-- constructor and has no top level binding in the program. The type may +-- be different from the obvious one written in the source program. Panics +-- if there is no such 'Id' for this 'DataCon' +dataConWorkId :: DataCon -> Id +dataConWorkId dc = dcWorkId dc + +-- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" +-- constructor so it has the type visible in the source program: c.f. +-- 'dataConWorkId'. +-- Returns Nothing if there is no wrapper, which occurs for an algebraic data +-- constructor and also for a newtype (whose constructor is inlined +-- compulsorily) +dataConWrapId_maybe :: DataCon -> Maybe Id +dataConWrapId_maybe dc = case dcRep dc of + NoDataConRep -> Nothing + DCR { dcr_wrap_id = wrap_id } -> Just wrap_id + +-- | Returns an Id which looks like the Haskell-source constructor by using +-- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to +-- the worker (see 'dataConWorkId') +dataConWrapId :: DataCon -> Id +dataConWrapId dc = case dcRep dc of + NoDataConRep-> dcWorkId dc -- worker=wrapper + DCR { dcr_wrap_id = wrap_id } -> wrap_id + +-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, +-- the union of the 'dataConWorkId' and the 'dataConWrapId' +dataConImplicitTyThings :: DataCon -> [TyThing] +dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep }) + = [AnId work] ++ wrap_ids + where + wrap_ids = case rep of + NoDataConRep -> [] + DCR { dcr_wrap_id = wrap } -> [AnId wrap] + +-- | The labels for the fields of this particular 'DataCon' +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConFieldLabels = dcFields + +-- | Extract the type for any given labelled field of the 'DataCon' +dataConFieldType :: DataCon -> FieldLabelString -> Type +dataConFieldType con label = case dataConFieldType_maybe con label of + Just (_, ty) -> ty + Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) + +-- | Extract the label and type for any given labelled field of the +-- 'DataCon', or return 'Nothing' if the field does not belong to it +dataConFieldType_maybe :: DataCon -> FieldLabelString + -> Maybe (FieldLabel, Type) +dataConFieldType_maybe con label + = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) + +-- | Strictness/unpack annotations, from user; or, for imported +-- DataCons, from the interface file +-- The list is in one-to-one correspondence with the arity of the 'DataCon' + +dataConSrcBangs :: DataCon -> [HsSrcBang] +dataConSrcBangs = dcSrcBangs + +-- | Source-level arity of the data constructor +dataConSourceArity :: DataCon -> Arity +dataConSourceArity (MkData { dcSourceArity = arity }) = arity + +-- | Gives the number of actual fields in the /representation/ of the +-- data constructor. This may be more than appear in the source code; +-- the extra ones are the existentially quantified dictionaries +dataConRepArity :: DataCon -> Arity +dataConRepArity (MkData { dcRepArity = arity }) = arity + +-- | Return whether there are any argument types for this 'DataCon's original source type +-- See Note [DataCon arities] +isNullarySrcDataCon :: DataCon -> Bool +isNullarySrcDataCon dc = dataConSourceArity dc == 0 + +-- | Return whether there are any argument types for this 'DataCon's runtime representation type +-- See Note [DataCon arities] +isNullaryRepDataCon :: DataCon -> Bool +isNullaryRepDataCon dc = dataConRepArity dc == 0 + +dataConRepStrictness :: DataCon -> [StrictnessMark] +-- ^ Give the demands on the arguments of a +-- Core constructor application (Con dc args) +dataConRepStrictness dc = case dcRep dc of + NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] + DCR { dcr_stricts = strs } -> strs + +dataConImplBangs :: DataCon -> [HsImplBang] +-- The implementation decisions about the strictness/unpack of each +-- source program argument to the data constructor +dataConImplBangs dc + = case dcRep dc of + NoDataConRep -> replicate (dcSourceArity dc) HsLazy + DCR { dcr_bangs = bangs } -> bangs + +dataConBoxer :: DataCon -> Maybe DataConBoxer +dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer +dataConBoxer _ = Nothing + +dataConInstSig + :: DataCon + -> [Type] -- Instantiate the *universal* tyvars with these types + -> ([TyCoVar], ThetaType, [Type]) -- Return instantiated existentials + -- theta and arg tys +-- ^ Instantiate the universal tyvars of a data con, +-- returning +-- ( instantiated existentials +-- , instantiated constraints including dependent GADT equalities +-- which are *also* listed in the instantiated existentials +-- , instantiated args) +dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs + , dcOrigArgTys = arg_tys }) + univ_tys + = ( ex_tvs' + , substTheta subst (dataConTheta con) + , substTys subst arg_tys) + where + univ_subst = zipTvSubst univ_tvs univ_tys + (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs + + +-- | The \"full signature\" of the 'DataCon' returns, in order: +-- +-- 1) The result of 'dataConUnivTyVars' +-- +-- 2) The result of 'dataConExTyCoVars' +-- +-- 3) The non-dependent GADT equalities. +-- Dependent GADT equalities are implied by coercion variables in +-- return value (2). +-- +-- 4) The other constraints of the data constructor type, excluding GADT +-- equalities +-- +-- 5) The original argument types to the 'DataCon' (i.e. before +-- any change of the representation of the type) +-- +-- 6) The original result type of the 'DataCon' +dataConFullSig :: DataCon + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) +dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, + dcEqSpec = eq_spec, dcOtherTheta = theta, + dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) + +dataConOrigResTy :: DataCon -> Type +dataConOrigResTy dc = dcOrigResTy dc + +-- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... +dataConStupidTheta :: DataCon -> ThetaType +dataConStupidTheta dc = dcStupidTheta dc + +dataConUserType :: DataCon -> Type +-- ^ The user-declared type of the data constructor +-- in the nice-to-read form: +-- +-- > T :: forall a b. a -> b -> T [a] +-- +-- rather than: +-- +-- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c +-- +-- The type variables are quantified in the order that the user wrote them. +-- See @Note [DataCon user type variable binders]@. +-- +-- NB: If the constructor is part of a data instance, the result type +-- mentions the family tycon, not the internal one. +dataConUserType (MkData { dcUserTyVarBinders = user_tvbs, + dcOtherTheta = theta, dcOrigArgTys = arg_tys, + dcOrigResTy = res_ty }) + = mkForAllTys user_tvbs $ + mkInvisFunTys theta $ + mkVisFunTys arg_tys $ + res_ty + +-- | Finds the instantiated types of the arguments required to construct a +-- 'DataCon' representation +-- NB: these INCLUDE any dictionary args +-- but EXCLUDE the data-declaration context, which is discarded +-- It's all post-flattening etc; this is a representation type +dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints + -- However, it can have a dcTheta (notably it can be a + -- class dictionary, with superclasses) + -> [Type] -- ^ Instantiated at these types + -> [Type] +dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs}) inst_tys + = ASSERT2( univ_tvs `equalLength` inst_tys + , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) + ASSERT2( null ex_tvs, ppr dc ) + map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc) + +-- | Returns just the instantiated /value/ argument types of a 'DataCon', +-- (excluding dictionary args) +dataConInstOrigArgTys + :: DataCon -- Works for any DataCon + -> [Type] -- Includes existential tyvar args, but NOT + -- equality constraints or dicts + -> [Type] +-- For vanilla datacons, it's all quite straightforward +-- But for the call in GHC.HsToCore.Match.Constructor, we really do want just +-- the value args +dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, + dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs}) inst_tys + = ASSERT2( tyvars `equalLength` inst_tys + , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) + map (substTy subst) arg_tys + where + tyvars = univ_tvs ++ ex_tvs + subst = zipTCvSubst tyvars inst_tys + +-- | Returns the argument types of the wrapper, excluding all dictionary arguments +-- and without substituting for any type variables +dataConOrigArgTys :: DataCon -> [Type] +dataConOrigArgTys dc = dcOrigArgTys dc + +-- | Returns the arg types of the worker, including *all* non-dependent +-- evidence, after any flattening has been done and without substituting for +-- any type variables +dataConRepArgTys :: DataCon -> [Type] +dataConRepArgTys (MkData { dcRep = rep + , dcEqSpec = eq_spec + , dcOtherTheta = theta + , dcOrigArgTys = orig_arg_tys }) + = case rep of + NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys + DCR { dcr_arg_tys = arg_tys } -> arg_tys + +-- | The string @package:module.name@ identifying a constructor, which is attached +-- to its info table and used by the GHCi debugger and the heap profiler +dataConIdentity :: DataCon -> ByteString +-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. +dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat + [ BSB.byteString $ bytesFS (unitIdFS (moduleUnitId mod)) + , BSB.int8 $ fromIntegral (ord ':') + , BSB.byteString $ bytesFS (moduleNameFS (moduleName mod)) + , BSB.int8 $ fromIntegral (ord '.') + , BSB.byteString $ bytesFS (occNameFS (nameOccName name)) + ] + where name = dataConName dc + mod = ASSERT( isExternalName name ) nameModule name + +isTupleDataCon :: DataCon -> Bool +isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc + +isUnboxedTupleCon :: DataCon -> Bool +isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc + +isUnboxedSumCon :: DataCon -> Bool +isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc + +-- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors +isVanillaDataCon :: DataCon -> Bool +isVanillaDataCon dc = dcVanilla dc + +-- | Should this DataCon be allowed in a type even without -XDataKinds? +-- Currently, only Lifted & Unlifted +specialPromotedDc :: DataCon -> Bool +specialPromotedDc = isKindTyCon . dataConTyCon + +classDataCon :: Class -> DataCon +classDataCon clas = case tyConDataCons (classTyCon clas) of + (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr + [] -> panic "classDataCon" + +dataConCannotMatch :: [Type] -> DataCon -> Bool +-- Returns True iff the data con *definitely cannot* match a +-- scrutinee of type (T tys) +-- where T is the dcRepTyCon for the data con +dataConCannotMatch tys con + -- See (U6) in Note [Implementing unsafeCoerce] + -- in base:Unsafe.Coerce + | dataConName con == unsafeReflDataConName + = False + | null inst_theta = False -- Common + | all isTyVarTy tys = False -- Also common + | otherwise = typesCantMatch (concatMap predEqs inst_theta) + where + (_, inst_theta, _) = dataConInstSig con tys + + -- TODO: could gather equalities from superclasses too + predEqs pred = case classifyPredType pred of + EqPred NomEq ty1 ty2 -> [(ty1, ty2)] + ClassPred eq args + | eq `hasKey` eqTyConKey + , [_, ty1, ty2] <- args -> [(ty1, ty2)] + | eq `hasKey` heqTyConKey + , [_, _, ty1, ty2] <- args -> [(ty1, ty2)] + _ -> [] + +-- | Were the type variables of the data con written in a different order +-- than the regular order (universal tyvars followed by existential tyvars)? +-- +-- This is not a cheap test, so we minimize its use in GHC as much as possible. +-- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in +-- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once +-- during a data constructor's lifetime. + +-- See Note [DataCon user type variable binders], as well as +-- Note [Data con wrappers and GADT syntax] for an explanation of what +-- mkDataConRep is doing with this function. +dataConUserTyVarsArePermuted :: DataCon -> Bool +dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec + , dcUserTyVarBinders = user_tvbs }) = + (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs + +{- +%************************************************************************ +%* * + Promoting of data types to the kind level +* * +************************************************************************ + +-} + +promoteDataCon :: DataCon -> TyCon +promoteDataCon (MkData { dcPromoted = tc }) = tc + +{- +************************************************************************ +* * +\subsection{Splitting products} +* * +************************************************************************ +-} + +-- | Extract the type constructor, type argument, data constructor and it's +-- /representation/ argument types from a type if it is a product type. +-- +-- Precisely, we return @Just@ for any type that is all of: +-- +-- * Concrete (i.e. constructors visible) +-- +-- * Single-constructor +-- +-- * Not existentially quantified +-- +-- Whether the type is a @data@ type or a @newtype@ +splitDataProductType_maybe + :: Type -- ^ A product type, perhaps + -> Maybe (TyCon, -- The type constructor + [Type], -- Type args of the tycon + DataCon, -- The data constructor + [Type]) -- Its /representation/ arg types + + -- Rejecting existentials is conservative. Maybe some things + -- could be made to work with them, but I'm not going to sweat + -- it through till someone finds it's important. + +splitDataProductType_maybe ty + | Just (tycon, ty_args) <- splitTyConApp_maybe ty + , Just con <- isDataProductTyCon_maybe tycon + = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) + | otherwise + = Nothing + diff --git a/compiler/GHC/Core/DataCon.hs-boot b/compiler/GHC/Core/DataCon.hs-boot new file mode 100644 index 0000000000..0d8957ea60 --- /dev/null +++ b/compiler/GHC/Core/DataCon.hs-boot @@ -0,0 +1,34 @@ +module GHC.Core.DataCon where + +import GhcPrelude +import Var( TyVar, TyCoVar, TyVarBinder ) +import Name( Name, NamedThing ) +import {-# SOURCE #-} GHC.Core.TyCon( TyCon ) +import FieldLabel ( FieldLabel ) +import Unique ( Uniquable ) +import Outputable ( Outputable, OutputableBndr ) +import BasicTypes (Arity) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, ThetaType ) + +data DataCon +data DataConRep +data EqSpec + +dataConName :: DataCon -> Name +dataConTyCon :: DataCon -> TyCon +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConUserTyVars :: DataCon -> [TyVar] +dataConUserTyVarBinders :: DataCon -> [TyVarBinder] +dataConSourceArity :: DataCon -> Arity +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] +dataConStupidTheta :: DataCon -> ThetaType +dataConFullSig :: DataCon + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) +isUnboxedSumCon :: DataCon -> Bool + +instance Eq DataCon +instance Uniquable DataCon +instance NamedThing DataCon +instance Outputable DataCon +instance OutputableBndr DataCon diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index 00c2bbfe9f..31c10045d6 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -70,12 +70,12 @@ import Unique (Uniquable (..)) import Name import VarSet import Var -import Type -import TyCoRep -import TyCoFVs -import TyCon -import CoAxiom -import FamInstEnv +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.FamInstEnv import TysPrim( funTyConName ) import Maybes( orElse ) import Util diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs new file mode 100644 index 0000000000..c8e5a7a4f9 --- /dev/null +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -0,0 +1,1833 @@ +-- (c) The University of Glasgow 2006 +-- +-- FamInstEnv: Type checked family instance declarations + +{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections, + DeriveFunctor #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Core.FamInstEnv ( + FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, + famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, + pprFamInst, pprFamInsts, + mkImportedFamInst, + + FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, + extendFamInstEnv, extendFamInstEnvList, + famInstEnvElts, famInstEnvSize, familyInstances, + + -- * CoAxioms + mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, + mkNewTypeCoAxiom, + + FamInstMatch(..), + lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, + + isDominatedBy, apartnessCheck, + + -- Injectivity + InjectivityCheckResult(..), + lookupFamInstEnvInjectivityConflicts, injectiveBranches, + + -- Normalisation + topNormaliseType, topNormaliseType_maybe, + normaliseType, normaliseTcApp, normaliseTcArgs, + reduceTyFamApp_maybe, + + -- Flattening + flattenTys + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core.Unify +import GHC.Core.Type as Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom +import VarSet +import VarEnv +import Name +import UniqDFM +import Outputable +import Maybes +import GHC.Core.Map +import Unique +import Util +import Var +import SrcLoc +import FastString +import Control.Monad +import Data.List( mapAccumL ) +import Data.Array( Array, assocs ) + +{- +************************************************************************ +* * + Type checked family instance heads +* * +************************************************************************ + +Note [FamInsts and CoAxioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* CoAxioms and FamInsts are just like + DFunIds and ClsInsts + +* A CoAxiom is a System-FC thing: it can relate any two types + +* A FamInst is a Haskell source-language thing, corresponding + to a type/data family instance declaration. + - The FamInst contains a CoAxiom, which is the evidence + for the instance + + - The LHS of the CoAxiom is always of form F ty1 .. tyn + where F is a type family +-} + +data FamInst -- See Note [FamInsts and CoAxioms] + = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom + -- introduced by this family + -- instance + -- INVARIANT: apart from freshening (see below) + -- fi_tvs = cab_tvs of the (single) axiom branch + -- fi_cvs = cab_cvs ...ditto... + -- fi_tys = cab_lhs ...ditto... + -- fi_rhs = cab_rhs ...ditto... + + , fi_flavor :: FamFlavor + + -- Everything below here is a redundant, + -- cached version of the two things above + -- except that the TyVars are freshened + , fi_fam :: Name -- Family name + + -- Used for "rough matching"; same idea as for class instances + -- See Note [Rough-match field] in GHC.Core.InstEnv + , fi_tcs :: [Maybe Name] -- Top of type args + -- INVARIANT: fi_tcs = roughMatchTcs fi_tys + + -- Used for "proper matching"; ditto + , fi_tvs :: [TyVar] -- Template tyvars for full match + , fi_cvs :: [CoVar] -- Template covars for full match + -- Like ClsInsts, these variables are always fresh + -- See Note [Template tyvars are fresh] in GHC.Core.InstEnv + + , fi_tys :: [Type] -- The LHS type patterns + -- May be eta-reduced; see Note [Eta reduction for data families] + + , fi_rhs :: Type -- the RHS, with its freshened vars + } + +data FamFlavor + = SynFamilyInst -- A synonym family + | DataFamilyInst TyCon -- A data family, with its representation TyCon + +{- +Note [Arity of data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Data family instances might legitimately be over- or under-saturated. + +Under-saturation has two potential causes: + U1) Eta reduction. See Note [Eta reduction for data families]. + U2) When the user has specified a return kind instead of written out patterns. + Example: + + data family Sing (a :: k) + data instance Sing :: Bool -> Type + + The data family tycon Sing has an arity of 2, the k and the a. But + the data instance has only one pattern, Bool (standing in for k). + This instance is equivalent to `data instance Sing (a :: Bool)`, but + without the last pattern, we have an under-saturated data family instance. + On its own, this example is not compelling enough to add support for + under-saturation, but U1 makes this feature more compelling. + +Over-saturation is also possible: + O1) If the data family's return kind is a type variable (see also #12369), + an instance might legitimately have more arguments than the family. + Example: + + data family Fix :: (Type -> k) -> k + data instance Fix f = MkFix1 (f (Fix f)) + data instance Fix f x = MkFix2 (f (Fix f x) x) + + In the first instance here, the k in the data family kind is chosen to + be Type. In the second, it's (Type -> Type). + + However, we require that any over-saturation is eta-reducible. That is, + we require that any extra patterns be bare unrepeated type variables; + see Note [Eta reduction for data families]. Accordingly, the FamInst + is never over-saturated. + +Why can we allow such flexibility for data families but not for type families? +Because data families can be decomposed -- that is, they are generative and +injective. A Type family is neither and so always must be applied to all its +arguments. +-} + +-- Obtain the axiom of a family instance +famInstAxiom :: FamInst -> CoAxiom Unbranched +famInstAxiom = fi_axiom + +-- Split the left-hand side of the FamInst +famInstSplitLHS :: FamInst -> (TyCon, [Type]) +famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs }) + = (coAxiomTyCon axiom, lhs) + +-- Get the RHS of the FamInst +famInstRHS :: FamInst -> Type +famInstRHS = fi_rhs + +-- Get the family TyCon of the FamInst +famInstTyCon :: FamInst -> TyCon +famInstTyCon = coAxiomTyCon . famInstAxiom + +-- Return the representation TyCons introduced by data family instances, if any +famInstsRepTyCons :: [FamInst] -> [TyCon] +famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] + +-- Extracts the TyCon for this *data* (or newtype) instance +famInstRepTyCon_maybe :: FamInst -> Maybe TyCon +famInstRepTyCon_maybe fi + = case fi_flavor fi of + DataFamilyInst tycon -> Just tycon + SynFamilyInst -> Nothing + +dataFamInstRepTyCon :: FamInst -> TyCon +dataFamInstRepTyCon fi + = case fi_flavor fi of + DataFamilyInst tycon -> tycon + SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) + +{- +************************************************************************ +* * + Pretty printing +* * +************************************************************************ +-} + +instance NamedThing FamInst where + getName = coAxiomName . fi_axiom + +instance Outputable FamInst where + ppr = pprFamInst + +pprFamInst :: FamInst -> SDoc +-- Prints the FamInst as a family instance declaration +-- NB: This function, FamInstEnv.pprFamInst, is used only for internal, +-- debug printing. See GHC.Core.Ppr.TyThing.pprFamInst for printing for the user +pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax + , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs }) + = hang (ppr_tc_sort <+> text "instance" + <+> pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)) + 2 (whenPprDebug debug_stuff) + where + ppr_tc_sort = case flavor of + SynFamilyInst -> text "type" + DataFamilyInst tycon + | isDataTyCon tycon -> text "data" + | isNewTyCon tycon -> text "newtype" + | isAbstractTyCon tycon -> text "data" + | otherwise -> text "WEIRD" <+> ppr tycon + + debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax + , text "Tvs:" <+> ppr tvs + , text "LHS:" <+> ppr tys + , text "RHS:" <+> ppr rhs ] + +pprFamInsts :: [FamInst] -> SDoc +pprFamInsts finsts = vcat (map pprFamInst finsts) + +{- +Note [Lazy axiom match] +~~~~~~~~~~~~~~~~~~~~~~~ +It is Vitally Important that mkImportedFamInst is *lazy* in its axiom +parameter. The axiom is loaded lazily, via a forkM, in GHC.IfaceToCore. Sometime +later, mkImportedFamInst is called using that axiom. However, the axiom +may itself depend on entities which are not yet loaded as of the time +of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the +axiom, a dependency loop spontaneously appears and GHC hangs. The solution +is simply for mkImportedFamInst never, ever to look inside of the axiom +until everything else is good and ready to do so. We can assume that this +readiness has been achieved when some other code pulls on the axiom in the +FamInst. Thus, we pattern match on the axiom lazily (in the where clause, +not in the parameter list) and we assert the consistency of names there +also. +-} + +-- Make a family instance representation from the information found in an +-- interface file. In particular, we get the rough match info from the iface +-- (instead of computing it here). +mkImportedFamInst :: Name -- Name of the family + -> [Maybe Name] -- Rough match info + -> CoAxiom Unbranched -- Axiom introduced + -> FamInst -- Resulting family instance +mkImportedFamInst fam mb_tcs axiom + = FamInst { + fi_fam = fam, + fi_tcs = mb_tcs, + fi_tvs = tvs, + fi_cvs = cvs, + fi_tys = tys, + fi_rhs = rhs, + fi_axiom = axiom, + fi_flavor = flavor } + where + -- See Note [Lazy axiom match] + ~(CoAxBranch { cab_lhs = tys + , cab_tvs = tvs + , cab_cvs = cvs + , cab_rhs = rhs }) = coAxiomSingleBranch axiom + + -- Derive the flavor for an imported FamInst rather disgustingly + -- Maybe we should store it in the IfaceFamInst? + flavor = case splitTyConApp_maybe rhs of + Just (tc, _) + | Just ax' <- tyConFamilyCoercion_maybe tc + , ax' == axiom + -> DataFamilyInst tc + _ -> SynFamilyInst + +{- +************************************************************************ +* * + FamInstEnv +* * +************************************************************************ + +Note [FamInstEnv] +~~~~~~~~~~~~~~~~~ +A FamInstEnv maps a family name to the list of known instances for that family. + +The same FamInstEnv includes both 'data family' and 'type family' instances. +Type families are reduced during type inference, but not data families; +the user explains when to use a data family instance by using constructors +and pattern matching. + +Nevertheless it is still useful to have data families in the FamInstEnv: + + - For finding overlaps and conflicts + + - For finding the representation type...see FamInstEnv.topNormaliseType + and its call site in Simplify + + - In standalone deriving instance Eq (T [Int]) we need to find the + representation type for T [Int] + +Note [Varying number of patterns for data family axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For data families, the number of patterns may vary between instances. +For example + data family T a b + data instance T Int a = T1 a | T2 + data instance T Bool [a] = T3 a + +Then we get a data type for each instance, and an axiom: + data TInt a = T1 a | T2 + data TBoolList a = T3 a + + axiom ax7 :: T Int ~ TInt -- Eta-reduced + axiom ax8 a :: T Bool [a] ~ TBoolList a + +These two axioms for T, one with one pattern, one with two; +see Note [Eta reduction for data families] + +Note [FamInstEnv determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We turn FamInstEnvs into a list in some places that don't directly affect +the ABI. That happens in family consistency checks and when producing output +for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard +to tell what it affects without following a chain of functions. It's also +easy to accidentally make that nondeterminism affect the ABI. Furthermore +the envs should be relatively small, so it should be free to use deterministic +maps here. Testing with nofib and validate detected no difference between +UniqFM and UniqDFM. +See Note [Deterministic UniqFM]. +-} + +type FamInstEnv = UniqDFM FamilyInstEnv -- Maps a family to its instances + -- See Note [FamInstEnv] + -- See Note [FamInstEnv determinism] + +type FamInstEnvs = (FamInstEnv, FamInstEnv) + -- External package inst-env, Home-package inst-env + +newtype FamilyInstEnv + = FamIE [FamInst] -- The instances for a particular family, in any order + +instance Outputable FamilyInstEnv where + ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs) + +-- INVARIANTS: +-- * The fs_tvs are distinct in each FamInst +-- of a range value of the map (so we can safely unify them) + +emptyFamInstEnvs :: (FamInstEnv, FamInstEnv) +emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv) + +emptyFamInstEnv :: FamInstEnv +emptyFamInstEnv = emptyUDFM + +famInstEnvElts :: FamInstEnv -> [FamInst] +famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts] + -- See Note [FamInstEnv determinism] + +famInstEnvSize :: FamInstEnv -> Int +famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0 + -- It's OK to use nonDetFoldUDFM here since we're just computing the + -- size. + +familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] +familyInstances (pkg_fie, home_fie) fam + = get home_fie ++ get pkg_fie + where + get env = case lookupUDFM env fam of + Just (FamIE insts) -> insts + Nothing -> [] + +extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv +extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis + +extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +extendFamInstEnv inst_env + ins_item@(FamInst {fi_fam = cls_nm}) + = addToUDFM_C add inst_env cls_nm (FamIE [ins_item]) + where + add (FamIE items) _ = FamIE (ins_item:items) + +{- +************************************************************************ +* * + Compatibility +* * +************************************************************************ + +Note [Apartness] +~~~~~~~~~~~~~~~~ +In dealing with closed type families, we must be able to check that one type +will never reduce to another. This check is called /apartness/. The check +is always between a target (which may be an arbitrary type) and a pattern. +Here is how we do it: + +apart(target, pattern) = not (unify(flatten(target), pattern)) + +where flatten (implemented in flattenTys, below) converts all type-family +applications into fresh variables. (See Note [Flattening].) + +Note [Compatibility] +~~~~~~~~~~~~~~~~~~~~ +Two patterns are /compatible/ if either of the following conditions hold: +1) The patterns are apart. +2) The patterns unify with a substitution S, and their right hand sides +equal under that substitution. + +For open type families, only compatible instances are allowed. For closed +type families, the story is slightly more complicated. Consider the following: + +type family F a where + F Int = Bool + F a = Int + +g :: Show a => a -> F a +g x = length (show x) + +Should that type-check? No. We need to allow for the possibility that 'a' +might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int +only when we can be sure that 'a' is not Int. + +To achieve this, after finding a possible match within the equations, we have to +go back to all previous equations and check that, under the +substitution induced by the match, other branches are surely apart. (See +Note [Apartness].) This is similar to what happens with class +instance selection, when we need to guarantee that there is only a match and +no unifiers. The exact algorithm is different here because the +potentially-overlapping group is closed. + +As another example, consider this: + +type family G x where + G Int = Bool + G a = Double + +type family H y +-- no instances + +Now, we want to simplify (G (H Char)). We can't, because (H Char) might later +simplify to be Int. So, (G (H Char)) is stuck, for now. + +While everything above is quite sound, it isn't as expressive as we'd like. +Consider this: + +type family J a where + J Int = Int + J a = a + +Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if +b is instantiated with Int, but the RHSs coincide there, so it's all OK. + +So, the rule is this: when looking up a branch in a closed type family, we +find a branch that matches the target, but then we make sure that the target +is apart from every previous *incompatible* branch. We don't check the +branches that are compatible with the matching branch, because they are either +irrelevant (clause 1 of compatible) or benign (clause 2 of compatible). + +Note [Compatibility of eta-reduced axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In newtype instances of data families we eta-reduce the axioms, +See Note [Eta reduction for data families] in GHC.Core.FamInstEnv. This means that +we sometimes need to test compatibility of two axioms that were eta-reduced to +different degrees, e.g.: + + +data family D a b c +newtype instance D a Int c = DInt (Maybe a) + -- D a Int ~ Maybe + -- lhs = [a, Int] +newtype instance D Bool Int Char = DIntChar Float + -- D Bool Int Char ~ Float + -- lhs = [Bool, Int, Char] + +These are obviously incompatible. We could detect this by saturating +(eta-expanding) the shorter LHS with fresh tyvars until the lists are of +equal length, but instead we can just remove the tail of the longer list, as +those types will simply unify with the freshly introduced tyvars. + +By doing this, in case the LHS are unifiable, the yielded substitution won't +mention the tyvars that appear in the tail we dropped off, and we might try +to test equality RHSes of different kinds, but that's fine since this case +occurs only for data families, where the RHS is a unique tycon and the equality +fails anyway. +-} + +-- See Note [Compatibility] +compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool +compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2 + -- See Note [Compatibility of eta-reduced axioms] + in case tcUnifyTysFG (const BindMe) commonlhs1 commonlhs2 of + SurelyApart -> True + Unifiable subst + | Type.substTyAddInScope subst rhs1 `eqType` + Type.substTyAddInScope subst rhs2 + -> True + _ -> False + +-- | Result of testing two type family equations for injectiviy. +data InjectivityCheckResult + = InjectivityAccepted + -- ^ Either RHSs are distinct or unification of RHSs leads to unification of + -- LHSs + | InjectivityUnified CoAxBranch CoAxBranch + -- ^ RHSs unify but LHSs don't unify under that substitution. Relevant for + -- closed type families where equation after unification might be + -- overlpapped (in which case it is OK if they don't unify). Constructor + -- stores axioms after unification. + +-- | Check whether two type family axioms don't violate injectivity annotation. +injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch + -> InjectivityCheckResult +injectiveBranches injectivity + ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) + ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + -- See Note [Verifying injectivity annotation], case 1. + = let getInjArgs = filterByList injectivity + in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification + Nothing -> InjectivityAccepted + -- RHS are different, so equations are injective. + -- This is case 1A from Note [Verifying injectivity annotation] + Just subst -> -- RHS unify under a substitution + let lhs1Subst = Type.substTys subst (getInjArgs lhs1) + lhs2Subst = Type.substTys subst (getInjArgs lhs2) + -- If LHSs are equal under the substitution used for RHSs then this pair + -- of equations does not violate injectivity annotation. If LHSs are not + -- equal under that substitution then this pair of equations violates + -- injectivity annotation, but for closed type families it still might + -- be the case that one LHS after substitution is unreachable. + in if eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note. + then InjectivityAccepted + else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 + , cab_rhs = Type.substTy subst rhs1 }) + ( ax2 { cab_lhs = Type.substTys subst lhs2 + , cab_rhs = Type.substTy subst rhs2 }) + -- payload of InjectivityUnified used only for check 1B2, only + -- for closed type families + +-- takes a CoAxiom with unknown branch incompatibilities and computes +-- the compatibilities +-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom +computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch] +computeAxiomIncomps branches + = snd (mapAccumL go [] branches) + where + go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) + go prev_brs cur_br + = (cur_br : prev_brs, new_br) + where + new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br } + + mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch] + mk_incomps prev_brs cur_br + = filter (not . compatibleBranches cur_br) prev_brs + +{- +************************************************************************ +* * + Constructing axioms + These functions are here because tidyType / tcUnifyTysFG + are not available in GHC.Core.Coercion.Axiom + + Also computeAxiomIncomps is too sophisticated for CoAxiom +* * +************************************************************************ + +Note [Tidy axioms when we build them] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Like types and classes, we build axioms fully quantified over all +their variables, and tidy them when we build them. For example, +we print out axioms and don't want to print stuff like + F k k a b = ... +Instead we must tidy those kind variables. See #7524. + +We could instead tidy when we print, but that makes it harder to get +things like injectivity errors to come out right. Danger of + Type family equation violates injectivity annotation. + Kind variable ‘k’ cannot be inferred from the right-hand side. + In the type family equation: + PolyKindVars @[k1] @[k2] ('[] @k1) = '[] @k2 + +Note [Always number wildcard types in CoAxBranch] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example (from the DataFamilyInstanceLHS test case): + + data family Sing (a :: k) + data instance Sing (_ :: MyKind) where + SingA :: Sing A + SingB :: Sing B + +If we're not careful during tidying, then when this program is compiled with +-ddump-types, we'll get the following information: + + COERCION AXIOMS + axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: + Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _ + +It's misleading to have a wildcard type appearing on the RHS like +that. To avoid this issue, when building a CoAxiom (which is what eventually +gets printed above), we tidy all the variables in an env that already contains +'_'. Thus, any variable named '_' will be renamed, giving us the nicer output +here: + + COERCION AXIOMS + axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: + Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1 + +Which is at least legal syntax. + +See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom; note that we +are tidying (changing OccNames only), not freshening, in accordance with +that Note. +-} + +-- all axiom roles are Nominal, as this is only used with type families +mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars + -> [TyVar] -- Extra eta tyvars + -> [CoVar] -- possibly stale covars + -> [Type] -- LHS patterns + -> Type -- RHS + -> [Role] + -> SrcSpan + -> CoAxBranch +mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc + = CoAxBranch { cab_tvs = tvs' + , cab_eta_tvs = eta_tvs' + , cab_cvs = cvs' + , cab_lhs = tidyTypes env lhs + , cab_roles = roles + , cab_rhs = tidyType env rhs + , cab_loc = loc + , cab_incomps = placeHolderIncomps } + where + (env1, tvs') = tidyVarBndrs init_tidy_env tvs + (env2, eta_tvs') = tidyVarBndrs env1 eta_tvs + (env, cvs') = tidyVarBndrs env2 cvs + -- See Note [Tidy axioms when we build them] + -- See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom + + init_occ_env = initTidyOccEnv [mkTyVarOcc "_"] + init_tidy_env = mkEmptyTidyEnv init_occ_env + -- See Note [Always number wildcard types in CoAxBranch] + +-- all of the following code is here to avoid mutual dependencies with +-- Coercion +mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched +mkBranchedCoAxiom ax_name fam_tc branches + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = manyBranches (computeAxiomIncomps branches) } + +mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched +mkUnbranchedCoAxiom ax_name fam_tc branch + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + +mkSingleCoAxiom :: Role -> Name + -> [TyVar] -> [TyVar] -> [CoVar] + -> TyCon -> [Type] -> Type + -> CoAxiom Unbranched +-- Make a single-branch CoAxiom, including making the branch itself +-- Used for both type family (Nominal) and data family (Representational) +-- axioms, hence passing in the Role +mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = role + , co_ax_implicit = False + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + where + branch = mkCoAxBranch tvs eta_tvs cvs lhs_tys rhs_ty + (map (const Nominal) tvs) + (getSrcSpan ax_name) + +-- | Create a coercion constructor (axiom) suitable for the given +-- newtype 'TyCon'. The 'Name' should be that of a new coercion +-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and +-- the type the appropriate right hand side of the @newtype@, with +-- the free variables a subset of those 'TyVar's. +mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched +mkNewTypeCoAxiom name tycon tvs roles rhs_ty + = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_implicit = True -- See Note [Implicit axioms] in GHC.Core.TyCon + , co_ax_role = Representational + , co_ax_tc = tycon + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + where + branch = mkCoAxBranch tvs [] [] (mkTyVarTys tvs) rhs_ty + roles (getSrcSpan name) + +{- +************************************************************************ +* * + Looking up a family instance +* * +************************************************************************ + +@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. +Multiple matches are only possible in case of type families (not data +families), and then, it doesn't matter which match we choose (as the +instances are guaranteed confluent). + +We return the matching family instances and the type instance at which it +matches. For example, if we lookup 'T [Int]' and have a family instance + + data instance T [a] = .. + +desugared to + + data :R42T a = .. + coe :Co:R42T a :: T [a] ~ :R42T a + +we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. +-} + +-- when matching a type family application, we get a FamInst, +-- and the list of types the axiom should be applied to +data FamInstMatch = FamInstMatch { fim_instance :: FamInst + , fim_tys :: [Type] + , fim_cos :: [Coercion] + } + -- See Note [Over-saturated matches] + +instance Outputable FamInstMatch where + ppr (FamInstMatch { fim_instance = inst + , fim_tys = tys + , fim_cos = cos }) + = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos + +lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] +lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc + = get pkg_ie ++ get home_ie + where + get ie = case lookupUDFM ie fam_tc of + Nothing -> [] + Just (FamIE fis) -> fis + +lookupFamInstEnv + :: FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnv + = lookup_fam_inst_env match + where + match _ _ tpl_tys tys = tcMatchTys tpl_tys tys + +lookupFamInstEnvConflicts + :: FamInstEnvs + -> FamInst -- Putative new instance + -> [FamInstMatch] -- Conflicting matches (don't look at the fim_tys field) +-- E.g. when we are about to add +-- f : type instance F [a] = a->a +-- we do (lookupFamInstConflicts f [b]) +-- to find conflicting matches +-- +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) + = lookup_fam_inst_env my_unify envs fam tys + where + (fam, tys) = famInstSplitLHS fam_inst + -- In example above, fam tys' = F [b] + + my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ + = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs, + (ppr fam <+> ppr tys) $$ + (ppr tpl_tvs <+> ppr tpl_tys) ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch + then Nothing + else Just noSubst + -- Note [Family instance overlap conflicts] + + noSubst = panic "lookupFamInstEnvConflicts noSubst" + new_branch = coAxiomSingleBranch new_axiom + +-------------------------------------------------------------------------------- +-- Type family injectivity checking bits -- +-------------------------------------------------------------------------------- + +{- Note [Verifying injectivity annotation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Injectivity means that the RHS of a type family uniquely determines the LHS (see +Note [Type inference for type families with injectivity]). The user informs us about +injectivity using an injectivity annotation and it is GHC's task to verify that +this annotation is correct w.r.t. type family equations. Whenever we see a new +equation of a type family we need to make sure that adding this equation to the +already known equations of a type family does not violate the injectivity annotation +supplied by the user (see Note [Injectivity annotation]). Of course if the type +family has no injectivity annotation then no check is required. But if a type +family has injectivity annotation we need to make sure that the following +conditions hold: + +1. For each pair of *different* equations of a type family, one of the following + conditions holds: + + A: RHSs are different. (Check done in GHC.Core.FamInstEnv.injectiveBranches) + + B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution + then it must be possible to unify the LHSs under the same substitution. + Example: + + type family FunnyId a = r | r -> a + type instance FunnyId Int = Int + type instance FunnyId a = a + + RHSs of these two equations unify under [ a |-> Int ] substitution. + Under this substitution LHSs are equal therefore these equations don't + violate injectivity annotation. (Check done in GHC.Core.FamInstEnv.injectiveBranches) + + B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some + substitution then either the LHSs unify under the same substitution or + the LHS of the latter equation is overlapped by earlier equations. + Example 1: + + type family SwapIntChar a = r | r -> a where + SwapIntChar Int = Char + SwapIntChar Char = Int + SwapIntChar a = a + + Say we are checking the last two equations. RHSs unify under [ a |-> + Int ] substitution but LHSs don't. So we apply the substitution to LHS + of last equation and check whether it is overlapped by any of previous + equations. Since it is overlapped by the first equation we conclude + that pair of last two equations does not violate injectivity + annotation. (Check done in TcValidity.checkValidCoAxiom#gather_conflicts) + + A special case of B is when RHSs unify with an empty substitution ie. they + are identical. + + If any of the above two conditions holds we conclude that the pair of + equations does not violate injectivity annotation. But if we find a pair + of equations where neither of the above holds we report that this pair + violates injectivity annotation because for a given RHS we don't have a + unique LHS. (Note that (B) actually implies (A).) + + Note that we only take into account these LHS patterns that were declared + as injective. + +2. If an RHS of a type family equation is a bare type variable then + all LHS variables (including implicit kind variables) also have to be bare. + In other words, this has to be a sole equation of that type family and it has + to cover all possible patterns. So for example this definition will be + rejected: + + type family W1 a = r | r -> a + type instance W1 [a] = a + + If it were accepted we could call `W1 [W1 Int]`, which would reduce to + `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`, + which is bogus. Checked FamInst.bareTvInRHSViolated. + +3. If the RHS of a type family equation is a type family application then the type + family is rejected as not injective. This is checked by FamInst.isTFHeaded. + +4. If a LHS type variable that is declared as injective is not mentioned in an + injective position in the RHS then the type family is rejected as not + injective. "Injective position" means either an argument to a type + constructor or argument to a type family on injective position. + There are subtleties here. See Note [Coverage condition for injective type families] + in FamInst. + +Check (1) must be done for all family instances (transitively) imported. Other +checks (2-4) should be done just for locally written equations, as they are checks +involving just a single equation, not about interactions. Doing the other checks for +imported equations led to #17405, as the behavior of check (4) depends on +-XUndecidableInstances (see Note [Coverage condition for injective type families] in +FamInst), which may vary between modules. + +See also Note [Injective type families] in GHC.Core.TyCon +-} + + +-- | Check whether an open type family equation can be added to already existing +-- instance environment without causing conflicts with supplied injectivity +-- annotations. Returns list of conflicting axioms (type instance +-- declarations). +lookupFamInstEnvInjectivityConflicts + :: [Bool] -- injectivity annotation for this type family instance + -- INVARIANT: list contains at least one True value + -> FamInstEnvs -- all type instances seens so far + -> FamInst -- new type instance that we're checking + -> [CoAxBranch] -- conflicting instance declarations +lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie) + fam_inst@(FamInst { fi_axiom = new_axiom }) + -- See Note [Verifying injectivity annotation]. This function implements + -- check (1.B1) for open type families described there. + = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie + where + fam = famInstTyCon fam_inst + new_branch = coAxiomSingleBranch new_axiom + + -- filtering function used by `lookup_inj_fam_conflicts` to check whether + -- a pair of equations conflicts with the injectivity annotation. + isInjConflict (FamInst { fi_axiom = old_axiom }) + | InjectivityAccepted <- + injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch + = False -- no conflict + | otherwise = True + + lookup_inj_fam_conflicts ie + | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam + = map (coAxiomSingleBranch . fi_axiom) $ + filter isInjConflict insts + | otherwise = [] + + +-------------------------------------------------------------------------------- +-- Type family overlap checking bits -- +-------------------------------------------------------------------------------- + +{- +Note [Family instance overlap conflicts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +- In the case of data family instances, any overlap is fundamentally a + conflict (as these instances imply injective type mappings). + +- In the case of type family instances, overlap is admitted as long as + the right-hand sides of the overlapping rules coincide under the + overlap substitution. eg + type instance F a Int = a + type instance F Int b = b + These two overlap on (F Int Int) but then both RHSs are Int, + so all is well. We require that they are syntactically equal; + anything else would be difficult to test for at this stage. +-} + +------------------------------------------------------------ +-- Might be a one-way match or a unifier +type MatchFun = FamInst -- The FamInst template + -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst + -> [Type] -- Target to match against + -> Maybe TCvSubst + +lookup_fam_inst_env' -- The worker, local to this module + :: MatchFun + -> FamInstEnv + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] +lookup_fam_inst_env' match_fun ie fam match_tys + | isOpenFamilyTyCon fam + , Just (FamIE insts) <- lookupUDFM ie fam + = find insts -- The common case + | otherwise = [] + where + + find [] = [] + find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs + , fi_tys = tpl_tys }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find rest + + -- Proper check + | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 + = (FamInstMatch { fim_instance = item + , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 + , fim_cos = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) + substCoVars subst tpl_cvs + }) + : find rest + + -- No match => try next + | otherwise + = find rest + where + (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys + + -- Precondition: the tycon is saturated (or over-saturated) + + -- Deal with over-saturation + -- See Note [Over-saturated matches] + split_tys tpl_tys + | isTypeFamilyTyCon fam + = pre_rough_split_tys + + | otherwise + = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys + rough_tcs = roughMatchTcs match_tys1 + in (rough_tcs, match_tys1, match_tys2) + + (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys + pre_rough_split_tys + = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2) + +lookup_fam_inst_env -- The worker, local to this module + :: MatchFun + -> FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches + +-- Precondition: the tycon is saturated (or over-saturated) + +lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys + = lookup_fam_inst_env' match_fun home_ie fam tys + ++ lookup_fam_inst_env' match_fun pkg_ie fam tys + +{- +Note [Over-saturated matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's ok to look up an over-saturated type constructor. E.g. + type family F a :: * -> * + type instance F (a,b) = Either (a->b) + +The type instance gives rise to a newtype TyCon (at a higher kind +which you can't do in Haskell!): + newtype FPair a b = FP (Either (a->b)) + +Then looking up (F (Int,Bool) Char) will return a FamInstMatch + (FPair, [Int,Bool,Char]) +The "extra" type argument [Char] just stays on the end. + +We handle data families and type families separately here: + + * For type families, all instances of a type family must have the + same arity, so we can precompute the split between the match_tys + and the overflow tys. This is done in pre_rough_split_tys. + + * For data family instances, though, we need to re-split for each + instance, because the breakdown might be different for each + instance. Why? Because of eta reduction; see + Note [Eta reduction for data families]. +-} + +-- checks if one LHS is dominated by a list of other branches +-- in other words, if an application would match the first LHS, it is guaranteed +-- to match at least one of the others. The RHSs are ignored. +-- This algorithm is conservative: +-- True -> the LHS is definitely covered by the others +-- False -> no information +-- It is currently (Oct 2012) used only for generating errors for +-- inaccessible branches. If these errors go unreported, no harm done. +-- This is defined here to avoid a dependency from CoAxiom to Unify +isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool +isDominatedBy branch branches + = or $ map match branches + where + lhs = coAxBranchLHS branch + match (CoAxBranch { cab_lhs = tys }) + = isJust $ tcMatchTys tys lhs + +{- +************************************************************************ +* * + Choosing an axiom application +* * +************************************************************************ + +The lookupFamInstEnv function does a nice job for *open* type families, +but we also need to handle closed ones when normalising a type: +-} + +reduceTyFamApp_maybe :: FamInstEnvs + -> Role -- Desired role of result coercion + -> TyCon -> [Type] + -> Maybe (Coercion, Type) +-- Attempt to do a *one-step* reduction of a type-family application +-- but *not* newtypes +-- Works on type-synonym families always; data-families only if +-- the role we seek is representational +-- It does *not* normalise the type arguments first, so this may not +-- go as far as you want. If you want normalised type arguments, +-- use normaliseTcArgs first. +-- +-- The TyCon can be oversaturated. +-- Works on both open and closed families +-- +-- Always returns a *homogeneous* coercion -- type family reductions are always +-- homogeneous +reduceTyFamApp_maybe envs role tc tys + | Phantom <- role + = Nothing + + | case role of + Representational -> isOpenFamilyTyCon tc + _ -> isOpenTypeFamilyTyCon tc + -- If we seek a representational coercion + -- (e.g. the call in topNormaliseType_maybe) then we can + -- unwrap data families as well as type-synonym families; + -- otherwise only type-synonym families + , FamInstMatch { fim_instance = FamInst { fi_axiom = ax } + , fim_tys = inst_tys + , fim_cos = inst_cos } : _ <- lookupFamInstEnv envs tc tys + -- NB: Allow multiple matches because of compatible overlap + + = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos + ty = coercionRKind co + in Just (co, ty) + + | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc + , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys + = let co = mkAxInstCo role ax ind inst_tys inst_cos + ty = coercionRKind co + in Just (co, ty) + + | Just ax <- isBuiltInSynFamTyCon_maybe tc + , Just (coax,ts,ty) <- sfMatchFam ax tys + = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) + in Just (co, ty) + + | otherwise + = Nothing + +-- The axiom can be oversaturated. (Closed families only.) +chooseBranch :: CoAxiom Branched -> [Type] + -> Maybe (BranchIndex, [Type], [Coercion]) -- found match, with args +chooseBranch axiom tys + = do { let num_pats = coAxiomNumPats axiom + (target_tys, extra_tys) = splitAt num_pats tys + branches = coAxiomBranches axiom + ; (ind, inst_tys, inst_cos) + <- findBranch (unMkBranches branches) target_tys + ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) } + +-- The axiom must *not* be oversaturated +findBranch :: Array BranchIndex CoAxBranch + -> [Type] + -> Maybe (BranchIndex, [Type], [Coercion]) + -- coercions relate requested types to returned axiom LHS at role N +findBranch branches target_tys + = foldr go Nothing (assocs branches) + where + go :: (BranchIndex, CoAxBranch) + -> Maybe (BranchIndex, [Type], [Coercion]) + -> Maybe (BranchIndex, [Type], [Coercion]) + go (index, branch) other + = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs + , cab_lhs = tpl_lhs + , cab_incomps = incomps }) = branch + in_scope = mkInScopeSet (unionVarSets $ + map (tyCoVarsOfTypes . coAxBranchLHS) incomps) + -- See Note [Flattening] below + flattened_target = flattenTys in_scope target_tys + in case tcMatchTys tpl_lhs target_tys of + Just subst -- matching worked. now, check for apartness. + | apartnessCheck flattened_target branch + -> -- matching worked & we're apart from all incompatible branches. + -- success + ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) + Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) + + -- failure. keep looking + _ -> other + +-- | Do an apartness check, as described in the "Closed Type Families" paper +-- (POPL '14). This should be used when determining if an equation +-- ('CoAxBranch') of a closed type family can be used to reduce a certain target +-- type family application. +apartnessCheck :: [Type] -- ^ /flattened/ target arguments. Make sure + -- they're flattened! See Note [Flattening]. + -- (NB: This "flat" is a different + -- "flat" than is used in TcFlatten.) + -> CoAxBranch -- ^ the candidate equation we wish to use + -- Precondition: this matches the target + -> Bool -- ^ True <=> equation can fire +apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps }) + = all (isSurelyApart + . tcUnifyTysFG (const BindMe) flattened_target + . coAxBranchLHS) incomps + where + isSurelyApart SurelyApart = True + isSurelyApart _ = False + +{- +************************************************************************ +* * + Looking up a family instance +* * +************************************************************************ + +Note [Normalising types] +~~~~~~~~~~~~~~~~~~~~~~~~ +The topNormaliseType function removes all occurrences of type families +and newtypes from the top-level structure of a type. normaliseTcApp does +the type family lookup and is fairly straightforward. normaliseType is +a little more involved. + +The complication comes from the fact that a type family might be used in the +kind of a variable bound in a forall. We wish to remove this type family +application, but that means coming up with a fresh variable (with the new +kind). Thus, we need a substitution to be built up as we recur through the +type. However, an ordinary TCvSubst just won't do: when we hit a type variable +whose kind has changed during normalisation, we need both the new type +variable *and* the coercion. We could conjure up a new VarEnv with just this +property, but a usable substitution environment already exists: +LiftingContexts from the liftCoSubst family of functions, defined in GHC.Core.Coercion. +A LiftingContext maps a type variable to a coercion and a coercion variable to +a pair of coercions. Let's ignore coercion variables for now. Because the +coercion a type variable maps to contains the destination type (via +coercionKind), we don't need to store that destination type separately. Thus, +a LiftingContext has what we need: a map from type variables to (Coercion, +Type) pairs. + +We also benefit because we can piggyback on the liftCoSubstVarBndr function to +deal with binders. However, I had to modify that function to work with this +application. Thus, we now have liftCoSubstVarBndrUsing, which takes +a function used to process the kind of the binder. We don't wish +to lift the kind, but instead normalise it. So, we pass in a callback function +that processes the kind of the binder. + +After that brilliant explanation of all this, I'm sure you've forgotten the +dangling reference to coercion variables. What do we do with those? Nothing at +all. The point of normalising types is to remove type family applications, but +there's no sense in removing these from coercions. We would just get back a +new coercion witnessing the equality between the same types as the original +coercion. Because coercions are irrelevant anyway, there is no point in doing +this. So, whenever we encounter a coercion, we just say that it won't change. +That's what the CoercionTy case is doing within normalise_type. + +Note [Normalisation and type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to be a bit careful about normalising in the presence of type +synonyms (#13035). Suppose S is a type synonym, and we have + S t1 t2 +If S is family-free (on its RHS) we can just normalise t1 and t2 and +reconstruct (S t1' t2'). Expanding S could not reveal any new redexes +because type families are saturated. + +But if S has a type family on its RHS we expand /before/ normalising +the args t1, t2. If we normalise t1, t2 first, we'll re-normalise them +after expansion, and that can lead to /exponential/ behaviour; see #13035. + +Notice, though, that expanding first can in principle duplicate t1,t2, +which might contain redexes. I'm sure you could conjure up an exponential +case by that route too, but it hasn't happened in practice yet! +-} + +topNormaliseType :: FamInstEnvs -> Type -> Type +topNormaliseType env ty = case topNormaliseType_maybe env ty of + Just (_co, ty') -> ty' + Nothing -> ty + +topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type) + +-- ^ Get rid of *outermost* (or toplevel) +-- * type function redex +-- * data family redex +-- * newtypes +-- returning an appropriate Representational coercion. Specifically, if +-- topNormaliseType_maybe env ty = Just (co, ty') +-- then +-- (a) co :: ty ~R ty' +-- (b) ty' is not a newtype, and is not a type-family or data-family redex +-- +-- However, ty' can be something like (Maybe (F ty)), where +-- (F ty) is a redex. +-- +-- Always operates homogeneously: the returned type has the same kind as the +-- original type, and the returned coercion is always homogeneous. +topNormaliseType_maybe env ty + = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty + ; return $ case mkind_co of + MRefl -> (co, nty) + MCo kind_co -> let nty_casted = nty `mkCastTy` mkSymCo kind_co + final_co = mkCoherenceRightCo Representational nty + (mkSymCo kind_co) co + in (final_co, nty_casted) } + where + stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper + + combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2) + + unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN) + unwrapNewTypeStepper' rec_nts tc tys + = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys + + -- second coercion below is the kind coercion relating the original type's kind + -- to the normalised type's kind + tyFamStepper :: NormaliseStepper (Coercion, MCoercionN) + tyFamStepper rec_nts tc tys -- Try to step a type/data family + = let (args_co, ntys, res_co) = normaliseTcArgs env Representational tc tys in + case reduceTyFamApp_maybe env Representational tc ntys of + Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co, MCo res_co) + _ -> NS_Done + +--------------- +normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) +-- See comments on normaliseType for the arguments of this function +normaliseTcApp env role tc tys + = initNormM env role (tyCoVarsOfTypes tys) $ + normalise_tc_app tc tys + +-- See Note [Normalising types] about the LiftingContext +normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type) +normalise_tc_app tc tys + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + , not (isFamFreeTyCon tc) -- Expand and try again + = -- A synonym with type families in the RHS + -- Expand and try again + -- See Note [Normalisation and type synonyms] + normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + + | isFamilyTyCon tc + = -- A type-family application + do { env <- getEnv + ; role <- getRole + ; (args_co, ntys, res_co) <- normalise_tc_args tc tys + ; case reduceTyFamApp_maybe env role tc ntys of + Just (first_co, ty') + -> do { (rest_co,nty) <- normalise_type ty' + ; return (assemble_result role nty + (args_co `mkTransCo` first_co `mkTransCo` rest_co) + res_co) } + _ -> -- No unique matching family instance exists; + -- we do not do anything + return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } + + | otherwise + = -- A synonym with no type families in the RHS; or data type etc + -- Just normalise the arguments and rebuild + do { (args_co, ntys, res_co) <- normalise_tc_args tc tys + ; role <- getRole + ; return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } + + where + assemble_result :: Role -- r, ambient role in NormM monad + -> Type -- nty, result type, possibly of changed kind + -> Coercion -- orig_ty ~r nty, possibly heterogeneous + -> CoercionN -- typeKind(orig_ty) ~N typeKind(nty) + -> (Coercion, Type) -- (co :: orig_ty ~r nty_casted, nty_casted) + -- where nty_casted has same kind as orig_ty + assemble_result r nty orig_to_nty kind_co + = ( final_co, nty_old_kind ) + where + nty_old_kind = nty `mkCastTy` mkSymCo kind_co + final_co = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty + +--------------- +-- | Normalise arguments to a tycon +normaliseTcArgs :: FamInstEnvs -- ^ env't with family instances + -> Role -- ^ desired role of output coercion + -> TyCon -- ^ tc + -> [Type] -- ^ tys + -> (Coercion, [Type], CoercionN) + -- ^ co :: tc tys ~ tc new_tys + -- NB: co might not be homogeneous + -- last coercion :: kind(tc tys) ~ kind(tc new_tys) +normaliseTcArgs env role tc tys + = initNormM env role (tyCoVarsOfTypes tys) $ + normalise_tc_args tc tys + +normalise_tc_args :: TyCon -> [Type] -- tc tys + -> NormM (Coercion, [Type], CoercionN) + -- (co, new_tys), where + -- co :: tc tys ~ tc new_tys; might not be homogeneous + -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys) +normalise_tc_args tc tys + = do { role <- getRole + ; (args_cos, nargs, res_co) <- normalise_args (tyConKind tc) (tyConRolesX role tc) tys + ; return (mkTyConAppCo role tc args_cos, nargs, res_co) } + +--------------- +normaliseType :: FamInstEnvs + -> Role -- desired role of coercion + -> Type -> (Coercion, Type) +normaliseType env role ty + = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty + +normalise_type :: Type -- old type + -> NormM (Coercion, Type) -- (coercion, new type), where + -- co :: old-type ~ new_type +-- Normalise the input type, by eliminating *all* type-function redexes +-- but *not* newtypes (which are visible to the programmer) +-- Returns with Refl if nothing happens +-- Does nothing to newtypes +-- The returned coercion *must* be *homogeneous* +-- See Note [Normalising types] +-- Try not to disturb type synonyms if possible + +normalise_type ty + = go ty + where + go (TyConApp tc tys) = normalise_tc_app tc tys + go ty@(LitTy {}) = do { r <- getRole + ; return (mkReflCo r ty, ty) } + + go (AppTy ty1 ty2) = go_app_tys ty1 [ty2] + + go ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) + = do { (co1, nty1) <- go ty1 + ; (co2, nty2) <- go ty2 + ; r <- getRole + ; return (mkFunCo r co1 co2, ty { ft_arg = nty1, ft_res = nty2 }) } + go (ForAllTy (Bndr tcvar vis) ty) + = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar + ; (co, nty) <- withLC lc' $ normalise_type ty + ; let tv2 = setTyVarKind tv' ki' + ; return (mkForAllCo tv' h co, ForAllTy (Bndr tv2 vis) nty) } + go (TyVarTy tv) = normalise_tyvar tv + go (CastTy ty co) + = do { (nco, nty) <- go ty + ; lc <- getLC + ; let co' = substRightCo lc co + ; return (castCoercionKind nco Nominal ty nty co co' + , mkCastTy nty co') } + go (CoercionTy co) + = do { lc <- getLC + ; r <- getRole + ; let right_co = substRightCo lc co + ; return ( mkProofIrrelCo r + (liftCoSubst Nominal lc (coercionType co)) + co right_co + , mkCoercionTy right_co ) } + + go_app_tys :: Type -- function + -> [Type] -- args + -> NormM (Coercion, Type) + -- cf. TcFlatten.flatten_app_ty_args + go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys) + go_app_tys fun_ty arg_tys + = do { (fun_co, nfun) <- go fun_ty + ; case tcSplitTyConApp_maybe nfun of + Just (tc, xis) -> + do { (second_co, nty) <- go (mkTyConApp tc (xis ++ arg_tys)) + -- flatten_app_ty_args avoids redundantly processing the xis, + -- but that's a much more performance-sensitive function. + -- This type normalisation is not called in a loop. + ; return (mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransCo` second_co, nty) } + Nothing -> + do { (args_cos, nargs, res_co) <- normalise_args (typeKind nfun) + (repeat Nominal) + arg_tys + ; role <- getRole + ; let nty = mkAppTys nfun nargs + nco = mkAppCos fun_co args_cos + nty_casted = nty `mkCastTy` mkSymCo res_co + final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco + ; return (final_co, nty_casted) } } + +normalise_args :: Kind -- of the function + -> [Role] -- roles at which to normalise args + -> [Type] -- args + -> NormM ([Coercion], [Type], Coercion) +-- returns (cos, xis, res_co), where each xi is the normalised +-- version of the corresponding type, each co is orig_arg ~ xi, +-- and the res_co :: kind(f orig_args) ~ kind(f xis) +-- NB: The xis might *not* have the same kinds as the input types, +-- but the resulting application *will* be well-kinded +-- cf. TcFlatten.flatten_args_slow +normalise_args fun_ki roles args + = do { normed_args <- zipWithM normalise1 roles args + ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args + ; return (map mkSymCo cos, xis, mkSymCo res_co) } + where + (ki_binders, inner_ki) = splitPiTys fun_ki + fvs = tyCoVarsOfTypes args + + -- flattener conventions are different from ours + impedance_match :: NormM (Coercion, Type) -> NormM (Type, Coercion) + impedance_match action = do { (co, ty) <- action + ; return (ty, mkSymCo co) } + + normalise1 role ty + = impedance_match $ withRole role $ normalise_type ty + +normalise_tyvar :: TyVar -> NormM (Coercion, Type) +normalise_tyvar tv + = ASSERT( isTyVar tv ) + do { lc <- getLC + ; r <- getRole + ; return $ case liftCoSubstTyVar lc r tv of + Just co -> (co, coercionRKind co) + Nothing -> (mkReflCo r ty, ty) } + where ty = mkTyVarTy tv + +normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Coercion, Kind) +normalise_var_bndr tcvar + -- works for both tvar and covar + = do { lc1 <- getLC + ; env <- getEnv + ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal + ; return $ liftCoSubstVarBndrUsing callback lc1 tcvar } + +-- | a monad for the normalisation functions, reading 'FamInstEnvs', +-- a 'LiftingContext', and a 'Role'. +newtype NormM a = NormM { runNormM :: + FamInstEnvs -> LiftingContext -> Role -> a } + deriving (Functor) + +initNormM :: FamInstEnvs -> Role + -> TyCoVarSet -- the in-scope variables + -> NormM a -> a +initNormM env role vars (NormM thing_inside) + = thing_inside env lc role + where + in_scope = mkInScopeSet vars + lc = emptyLiftingContext in_scope + +getRole :: NormM Role +getRole = NormM (\ _ _ r -> r) + +getLC :: NormM LiftingContext +getLC = NormM (\ _ lc _ -> lc) + +getEnv :: NormM FamInstEnvs +getEnv = NormM (\ env _ _ -> env) + +withRole :: Role -> NormM a -> NormM a +withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r + +withLC :: LiftingContext -> NormM a -> NormM a +withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r + +instance Monad NormM where + ma >>= fmb = NormM $ \env lc r -> + let a = runNormM ma env lc r in + runNormM (fmb a) env lc r + +instance Applicative NormM where + pure x = NormM $ \ _ _ _ -> x + (<*>) = ap + +{- +************************************************************************ +* * + Flattening +* * +************************************************************************ + +Note [Flattening] +~~~~~~~~~~~~~~~~~ +As described in "Closed type families with overlapping equations" +http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf +we need to flatten core types before unifying them, when checking for "surely-apart" +against earlier equations of a closed type family. +Flattening means replacing all top-level uses of type functions with +fresh variables, *taking care to preserve sharing*. That is, the type +(Either (F a b) (F a b)) should flatten to (Either c c), never (Either +c d). + +Here is a nice example of why it's all necessary: + + type family F a b where + F Int Bool = Char + F a b = Double + type family G a -- open, no instances + +How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match, +while the second equation does. But, before reducing, we must make sure that the +target can never become (F Int Bool). Well, no matter what G Float becomes, it +certainly won't become *both* Int and Bool, so indeed we're safe reducing +(F (G Float) (G Float)) to Double. + +This is necessary not only to get more reductions (which we might be +willing to give up on), but for substitutivity. If we have (F x x), we +can see that (F x x) can reduce to Double. So, it had better be the +case that (F blah blah) can reduce to Double, no matter what (blah) +is! Flattening as done below ensures this. + +The algorithm works by building up a TypeMap TyVar, mapping +type family applications to fresh variables. This mapping must +be threaded through all the function calls, as any entry in +the mapping must be propagated to all future nodes in the tree. + +The algorithm also must track the set of in-scope variables, in +order to make fresh variables as it flattens. (We are far from a +source of fresh Uniques.) See Wrinkle 2, below. + +There are wrinkles, of course: + +1. The flattening algorithm must account for the possibility + of inner `forall`s. (A `forall` seen here can happen only + because of impredicativity. However, the flattening operation + is an algorithm in Core, which is impredicative.) + Suppose we have (forall b. F b) -> (forall b. F b). Of course, + those two bs are entirely unrelated, and so we should certainly + not flatten the two calls F b to the same variable. Instead, they + must be treated separately. We thus carry a substitution that + freshens variables; we must apply this substitution (in + `coreFlattenTyFamApp`) before looking up an application in the environment. + Note that the range of the substitution contains only TyVars, never anything + else. + + For the sake of efficiency, we only apply this substitution when absolutely + necessary. Namely: + + * We do not perform the substitution at all if it is empty. + * We only need to worry about the arguments of a type family that are within + the arity of said type family, so we can get away with not applying the + substitution to any oversaturated type family arguments. + * Importantly, we do /not/ achieve this substitution by recursively + flattening the arguments, as this would be wrong. Consider `F (G a)`, + where F and G are type families. We might decide that `F (G a)` flattens + to `beta`. Later, the substitution is non-empty (but does not map `a`) and + so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course, + `F gamma` is unknown, and so we flatten it to `delta`, but it really + should have been `beta`! Argh! + + Moral of the story: instead of flattening the arguments, just substitute + them directly. + +2. There are two different reasons we might add a variable + to the in-scope set as we work: + + A. We have just invented a new flattening variable. + B. We have entered a `forall`. + + Annoying here is that in-scope variable source (A) must be + threaded through the calls. For example, consider (F b -> forall c. F c). + Suppose that, when flattening F b, we invent a fresh variable c. + Now, when we encounter (forall c. F c), we need to know c is already in + scope so that we locally rename c to c'. However, if we don't thread through + the in-scope set from one argument of (->) to the other, we won't know this + and might get very confused. + + In contrast, source (B) increases only as we go deeper, as in-scope sets + normally do. However, even here we must be careful. The TypeMap TyVar that + contains mappings from type family applications to freshened variables will + be threaded through both sides of (forall b. F b) -> (forall b. F b). We + thus must make sure that the two `b`s don't get renamed to the same b1. (If + they did, then looking up `F b1` would yield the same flatten var for + each.) So, even though `forall`-bound variables should really be in the + in-scope set only when they are in scope, we retain these variables even + outside of their scope. This ensures that, if we encounter a fresh + `forall`-bound b, we will rename it to b2, not b1. Note that keeping a + larger in-scope set than strictly necessary is always OK, as in-scope sets + are only ever used to avoid collisions. + + Sadly, the freshening substitution described in (1) really mustn't bind + variables outside of their scope: note that its domain is the *unrenamed* + variables. This means that the substitution gets "pushed down" (like a + reader monad) while the in-scope set gets threaded (like a state monad). + Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst; + instead, we just carry a TvSubstEnv down, tying it to the InScopeSet + traveling separately as necessary. + +3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k: + + type family F ty_1 ... ty_k :: res_k + + It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a + flattening skolem. But we must instead flatten it to + `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the + type family. + + Why is this better? Consider the following concrete example from #16995: + + type family Param :: Type -> Type + + type family LookupParam (a :: Type) :: Type where + LookupParam (f Char) = Bool + LookupParam x = Int + + foo :: LookupParam (Param ()) + foo = 42 + + In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to + `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if + `alpha` is apart from `f Char`, so it won't fall through to the second + equation. But since the `Param` type family has arity 0, we can instead + flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is + apart from `f Char`, permitting the second equation to be reached. + + Not only does this allow more programs to be accepted, it's also important + for correctness. Not doing this was the root cause of the Core Lint error + in #16995. + +flattenTys is defined here because of module dependencies. +-} + +data FlattenEnv + = FlattenEnv { fe_type_map :: TypeMap TyVar + -- domain: exactly-saturated type family applications + -- range: fresh variables + , fe_in_scope :: InScopeSet } + -- See Note [Flattening] + +emptyFlattenEnv :: InScopeSet -> FlattenEnv +emptyFlattenEnv in_scope + = FlattenEnv { fe_type_map = emptyTypeMap + , fe_in_scope = in_scope } + +updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv +updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) } + +flattenTys :: InScopeSet -> [Type] -> [Type] +-- See Note [Flattening] +-- NB: the returned types may mention fresh type variables, +-- arising from the flattening. We don't return the +-- mapping from those fresh vars to the ty-fam +-- applications they stand for (we could, but no need) +flattenTys in_scope tys + = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys + +coreFlattenTys :: TvSubstEnv -> FlattenEnv + -> [Type] -> (FlattenEnv, [Type]) +coreFlattenTys subst = mapAccumL (coreFlattenTy subst) + +coreFlattenTy :: TvSubstEnv -> FlattenEnv + -> Type -> (FlattenEnv, Type) +coreFlattenTy subst = go + where + go env ty | Just ty' <- coreView ty = go env ty' + + go env (TyVarTy tv) + | Just ty <- lookupVarEnv subst tv = (env, ty) + | otherwise = let (env', ki) = go env (tyVarKind tv) in + (env', mkTyVarTy $ setTyVarKind tv ki) + go env (AppTy ty1 ty2) = let (env1, ty1') = go env ty1 + (env2, ty2') = go env1 ty2 in + (env2, AppTy ty1' ty2') + go env (TyConApp tc tys) + -- NB: Don't just check if isFamilyTyCon: this catches *data* families, + -- which are generative and thus can be preserved during flattening + | not (isGenerativeTyCon tc Nominal) + = coreFlattenTyFamApp subst env tc tys + + | otherwise + = let (env', tys') = coreFlattenTys subst env tys in + (env', mkTyConApp tc tys') + + go env ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) + = let (env1, ty1') = go env ty1 + (env2, ty2') = go env1 ty2 in + (env2, ty { ft_arg = ty1', ft_res = ty2' }) + + go env (ForAllTy (Bndr tv vis) ty) + = let (env1, subst', tv') = coreFlattenVarBndr subst env tv + (env2, ty') = coreFlattenTy subst' env1 ty in + (env2, ForAllTy (Bndr tv' vis) ty') + + go env ty@(LitTy {}) = (env, ty) + + go env (CastTy ty co) + = let (env1, ty') = go env ty + (env2, co') = coreFlattenCo subst env1 co in + (env2, CastTy ty' co') + + go env (CoercionTy co) + = let (env', co') = coreFlattenCo subst env co in + (env', CoercionTy co') + +-- when flattening, we don't care about the contents of coercions. +-- so, just return a fresh variable of the right (flattened) type +coreFlattenCo :: TvSubstEnv -> FlattenEnv + -> Coercion -> (FlattenEnv, Coercion) +coreFlattenCo subst env co + = (env2, mkCoVarCo covar) + where + (env1, kind') = coreFlattenTy subst env (coercionType co) + covar = mkFlattenFreshCoVar (fe_in_scope env1) kind' + -- Add the covar to the FlattenEnv's in-scope set. + -- See Note [Flattening], wrinkle 2A. + env2 = updateInScopeSet env1 (flip extendInScopeSet covar) + +coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv + -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar) +coreFlattenVarBndr subst env tv + = (env2, subst', tv') + where + -- See Note [Flattening], wrinkle 2B. + kind = varType tv + (env1, kind') = coreFlattenTy subst env kind + tv' = uniqAway (fe_in_scope env1) (setVarType tv kind') + subst' = extendVarEnv subst tv (mkTyVarTy tv') + env2 = updateInScopeSet env1 (flip extendInScopeSet tv') + +coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv + -> TyCon -- type family tycon + -> [Type] -- args, already flattened + -> (FlattenEnv, Type) +coreFlattenTyFamApp tv_subst env fam_tc fam_args + = case lookupTypeMap type_map fam_ty of + Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args') + Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc + tv = uniqAway in_scope $ + mkTyVar tyvar_name (typeKind fam_ty) + + ty' = mkAppTys (mkTyVarTy tv) leftover_args' + env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv + , fe_in_scope = extendInScopeSet in_scope tv } + in (env'', ty') + where + arity = tyConArity fam_tc + tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv + (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args ) + splitAt arity fam_args + -- Apply the substitution before looking up an application in the + -- environment. See Note [Flattening], wrinkle 1. + -- NB: substTys short-cuts the common case when the substitution is empty. + sat_fam_args' = substTys tcv_subst sat_fam_args + (env', leftover_args') = coreFlattenTys tv_subst env leftover_args + -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening], + -- wrinkle 3), so we split it into the arguments needed to saturate it + -- (sat_fam_args') and the rest (leftover_args') + fam_ty = mkTyConApp fam_tc sat_fam_args' + FlattenEnv { fe_type_map = type_map + , fe_in_scope = in_scope } = env' + +mkFlattenFreshTyName :: Uniquable a => a -> Name +mkFlattenFreshTyName unq + = mkSysTvName (getUnique unq) (fsLit "flt") + +mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar +mkFlattenFreshCoVar in_scope kind + = let uniq = unsafeGetFreshLocalUnique in_scope + name = mkSystemVarName uniq (fsLit "flc") + in mkCoVar name kind diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs new file mode 100644 index 0000000000..51c1db1b25 --- /dev/null +++ b/compiler/GHC/Core/InstEnv.hs @@ -0,0 +1,1030 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[InstEnv]{Utilities for typechecking instance declarations} + +The bits common to TcInstDcls and TcDeriv. +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module GHC.Core.InstEnv ( + DFunId, InstMatch, ClsInstLookupResult, + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, + instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, + instanceDFunId, updateClsInstDFun, instanceRoughTcs, + fuzzyClsInstCmp, orphNamesOfClsInst, + + InstEnvs(..), VisibleOrphanModules, InstEnv, + emptyInstEnv, extendInstEnv, + deleteFromInstEnv, deleteDFunFromInstEnv, + identicalClsInstHead, + extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses, + memberInstEnv, + instIsVisible, + classInstances, instanceBindFun, + instanceCantMatch, roughMatchTcs, + isOverlappable, isOverlapping, isIncoherent + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TcType -- InstEnv is really part of the type checker, + -- and depends on TcType in many ways +import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) +import Module +import GHC.Core.Class +import Var +import VarSet +import Name +import NameSet +import GHC.Core.Unify +import Outputable +import ErrUtils +import BasicTypes +import UniqDFM +import Util +import Id +import Data.Data ( Data ) +import Data.Maybe ( isJust, isNothing ) + +{- +************************************************************************ +* * + ClsInst: the data type for type-class instances +* * +************************************************************************ +-} + +-- | A type-class instance. Note that there is some tricky laziness at work +-- here. See Note [ClsInst laziness and the rough-match fields] for more +-- details. +data ClsInst + = ClsInst { -- Used for "rough matching"; see + -- Note [ClsInst laziness and the rough-match fields] + -- INVARIANT: is_tcs = roughMatchTcs is_tys + is_cls_nm :: Name -- ^ Class name + , is_tcs :: [Maybe Name] -- ^ Top of type args + + -- | @is_dfun_name = idName . is_dfun@. + -- + -- We use 'is_dfun_name' for the visibility check, + -- 'instIsVisible', which needs to know the 'Module' which the + -- dictionary is defined in. However, we cannot use the 'Module' + -- attached to 'is_dfun' since doing so would mean we would + -- potentially pull in an entire interface file unnecessarily. + -- This was the cause of #12367. + , is_dfun_name :: Name + + -- Used for "proper matching"; see Note [Proper-match fields] + , is_tvs :: [TyVar] -- Fresh template tyvars for full match + -- See Note [Template tyvars are fresh] + , is_cls :: Class -- The real class + , is_tys :: [Type] -- Full arg types (mentioning is_tvs) + -- INVARIANT: is_dfun Id has type + -- forall is_tvs. (...) => is_cls is_tys + -- (modulo alpha conversion) + + , is_dfun :: DFunId -- See Note [Haddock assumptions] + + , is_flag :: OverlapFlag -- See detailed comments with + -- the decl of BasicTypes.OverlapFlag + , is_orphan :: IsOrphan + } + deriving Data + +-- | A fuzzy comparison function for class instances, intended for sorting +-- instances before displaying them to the user. +fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering +fuzzyClsInstCmp x y = + stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend` + mconcat (map cmp (zip (is_tcs x) (is_tcs y))) + where + cmp (Nothing, Nothing) = EQ + cmp (Nothing, Just _) = LT + cmp (Just _, Nothing) = GT + cmp (Just x, Just y) = stableNameCmp x y + +isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool +isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) +isOverlapping i = hasOverlappingFlag (overlapMode (is_flag i)) +isIncoherent i = hasIncoherentFlag (overlapMode (is_flag i)) + +{- +Note [ClsInst laziness and the rough-match fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is +otherwise unused in the program. Then it's stupid to load B.hi, the data type +declaration for B.T -- and perhaps further instance declarations! + +We avoid this as follows: + +* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's + content. + +* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys + contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we + poke any of these fields we'll typecheck the DFunId declaration, and hence + pull in interfaces that it refers to. See Note [Proper-match fields]. + +* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and + is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking + inside the DFunId. The rough-match fields allow us to say "definitely does not + match", based only on Names. + + This laziness is very important; see #12367. Try hard to avoid pulling on + the structured fields unless you really need the instance. + +* Another place to watch is InstEnv.instIsVisible, which needs the module to + which the ClsInst belongs. We can get this from is_dfun_name. + +* In is_tcs, + Nothing means that this type arg is a type variable + + (Just n) means that this type arg is a + TyConApp with a type constructor of n. + This is always a real tycon, never a synonym! + (Two different synonyms might match, but two + different real tycons can't.) + NB: newtypes are not transparent, though! +-} + +{- +Note [Template tyvars are fresh] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_tvs field of a ClsInst has *completely fresh* tyvars. +That is, they are + * distinct from any other ClsInst + * distinct from any tyvars free in predicates that may + be looked up in the class instance environment +Reason for freshness: we use unification when checking for overlap +etc, and that requires the tyvars to be distinct. + +The invariant is checked by the ASSERT in lookupInstEnv'. + +Note [Proper-match fields] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_tvs, is_cls, is_tys fields are simply cached values, pulled +out (lazily) from the dfun id. They are cached here simply so +that we don't need to decompose the DFunId each time we want +to match it. The hope is that the rough-match fields mean +that we often never poke the proper-match fields. + +However, note that: + * is_tvs must be a superset of the free vars of is_tys + + * is_tvs, is_tys may be alpha-renamed compared to the ones in + the dfun Id + +Note [Haddock assumptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For normal user-written instances, Haddock relies on + + * the SrcSpan of + * the Name of + * the is_dfun of + * an Instance + +being equal to + + * the SrcSpan of + * the instance head type of + * the InstDecl used to construct the Instance. +-} + +instanceDFunId :: ClsInst -> DFunId +instanceDFunId = is_dfun + +updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst +updateClsInstDFun tidy_dfun ispec + = ispec { is_dfun = tidy_dfun (is_dfun ispec) } + +instanceRoughTcs :: ClsInst -> [Maybe Name] +instanceRoughTcs = is_tcs + + +instance NamedThing ClsInst where + getName ispec = getName (is_dfun ispec) + +instance Outputable ClsInst where + ppr = pprInstance + +pprInstance :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstance ispec + = hang (pprInstanceHdr ispec) + 2 (vcat [ text "--" <+> pprDefinedAt (getName ispec) + , whenPprDebug (ppr (is_dfun ispec)) ]) + +-- * pprInstanceHdr is used in VStudio to populate the ClassView tree +pprInstanceHdr :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) + = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun) + +pprInstances :: [ClsInst] -> SDoc +pprInstances ispecs = vcat (map pprInstance ispecs) + +instanceHead :: ClsInst -> ([TyVar], Class, [Type]) +-- Returns the head, using the fresh tyavs from the ClsInst +instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun }) + = (tvs, cls, tys) + where + (_, _, cls, _) = tcSplitDFunTy (idType dfun) + +-- | Collects the names of concrete types and type constructors that make +-- up the head of a class instance. For instance, given `class Foo a b`: +-- +-- `instance Foo (Either (Maybe Int) a) Bool` would yield +-- [Either, Maybe, Int, Bool] +-- +-- Used in the implementation of ":info" in GHCi. +-- +-- The 'tcSplitSigmaTy' is because of +-- instance Foo a => Baz T where ... +-- The decl is an orphan if Baz and T are both not locally defined, +-- even if Foo *is* locally defined +orphNamesOfClsInst :: ClsInst -> NameSet +orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys }) + = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm + +instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type]) +-- Decomposes the DFunId +instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) + +mkLocalInstance :: DFunId -> OverlapFlag + -> [TyVar] -> Class -> [Type] + -> ClsInst +-- Used for local instances, where we can safely pull on the DFunId. +-- Consider using newClsInst instead; this will also warn if +-- the instance is an orphan. +mkLocalInstance dfun oflag tvs cls tys + = ClsInst { is_flag = oflag, is_dfun = dfun + , is_tvs = tvs + , is_dfun_name = dfun_name + , is_cls = cls, is_cls_nm = cls_name + , is_tys = tys, is_tcs = roughMatchTcs tys + , is_orphan = orph + } + where + cls_name = className cls + dfun_name = idName dfun + this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name + is_local name = nameIsLocalOrFrom this_mod name + + -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv + (cls_tvs, fds) = classTvsFds cls + arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] + + -- See Note [When exactly is an instance decl an orphan?] + orph | is_local cls_name = NotOrphan (nameOccName cls_name) + | all notOrphan mb_ns = ASSERT( not (null mb_ns) ) head mb_ns + | otherwise = IsOrphan + + notOrphan NotOrphan{} = True + notOrphan _ = False + + mb_ns :: [IsOrphan] -- One for each fundep; a locally-defined name + -- that is not in the "determined" arguments + mb_ns | null fds = [choose_one arg_names] + | otherwise = map do_one fds + do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names + , not (tv `elem` rtvs)] + + choose_one nss = chooseOrphanAnchor (unionNameSets nss) + +mkImportedInstance :: Name -- ^ the name of the class + -> [Maybe Name] -- ^ the types which the class was applied to + -> Name -- ^ the 'Name' of the dictionary binding + -> DFunId -- ^ the 'Id' of the dictionary. + -> OverlapFlag -- ^ may this instance overlap? + -> IsOrphan -- ^ is this instance an orphan? + -> ClsInst +-- Used for imported instances, where we get the rough-match stuff +-- from the interface file +-- The bound tyvars of the dfun are guaranteed fresh, because +-- the dfun has been typechecked out of the same interface file +mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan + = ClsInst { is_flag = oflag, is_dfun = dfun + , is_tvs = tvs, is_tys = tys + , is_dfun_name = dfun_name + , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs + , is_orphan = orphan } + where + (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) + +{- +Note [When exactly is an instance decl an orphan?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + (see GHC.Iface.Make.instanceToIfaceInst, which implements this) +Roughly speaking, an instance is an orphan if its head (after the =>) +mentions nothing defined in this module. + +Functional dependencies complicate the situation though. Consider + + module M where { class C a b | a -> b } + +and suppose we are compiling module X: + + module X where + import M + data T = ... + instance C Int T where ... + +This instance is an orphan, because when compiling a third module Y we +might get a constraint (C Int v), and we'd want to improve v to T. So +we must make sure X's instances are loaded, even if we do not directly +use anything from X. + +More precisely, an instance is an orphan iff + + If there are no fundeps, then at least of the names in + the instance head is locally defined. + + If there are fundeps, then for every fundep, at least one of the + names free in a *non-determined* part of the instance head is + defined in this module. + +(Note that these conditions hold trivially if the class is locally +defined.) + + +************************************************************************ +* * + InstEnv, ClsInstEnv +* * +************************************************************************ + +A @ClsInstEnv@ all the instances of that class. The @Id@ inside a +ClsInstEnv mapping is the dfun for that instance. + +If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then + + forall a b, C t1 t2 t3 can be constructed by dfun + +or, to put it another way, we have + + instance (...) => C t1 t2 t3, witnessed by dfun +-} + +--------------------------------------------------- +{- +Note [InstEnv determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We turn InstEnvs into a list in some places that don't directly affect +the ABI. That happens when we create output for `:info`. +Unfortunately that nondeterminism is nonlocal and it's hard to tell what it +affects without following a chain of functions. It's also easy to accidentally +make that nondeterminism affect the ABI. Furthermore the envs should be +relatively small, so it should be free to use deterministic maps here. +Testing with nofib and validate detected no difference between UniqFM and +UniqDFM. See also Note [Deterministic UniqFM] +-} + +type InstEnv = UniqDFM ClsInstEnv -- Maps Class to instances for that class + -- See Note [InstEnv determinism] + +-- | 'InstEnvs' represents the combination of the global type class instance +-- environment, the local type class instance environment, and the set of +-- transitively reachable orphan modules (according to what modules have been +-- directly imported) used to test orphan instance visibility. +data InstEnvs = InstEnvs { + ie_global :: InstEnv, -- External-package instances + ie_local :: InstEnv, -- Home-package instances + ie_visible :: VisibleOrphanModules -- Set of all orphan modules transitively + -- reachable from the module being compiled + -- See Note [Instance lookup and orphan instances] + } + +-- | Set of visible orphan modules, according to what modules have been directly +-- imported. This is based off of the dep_orphs field, which records +-- transitively reachable orphan modules (modules that define orphan instances). +type VisibleOrphanModules = ModuleSet + +newtype ClsInstEnv + = ClsIE [ClsInst] -- The instances for a particular class, in any order + +instance Outputable ClsInstEnv where + ppr (ClsIE is) = pprInstances is + +-- INVARIANTS: +-- * The is_tvs are distinct in each ClsInst +-- of a ClsInstEnv (so we can safely unify them) + +-- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: +-- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] +-- The "a" in the pattern must be one of the forall'd variables in +-- the dfun type. + +emptyInstEnv :: InstEnv +emptyInstEnv = emptyUDFM + +instEnvElts :: InstEnv -> [ClsInst] +instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts] + -- See Note [InstEnv determinism] + +instEnvClasses :: InstEnv -> [Class] +instEnvClasses ie = [is_cls e | ClsIE (e : _) <- eltsUDFM ie] + +-- | Test if an instance is visible, by checking that its origin module +-- is in 'VisibleOrphanModules'. +-- See Note [Instance lookup and orphan instances] +instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool +instIsVisible vis_mods ispec + -- NB: Instances from the interactive package always are visible. We can't + -- add interactive modules to the set since we keep creating new ones + -- as a GHCi session progresses. + = case nameModule_maybe (is_dfun_name ispec) of + Nothing -> True + Just mod | isInteractiveModule mod -> True + | IsOrphan <- is_orphan ispec -> mod `elemModuleSet` vis_mods + | otherwise -> True + +classInstances :: InstEnvs -> Class -> [ClsInst] +classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls + = get home_ie ++ get pkg_ie + where + get env = case lookupUDFM env cls of + Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts + Nothing -> [] + +-- | Checks for an exact match of ClsInst in the instance environment. +-- We use this when we do signature checking in TcRnDriver +memberInstEnv :: InstEnv -> ClsInst -> Bool +memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = + maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items) + (lookupUDFM inst_env cls_nm) + where + identicalDFunType cls1 cls2 = + eqType (varType (is_dfun cls1)) (varType (is_dfun cls2)) + +extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv +extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs + +extendInstEnv :: InstEnv -> ClsInst -> InstEnv +extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) + = addToUDFM_C add inst_env cls_nm (ClsIE [ins_item]) + where + add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) + +deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv +deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) + = adjustUDFM adjust inst_env cls_nm + where + adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items) + +deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv +-- Delete a specific instance fron an InstEnv +deleteDFunFromInstEnv inst_env dfun + = adjustUDFM adjust inst_env cls + where + (_, _, cls, _) = tcSplitDFunTy (idType dfun) + adjust (ClsIE items) = ClsIE (filterOut same_dfun items) + same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun' + +identicalClsInstHead :: ClsInst -> ClsInst -> Bool +-- ^ True when when the instance heads are the same +-- e.g. both are Eq [(a,b)] +-- Used for overriding in GHCi +-- Obviously should be insensitive to alpha-renaming +identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 }) + (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 }) + = cls_nm1 == cls_nm2 + && not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields + && isJust (tcMatchTys tys1 tys2) + && isJust (tcMatchTys tys2 tys1) + +{- +************************************************************************ +* * + Looking up an instance +* * +************************************************************************ + +@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since +the env is kept ordered, the first match must be the only one. The +thing we are looking up can have an arbitrary "flexi" part. + +Note [Instance lookup and orphan instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are compiling a module M, and we have a zillion packages +loaded, and we are looking up an instance for C (T W). If we find a +match in module 'X' from package 'p', should be "in scope"; that is, + + is p:X in the transitive closure of modules imported from M? + +The difficulty is that the "zillion packages" might include ones loaded +through earlier invocations of the GHC API, or earlier module loads in GHCi. +They might not be in the dependencies of M itself; and if not, the instances +in them should not be visible. #2182, #8427. + +There are two cases: + * If the instance is *not an orphan*, then module X defines C, T, or W. + And in order for those types to be involved in typechecking M, it + must be that X is in the transitive closure of M's imports. So we + can use the instance. + + * If the instance *is an orphan*, the above reasoning does not apply. + So we keep track of the set of orphan modules transitively below M; + this is the ie_visible field of InstEnvs, of type VisibleOrphanModules. + + If module p:X is in this set, then we can use the instance, otherwise + we can't. + +Note [Rules for instance lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These functions implement the carefully-written rules in the user +manual section on "overlapping instances". At risk of duplication, +here are the rules. If the rules change, change this text and the +user manual simultaneously. The link may be this: +http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap + +The willingness to be overlapped or incoherent is a property of the +instance declaration itself, controlled as follows: + + * An instance is "incoherent" + if it has an INCOHERENT pragma, or + if it appears in a module compiled with -XIncoherentInstances. + + * An instance is "overlappable" + if it has an OVERLAPPABLE or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + + * An instance is "overlapping" + if it has an OVERLAPPING or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + compiled with -XOverlappingInstances. + +Now suppose that, in some client module, we are searching for an instance +of the target constraint (C ty1 .. tyn). The search works like this. + +* Find all instances `I` that *match* the target constraint; that is, the + target constraint is a substitution instance of `I`. These instance + declarations are the *candidates*. + +* Eliminate any candidate `IX` for which both of the following hold: + + - There is another candidate `IY` that is strictly more specific; that + is, `IY` is a substitution instance of `IX` but not vice versa. + + - Either `IX` is *overlappable*, or `IY` is *overlapping*. (This + "either/or" design, rather than a "both/and" design, allow a + client to deliberately override an instance from a library, + without requiring a change to the library.) + +- If exactly one non-incoherent candidate remains, select it. If all + remaining candidates are incoherent, select an arbitrary one. + Otherwise the search fails (i.e. when more than one surviving + candidate is not incoherent). + +- If the selected candidate (from the previous step) is incoherent, the + search succeeds, returning that candidate. + +- If not, find all instances that *unify* with the target constraint, + but do not *match* it. Such non-candidate instances might match when + the target constraint is further instantiated. If all of them are + incoherent, the search succeeds, returning the selected candidate; if + not, the search fails. + +Notice that these rules are not influenced by flag settings in the +client module, where the instances are *used*. These rules make it +possible for a library author to design a library that relies on +overlapping instances without the client having to know. + +Note [Overlapping instances] (NB: these notes are quite old) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Overlap is permitted, but only in such a way that one can make +a unique choice when looking up. That is, overlap is only permitted if +one template matches the other, or vice versa. So this is ok: + + [a] [Int] + +but this is not + + (Int,a) (b,Int) + +If overlap is permitted, the list is kept most specific first, so that +the first lookup is the right choice. + + +For now we just use association lists. + +\subsection{Avoiding a problem with overlapping} + +Consider this little program: + +\begin{pseudocode} + class C a where c :: a + class C a => D a where d :: a + + instance C Int where c = 17 + instance D Int where d = 13 + + instance C a => C [a] where c = [c] + instance ({- C [a], -} D a) => D [a] where d = c + + instance C [Int] where c = [37] + + main = print (d :: [Int]) +\end{pseudocode} + +What do you think `main' prints (assuming we have overlapping instances, and +all that turned on)? Well, the instance for `D' at type `[a]' is defined to +be `c' at the same type, and we've got an instance of `C' at `[Int]', so the +answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because +the `C [Int]' instance is more specific). + +Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That +was easy ;-) Let's just consult hugs for good measure. Wait - if I use old +hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it +doesn't even compile! What's going on!? + +What hugs complains about is the `D [a]' instance decl. + +\begin{pseudocode} + ERROR "mj.hs" (line 10): Cannot build superclass instance + *** Instance : D [a] + *** Context supplied : D a + *** Required superclass : C [a] +\end{pseudocode} + +You might wonder what hugs is complaining about. It's saying that you +need to add `C [a]' to the context of the `D [a]' instance (as appears +in comments). But there's that `C [a]' instance decl one line above +that says that I can reduce the need for a `C [a]' instance to the +need for a `C a' instance, and in this case, I already have the +necessary `C a' instance (since we have `D a' explicitly in the +context, and `C' is a superclass of `D'). + +Unfortunately, the above reasoning indicates a premature commitment to the +generic `C [a]' instance. I.e., it prematurely rules out the more specific +instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to +add the context that hugs suggests (uncomment the `C [a]'), effectively +deferring the decision about which instance to use. + +Now, interestingly enough, 4.04 has this same bug, but it's covered up +in this case by a little known `optimization' that was disabled in +4.06. Ghc-4.04 silently inserts any missing superclass context into +an instance declaration. In this case, it silently inserts the `C +[a]', and everything happens to work out. + +(See `basicTypes/MkId:mkDictFunId' for the code in question. Search for +`Mark Jones', although Mark claims no credit for the `optimization' in +question, and would rather it stopped being called the `Mark Jones +optimization' ;-) + +So, what's the fix? I think hugs has it right. Here's why. Let's try +something else out with ghc-4.04. Let's add the following line: + + d' :: D a => [a] + d' = c + +Everyone raise their hand who thinks that `d :: [Int]' should give a +different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The +`optimization' only applies to instance decls, not to regular +bindings, giving inconsistent behavior. + +Old hugs had this same bug. Here's how we fixed it: like GHC, the +list of instances for a given class is ordered, so that more specific +instances come before more generic ones. For example, the instance +list for C might contain: + ..., C Int, ..., C a, ... +When we go to look for a `C Int' instance we'll get that one first. +But what if we go looking for a `C b' (`b' is unconstrained)? We'll +pass the `C Int' instance, and keep going. But if `b' is +unconstrained, then we don't know yet if the more specific instance +will eventually apply. GHC keeps going, and matches on the generic `C +a'. The fix is to, at each step, check to see if there's a reverse +match, and if so, abort the search. This prevents hugs from +prematurely choosing a generic instance when a more specific one +exists. + +--Jeff + +BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in +this test. Suppose the instance envt had + ..., forall a b. C a a b, ..., forall a b c. C a b c, ... +(still most specific first) +Now suppose we are looking for (C x y Int), where x and y are unconstrained. + C x y Int doesn't match the template {a,b} C a a b +but neither does + C a a b match the template {x,y} C x y Int +But still x and y might subsequently be unified so they *do* match. + +Simple story: unify, don't match. +-} + +type DFunInstType = Maybe Type + -- Just ty => Instantiate with this type + -- Nothing => Instantiate with any type of this tyvar's kind + -- See Note [DFunInstType: instantiating types] + +type InstMatch = (ClsInst, [DFunInstType]) + +type ClsInstLookupResult + = ( [InstMatch] -- Successful matches + , [ClsInst] -- These don't match but do unify + , [InstMatch] ) -- Unsafe overlapped instances under Safe Haskell + -- (see Note [Safe Haskell Overlapping Instances] in + -- TcSimplify). + +{- +Note [DFunInstType: instantiating types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A successful match is a ClsInst, together with the types at which + the dfun_id in the ClsInst should be instantiated +The instantiating types are (Either TyVar Type)s because the dfun +might have some tyvars that *only* appear in arguments + dfun :: forall a b. C a b, Ord b => D [a] +When we match this against D [ty], we return the instantiating types + [Just ty, Nothing] +where the 'Nothing' indicates that 'b' can be freely instantiated. +(The caller instantiates it to a flexi type variable, which will + presumably later become fixed via functional dependencies.) +-} + +-- |Look up an instance in the given instance environment. The given class application must match exactly +-- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, +-- yield 'Left errorMessage'. +lookupUniqueInstEnv :: InstEnvs + -> Class -> [Type] + -> Either MsgDoc (ClsInst, [Type]) +lookupUniqueInstEnv instEnv cls tys + = case lookupInstEnv False instEnv cls tys of + ([(inst, inst_tys)], _, _) + | noFlexiVar -> Right (inst, inst_tys') + | otherwise -> Left $ text "flexible type variable:" <+> + (ppr $ mkTyConApp (classTyCon cls) tys) + where + inst_tys' = [ty | Just ty <- inst_tys] + noFlexiVar = all isJust inst_tys + _other -> Left $ text "instance not found" <+> + (ppr $ mkTyConApp (classTyCon cls) tys) + +lookupInstEnv' :: InstEnv -- InstEnv to look in + -> VisibleOrphanModules -- But filter against this + -> Class -> [Type] -- What we are looking for + -> ([InstMatch], -- Successful matches + [ClsInst]) -- These don't match but do unify + -- (no incoherent ones in here) +-- The second component of the result pair happens when we look up +-- Foo [a] +-- in an InstEnv that has entries for +-- Foo [Int] +-- Foo [b] +-- Then which we choose would depend on the way in which 'a' +-- is instantiated. So we report that Foo [b] is a match (mapping b->a) +-- but Foo [Int] is a unifier. This gives the caller a better chance of +-- giving a suitable error message + +lookupInstEnv' ie vis_mods cls tys + = lookup ie + where + rough_tcs = roughMatchTcs tys + all_tvs = all isNothing rough_tcs + + -------------- + lookup env = case lookupUDFM env cls of + Nothing -> ([],[]) -- No instances for this class + Just (ClsIE insts) -> find [] [] insts + + -------------- + find ms us [] = (ms, us) + find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs + , is_tys = tpl_tys }) : rest) + | not (instIsVisible vis_mods item) + = find ms us rest -- See Note [Instance lookup and orphan instances] + + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find ms us rest + + | Just subst <- tcMatchTys tpl_tys tys + = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest + + -- Does not match, so next check whether the things unify + -- See Note [Overlapping instances] + -- Ignore ones that are incoherent: Note [Incoherent instances] + | isIncoherent item + = find ms us rest + + | otherwise + = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set, + (ppr cls <+> ppr tys <+> ppr all_tvs) $$ + (ppr tpl_tvs <+> ppr tpl_tys) + ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + -- See Note [Template tyvars are fresh] + case tcUnifyTys instanceBindFun tpl_tys tys of + Just _ -> find ms (item:us) rest + Nothing -> find ms us rest + where + tpl_tv_set = mkVarSet tpl_tvs + +--------------- +-- This is the common way to call this function. +lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions + -> InstEnvs -- External and home package inst-env + -> Class -> [Type] -- What we are looking for + -> ClsInstLookupResult +-- ^ See Note [Rules for instance lookup] +-- ^ See Note [Safe Haskell Overlapping Instances] in TcSimplify +-- ^ See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify +lookupInstEnv check_overlap_safe + (InstEnvs { ie_global = pkg_ie + , ie_local = home_ie + , ie_visible = vis_mods }) + cls + tys + = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $ + (final_matches, final_unifs, unsafe_overlapped) + where + (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys + (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys + all_matches = home_matches ++ pkg_matches + all_unifs = home_unifs ++ pkg_unifs + final_matches = foldr insert_overlapping [] all_matches + -- Even if the unifs is non-empty (an error situation) + -- we still prune the matches, so that the error message isn't + -- misleading (complaining of multiple matches when some should be + -- overlapped away) + + unsafe_overlapped + = case final_matches of + [match] -> check_safe match + _ -> [] + + -- If the selected match is incoherent, discard all unifiers + final_unifs = case final_matches of + (m:_) | isIncoherent (fst m) -> [] + _ -> all_unifs + + -- NOTE [Safe Haskell isSafeOverlap] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We restrict code compiled in 'Safe' mode from overriding code + -- compiled in any other mode. The rationale is that code compiled + -- in 'Safe' mode is code that is untrusted by the ghc user. So + -- we shouldn't let that code change the behaviour of code the + -- user didn't compile in 'Safe' mode since that's the code they + -- trust. So 'Safe' instances can only overlap instances from the + -- same module. A same instance origin policy for safe compiled + -- instances. + check_safe (inst,_) + = case check_overlap_safe && unsafeTopInstance inst of + -- make sure it only overlaps instances from the same module + True -> go [] all_matches + -- most specific is from a trusted location. + False -> [] + where + go bad [] = bad + go bad (i@(x,_):unchecked) = + if inSameMod x || isOverlappable x + then go bad unchecked + else go (i:bad) unchecked + + inSameMod b = + let na = getName $ getName inst + la = isInternalName na + nb = getName $ getName b + lb = isInternalName nb + in (la && lb) || (nameModule na == nameModule nb) + + -- We consider the most specific instance unsafe when it both: + -- (1) Comes from a module compiled as `Safe` + -- (2) Is an orphan instance, OR, an instance for a MPTC + unsafeTopInstance inst = isSafeOverlap (is_flag inst) && + (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1) + +--------------- +insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] +-- ^ Add a new solution, knocking out strictly less specific ones +-- See Note [Rules for instance lookup] +insert_overlapping new_item [] = [new_item] +insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items) + | new_beats_old -- New strictly overrides old + , not old_beats_new + , new_inst `can_override` old_inst + = insert_overlapping new_item old_items + + | old_beats_new -- Old strictly overrides new + , not new_beats_old + , old_inst `can_override` new_inst + = old_item : old_items + + -- Discard incoherent instances; see Note [Incoherent instances] + | isIncoherent old_inst -- Old is incoherent; discard it + = insert_overlapping new_item old_items + | isIncoherent new_inst -- New is incoherent; discard it + = old_item : old_items + + -- Equal or incomparable, and neither is incoherent; keep both + | otherwise + = old_item : insert_overlapping new_item old_items + where + + new_beats_old = new_inst `more_specific_than` old_inst + old_beats_new = old_inst `more_specific_than` new_inst + + -- `instB` can be instantiated to match `instA` + -- or the two are equal + instA `more_specific_than` instB + = isJust (tcMatchTys (is_tys instB) (is_tys instA)) + + instA `can_override` instB + = isOverlapping instA || isOverlappable instB + -- Overlap permitted if either the more specific instance + -- is marked as overlapping, or the more general one is + -- marked as overlappable. + -- Latest change described in: #9242. + -- Previous change: #3877, Dec 10. + +{- +Note [Incoherent instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some classes, the choice of a particular instance does not matter, any one +is good. E.g. consider + + class D a b where { opD :: a -> b -> String } + instance D Int b where ... + instance D a Int where ... + + g (x::Int) = opD x x -- Wanted: D Int Int + +For such classes this should work (without having to add an "instance D Int +Int", and using -XOverlappingInstances, which would then work). This is what +-XIncoherentInstances is for: Telling GHC "I don't care which instance you use; +if you can use one, use it." + +Should this logic only work when *all* candidates have the incoherent flag, or +even when all but one have it? The right choice is the latter, which can be +justified by comparing the behaviour with how -XIncoherentInstances worked when +it was only about the unify-check (note [Overlapping instances]): + +Example: + class C a b c where foo :: (a,b,c) + instance C [a] b Int + instance [incoherent] [Int] b c + instance [incoherent] C a Int c +Thanks to the incoherent flags, + [Wanted] C [a] b Int +works: Only instance one matches, the others just unify, but are marked +incoherent. + +So I can write + (foo :: ([a],b,Int)) :: ([Int], Int, Int). +but if that works then I really want to be able to write + foo :: ([Int], Int, Int) +as well. Now all three instances from above match. None is more specific than +another, so none is ruled out by the normal overlapping rules. One of them is +not incoherent, but we still want this to compile. Hence the +"all-but-one-logic". + +The implementation is in insert_overlapping, where we remove matching +incoherent instances as long as there are others. + + + +************************************************************************ +* * + Binding decisions +* * +************************************************************************ +-} + +instanceBindFun :: TyCoVar -> BindFlag +instanceBindFun tv | isOverlappableTyVar tv = Skolem + | otherwise = BindMe + -- Note [Binding when looking up instances] + +{- +Note [Binding when looking up instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When looking up in the instance environment, or family-instance environment, +we are careful about multiple matches, as described above in +Note [Overlapping instances] + +The key_tys can contain skolem constants, and we can guarantee that those +are never going to be instantiated to anything, so we should not involve +them in the unification test. Example: + class Foo a where { op :: a -> Int } + instance Foo a => Foo [a] -- NB overlap + instance Foo [Int] -- NB overlap + data T = forall a. Foo a => MkT a + f :: T -> Int + f (MkT x) = op [x,x] +The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd +complain, saying that the choice of instance depended on the instantiation +of 'a'; but of course it isn't *going* to be instantiated. + +We do this only for isOverlappableTyVar skolems. For example we reject + g :: forall a => [a] -> Int + g x = op x +on the grounds that the correct instance depends on the instantiation of 'a' +-} diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index d3598dc722..b22705eb6f 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -32,7 +32,7 @@ import GHC.Core.Stats ( coreBindsStats ) import CoreMonad import Bag import Literal -import DataCon +import GHC.Core.DataCon import TysWiredIn import TysPrim import TcType ( isFloatingTy ) @@ -45,16 +45,16 @@ import Id import IdInfo import GHC.Core.Ppr import ErrUtils -import Coercion +import GHC.Core.Coercion import SrcLoc -import Type +import GHC.Core.Type as Type import GHC.Types.RepType -import TyCoRep -- checks validity of types/coercions -import TyCoSubst -import TyCoFVs -import TyCoPpr ( pprTyVar ) -import TyCon -import CoAxiom +import GHC.Core.TyCo.Rep -- checks validity of types/coercions +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr ( pprTyVar ) +import GHC.Core.TyCon as TyCon +import GHC.Core.Coercion.Axiom import BasicTypes import ErrUtils as Err import ListSetOps @@ -62,9 +62,9 @@ import PrelNames import Outputable import FastString import Util -import InstEnv ( instanceDFunId ) -import OptCoercion ( checkAxInstCo ) -import GHC.Core.Arity ( typeArity ) +import GHC.Core.InstEnv ( instanceDFunId ) +import GHC.Core.Coercion.Opt ( checkAxInstCo ) +import GHC.Core.Arity ( typeArity ) import Demand ( splitStrictSig, isBotDiv ) import GHC.Driver.Types @@ -1087,7 +1087,7 @@ lintTyApp fun_ty arg_ty ; in_scope <- getInScope -- substTy needs the set of tyvars in scope to avoid generating -- uniques that are already in scope. - -- See Note [The substitution invariant] in TyCoSubst + -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } | otherwise @@ -1466,7 +1466,7 @@ lintType t@(ForAllTy (Bndr cv _vis) ty) ; checkValueKind k (text "the body of forall:" <+> ppr t) ; return liftedTypeKind -- We don't check variable escape here. Namely, k could refer to cv' - -- See Note [NthCo and newtypes] in TyCoRep + -- See Note [NthCo and newtypes] in GHC.Core.TyCo.Rep }} lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) @@ -1585,7 +1585,7 @@ lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind lint_app doc kfn kas = do { in_scope <- getInScope -- We need the in_scope set to satisfy the invariant in - -- Note [The substitution invariant] in TyCoSubst + -- Note [The substitution invariant] in GHC.Core.TyCo.Subst ; foldlM (go_app in_scope) kfn kas } where fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc @@ -1807,7 +1807,7 @@ lintCoercion (ForAllCo tv1 kind_co co) -- scope. All the free vars of `t2` and `kind_co` should -- already be in `in_scope`, because they've been -- linted and `tv2` has the same unique as `tv1`. - -- See Note [The substitution invariant] in TyCoSubst. + -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst. unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co) tyr = mkInvForAllTy tv2 $ substTy subst t2 @@ -1825,7 +1825,7 @@ lintCoercion (ForAllCo cv1 kind_co co) ; (k3, k4, t1, t2, r) <- lintCoercion co ; checkValueKind k3 (text "the body of a ForAllCo over covar:" <+> ppr co) ; checkValueKind k4 (text "the body of a ForAllCo over covar:" <+> ppr co) - -- See Note [Weird typing rule for ForAllTy] in Type + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.Type ; in_scope <- getInScope ; let tyl = mkTyCoInvForAllTy cv1 t1 r2 = coVarRole cv1 @@ -1838,13 +1838,13 @@ lintCoercion (ForAllCo cv1 kind_co co) -- scope. All the free vars of `t2` and `kind_co` should -- already be in `in_scope`, because they've been -- linted and `cv2` has the same unique as `cv1`. - -- See Note [The substitution invariant] in TyCoSubst. + -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst. unitVarEnv cv1 (eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)) tyr = mkTyCoInvForAllTy cv2 $ substTy subst t2 ; return (liftedTypeKind, liftedTypeKind, tyl, tyr, r) } } - -- See Note [Weird typing rule for ForAllTy] in Type + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.Type lintCoercion co@(FunCo r co1 co2) = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1 @@ -1964,7 +1964,7 @@ lintCoercion the_co@(NthCo r0 n co) { (Just (tc_s, tys_s), Just (tc_t, tys_t)) | tc_s == tc_t , isInjectiveTyCon tc_s r - -- see Note [NthCo and newtypes] in TyCoRep + -- see Note [NthCo and newtypes] in GHC.Core.TyCo.Rep , tys_s `equalLength` tys_t , tys_s `lengthExceeds` n -> do { lintRole the_co tr r0 @@ -2018,7 +2018,7 @@ lintCoercion (InstCo co arg) , CoercionTy s2' <- s2 -> do { return $ (liftedTypeKind, liftedTypeKind - -- See Note [Weird typing rule for ForAllTy] in Type + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.Type , substTy (mkCvSubst in_scope $ unitVarEnv cv1 s1') t1 , substTy (mkCvSubst in_scope $ unitVarEnv cv2 s2') t2 , r) } diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 540ecfbe56..17fc146608 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -68,10 +68,10 @@ import TysWiredIn import PrelNames import GHC.Hs.Utils ( mkChunkified, chunkify ) -import Type -import Coercion ( isCoVar ) +import GHC.Core.Type +import GHC.Core.Coercion ( isCoVar ) +import GHC.Core.DataCon ( DataCon, dataConWorkId ) import TysPrim -import DataCon ( DataCon, dataConWorkId ) import IdInfo import Demand import Cpr diff --git a/compiler/GHC/Core/Map.hs b/compiler/GHC/Core/Map.hs index ee12bdd8a3..c3e765ff2b 100644 --- a/compiler/GHC/Core/Map.hs +++ b/compiler/GHC/Core/Map.hs @@ -41,10 +41,10 @@ import GhcPrelude import TrieMap import GHC.Core -import Coercion +import GHC.Core.Coercion import Name -import Type -import TyCoRep +import GHC.Core.Type +import GHC.Core.TyCo.Rep import Var import FastString(FastString) import Util @@ -475,10 +475,10 @@ data TypeMapX a , tm_tylit :: TyLitMap a , tm_coerce :: Maybe a } - -- Note that there is no tyconapp case; see Note [Equality on AppTys] in Type + -- Note that there is no tyconapp case; see Note [Equality on AppTys] in GHC.Core.Type -- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the --- last one? See Note [Equality on AppTys] in Type +-- last one? See Note [Equality on AppTys] in GHC.Core.Type -- -- Note, however, that we keep Constraint and Type apart here, despite the fact -- that they are both synonyms of TYPE 'LiftedRep (see #11715). @@ -515,7 +515,7 @@ instance Eq (DeBruijn Type) where (Just bv, Just bv') -> bv == bv' (Nothing, Nothing) -> v == v' _ -> False - -- See Note [Equality on AppTys] in Type + -- See Note [Equality on AppTys] in GHC.Core.Type (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s -> D env t1 == D env' t1' && D env t2 == D env' t2' (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s diff --git a/compiler/GHC/Core/Op/Tidy.hs b/compiler/GHC/Core/Op/Tidy.hs index 8ddd3708c3..60db2c8fea 100644 --- a/compiler/GHC/Core/Op/Tidy.hs +++ b/compiler/GHC/Core/Op/Tidy.hs @@ -22,8 +22,8 @@ import GHC.Core.Seq ( seqUnfolding ) import Id import IdInfo import Demand ( zapUsageEnvSig ) -import Type( tidyType, tidyVarBndr ) -import Coercion( tidyCo ) +import GHC.Core.Type ( tidyType, tidyVarBndr ) +import GHC.Core.Coercion ( tidyCo ) import Var import VarEnv import UniqFM diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs new file mode 100644 index 0000000000..7f84e92e3f --- /dev/null +++ b/compiler/GHC/Core/PatSyn.hs @@ -0,0 +1,484 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[PatSyn]{@PatSyn@: Pattern synonyms} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Core.PatSyn ( + -- * Main data types + PatSyn, mkPatSyn, + + -- ** Type deconstruction + patSynName, patSynArity, patSynIsInfix, + patSynArgs, + patSynMatcher, patSynBuilder, + patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig, + patSynInstArgTys, patSynInstResTy, patSynFieldLabels, + patSynFieldType, + + updatePatSynIds, pprPatSynType + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core.Type +import GHC.Core.TyCo.Ppr +import Name +import Outputable +import Unique +import Util +import BasicTypes +import Var +import FieldLabel + +import qualified Data.Data as Data +import Data.Function +import Data.List (find) + +{- +************************************************************************ +* * +\subsection{Pattern synonyms} +* * +************************************************************************ +-} + +-- | Pattern Synonym +-- +-- See Note [Pattern synonym representation] +-- See Note [Pattern synonym signature contexts] +data PatSyn + = MkPatSyn { + psName :: Name, + psUnique :: Unique, -- Cached from Name + + psArgs :: [Type], + psArity :: Arity, -- == length psArgs + psInfix :: Bool, -- True <=> declared infix + psFieldLabels :: [FieldLabel], -- List of fields for a + -- record pattern synonym + -- INVARIANT: either empty if no + -- record pat syn or same length as + -- psArgs + + -- Universally-quantified type variables + psUnivTyVars :: [TyVarBinder], + + -- Required dictionaries (may mention psUnivTyVars) + psReqTheta :: ThetaType, + + -- Existentially-quantified type vars + psExTyVars :: [TyVarBinder], + + -- Provided dictionaries (may mention psUnivTyVars or psExTyVars) + psProvTheta :: ThetaType, + + -- Result type + psResultTy :: Type, -- Mentions only psUnivTyVars + -- See Note [Pattern synonym result type] + + -- See Note [Matchers and builders for pattern synonyms] + psMatcher :: (Id, Bool), + -- Matcher function. + -- If Bool is True then prov_theta and arg_tys are empty + -- and type is + -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs. + -- req_theta + -- => res_ty + -- -> (forall ex_tvs. Void# -> r) + -- -> (Void# -> r) + -- -> r + -- + -- Otherwise type is + -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs. + -- req_theta + -- => res_ty + -- -> (forall ex_tvs. prov_theta => arg_tys -> r) + -- -> (Void# -> r) + -- -> r + + psBuilder :: Maybe (Id, Bool) + -- Nothing => uni-directional pattern synonym + -- Just (builder, is_unlifted) => bi-directional + -- Builder function, of type + -- forall univ_tvs, ex_tvs. (req_theta, prov_theta) + -- => arg_tys -> res_ty + -- See Note [Builder for pattern synonyms with unboxed type] + } + +{- Note [Pattern synonym signature contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a pattern synonym signature we write + pattern P :: req => prov => t1 -> ... tn -> res_ty + +Note that the "required" context comes first, then the "provided" +context. Moreover, the "required" context must not mention +existentially-bound type variables; that is, ones not mentioned in +res_ty. See lots of discussion in #10928. + +If there is no "provided" context, you can omit it; but you +can't omit the "required" part (unless you omit both). + +Example 1: + pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b) + pattern P1 x = Just (3,x) + + We require (Num a, Eq a) to match the 3; there is no provided + context. + +Example 2: + data T2 where + MkT2 :: (Num a, Eq a) => a -> a -> T2 + + pattern P2 :: () => (Num a, Eq a) => a -> T2 + pattern P2 x = MkT2 3 x + + When we match against P2 we get a Num dictionary provided. + We can use that to check the match against 3. + +Example 3: + pattern P3 :: Eq a => a -> b -> T3 b + + This signature is illegal because the (Eq a) is a required + constraint, but it mentions the existentially-bound variable 'a'. + You can see it's existential because it doesn't appear in the + result type (T3 b). + +Note [Pattern synonym result type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a b = MkT b a + + pattern P :: a -> T [a] Bool + pattern P x = MkT True [x] + +P's psResultTy is (T a Bool), and it really only matches values of +type (T [a] Bool). For example, this is ill-typed + + f :: T p q -> String + f (P x) = "urk" + +This is different to the situation with GADTs: + + data S a where + MkS :: Int -> S Bool + +Now MkS (and pattern synonyms coming from MkS) can match a +value of type (S a), not just (S Bool); we get type refinement. + +That in turn means that if you have a pattern + + P x :: T [ty] Bool + +it's not entirely straightforward to work out the instantiation of +P's universal tyvars. You have to /match/ + the type of the pattern, (T [ty] Bool) +against + the psResultTy for the pattern synonym, T [a] Bool +to get the instantiation a := ty. + +This is very unlike DataCons, where univ tyvars match 1-1 the +arguments of the TyCon. + +Side note: I (SG) get the impression that instantiated return types should +generate a *required* constraint for pattern synonyms, rather than a *provided* +constraint like it's the case for GADTs. For example, I'd expect these +declarations to have identical semantics: + + pattern Just42 :: Maybe Int + pattern Just42 = Just 42 + + pattern Just'42 :: (a ~ Int) => Maybe a + pattern Just'42 = Just 42 + +The latter generates the proper required constraint, the former does not. +Also rather different to GADTs is the fact that Just42 doesn't have any +universally quantified type variables, whereas Just'42 or MkS above has. + +Note [Pattern synonym representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following pattern synonym declaration + + pattern P x = MkT [x] (Just 42) + +where + data T a where + MkT :: (Show a, Ord b) => [b] -> a -> T a + +so pattern P has type + + b -> T (Maybe t) + +with the following typeclass constraints: + + requires: (Eq t, Num t) + provides: (Show (Maybe t), Ord b) + +In this case, the fields of MkPatSyn will be set as follows: + + psArgs = [b] + psArity = 1 + psInfix = False + + psUnivTyVars = [t] + psExTyVars = [b] + psProvTheta = (Show (Maybe t), Ord b) + psReqTheta = (Eq t, Num t) + psResultTy = T (Maybe t) + +Note [Matchers and builders for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For each pattern synonym P, we generate + + * a "matcher" function, used to desugar uses of P in patterns, + which implements pattern matching + + * A "builder" function (for bidirectional pattern synonyms only), + used to desugar uses of P in expressions, which constructs P-values. + +For the above example, the matcher function has type: + + $mP :: forall (r :: ?) t. (Eq t, Num t) + => T (Maybe t) + -> (forall b. (Show (Maybe t), Ord b) => b -> r) + -> (Void# -> r) + -> r + +with the following implementation: + + $mP @r @t $dEq $dNum scrut cont fail + = case scrut of + MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x + _ -> fail Void# + +Notice that the return type 'r' has an open kind, so that it can +be instantiated by an unboxed type; for example where we see + f (P x) = 3# + +The extra Void# argument for the failure continuation is needed so that +it is lazy even when the result type is unboxed. + +For the same reason, if the pattern has no arguments, an extra Void# +argument is added to the success continuation as well. + +For *bidirectional* pattern synonyms, we also generate a "builder" +function which implements the pattern synonym in an expression +context. For our running example, it will be: + + $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b) + => b -> T (Maybe t) + $bP x = MkT [x] (Just 42) + +NB: the existential/universal and required/provided split does not +apply to the builder since you are only putting stuff in, not getting +stuff out. + +Injectivity of bidirectional pattern synonyms is checked in +tcPatToExpr which walks the pattern and returns its corresponding +expression when available. + +Note [Builder for pattern synonyms with unboxed type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For bidirectional pattern synonyms that have no arguments and have an +unboxed type, we add an extra Void# argument to the builder, else it +would be a top-level declaration with an unboxed type. + + pattern P = 0# + + $bP :: Void# -> Int# + $bP _ = 0# + +This means that when typechecking an occurrence of P in an expression, +we must remember that the builder has this void argument. This is +done by TcPatSyn.patSynBuilderOcc. + +Note [Pattern synonyms and the data type Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type of a pattern synonym is of the form (See Note +[Pattern synonym signatures] in TcSigs): + + forall univ_tvs. req => forall ex_tvs. prov => ... + +We cannot in general represent this by a value of type Type: + + - if ex_tvs is empty, then req and prov cannot be distinguished from + each other + - if req is empty, then univ_tvs and ex_tvs cannot be distinguished + from each other, and moreover, prov is seen as the "required" context + (as it is the only context) + + +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq PatSyn where + (==) = (==) `on` getUnique + (/=) = (/=) `on` getUnique + +instance Uniquable PatSyn where + getUnique = psUnique + +instance NamedThing PatSyn where + getName = patSynName + +instance Outputable PatSyn where + ppr = ppr . getName + +instance OutputableBndr PatSyn where + pprInfixOcc = pprInfixName . getName + pprPrefixOcc = pprPrefixName . getName + +instance Data.Data PatSyn where + -- don't traverse? + toConstr _ = abstractConstr "PatSyn" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "PatSyn" + +{- +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +-- | Build a new pattern synonym +mkPatSyn :: Name + -> Bool -- ^ Is the pattern synonym declared infix? + -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type + -- variables and required dicts + -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type + -- variables and provided dicts + -> [Type] -- ^ Original arguments + -> Type -- ^ Original result type + -> (Id, Bool) -- ^ Name of matcher + -> Maybe (Id, Bool) -- ^ Name of builder + -> [FieldLabel] -- ^ Names of fields for + -- a record pattern synonym + -> PatSyn + -- NB: The univ and ex vars are both in TyBinder form and TyVar form for + -- convenience. All the TyBinders should be Named! +mkPatSyn name declared_infix + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + orig_args + orig_res_ty + matcher builder field_labels + = MkPatSyn {psName = name, psUnique = getUnique name, + psUnivTyVars = univ_tvs, + psExTyVars = ex_tvs, + psProvTheta = prov_theta, psReqTheta = req_theta, + psInfix = declared_infix, + psArgs = orig_args, + psArity = length orig_args, + psResultTy = orig_res_ty, + psMatcher = matcher, + psBuilder = builder, + psFieldLabels = field_labels + } + +-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification +patSynName :: PatSyn -> Name +patSynName = psName + +-- | Should the 'PatSyn' be presented infix? +patSynIsInfix :: PatSyn -> Bool +patSynIsInfix = psInfix + +-- | Arity of the pattern synonym +patSynArity :: PatSyn -> Arity +patSynArity = psArity + +patSynArgs :: PatSyn -> [Type] +patSynArgs = psArgs + +patSynFieldLabels :: PatSyn -> [FieldLabel] +patSynFieldLabels = psFieldLabels + +-- | Extract the type for any given labelled field of the 'DataCon' +patSynFieldType :: PatSyn -> FieldLabelString -> Type +patSynFieldType ps label + = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of + Just (_, ty) -> ty + Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label) + +patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder] +patSynUnivTyVarBinders = psUnivTyVars + +patSynExTyVars :: PatSyn -> [TyVar] +patSynExTyVars ps = binderVars (psExTyVars ps) + +patSynExTyVarBinders :: PatSyn -> [TyVarBinder] +patSynExTyVarBinders = psExTyVars + +patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) +patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs + , psProvTheta = prov, psReqTheta = req + , psArgs = arg_tys, psResultTy = res_ty }) + = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty) + +patSynMatcher :: PatSyn -> (Id,Bool) +patSynMatcher = psMatcher + +patSynBuilder :: PatSyn -> Maybe (Id, Bool) +patSynBuilder = psBuilder + +updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn +updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) + = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder } + where + tidy_pr (id, dummy) = (tidy_fn id, dummy) + +patSynInstArgTys :: PatSyn -> [Type] -> [Type] +-- Return the types of the argument patterns +-- e.g. data D a = forall b. MkD a b (b->a) +-- pattern P f x y = MkD (x,True) y f +-- D :: forall a. forall b. a -> b -> (b->a) -> D a +-- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c +-- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb] +-- NB: the inst_tys should be both universal and existential +patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psExTyVars = ex_tvs, psArgs = arg_tys }) + inst_tys + = ASSERT2( tyvars `equalLength` inst_tys + , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) + map (substTyWith tyvars inst_tys) arg_tys + where + tyvars = binderVars (univ_tvs ++ ex_tvs) + +patSynInstResTy :: PatSyn -> [Type] -> Type +-- Return the type of whole pattern +-- E.g. pattern P x y = Just (x,x,y) +-- P :: a -> b -> Just (a,a,b) +-- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool) +-- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars +patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psResultTy = res_ty }) + inst_tys + = ASSERT2( univ_tvs `equalLength` inst_tys + , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) + substTyWith (binderVars univ_tvs) inst_tys res_ty + +-- | Print the type of a pattern synonym. The foralls are printed explicitly +pprPatSynType :: PatSyn -> SDoc +pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta + , psExTyVars = ex_tvs, psProvTheta = prov_theta + , psArgs = orig_args, psResultTy = orig_res_ty }) + = sep [ pprForAll univ_tvs + , pprThetaArrowTy req_theta + , ppWhen insert_empty_ctxt $ parens empty <+> darrow + , pprType sigma_ty ] + where + sigma_ty = mkForAllTys ex_tvs $ + mkInvisFunTys prov_theta $ + mkVisFunTys orig_args orig_res_ty + insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/compiler/GHC/Core/PatSyn.hs-boot b/compiler/GHC/Core/PatSyn.hs-boot new file mode 100644 index 0000000000..8ce7621450 --- /dev/null +++ b/compiler/GHC/Core/PatSyn.hs-boot @@ -0,0 +1,13 @@ +module GHC.Core.PatSyn where + +import BasicTypes (Arity) +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type) +import Var (TyVar) +import Name (Name) + +data PatSyn + +patSynArity :: PatSyn -> Arity +patSynInstArgTys :: PatSyn -> [Type] -> [Type] +patSynExTyVars :: PatSyn -> [TyVar] +patSynName :: PatSyn -> Name diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index bd2b968ef4..0ab98c3208 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -28,10 +28,10 @@ import Id import IdInfo import Demand import Cpr -import DataCon -import TyCon -import TyCoPpr -import Coercion +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr +import GHC.Core.Coercion import BasicTypes import Maybes import Util diff --git a/compiler/GHC/Core/Ppr/TyThing.hs b/compiler/GHC/Core/Ppr/TyThing.hs index 6e092498d9..bf3450c447 100644 --- a/compiler/GHC/Core/Ppr/TyThing.hs +++ b/compiler/GHC/Core/Ppr/TyThing.hs @@ -21,14 +21,14 @@ module GHC.Core.Ppr.TyThing ( import GhcPrelude -import Type ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) +import GHC.Core.Type ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) , showToHeader, pprIfaceDecl ) -import CoAxiom ( coAxiomTyCon ) +import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) import GHC.Driver.Types( tyThingParent_maybe ) import GHC.Iface.Make ( tyThingToIfaceDecl ) -import FamInstEnv( FamInst(..), FamFlavor(..) ) -import TyCoPpr ( pprUserForAll, pprTypeApp, pprSigmaType ) +import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) ) +import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType ) import Name import VarEnv( emptyTidyEnv ) import Outputable diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs new file mode 100644 index 0000000000..e84333283d --- /dev/null +++ b/compiler/GHC/Core/Predicate.hs @@ -0,0 +1,228 @@ +{- + +Describes predicates as they are considered by the solver. + +-} + +module GHC.Core.Predicate ( + Pred(..), classifyPredType, + isPredTy, isEvVarType, + + -- Equality predicates + EqRel(..), eqRelRole, + isEqPrimPred, isEqPred, + getEqPredTys, getEqPredTys_maybe, getEqPredRole, + predTypeEqRel, + mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, + mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, + + -- Class predicates + mkClassPred, isDictTy, + isClassPred, isEqPredClass, isCTupleClass, + getClassPredTys, getClassPredTys_maybe, + + -- Implicit parameters + isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, hasIPPred, + + -- Evidence variables + DictId, isEvVar, isDictId + ) where + +import GhcPrelude + +import GHC.Core.Type +import GHC.Core.Class +import GHC.Core.TyCon +import Var +import GHC.Core.Coercion + +import PrelNames + +import FastString +import Outputable +import Util + +import Control.Monad ( guard ) + +-- | A predicate in the solver. The solver tries to prove Wanted predicates +-- from Given ones. +data Pred + = ClassPred Class [Type] + | EqPred EqRel Type Type + | IrredPred PredType + | ForAllPred [TyVar] [PredType] PredType + -- ForAllPred: see Note [Quantified constraints] in TcCanonical + -- NB: There is no TuplePred case + -- Tuple predicates like (Eq a, Ord b) are just treated + -- as ClassPred, as if we had a tuple class with two superclasses + -- class (c1, c2) => (%,%) c1 c2 + +classifyPredType :: PredType -> Pred +classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2 + | tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2 + + Just (tc, tys) + | Just clas <- tyConClass_maybe tc + -> ClassPred clas tys + + _ | (tvs, rho) <- splitForAllTys ev_ty + , (theta, pred) <- splitFunTys rho + , not (null tvs && null theta) + -> ForAllPred tvs theta pred + + | otherwise + -> IrredPred ev_ty + +-- --------------------- Dictionary types --------------------------------- + +mkClassPred :: Class -> [Type] -> PredType +mkClassPred clas tys = mkTyConApp (classTyCon clas) tys + +isDictTy :: Type -> Bool +isDictTy = isClassPred + +getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) +getClassPredTys ty = case getClassPredTys_maybe ty of + Just (clas, tys) -> (clas, tys) + Nothing -> pprPanic "getClassPredTys" (ppr ty) + +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) +getClassPredTys_maybe ty = case splitTyConApp_maybe ty of + Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys) + _ -> Nothing + +-- --------------------- Equality predicates --------------------------------- + +-- | A choice of equality relation. This is separate from the type 'Role' +-- because 'Phantom' does not define a (non-trivial) equality relation. +data EqRel = NomEq | ReprEq + deriving (Eq, Ord) + +instance Outputable EqRel where + ppr NomEq = text "nominal equality" + ppr ReprEq = text "representational equality" + +eqRelRole :: EqRel -> Role +eqRelRole NomEq = Nominal +eqRelRole ReprEq = Representational + +getEqPredTys :: PredType -> (Type, Type) +getEqPredTys ty + = case splitTyConApp_maybe ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqPrimTyConKey + || tc `hasKey` eqReprPrimTyConKey + -> (ty1, ty2) + _ -> pprPanic "getEqPredTys" (ppr ty) + +getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type) +getEqPredTys_maybe ty + = case splitTyConApp_maybe ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqPrimTyConKey -> Just (Nominal, ty1, ty2) + | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2) + _ -> Nothing + +getEqPredRole :: PredType -> Role +getEqPredRole ty = eqRelRole (predTypeEqRel ty) + +-- | Get the equality relation relevant for a pred type. +predTypeEqRel :: PredType -> EqRel +predTypeEqRel ty + | Just (tc, _) <- splitTyConApp_maybe ty + , tc `hasKey` eqReprPrimTyConKey + = ReprEq + | otherwise + = NomEq + +{------------------------------------------- +Predicates on PredType +--------------------------------------------} + +{- +Note [Evidence for quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The superclass mechanism in TcCanonical.makeSuperClasses risks +taking a quantified constraint like + (forall a. C a => a ~ b) +and generate superclass evidence + (forall a. C a => a ~# b) + +This is a funny thing: neither isPredTy nor isCoVarType are true +of it. So we are careful not to generate it in the first place: +see Note [Equality superclasses in quantified constraints] +in TcCanonical. +-} + +isEvVarType :: Type -> Bool +-- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b) +-- (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2) +-- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep +-- See Note [Evidence for quantified constraints] +isEvVarType ty = isCoVarType ty || isPredTy ty + +isEqPredClass :: Class -> Bool +-- True of (~) and (~~) +isEqPredClass cls = cls `hasKey` eqTyConKey + || cls `hasKey` heqTyConKey + +isClassPred, isEqPred, isEqPrimPred, isIPPred :: PredType -> Bool +isClassPred ty = case tyConAppTyCon_maybe ty of + Just tyCon | isClassTyCon tyCon -> True + _ -> False + +isEqPred ty -- True of (a ~ b) and (a ~~ b) + -- ToDo: should we check saturation? + | Just tc <- tyConAppTyCon_maybe ty + , Just cls <- tyConClass_maybe tc + = isEqPredClass cls + | otherwise + = False + +isEqPrimPred ty = isCoVarType ty + -- True of (a ~# b) (a ~R# b) + +isIPPred ty = case tyConAppTyCon_maybe ty of + Just tc -> isIPTyCon tc + _ -> False + +isIPTyCon :: TyCon -> Bool +isIPTyCon tc = tc `hasKey` ipClassKey + -- Class and its corresponding TyCon have the same Unique + +isIPClass :: Class -> Bool +isIPClass cls = cls `hasKey` ipClassKey + +isCTupleClass :: Class -> Bool +isCTupleClass cls = isTupleTyCon (classTyCon cls) + +isIPPred_maybe :: Type -> Maybe (FastString, Type) +isIPPred_maybe ty = + do (tc,[t1,t2]) <- splitTyConApp_maybe ty + guard (isIPTyCon tc) + x <- isStrLitTy t1 + return (x,t2) + +hasIPPred :: PredType -> Bool +hasIPPred pred + = case classifyPredType pred of + ClassPred cls tys + | isIPClass cls -> True + | isCTupleClass cls -> any hasIPPred tys + _other -> False + +{- +************************************************************************ +* * + Evidence variables +* * +************************************************************************ +-} + +isEvVar :: Var -> Bool +isEvVar var = isEvVarType (varType var) + +isDictId :: Id -> Bool +isDictId id = isDictTy (varType id) diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index 9d2a209993..31b27b03e6 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -40,11 +40,12 @@ import GHC.Core.Utils ( exprType, eqExpr, mkTick, mkTicks , stripTicksTopT, stripTicksTopE , isJoinBind ) import GHC.Core.Ppr ( pprRules ) -import Type ( Type, TCvSubst, extendTvSubst, extendCvSubst - , mkEmptyTCvSubst, substTy ) +import GHC.Core.Type as Type + ( Type, TCvSubst, extendTvSubst, extendCvSubst + , mkEmptyTCvSubst, substTy ) import TcType ( tcSplitTyConApp_maybe ) import TysWiredIn ( anyTypeOfKind ) -import Coercion +import GHC.Core.Coercion as Coercion import GHC.Core.Op.Tidy ( tidyRules ) import Id import IdInfo ( RuleInfo( RuleInfo ) ) @@ -55,7 +56,7 @@ import Name ( Name, NamedThing(..), nameIsLocalOrFrom ) import NameSet import NameEnv import UniqFM -import Unify ( ruleMatchTyKiX ) +import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import BasicTypes import GHC.Driver.Session ( DynFlags ) import Outputable @@ -181,7 +182,7 @@ mkRule this_mod is_auto is_local name act fn bndrs args rhs ru_orphan = orph, ru_auto = is_auto, ru_local = is_local } where - -- Compute orphanhood. See Note [Orphans] in InstEnv + -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv -- A rule is an orphan only if none of the variables -- mentioned on its left-hand side are locally defined lhs_names = extendNameSet (exprsOrphNames args) fn @@ -734,7 +735,7 @@ match _ _ e@Tick{} _ -- might substitute [a/b] in the template, and then erroneously -- succeed in matching what looks like the template variable 'a' against 3. --- The Var case follows closely what happens in Unify.match +-- The Var case follows closely what happens in GHC.Core.Unify.match match renv subst (Var v1) e2 = match_var renv subst v1 e2 diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs index 5c600296e0..13a0841503 100644 --- a/compiler/GHC/Core/Seq.hs +++ b/compiler/GHC/Core/Seq.hs @@ -19,8 +19,8 @@ import Cpr( seqCprSig ) import BasicTypes( seqOccInfo ) import VarSet( seqDVarSet ) import Var( varType, tyVarKind ) -import Type( seqType, isTyVar ) -import Coercion( seqCo ) +import GHC.Core.Type( seqType, isTyVar ) +import GHC.Core.Coercion( seqCo ) import Id( Id, idInfo ) -- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index f9665140b1..829e746498 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -38,13 +38,13 @@ import IdInfo ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) import Var ( isNonCoVarId ) import VarSet import VarEnv -import DataCon +import GHC.Core.DataCon import Demand( etaExpandStrictSig ) -import OptCoercion ( optCoercion ) -import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import Coercion hiding ( substCo, substCoVarBndr ) -import TyCon ( tyConArity ) +import GHC.Core.Coercion.Opt ( optCoercion ) +import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) +import GHC.Core.TyCon ( tyConArity ) import TysWiredIn import PrelNames import BasicTypes diff --git a/compiler/GHC/Core/Stats.hs b/compiler/GHC/Core/Stats.hs index fe288f5348..148255e140 100644 --- a/compiler/GHC/Core/Stats.hs +++ b/compiler/GHC/Core/Stats.hs @@ -16,9 +16,9 @@ import GhcPrelude import BasicTypes import GHC.Core import Outputable -import Coercion +import GHC.Core.Coercion import Var -import Type (Type, typeSize) +import GHC.Core.Type(Type, typeSize) import Id (isJoinId) data CoreStats = CS { cs_tm :: !Int -- Terms diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index e61088a277..672786aaa6 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -43,13 +43,14 @@ import GHC.Core import GHC.Core.FVs import GHC.Core.Seq import GHC.Core.Utils -import qualified Type -import qualified Coercion +import qualified GHC.Core.Type as Type +import qualified GHC.Core.Coercion as Coercion -- We are defining local versions -import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import Coercion hiding ( substCo, substCoVarBndr ) +import GHC.Core.Type hiding + ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) import PrelNames import VarSet @@ -79,9 +80,9 @@ import Data.List -- -- Some invariants apply to how you use the substitution: -- --- 1. Note [The substitution invariant] in TyCoSubst +-- 1. Note [The substitution invariant] in GHC.Core.TyCo.Subst -- --- 2. Note [Substitutions apply only once] in TyCoSubst +-- 2. Note [Substitutions apply only once] in GHC.Core.TyCo.Subst data Subst = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ -- applying the substitution @@ -104,7 +105,7 @@ Note [Extending the Subst] For a core Subst, which binds Ids as well, we make a different choice for Ids than we do for TyVars. -For TyVars, see Note [Extending the TCvSubst] in TyCoSubst. +For TyVars, see Note [Extending the TCvSubst] in GHC.Core.TyCo.Subst. For Ids, we have a different invariant The IdSubstEnv is extended *only* when the Unique on an Id changes @@ -339,7 +340,7 @@ instance Outputable Subst where -- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only -- apply the substitution /once/: --- See Note [Substitutions apply only once] in TyCoSubst +-- See Note [Substitutions apply only once] in GHC.Core.TyCo.Subst -- -- Do *not* attempt to short-cut in the case of an empty substitution! -- See Note [Extending the Subst] diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs new file mode 100644 index 0000000000..82d7699ed3 --- /dev/null +++ b/compiler/GHC/Core/TyCo/FVs.hs @@ -0,0 +1,984 @@ +{-# LANGUAGE CPP #-} + +module GHC.Core.TyCo.FVs + ( shallowTyCoVarsOfType, shallowTyCoVarsOfTypes, + tyCoVarsOfType, tyCoVarsOfTypes, + tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, + + tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoFVsOfType, tyCoVarsOfTypeList, + tyCoFVsOfTypes, tyCoVarsOfTypesList, + deepTcvFolder, + + shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv, + + shallowTyCoVarsOfCo, shallowTyCoVarsOfCos, + tyCoVarsOfCo, tyCoVarsOfCos, + coVarsOfType, coVarsOfTypes, + coVarsOfCo, coVarsOfCos, + tyCoVarsOfCoDSet, + tyCoFVsOfCo, tyCoFVsOfCos, + tyCoVarsOfCoList, + + almostDevoidCoVarOfCo, + + -- Injective free vars + injectiveVarsOfType, injectiveVarsOfTypes, + invisibleVarsOfType, invisibleVarsOfTypes, + + -- No Free vars + noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, + + -- * Well-scoped free variables + scopedSort, tyCoVarsOfTypeWellScoped, + tyCoVarsOfTypesWellScoped, + + -- * Closing over kinds + closeOverKindsDSet, closeOverKindsList, + closeOverKinds, + + -- * Raw materials + Endo(..), runTyCoVars + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes) + +import Data.Monoid as DM ( Endo(..), All(..) ) +import GHC.Core.TyCo.Rep +import GHC.Core.TyCon +import Var +import FV + +import UniqFM +import VarSet +import VarEnv +import Util +import Panic + +{- +%************************************************************************ +%* * + Free variables of types and coercions +%* * +%************************************************************************ +-} + +{- Note [Shallow and deep free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Definitions + +* Shallow free variables of a type: the variables + affected by substitution. Specifically, the (TyVarTy tv) + and (CoVar cv) that appear + - In the type and coercions appearing in the type + - In shallow free variables of the kind of a Forall binder + but NOT in the kind of the /occurrences/ of a type variable. + +* Deep free variables of a type: shallow free variables, plus + the deep free variables of the kinds of those variables. + That is, deepFVs( t ) = closeOverKinds( shallowFVs( t ) ) + +Examples: + + Type Shallow Deep + --------------------------------- + (a : (k:Type)) {a} {a,k} + forall (a:(k:Type)). a {k} {k} + (a:k->Type) (b:k) {a,b} {a,b,k} +-} + + +{- Note [Free variables of types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns +a VarSet that is closed over the types of its variables. More precisely, + if S = tyCoVarsOfType( t ) + and (a:k) is in S + then tyCoVarsOftype( k ) is a subset of S + +Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}. + +We could /not/ close over the kinds of the variable occurrences, and +instead do so at call sites, but it seems that we always want to do +so, so it's easiest to do it here. + +It turns out that getting the free variables of types is performance critical, +so we profiled several versions, exploring different implementation strategies. + +1. Baseline version: uses FV naively. Essentially: + + tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty + + This is not nice, because FV introduces some overhead to implement + determinism, and through its "interesting var" function, neither of which + we need here, so they are a complete waste. + +2. UnionVarSet version: instead of reusing the FV-based code, we simply used + VarSets directly, trying to avoid the overhead of FV. E.g.: + + -- FV version: + tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c + + -- UnionVarSet version: + tyCoVarsOfType (AppTy fun arg) = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg) + + This looks deceptively similar, but while FV internally builds a list- and + set-generating function, the VarSet functions manipulate sets directly, and + the latter performs a lot worse than the naive FV version. + +3. Accumulator-style VarSet version: this is what we use now. We do use VarSet + as our data structure, but delegate the actual work to a new + ty_co_vars_of_... family of functions, which use accumulator style and the + "in-scope set" filter found in the internals of FV, but without the + determinism overhead. + +See #14880. + +Note [Closing over free variable kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over +free variable kinds. In previous GHC versions, this happened naively: whenever +we would encounter an occurrence of a free type variable, we would close over +its kind. This, however is wrong for two reasons (see #14880): + +1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then + we don't want to have to traverse k more than once. + +2. Correctness. Imagine we have forall k. b -> k, where b has + kind k, for some k bound in an outer scope. If we look at b's kind inside + the forall, we'll collect that k is free and then remove k from the set of + free variables. This is plain wrong. We must instead compute that b is free + and then conclude that b's kind is free. + +An obvious first approach is to move the closing-over-kinds from the +occurrences of a type variable to after finding the free vars - however, this +turns out to introduce performance regressions, and isn't even entirely +correct. + +In fact, it isn't even important *when* we close over kinds; what matters is +that we handle each type var exactly once, and that we do it in the right +context. + +So the next approach we tried was to use the "in-scope set" part of FV or the +equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to +say "don't bother with variables we have already closed over". This should work +fine in theory, but the code is complicated and doesn't perform well. + +But there is a simpler way, which is implemented here. Consider the two points +above: + +1. Efficiency: we now have an accumulator, so the second time we encounter 'a', + we'll ignore it, certainly not looking at its kind - this is why + pre-checking set membership before inserting ends up not only being faster, + but also being correct. + +2. Correctness: we have an "in-scope set" (I think we should call it it a + "bound-var set"), specifying variables that are bound by a forall in the type + we are traversing; we simply ignore these variables, certainly not looking at + their kind. + +So now consider: + + forall k. b -> k + +where b :: k->Type is free; but of course, it's a different k! When looking at +b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose +this is our first encounter with b; we want the free vars of its kind. But we +want to behave as if we took the free vars of its kind at the end; that is, +with no bound vars in scope. + +So the solution is easy. The old code was this: + + ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v) + +Now all we need to do is take the free vars of tyVarKind v *with an empty +bound-var set*, thus: + +ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v) + ^^^^^^^^^^^ + +And that's it. This works because a variable is either bound or free. If it is bound, +then we won't look at it at all. If it is free, then all the variables free in its +kind are free -- regardless of whether some local variable has the same Unique. +So if we're looking at a variable occurrence at all, then all variables in its +kind are free. +-} + +{- ********************************************************************* +* * + Endo for free variables +* * +********************************************************************* -} + +{- Note [Acumulating parameter free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can use foldType to build an accumulating-parameter version of a +free-var finder, thus: + + fvs :: Type -> TyCoVarSet + fvs ty = appEndo (foldType folder ty) emptyVarSet + +Recall that + foldType :: TyCoFolder env a -> env -> Type -> a + + newtype Endo a = Endo (a -> a) -- In Data.Monoid + instance Monoid a => Monoid (Endo a) where + (Endo f) `mappend` (Endo g) = Endo (f.g) + + appEndo :: Endo a -> a -> a + appEndo (Endo f) x = f x + +So `mappend` for Endos is just function composition. + +It's very important that, after optimisation, we end up with +* an arity-three function +* that is strict in the accumulator + + fvs env (TyVarTy v) acc + | v `elemVarSet` env = acc + | v `elemVarSet` acc = acc + | otherwise = acc `extendVarSet` v + fvs env (AppTy t1 t2) = fvs env t1 (fvs env t2 acc) + ... + +The "strict in the accumulator" part is to ensure that in the +AppTy equation we don't build a thunk for (fvs env t2 acc). + +The optimiser does do all this, but not very robustly. It depends +critially on the basic arity-2 function not being exported, so that +all its calls are visibly to three arguments. This analysis is +done by the Call Arity pass. + +TL;DR: check this regularly! +-} + +runTyCoVars :: Endo TyCoVarSet -> TyCoVarSet +{-# INLINE runTyCoVars #-} +runTyCoVars f = appEndo f emptyVarSet + +noView :: Type -> Maybe Type +noView _ = Nothing + +{- ********************************************************************* +* * + Deep free variables + See Note [Shallow and deep free variables] +* * +********************************************************************* -} + +tyCoVarsOfType :: Type -> TyCoVarSet +tyCoVarsOfType ty = runTyCoVars (deep_ty ty) +-- Alternative: +-- tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty) + +tyCoVarsOfTypes :: [Type] -> TyCoVarSet +tyCoVarsOfTypes tys = runTyCoVars (deep_tys tys) +-- Alternative: +-- tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys) + +tyCoVarsOfCo :: Coercion -> TyCoVarSet +-- See Note [Free variables of Coercions] +tyCoVarsOfCo co = runTyCoVars (deep_co co) + +tyCoVarsOfCos :: [Coercion] -> TyCoVarSet +tyCoVarsOfCos cos = runTyCoVars (deep_cos cos) + +deep_ty :: Type -> Endo TyCoVarSet +deep_tys :: [Type] -> Endo TyCoVarSet +deep_co :: Coercion -> Endo TyCoVarSet +deep_cos :: [Coercion] -> Endo TyCoVarSet +(deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet + +deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +deepTcvFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tcv is v = Endo do_it + where + do_it acc | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = appEndo (deep_ty (varType v)) $ + acc `extendVarSet` v + + do_bndr is tcv _ = extendVarSet is tcv + do_hole is hole = do_tcv is (coHoleCoVar hole) + -- See Note [CoercionHoles and coercion free variables] + -- in GHC.Core.TyCo.Rep + +{- ********************************************************************* +* * + Shallow free variables + See Note [Shallow and deep free variables] +* * +********************************************************************* -} + + +shallowTyCoVarsOfType :: Type -> TyCoVarSet +-- See Note [Free variables of types] +shallowTyCoVarsOfType ty = runTyCoVars (shallow_ty ty) + +shallowTyCoVarsOfTypes :: [Type] -> TyCoVarSet +shallowTyCoVarsOfTypes tys = runTyCoVars (shallow_tys tys) + +shallowTyCoVarsOfCo :: Coercion -> TyCoVarSet +shallowTyCoVarsOfCo co = runTyCoVars (shallow_co co) + +shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet +shallowTyCoVarsOfCos cos = runTyCoVars (shallow_cos cos) + +-- | Returns free variables of types, including kind variables as +-- a non-deterministic set. For type synonyms it does /not/ expand the +-- synonym. +shallowTyCoVarsOfTyVarEnv :: TyVarEnv Type -> TyCoVarSet +-- See Note [Free variables of types] +shallowTyCoVarsOfTyVarEnv tys = shallowTyCoVarsOfTypes (nonDetEltsUFM tys) + -- It's OK to use nonDetEltsUFM here because we immediately + -- forget the ordering by returning a set + +shallowTyCoVarsOfCoVarEnv :: CoVarEnv Coercion -> TyCoVarSet +shallowTyCoVarsOfCoVarEnv cos = shallowTyCoVarsOfCos (nonDetEltsUFM cos) + -- It's OK to use nonDetEltsUFM here because we immediately + -- forget the ordering by returning a set + +shallow_ty :: Type -> Endo TyCoVarSet +shallow_tys :: [Type] -> Endo TyCoVarSet +shallow_co :: Coercion -> Endo TyCoVarSet +shallow_cos :: [Coercion] -> Endo TyCoVarSet +(shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet + +shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +shallowTcvFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tcv is v = Endo do_it + where + do_it acc | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = acc `extendVarSet` v + + do_bndr is tcv _ = extendVarSet is tcv + do_hole _ _ = mempty -- Ignore coercion holes + + +{- ********************************************************************* +* * + Free coercion variables +* * +********************************************************************* -} + + +{- Note [Finding free coercion varibles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here we are only interested in the free /coercion/ variables. +We can achieve this through a slightly differnet TyCo folder. + +Notice that we look deeply, into kinds. + +See #14880. +-} + +coVarsOfType :: Type -> CoVarSet +coVarsOfTypes :: [Type] -> CoVarSet +coVarsOfCo :: Coercion -> CoVarSet +coVarsOfCos :: [Coercion] -> CoVarSet + +coVarsOfType ty = runTyCoVars (deep_cv_ty ty) +coVarsOfTypes tys = runTyCoVars (deep_cv_tys tys) +coVarsOfCo co = runTyCoVars (deep_cv_co co) +coVarsOfCos cos = runTyCoVars (deep_cv_cos cos) + +deep_cv_ty :: Type -> Endo CoVarSet +deep_cv_tys :: [Type] -> Endo CoVarSet +deep_cv_co :: Coercion -> Endo CoVarSet +deep_cv_cos :: [Coercion] -> Endo CoVarSet +(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder emptyVarSet + +deepCoVarFolder :: TyCoFolder TyCoVarSet (Endo CoVarSet) +deepCoVarFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tyvar, tcf_covar = do_covar + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tyvar _ _ = mempty + -- This do_tyvar means we won't see any CoVars in this + -- TyVar's kind. This may be wrong; but it's the way it's + -- always been. And its awkward to change, because + -- the tyvar won't end up in the accumulator, so + -- we'd look repeatedly. Blargh. + + do_covar is v = Endo do_it + where + do_it acc | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = appEndo (deep_cv_ty (varType v)) $ + acc `extendVarSet` v + + do_bndr is tcv _ = extendVarSet is tcv + do_hole is hole = do_covar is (coHoleCoVar hole) + -- See Note [CoercionHoles and coercion free variables] + -- in GHC.Core.TyCo.Rep + + +{- ********************************************************************* +* * + Closing over kinds +* * +********************************************************************* -} + +------------- Closing over kinds ----------------- + +closeOverKinds :: TyCoVarSet -> TyCoVarSet +-- For each element of the input set, +-- add the deep free variables of its kind +closeOverKinds vs = nonDetFoldVarSet do_one vs vs + where + do_one v acc = appEndo (deep_ty (varType v)) acc + +{- --------------- Alternative version 1 (using FV) ------------ +closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet +-} + +{- ---------------- Alternative version 2 ------------- + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a non-deterministic set. +closeOverKinds :: TyCoVarSet -> TyCoVarSet +closeOverKinds vs + = go vs vs + where + go :: VarSet -- Work list + -> VarSet -- Accumulator, always a superset of wl + -> VarSet + go wl acc + | isEmptyVarSet wl = acc + | otherwise = go wl_kvs (acc `unionVarSet` wl_kvs) + where + k v inner_acc = ty_co_vars_of_type (varType v) acc inner_acc + wl_kvs = nonDetFoldVarSet k emptyVarSet wl + -- wl_kvs = union of shallow free vars of the kinds of wl + -- but don't bother to collect vars in acc + +-} + +{- ---------------- Alternative version 3 ------------- +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a non-deterministic set. +closeOverKinds :: TyVarSet -> TyVarSet +closeOverKinds vs = close_over_kinds vs emptyVarSet + + +close_over_kinds :: TyVarSet -- Work list + -> TyVarSet -- Accumulator + -> TyVarSet +-- Precondition: in any call (close_over_kinds wl acc) +-- for every tv in acc, the shallow kind-vars of tv +-- are either in the work list wl, or in acc +-- Postcondition: result is the deep free vars of (wl `union` acc) +close_over_kinds wl acc + = nonDetFoldVarSet do_one acc wl + where + do_one :: Var -> TyVarSet -> TyVarSet + -- (do_one v acc) adds v and its deep free-vars to acc + do_one v acc | v `elemVarSet` acc + = acc + | otherwise + = close_over_kinds (shallowTyCoVarsOfType (varType v)) $ + acc `extendVarSet` v +-} + + +{- ********************************************************************* +* * + The FV versions return deterministic results +* * +********************************************************************* -} + +-- | Given a list of tyvars returns a deterministic FV computation that +-- returns the given tyvars with the kind variables free in the kinds of the +-- given tyvars. +closeOverKindsFV :: [TyVar] -> FV +closeOverKindsFV tvs = + mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministically ordered list. +closeOverKindsList :: [TyVar] -> [TyVar] +closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministic set. +closeOverKindsDSet :: DTyVarSet -> DTyVarSet +closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems + +-- | `tyCoFVsOfType` that returns free variables of a type in a deterministic +-- set. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in FV. +tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty + +-- | `tyCoFVsOfType` that returns free variables of a type in deterministic +-- order. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in FV. +tyCoVarsOfTypeList :: Type -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty + +-- | Returns free variables of types, including kind variables as +-- a deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys + +-- | Returns free variables of types, including kind variables as +-- a deterministically ordered list. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesList :: [Type] -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys + +-- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`. +-- The previous implementation used `unionVarSet` which is O(n+m) and can +-- make the function quadratic. +-- It's exported, so that it can be composed with +-- other functions that compute free variables. +-- See Note [FV naming conventions] in FV. +-- +-- Eta-expanded because that makes it run faster (apparently) +-- See Note [FV eta expansion] in FV for explanation. +tyCoFVsOfType :: Type -> FV +-- See Note [Free variables of types] +tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) + | not (f v) = (acc_list, acc_set) + | v `elemVarSet` bound_vars = (acc_list, acc_set) + | v `elemVarSet` acc_set = (acc_list, acc_set) + | otherwise = tyCoFVsOfType (tyVarKind v) f + emptyVarSet -- See Note [Closing over free variable kinds] + (v:acc_list, extendVarSet acc_set v) +tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc +tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc +tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc +tyCoFVsOfType (FunTy _ arg res) f bound_vars acc = (tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc +tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc +tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc +tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc + +tyCoFVsBndr :: TyCoVarBinder -> FV -> FV +-- Free vars of (forall b. <thing with fvs>) +tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs + +tyCoFVsVarBndrs :: [Var] -> FV -> FV +tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars + +tyCoFVsVarBndr :: Var -> FV -> FV +tyCoFVsVarBndr var fvs + = tyCoFVsOfType (varType var) -- Free vars of its type/kind + `unionFV` delFV var fvs -- Delete it from the thing-inside + +tyCoFVsOfTypes :: [Type] -> FV +-- See Note [Free variables of types] +tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc +tyCoFVsOfTypes [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +-- | Get a deterministic set of the vars free in a coercion +tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co + +tyCoVarsOfCoList :: Coercion -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co + +tyCoFVsOfMCo :: MCoercion -> FV +tyCoFVsOfMCo MRefl = emptyFV +tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co + +tyCoFVsOfCo :: Coercion -> FV +-- Extracts type and coercion variables from a coercion +-- See Note [Free variables of types] +tyCoFVsOfCo (Refl ty) fv_cand in_scope acc + = tyCoFVsOfType ty fv_cand in_scope acc +tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc + = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc +tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc +tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc + = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc +tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc + = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc +tyCoFVsOfCo (FunCo _ co1 co2) fv_cand in_scope acc + = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc +tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc + = tyCoFVsOfCoVar v fv_cand in_scope acc +tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc + = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc + -- See Note [CoercionHoles and coercion free variables] +tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc +tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc + = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1 + `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc +tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc +tyCoFVsOfCo (NthCo _ _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc +tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc + +tyCoFVsOfCoVar :: CoVar -> FV +tyCoFVsOfCoVar v fv_cand in_scope acc + = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc + +tyCoFVsOfProv :: UnivCoProvenance -> FV +tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +tyCoFVsOfCos :: [Coercion] -> FV +tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc + + +----- Whether a covar is /Almost Devoid/ in a type or coercion ---- + +-- | Given a covar and a coercion, returns True if covar is almost devoid in +-- the coercion. That is, covar can only appear in Refl and GRefl. +-- See last wrinkle in Note [Unused coercion variable in ForAllCo] in GHC.Core.Coercion +almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool +almostDevoidCoVarOfCo cv co = + almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool +almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and +almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into + -- the coercions +almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv + = almost_devoid_co_var_of_cos cos cv +almost_devoid_co_var_of_co (AppCo co arg) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_co arg cv +almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv + = almost_devoid_co_var_of_co kind_co cv + && (v == cv || almost_devoid_co_var_of_co co cv) +almost_devoid_co_var_of_co (FunCo _ co1 co2) cv + = almost_devoid_co_var_of_co co1 cv + && almost_devoid_co_var_of_co co2 cv +almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv +almost_devoid_co_var_of_co (HoleCo h) cv = (coHoleCoVar h) /= cv +almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv + = almost_devoid_co_var_of_cos cos cv +almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv + = almost_devoid_co_var_of_prov p cv + && almost_devoid_co_var_of_type t1 cv + && almost_devoid_co_var_of_type t2 cv +almost_devoid_co_var_of_co (SymCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (TransCo co1 co2) cv + = almost_devoid_co_var_of_co co1 cv + && almost_devoid_co_var_of_co co2 cv +almost_devoid_co_var_of_co (NthCo _ _ co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (LRCo _ co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (InstCo co arg) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_co arg cv +almost_devoid_co_var_of_co (KindCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (SubCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv + = almost_devoid_co_var_of_cos cs cv + +almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool +almost_devoid_co_var_of_cos [] _ = True +almost_devoid_co_var_of_cos (co:cos) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_cos cos cv + +almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool +almost_devoid_co_var_of_prov (PhantomProv co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_prov (ProofIrrelProv co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_prov (PluginProv _) _ = True + +almost_devoid_co_var_of_type :: Type -> CoVar -> Bool +almost_devoid_co_var_of_type (TyVarTy _) _ = True +almost_devoid_co_var_of_type (TyConApp _ tys) cv + = almost_devoid_co_var_of_types tys cv +almost_devoid_co_var_of_type (LitTy {}) _ = True +almost_devoid_co_var_of_type (AppTy fun arg) cv + = almost_devoid_co_var_of_type fun cv + && almost_devoid_co_var_of_type arg cv +almost_devoid_co_var_of_type (FunTy _ arg res) cv + = almost_devoid_co_var_of_type arg cv + && almost_devoid_co_var_of_type res cv +almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv + = almost_devoid_co_var_of_type (varType v) cv + && (v == cv || almost_devoid_co_var_of_type ty cv) +almost_devoid_co_var_of_type (CastTy ty co) cv + = almost_devoid_co_var_of_type ty cv + && almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_type (CoercionTy co) cv + = almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool +almost_devoid_co_var_of_types [] _ = True +almost_devoid_co_var_of_types (ty:tys) cv + = almost_devoid_co_var_of_type ty cv + && almost_devoid_co_var_of_types tys cv + + + +{- ********************************************************************* +* * + Injective free vars +* * +********************************************************************* -} + +-- | Returns the free variables of a 'Type' that are in injective positions. +-- Specifically, it finds the free variables while: +-- +-- * Expanding type synonyms +-- +-- * Ignoring the coercion in @(ty |> co)@ +-- +-- * Ignoring the non-injective fields of a 'TyConApp' +-- +-- +-- For example, if @F@ is a non-injective type family, then: +-- +-- @ +-- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c} +-- @ +-- +-- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@. +-- More formally, if +-- @a@ is in @'injectiveVarsOfType' ty@ +-- and @S1(ty) ~ S2(ty)@, +-- then @S1(a) ~ S2(a)@, +-- where @S1@ and @S2@ are arbitrary substitutions. +-- +-- See @Note [When does a tycon application need an explicit kind signature?]@. +injectiveVarsOfType :: Bool -- ^ Should we look under injective type families? + -- See Note [Coverage condition for injective type families] + -- in FamInst. + -> Type -> FV +injectiveVarsOfType look_under_tfs = go + where + go ty | Just ty' <- coreView ty + = go ty' + go (TyVarTy v) = unitFV v `unionFV` go (tyVarKind v) + go (AppTy f a) = go f `unionFV` go a + go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 + go (TyConApp tc tys) = + case tyConInjectivityInfo tc of + Injective inj + | look_under_tfs || not (isTypeFamilyTyCon tc) + -> mapUnionFV go $ + filterByList (inj ++ repeat True) tys + -- Oversaturated arguments to a tycon are + -- always injective, hence the repeat True + _ -> emptyFV + go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty) + go LitTy{} = emptyFV + go (CastTy ty _) = go ty + go CoercionTy{} = emptyFV + +-- | Returns the free variables of a 'Type' that are in injective positions. +-- Specifically, it finds the free variables while: +-- +-- * Expanding type synonyms +-- +-- * Ignoring the coercion in @(ty |> co)@ +-- +-- * Ignoring the non-injective fields of a 'TyConApp' +-- +-- See @Note [When does a tycon application need an explicit kind signature?]@. +injectiveVarsOfTypes :: Bool -- ^ look under injective type families? + -- See Note [Coverage condition for injective type families] + -- in FamInst. + -> [Type] -> FV +injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under_tfs) + + +{- ********************************************************************* +* * + Invisible vars +* * +********************************************************************* -} + + +-- | Returns the set of variables that are used invisibly anywhere within +-- the given type. A variable will be included even if it is used both visibly +-- and invisibly. An invisible use site includes: +-- * In the kind of a variable +-- * In the kind of a bound variable in a forall +-- * In a coercion +-- * In a Specified or Inferred argument to a function +-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep +invisibleVarsOfType :: Type -> FV +invisibleVarsOfType = go + where + go ty | Just ty' <- coreView ty + = go ty' + go (TyVarTy v) = go (tyVarKind v) + go (AppTy f a) = go f `unionFV` go a + go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 + go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV` + invisibleVarsOfTypes visibles + where (invisibles, visibles) = partitionInvisibleTypes tc tys + go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty + go LitTy{} = emptyFV + go (CastTy ty co) = tyCoFVsOfCo co `unionFV` go ty + go (CoercionTy co) = tyCoFVsOfCo co + +-- | Like 'invisibleVarsOfType', but for many types. +invisibleVarsOfTypes :: [Type] -> FV +invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType + + +{- ********************************************************************* +* * + No free vars +* * +********************************************************************* -} + +nfvFolder :: TyCoFolder TyCoVarSet DM.All +nfvFolder = TyCoFolder { tcf_view = noView + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole, tcf_tycobinder = do_bndr } + where + do_tcv is tv = All (tv `elemVarSet` is) + do_hole _ _ = All True -- I'm unsure; probably never happens + do_bndr is tv _ = is `extendVarSet` tv + +nfv_ty :: Type -> DM.All +nfv_tys :: [Type] -> DM.All +nfv_co :: Coercion -> DM.All +(nfv_ty, nfv_tys, nfv_co, _) = foldTyCo nfvFolder emptyVarSet + +noFreeVarsOfType :: Type -> Bool +noFreeVarsOfType ty = DM.getAll (nfv_ty ty) + +noFreeVarsOfTypes :: [Type] -> Bool +noFreeVarsOfTypes tys = DM.getAll (nfv_tys tys) + +noFreeVarsOfCo :: Coercion -> Bool +noFreeVarsOfCo co = getAll (nfv_co co) + + +{- ********************************************************************* +* * + scopedSort +* * +********************************************************************* -} + +{- Note [ScopedSort] +~~~~~~~~~~~~~~~~~~~~ +Consider + + foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> () + +This function type is implicitly generalised over [a, b, k, k2]. These +variables will be Specified; that is, they will be available for visible +type application. This is because they are written in the type signature +by the user. + +However, we must ask: what order will they appear in? In cases without +dependency, this is easy: we just use the lexical left-to-right ordering +of first occurrence. With dependency, we cannot get off the hook so +easily. + +We thus state: + + * These variables appear in the order as given by ScopedSort, where + the input to ScopedSort is the left-to-right order of first occurrence. + +Note that this applies only to *implicit* quantification, without a +`forall`. If the user writes a `forall`, then we just use the order given. + +ScopedSort is defined thusly (as proposed in #15743): + * Work left-to-right through the input list, with a cursor. + * If variable v at the cursor is depended on by any earlier variable w, + move v immediately before the leftmost such w. + +INVARIANT: The prefix of variables before the cursor form a valid telescope. + +Note that ScopedSort makes sense only after type inference is done and all +types/kinds are fully settled and zonked. + +-} + +-- | Do a topological sort on a list of tyvars, +-- so that binders occur before occurrences +-- E.g. given [ a::k, k::*, b::k ] +-- it'll return a well-scoped list [ k::*, a::k, b::k ] +-- +-- This is a deterministic sorting operation +-- (that is, doesn't depend on Uniques). +-- +-- It is also meant to be stable: that is, variables should not +-- be reordered unnecessarily. This is specified in Note [ScopedSort] +-- See also Note [Ordering of implicit variables] in GHC.Rename.Types + +scopedSort :: [TyCoVar] -> [TyCoVar] +scopedSort = go [] [] + where + go :: [TyCoVar] -- already sorted, in reverse order + -> [TyCoVarSet] -- each set contains all the variables which must be placed + -- before the tv corresponding to the set; they are accumulations + -- of the fvs in the sorted tvs' kinds + + -- This list is in 1-to-1 correspondence with the sorted tyvars + -- INVARIANT: + -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list) + -- That is, each set in the list is a superset of all later sets. + + -> [TyCoVar] -- yet to be sorted + -> [TyCoVar] + go acc _fv_list [] = reverse acc + go acc fv_list (tv:tvs) + = go acc' fv_list' tvs + where + (acc', fv_list') = insert tv acc fv_list + + insert :: TyCoVar -- var to insert + -> [TyCoVar] -- sorted list, in reverse order + -> [TyCoVarSet] -- list of fvs, as above + -> ([TyCoVar], [TyCoVarSet]) -- augmented lists + insert tv [] [] = ([tv], [tyCoVarsOfType (tyVarKind tv)]) + insert tv (a:as) (fvs:fvss) + | tv `elemVarSet` fvs + , (as', fvss') <- insert tv as fvss + = (a:as', fvs `unionVarSet` fv_tv : fvss') + + | otherwise + = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss) + where + fv_tv = tyCoVarsOfType (tyVarKind tv) + + -- lists not in correspondence + insert _ _ _ = panic "scopedSort" + +-- | Get the free vars of a type in scoped order +tyCoVarsOfTypeWellScoped :: Type -> [TyVar] +tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList + +-- | Get the free vars of types in scoped order +tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] +tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList + diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs new file mode 100644 index 0000000000..3d4c065aba --- /dev/null +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -0,0 +1,341 @@ +-- | Pretty-printing types and coercions. +module GHC.Core.TyCo.Ppr + ( + -- * Precedence + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, + + -- * Pretty-printing types + pprType, pprParendType, pprTidiedType, pprPrecType, pprPrecTypeX, + pprTypeApp, pprTCvBndr, pprTCvBndrs, + pprSigmaType, + pprTheta, pprParendTheta, pprForAll, pprUserForAll, + pprTyVar, pprTyVars, + pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprTyLit, + pprDataCons, pprWithExplicitKindsWhen, + pprWithTYPE, pprSourceTyCon, + + + -- * Pretty-printing coercions + pprCo, pprParendCo, + + debugPprType, + + -- * Pretty-printing 'TyThing's + pprTyThingCategory, pprShortTyThing, + ) where + +import GhcPrelude + +import {-# SOURCE #-} GHC.CoreToIface + ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr + , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) + +import {-# SOURCE #-} GHC.Core.DataCon + ( dataConFullSig , dataConUserTyVarBinders + , DataCon ) + +import {-# SOURCE #-} GHC.Core.Type + ( isLiftedTypeKind ) + +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Tidy +import GHC.Core.TyCo.FVs +import GHC.Core.Class +import Var + +import GHC.Iface.Type + +import VarSet +import VarEnv + +import Outputable +import BasicTypes ( PprPrec(..), topPrec, sigPrec, opPrec + , funPrec, appPrec, maybeParen ) + +{- +%************************************************************************ +%* * + Pretty-printing types + + Defined very early because of debug printing in assertions +%* * +%************************************************************************ + +@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is +defined to use this. @pprParendType@ is the same, except it puts +parens around the type, except for the atomic cases. @pprParendType@ +works just by setting the initial context precedence very high. + +Note that any function which pretty-prints a @Type@ first converts the @Type@ +to an @IfaceType@. See Note [IfaceType and pretty-printing] in GHC.Iface.Type. + +See Note [Precedence in types] in BasicTypes. +-} + +-------------------------------------------------------- +-- When pretty-printing types, we convert to IfaceType, +-- and pretty-print that. +-- See Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing +-------------------------------------------------------- + +pprType, pprParendType, pprTidiedType :: Type -> SDoc +pprType = pprPrecType topPrec +pprParendType = pprPrecType appPrec + +-- already pre-tidied +pprTidiedType = pprIfaceType . toIfaceTypeX emptyVarSet + +pprPrecType :: PprPrec -> Type -> SDoc +pprPrecType = pprPrecTypeX emptyTidyEnv + +pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc +pprPrecTypeX env prec ty + = getPprStyle $ \sty -> + if debugStyle sty -- Use debugPprType when in + then debug_ppr_ty prec ty -- when in debug-style + else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty) + -- NB: debug-style is used for -dppr-debug + -- dump-style is used for -ddump-tc-trace etc + +pprTyLit :: TyLit -> SDoc +pprTyLit = pprIfaceTyLit . toIfaceTyLit + +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType + +tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType +tidyToIfaceTypeStyX env ty sty + | userStyle sty = tidyToIfaceTypeX env ty + | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty + -- in latter case, don't tidy, as we'll be printing uniques. + +tidyToIfaceType :: Type -> IfaceType +tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv + +tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceTypeX to +-- leave them as IfaceFreeTyVar. This is super-important +-- for debug printing. +tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty) + where + env' = tidyFreeTyCoVars env free_tcvs + free_tcvs = tyCoVarsOfTypeWellScoped ty + +------------ +pprCo, pprParendCo :: Coercion -> SDoc +pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty) +pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty) + +tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion +tidyToIfaceCoSty co sty + | userStyle sty = tidyToIfaceCo co + | otherwise = toIfaceCoercionX (tyCoVarsOfCo co) co + -- in latter case, don't tidy, as we'll be printing uniques. + +tidyToIfaceCo :: Coercion -> IfaceCoercion +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceCoercionX to +-- leave them as IfaceFreeCoVar. This is super-important +-- for debug printing. +tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co) + where + env = tidyFreeTyCoVars emptyTidyEnv free_tcvs + free_tcvs = scopedSort $ tyCoVarsOfCoList co +------------ +pprClassPred :: Class -> [Type] -> SDoc +pprClassPred clas tys = pprTypeApp (classTyCon clas) tys + +------------ +pprTheta :: ThetaType -> SDoc +pprTheta = pprIfaceContext topPrec . map tidyToIfaceType + +pprParendTheta :: ThetaType -> SDoc +pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType + +pprThetaArrowTy :: ThetaType -> SDoc +pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType + +------------------ +pprSigmaType :: Type -> SDoc +pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType + +pprForAll :: [TyCoVarBinder] -> SDoc +pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) + +-- | Print a user-level forall; see Note [When to print foralls] in this module. +pprUserForAll :: [TyCoVarBinder] -> SDoc +pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr + +pprTCvBndrs :: [TyCoVarBinder] -> SDoc +pprTCvBndrs tvs = sep (map pprTCvBndr tvs) + +pprTCvBndr :: TyCoVarBinder -> SDoc +pprTCvBndr = pprTyVar . binderVar + +pprTyVars :: [TyVar] -> SDoc +pprTyVars tvs = sep (map pprTyVar tvs) + +pprTyVar :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +-- Here we do not go via IfaceType, because the duplication with +-- pprIfaceTvBndr is minimal, and the loss of uniques etc in +-- debug printing is disastrous +pprTyVar tv + | isLiftedTypeKind kind = ppr tv + | otherwise = parens (ppr tv <+> dcolon <+> ppr kind) + where + kind = tyVarKind tv + +----------------- +debugPprType :: Type -> SDoc +-- ^ debugPprType is a simple pretty printer that prints a type +-- without going through IfaceType. It does not format as prettily +-- as the normal route, but it's much more direct, and that can +-- be useful for debugging. E.g. with -dppr-debug it prints the +-- kind on type-variable /occurrences/ which the normal route +-- fundamentally cannot do. +debugPprType ty = debug_ppr_ty topPrec ty + +debug_ppr_ty :: PprPrec -> Type -> SDoc +debug_ppr_ty _ (LitTy l) + = ppr l + +debug_ppr_ty _ (TyVarTy tv) + = ppr tv -- With -dppr-debug we get (tv :: kind) + +debug_ppr_ty prec (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) + = maybeParen prec funPrec $ + sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res] + where + arrow = case af of + VisArg -> text "->" + InvisArg -> text "=>" + +debug_ppr_ty prec (TyConApp tc tys) + | null tys = ppr tc + | otherwise = maybeParen prec appPrec $ + hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys)) + +debug_ppr_ty _ (AppTy t1 t2) + = hang (debug_ppr_ty appPrec t1) -- Print parens so we see ((a b) c) + 2 (debug_ppr_ty appPrec t2) -- so that we can distinguish + -- TyConApp from AppTy + +debug_ppr_ty prec (CastTy ty co) + = maybeParen prec topPrec $ + hang (debug_ppr_ty topPrec ty) + 2 (text "|>" <+> ppr co) + +debug_ppr_ty _ (CoercionTy co) + = parens (text "CO" <+> ppr co) + +debug_ppr_ty prec ty@(ForAllTy {}) + | (tvs, body) <- split ty + = maybeParen prec funPrec $ + hang (text "forall" <+> fsep (map ppr tvs) <> dot) + -- The (map ppr tvs) will print kind-annotated + -- tvs, because we are (usually) in debug-style + 2 (ppr body) + where + split ty | ForAllTy tv ty' <- ty + , (tvs, body) <- split ty' + = (tv:tvs, body) + | otherwise + = ([], ty) + +{- +Note [When to print foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Mostly we want to print top-level foralls when (and only when) the user specifies +-fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses +too much information; see #9018. + +So I'm trying out this rule: print explicit foralls if + a) User specifies -fprint-explicit-foralls, or + b) Any of the quantified type variables has a kind + that mentions a kind variable + +This catches common situations, such as a type siguature + f :: m a +which means + f :: forall k. forall (m :: k->*) (a :: k). m a +We really want to see both the "forall k" and the kind signatures +on m and a. The latter comes from pprTCvBndr. + +Note [Infix type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With TypeOperators you can say + + f :: (a ~> b) -> b + +and the (~>) is considered a type variable. However, the type +pretty-printer in this module will just see (a ~> b) as + + App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") + +So it'll print the type in prefix form. To avoid confusion we must +remember to parenthesise the operator, thus + + (~>) a b -> b + +See #2766. +-} + +pprDataCons :: TyCon -> SDoc +pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons + where + sepWithVBars [] = empty + sepWithVBars docs = sep (punctuate (space <> vbar) docs) + +pprDataConWithArgs :: DataCon -> SDoc +pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] + where + (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc + user_bndrs = dataConUserTyVarBinders dc + forAllDoc = pprUserForAll user_bndrs + thetaDoc = pprThetaArrowTy theta + argsDoc = hsep (fmap pprParendType arg_tys) + + +pprTypeApp :: TyCon -> [Type] -> SDoc +pprTypeApp tc tys + = pprIfaceTypeApp topPrec (toIfaceTyCon tc) + (toIfaceTcArgs tc tys) + -- TODO: toIfaceTcArgs seems rather wasteful here + +------------------ +-- | Display all kind information (with @-fprint-explicit-kinds@) when the +-- provided 'Bool' argument is 'True'. +-- See @Note [Kind arguments in error messages]@ in TcErrors. +pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc +pprWithExplicitKindsWhen b + = updSDocContext $ \ctx -> + if b then ctx { sdocPrintExplicitKinds = True } + else ctx + +-- | This variant preserves any use of TYPE in a type, effectively +-- locally setting -fprint-explicit-runtime-reps. +pprWithTYPE :: Type -> SDoc +pprWithTYPE ty = updSDocContext (\ctx -> ctx { sdocPrintExplicitRuntimeReps = True }) $ + ppr ty + +-- | Pretty prints a 'TyCon', using the family instance in case of a +-- representation tycon. For example: +-- +-- > data T [a] = ... +-- +-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' +pprSourceTyCon :: TyCon -> SDoc +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon diff --git a/compiler/GHC/Core/TyCo/Ppr.hs-boot b/compiler/GHC/Core/TyCo/Ppr.hs-boot new file mode 100644 index 0000000000..64562d9a28 --- /dev/null +++ b/compiler/GHC/Core/TyCo/Ppr.hs-boot @@ -0,0 +1,10 @@ +module GHC.Core.TyCo.Ppr where + +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, TyLit) +import Outputable + +pprType :: Type -> SDoc +pprKind :: Kind -> SDoc +pprCo :: Coercion -> SDoc +pprTyLit :: TyLit -> SDoc + diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs new file mode 100644 index 0000000000..26c01ebcb8 --- /dev/null +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -0,0 +1,1848 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +\section[GHC.Core.TyCo.Rep]{Type and Coercion - friends' interface} + +Note [The Type-related module hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + GHC.Core.Class + GHC.Core.Coercion.Axiom + GHC.Core.TyCon imports GHC.Core.{Class, Coercion.Axiom} + GHC.Core.TyCo.Rep imports GHC.Core.{Class, Coercion.Axiom, TyCon} + GHC.Core.TyCo.Ppr imports GHC.Core.TyCo.Rep + GHC.Core.TyCo.FVs imports GHC.Core.TyCo.Rep + GHC.Core.TyCo.Subst imports GHC.Core.TyCo.{Rep, FVs, Ppr} + GHC.Core.TyCo.Tidy imports GHC.Core.TyCo.{Rep, FVs} + TysPrim imports GHC.Core.TyCo.Rep ( including mkTyConTy ) + GHC.Core.Coercion imports GHC.Core.Type +-} + +-- We expose the relevant stuff from this module via the Type module +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf, PatternSynonyms, BangPatterns #-} + +module GHC.Core.TyCo.Rep ( + TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, + + -- * Types + Type( TyVarTy, AppTy, TyConApp, ForAllTy + , LitTy, CastTy, CoercionTy + , FunTy, ft_arg, ft_res, ft_af + ), -- Export the type synonym FunTy too + + TyLit(..), + KindOrType, Kind, + KnotTied, + PredType, ThetaType, -- Synonyms + ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), + + -- * Coercions + Coercion(..), + UnivCoProvenance(..), + CoercionHole(..), coHoleCoVar, setCoHoleCoVar, + CoercionN, CoercionR, CoercionP, KindCoercion, + MCoercion(..), MCoercionR, MCoercionN, + + -- * Functions over types + mkTyConTy, mkTyVarTy, mkTyVarTys, + mkTyCoVarTy, mkTyCoVarTys, + mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, + mkForAllTy, mkForAllTys, + mkPiTy, mkPiTys, + + -- * Functions over binders + TyCoBinder(..), TyCoVarBinder, TyBinder, + binderVar, binderVars, binderType, binderArgFlag, + delBinderVar, + isInvisibleArgFlag, isVisibleArgFlag, + isInvisibleBinder, isVisibleBinder, + isTyBinder, isNamedBinder, + + -- * Functions over coercions + pickLR, + + -- ** Analyzing types + TyCoFolder(..), foldTyCo, + + -- * Sizes + typeSize, coercionSize, provSize + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) + + -- Transitively pulls in a LOT of stuff, better to break the loop + +import {-# SOURCE #-} GHC.Core.ConLike ( ConLike(..), conLikeName ) + +-- friends: +import GHC.Iface.Type +import Var +import VarSet +import Name hiding ( varName ) +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom + +-- others +import BasicTypes ( LeftOrRight(..), pickLR ) +import Outputable +import FastString +import Util + +-- libraries +import qualified Data.Data as Data hiding ( TyCon ) +import Data.IORef ( IORef ) -- for CoercionHole + +{- +%************************************************************************ +%* * + TyThing +%* * +%************************************************************************ + +Despite the fact that DataCon has to be imported via a hi-boot route, +this module seems the right place for TyThing, because it's needed for +funTyCon and all the types in TysPrim. + +It is also SOURCE-imported into Name.hs + + +Note [ATyCon for classes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Both classes and type constructors are represented in the type environment +as ATyCon. You can tell the difference, and get to the class, with + isClassTyCon :: TyCon -> Bool + tyConClass_maybe :: TyCon -> Maybe Class +The Class and its associated TyCon have the same Name. +-} + +-- | A global typecheckable-thing, essentially anything that has a name. +-- Not to be confused with a 'TcTyThing', which is also a typecheckable +-- thing but in the *local* context. See 'TcEnv' for how to retrieve +-- a 'TyThing' given a 'Name'. +data TyThing + = AnId Id + | AConLike ConLike + | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] + | ACoAxiom (CoAxiom Branched) + +instance Outputable TyThing where + ppr = pprShortTyThing + +instance NamedThing TyThing where -- Can't put this with the type + getName (AnId id) = getName id -- decl, because the DataCon instance + getName (ATyCon tc) = getName tc -- isn't visible there + getName (ACoAxiom cc) = getName cc + getName (AConLike cl) = conLikeName cl + +pprShortTyThing :: TyThing -> SDoc +-- c.f. GHC.Core.Ppr.TyThing.pprTyThing, which prints all the details +pprShortTyThing thing + = pprTyThingCategory thing <+> quotes (ppr (getName thing)) + +pprTyThingCategory :: TyThing -> SDoc +pprTyThingCategory = text . capitalise . tyThingCategory + +tyThingCategory :: TyThing -> String +tyThingCategory (ATyCon tc) + | isClassTyCon tc = "class" + | otherwise = "type constructor" +tyThingCategory (ACoAxiom _) = "coercion axiom" +tyThingCategory (AnId _) = "identifier" +tyThingCategory (AConLike (RealDataCon _)) = "data constructor" +tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym" + + +{- ********************************************************************** +* * + Type +* * +********************************************************************** -} + +-- | The key representation of types within the compiler + +type KindOrType = Type -- See Note [Arguments to type constructors] + +-- | The key type representing kinds in the compiler. +type Kind = Type + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Type + -- See Note [Non-trivial definitional equality] + = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) + + | AppTy + Type + Type -- ^ Type application to something other than a 'TyCon'. Parameters: + -- + -- 1) Function: must /not/ be a 'TyConApp' or 'CastTy', + -- must be another 'AppTy', or 'TyVarTy' + -- See Note [Respecting definitional equality] (EQ1) about the + -- no 'CastTy' requirement + -- + -- 2) Argument type + + | TyConApp + TyCon + [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. + -- Invariant: saturated applications of 'FunTyCon' must + -- use 'FunTy' and saturated synonyms must use their own + -- constructors. However, /unsaturated/ 'FunTyCon's + -- do appear as 'TyConApp's. + -- Parameters: + -- + -- 1) Type constructor being applied to. + -- + -- 2) Type arguments. Might not have enough type arguments + -- here to saturate the constructor. + -- Even type synonyms are not necessarily saturated; + -- for example unsaturated type synonyms + -- can appear as the right hand side of a type synonym. + + | ForAllTy + {-# UNPACK #-} !TyCoVarBinder + Type -- ^ A Π type. + + | FunTy -- ^ t1 -> t2 Very common, so an important special case + -- See Note [Function types] + { ft_af :: AnonArgFlag -- Is this (->) or (=>)? + , ft_arg :: Type -- Argument type + , ft_res :: Type } -- Result type + + | LitTy TyLit -- ^ Type literals are similar to type constructors. + + | CastTy + Type + KindCoercion -- ^ A kind cast. The coercion is always nominal. + -- INVARIANT: The cast is never refl. + -- INVARIANT: The Type is not a CastTy (use TransCo instead) + -- See Note [Respecting definitional equality] (EQ2) and (EQ3) + + | CoercionTy + Coercion -- ^ Injection of a Coercion into a type + -- This should only ever be used in the RHS of an AppTy, + -- in the list of a TyConApp, when applying a promoted + -- GADT data constructor + + deriving Data.Data + +instance Outputable Type where + ppr = pprType + +-- NOTE: Other parts of the code assume that type literals do not contain +-- types or type variables. +data TyLit + = NumTyLit Integer + | StrTyLit FastString + deriving (Eq, Ord, Data.Data) + +instance Outputable TyLit where + ppr = pprTyLit + +{- Note [Function types] +~~~~~~~~~~~~~~~~~~~~~~~~ +FFunTy is the constructor for a function type. Lots of things to say +about it! + +* FFunTy is the data constructor, meaning "full function type". + +* The function type constructor (->) has kind + (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> Type LiftedRep + mkTyConApp ensure that we convert a saturated application + TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2 + dropping the 'r1' and 'r2' arguments; they are easily recovered + from 't1' and 't2'. + +* The ft_af field says whether or not this is an invisible argument + VisArg: t1 -> t2 Ordinary function type + InvisArg: t1 => t2 t1 is guaranteed to be a predicate type, + i.e. t1 :: Constraint + See Note [Types for coercions, predicates, and evidence] + + This visibility info makes no difference in Core; it matters + only when we regard the type as a Haskell source type. + +* FunTy is a (unidirectional) pattern synonym that allows + positional pattern matching (FunTy arg res), ignoring the + ArgFlag. +-} + +{- ----------------------- + Commented out until the pattern match + checker can handle it; see #16185 + + For now we use the CPP macro #define FunTy FFunTy _ + (see HsVersions.h) to allow pattern matching on a + (positional) FunTy constructor. + +{-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp + , ForAllTy, LitTy, CastTy, CoercionTy :: Type #-} + +-- | 'FunTy' is a (uni-directional) pattern synonym for the common +-- case where we want to match on the argument/result type, but +-- ignoring the AnonArgFlag +pattern FunTy :: Type -> Type -> Type +pattern FunTy arg res <- FFunTy { ft_arg = arg, ft_res = res } + + End of commented out block +---------------------------------- -} + +{- Note [Types for coercions, predicates, and evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat differently: + + (a) Predicate types + Test: isPredTy + Binders: DictIds + Kind: Constraint + Examples: (Eq a), and (a ~ b) + + (b) Coercion types are primitive, unboxed equalities + Test: isCoVarTy + Binders: CoVars (can appear in coercions) + Kind: TYPE (TupleRep []) + Examples: (t1 ~# t2) or (t1 ~R# t2) + + (c) Evidence types is the type of evidence manipulated by + the type constraint solver. + Test: isEvVarType + Binders: EvVars + Kind: Constraint or TYPE (TupleRep []) + Examples: all coercion types and predicate types + +Coercion types and predicate types are mutually exclusive, +but evidence types are a superset of both. + +When treated as a user type, + + - Predicates (of kind Constraint) are invisible and are + implicitly instantiated + + - Coercion types, and non-pred evidence types (i.e. not + of kind Constrain), are just regular old types, are + visible, and are not implicitly instantiated. + +In a FunTy { ft_af = InvisArg }, the argument type is always +a Predicate type. + +Note [Constraints in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do we allow a type constructor to have a kind like + S :: Eq a => a -> Type + +No, we do not. Doing so would mean would need a TyConApp like + S @k @(d :: Eq k) (ty :: k) + and we have no way to build, or decompose, evidence like + (d :: Eq k) at the type level. + +But we admit one exception: equality. We /do/ allow, say, + MkT :: (a ~ b) => a -> b -> Type a b + +Why? Because we can, without much difficulty. Moreover +we can promote a GADT data constructor (see TyCon +Note [Promoted data constructors]), like + data GT a b where + MkGT : a -> a -> GT a a +so programmers might reasonably expect to be able to +promote MkT as well. + +How does this work? + +* In TcValidity.checkConstraintsOK we reject kinds that + have constraints other than (a~b) and (a~~b). + +* In Inst.tcInstInvisibleTyBinder we instantiate a call + of MkT by emitting + [W] co :: alpha ~# beta + and producing the elaborated term + MkT @alpha @beta (Eq# alpha beta co) + We don't generate a boxed "Wanted"; we generate only a + regular old /unboxed/ primitive-equality Wanted, and build + the box on the spot. + +* How can we get such a MkT? By promoting a GADT-style data + constructor + data T a b where + MkT :: (a~b) => a -> b -> T a b + See DataCon.mkPromotedDataCon + and Note [Promoted data constructors] in GHC.Core.TyCon + +* We support both homogeneous (~) and heterogeneous (~~) + equality. (See Note [The equality types story] + in TysPrim for a primer on these equality types.) + +* How do we prevent a MkT having an illegal constraint like + Eq a? We check for this at use-sites; see TcHsType.tcTyVar, + specifically dc_theta_illegal_constraint. + +* Notice that nothing special happens if + K :: (a ~# b) => blah + because (a ~# b) is not a predicate type, and is never + implicitly instantiated. (Mind you, it's not clear how you + could creates a type constructor with such a kind.) See + Note [Types for coercions, predicates, and evidence] + +* The existence of promoted MkT with an equality-constraint + argument is the (only) reason that the AnonTCB constructor + of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg). + For example, when we promote the data constructor + MkT :: forall a b. (a~b) => a -> b -> T a b + we get a PromotedDataCon with tyConBinders + Bndr (a :: Type) (NamedTCB Inferred) + Bndr (b :: Type) (NamedTCB Inferred) + Bndr (_ :: a ~ b) (AnonTCB InvisArg) + Bndr (_ :: a) (AnonTCB VisArg)) + Bndr (_ :: b) (AnonTCB VisArg)) + +* One might reasonably wonder who *unpacks* these boxes once they are + made. After all, there is no type-level `case` construct. The + surprising answer is that no one ever does. Instead, if a GADT + constructor is used on the left-hand side of a type family equation, + that occurrence forces GHC to unify the types in question. For + example: + + data G a where + MkG :: G Bool + + type family F (x :: G a) :: a where + F MkG = False + + When checking the LHS `F MkG`, GHC sees the MkG constructor and then must + unify F's implicit parameter `a` with Bool. This succeeds, making the equation + + F Bool (MkG @Bool <Bool>) = False + + Note that we never need unpack the coercion. This is because type + family equations are *not* parametric in their kind variables. That + is, we could have just said + + type family H (x :: G a) :: a where + H _ = False + + The presence of False on the RHS also forces `a` to become Bool, + giving us + + H Bool _ = False + + The fact that any of this works stems from the lack of phase + separation between types and kinds (unlike the very present phase + separation between terms and types). + + Once we have the ability to pattern-match on types below top-level, + this will no longer cut it, but it seems fine for now. + + +Note [Arguments to type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because of kind polymorphism, in addition to type application we now +have kind instantiation. We reuse the same notations to do so. + +For example: + + Just (* -> *) Maybe + Right * Nat Zero + +are represented by: + + TyConApp (PromotedDataCon Just) [* -> *, Maybe] + TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] + +Important note: Nat is used as a *kind* and not as a type. This can be +confusing, since type-level Nat and kind-level Nat are identical. We +use the kind of (PromotedDataCon Right) to know if its arguments are +kinds or types. + +This kind instantiation only happens in TyConApp currently. + +Note [Non-trivial definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is Int |> <*> the same as Int? YES! In order to reduce headaches, +we decide that any reflexive casts in types are just ignored. +(Indeed they must be. See Note [Respecting definitional equality].) +More generally, the `eqType` function, which defines Core's type equality +relation, ignores casts and coercion arguments, as long as the +two types have the same kind. This allows us to be a little sloppier +in keeping track of coercions, which is a good thing. It also means +that eqType does not depend on eqCoercion, which is also a good thing. + +Why is this sensible? That is, why is something different than α-equivalence +appropriate for the implementation of eqType? + +Anything smaller than ~ and homogeneous is an appropriate definition for +equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any +expression of type τ can be transmuted to one of type σ at any point by +casting. The same is true of expressions of type σ. So in some sense, τ and σ +are interchangeable. + +But let's be more precise. If we examine the typing rules of FC (say, those in +https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf) +there are several places where the same metavariable is used in two different +premises to a rule. (For example, see Ty_App.) There is an implicit equality +check here. What definition of equality should we use? By convention, we use +α-equivalence. Take any rule with one (or more) of these implicit equality +checks. Then there is an admissible rule that uses ~ instead of the implicit +check, adding in casts as appropriate. + +The only problem here is that ~ is heterogeneous. To make the kinds work out +in the admissible rule that uses ~, it is necessary to homogenize the +coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η; +we use η |> kind η, which is homogeneous. + +The effect of this all is that eqType, the implementation of the implicit +equality check, can use any homogeneous relation that is smaller than ~, as +those rules must also be admissible. + +A more drawn out argument around all of this is presented in Section 7.2 of +Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf). + +What would go wrong if we insisted on the casts matching? See the beginning of +Section 8 in the unpublished paper above. Theoretically, nothing at all goes +wrong. But in practical terms, getting the coercions right proved to be +nightmarish. And types would explode: during kind-checking, we often produce +reflexive kind coercions. When we try to cast by these, mkCastTy just discards +them. But if we used an eqType that distinguished between Int and Int |> <*>, +then we couldn't discard -- the output of kind-checking would be enormous, +and we would need enormous casts with lots of CoherenceCo's to straighten +them out. + +Would anything go wrong if eqType respected type families? No, not at all. But +that makes eqType rather hard to implement. + +Thus, the guideline for eqType is that it should be the largest +easy-to-implement relation that is still smaller than ~ and homogeneous. The +precise choice of relation is somewhat incidental, as long as the smart +constructors and destructors in Type respect whatever relation is chosen. + +Another helpful principle with eqType is this: + + (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere. + +This principle also tells us that eqType must relate only types with the +same kinds. + +Note [Respecting definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Non-trivial definitional equality] introduces the property (EQ). +How is this upheld? + +Any function that pattern matches on all the constructors will have to +consider the possibility of CastTy. Presumably, those functions will handle +CastTy appropriately and we'll be OK. + +More dangerous are the splitXXX functions. Let's focus on splitTyConApp. +We don't want it to fail on (T a b c |> co). Happily, if we have + (T a b c |> co) `eqType` (T d e f) +then co must be reflexive. Why? eqType checks that the kinds are equal, as +well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f). +By the kind check, we know that (T a b c |> co) and (T d e f) have the same +kind. So the only way that co could be non-reflexive is for (T a b c) to have +a different kind than (T d e f). But because T's kind is closed (all tycon kinds +are closed), the only way for this to happen is that one of the arguments has +to differ, leading to a contradiction. Thus, co is reflexive. + +Accordingly, by eliminating reflexive casts, splitTyConApp need not worry +about outermost casts to uphold (EQ). Eliminating reflexive casts is done +in mkCastTy. + +Unforunately, that's not the end of the story. Consider comparing + (T a b c) =? (T a b |> (co -> <Type>)) (c |> co) +These two types have the same kind (Type), but the left type is a TyConApp +while the right type is not. To handle this case, we say that the right-hand +type is ill-formed, requiring an AppTy never to have a casted TyConApp +on its left. It is easy enough to pull around the coercions to maintain +this invariant, as done in Type.mkAppTy. In the example above, trying to +form the right-hand type will instead yield (T a b (c |> co |> sym co) |> <Type>). +Both the casts there are reflexive and will be dropped. Huzzah. + +This idea of pulling coercions to the right works for splitAppTy as well. + +However, there is one hiccup: it's possible that a coercion doesn't relate two +Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@, +then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't +be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not +`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate +our (EQ) property. + +Lastly, in order to detect reflexive casts reliably, we must make sure not +to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)). + +In sum, in order to uphold (EQ), we need the following three invariants: + + (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable + cast is one that relates either a FunTy to a FunTy or a + ForAllTy to a ForAllTy. + (EQ2) No reflexive casts in CastTy. + (EQ3) No nested CastTys. + (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body). + See Note [Weird typing rule for ForAllTy] in GHC.Core.Type. + +These invariants are all documented above, in the declaration for Type. + +Note [Unused coercion variable in ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + \(co:t1 ~ t2). e + +What type should we give to this expression? + (1) forall (co:t1 ~ t2) -> t + (2) (t1 ~ t2) -> t + +If co is used in t, (1) should be the right choice. +if co is not used in t, we would like to have (1) and (2) equivalent. + +However, we want to keep eqType simple and don't want eqType (1) (2) to return +True in any case. + +We decide to always construct (2) if co is not used in t. + +Thus in mkLamType, we check whether the variable is a coercion +variable (of type (t1 ~# t2), and whether it is un-used in the +body. If so, it returns a FunTy instead of a ForAllTy. + +There are cases we want to skip the check. For example, the check is +unnecessary when it is known from the context that the input variable +is a type variable. In those cases, we use mkForAllTy. + +-} + +-- | A type labeled 'KnotTied' might have knot-tied tycons in it. See +-- Note [Type checking recursive type and class declarations] in +-- TcTyClsDecls +type KnotTied ty = ty + +{- ********************************************************************** +* * + TyCoBinder and ArgFlag +* * +********************************************************************** -} + +-- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be +-- dependent ('Named') or nondependent ('Anon'). They may also be visible or +-- not. See Note [TyCoBinders] +data TyCoBinder + = Named TyCoVarBinder -- A type-lambda binder + | Anon AnonArgFlag Type -- A term-lambda binder. Type here can be CoercionTy. + -- Visibility is determined by the AnonArgFlag + deriving Data.Data + +instance Outputable TyCoBinder where + ppr (Anon af ty) = ppr af <+> ppr ty + ppr (Named (Bndr v Required)) = ppr v + ppr (Named (Bndr v Specified)) = char '@' <> ppr v + ppr (Named (Bndr v Inferred)) = braces (ppr v) + + +-- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' +-- in the 'Named' field. +type TyBinder = TyCoBinder + +-- | Remove the binder's variable from the set, if the binder has +-- a variable. +delBinderVar :: VarSet -> TyCoVarBinder -> VarSet +delBinderVar vars (Bndr tv _) = vars `delVarSet` tv + +-- | Does this binder bind an invisible argument? +isInvisibleBinder :: TyCoBinder -> Bool +isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis +isInvisibleBinder (Anon InvisArg _) = True +isInvisibleBinder (Anon VisArg _) = False + +-- | Does this binder bind a visible argument? +isVisibleBinder :: TyCoBinder -> Bool +isVisibleBinder = not . isInvisibleBinder + +isNamedBinder :: TyCoBinder -> Bool +isNamedBinder (Named {}) = True +isNamedBinder (Anon {}) = False + +-- | If its a named binder, is the binder a tyvar? +-- Returns True for nondependent binder. +-- This check that we're really returning a *Ty*Binder (as opposed to a +-- coercion binder). That way, if/when we allow coercion quantification +-- in more places, we'll know we missed updating some function. +isTyBinder :: TyCoBinder -> Bool +isTyBinder (Named bnd) = isTyVarBinder bnd +isTyBinder _ = True + +{- Note [TyCoBinders] +~~~~~~~~~~~~~~~~~~~ +A ForAllTy contains a TyCoVarBinder. But a type can be decomposed +to a telescope consisting of a [TyCoBinder] + +A TyCoBinder represents the type of binders -- that is, the type of an +argument to a Pi-type. GHC Core currently supports two different +Pi-types: + + * A non-dependent function type, + written with ->, e.g. ty1 -> ty2 + represented as FunTy ty1 ty2. These are + lifted to Coercions with the corresponding FunCo. + + * A dependent compile-time-only polytype, + written with forall, e.g. forall (a:*). ty + represented as ForAllTy (Bndr a v) ty + +Both Pi-types classify terms/types that take an argument. In other +words, if `x` is either a function or a polytype, `x arg` makes sense +(for an appropriate `arg`). + + +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder. + Each TyCoVarBinder + Bndr a tvis + is equipped with tvis::ArgFlag, which says whether or not arguments + for this binder should be visible (explicit) in source Haskell. + +* A TyCon contains a list of TyConBinders. Each TyConBinder + Bndr a cvis + is equipped with cvis::TyConBndrVis, which says whether or not type + and kind arguments for this TyCon should be visible (explicit) in + source Haskell. + +This table summarises the visibility rules: +--------------------------------------------------------------------------------------- +| Occurrences look like this +| GHC displays type as in Haskell source code +|-------------------------------------------------------------------------------------- +| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term +| tvis :: ArgFlag +| tvis = Inferred: f :: forall {a}. type Arg not allowed: f + f :: forall {co}. type Arg not allowed: f +| tvis = Specified: f :: forall a. type Arg optional: f or f @Int +| tvis = Required: T :: forall k -> type Arg required: T * +| This last form is illegal in terms: See Note [No Required TyCoBinder in terms] +| +| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon +| cvis :: TyConBndrVis +| cvis = AnonTCB: T :: kind -> kind Required: T * +| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T +| T :: forall {co}. kind Arg not allowed: T +| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T +| cvis = NamedTCB Required: T :: forall k -> kind Required: T * +--------------------------------------------------------------------------------------- + +[1] In types, in the Specified case, it would make sense to allow + optional kind applications, thus (T @*), but we have not + yet implemented that + +---- In term declarations ---- + +* Inferred. Function defn, with no signature: f1 x = x + We infer f1 :: forall {a}. a -> a, with 'a' Inferred + It's Inferred because it doesn't appear in any + user-written signature for f1 + +* Specified. Function defn, with signature (implicit forall): + f2 :: a -> a; f2 x = x + So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified + even though 'a' is not bound in the source code by an explicit forall + +* Specified. Function defn, with signature (explicit forall): + f3 :: forall a. a -> a; f3 x = x + So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified + +* Inferred/Specified. Function signature with inferred kind polymorphism. + f4 :: a b -> Int + So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int + Here 'k' is Inferred (it's not mentioned in the type), + but 'a' and 'b' are Specified. + +* Specified. Function signature with explicit kind polymorphism + f5 :: a (b :: k) -> Int + This time 'k' is Specified, because it is mentioned explicitly, + so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int + +* Similarly pattern synonyms: + Inferred - from inferred types (e.g. no pattern type signature) + - or from inferred kind polymorphism + +---- In type declarations ---- + +* Inferred (k) + data T1 a b = MkT1 (a b) + Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * + The kind variable 'k' is Inferred, since it is not mentioned + + Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind, + and Anon binders don't have a visibility flag. (Or you could think + of Anon having an implicit Required flag.) + +* Specified (k) + data T2 (a::k->*) b = MkT (a b) + Here T's kind is T :: forall (k:*). (k->*) -> k -> * + The kind variable 'k' is Specified, since it is mentioned in + the signature. + +* Required (k) + data T k (a::k->*) b = MkT (a b) + Here T's kind is T :: forall k:* -> (k->*) -> k -> * + The kind is Required, since it bound in a positional way in T's declaration + Every use of T must be explicitly applied to a kind + +* Inferred (k1), Specified (k) + data T a b (c :: k) = MkT (a b) (Proxy c) + Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * + So 'k' is Specified, because it appears explicitly, + but 'k1' is Inferred, because it does not + +Generally, in the list of TyConBinders for a TyCon, + +* Inferred arguments always come first +* Specified, Anon and Required can be mixed + +e.g. + data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... + +Here Foo's TyConBinders are + [Required 'a', Specified 'b', Anon] +and its kind prints as + Foo :: forall a -> forall b. (a -> b -> Type) -> Type + +See also Note [Required, Specified, and Inferred for types] in TcTyClsDecls + +---- Printing ----- + + We print forall types with enough syntax to tell you their visibility + flag. But this is not source Haskell, and these types may not all + be parsable. + + Specified: a list of Specified binders is written between `forall` and `.`: + const :: forall a b. a -> b -> a + + Inferred: like Specified, but every binder is written in braces: + f :: forall {k} (a:k). S k a -> Int + + Required: binders are put between `forall` and `->`: + T :: forall k -> * + +---- Other points ----- + +* In classic Haskell, all named binders (that is, the type variables in + a polymorphic function type f :: forall a. a -> a) have been Inferred. + +* Inferred variables correspond to "generalized" variables from the + Visible Type Applications paper (ESOP'16). + +Note [No Required TyCoBinder in terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't allow Required foralls for term variables, including pattern +synonyms and data constructors. Why? Because then an application +would need a /compulsory/ type argument (possibly without an "@"?), +thus (f Int); and we don't have concrete syntax for that. + +We could change this decision, but Required, Named TyCoBinders are rare +anyway. (Most are Anons.) + +However the type of a term can (just about) have a required quantifier; +see Note [Required quantifiers in the type of a term] in TcExpr. +-} + + +{- ********************************************************************** +* * + PredType +* * +********************************************************************** -} + + +-- | A type of the form @p@ of constraint kind represents a value whose type is +-- the Haskell predicate @p@, where a predicate is what occurs before +-- the @=>@ in a Haskell type. +-- +-- We use 'PredType' as documentation to mark those types that we guarantee to +-- have this kind. +-- +-- It can be expanded into its representation, but: +-- +-- * The type checker must treat it as opaque +-- +-- * The rest of the compiler treats it as transparent +-- +-- Consider these examples: +-- +-- > f :: (Eq a) => a -> Int +-- > g :: (?x :: Int -> Int) => a -> Int +-- > h :: (r\l) => {r} => {l::Int | r} +-- +-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" +type PredType = Type + +-- | A collection of 'PredType's +type ThetaType = [PredType] + +{- +(We don't support TREX records yet, but the setup is designed +to expand to allow them.) + +A Haskell qualified type, such as that for f,g,h above, is +represented using + * a FunTy for the double arrow + * with a type of kind Constraint as the function argument + +The predicate really does turn into a real extra argument to the +function. If the argument has type (p :: Constraint) then the predicate p is +represented by evidence of type p. + + +%************************************************************************ +%* * + Simple constructors +%* * +%************************************************************************ + +These functions are here so that they can be used by TysPrim, +which in turn is imported by Type +-} + +mkTyVarTy :: TyVar -> Type +mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) ) + TyVarTy v + +mkTyVarTys :: [TyVar] -> [Type] +mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy + +mkTyCoVarTy :: TyCoVar -> Type +mkTyCoVarTy v + | isTyVar v + = TyVarTy v + | otherwise + = CoercionTy (CoVarCo v) + +mkTyCoVarTys :: [TyCoVar] -> [Type] +mkTyCoVarTys = map mkTyCoVarTy + +infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy` -- Associates to the right + +mkFunTy :: AnonArgFlag -> Type -> Type -> Type +mkFunTy af arg res = FunTy { ft_af = af, ft_arg = arg, ft_res = res } + +mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type +mkVisFunTy = mkFunTy VisArg +mkInvisFunTy = mkFunTy InvisArg + +-- | Make nested arrow types +mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type +mkVisFunTys tys ty = foldr mkVisFunTy ty tys +mkInvisFunTys tys ty = foldr mkInvisFunTy ty tys + +-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder +-- See Note [Unused coercion variable in ForAllTy] +mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type +mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty + +-- | Wraps foralls over the type using the provided 'TyCoVar's from left to right +mkForAllTys :: [TyCoVarBinder] -> Type -> Type +mkForAllTys tyvars ty = foldr ForAllTy ty tyvars + +mkPiTy:: TyCoBinder -> Type -> Type +mkPiTy (Anon af ty1) ty2 = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 } +mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty + +mkPiTys :: [TyCoBinder] -> Type -> Type +mkPiTys tbs ty = foldr mkPiTy ty tbs + +-- | Create the plain type constructor type which has been applied to no type arguments at all. +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = TyConApp tycon [] + +{- +%************************************************************************ +%* * + Coercions +%* * +%************************************************************************ +-} + +-- | A 'Coercion' is concrete evidence of the equality/convertibility +-- of two types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data Coercion + -- Each constructor has a "role signature", indicating the way roles are + -- propagated through coercions. + -- - P, N, and R stand for coercions of the given role + -- - e stands for a coercion of a specific unknown role + -- (think "role polymorphism") + -- - "e" stands for an explicit role parameter indicating role e. + -- - _ stands for a parameter that is not a Role or Coercion. + + -- These ones mirror the shape of types + = -- Refl :: _ -> N + Refl Type -- See Note [Refl invariant] + -- Invariant: applications of (Refl T) to a bunch of identity coercions + -- always show up as Refl. + -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). + + -- Applications of (Refl T) to some coercions, at least one of + -- which is NOT the identity, show up as TyConAppCo. + -- (They may not be fully saturated however.) + -- ConAppCo coercions (like all coercions other than Refl) + -- are NEVER the identity. + + -- Use (GRefl Representational ty MRefl), not (SubCo (Refl ty)) + + -- GRefl :: "e" -> _ -> Maybe N -> e + -- See Note [Generalized reflexive coercion] + | GRefl Role Type MCoercionN -- See Note [Refl invariant] + -- Use (Refl ty), not (GRefl Nominal ty MRefl) + -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _)) + + -- These ones simply lift the correspondingly-named + -- Type constructors into Coercions + + -- TyConAppCo :: "e" -> _ -> ?? -> e + -- See Note [TyConAppCo roles] + | TyConAppCo Role TyCon [Coercion] -- lift TyConApp + -- The TyCon is never a synonym; + -- we expand synonyms eagerly + -- But it can be a type function + + | AppCo Coercion CoercionN -- lift AppTy + -- AppCo :: e -> N -> e + + -- See Note [Forall coercions] + | ForAllCo TyCoVar KindCoercion Coercion + -- ForAllCo :: _ -> N -> e -> e + + | FunCo Role Coercion Coercion -- lift FunTy + -- FunCo :: "e" -> e -> e -> e + -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy? + -- Because the AnonArgFlag has no impact on Core; it is only + -- there to guide implicit instantiation of Haskell source + -- types, and that is irrelevant for coercions, which are + -- Core-only. + + -- These are special + | CoVarCo CoVar -- :: _ -> (N or R) + -- result role depends on the tycon of the variable's type + + -- AxiomInstCo :: e -> _ -> ?? -> e + | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] + -- See also [CoAxiom index] + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. + -- See [Coercion axioms applied to coercions] + -- The roles of the argument coercions are determined + -- by the cab_roles field of the relevant branch of the CoAxiom + + | AxiomRuleCo CoAxiomRule [Coercion] + -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule + -- The number coercions should match exactly the expectations + -- of the CoAxiomRule (i.e., the rule is fully saturated). + + | UnivCo UnivCoProvenance Role Type Type + -- :: _ -> "e" -> _ -> _ -> e + + | SymCo Coercion -- :: e -> e + | TransCo Coercion Coercion -- :: e -> e -> e + + | NthCo Role Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles]) + -- Using NthCo on a ForAllCo gives an N coercion always + -- See Note [NthCo and newtypes] + -- + -- Invariant: (NthCo r i co), it is always the case that r = role of (Nth i co) + -- That is: the role of the entire coercion is redundantly cached here. + -- See Note [NthCo Cached Roles] + + | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) + -- :: _ -> N -> N + | InstCo Coercion CoercionN + -- :: e -> N -> e + -- See Note [InstCo roles] + + -- Extract a kind coercion from a (heterogeneous) type coercion + -- NB: all kind coercions are Nominal + | KindCo Coercion + -- :: e -> N + + | SubCo CoercionN -- Turns a ~N into a ~R + -- :: N -> R + + | HoleCo CoercionHole -- ^ See Note [Coercion holes] + -- Only present during typechecking + deriving Data.Data + +type CoercionN = Coercion -- always nominal +type CoercionR = Coercion -- always representational +type CoercionP = Coercion -- always phantom +type KindCoercion = CoercionN -- always nominal + +instance Outputable Coercion where + ppr = pprCo + +-- | A semantically more meaningful type to represent what may or may not be a +-- useful 'Coercion'. +data MCoercion + = MRefl + -- A trivial Reflexivity coercion + | MCo Coercion + -- Other coercions + deriving Data.Data +type MCoercionR = MCoercion +type MCoercionN = MCoercion + +instance Outputable MCoercion where + ppr MRefl = text "MRefl" + ppr (MCo co) = text "MCo" <+> ppr co + +{- +Note [Refl invariant] +~~~~~~~~~~~~~~~~~~~~~ +Invariant 1: + +Coercions have the following invariant + Refl (similar for GRefl r ty MRefl) is always lifted as far as possible. + +You might think that a consequences is: + Every identity coercions has Refl at the root + +But that's not quite true because of coercion variables. Consider + g where g :: Int~Int + Left h where h :: Maybe Int ~ Maybe Int +etc. So the consequence is only true of coercions that +have no coercion variables. + +Note [Generalized reflexive coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GRefl is a generalized reflexive coercion (see #15192). It wraps a kind +coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing +rules for GRefl: + + ty : k1 + ------------------------------------ + GRefl r ty MRefl: ty ~r ty + + ty : k1 co :: k1 ~ k2 + ------------------------------------ + GRefl r ty (MCo co) : ty ~r ty |> co + +Consider we have + + g1 :: s ~r t + s :: k1 + g2 :: k1 ~ k2 + +and we want to construct a coercions co which has type + + (s |> g2) ~r t + +We can define + + co = Sym (GRefl r s g2) ; g1 + +It is easy to see that + + Refl == GRefl Nominal ty MRefl :: ty ~n ty + +A nominal reflexive coercion is quite common, so we keep the special form Refl to +save allocation. + +Note [Coercion axioms applied to coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The reason coercion axioms can be applied to coercions and not just +types is to allow for better optimization. There are some cases where +we need to be able to "push transitivity inside" an axiom in order to +expose further opportunities for optimization. + +For example, suppose we have + + C a : t[a] ~ F a + g : b ~ c + +and we want to optimize + + sym (C b) ; t[g] ; C c + +which has the kind + + F b ~ F c + +(stopping through t[b] and t[c] along the way). + +We'd like to optimize this to just F g -- but how? The key is +that we need to allow axioms to be instantiated by *coercions*, +not just by types. Then we can (in certain cases) push +transitivity inside the axiom instantiations, and then react +opposite-polarity instantiations of the same axiom. In this +case, e.g., we match t[g] against the LHS of (C c)'s kind, to +obtain the substitution a |-> g (note this operation is sort +of the dual of lifting!) and hence end up with + + C g : t[b] ~ F c + +which indeed has the same kind as t[g] ; C c. + +Now we have + + sym (C b) ; C g + +which can be optimized to F g. + +Note [CoAxiom index] +~~~~~~~~~~~~~~~~~~~~ +A CoAxiom has 1 or more branches. Each branch has contains a list +of the free type variables in that branch, the LHS type patterns, +and the RHS type for that branch. When we apply an axiom to a list +of coercions, we must choose which branch of the axiom we wish to +use, as the different branches may have different numbers of free +type variables. (The number of type patterns is always the same +among branches, but that doesn't quite concern us here.) + +The Int in the AxiomInstCo constructor is the 0-indexed number +of the chosen branch. + +Note [Forall coercions] +~~~~~~~~~~~~~~~~~~~~~~~ +Constructing coercions between forall-types can be a bit tricky, +because the kinds of the bound tyvars can be different. + +The typing rule is: + + + kind_co : k1 ~ k2 + tv1:k1 |- co : t1 ~ t2 + ------------------------------------------------------------------- + ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ + all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) + +First, the TyCoVar stored in a ForAllCo is really an optimisation: this field +should be a Name, as its kind is redundant. Thinking of the field as a Name +is helpful in understanding what a ForAllCo means. +The kind of TyCoVar always matches the left-hand kind of the coercion. + +The idea is that kind_co gives the two kinds of the tyvar. See how, in the +conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. + +Of course, a type variable can't have different kinds at the same time. So, +we arbitrarily prefer the first kind when using tv1 in the inner coercion +co, which shows that t1 equals t2. + +The last wrinkle is that we need to fix the kinds in the conclusion. In +t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of +the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with +(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it +mentions the same name with different kinds, but it *is* well-kinded, noting +that `(tv1:k2) |> sym kind_co` has kind k1. + +This all really would work storing just a Name in the ForAllCo. But we can't +add Names to, e.g., VarSets, and there generally is just an impedance mismatch +in a bunch of places. So we use tv1. When we need tv2, we can use +setTyVarKind. + +Note [Predicate coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: a~b +How can we coerce between types + ([c]~a) => [a] -> c +and + ([c]~b) => [b] -> c +where the equality predicate *itself* differs? + +Answer: we simply treat (~) as an ordinary type constructor, so these +types really look like + + ((~) [c] a) -> [a] -> c + ((~) [c] b) -> [b] -> c + +So the coercion between the two is obviously + + ((~) [c] g) -> [g] -> c + +Another way to see this to say that we simply collapse predicates to +their representation type (see Type.coreView and Type.predTypeRep). + +This collapse is done by mkPredCo; there is no PredCo constructor +in Coercion. This is important because we need Nth to work on +predicates too: + Nth 1 ((~) [c] g) = g +See Simplify.simplCoercionF, which generates such selections. + +Note [Roles] +~~~~~~~~~~~~ +Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated +in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see +https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation + +Here is one way to phrase the problem: + +Given: +newtype Age = MkAge Int +type family F x +type instance F Age = Bool +type instance F Int = Char + +This compiles down to: +axAge :: Age ~ Int +axF1 :: F Age ~ Bool +axF2 :: F Int ~ Char + +Then, we can make: +(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char + +Yikes! + +The solution is _roles_, as articulated in "Generative Type Abstraction and +Type-level Computation" (POPL 2010), available at +http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf + +The specification for roles has evolved somewhat since that paper. For the +current full details, see the documentation in docs/core-spec. Here are some +highlights. + +We label every equality with a notion of type equivalence, of which there are +three options: Nominal, Representational, and Phantom. A ground type is +nominally equivalent only with itself. A newtype (which is considered a ground +type in Haskell) is representationally equivalent to its representation. +Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" +to denote the equivalences. + +The axioms above would be: +axAge :: Age ~R Int +axF1 :: F Age ~N Bool +axF2 :: F Age ~N Char + +Then, because transitivity applies only to coercions proving the same notion +of equivalence, the above construction is impossible. + +However, there is still an escape hatch: we know that any two types that are +nominally equivalent are representationally equivalent as well. This is what +the form SubCo proves -- it "demotes" a nominal equivalence into a +representational equivalence. So, it would seem the following is possible: + +sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG + +What saves us here is that the arguments to a type function F, lifted into a +coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and +we are safe. + +Roles are attached to parameters to TyCons. When lifting a TyCon into a +coercion (through TyConAppCo), we need to ensure that the arguments to the +TyCon respect their roles. For example: + +data T a b = MkT a (F b) + +If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know +that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because +the type function F branches on b's *name*, not representation. So, we say +that 'a' has role Representational and 'b' has role Nominal. The third role, +Phantom, is for parameters not used in the type's definition. Given the +following definition + +data Q a = MkQ Int + +the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we +can construct the coercion Bool ~P Char (using UnivCo). + +See the paper cited above for more examples and information. + +Note [TyConAppCo roles] +~~~~~~~~~~~~~~~~~~~~~~~ +The TyConAppCo constructor has a role parameter, indicating the role at +which the coercion proves equality. The choice of this parameter affects +the required roles of the arguments of the TyConAppCo. To help explain +it, assume the following definition: + + type instance F Int = Bool -- Axiom axF : F Int ~N Bool + newtype Age = MkAge Int -- Axiom axAge : Age ~R Int + data Foo a = MkFoo a -- Role on Foo's parameter is Representational + +TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool + For (TyConAppCo Nominal) all arguments must have role Nominal. Why? + So that Foo Age ~N Foo Int does *not* hold. + +TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool +TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int + For (TyConAppCo Representational), all arguments must have the roles + corresponding to the result of tyConRoles on the TyCon. This is the + whole point of having roles on the TyCon to begin with. So, we can + have Foo Age ~R Foo Int, if Foo's parameter has role R. + + If a Representational TyConAppCo is over-saturated (which is otherwise fine), + the spill-over arguments must all be at Nominal. This corresponds to the + behavior for AppCo. + +TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool + All arguments must have role Phantom. This one isn't strictly + necessary for soundness, but this choice removes ambiguity. + +The rules here dictate the roles of the parameters to mkTyConAppCo +(should be checked by Lint). + +Note [NthCo and newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype N a = MkN Int + type role N representational + +This yields axiom + + NTCo:N :: forall a. N a ~R Int + +We can then build + + co :: forall a b. N a ~R N b + co = NTCo:N a ; sym (NTCo:N b) + +for any `a` and `b`. Because of the role annotation on N, if we use +NthCo, we'll get out a representational coercion. That is: + + NthCo r 0 co :: forall a b. a ~R b + +Yikes! Clearly, this is terrible. The solution is simple: forbid +NthCo to be used on newtypes if the internal coercion is representational. + +This is not just some corner case discovered by a segfault somewhere; +it was discovered in the proof of soundness of roles and described +in the "Safe Coercions" paper (ICFP '14). + +Note [NthCo Cached Roles] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we cache the role of NthCo in the NthCo constructor? +Because computing role(Nth i co) involves figuring out that + + co :: T tys1 ~ T tys2 + +using coercionKind, and finding (coercionRole co), and then looking +at the tyConRoles of T. Avoiding bad asymptotic behaviour here means +we have to compute the kind and role of a coercion simultaneously, +which makes the code complicated and inefficient. + +This only happens for NthCo. Caching the role solves the problem, and +allows coercionKind and coercionRole to be simple. + +See #11735 + +Note [InstCo roles] +~~~~~~~~~~~~~~~~~~~ +Here is (essentially) the typing rule for InstCo: + +g :: (forall a. t1) ~r (forall a. t2) +w :: s1 ~N s2 +------------------------------- InstCo +InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2]) + +Note that the Coercion w *must* be nominal. This is necessary +because the variable a might be used in a "nominal position" +(that is, a place where role inference would require a nominal +role) in t1 or t2. If we allowed w to be representational, we +could get bogus equalities. + +A more nuanced treatment might be able to relax this condition +somewhat, by checking if t1 and/or t2 use their bound variables +in nominal ways. If not, having w be representational is OK. + + +%************************************************************************ +%* * + UnivCoProvenance +%* * +%************************************************************************ + +A UnivCo is a coercion whose proof does not directly express its role +and kind (indeed for some UnivCos, like PluginProv, there /is/ no proof). + +The different kinds of UnivCo are described by UnivCoProvenance. Really +each is entirely separate, but they all share the need to represent their +role and kind, which is done in the UnivCo constructor. + +-} + +-- | For simplicity, we have just one UnivCo that represents a coercion from +-- some type to some other type, with (in general) no restrictions on the +-- type. The UnivCoProvenance specifies more exactly what the coercion really +-- is and why a program should (or shouldn't!) trust the coercion. +-- It is reasonable to consider each constructor of 'UnivCoProvenance' +-- as a totally independent coercion form; their only commonality is +-- that they don't tell you what types they coercion between. (That info +-- is in the 'UnivCo' constructor of 'Coercion'. +data UnivCoProvenance + = PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom + -- roled coercions + + | ProofIrrelProv KindCoercion -- ^ From the fact that any two coercions are + -- considered equivalent. See Note [ProofIrrelProv]. + -- Can be used in Nominal or Representational coercions + + | PluginProv String -- ^ From a plugin, which asserts that this coercion + -- is sound. The string is for the use of the plugin. + + deriving Data.Data + +instance Outputable UnivCoProvenance where + ppr (PhantomProv _) = text "(phantom)" + ppr (ProofIrrelProv _) = text "(proof irrel.)" + ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) + +-- | A coercion to be filled in by the type-checker. See Note [Coercion holes] +data CoercionHole + = CoercionHole { ch_co_var :: CoVar + -- See Note [CoercionHoles and coercion free variables] + + , ch_ref :: IORef (Maybe Coercion) + } + +coHoleCoVar :: CoercionHole -> CoVar +coHoleCoVar = ch_co_var + +setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole +setCoHoleCoVar h cv = h { ch_co_var = cv } + +instance Data.Data CoercionHole where + -- don't traverse? + toConstr _ = abstractConstr "CoercionHole" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoercionHole" + +instance Outputable CoercionHole where + ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) + + +{- Note [Phantom coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = T1 | T2 +Then we have + T s ~R T t +for any old s,t. The witness for this is (TyConAppCo T Rep co), +where (co :: s ~P t) is a phantom coercion built with PhantomProv. +The role of the UnivCo is always Phantom. The Coercion stored is the +(nominal) kind coercion between the types + kind(s) ~N kind (t) + +Note [Coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~ +During typechecking, constraint solving for type classes works by + - Generate an evidence Id, d7 :: Num a + - Wrap it in a Wanted constraint, [W] d7 :: Num a + - Use the evidence Id where the evidence is needed + - Solve the constraint later + - When solved, add an enclosing let-binding let d7 = .... in .... + which actually binds d7 to the (Num a) evidence + +For equality constraints we use a different strategy. See Note [The +equality types story] in TysPrim for background on equality constraints. + - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just + like type classes above. (Indeed, boxed equality constraints *are* classes.) + - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2) + we use a different plan + +For unboxed equalities: + - Generate a CoercionHole, a mutable variable just like a unification + variable + - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest + - Use the CoercionHole in a Coercion, via HoleCo + - Solve the constraint later + - When solved, fill in the CoercionHole by side effect, instead of + doing the let-binding thing + +The main reason for all this is that there may be no good place to let-bind +the evidence for unboxed equalities: + + - We emit constraints for kind coercions, to be used to cast a + type's kind. These coercions then must be used in types. Because + they might appear in a top-level type, there is no place to bind + these (unlifted) coercions in the usual way. + + - A coercion for (forall a. t1) ~ (forall a. t2) will look like + forall a. (coercion for t1~t2) + But the coercion for (t1~t2) may mention 'a', and we don't have + let-bindings within coercions. We could add them, but coercion + holes are easier. + + - Moreover, nothing is lost from the lack of let-bindings. For + dictionaries want to achieve sharing to avoid recomoputing the + dictionary. But coercions are entirely erased, so there's little + benefit to sharing. Indeed, even if we had a let-binding, we + always inline types and coercions at every use site and drop the + binding. + +Other notes about HoleCo: + + * INVARIANT: CoercionHole and HoleCo are used only during type checking, + and should never appear in Core. Just like unification variables; a Type + can contain a TcTyVar, but only during type checking. If, one day, we + use type-level information to separate out forms that can appear during + type-checking vs forms that can appear in core proper, holes in Core will + be ruled out. + + * See Note [CoercionHoles and coercion free variables] + + * Coercion holes can be compared for equality like other coercions: + by looking at the types coerced. + + +Note [CoercionHoles and coercion free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why does a CoercionHole contain a CoVar, as well as reference to +fill in? Because we want to treat that CoVar as a free variable of +the coercion. See #14584, and Note [What prevents a +constraint from floating] in TcSimplify, item (4): + + forall k. [W] co1 :: t1 ~# t2 |> co2 + [W] co2 :: k ~# * + +Here co2 is a CoercionHole. But we /must/ know that it is free in +co1, because that's all that stops it floating outside the +implication. + + +Note [ProofIrrelProv] +~~~~~~~~~~~~~~~~~~~~~ +A ProofIrrelProv is a coercion between coercions. For example: + + data G a where + MkG :: G Bool + +In core, we get + + G :: * -> * + MkG :: forall (a :: *). (a ~ Bool) -> G a + +Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want +a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be + + TyConAppCo Nominal MkG [co3, co4] + where + co3 :: co1 ~ co2 + co4 :: a1 ~ a2 + +Note that + co1 :: a1 ~ Bool + co2 :: a2 ~ Bool + +Here, + co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) + where + co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) + co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, <Bool>] +-} + + +{- ********************************************************************* +* * + foldType and foldCoercion +* * +********************************************************************* -} + +{- Note [foldType] +~~~~~~~~~~~~~~~~~~ +foldType is a bit more powerful than perhaps it looks: + +* You can fold with an accumulating parameter, via + TyCoFolder env (Endo a) + Recall newtype Endo a = Endo (a->a) + +* You can fold monadically with a monad M, via + TyCoFolder env (M a) + provided you have + instance .. => Monoid (M a) + +Note [mapType vs foldType] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We define foldType here, but mapType in module Type. Why? + +* foldType is used in GHC.Core.TyCo.FVs for finding free variables. + It's a very simple function that analyses a type, + but does not construct one. + +* mapType constructs new types, and so it needs to call + the "smart constructors", mkAppTy, mkCastTy, and so on. + These are sophisticated functions, and can't be defined + here in GHC.Core.TyCo.Rep. + +Note [Specialising foldType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We inline foldType at every call site (there are not many), so that it +becomes specialised for the particular monoid *and* TyCoFolder at +that site. This is just for efficiency, but walking over types is +done a *lot* in GHC, so worth optimising. + +We were worried that + TyCoFolder env (Endo a) +might not eta-expand. Recall newtype Endo a = Endo (a->a). + +In particular, given + fvs :: Type -> TyCoVarSet + fvs ty = appEndo (foldType tcf emptyVarSet ty) emptyVarSet + + tcf :: TyCoFolder enf (Endo a) + tcf = TyCoFolder { tcf_tyvar = do_tv, ... } + where + do_tvs is tv = Endo do_it + where + do_it acc | tv `elemVarSet` is = acc + | tv `elemVarSet` acc = acc + | otherwise = acc `extendVarSet` tv + + +we want to end up with + fvs ty = go emptyVarSet ty emptyVarSet + where + go env (TyVarTy tv) acc = acc `extendVarSet` tv + ..etc.. + +And indeed this happens. + - Selections from 'tcf' are done at compile time + - 'go' is nicely eta-expanded. + +We were also worried about + deep_fvs :: Type -> TyCoVarSet + deep_fvs ty = appEndo (foldType deep_tcf emptyVarSet ty) emptyVarSet + + deep_tcf :: TyCoFolder enf (Endo a) + deep_tcf = TyCoFolder { tcf_tyvar = do_tv, ... } + where + do_tvs is tv = Endo do_it + where + do_it acc | tv `elemVarSet` is = acc + | tv `elemVarSet` acc = acc + | otherwise = deep_fvs (varType tv) + `unionVarSet` acc + `extendVarSet` tv + +Here deep_fvs and deep_tcf are mutually recursive, unlike fvs and tcf. +But, amazingly, we get good code here too. GHC is careful not to makr +TyCoFolder data constructor for deep_tcf as a loop breaker, so the +record selections still cancel. And eta expansion still happens too. +-} + +data TyCoFolder env a + = TyCoFolder + { tcf_view :: Type -> Maybe Type -- Optional "view" function + -- E.g. expand synonyms + , tcf_tyvar :: env -> TyVar -> a + , tcf_covar :: env -> CoVar -> a + , tcf_hole :: env -> CoercionHole -> a + -- ^ What to do with coercion holes. + -- See Note [Coercion holes] in GHC.Core.TyCo.Rep. + + , tcf_tycobinder :: env -> TyCoVar -> ArgFlag -> env + -- ^ The returned env is used in the extended scope + } + +{-# INLINE foldTyCo #-} -- See Note [Specialising foldType] +foldTyCo :: Monoid a => TyCoFolder env a -> env + -> (Type -> a, [Type] -> a, Coercion -> a, [Coercion] -> a) +foldTyCo (TyCoFolder { tcf_view = view + , tcf_tyvar = tyvar + , tcf_tycobinder = tycobinder + , tcf_covar = covar + , tcf_hole = cohole }) env + = (go_ty env, go_tys env, go_co env, go_cos env) + where + go_ty env ty | Just ty' <- view ty = go_ty env ty' + go_ty env (TyVarTy tv) = tyvar env tv + go_ty env (AppTy t1 t2) = go_ty env t1 `mappend` go_ty env t2 + go_ty _ (LitTy {}) = mempty + go_ty env (CastTy ty co) = go_ty env ty `mappend` go_co env co + go_ty env (CoercionTy co) = go_co env co + go_ty env (FunTy _ arg res) = go_ty env arg `mappend` go_ty env res + go_ty env (TyConApp _ tys) = go_tys env tys + go_ty env (ForAllTy (Bndr tv vis) inner) + = let !env' = tycobinder env tv vis -- Avoid building a thunk here + in go_ty env (varType tv) `mappend` go_ty env' inner + + -- Explicit recursion becuase using foldr builds a local + -- loop (with env free) and I'm not confident it'll be + -- lambda lifted in the end + go_tys _ [] = mempty + go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts + + go_cos _ [] = mempty + go_cos env (c:cs) = go_co env c `mappend` go_cos env cs + + go_co env (Refl ty) = go_ty env ty + go_co env (GRefl _ ty MRefl) = go_ty env ty + go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co + go_co env (TyConAppCo _ _ args) = go_cos env args + go_co env (AppCo c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (FunCo _ c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (CoVarCo cv) = covar env cv + go_co env (AxiomInstCo _ _ args) = go_cos env args + go_co env (HoleCo hole) = cohole env hole + go_co env (UnivCo p _ t1 t2) = go_prov env p `mappend` go_ty env t1 + `mappend` go_ty env t2 + go_co env (SymCo co) = go_co env co + go_co env (TransCo c1 c2) = go_co env c1 `mappend` go_co env c2 + go_co env (AxiomRuleCo _ cos) = go_cos env cos + go_co env (NthCo _ _ co) = go_co env co + go_co env (LRCo _ co) = go_co env co + go_co env (InstCo co arg) = go_co env co `mappend` go_co env arg + go_co env (KindCo co) = go_co env co + go_co env (SubCo co) = go_co env co + go_co env (ForAllCo tv kind_co co) + = go_co env kind_co `mappend` go_ty env (varType tv) + `mappend` go_co env' co + where + env' = tycobinder env tv Inferred + + go_prov env (PhantomProv co) = go_co env co + go_prov env (ProofIrrelProv co) = go_co env co + go_prov _ (PluginProv _) = mempty + +{- ********************************************************************* +* * + typeSize, coercionSize +* * +********************************************************************* -} + +-- NB: We put typeSize/coercionSize here because they are mutually +-- recursive, and have the CPR property. If we have mutual +-- recursion across a hi-boot file, we don't get the CPR property +-- and these functions allocate a tremendous amount of rubbish. +-- It's not critical (because typeSize is really only used in +-- debug mode, but I tripped over an example (T5642) in which +-- typeSize was one of the biggest single allocators in all of GHC. +-- And it's easy to fix, so I did. + +-- NB: typeSize does not respect `eqType`, in that two types that +-- are `eqType` may return different sizes. This is OK, because this +-- function is used only in reporting, not decision-making. + +typeSize :: Type -> Int +typeSize (LitTy {}) = 1 +typeSize (TyVarTy {}) = 1 +typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (FunTy _ t1 t2) = typeSize t1 + typeSize t2 +typeSize (ForAllTy (Bndr tv _) t) = typeSize (varType tv) + typeSize t +typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) +typeSize (CastTy ty co) = typeSize ty + coercionSize co +typeSize (CoercionTy co) = coercionSize co + +coercionSize :: Coercion -> Int +coercionSize (Refl ty) = typeSize ty +coercionSize (GRefl _ ty MRefl) = typeSize ty +coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co +coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) +coercionSize (AppCo co arg) = coercionSize co + coercionSize arg +coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h +coercionSize (FunCo _ co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (CoVarCo _) = 1 +coercionSize (HoleCo _) = 1 +coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) +coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2 +coercionSize (SymCo co) = 1 + coercionSize co +coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (NthCo _ _ co) = 1 + coercionSize co +coercionSize (LRCo _ co) = 1 + coercionSize co +coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg +coercionSize (KindCo co) = 1 + coercionSize co +coercionSize (SubCo co) = 1 + coercionSize co +coercionSize (AxiomRuleCo _ cs) = 1 + sum (map coercionSize cs) + +provSize :: UnivCoProvenance -> Int +provSize (PhantomProv co) = 1 + coercionSize co +provSize (ProofIrrelProv co) = 1 + coercionSize co +provSize (PluginProv _) = 1 diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot new file mode 100644 index 0000000000..2ffc19795c --- /dev/null +++ b/compiler/GHC/Core/TyCo/Rep.hs-boot @@ -0,0 +1,23 @@ +module GHC.Core.TyCo.Rep where + +import Data.Data ( Data ) +import {-# SOURCE #-} Var( Var, ArgFlag, AnonArgFlag ) + +data Type +data TyThing +data Coercion +data UnivCoProvenance +data TyLit +data TyCoBinder +data MCoercion + +type PredType = Type +type Kind = Type +type ThetaType = [PredType] +type CoercionN = Coercion +type MCoercionN = MCoercion + +mkFunTy :: AnonArgFlag -> Type -> Type -> Type +mkForAllTy :: Var -> ArgFlag -> Type -> Type + +instance Data Type -- To support Data instances in GHC.Core.Coercion.Axiom diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs new file mode 100644 index 0000000000..14eee30633 --- /dev/null +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -0,0 +1,1032 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +Type and Coercion - friends' interface +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Substitution into types and coercions. +module GHC.Core.TyCo.Subst + ( + -- * Substitutions + TCvSubst(..), TvSubstEnv, CvSubstEnv, + emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, + emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, + mkTCvSubst, mkTvSubst, mkCvSubst, + getTvSubstEnv, + getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, + isInScope, notElemTCvSubst, + setTvSubstEnv, setCvSubstEnv, zapTCvSubst, + extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + extendTCvSubst, extendTCvSubstWithClone, + extendCvSubst, extendCvSubstWithClone, + extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, + extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + unionTCvSubst, zipTyEnv, zipCoEnv, + zipTvSubst, zipCvSubst, + zipTCvSubst, + mkTvSubstPrs, + + substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, + substCoWith, + substTy, substTyAddInScope, + substTyUnchecked, substTysUnchecked, substThetaUnchecked, + substTyWithUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTyWithInScope, + substTys, substTheta, + lookupTyVar, + substCo, substCos, substCoVar, substCoVars, lookupCoVar, + cloneTyVarBndr, cloneTyVarBndrs, + substVarBndr, substVarBndrs, + substTyVarBndr, substTyVarBndrs, + substCoVarBndr, + substTyVar, substTyVars, substTyCoVars, + substForAllCoBndr, + substVarBndrUsing, substForAllCoBndrUsing, + checkValidSubst, isValidTCvSubst, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.Type + ( mkCastTy, mkAppTy, isCoercionTy ) +import {-# SOURCE #-} GHC.Core.Coercion + ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo + , mkNomReflCo, mkSubCo, mkSymCo + , mkFunCo, mkForAllCo, mkUnivCo + , mkAxiomInstCo, mkAppCo, mkGReflCo + , mkInstCo, mkLRCo, mkTyConAppCo + , mkCoercionType + , coercionKind, coercionLKind, coVarKindsTypesRole ) + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr + +import Var +import VarSet +import VarEnv + +import Pair +import Util +import UniqSupply +import Unique +import UniqFM +import UniqSet +import Outputable + +import Data.List (mapAccumL) + +{- +%************************************************************************ +%* * + Substitutions + Data type defined here to avoid unnecessary mutual recursion +%* * +%************************************************************************ +-} + +-- | Type & coercion substitution +-- +-- #tcvsubst_invariant# +-- The following invariants must hold of a 'TCvSubst': +-- +-- 1. The in-scope set is needed /only/ to +-- guide the generation of fresh uniques +-- +-- 2. In particular, the /kind/ of the type variables in +-- the in-scope set is not relevant +-- +-- 3. The substitution is only applied ONCE! This is because +-- in general such application will not reach a fixed point. +data TCvSubst + = TCvSubst InScopeSet -- The in-scope type and kind variables + TvSubstEnv -- Substitutes both type and kind variables + CvSubstEnv -- Substitutes coercion variables + -- See Note [Substitutions apply only once] + -- and Note [Extending the TvSubstEnv] + -- and Note [Substituting types and coercions] + -- and Note [The substitution invariant] + +-- | A substitution of 'Type's for 'TyVar's +-- and 'Kind's for 'KindVar's +type TvSubstEnv = TyVarEnv Type + -- NB: A TvSubstEnv is used + -- both inside a TCvSubst (with the apply-once invariant + -- discussed in Note [Substitutions apply only once], + -- and also independently in the middle of matching, + -- and unification (see Types.Unify). + -- So you have to look at the context to know if it's idempotent or + -- apply-once or whatever + +-- | A substitution of 'Coercion's for 'CoVar's +type CvSubstEnv = CoVarEnv Coercion + +{- Note [The substitution invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When calling (substTy subst ty) it should be the case that +the in-scope set in the substitution is a superset of both: + + (SIa) The free vars of the range of the substitution + (SIb) The free vars of ty minus the domain of the substitution + +The same rules apply to other substitutions (notably GHC.Core.Subst.Subst) + +* Reason for (SIa). Consider + substTy [a :-> Maybe b] (forall b. b->a) + we must rename the forall b, to get + forall b2. b2 -> Maybe b + Making 'b' part of the in-scope set forces this renaming to + take place. + +* Reason for (SIb). Consider + substTy [a :-> Maybe b] (forall b. (a,b,x)) + Then if we use the in-scope set {b}, satisfying (SIa), there is + a danger we will rename the forall'd variable to 'x' by mistake, + getting this: + forall x. (Maybe b, x, x) + Breaking (SIb) caused the bug from #11371. + +Note: if the free vars of the range of the substitution are freshly created, +then the problems of (SIa) can't happen, and so it would be sound to +ignore (SIa). + +Note [Substitutions apply only once] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use TCvSubsts to instantiate things, and we might instantiate + forall a b. ty +with the types + [a, b], or [b, a]. +So the substitution might go [a->b, b->a]. A similar situation arises in Core +when we find a beta redex like + (/\ a /\ b -> e) b a +Then we also end up with a substitution that permutes type variables. Other +variations happen to; for example [a -> (a, b)]. + + ******************************************************** + *** So a substitution must be applied precisely once *** + ******************************************************** + +A TCvSubst is not idempotent, but, unlike the non-idempotent substitution +we use during unifications, it must not be repeatedly applied. + +Note [Extending the TvSubstEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #tcvsubst_invariant# for the invariants that must hold. + +This invariant allows a short-cut when the subst envs are empty: +if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) +holds --- then (substTy subst ty) does nothing. + +For example, consider: + (/\a. /\b:(a~Int). ...b..) Int +We substitute Int for 'a'. The Unique of 'b' does not change, but +nevertheless we add 'b' to the TvSubstEnv, because b's kind does change + +This invariant has several crucial consequences: + +* In substVarBndr, we need extend the TvSubstEnv + - if the unique has changed + - or if the kind has changed + +* In substTyVar, we do not need to consult the in-scope set; + the TvSubstEnv is enough + +* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty + +Note [Substituting types and coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Types and coercions are mutually recursive, and either may have variables +"belonging" to the other. Thus, every time we wish to substitute in a +type, we may also need to substitute in a coercion, and vice versa. +However, the constructor used to create type variables is distinct from +that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note +that it would be possible to use the CoercionTy constructor to combine +these environments, but that seems like a false economy. + +Note that the TvSubstEnv should *never* map a CoVar (built with the Id +constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, +the range of the TvSubstEnv should *never* include a type headed with +CoercionTy. +-} + +emptyTvSubstEnv :: TvSubstEnv +emptyTvSubstEnv = emptyVarEnv + +emptyCvSubstEnv :: CvSubstEnv +emptyCvSubstEnv = emptyVarEnv + +composeTCvSubstEnv :: InScopeSet + -> (TvSubstEnv, CvSubstEnv) + -> (TvSubstEnv, CvSubstEnv) + -> (TvSubstEnv, CvSubstEnv) +-- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. +-- It assumes that both are idempotent. +-- Typically, @env1@ is the refinement to a base substitution @env2@ +composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) + = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 + , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) + -- First apply env1 to the range of env2 + -- Then combine the two, making sure that env1 loses if + -- both bind the same variable; that's why env1 is the + -- *left* argument to plusVarEnv, because the right arg wins + where + subst1 = TCvSubst in_scope tenv1 cenv1 + +-- | Composes two substitutions, applying the second one provided first, +-- like in function composition. +composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) + = TCvSubst is3 tenv3 cenv3 + where + is3 = is1 `unionInScope` is2 + (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) + +emptyTCvSubst :: TCvSubst +emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv + +mkEmptyTCvSubst :: InScopeSet -> TCvSubst +mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv + +isEmptyTCvSubst :: TCvSubst -> Bool + -- See Note [Extending the TvSubstEnv] +isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv + +mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst +mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv + +mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst +-- ^ Make a TCvSubst with specified tyvar subst and empty covar subst +mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv + +mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst +-- ^ Make a TCvSubst with specified covar subst and empty tyvar subst +mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv + +getTvSubstEnv :: TCvSubst -> TvSubstEnv +getTvSubstEnv (TCvSubst _ env _) = env + +getCvSubstEnv :: TCvSubst -> CvSubstEnv +getCvSubstEnv (TCvSubst _ _ env) = env + +getTCvInScope :: TCvSubst -> InScopeSet +getTCvInScope (TCvSubst in_scope _ _) = in_scope + +-- | Returns the free variables of the types in the range of a substitution as +-- a non-deterministic set. +getTCvSubstRangeFVs :: TCvSubst -> VarSet +getTCvSubstRangeFVs (TCvSubst _ tenv cenv) + = unionVarSet tenvFVs cenvFVs + where + tenvFVs = shallowTyCoVarsOfTyVarEnv tenv + cenvFVs = shallowTyCoVarsOfCoVarEnv cenv + +isInScope :: Var -> TCvSubst -> Bool +isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope + +notElemTCvSubst :: Var -> TCvSubst -> Bool +notElemTCvSubst v (TCvSubst _ tenv cenv) + | isTyVar v + = not (v `elemVarEnv` tenv) + | otherwise + = not (v `elemVarEnv` cenv) + +setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst +setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv + +setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst +setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv + +zapTCvSubst :: TCvSubst -> TCvSubst +zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv + +extendTCvInScope :: TCvSubst -> Var -> TCvSubst +extendTCvInScope (TCvSubst in_scope tenv cenv) var + = TCvSubst (extendInScopeSet in_scope var) tenv cenv + +extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst +extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars + = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv + +extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst +extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars + = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv + +extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst +extendTCvSubst subst v ty + | isTyVar v + = extendTvSubst subst v ty + | CoercionTy co <- ty + = extendCvSubst subst v co + | otherwise + = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) + +extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst +extendTCvSubstWithClone subst tcv + | isTyVar tcv = extendTvSubstWithClone subst tcv + | otherwise = extendCvSubstWithClone subst tcv + +extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst +extendTvSubst (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv + +extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst +extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty + = ASSERT( isTyVar v ) + extendTvSubstAndInScope subst v ty +extendTvSubstBinderAndInScope subst (Anon {}) _ + = subst + +extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst +-- Adds a new tv -> tv mapping, /and/ extends the in-scope set +extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' + = TCvSubst (extendInScopeSetSet in_scope new_in_scope) + (extendVarEnv tenv tv (mkTyVarTy tv')) + cenv + where + new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' + +extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst +extendCvSubst (TCvSubst in_scope tenv cenv) v co + = TCvSubst in_scope tenv (extendVarEnv cenv v co) + +extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst +extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' + = TCvSubst (extendInScopeSetSet in_scope new_in_scope) + tenv + (extendVarEnv cenv cv (mkCoVarCo cv')) + where + new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' + +extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst +-- Also extends the in-scope set +extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) + (extendVarEnv tenv tv ty) + cenv + +extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTvSubstList subst tvs tys + = foldl2 extendTvSubst subst tvs tys + +extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTCvSubstList subst tvs tys + = foldl2 extendTCvSubst subst tvs tys + +unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +-- Works when the ranges are disjoint +unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) + = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) + && not (cenv1 `intersectsVarEnv` cenv2) ) + TCvSubst (in_scope1 `unionInScope` in_scope2) + (tenv1 `plusVarEnv` tenv2) + (cenv1 `plusVarEnv` cenv2) + +-- mkTvSubstPrs and zipTvSubst generate the in-scope set from +-- the types given; but it's just a thunk so with a bit of luck +-- it'll never be evaluated + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment. No CoVars, please! +zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst +zipTvSubst tvs tys + = mkTvSubst (mkInScopeSet (shallowTyCoVarsOfTypes tys)) tenv + where + tenv = zipTyEnv tvs tys + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment. No TyVars, please! +zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst +zipCvSubst cvs cos + = TCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) emptyTvSubstEnv cenv + where + cenv = zipCoEnv cvs cos + +zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst +zipTCvSubst tcvs tys + = zip_tcvsubst tcvs tys $ + mkEmptyTCvSubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys + where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst + zip_tcvsubst (tv:tvs) (ty:tys) subst + = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) + zip_tcvsubst [] [] subst = subst -- empty case + zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" + (ppr tcvs <+> ppr tys) + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the +-- incoming environment. No CoVars, please! +mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst +mkTvSubstPrs prs = + ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs ) + mkTvSubst in_scope tenv + where tenv = mkVarEnv prs + in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ map snd prs + onlyTyVarsAndNoCoercionTy = + and [ isTyVar tv && not (isCoercionTy ty) + | (tv, ty) <- prs ] + +zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv +zipTyEnv tyvars tys + | debugIsOn + , not (all isTyVar tyvars) + = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys) + | otherwise + = ASSERT( all (not . isCoercionTy) tys ) + mkVarEnv (zipEqual "zipTyEnv" tyvars tys) + -- There used to be a special case for when + -- ty == TyVarTy tv + -- (a not-uncommon case) in which case the substitution was dropped. + -- But the type-tidier changes the print-name of a type variable without + -- changing the unique, and that led to a bug. Why? Pre-tidying, we had + -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. + -- And it happened that t was the type variable of the class. Post-tiding, + -- it got turned into {Foo t2}. The ext-core printer expanded this using + -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, + -- and so generated a rep type mentioning t not t2. + -- + -- Simplest fix is to nuke the "optimisation" + +zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv +zipCoEnv cvs cos + | debugIsOn + , not (all isCoVar cvs) + = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos) + | otherwise + = mkVarEnv (zipEqual "zipCoEnv" cvs cos) + +instance Outputable TCvSubst where + ppr (TCvSubst ins tenv cenv) + = brackets $ sep[ text "TCvSubst", + nest 2 (text "In scope:" <+> ppr ins), + nest 2 (text "Type env:" <+> ppr tenv), + nest 2 (text "Co env:" <+> ppr cenv) ] + +{- +%************************************************************************ +%* * + Performing type or kind substitutions +%* * +%************************************************************************ + +Note [Sym and ForAllCo] +~~~~~~~~~~~~~~~~~~~~~~~ +In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, +how do we push sym into a ForAllCo? It's a little ugly. + +Here is the typing rule: + +h : k1 ~# k2 +(tv : k1) |- g : ty1 ~# ty2 +---------------------------- +ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~# + (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) + +Here is what we want: + +ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~# + (ForAllTy (tv : k1) ty1) + + +Because the kinds of the type variables to the right of the colon are the kinds +coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h). + +Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want + +ForAllCo tv h' g' : + (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~# + (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h'])) + +We thus see that we want + +g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h'] + +and thus g' = sym (g[tv |-> tv |> h']). + +Putting it all together, we get this: + +sym (ForAllCo tv h g) +==> +ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h]) + +Note [Substituting in a coercion hole] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It seems highly suspicious to be substituting in a coercion that still +has coercion holes. Yet, this can happen in a situation like this: + + f :: forall k. k :~: Type -> () + f Refl = let x :: forall (a :: k). [a] -> ... + x = ... + +When we check x's type signature, we require that k ~ Type. We indeed +know this due to the Refl pattern match, but the eager unifier can't +make use of givens. So, when we're done looking at x's type, a coercion +hole will remain. Then, when we're checking x's definition, we skolemise +x's type (in order to, e.g., bring the scoped type variable `a` into scope). +This requires performing a substitution for the fresh skolem variables. + +This substitution needs to affect the kind of the coercion hole, too -- +otherwise, the kind will have an out-of-scope variable in it. More problematically +in practice (we won't actually notice the out-of-scope variable ever), skolems +in the kind might have too high a level, triggering a failure to uphold the +invariant that no free variables in a type have a higher level than the +ambient level in the type checker. In the event of having free variables in the +hole's kind, I'm pretty sure we'll always have an erroneous program, so we +don't need to worry what will happen when the hole gets filled in. After all, +a hole relating a locally-bound type variable will be unable to be solved. This +is why it's OK not to look through the IORef of a coercion hole during +substitution. + +-} + +-- | Type substitution, see 'zipTvSubst' +substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type +-- Works only if the domain of the substitution is a +-- superset of the type being substituted into +substTyWith tvs tys = {-#SCC "substTyWith" #-} + ASSERT( tvs `equalLength` tys ) + substTy (zipTvSubst tvs tys) + +-- | Type substitution, see 'zipTvSubst'. Disables sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type +substTyWithUnchecked tvs tys + = ASSERT( tvs `equalLength` tys ) + substTyUnchecked (zipTvSubst tvs tys) + +-- | Substitute tyvars within a type using a known 'InScopeSet'. +-- Pre-condition: the 'in_scope' set should satisfy Note [The substitution +-- invariant]; specifically it should include the free vars of 'tys', +-- and of 'ty' minus the domain of the subst. +substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type +substTyWithInScope in_scope tvs tys ty = + ASSERT( tvs `equalLength` tys ) + substTy (mkTvSubst in_scope tenv) ty + where tenv = zipTyEnv tvs tys + +-- | Coercion substitution, see 'zipTvSubst' +substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion +substCoWith tvs tys = ASSERT( tvs `equalLength` tys ) + substCo (zipTvSubst tvs tys) + +-- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion +substCoWithUnchecked tvs tys + = ASSERT( tvs `equalLength` tys ) + substCoUnchecked (zipTvSubst tvs tys) + + + +-- | Substitute covars within a type +substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type +substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) + +-- | Type substitution, see 'zipTvSubst' +substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] +substTysWith tvs tys = ASSERT( tvs `equalLength` tys ) + substTys (zipTvSubst tvs tys) + +-- | Type substitution, see 'zipTvSubst' +substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] +substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos ) + substTys (zipCvSubst cvs cos) + +-- | Substitute within a 'Type' after adding the free variables of the type +-- to the in-scope set. This is useful for the case when the free variables +-- aren't already in the in-scope set or easily available. +-- See also Note [The substitution invariant]. +substTyAddInScope :: TCvSubst -> Type -> Type +substTyAddInScope subst ty = + substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty + +-- | When calling `substTy` it should be the case that the in-scope set in +-- the substitution is a superset of the free vars of the range of the +-- substitution. +-- See also Note [The substitution invariant]. +isValidTCvSubst :: TCvSubst -> Bool +isValidTCvSubst (TCvSubst in_scope tenv cenv) = + (tenvFVs `varSetInScope` in_scope) && + (cenvFVs `varSetInScope` in_scope) + where + tenvFVs = shallowTyCoVarsOfTyVarEnv tenv + cenvFVs = shallowTyCoVarsOfCoVarEnv cenv + +-- | This checks if the substitution satisfies the invariant from +-- Note [The substitution invariant]. +checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a +checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a + = ASSERT2( isValidTCvSubst subst, + text "in_scope" <+> ppr in_scope $$ + text "tenv" <+> ppr tenv $$ + text "tenvFVs" <+> ppr (shallowTyCoVarsOfTyVarEnv tenv) $$ + text "cenv" <+> ppr cenv $$ + text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$ + text "tys" <+> ppr tys $$ + text "cos" <+> ppr cos ) + ASSERT2( tysCosFVsInScope, + text "in_scope" <+> ppr in_scope $$ + text "tenv" <+> ppr tenv $$ + text "cenv" <+> ppr cenv $$ + text "tys" <+> ppr tys $$ + text "cos" <+> ppr cos $$ + text "needInScope" <+> ppr needInScope ) + a + where + substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv + -- It's OK to use nonDetKeysUFM here, because we only use this list to + -- remove some elements from a set + needInScope = (shallowTyCoVarsOfTypes tys `unionVarSet` + shallowTyCoVarsOfCos cos) + `delListFromUniqSet_Directly` substDomain + tysCosFVsInScope = needInScope `varSetInScope` in_scope + + +-- | Substitute within a 'Type' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTy :: HasCallStack => TCvSubst -> Type -> Type +substTy subst ty + | isEmptyTCvSubst subst = ty + | otherwise = checkValidSubst subst [ty] [] $ + subst_ty subst ty + +-- | Substitute within a 'Type' disabling the sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substTyUnchecked :: TCvSubst -> Type -> Type +substTyUnchecked subst ty + | isEmptyTCvSubst subst = ty + | otherwise = subst_ty subst ty + +-- | Substitute within several 'Type's +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTys :: HasCallStack => TCvSubst -> [Type] -> [Type] +substTys subst tys + | isEmptyTCvSubst subst = tys + | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys + +-- | Substitute within several 'Type's disabling the sanity checks. +-- The problems that the sanity checks in substTys catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTysUnchecked to +-- substTys and remove this function. Please don't use in new code. +substTysUnchecked :: TCvSubst -> [Type] -> [Type] +substTysUnchecked subst tys + | isEmptyTCvSubst subst = tys + | otherwise = map (subst_ty subst) tys + +-- | Substitute within a 'ThetaType' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType +substTheta = substTys + +-- | Substitute within a 'ThetaType' disabling the sanity checks. +-- The problems that the sanity checks in substTys catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substThetaUnchecked to +-- substTheta and remove this function. Please don't use in new code. +substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType +substThetaUnchecked = substTysUnchecked + + +subst_ty :: TCvSubst -> Type -> Type +-- subst_ty is the main workhorse for type substitution +-- +-- Note that the in_scope set is poked only if we hit a forall +-- so it may often never be fully computed +subst_ty subst ty + = go ty + where + go (TyVarTy tv) = substTyVar subst tv + go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) + -- The mkAppTy smart constructor is important + -- we might be replacing (a Int), represented with App + -- by [Int], represented with TyConApp + go (TyConApp tc tys) = let args = map go tys + in args `seqList` TyConApp tc args + go ty@(FunTy { ft_arg = arg, ft_res = res }) + = let !arg' = go arg + !res' = go res + in ty { ft_arg = arg', ft_res = res' } + go (ForAllTy (Bndr tv vis) ty) + = case substVarBndrUnchecked subst tv of + (subst', tv') -> + (ForAllTy $! ((Bndr $! tv') vis)) $! + (subst_ty subst' ty) + go (LitTy n) = LitTy $! n + go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) + go (CoercionTy co) = CoercionTy $! (subst_co subst co) + +substTyVar :: TCvSubst -> TyVar -> Type +substTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + case lookupVarEnv tenv tv of + Just ty -> ty + Nothing -> TyVarTy tv + +substTyVars :: TCvSubst -> [TyVar] -> [Type] +substTyVars subst = map $ substTyVar subst + +substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] +substTyCoVars subst = map $ substTyCoVar subst + +substTyCoVar :: TCvSubst -> TyCoVar -> Type +substTyCoVar subst tv + | isTyVar tv = substTyVar subst tv + | otherwise = CoercionTy $ substCoVar subst tv + +lookupTyVar :: TCvSubst -> TyVar -> Maybe Type + -- See Note [Extending the TCvSubst] +lookupTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + lookupVarEnv tenv tv + +-- | Substitute within a 'Coercion' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion +substCo subst co + | isEmptyTCvSubst subst = co + | otherwise = checkValidSubst subst [] [co] $ subst_co subst co + +-- | Substitute within a 'Coercion' disabling sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substCoUnchecked :: TCvSubst -> Coercion -> Coercion +substCoUnchecked subst co + | isEmptyTCvSubst subst = co + | otherwise = subst_co subst co + +-- | Substitute within several 'Coercion's +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion] +substCos subst cos + | isEmptyTCvSubst subst = cos + | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos + +subst_co :: TCvSubst -> Coercion -> Coercion +subst_co subst co + = go co + where + go_ty :: Type -> Type + go_ty = subst_ty subst + + go_mco :: MCoercion -> MCoercion + go_mco MRefl = MRefl + go_mco (MCo co) = MCo (go co) + + go :: Coercion -> Coercion + go (Refl ty) = mkNomReflCo $! (go_ty ty) + go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) + go (TyConAppCo r tc args)= let args' = map go args + in args' `seqList` mkTyConAppCo r tc args' + go (AppCo co arg) = (mkAppCo $! go co) $! go arg + go (ForAllCo tv kind_co co) + = case substForAllCoBndrUnchecked subst tv kind_co of + (subst', tv', kind_co') -> + ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co + go (FunCo r co1 co2) = (mkFunCo r $! go co1) $! go co2 + go (CoVarCo cv) = substCoVar subst cv + go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos + go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $! + (go_ty t1)) $! (go_ty t2) + go (SymCo co) = mkSymCo $! (go co) + go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) + go (NthCo r d co) = mkNthCo r d $! (go co) + go (LRCo lr co) = mkLRCo lr $! (go co) + go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg + go (KindCo co) = mkKindCo $! (go co) + go (SubCo co) = mkSubCo $! (go co) + go (AxiomRuleCo c cs) = let cs1 = map go cs + in cs1 `seqList` AxiomRuleCo c cs1 + go (HoleCo h) = HoleCo $! go_hole h + + go_prov (PhantomProv kco) = PhantomProv (go kco) + go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) + go_prov p@(PluginProv _) = p + + -- See Note [Substituting in a coercion hole] + go_hole h@(CoercionHole { ch_co_var = cv }) + = h { ch_co_var = updateVarType go_ty cv } + +substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndr subst + = substForAllCoBndrUsing False (substCo subst) subst + +-- | Like 'substForAllCoBndr', but disables sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndrUnchecked subst + = substForAllCoBndrUsing False (substCoUnchecked subst) subst + +-- See Note [Sym and ForAllCo] +substForAllCoBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, KindCoercion) +substForAllCoBndrUsing sym sco subst old_var + | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var + | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var + +substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyVar -> KindCoercion + -> (TCvSubst, TyVar, KindCoercion) +substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co + = ASSERT( isTyVar old_var ) + ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv + , new_var, new_kind_co ) + where + new_env | no_change && not sym = delVarEnv tenv old_var + | sym = extendVarEnv tenv old_var $ + TyVarTy new_var `CastTy` new_kind_co + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + new_ki1 = coercionLKind new_kind_co + -- We could do substitution to (tyVarKind old_var). We don't do so because + -- we already substituted new_kind_co, which contains the kind information + -- we want. We don't want to do substitution once more. Also, in most cases, + -- new_kind_co is a Refl, in which case coercionKind is really fast. + + new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) + +substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> CoVar -> KindCoercion + -> (TCvSubst, CoVar, KindCoercion) +substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) + old_var old_kind_co + = ASSERT( isCoVar old_var ) + ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv + , new_var, new_kind_co ) + where + new_cenv | no_change && not sym = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + Pair h1 h2 = coercionKind new_kind_co + + new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type + new_var_type | sym = h2 + | otherwise = h1 + +substCoVar :: TCvSubst -> CoVar -> Coercion +substCoVar (TCvSubst _ _ cenv) cv + = case lookupVarEnv cenv cv of + Just co -> co + Nothing -> CoVarCo cv + +substCoVars :: TCvSubst -> [CoVar] -> [Coercion] +substCoVars subst cvs = map (substCoVar subst) cvs + +lookupCoVar :: TCvSubst -> Var -> Maybe Coercion +lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v + +substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndr = substTyVarBndrUsing substTy + +substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) +substTyVarBndrs = mapAccumL substTyVarBndr + +substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndr = substVarBndrUsing substTy + +substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) +substVarBndrs = mapAccumL substVarBndr + +substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndr = substCoVarBndrUsing substTy + +-- | Like 'substVarBndr', but disables sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUnchecked = substVarBndrUsing substTyUnchecked + +substVarBndrUsing :: (TCvSubst -> Type -> Type) + -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUsing subst_fn subst v + | isTyVar v = substTyVarBndrUsing subst_fn subst v + | otherwise = substCoVarBndrUsing subst_fn subst v + +-- | Substitute a tyvar in a binding position, returning an +-- extended subst and a new tyvar. +-- Use the supplied function to substitute in the kind +substTyVarBndrUsing + :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind + -> TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst ) + ASSERT( isTyVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) + where + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + _no_capture = not (new_var `elemVarSet` shallowTyCoVarsOfTyVarEnv tenv) + -- Assertion check that we are not capturing something in the substitution + + old_ki = tyVarKind old_var + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + no_change = no_kind_change && (new_var == old_var) + -- no_change means that the new_var is identical in + -- all respects to the old_var (same unique, same kind) + -- See Note [Extending the TCvSubst] + -- + -- In that case we don't need to extend the substitution + -- to map old to new. But instead we must zap any + -- current substitution for the variable. For example: + -- (\x.e) with id_subst = [x |-> e'] + -- Here we must simply zap the substitution for x + + new_var | no_kind_change = uniqAway in_scope old_var + | otherwise = uniqAway in_scope $ + setTyVarKind old_var (subst_fn subst old_ki) + -- The uniqAway part makes sure the new variable is not already in scope + +-- | Substitute a covar in a binding position, returning an +-- extended subst and a new covar. +-- Use the supplied function to substitute in the kind +substCoVarBndrUsing + :: (TCvSubst -> Type -> Type) + -> TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT( isCoVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + where + new_co = mkCoVarCo new_var + no_kind_change = noFreeVarsOfTypes [t1, t2] + no_change = new_var == old_var && no_kind_change + + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var new_co + + new_var = uniqAway in_scope subst_old_var + subst_old_var = mkCoVar (varName old_var) new_var_type + + (_, _, t1, t2, role) = coVarKindsTypesRole old_var + t1' = subst_fn subst t1 + t2' = subst_fn subst t2 + new_var_type = mkCoercionType role t1' t2' + -- It's important to do the substitution for coercions, + -- because they can have free type variables + +cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) +cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq + = ASSERT2( isTyVar tv, ppr tv ) -- I think it's only called on TyVars + (TCvSubst (extendInScopeSet in_scope tv') + (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') + where + old_ki = tyVarKind tv + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + + tv1 | no_kind_change = tv + | otherwise = setTyVarKind tv (substTy subst old_ki) + + tv' = setVarUnique tv1 uniq + +cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) +cloneTyVarBndrs subst [] _usupply = (subst, []) +cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) + where + (uniq, usupply') = takeUniqFromSupply usupply + (subst' , tv ) = cloneTyVarBndr subst t uniq + (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs new file mode 100644 index 0000000000..3e41e922cc --- /dev/null +++ b/compiler/GHC/Core/TyCo/Tidy.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Tidying types and coercions for printing in error messages. +module GHC.Core.TyCo.Tidy + ( + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes, + tidyOpenTyCoVar, tidyOpenTyCoVars, + tidyTyCoVarOcc, + tidyTopType, + tidyKind, + tidyCo, tidyCos, + tidyTyCoVarBinder, tidyTyCoVarBinders + ) where + +import GhcPrelude + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) + +import Name hiding (varName) +import Var +import VarEnv +import Util (seqList) + +import Data.List (mapAccumL) + +{- +%************************************************************************ +%* * +\subsection{TidyType} +%* * +%************************************************************************ +-} + +-- | This tidies up a type for printing in an error message, or in +-- an interface file. +-- +-- It doesn't change the uniques at all, just the print names. +tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyVarBndrs tidy_env tvs + = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs + +tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +tidyVarBndr tidy_env@(occ_env, subst) var + = case tidyOccName occ_env (getHelpfulOccName var) of + (occ_env', occ') -> ((occ_env', subst'), var') + where + subst' = extendVarEnv subst var var' + var' = setVarType (setVarName var name') type' + type' = tidyType tidy_env (varType var) + name' = tidyNameOcc name occ' + name = varName var + +avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv +-- Seed the occ_env with clashes among the names, see +-- Note [Tidying multiple names at once] in OccName +avoidNameClashes tvs (occ_env, subst) + = (avoidClashesOccEnv occ_env occs, subst) + where + occs = map getHelpfulOccName tvs + +getHelpfulOccName :: TyCoVar -> OccName +-- A TcTyVar with a System Name is probably a +-- unification variable; when we tidy them we give them a trailing +-- "0" (or 1 etc) so that they don't take precedence for the +-- un-modified name. Plus, indicating a unification variable in +-- this way is a helpful clue for users +getHelpfulOccName tv + | isSystemName name, isTcTyVar tv + = mkTyVarOcc (occNameString occ ++ "0") + | otherwise + = occ + where + name = varName tv + occ = getOccName name + +tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis + -> (TidyEnv, VarBndr TyCoVar vis) +tidyTyCoVarBinder tidy_env (Bndr tv vis) + = (tidy_env', Bndr tv' vis) + where + (tidy_env', tv') = tidyVarBndr tidy_env tv + +tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis] + -> (TidyEnv, [VarBndr TyCoVar vis]) +tidyTyCoVarBinders tidy_env tvbs + = mapAccumL tidyTyCoVarBinder + (avoidNameClashes (binderVars tvbs) tidy_env) tvbs + +--------------- +tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv +-- ^ Add the free 'TyVar's to the env in tidy form, +-- so that we can tidy the type they are free in +tidyFreeTyCoVars tidy_env tyvars + = fst (tidyOpenTyCoVars tidy_env tyvars) + +--------------- +tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars + +--------------- +tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +-- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name +-- using the environment if one has not already been allocated. See +-- also 'tidyVarBndr' +tidyOpenTyCoVar env@(_, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> + let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar)) + in tidyVarBndr env' tyvar -- Treat it as a binder + +--------------- +tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar +tidyTyCoVarOcc env@(_, subst) tv + = case lookupVarEnv subst tv of + Nothing -> updateVarType (tidyType env) tv + Just tv' -> tv' + +--------------- +tidyTypes :: TidyEnv -> [Type] -> [Type] +tidyTypes env tys = map (tidyType env) tys + +--------------- +tidyType :: TidyEnv -> Type -> Type +tidyType _ (LitTy n) = LitTy n +tidyType env (TyVarTy tv) = TyVarTy (tidyTyCoVarOcc env tv) +tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys + in args `seqList` TyConApp tycon args +tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env ty@(FunTy _ arg res) = let { !arg' = tidyType env arg + ; !res' = tidyType env res } + in ty { ft_arg = arg', ft_res = res' } +tidyType env (ty@(ForAllTy{})) = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty + where + (tvs, vis, body_ty) = splitForAllTys' ty + (env', tvs') = tidyVarBndrs env tvs +tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) +tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) + + +-- The following two functions differ from mkForAllTys and splitForAllTys in that +-- they expect/preserve the ArgFlag argument. These belong to types/Type.hs, but +-- how should they be named? +mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type +mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs + where + strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty + +splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type) +splitForAllTys' ty = go ty [] [] + where + go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) + go ty tvs viss = (reverse tvs, reverse viss, ty) + + +--------------- +-- | Grabs the free type variables, tidies them +-- and then uses 'tidyType' to work over the type itself +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys + = (env', tidyTypes (trimmed_occ_env, var_env) tys) + where + (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $ + tyCoVarsOfTypesWellScoped tys + trimmed_occ_env = initTidyOccEnv (map getOccName tvs') + -- The idea here was that we restrict the new TidyEnv to the + -- _free_ vars of the types, so that we don't gratuitously rename + -- the _bound_ variables of the types. + +--------------- +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in + (env', ty') + +--------------- +-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty + +--------------- +tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) +tidyOpenKind = tidyOpenType + +tidyKind :: TidyEnv -> Kind -> Kind +tidyKind = tidyType + +---------------- +tidyCo :: TidyEnv -> Coercion -> Coercion +tidyCo env@(_, subst) co + = go co + where + go_mco MRefl = MRefl + go_mco (MCo co) = MCo (go co) + + go (Refl ty) = Refl (tidyType env ty) + go (GRefl r ty mco) = GRefl r (tidyType env ty) $! go_mco mco + go (TyConAppCo r tc cos) = let args = map go cos + in args `seqList` TyConAppCo r tc args + go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 + go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co) + where (envp, tvp) = tidyVarBndr env tv + -- the case above duplicates a bit of work in tidying h and the kind + -- of tv. But the alternative is to use coercionKind, which seems worse. + go (FunCo r co1 co2) = (FunCo r $! go co1) $! go co2 + go (CoVarCo cv) = case lookupVarEnv subst cv of + Nothing -> CoVarCo cv + Just cv' -> CoVarCo cv' + go (HoleCo h) = HoleCo h + go (AxiomInstCo con ind cos) = let args = map go cos + in args `seqList` AxiomInstCo con ind args + go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! + tidyType env t1) $! tidyType env t2 + go (SymCo co) = SymCo $! go co + go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 + go (NthCo r d co) = NthCo r d $! go co + go (LRCo lr co) = LRCo lr $! go co + go (InstCo co ty) = (InstCo $! go co) $! go ty + go (KindCo co) = KindCo $! go co + go (SubCo co) = SubCo $! go co + go (AxiomRuleCo ax cos) = let cos1 = tidyCos env cos + in cos1 `seqList` AxiomRuleCo ax cos1 + + go_prov (PhantomProv co) = PhantomProv (go co) + go_prov (ProofIrrelProv co) = ProofIrrelProv (go co) + go_prov p@(PluginProv _) = p + +tidyCos :: TidyEnv -> [Coercion] -> [Coercion] +tidyCos env = map (tidyCo env) diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs new file mode 100644 index 0000000000..6ee5b27963 --- /dev/null +++ b/compiler/GHC/Core/TyCon.hs @@ -0,0 +1,2811 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The @TyCon@ datatype +-} + +{-# LANGUAGE CPP, FlexibleInstances #-} + +module GHC.Core.TyCon( + -- * Main TyCon data types + TyCon, + AlgTyConRhs(..), visibleDataCons, + AlgTyConFlav(..), isNoParent, + FamTyConFlav(..), Role(..), Injectivity(..), + RuntimeRepInfo(..), TyConFlavour(..), + + -- * TyConBinder + TyConBinder, TyConBndrVis(..), TyConTyCoBinder, + mkNamedTyConBinder, mkNamedTyConBinders, + mkRequiredTyConBinder, + mkAnonTyConBinder, mkAnonTyConBinders, + tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder, + isVisibleTyConBinder, isInvisibleTyConBinder, + + -- ** Field labels + tyConFieldLabels, lookupTyConFieldLabel, + + -- ** Constructing TyCons + mkAlgTyCon, + mkClassTyCon, + mkFunTyCon, + mkPrimTyCon, + mkKindTyCon, + mkLiftedPrimTyCon, + mkTupleTyCon, + mkSumTyCon, + mkDataTyConRhs, + mkSynonymTyCon, + mkFamilyTyCon, + mkPromotedDataCon, + mkTcTyCon, + noTcTyConScopedTyVars, + + -- ** Predicates on TyCons + isAlgTyCon, isVanillaAlgTyCon, + isClassTyCon, isFamInstTyCon, + isFunTyCon, + isPrimTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, + isUnboxedSumTyCon, isPromotedTupleTyCon, + isTypeSynonymTyCon, + mustBeSaturated, + isPromotedDataCon, isPromotedDataCon_maybe, + isKindTyCon, isLiftedTypeKindTyConName, + isTauTyCon, isFamFreeTyCon, + + isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, + isDataSumTyCon_maybe, + isEnumerationTyCon, + isNewTyCon, isAbstractTyCon, + isFamilyTyCon, isOpenFamilyTyCon, + isTypeFamilyTyCon, isDataFamilyTyCon, + isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, + tyConInjectivityInfo, + isBuiltInSynFamTyCon_maybe, + isUnliftedTyCon, + isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, + isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, + isImplicitTyCon, + isTyConWithSrcDataCons, + isTcTyCon, setTcTyConKind, + isTcLevPoly, + + -- ** Extracting information out of TyCons + tyConName, + tyConSkolem, + tyConKind, + tyConUnique, + tyConTyVars, tyConVisibleTyVars, + tyConCType, tyConCType_maybe, + tyConDataCons, tyConDataCons_maybe, + tyConSingleDataCon_maybe, tyConSingleDataCon, + tyConSingleAlgDataCon_maybe, + tyConFamilySize, + tyConStupidTheta, + tyConArity, + tyConRoles, + tyConFlavour, + tyConTuple_maybe, tyConClass_maybe, tyConATs, + tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, + tyConFamilyResVar_maybe, + synTyConDefn_maybe, synTyConRhs_maybe, + famTyConFlav_maybe, famTcResVar, + algTyConRhs, + newTyConRhs, newTyConEtadArity, newTyConEtadRhs, + unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, + newTyConDataCon_maybe, + algTcFields, + tyConRuntimeRepInfo, + tyConBinders, tyConResKind, tyConTyVarBinders, + tcTyConScopedTyVars, tcTyConIsPoly, + mkTyConTagMap, + + -- ** Manipulating TyCons + expandSynTyCon_maybe, + newTyConCo, newTyConCo_maybe, + pprPromotionQuote, mkTyConKind, + + -- ** Predicated on TyConFlavours + tcFlavourIsOpen, + + -- * Runtime type representation + TyConRepName, tyConRepName_maybe, + mkPrelTyConRepName, + tyConRepModOcc, + + -- * Primitive representations of Types + PrimRep(..), PrimElemRep(..), + isVoidRep, isGcPtrRep, + primRepSizeB, + primElemRepSizeB, + primRepIsFloat, + primRepsCompatible, + primRepCompatible, + + -- * Recursion breaking + RecTcChecker, initRecTc, defaultRecTcMaxBound, + setRecTcMaxBound, checkRecTc + +) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Core.TyCo.Rep + ( Kind, Type, PredType, mkForAllTy, mkFunTy ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr + ( pprType ) +import {-# SOURCE #-} TysWiredIn + ( runtimeRepTyCon, constraintKind + , vecCountTyCon, vecElemTyCon, liftedTypeKind ) +import {-# SOURCE #-} GHC.Core.DataCon + ( DataCon, dataConExTyCoVars, dataConFieldLabels + , dataConTyCon, dataConFullSig + , isUnboxedSumCon ) + +import Binary +import Var +import VarSet +import GHC.Core.Class +import BasicTypes +import GHC.Driver.Session +import ForeignCall +import Name +import NameEnv +import GHC.Core.Coercion.Axiom +import PrelNames +import Maybes +import Outputable +import FastStringEnv +import FieldLabel +import Constants +import Util +import Unique( tyConRepNameUnique, dataConTyRepNameUnique ) +import UniqSet +import Module + +import qualified Data.Data as Data + +{- +----------------------------------------------- + Notes about type families +----------------------------------------------- + +Note [Type synonym families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Type synonym families, also known as "type functions", map directly + onto the type functions in FC: + + type family F a :: * + type instance F Int = Bool + ..etc... + +* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon + +* From the user's point of view (F Int) and Bool are simply + equivalent types. + +* A Haskell 98 type synonym is a degenerate form of a type synonym + family. + +* Type functions can't appear in the LHS of a type function: + type instance F (F Int) = ... -- BAD! + +* Translation of type family decl: + type family F a :: * + translates to + a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon + + type family G a :: * where + G Int = Bool + G Bool = Char + G a = () + translates to + a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the + appropriate CoAxiom representing the equations + +We also support injective type families -- see Note [Injective type families] + +Note [Data type families] +~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Wrappers for data instance tycons] in MkId.hs + +* Data type families are declared thus + data family T a :: * + data instance T Int = T1 | T2 Bool + + Here T is the "family TyCon". + +* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon + +* The user does not see any "equivalent types" as he did with type + synonym families. He just sees constructors with types + T1 :: T Int + T2 :: Bool -> T Int + +* Here's the FC version of the above declarations: + + data T a + data R:TInt = T1 | T2 Bool + axiom ax_ti : T Int ~R R:TInt + + Note that this is a *representational* coercion + The R:TInt is the "representation TyCons". + It has an AlgTyConFlav of + DataFamInstTyCon T [Int] ax_ti + +* The axiom ax_ti may be eta-reduced; see + Note [Eta reduction for data families] in GHC.Core.FamInstEnv + +* Data family instances may have a different arity than the data family. + See Note [Arity of data families] in GHC.Core.FamInstEnv + +* The data constructor T2 has a wrapper (which is what the + source-level "T2" invokes): + + $WT2 :: Bool -> T Int + $WT2 b = T2 b `cast` sym ax_ti + +* A data instance can declare a fully-fledged GADT: + + data instance T (a,b) where + X1 :: T (Int,Bool) + X2 :: a -> b -> T (a,b) + + Here's the FC version of the above declaration: + + data R:TPair a b where + X1 :: R:TPair Int Bool + X2 :: a -> b -> R:TPair a b + axiom ax_pr :: T (a,b) ~R R:TPair a b + + $WX1 :: forall a b. a -> b -> T (a,b) + $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) + + The R:TPair are the "representation TyCons". + We have a bit of work to do, to unpick the result types of the + data instance declaration for T (a,b), to get the result type in the + representation; e.g. T (a,b) --> R:TPair a b + + The representation TyCon R:TList, has an AlgTyConFlav of + + DataFamInstTyCon T [(a,b)] ax_pr + +* Notice that T is NOT translated to a FC type function; it just + becomes a "data type" with no constructors, which can be coerced + into R:TInt, R:TPair by the axioms. These axioms + axioms come into play when (and *only* when) you + - use a data constructor + - do pattern matching + Rather like newtype, in fact + + As a result + + - T behaves just like a data type so far as decomposition is concerned + + - (T Int) is not implicitly converted to R:TInt during type inference. + Indeed the latter type is unknown to the programmer. + + - There *is* an instance for (T Int) in the type-family instance + environment, but it is only used for overlap checking + + - It's fine to have T in the LHS of a type function: + type instance F (T a) = [a] + + It was this last point that confused me! The big thing is that you + should not think of a data family T as a *type function* at all, not + even an injective one! We can't allow even injective type functions + on the LHS of a type function: + type family injective G a :: * + type instance F (G Int) = Bool + is no good, even if G is injective, because consider + type instance G Int = Bool + type instance F Bool = Char + + So a data type family is not an injective type function. It's just a + data type with some axioms that connect it to other data types. + +* The tyConTyVars of the representation tycon are the tyvars that the + user wrote in the patterns. This is important in TcDeriv, where we + bring these tyvars into scope before type-checking the deriving + clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. + +Note [Associated families and their parent class] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*Associated* families are just like *non-associated* families, except +that they have a famTcParent field of (Just cls_tc), which identifies the +parent class. + +However there is an important sharing relationship between + * the tyConTyVars of the parent Class + * the tyConTyVars of the associated TyCon + + class C a b where + data T p a + type F a q b + +Here the 'a' and 'b' are shared with the 'Class'; that is, they have +the same Unique. + +This is important. In an instance declaration we expect + * all the shared variables to be instantiated the same way + * the non-shared variables of the associated type should not + be instantiated at all + + instance C [x] (Tree y) where + data T p [x] = T1 x | T2 p + type F [x] q (Tree y) = (x,y,q) + +Note [TyCon Role signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every tycon has a role signature, assigning a role to each of the tyConTyVars +(or of equal length to the tyConArity, if there are no tyConTyVars). An +example demonstrates these best: say we have a tycon T, with parameters a at +nominal, b at representational, and c at phantom. Then, to prove +representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have +nominal equality between a1 and a2, representational equality between b1 and +b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This +might happen, say, with the following declaration: + + data T a b c where + MkT :: b -> T Int b c + +Data and class tycons have their roles inferred (see inferRoles in TcTyDecls), +as do vanilla synonym tycons. Family tycons have all parameters at role N, +though it is conceivable that we could relax this restriction. (->)'s and +tuples' parameters are at role R. Each primitive tycon declares its roles; +it's worth noting that (~#)'s parameters are at role N. Promoted data +constructors' type arguments are at role R. All kind arguments are at role +N. + +Note [Unboxed tuple RuntimeRep vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The contents of an unboxed tuple may have any representation. Accordingly, +the kind of the unboxed tuple constructor is runtime-representation +polymorphic. + +Type constructor (2 kind arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). + TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) +Data constructor (4 type arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) + (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) + +These extra tyvars (q and r) cause some delicate processing around tuples, +where we need to manually insert RuntimeRep arguments. +The same situation happens with unboxed sums: each alternative +has its own RuntimeRep. +For boxed tuples, there is no levity polymorphism, and therefore +we add RuntimeReps only for the unboxed version. + +Type constructor (no kind arguments) + (,) :: Type -> Type -> Type +Data constructor (2 type arguments) + (,) :: forall a b. a -> b -> (a, b) + + +Note [Injective type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow injectivity annotations for type families (both open and closed): + + type family F (a :: k) (b :: k) = r | r -> a + type family G a b = res | res -> a b where ... + +Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. +`famTcInj` maybe stores a list of Bools, where each entry corresponds to a +single element of `tyConTyVars` (both lists should have identical length). If no +injectivity annotation was provided `famTcInj` is Nothing. From this follows an +invariant that if `famTcInj` is a Just then at least one element in the list +must be True. + +See also: + * [Injectivity annotation] in GHC.Hs.Decls + * [Renaming injectivity annotation] in GHC.Rename.Source + * [Verifying injectivity annotation] in GHC.Core.FamInstEnv + * [Type inference for type families with injectivity] in TcInteract + +************************************************************************ +* * + TyConBinder, TyConTyCoBinder +* * +************************************************************************ +-} + +type TyConBinder = VarBndr TyVar TyConBndrVis + +-- In the whole definition of @data TyCon@, only @PromotedDataCon@ will really +-- contain CoVar. +type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis + +data TyConBndrVis + = NamedTCB ArgFlag + | AnonTCB AnonArgFlag + +instance Outputable TyConBndrVis where + ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag + ppr (AnonTCB af) = text "AnonTCB" <> ppr af + +mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder +mkAnonTyConBinder af tv = ASSERT( isTyVar tv) + Bndr tv (AnonTCB af) + +mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder] +mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs + +mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder +-- The odd argument order supports currying +mkNamedTyConBinder vis tv = ASSERT( isTyVar tv ) + Bndr tv (NamedTCB vis) + +mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder] +-- The odd argument order supports currying +mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs + +-- | Make a Required TyConBinder. It chooses between NamedTCB and +-- AnonTCB based on whether the tv is mentioned in the dependent set +mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently + -> TyVar + -> TyConBinder +mkRequiredTyConBinder dep_set tv + | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv + | otherwise = mkAnonTyConBinder VisArg tv + +tyConBinderArgFlag :: TyConBinder -> ArgFlag +tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis + +tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag +tyConBndrVisArgFlag (NamedTCB vis) = vis +tyConBndrVisArgFlag (AnonTCB VisArg) = Required +tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred -- See Note [AnonTCB InvisArg] + +isNamedTyConBinder :: TyConBinder -> Bool +-- Identifies kind variables +-- E.g. data T k (a:k) = blah +-- Here 'k' is a NamedTCB, a variable used in the kind of other binders +isNamedTyConBinder (Bndr _ (NamedTCB {})) = True +isNamedTyConBinder _ = False + +isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis + +isVisibleTcbVis :: TyConBndrVis -> Bool +isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis +isVisibleTcbVis (AnonTCB VisArg) = True +isVisibleTcbVis (AnonTCB InvisArg) = False + +isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) + +-- Build the 'tyConKind' from the binders and the result kind. +-- Keep in sync with 'mkTyConKind' in GHC.Iface.Type. +mkTyConKind :: [TyConBinder] -> Kind -> Kind +mkTyConKind bndrs res_kind = foldr mk res_kind bndrs + where + mk :: TyConBinder -> Kind -> Kind + mk (Bndr tv (AnonTCB af)) k = mkFunTy af (varType tv) k + mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k + +tyConTyVarBinders :: [TyConBinder] -- From the TyCon + -> [TyVarBinder] -- Suitable for the foralls of a term function +-- See Note [Building TyVarBinders from TyConBinders] +tyConTyVarBinders tc_bndrs + = map mk_binder tc_bndrs + where + mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv + where + vis = case tc_vis of + AnonTCB VisArg -> Specified + AnonTCB InvisArg -> Inferred -- See Note [AnonTCB InvisArg] + NamedTCB Required -> Specified + NamedTCB vis -> vis + +-- Returns only tyvars, as covars are always inferred +tyConVisibleTyVars :: TyCon -> [TyVar] +tyConVisibleTyVars tc + = [ tv | Bndr tv vis <- tyConBinders tc + , isVisibleTcbVis vis ] + +{- Note [AnonTCB InvisArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's pretty rare to have an (AnonTCB InvisArg) binder. The +only way it can occur is through equality constraints in kinds. These +can arise in one of two ways: + +* In a PromotedDataCon whose kind has an equality constraint: + + 'MkT :: forall a b. (a~b) => blah + + See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and + Note [Promoted data constructors] in this module. +* In a data type whose kind has an equality constraint, as in the + following example from #12102: + + data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type + +When mapping an (AnonTCB InvisArg) to an ArgFlag, in +tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot +specify this arguments, even with visible type/kind application; +instead the type checker must fill it in. + +We map (AnonTCB VisArg) to Required, of course: the user must +provide it. It would be utterly wrong to do this for constraint +arguments, which is why AnonTCB must have the AnonArgFlag in +the first place. + +Note [Building TyVarBinders from TyConBinders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We sometimes need to build the quantified type of a value from +the TyConBinders of a type or class. For that we need not +TyConBinders but TyVarBinders (used in forall-type) E.g: + + * From data T a = MkT (Maybe a) + we are going to make a data constructor with type + MkT :: forall a. Maybe a -> T a + See the TyCoVarBinders passed to buildDataCon + + * From class C a where { op :: a -> Maybe a } + we are going to make a default method + $dmop :: forall a. C a => a -> Maybe a + See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType + +Both of these are user-callable. (NB: default methods are not callable +directly by the user but rather via the code generated by 'deriving', +which uses visible type application; see mkDefMethBind.) + +Since they are user-callable we must get their type-argument visibility +information right; and that info is in the TyConBinders. +Here is an example: + + data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> * + +The TyCon has + + tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ] + +The TyConBinders for App line up with App's kind, given above. + +But the DataCon MkApp has the type + MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b + +That is, its TyCoVarBinders should be + + dataConUnivTyVarBinders = [ Bndr (k:*) Inferred + , Bndr (a:k->*) Specified + , Bndr (b:k) Specified ] + +So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: + - variable names from the TyConBinders + - but changing Anon/Required to Specified + +The last part about Required->Specified comes from this: + data T k (a:k) b = MkT (a b) +Here k is Required in T's kind, but we don't have Required binders in +the TyCoBinders for a term (see Note [No Required TyCoBinder in terms] +in GHC.Core.TyCo.Rep), so we change it to Specified when making MkT's TyCoBinders +-} + + +{- Note [The binders/kind/arity fields of a TyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All TyCons have this group of fields + tyConBinders :: [TyConBinder/TyConTyCoBinder] + tyConResKind :: Kind + tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders + -- NB: Currently (Aug 2018), TyCons that own this + -- field really only contain TyVars. So it is + -- [TyVar] instead of [TyCoVar]. + tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind + tyConArity :: Arity -- Cached = length tyConBinders + +They fit together like so: + +* tyConBinders gives the telescope of type/coercion variables on the LHS of the + type declaration. For example: + + type App a (b :: k) = a b + + tyConBinders = [ Bndr (k::*) (NamedTCB Inferred) + , Bndr (a:k->*) AnonTCB + , Bndr (b:k) AnonTCB ] + + Note that that are three binders here, including the + kind variable k. + +* See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep + for what the visibility flag means. + +* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and + that TyVar may scope over some other part of the TyCon's definition. Eg + type T a = a -> a + we have + tyConBinders = [ Bndr (a:*) AnonTCB ] + synTcRhs = a -> a + So the 'a' scopes over the synTcRhs + +* From the tyConBinders and tyConResKind we can get the tyConKind + E.g for our App example: + App :: forall k. (k->*) -> k -> * + + We get a 'forall' in the kind for each NamedTCB, and an arrow + for each AnonTCB + + tyConKind is the full kind of the TyCon, not just the result kind + +* For type families, tyConArity is the arguments this TyCon must be + applied to, to be considered saturated. Here we mean "applied to in + the actual Type", not surface syntax; i.e. including implicit kind + variables. So it's just (length tyConBinders) + +* For an algebraic data type, or data instance, the tyConResKind is + always (TYPE r); that is, the tyConBinders are enough to saturate + the type constructor. I'm not quite sure why we have this invariant, + but it's enforced by etaExpandAlgTyCon +-} + +instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where + ppr (Bndr v bi) = ppr_bi bi <+> parens (pprBndr LetBind v) + where + ppr_bi (AnonTCB VisArg) = text "anon-vis" + ppr_bi (AnonTCB InvisArg) = text "anon-invis" + ppr_bi (NamedTCB Required) = text "req" + ppr_bi (NamedTCB Specified) = text "spec" + ppr_bi (NamedTCB Inferred) = text "inf" + +instance Binary TyConBndrVis where + put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } + put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { af <- get bh; return (AnonTCB af) } + _ -> do { vis <- get bh; return (NamedTCB vis) } } + + +{- ********************************************************************* +* * + The TyCon type +* * +************************************************************************ +-} + + +-- | TyCons represent type constructors. Type constructors are introduced by +-- things such as: +-- +-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of +-- kind @*@ +-- +-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor +-- +-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor +-- of kind @* -> *@ +-- +-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor +-- of kind @*@ +-- +-- This data type also encodes a number of primitive, built in type constructors +-- such as those for function and tuple types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data TyCon + = -- | The function type constructor, @(->)@ + FunTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + tcRepName :: TyConRepName + } + + -- | Algebraic data types, from + -- - @data@ declarations + -- - @newtype@ declarations + -- - data instance declarations + -- - type instance declarations + -- - the TyCon generated by a class declaration + -- - boxed tuples + -- - unboxed tuples + -- - constraint tuples + -- All these constructors are lifted and boxed except unboxed tuples + -- which should have an 'UnboxedAlgTyCon' parent. + -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. + -- See 'AlgTyConRhs' for more information. + | AlgTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + -- The tyConTyVars scope over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in algTyConRhs.NewTyCon + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data + -- constructors. + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + tyConCType :: Maybe CType,-- ^ The C type that should be used + -- for this type when using the FFI + -- and CAPI + + algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT + -- syntax? If so, that doesn't mean it's a + -- true GADT; only that the "where" form + -- was used. This field is used only to + -- guide pretty-printing + + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data + -- type (always empty for GADTs). A + -- \"stupid theta\" is the context to + -- the left of an algebraic type + -- declaration, e.g. @Eq a@ in the + -- declaration @data Eq a => T a ...@. + + algTcRhs :: AlgTyConRhs, -- ^ Contains information about the + -- data constructors of the algebraic type + + algTcFields :: FieldLabelEnv, -- ^ Maps a label to information + -- about the field + + algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration + -- 'TyCon' for derived 'TyCon's representing + -- class or family instances, respectively. + + } + + -- | Represents type synonyms + | SynonymTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + -- tyConTyVars scope over: synTcRhs + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + synTcRhs :: Type, -- ^ Contains information about the expansion + -- of the synonym + + synIsTau :: Bool, -- True <=> the RHS of this synonym does not + -- have any foralls, after expanding any + -- nested synonyms + synIsFamFree :: Bool -- True <=> the RHS of this synonym does not mention + -- any type synonym families (data families + -- are fine), again after expanding any + -- nested synonyms + } + + -- | Represents families (both type and data) + -- Argument roles are all Nominal + | FamilyTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + -- tyConTyVars connect an associated family TyCon + -- with its parent class; see TcValidity.checkConsistentFamInst + + famTcResVar :: Maybe Name, -- ^ Name of result type variable, used + -- for pretty-printing with --show-iface + -- and for reifying TyCon in Template + -- Haskell + + famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, + -- abstract, built-in. See comments for + -- FamTyConFlav + + famTcParent :: Maybe TyCon, -- ^ For *associated* type/data families + -- The class tycon in which the family is declared + -- See Note [Associated families and their parent class] + + famTcInj :: Injectivity -- ^ is this a type family injective in + -- its type variables? Nothing if no + -- injectivity annotation was given + } + + -- | Primitive types; cannot be defined in Haskell. This includes + -- the usual suspects (such as @Int#@) as well as foreign-imported + -- types and kinds (@*@, @#@, and @?@) + | PrimTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + isUnlifted :: Bool, -- ^ Most primitive tycons are unlifted (may + -- not contain bottom) but other are lifted, + -- e.g. @RealWorld@ + -- Only relevant if tyConKind = * + + primRepName :: Maybe TyConRepName -- Only relevant for kind TyCons + -- i.e, *, #, ? + } + + -- | Represents promoted data constructor. + | PromotedDataCon { -- See Note [Promoted data constructors] + tyConUnique :: Unique, -- ^ Same Unique as the data constructor + tyConName :: Name, -- ^ Same Name as the data constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConTyCoBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars + dataCon :: DataCon, -- ^ Corresponding data constructor + tcRepName :: TyConRepName, + promDcRepInfo :: RuntimeRepInfo -- ^ See comments with 'RuntimeRepInfo' + } + + -- | These exist only during type-checking. See Note [How TcTyCons work] + -- in TcTyClsDecls + | TcTyCon { + tyConUnique :: Unique, + tyConName :: Name, + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + -- NB: the TyConArity of a TcTyCon must match + -- the number of Required (positional, user-specified) + -- arguments to the type constructor; see the use + -- of tyConArity in generaliseTcTyCon + + tcTyConScopedTyVars :: [(Name,TyVar)], + -- ^ Scoped tyvars over the tycon's body + -- See Note [Scoped tyvars in a TcTyCon] + + tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized? + + tcTyConFlavour :: TyConFlavour + -- ^ What sort of 'TyCon' this represents. + } +{- Note [Scoped tyvars in a TcTyCon] + +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The tcTyConScopedTyVars field records the lexicial-binding connection +between the original, user-specified Name (i.e. thing in scope) and +the TcTyVar that the Name is bound to. + +Order *does* matter; the tcTyConScopedTyvars list consists of + specified_tvs ++ required_tvs + +where + * specified ones first + * required_tvs the same as tyConTyVars + * tyConArity = length required_tvs + +See also Note [How TcTyCons work] in TcTyClsDecls +-} + +-- | Represents right-hand-sides of 'TyCon's for algebraic types +data AlgTyConRhs + + -- | Says that we know nothing about this data type, except that + -- it's represented by a pointer. Used when we export a data type + -- abstractly into an .hi file. + = AbstractTyCon + + -- | Information about those 'TyCon's derived from a @data@ + -- declaration. This includes data types with no constructors at + -- all. + | DataTyCon { + data_cons :: [DataCon], + -- ^ The data type constructors; can be empty if the + -- user declares the type to have no constructors + -- + -- INVARIANT: Kept in order of increasing 'DataCon' + -- tag (see the tag assignment in mkTyConTagMap) + data_cons_size :: Int, + -- ^ Cached value: length data_cons + is_enum :: Bool -- ^ Cached value: is this an enumeration type? + -- See Note [Enumeration types] + } + + | TupleTyCon { -- A boxed, unboxed, or constraint tuple + data_con :: DataCon, -- NB: it can be an *unboxed* tuple + tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint + -- tuple? + } + + -- | An unboxed sum type. + | SumTyCon { + data_cons :: [DataCon], + data_cons_size :: Int -- ^ Cached value: length data_cons + } + + -- | Information about those 'TyCon's derived from a @newtype@ declaration + | NewTyCon { + data_con :: DataCon, -- ^ The unique constructor for the @newtype@. + -- It has no existentials + + nt_rhs :: Type, -- ^ Cached value: the argument type of the + -- constructor, which is just the representation + -- type of the 'TyCon' (remember that @newtype@s + -- do not exist at runtime so need a different + -- representation type). + -- + -- The free 'TyVar's of this type are the + -- 'tyConTyVars' from the corresponding 'TyCon' + + nt_etad_rhs :: ([TyVar], Type), + -- ^ Same as the 'nt_rhs', but this time eta-reduced. + -- Hence the list of 'TyVar's in this field may be + -- shorter than the declared arity of the 'TyCon'. + + -- See Note [Newtype eta] + nt_co :: CoAxiom Unbranched, + -- The axiom coercion that creates the @newtype@ + -- from the representation 'Type'. + + -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] + -- Watch out! If any newtypes become transparent + -- again check #1072. + nt_lev_poly :: Bool + -- 'True' if the newtype can be levity polymorphic when + -- fully applied to its arguments, 'False' otherwise. + -- This can only ever be 'True' with UnliftedNewtypes. + -- + -- Invariant: nt_lev_poly nt = isTypeLevPoly (nt_rhs nt) + -- + -- This is cached to make it cheaper to check if a + -- variable binding is levity polymorphic, as used by + -- isTcLevPoly. + } + +mkSumTyConRhs :: [DataCon] -> AlgTyConRhs +mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) + +mkDataTyConRhs :: [DataCon] -> AlgTyConRhs +mkDataTyConRhs cons + = DataTyCon { + data_cons = cons, + data_cons_size = length cons, + is_enum = not (null cons) && all is_enum_con cons + -- See Note [Enumeration types] in GHC.Core.TyCon + } + where + is_enum_con con + | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) + <- dataConFullSig con + = null ex_tvs && null eq_spec && null theta && null arg_tys + +-- | Some promoted datacons signify extra info relevant to GHC. For example, +-- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep' +-- constructor of 'PrimRep'. This data structure allows us to store this +-- information right in the 'TyCon'. The other approach would be to look +-- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. +-- See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType +data RuntimeRepInfo + = NoRRI -- ^ an ordinary promoted data con + | RuntimeRep ([Type] -> [PrimRep]) + -- ^ A constructor of @RuntimeRep@. The argument to the function should + -- be the list of arguments to the promoted datacon. + | VecCount Int -- ^ A constructor of @VecCount@ + | VecElem PrimElemRep -- ^ A constructor of @VecElem@ + +-- | Extract those 'DataCon's that we are able to learn about. Note +-- that visibility in this sense does not correspond to visibility in +-- the context of any particular user program! +visibleDataCons :: AlgTyConRhs -> [DataCon] +visibleDataCons (AbstractTyCon {}) = [] +visibleDataCons (DataTyCon{ data_cons = cs }) = cs +visibleDataCons (NewTyCon{ data_con = c }) = [c] +visibleDataCons (TupleTyCon{ data_con = c }) = [c] +visibleDataCons (SumTyCon{ data_cons = cs }) = cs + +-- ^ Both type classes as well as family instances imply implicit +-- type constructors. These implicit type constructors refer to their parent +-- structure (ie, the class or family from which they derive) using a type of +-- the following form. +data AlgTyConFlav + = -- | An ordinary type constructor has no parent. + VanillaAlgTyCon + TyConRepName -- For Typeable + + -- | An unboxed type constructor. The TyConRepName is a Maybe since we + -- currently don't allow unboxed sums to be Typeable since there are too + -- many of them. See #13276. + | UnboxedAlgTyCon + (Maybe TyConRepName) + + -- | Type constructors representing a class dictionary. + -- See Note [ATyCon for classes] in GHC.Core.TyCo.Rep + | ClassTyCon + Class -- INVARIANT: the classTyCon of this Class is the + -- current tycon + TyConRepName + + -- | Type constructors representing an *instance* of a *data* family. + -- Parameters: + -- + -- 1) The type family in question + -- + -- 2) Instance types; free variables are the 'tyConTyVars' + -- of the current 'TyCon' (not the family one). INVARIANT: + -- the number of types matches the arity of the family 'TyCon' + -- + -- 3) A 'CoTyCon' identifying the representation + -- type with the type instance family + | DataFamInstTyCon -- See Note [Data type families] + (CoAxiom Unbranched) -- The coercion axiom. + -- A *Representational* coercion, + -- of kind T ty1 ty2 ~R R:T a b c + -- where T is the family TyCon, + -- and R:T is the representation TyCon (ie this one) + -- and a,b,c are the tyConTyVars of this TyCon + -- + -- BUT may be eta-reduced; see FamInstEnv + -- Note [Eta reduction for data families] + + -- Cached fields of the CoAxiom, but adjusted to + -- use the tyConTyVars of this TyCon + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- No shorter in length than the tyConTyVars of the family TyCon + -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv + + -- E.g. data instance T [a] = ... + -- gives a representation tycon: + -- data R:TList a = ... + -- axiom co a :: T [a] ~ R:TList a + -- with R:TList's algTcParent = DataFamInstTyCon T [a] co + +instance Outputable AlgTyConFlav where + ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" + ppr (UnboxedAlgTyCon {}) = text "Unboxed ADT" + ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls + ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" + <+> ppr tc <+> sep (map pprType tys) + +-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class +-- name, if any +okParent :: Name -> AlgTyConFlav -> Bool +okParent _ (VanillaAlgTyCon {}) = True +okParent _ (UnboxedAlgTyCon {}) = True +okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) +okParent _ (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc + +isNoParent :: AlgTyConFlav -> Bool +isNoParent (VanillaAlgTyCon {}) = True +isNoParent _ = False + +-------------------- + +data Injectivity + = NotInjective + | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) + deriving( Eq ) + +-- | Information pertaining to the expansion of a type synonym (@type@) +data FamTyConFlav + = -- | Represents an open type family without a fixed right hand + -- side. Additional instances can appear at any time. + -- + -- These are introduced by either a top level declaration: + -- + -- > data family T a :: * + -- + -- Or an associated data type declaration, within a class declaration: + -- + -- > class C a b where + -- > data T b :: * + DataFamilyTyCon + TyConRepName + + -- | An open type synonym family e.g. @type family F x y :: * -> *@ + | OpenSynFamilyTyCon + + -- | A closed type synonym family e.g. + -- @type family F x where { F Int = Bool }@ + | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) + -- See Note [Closed type families] + + -- | A closed type synonym family declared in an hs-boot file with + -- type family F a where .. + | AbstractClosedSynFamilyTyCon + + -- | Built-in type family used by the TypeNats solver + | BuiltInSynFamTyCon BuiltInSynFamily + +instance Outputable FamTyConFlav where + ppr (DataFamilyTyCon n) = text "data family" <+> ppr n + ppr OpenSynFamilyTyCon = text "open type family" + ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" + ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax + ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" + ppr (BuiltInSynFamTyCon _) = text "built-in type family" + +{- Note [Closed type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* In an open type family you can add new instances later. This is the + usual case. + +* In a closed type family you can only put equations where the family + is defined. + +A non-empty closed type family has a single axiom with multiple +branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed +type family with no equations does not have an axiom, because there is +nothing for the axiom to prove! + + +Note [Promoted data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All data constructors can be promoted to become a type constructor, +via the PromotedDataCon alternative in GHC.Core.TyCon. + +* The TyCon promoted from a DataCon has the *same* Name and Unique as + the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, + say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) + +* We promote the *user* type of the DataCon. Eg + data T = MkT {-# UNPACK #-} !(Bool, Bool) + The promoted kind is + 'MkT :: (Bool,Bool) -> T + *not* + 'MkT :: Bool -> Bool -> T + +* Similarly for GADTs: + data G a where + MkG :: forall b. b -> G [b] + The promoted data constructor has kind + 'MkG :: forall b. b -> G [b] + *not* + 'MkG :: forall a b. (a ~# [b]) => b -> G a + +Note [Enumeration types] +~~~~~~~~~~~~~~~~~~~~~~~~ +We define datatypes with no constructors to *not* be +enumerations; this fixes trac #2578, Otherwise we +end up generating an empty table for + <mod>_<type>_closure_tbl +which is used by tagToEnum# to map Int# to constructors +in an enumeration. The empty table apparently upset +the linker. + +Moreover, all the data constructor must be enumerations, meaning +they have type (forall abc. T a b c). GADTs are not enumerations. +For example consider + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a +What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. +See #4528. + +Note [Newtype coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +The NewTyCon field nt_co is a CoAxiom which is used for coercing from +the representation type of the newtype, to the newtype itself. For +example, + + newtype T a = MkT (a -> a) + +the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t. + +In the case that the right hand side is a type application +ending with the same type variables as the left hand side, we +"eta-contract" the coercion. So if we had + + newtype S a = MkT [a] + +then we would generate the arity 0 axiom CoS : S ~ []. The +primary reason we do this is to make newtype deriving cleaner. + +In the paper we'd write + axiom CoT : (forall t. T t) ~ (forall t. [t]) +and then when we used CoT at a particular type, s, we'd say + CoT @ s +which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) + +Note [Newtype eta] +~~~~~~~~~~~~~~~~~~ +Consider + newtype Parser a = MkParser (IO a) deriving Monad +Are these two types equal (to Core)? + Monad Parser + Monad IO +which we need to make the derived instance for Monad Parser. + +Well, yes. But to see that easily we eta-reduce the RHS type of +Parser, in this case to ([], Froogle), so that even unsaturated applications +of Parser will work right. This eta reduction is done when the type +constructor is built, and cached in NewTyCon. + +Here's an example that I think showed up in practice +Source code: + newtype T a = MkT [a] + newtype Foo m = MkFoo (forall a. m a -> Int) + + w1 :: Foo [] + w1 = ... + + w2 :: Foo T + w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) + +After desugaring, and discarding the data constructors for the newtypes, +we get: + w2 = w1 `cast` Foo CoT +so the coercion tycon CoT must have + kind: T ~ [] + and arity: 0 + +This eta-reduction is implemented in BuildTyCl.mkNewTyConRhs. + + +************************************************************************ +* * + TyConRepName +* * +********************************************************************* -} + +type TyConRepName = Name + -- The Name of the top-level declaration for the Typeable world + -- $tcMaybe :: Data.Typeable.Internal.TyCon + -- $tcMaybe = TyCon { tyConName = "Maybe", ... } + +tyConRepName_maybe :: TyCon -> Maybe TyConRepName +tyConRepName_maybe (FunTyCon { tcRepName = rep_nm }) + = Just rep_nm +tyConRepName_maybe (PrimTyCon { primRepName = mb_rep_nm }) + = mb_rep_nm +tyConRepName_maybe (AlgTyCon { algTcParent = parent }) + | VanillaAlgTyCon rep_nm <- parent = Just rep_nm + | ClassTyCon _ rep_nm <- parent = Just rep_nm + | UnboxedAlgTyCon rep_nm <- parent = rep_nm +tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) + = Just rep_nm +tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm }) + | isUnboxedSumCon dc -- see #13276 + = Nothing + | otherwise + = Just rep_nm +tyConRepName_maybe _ = Nothing + +-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type +mkPrelTyConRepName :: Name -> TyConRepName +-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. +mkPrelTyConRepName tc_name -- Prelude tc_name is always External, + -- so nameModule will work + = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) + where + name_occ = nameOccName tc_name + name_mod = nameModule tc_name + name_uniq = nameUnique tc_name + rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq + | otherwise = dataConTyRepNameUnique name_uniq + (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ + +-- | The name (and defining module) for the Typeable representation (TyCon) of a +-- type constructor. +-- +-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. +tyConRepModOcc :: Module -> OccName -> (Module, OccName) +tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) + where + rep_module + | tc_module == gHC_PRIM = gHC_TYPES + | otherwise = tc_module + + +{- ********************************************************************* +* * + PrimRep +* * +************************************************************************ + +Note [rep swamp] + +GHC has a rich selection of types that represent "primitive types" of +one kind or another. Each of them makes a different set of +distinctions, and mostly the differences are for good reasons, +although it's probably true that we could merge some of these. + +Roughly in order of "includes more information": + + - A Width (cmm/CmmType) is simply a binary value with the specified + number of bits. It may represent a signed or unsigned integer, a + floating-point value, or an address. + + data Width = W8 | W16 | W32 | W64 | W128 + + - Size, which is used in the native code generator, is Width + + floating point information. + + data Size = II8 | II16 | II32 | II64 | FF32 | FF64 + + it is necessary because e.g. the instruction to move a 64-bit float + on x86 (movsd) is different from the instruction to move a 64-bit + integer (movq), so the mov instruction is parameterised by Size. + + - CmmType wraps Width with more information: GC ptr, float, or + other value. + + data CmmType = CmmType CmmCat Width + + data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + + It is important to have GcPtr information in Cmm, since we generate + info tables containing pointerhood for the GC from this. As for + why we have float (and not signed/unsigned) here, see Note [Signed + vs unsigned]. + + - ArgRep makes only the distinctions necessary for the call and + return conventions of the STG machine. It is essentially CmmType + + void. + + - PrimRep makes a few more distinctions than ArgRep: it divides + non-GC-pointers into signed/unsigned and addresses, information + that is necessary for passing these values to foreign functions. + +There's another tension here: whether the type encodes its size in +bytes, or whether its size depends on the machine word size. Width +and CmmType have the size built-in, whereas ArgRep and PrimRep do not. + +This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. + +On the other hand, CmmType includes some "nonsense" values, such as +CmmType GcPtrCat W32 on a 64-bit machine. + +The PrimRep type is closely related to the user-visible RuntimeRep type. +See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. + +-} + +-- | A 'PrimRep' is an abstraction of a type. It contains information that +-- the code generator needs in order to pass arguments, return results, +-- and store values of this type. See also Note [RuntimeRep and PrimRep] in +-- GHC.Types.RepType and Note [VoidRep] in GHC.Types.RepType. +data PrimRep + = VoidRep + | LiftedRep + | UnliftedRep -- ^ Unlifted pointer + | Int8Rep -- ^ Signed, 8-bit value + | Int16Rep -- ^ Signed, 16-bit value + | Int32Rep -- ^ Signed, 32-bit value + | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) + | IntRep -- ^ Signed, word-sized value + | Word8Rep -- ^ Unsigned, 8 bit value + | Word16Rep -- ^ Unsigned, 16 bit value + | Word32Rep -- ^ Unsigned, 32 bit value + | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) + | WordRep -- ^ Unsigned, word-sized value + | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') + | FloatRep + | DoubleRep + | VecRep Int PrimElemRep -- ^ A vector + deriving( Show ) + +data PrimElemRep + = Int8ElemRep + | Int16ElemRep + | Int32ElemRep + | Int64ElemRep + | Word8ElemRep + | Word16ElemRep + | Word32ElemRep + | Word64ElemRep + | FloatElemRep + | DoubleElemRep + deriving( Eq, Show ) + +instance Outputable PrimRep where + ppr r = text (show r) + +instance Outputable PrimElemRep where + ppr r = text (show r) + +isVoidRep :: PrimRep -> Bool +isVoidRep VoidRep = True +isVoidRep _other = False + +isGcPtrRep :: PrimRep -> Bool +isGcPtrRep LiftedRep = True +isGcPtrRep UnliftedRep = True +isGcPtrRep _ = False + +-- A PrimRep is compatible with another iff one can be coerced to the other. +-- See Note [bad unsafe coercion] in GHC.Core.Lint for when are two types coercible. +primRepCompatible :: DynFlags -> PrimRep -> PrimRep -> Bool +primRepCompatible dflags rep1 rep2 = + (isUnboxed rep1 == isUnboxed rep2) && + (primRepSizeB dflags rep1 == primRepSizeB dflags rep2) && + (primRepIsFloat rep1 == primRepIsFloat rep2) + where + isUnboxed = not . isGcPtrRep + +-- More general version of `primRepCompatible` for types represented by zero or +-- more than one PrimReps. +primRepsCompatible :: DynFlags -> [PrimRep] -> [PrimRep] -> Bool +primRepsCompatible dflags reps1 reps2 = + length reps1 == length reps2 && + and (zipWith (primRepCompatible dflags) reps1 reps2) + +-- | The size of a 'PrimRep' in bytes. +-- +-- This applies also when used in a constructor, where we allow packing the +-- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will +-- take only 8 bytes, which for 64-bit arch will be equal to 1 word. +-- See also mkVirtHeapOffsetsWithPadding for details of how data fields are +-- laid out. +primRepSizeB :: DynFlags -> PrimRep -> Int +primRepSizeB dflags IntRep = wORD_SIZE dflags +primRepSizeB dflags WordRep = wORD_SIZE dflags +primRepSizeB _ Int8Rep = 1 +primRepSizeB _ Int16Rep = 2 +primRepSizeB _ Int32Rep = 4 +primRepSizeB _ Int64Rep = wORD64_SIZE +primRepSizeB _ Word8Rep = 1 +primRepSizeB _ Word16Rep = 2 +primRepSizeB _ Word32Rep = 4 +primRepSizeB _ Word64Rep = wORD64_SIZE +primRepSizeB _ FloatRep = fLOAT_SIZE +primRepSizeB dflags DoubleRep = dOUBLE_SIZE dflags +primRepSizeB dflags AddrRep = wORD_SIZE dflags +primRepSizeB dflags LiftedRep = wORD_SIZE dflags +primRepSizeB dflags UnliftedRep = wORD_SIZE dflags +primRepSizeB _ VoidRep = 0 +primRepSizeB _ (VecRep len rep) = len * primElemRepSizeB rep + +primElemRepSizeB :: PrimElemRep -> Int +primElemRepSizeB Int8ElemRep = 1 +primElemRepSizeB Int16ElemRep = 2 +primElemRepSizeB Int32ElemRep = 4 +primElemRepSizeB Int64ElemRep = 8 +primElemRepSizeB Word8ElemRep = 1 +primElemRepSizeB Word16ElemRep = 2 +primElemRepSizeB Word32ElemRep = 4 +primElemRepSizeB Word64ElemRep = 8 +primElemRepSizeB FloatElemRep = 4 +primElemRepSizeB DoubleElemRep = 8 + +-- | Return if Rep stands for floating type, +-- returns Nothing for vector types. +primRepIsFloat :: PrimRep -> Maybe Bool +primRepIsFloat FloatRep = Just True +primRepIsFloat DoubleRep = Just True +primRepIsFloat (VecRep _ _) = Nothing +primRepIsFloat _ = Just False + + +{- +************************************************************************ +* * + Field labels +* * +************************************************************************ +-} + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabels :: TyCon -> [FieldLabel] +tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabelEnv :: TyCon -> FieldLabelEnv +tyConFieldLabelEnv tc + | isAlgTyCon tc = algTcFields tc + | otherwise = emptyDFsEnv + +-- | Look up a field label belonging to this 'TyCon' +lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel +lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl + +-- | Make a map from strings to FieldLabels from all the data +-- constructors of this algebraic tycon +fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv +fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl) + | fl <- dataConsFields (visibleDataCons rhs) ] + where + -- Duplicates in this list will be removed by 'mkFsEnv' + dataConsFields dcs = concatMap dataConFieldLabels dcs + + +{- +************************************************************************ +* * +\subsection{TyCon Construction} +* * +************************************************************************ + +Note: the TyCon constructors all take a Kind as one argument, even though +they could, in principle, work out their Kind from their other arguments. +But to do so they need functions from Types, and that makes a nasty +module mutual-recursion. And they aren't called from many places. +So we compromise, and move their Kind calculation to the call site. +-} + +-- | Given the name of the function type constructor and it's kind, create the +-- corresponding 'TyCon'. It is recommended to use 'GHC.Core.TyCo.Rep.funTyCon' if you want +-- this functionality +mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon +mkFunTyCon name binders rep_nm + = FunTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConResKind = liftedTypeKind, + tyConKind = mkTyConKind binders liftedTypeKind, + tyConArity = length binders, + tcRepName = rep_nm + } + +-- | This is the making of an algebraic 'TyCon'. Notably, you have to +-- pass in the generic (in the -XGenerics sense) information about the +-- type constructor - you can get hold of it easily (see Generics +-- module) +mkAlgTyCon :: Name + -> [TyConBinder] -- ^ Binders of the 'TyCon' + -> Kind -- ^ Result kind + -> [Role] -- ^ The roles for each TyVar + -> Maybe CType -- ^ The C type this type corresponds to + -- when using the CAPI FFI + -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' + -> AlgTyConRhs -- ^ Information about data constructors + -> AlgTyConFlav -- ^ What flavour is it? + -- (e.g. vanilla, type family) + -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? + -> TyCon +mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn + = AlgTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConTyVars = binderVars binders, + tcRoles = roles, + tyConCType = cType, + algTcStupidTheta = stupid, + algTcRhs = rhs, + algTcFields = fieldsOfAlgTcRhs rhs, + algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, + algTcGadtSyntax = gadt_syn + } + +-- | Simpler specialization of 'mkAlgTyCon' for classes +mkClassTyCon :: Name -> [TyConBinder] + -> [Role] -> AlgTyConRhs -> Class + -> Name -> TyCon +mkClassTyCon name binders roles rhs clas tc_rep_name + = mkAlgTyCon name binders constraintKind roles Nothing [] rhs + (ClassTyCon clas tc_rep_name) + False + +mkTupleTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Result kind of the 'TyCon' + -> Arity -- ^ Arity of the tuple 'TyCon' + -> DataCon + -> TupleSort -- ^ Whether the tuple is boxed or unboxed + -> AlgTyConFlav + -> TyCon +mkTupleTyCon name binders res_kind arity con sort parent + = AlgTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConTyVars = binderVars binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = arity, + tcRoles = replicate arity Representational, + tyConCType = Nothing, + algTcGadtSyntax = False, + algTcStupidTheta = [], + algTcRhs = TupleTyCon { data_con = con, + tup_sort = sort }, + algTcFields = emptyDFsEnv, + algTcParent = parent + } + +mkSumTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Kind of the resulting 'TyCon' + -> Arity -- ^ Arity of the sum + -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' + -> [DataCon] + -> AlgTyConFlav + -> TyCon +mkSumTyCon name binders res_kind arity tyvars cons parent + = AlgTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConTyVars = tyvars, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = arity, + tcRoles = replicate arity Representational, + tyConCType = Nothing, + algTcGadtSyntax = False, + algTcStupidTheta = [], + algTcRhs = mkSumTyConRhs cons, + algTcFields = emptyDFsEnv, + algTcParent = parent + } + +-- | Makes a tycon suitable for use during type-checking. It stores +-- a variety of details about the definition of the TyCon, but no +-- right-hand side. It lives only during the type-checking of a +-- mutually-recursive group of tycons; it is then zonked to a proper +-- TyCon in zonkTcTyCon. +-- See also Note [Kind checking recursive type and class declarations] +-- in TcTyClsDecls. +mkTcTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ /result/ kind only + -> [(Name,TcTyVar)] -- ^ Scoped type variables; + -- see Note [How TcTyCons work] in TcTyClsDecls + -> Bool -- ^ Is this TcTyCon generalised already? + -> TyConFlavour -- ^ What sort of 'TyCon' this represents + -> TyCon +mkTcTyCon name binders res_kind scoped_tvs poly flav + = TcTyCon { tyConUnique = getUnique name + , tyConName = name + , tyConTyVars = binderVars binders + , tyConBinders = binders + , tyConResKind = res_kind + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tcTyConScopedTyVars = scoped_tvs + , tcTyConIsPoly = poly + , tcTyConFlavour = flav } + +-- | No scoped type variables (to be used with mkTcTyCon). +noTcTyConScopedTyVars :: [(Name, TcTyVar)] +noTcTyConScopedTyVars = [] + +-- | Create an unlifted primitive 'TyCon', such as @Int#@. +mkPrimTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind, never levity-polymorphic + -> [Role] -> TyCon +mkPrimTyCon name binders res_kind roles + = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name) + +-- | Kind constructors +mkKindTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind + -> [Role] -> Name -> TyCon +mkKindTyCon name binders res_kind roles rep_nm + = tc + where + tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) + +-- | Create a lifted primitive 'TyCon' such as @RealWorld@ +mkLiftedPrimTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind + -> [Role] -> TyCon +mkLiftedPrimTyCon name binders res_kind roles + = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) + where rep_nm = mkPrelTyConRepName name + +mkPrimTyCon' :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind, never levity-polymorphic + -- (If you need a levity-polymorphic PrimTyCon, change + -- isTcLevPoly.) + -> [Role] + -> Bool -> Maybe TyConRepName -> TyCon +mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm + = PrimTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length roles, + tcRoles = roles, + isUnlifted = is_unlifted, + primRepName = rep_nm + } + +-- | Create a type synonym 'TyCon' +mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> Type -> Bool -> Bool -> TyCon +mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free + = SynonymTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConTyVars = binderVars binders, + tcRoles = roles, + synTcRhs = rhs, + synIsTau = is_tau, + synIsFamFree = is_fam_free + } + +-- | Create a type family 'TyCon' +mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> Maybe Name -> FamTyConFlav + -> Maybe Class -> Injectivity -> TyCon +mkFamilyTyCon name binders res_kind resVar flav parent inj + = FamilyTyCon + { tyConUnique = nameUnique name + , tyConName = name + , tyConBinders = binders + , tyConResKind = res_kind + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tyConTyVars = binderVars binders + , famTcResVar = resVar + , famTcFlav = flav + , famTcParent = classTyCon <$> parent + , famTcInj = inj + } + + +-- | Create a promoted data constructor 'TyCon' +-- Somewhat dodgily, we give it the same Name +-- as the data constructor itself; when we pretty-print +-- the TyCon we add a quote; see the Outputable TyCon instance +mkPromotedDataCon :: DataCon -> Name -> TyConRepName + -> [TyConTyCoBinder] -> Kind -> [Role] + -> RuntimeRepInfo -> TyCon +mkPromotedDataCon con name rep_name binders res_kind roles rep_info + = PromotedDataCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConArity = length roles, + tcRoles = roles, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + dataCon = con, + tcRepName = rep_name, + promDcRepInfo = rep_info + } + +isFunTyCon :: TyCon -> Bool +isFunTyCon (FunTyCon {}) = True +isFunTyCon _ = False + +-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) +isAbstractTyCon :: TyCon -> Bool +isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True +isAbstractTyCon _ = False + +-- | Does this 'TyCon' represent something that cannot be defined in Haskell? +isPrimTyCon :: TyCon -> Bool +isPrimTyCon (PrimTyCon {}) = True +isPrimTyCon _ = False + +-- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can +-- only be true for primitive and unboxed-tuple 'TyCon's +isUnliftedTyCon :: TyCon -> Bool +isUnliftedTyCon (PrimTyCon {isUnlifted = is_unlifted}) + = is_unlifted +isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) + | TupleTyCon { tup_sort = sort } <- rhs + = not (isBoxed (tupleSortBoxity sort)) +isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) + | SumTyCon {} <- rhs + = True +isUnliftedTyCon _ = False + +-- | Returns @True@ if the supplied 'TyCon' resulted from either a +-- @data@ or @newtype@ declaration +isAlgTyCon :: TyCon -> Bool +isAlgTyCon (AlgTyCon {}) = True +isAlgTyCon _ = False + +-- | Returns @True@ for vanilla AlgTyCons -- that is, those created +-- with a @data@ or @newtype@ declaration. +isVanillaAlgTyCon :: TyCon -> Bool +isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True +isVanillaAlgTyCon _ = False + +isDataTyCon :: TyCon -> Bool +-- ^ Returns @True@ for data types that are /definitely/ represented by +-- heap-allocated constructors. These are scrutinised by Core-level +-- @case@ expressions, and they get info tables allocated for them. +-- +-- Generally, the function will be true for all @data@ types and false +-- for @newtype@s, unboxed tuples, unboxed sums and type family +-- 'TyCon's. But it is not guaranteed to return @True@ in all cases +-- that it could. +-- +-- NB: for a data type family, only the /instance/ 'TyCon's +-- get an info table. The family declaration 'TyCon' does not +isDataTyCon (AlgTyCon {algTcRhs = rhs}) + = case rhs of + TupleTyCon { tup_sort = sort } + -> isBoxed (tupleSortBoxity sort) + SumTyCon {} -> False + DataTyCon {} -> True + NewTyCon {} -> False + AbstractTyCon {} -> False -- We don't know, so return False +isDataTyCon _ = False + +-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds +-- (where X is the role passed in): +-- If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2) +-- (where X1, X2, and X3, are the roles given by tyConRolesX tc X) +-- See also Note [Decomposing equality] in TcCanonical +isInjectiveTyCon :: TyCon -> Role -> Bool +isInjectiveTyCon _ Phantom = False +isInjectiveTyCon (FunTyCon {}) _ = True +isInjectiveTyCon (AlgTyCon {}) Nominal = True +isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational + = isGenInjAlgRhs rhs +isInjectiveTyCon (SynonymTyCon {}) _ = False +isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) + Nominal = True +isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj +isInjectiveTyCon (FamilyTyCon {}) _ = False +isInjectiveTyCon (PrimTyCon {}) _ = True +isInjectiveTyCon (PromotedDataCon {}) _ = True +isInjectiveTyCon (TcTyCon {}) _ = True + -- Reply True for TcTyCon to minimise knock on type errors + -- See Note [How TcTyCons work] item (1) in TcTyClsDecls + +-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds +-- (where X is the role passed in): +-- If (T tys ~X t), then (t's head ~X T). +-- See also Note [Decomposing equality] in TcCanonical +isGenerativeTyCon :: TyCon -> Role -> Bool +isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True +isGenerativeTyCon (FamilyTyCon {}) _ = False + -- in all other cases, injectivity implies generativity +isGenerativeTyCon tc r = isInjectiveTyCon tc r + +-- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective +-- with respect to representational equality? +isGenInjAlgRhs :: AlgTyConRhs -> Bool +isGenInjAlgRhs (TupleTyCon {}) = True +isGenInjAlgRhs (SumTyCon {}) = True +isGenInjAlgRhs (DataTyCon {}) = True +isGenInjAlgRhs (AbstractTyCon {}) = False +isGenInjAlgRhs (NewTyCon {}) = False + +-- | Is this 'TyCon' that for a @newtype@ +isNewTyCon :: TyCon -> Bool +isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True +isNewTyCon _ = False + +-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it +-- expands into, and (possibly) a coercion from the representation type to the +-- @newtype@. +-- Returns @Nothing@ if this is not possible. +unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, + algTcRhs = NewTyCon { nt_co = co, + nt_rhs = rhs }}) + = Just (tvs, rhs, co) +unwrapNewTyCon_maybe _ = Nothing + +unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co, + nt_etad_rhs = (tvs,rhs) }}) + = Just (tvs, rhs, co) +unwrapNewTyConEtad_maybe _ = Nothing + +isProductTyCon :: TyCon -> Bool +-- True of datatypes or newtypes that have +-- one, non-existential, data constructor +-- See Note [Product types] +isProductTyCon tc@(AlgTyCon {}) + = case algTcRhs tc of + TupleTyCon {} -> True + DataTyCon{ data_cons = [data_con] } + -> null (dataConExTyCoVars data_con) + NewTyCon {} -> True + _ -> False +isProductTyCon _ = False + +isDataProductTyCon_maybe :: TyCon -> Maybe DataCon +-- True of datatypes (not newtypes) with +-- one, vanilla, data constructor +-- See Note [Product types] +isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = [con] } + | null (dataConExTyCoVars con) -- non-existential + -> Just con + TupleTyCon { data_con = con } + -> Just con + _ -> Nothing +isDataProductTyCon_maybe _ = Nothing + +isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon] +isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = cons } + | cons `lengthExceeds` 1 + , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? + -> Just cons + SumTyCon { data_cons = cons } + | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? + -> Just cons + _ -> Nothing +isDataSumTyCon_maybe _ = Nothing + +{- Note [Product types] +~~~~~~~~~~~~~~~~~~~~~~~ +A product type is + * A data type (not a newtype) + * With one, boxed data constructor + * That binds no existential type variables + +The main point is that product types are amenable to unboxing for + * Strict function calls; we can transform + f (D a b) = e + to + fw a b = e + via the worker/wrapper transformation. (Question: couldn't this + work for existentials too?) + + * CPR for function results; we can transform + f x y = let ... in D a b + to + fw x y = let ... in (# a, b #) + +Note that the data constructor /can/ have evidence arguments: equality +constraints, type classes etc. So it can be GADT. These evidence +arguments are simply value arguments, and should not get in the way. +-} + + +-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? +isTypeSynonymTyCon :: TyCon -> Bool +isTypeSynonymTyCon (SynonymTyCon {}) = True +isTypeSynonymTyCon _ = False + +isTauTyCon :: TyCon -> Bool +isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau +isTauTyCon _ = True + +isFamFreeTyCon :: TyCon -> Bool +isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free +isFamFreeTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav +isFamFreeTyCon _ = True + +-- As for newtypes, it is in some contexts important to distinguish between +-- closed synonyms and synonym families, as synonym families have no unique +-- right hand side to which a synonym family application can expand. +-- + +-- | True iff we can decompose (T a b c) into ((T a b) c) +-- I.e. is it injective and generative w.r.t nominal equality? +-- That is, if (T a b) ~N d e f, is it always the case that +-- (T ~N d), (a ~N e) and (b ~N f)? +-- Specifically NOT true of synonyms (open and otherwise) +-- +-- It'd be unusual to call mustBeSaturated on a regular H98 +-- type synonym, because you should probably have expanded it first +-- But regardless, it's not decomposable +mustBeSaturated :: TyCon -> Bool +mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour + +-- | Is this an algebraic 'TyCon' declared with the GADT syntax? +isGadtSyntaxTyCon :: TyCon -> Bool +isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res +isGadtSyntaxTyCon _ = False + +-- | Is this an algebraic 'TyCon' which is just an enumeration of values? +isEnumerationTyCon :: TyCon -> Bool +-- See Note [Enumeration types] in GHC.Core.TyCon +isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs }) + = case rhs of + DataTyCon { is_enum = res } -> res + TupleTyCon {} -> arity == 0 + _ -> False +isEnumerationTyCon _ = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family? +isFamilyTyCon :: TyCon -> Bool +isFamilyTyCon (FamilyTyCon {}) = True +isFamilyTyCon _ = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family with +-- instances? +isOpenFamilyTyCon :: TyCon -> Bool +isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav }) + | OpenSynFamilyTyCon <- flav = True + | DataFamilyTyCon {} <- flav = True +isOpenFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isTypeFamilyTyCon :: TyCon -> Bool +isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav) +isTypeFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isDataFamilyTyCon :: TyCon -> Bool +isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav +isDataFamilyTyCon _ = False + +-- | Is this an open type family TyCon? +isOpenTypeFamilyTyCon :: TyCon -> Bool +isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True +isOpenTypeFamilyTyCon _ = False + +-- | Is this a non-empty closed type family? Returns 'Nothing' for +-- abstract or empty closed families. +isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) +isClosedSynFamilyTyConWithAxiom_maybe + (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb +isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing + +-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an +-- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is +-- injective), or 'NotInjective' otherwise. +tyConInjectivityInfo :: TyCon -> Injectivity +tyConInjectivityInfo tc + | FamilyTyCon { famTcInj = inj } <- tc + = inj + | isInjectiveTyCon tc Nominal + = Injective (replicate (tyConArity tc) True) + | otherwise + = NotInjective + +isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily +isBuiltInSynFamTyCon_maybe + (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops +isBuiltInSynFamTyCon_maybe _ = Nothing + +isDataFamFlav :: FamTyConFlav -> Bool +isDataFamFlav (DataFamilyTyCon {}) = True -- Data family +isDataFamFlav _ = False -- Type synonym family + +-- | Is this TyCon for an associated type? +isTyConAssoc :: TyCon -> Bool +isTyConAssoc = isJust . tyConAssoc_maybe + +-- | Get the enclosing class TyCon (if there is one) for the given TyCon. +tyConAssoc_maybe :: TyCon -> Maybe TyCon +tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour + +-- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour +tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon +tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent) = mb_parent +tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent +tyConFlavourAssoc_maybe _ = Nothing + +-- The unit tycon didn't used to be classed as a tuple tycon +-- but I thought that was silly so I've undone it +-- If it can't be for some reason, it should be a AlgTyCon +isTupleTyCon :: TyCon -> Bool +-- ^ Does this 'TyCon' represent a tuple? +-- +-- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to +-- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they +-- get spat into the interface file as tuple tycons, so I don't think +-- it matters. +isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True +isTupleTyCon _ = False + +tyConTuple_maybe :: TyCon -> Maybe TupleSort +tyConTuple_maybe (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon { tup_sort = sort} <- rhs = Just sort +tyConTuple_maybe _ = Nothing + +-- | Is this the 'TyCon' for an unboxed tuple? +isUnboxedTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon { tup_sort = sort } <- rhs + = not (isBoxed (tupleSortBoxity sort)) +isUnboxedTupleTyCon _ = False + +-- | Is this the 'TyCon' for a boxed tuple? +isBoxedTupleTyCon :: TyCon -> Bool +isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon { tup_sort = sort } <- rhs + = isBoxed (tupleSortBoxity sort) +isBoxedTupleTyCon _ = False + +-- | Is this the 'TyCon' for an unboxed sum? +isUnboxedSumTyCon :: TyCon -> Bool +isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) + | SumTyCon {} <- rhs + = True +isUnboxedSumTyCon _ = False + +-- | Is this the 'TyCon' for a /promoted/ tuple? +isPromotedTupleTyCon :: TyCon -> Bool +isPromotedTupleTyCon tyCon + | Just dataCon <- isPromotedDataCon_maybe tyCon + , isTupleTyCon (dataConTyCon dataCon) = True + | otherwise = False + +-- | Is this a PromotedDataCon? +isPromotedDataCon :: TyCon -> Bool +isPromotedDataCon (PromotedDataCon {}) = True +isPromotedDataCon _ = False + +-- | Retrieves the promoted DataCon if this is a PromotedDataCon; +isPromotedDataCon_maybe :: TyCon -> Maybe DataCon +isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc +isPromotedDataCon_maybe _ = Nothing + +-- | Is this tycon really meant for use at the kind level? That is, +-- should it be permitted without -XDataKinds? +isKindTyCon :: TyCon -> Bool +isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys + +-- | These TyCons should be allowed at the kind level, even without +-- -XDataKinds. +kindTyConKeys :: UniqSet Unique +kindTyConKeys = unionManyUniqSets + ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ] + : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon + , vecCountTyCon, vecElemTyCon ] ) + where + tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) + +isLiftedTypeKindTyConName :: Name -> Bool +isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) + +-- | Identifies implicit tycons that, in particular, do not go into interface +-- files (because they are implicitly reconstructed when the interface is +-- read). +-- +-- Note that: +-- +-- * Associated families are implicit, as they are re-constructed from +-- the class declaration in which they reside, and +-- +-- * Family instances are /not/ implicit as they represent the instance body +-- (similar to a @dfun@ does that for a class instance). +-- +-- * Tuples are implicit iff they have a wired-in name +-- (namely: boxed and unboxed tuples are wired-in and implicit, +-- but constraint tuples are not) +isImplicitTyCon :: TyCon -> Bool +isImplicitTyCon (FunTyCon {}) = True +isImplicitTyCon (PrimTyCon {}) = True +isImplicitTyCon (PromotedDataCon {}) = True +isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) + | TupleTyCon {} <- rhs = isWiredInName name + | SumTyCon {} <- rhs = True + | otherwise = False +isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent +isImplicitTyCon (SynonymTyCon {}) = False +isImplicitTyCon (TcTyCon {}) = False + +tyConCType_maybe :: TyCon -> Maybe CType +tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc +tyConCType_maybe _ = Nothing + +-- | Is this a TcTyCon? (That is, one only used during type-checking?) +isTcTyCon :: TyCon -> Bool +isTcTyCon (TcTyCon {}) = True +isTcTyCon _ = False + +setTcTyConKind :: TyCon -> Kind -> TyCon +-- Update the Kind of a TcTyCon +-- The new kind is always a zonked version of its previous +-- kind, so we don't need to update any other fields. +-- See Note [The Purely Kinded Invariant] in TcHsType +setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind } +setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc) + +-- | Could this TyCon ever be levity-polymorphic when fully applied? +-- True is safe. False means we're sure. Does only a quick check +-- based on the TyCon's category. +-- Precondition: The fully-applied TyCon has kind (TYPE blah) +isTcLevPoly :: TyCon -> Bool +isTcLevPoly FunTyCon{} = False +isTcLevPoly (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) + | UnboxedAlgTyCon _ <- parent + = True + | NewTyCon { nt_lev_poly = lev_poly } <- rhs + = lev_poly -- Newtypes can be levity polymorphic with UnliftedNewtypes (#17360) + | otherwise + = False +isTcLevPoly SynonymTyCon{} = True +isTcLevPoly FamilyTyCon{} = True +isTcLevPoly PrimTyCon{} = False +isTcLevPoly TcTyCon{} = False +isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc) + +{- +----------------------------------------------- +-- Expand type-constructor applications +----------------------------------------------- +-} + +expandSynTyCon_maybe + :: TyCon + -> [tyco] -- ^ Arguments to 'TyCon' + -> Maybe ([(TyVar,tyco)], + Type, + [tyco]) -- ^ Returns a 'TyVar' substitution, the body + -- type of the synonym (not yet substituted) + -- and any arguments remaining from the + -- application + +-- ^ Expand a type synonym application, if any +expandSynTyCon_maybe tc tys + | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc + = case tys `listLengthCmp` arity of + GT -> Just (tvs `zip` tys, rhs, drop arity tys) + EQ -> Just (tvs `zip` tys, rhs, []) + LT -> Nothing + | otherwise + = Nothing + +---------------- + +-- | Check if the tycon actually refers to a proper `data` or `newtype` +-- with user defined constructors rather than one from a class or other +-- construction. + +-- NB: This is only used in TcRnExports.checkPatSynParent to determine if an +-- exported tycon can have a pattern synonym bundled with it, e.g., +-- module Foo (TyCon(.., PatSyn)) where +isTyConWithSrcDataCons :: TyCon -> Bool +isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) = + case rhs of + DataTyCon {} -> isSrcParent + NewTyCon {} -> isSrcParent + TupleTyCon {} -> isSrcParent + _ -> False + where + isSrcParent = isNoParent parent +isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} }) + = True -- #14058 +isTyConWithSrcDataCons _ = False + + +-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no +-- constructors could be found +tyConDataCons :: TyCon -> [DataCon] +-- It's convenient for tyConDataCons to return the +-- empty list for type synonyms etc +tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] + +-- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' +-- is the sort that can have any constructors (note: this does not include +-- abstract algebraic types) +tyConDataCons_maybe :: TyCon -> Maybe [DataCon] +tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs}) + = case rhs of + DataTyCon { data_cons = cons } -> Just cons + NewTyCon { data_con = con } -> Just [con] + TupleTyCon { data_con = con } -> Just [con] + SumTyCon { data_cons = cons } -> Just cons + _ -> Nothing +tyConDataCons_maybe _ = Nothing + +-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ +-- type with one alternative, a tuple type or a @newtype@ then that constructor +-- is returned. If the 'TyCon' has more than one constructor, or represents a +-- primitive or function type constructor then @Nothing@ is returned. In any +-- other case, the function panics +tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon +tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = [c] } -> Just c + TupleTyCon { data_con = c } -> Just c + NewTyCon { data_con = c } -> Just c + _ -> Nothing +tyConSingleDataCon_maybe _ = Nothing + +tyConSingleDataCon :: TyCon -> DataCon +tyConSingleDataCon tc + = case tyConSingleDataCon_maybe tc of + Just c -> c + Nothing -> pprPanic "tyConDataCon" (ppr tc) + +tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon +-- Returns (Just con) for single-constructor +-- *algebraic* data types *not* newtypes +tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = [c] } -> Just c + TupleTyCon { data_con = c } -> Just c + _ -> Nothing +tyConSingleAlgDataCon_maybe _ = Nothing + +-- | Determine the number of value constructors a 'TyCon' has. Panics if the +-- 'TyCon' is not algebraic or a tuple +tyConFamilySize :: TyCon -> Int +tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons_size = size } -> size + NewTyCon {} -> 1 + TupleTyCon {} -> 1 + SumTyCon { data_cons_size = size } -> size + _ -> pprPanic "tyConFamilySize 1" (ppr tc) +tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc) + +-- | Extract an 'AlgTyConRhs' with information about data constructors from an +-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' +algTyConRhs :: TyCon -> AlgTyConRhs +algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs +algTyConRhs other = pprPanic "algTyConRhs" (ppr other) + +-- | Extract type variable naming the result of injective type family +tyConFamilyResVar_maybe :: TyCon -> Maybe Name +tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res +tyConFamilyResVar_maybe _ = Nothing + +-- | Get the list of roles for the type parameters of a TyCon +tyConRoles :: TyCon -> [Role] +-- See also Note [TyCon Role signatures] +tyConRoles tc + = case tc of + { FunTyCon {} -> [Nominal, Nominal, Representational, Representational] + ; AlgTyCon { tcRoles = roles } -> roles + ; SynonymTyCon { tcRoles = roles } -> roles + ; FamilyTyCon {} -> const_role Nominal + ; PrimTyCon { tcRoles = roles } -> roles + ; PromotedDataCon { tcRoles = roles } -> roles + ; TcTyCon {} -> const_role Nominal + } + where + const_role r = replicate (tyConArity tc) r + +-- | Extract the bound type variables and type expansion of a type synonym +-- 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConRhs :: TyCon -> ([TyVar], Type) +newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) + = (tvs, rhs) +newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) + +-- | The number of type parameters that need to be passed to a newtype to +-- resolve it. May be less than in the definition if it can be eta-contracted. +newTyConEtadArity :: TyCon -> Int +newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) + = length (fst tvs_rhs) +newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon) + +-- | Extract the bound type variables and type expansion of an eta-contracted +-- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConEtadRhs :: TyCon -> ([TyVar], Type) +newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs +newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) + +-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to +-- construct something with the @newtype@s type from its representation type +-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns +-- @Nothing@ +newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co +newTyConCo_maybe _ = Nothing + +newTyConCo :: TyCon -> CoAxiom Unbranched +newTyConCo tc = case newTyConCo_maybe tc of + Just co -> co + Nothing -> pprPanic "newTyConCo" (ppr tc) + +newTyConDataCon_maybe :: TyCon -> Maybe DataCon +newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con +newTyConDataCon_maybe _ = Nothing + +-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context +-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration +-- @data Eq a => T a ...@ +tyConStupidTheta :: TyCon -> [PredType] +tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid +tyConStupidTheta (FunTyCon {}) = [] +tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) + +-- | Extract the 'TyVar's bound by a vanilla type synonym +-- and the corresponding (unsubstituted) right hand side. +synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) +synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty}) + = Just (tyvars, ty) +synTyConDefn_maybe _ = Nothing + +-- | Extract the information pertaining to the right hand side of a type synonym +-- (@type@) declaration. +synTyConRhs_maybe :: TyCon -> Maybe Type +synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs +synTyConRhs_maybe _ = Nothing + +-- | Extract the flavour of a type family (with all the extra information that +-- it carries) +famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav +famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav +famTyConFlav_maybe _ = Nothing + +-- | Is this 'TyCon' that for a class instance? +isClassTyCon :: TyCon -> Bool +isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True +isClassTyCon _ = False + +-- | If this 'TyCon' is that for a class instance, return the class it is for. +-- Otherwise returns @Nothing@ +tyConClass_maybe :: TyCon -> Maybe Class +tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas +tyConClass_maybe _ = Nothing + +-- | Return the associated types of the 'TyCon', if any +tyConATs :: TyCon -> [TyCon] +tyConATs (AlgTyCon {algTcParent = ClassTyCon clas _}) = classATs clas +tyConATs _ = [] + +---------------------------------------------------------------------------- +-- | Is this 'TyCon' that for a data family instance? +isFamInstTyCon :: TyCon -> Bool +isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} }) + = True +isFamInstTyCon _ = False + +tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) +tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts }) + = Just (f, ts, ax) +tyConFamInstSig_maybe _ = Nothing + +-- | If this 'TyCon' is that of a data family instance, return the family in question +-- and the instance types. Otherwise, return @Nothing@ +tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) +tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts }) + = Just (f, ts) +tyConFamInst_maybe _ = Nothing + +-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which +-- represents a coercion identifying the representation type with the type +-- instance family. Otherwise, return @Nothing@ +tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ }) + = Just ax +tyConFamilyCoercion_maybe _ = Nothing + +-- | Extract any 'RuntimeRepInfo' from this TyCon +tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo +tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri +tyConRuntimeRepInfo _ = NoRRI + -- could panic in that second case. But Douglas Adams told me not to. + +{- +Note [Constructor tag allocation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking we need to allocate constructor tags to constructors. +They are allocated based on the position in the data_cons field of TyCon, +with the first constructor getting fIRST_TAG. + +We used to pay linear cost per constructor, with each constructor looking up +its relative index in the constructor list. That was quadratic and prohibitive +for large data types with more than 10k constructors. + +The current strategy is to build a NameEnv with a mapping from constructor's +Name to ConTag and pass it down to buildDataCon for efficient lookup. + +Relevant ticket: #14657 +-} + +mkTyConTagMap :: TyCon -> NameEnv ConTag +mkTyConTagMap tycon = + mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..] + -- See Note [Constructor tag allocation] + +{- +************************************************************************ +* * +\subsection[TyCon-instances]{Instance declarations for @TyCon@} +* * +************************************************************************ + +@TyCon@s are compared by comparing their @Unique@s. +-} + +instance Eq TyCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable TyCon where + getUnique tc = tyConUnique tc + +instance Outputable TyCon where + -- At the moment a promoted TyCon has the same Name as its + -- corresponding TyCon, so we add the quote to distinguish it here + ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc + where + pp_tc = getPprStyle $ \sty -> if ((debugStyle sty || dumpStyle sty) && isTcTyCon tc) + then text "[tc]" + else empty + +-- | Paints a picture of what a 'TyCon' represents, in broad strokes. +-- This is used towards more informative error messages. +data TyConFlavour + = ClassFlavour + | TupleFlavour Boxity + | SumFlavour + | DataTypeFlavour + | NewtypeFlavour + | AbstractTypeFlavour + | DataFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) + | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) + | ClosedTypeFamilyFlavour + | TypeSynonymFlavour + | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. + | PromotedDataConFlavour + deriving Eq + +instance Outputable TyConFlavour where + ppr = text . go + where + go ClassFlavour = "class" + go (TupleFlavour boxed) | isBoxed boxed = "tuple" + | otherwise = "unboxed tuple" + go SumFlavour = "unboxed sum" + go DataTypeFlavour = "data type" + go NewtypeFlavour = "newtype" + go AbstractTypeFlavour = "abstract type" + go (DataFamilyFlavour (Just _)) = "associated data family" + go (DataFamilyFlavour Nothing) = "data family" + go (OpenTypeFamilyFlavour (Just _)) = "associated type family" + go (OpenTypeFamilyFlavour Nothing) = "type family" + go ClosedTypeFamilyFlavour = "type family" + go TypeSynonymFlavour = "type synonym" + go BuiltInTypeFlavour = "built-in type" + go PromotedDataConFlavour = "promoted data constructor" + +tyConFlavour :: TyCon -> TyConFlavour +tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) + | ClassTyCon _ _ <- parent = ClassFlavour + | otherwise = case rhs of + TupleTyCon { tup_sort = sort } + -> TupleFlavour (tupleSortBoxity sort) + SumTyCon {} -> SumFlavour + DataTyCon {} -> DataTypeFlavour + NewTyCon {} -> NewtypeFlavour + AbstractTyCon {} -> AbstractTypeFlavour +tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent }) + = case flav of + DataFamilyTyCon{} -> DataFamilyFlavour parent + OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent + ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour + AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour + BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour +tyConFlavour (SynonymTyCon {}) = TypeSynonymFlavour +tyConFlavour (FunTyCon {}) = BuiltInTypeFlavour +tyConFlavour (PrimTyCon {}) = BuiltInTypeFlavour +tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour +tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav + +-- | Can this flavour of 'TyCon' appear unsaturated? +tcFlavourMustBeSaturated :: TyConFlavour -> Bool +tcFlavourMustBeSaturated ClassFlavour = False +tcFlavourMustBeSaturated DataTypeFlavour = False +tcFlavourMustBeSaturated NewtypeFlavour = False +tcFlavourMustBeSaturated DataFamilyFlavour{} = False +tcFlavourMustBeSaturated TupleFlavour{} = False +tcFlavourMustBeSaturated SumFlavour = False +tcFlavourMustBeSaturated AbstractTypeFlavour = False +tcFlavourMustBeSaturated BuiltInTypeFlavour = False +tcFlavourMustBeSaturated PromotedDataConFlavour = False +tcFlavourMustBeSaturated TypeSynonymFlavour = True +tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True +tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True + +-- | Is this flavour of 'TyCon' an open type family or a data family? +tcFlavourIsOpen :: TyConFlavour -> Bool +tcFlavourIsOpen DataFamilyFlavour{} = True +tcFlavourIsOpen OpenTypeFamilyFlavour{} = True +tcFlavourIsOpen ClosedTypeFamilyFlavour = False +tcFlavourIsOpen ClassFlavour = False +tcFlavourIsOpen DataTypeFlavour = False +tcFlavourIsOpen NewtypeFlavour = False +tcFlavourIsOpen TupleFlavour{} = False +tcFlavourIsOpen SumFlavour = False +tcFlavourIsOpen AbstractTypeFlavour = False +tcFlavourIsOpen BuiltInTypeFlavour = False +tcFlavourIsOpen PromotedDataConFlavour = False +tcFlavourIsOpen TypeSynonymFlavour = False + +pprPromotionQuote :: TyCon -> SDoc +-- Promoted data constructors already have a tick in their OccName +pprPromotionQuote tc + = case tc of + PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types + _ -> empty + +instance NamedThing TyCon where + getName = tyConName + +instance Data.Data TyCon where + -- don't traverse? + toConstr _ = abstractConstr "TyCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "TyCon" + +instance Binary Injectivity where + put_ bh NotInjective = putByte bh 0 + put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs + + get bh = do { h <- getByte bh + ; case h of + 0 -> return NotInjective + _ -> do { xs <- get bh + ; return (Injective xs) } } + +{- +************************************************************************ +* * + Walking over recursive TyCons +* * +************************************************************************ + +Note [Expanding newtypes and products] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When expanding a type to expose a data-type constructor, we need to be +careful about newtypes, lest we fall into an infinite loop. Here are +the key examples: + + newtype Id x = MkId x + newtype Fix f = MkFix (f (Fix f)) + newtype T = MkT (T -> T) + + Type Expansion + -------------------------- + T T -> T + Fix Maybe Maybe (Fix Maybe) + Id (Id Int) Int + Fix Id NO NO NO + +Notice that + * We can expand T, even though it's recursive. + * We can expand Id (Id Int), even though the Id shows up + twice at the outer level, because Id is non-recursive + +So, when expanding, we keep track of when we've seen a recursive +newtype at outermost level; and bail out if we see it again. + +We sometimes want to do the same for product types, so that the +strictness analyser doesn't unbox infinitely deeply. + +More precisely, we keep a *count* of how many times we've seen it. +This is to account for + data instance T (a,b) = MkT (T a) (T b) +Then (#10482) if we have a type like + T (Int,(Int,(Int,(Int,Int)))) +we can still unbox deeply enough during strictness analysis. +We have to treat T as potentially recursive, but it's still +good to be able to unwrap multiple layers. + +The function that manages all this is checkRecTc. +-} + +data RecTcChecker = RC !Int (NameEnv Int) + -- The upper bound, and the number of times + -- we have encountered each TyCon + +-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'. +initRecTc :: RecTcChecker +initRecTc = RC defaultRecTcMaxBound emptyNameEnv + +-- | The default upper bound (100) for the number of times a 'RecTcChecker' is +-- allowed to encounter each 'TyCon'. +defaultRecTcMaxBound :: Int +defaultRecTcMaxBound = 100 +-- Should we have a flag for this? + +-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed +-- to encounter each 'TyCon'. +setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker +setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts + +checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker +-- Nothing => Recursion detected +-- Just rec_tcs => Keep going +checkRecTc (RC bound rec_nts) tc + = case lookupNameEnv rec_nts tc_name of + Just n | n >= bound -> Nothing + | otherwise -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1))) + Nothing -> Just (RC bound (extendNameEnv rec_nts tc_name 1)) + where + tc_name = tyConName tc + +-- | Returns whether or not this 'TyCon' is definite, or a hole +-- that may be filled in at some later point. See Note [Skolem abstract data] +tyConSkolem :: TyCon -> Bool +tyConSkolem = isHoleName . tyConName + +-- Note [Skolem abstract data] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Skolem abstract data arises from data declarations in an hsig file. +-- +-- The best analogy is to interpret the types declared in signature files as +-- elaborating to universally quantified type variables; e.g., +-- +-- unit p where +-- signature H where +-- data T +-- data S +-- module M where +-- import H +-- f :: (T ~ S) => a -> b +-- f x = x +-- +-- elaborates as (with some fake structural types): +-- +-- p :: forall t s. { f :: forall a b. t ~ s => a -> b } +-- p = { f = \x -> x } -- ill-typed +-- +-- It is clear that inside p, t ~ s is not provable (and +-- if we tried to write a function to cast t to s, that +-- would not work), but if we call p @Int @Int, clearly Int ~ Int +-- is provable. The skolem variables are all distinct from +-- one another, but we can't make assumptions like "f is +-- inaccessible", because the skolem variables will get +-- instantiated eventually! +-- +-- Skolem abstractness can apply to "non-abstract" data as well): +-- +-- unit p where +-- signature H1 where +-- data T = MkT +-- signature H2 where +-- data T = MkT +-- module M where +-- import qualified H1 +-- import qualified H2 +-- f :: (H1.T ~ H2.T) => a -> b +-- f x = x +-- +-- This is why the test is on the original name of the TyCon, +-- not whether it is abstract or not. diff --git a/compiler/GHC/Core/TyCon.hs-boot b/compiler/GHC/Core/TyCon.hs-boot new file mode 100644 index 0000000000..84df99b0a9 --- /dev/null +++ b/compiler/GHC/Core/TyCon.hs-boot @@ -0,0 +1,9 @@ +module GHC.Core.TyCon where + +import GhcPrelude + +data TyCon + +isTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon :: TyCon -> Bool +isFunTyCon :: TyCon -> Bool diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs new file mode 100644 index 0000000000..cab22230aa --- /dev/null +++ b/compiler/GHC/Core/Type.hs @@ -0,0 +1,3221 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1998 +-- +-- Type - public interface + +{-# LANGUAGE CPP, FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Main functions for manipulating types and type-related things +module GHC.Core.Type ( + -- Note some of this is just re-exports from TyCon.. + + -- * Main data types representing Types + -- $type_classification + + -- $representation_types + TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), + KindOrType, PredType, ThetaType, + Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, + KnotTied, + + -- ** Constructing and deconstructing types + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, + getCastedTyVar_maybe, tyVarKind, varType, + + mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, + splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, + + mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, + splitFunTy, splitFunTy_maybe, + splitFunTys, funResultTy, funArgTy, + + mkTyConApp, mkTyConTy, + tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, + tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, + splitTyConApp_maybe, splitTyConApp, tyConAppArgN, + tcSplitTyConApp_maybe, + splitListTyConApp_maybe, + repSplitTyConApp_maybe, + + mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, + mkSpecForAllTy, mkSpecForAllTys, + mkVisForAllTys, mkTyCoInvForAllTy, + mkInvForAllTy, mkInvForAllTys, + splitForAllTys, splitForAllTysSameVis, + splitForAllVarBndrs, + splitForAllTy_maybe, splitForAllTy, + splitForAllTy_ty_maybe, splitForAllTy_co_maybe, + splitPiTy_maybe, splitPiTy, splitPiTys, + mkTyConBindersPreferAnon, + mkPiTy, mkPiTys, + mkLamType, mkLamTypes, + piResultTy, piResultTys, + applyTysX, dropForAlls, + mkFamilyTyConApp, + buildSynTyCon, + + mkNumLitTy, isNumLitTy, + mkStrLitTy, isStrLitTy, + isLitTy, + + isPredTy, + + getRuntimeRep_maybe, kindRep_maybe, kindRep, + + mkCastTy, mkCoercionTy, splitCastTy_maybe, + discardCast, + + userTypeError_maybe, pprUserTypeErrorTy, + + coAxNthLHS, + stripCoercionTy, + + splitPiTysInvisible, splitPiTysInvisibleN, + invisibleTyBndrCount, + filterOutInvisibleTypes, filterOutInferredTypes, + partitionInvisibleTypes, partitionInvisibles, + tyConArgFlags, appTyArgFlags, + synTyConResKind, + + modifyJoinResTy, setJoinResTy, + + -- ** Analyzing types + TyCoMapper(..), mapType, mapCoercion, + TyCoFolder(..), foldTyCo, + + -- (Newtypes) + newTyConInstRhs, + + -- ** Binders + sameVis, + mkTyCoVarBinder, mkTyCoVarBinders, + mkTyVarBinders, + mkAnonBinder, + isAnonTyCoBinder, + binderVar, binderVars, binderType, binderArgFlag, + tyCoBinderType, tyCoBinderVar_maybe, + tyBinderType, + binderRelevantType_maybe, + isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, + isInvisibleBinder, isNamedBinder, + tyConBindersTyCoBinders, + + -- ** Common type constructors + funTyCon, + + -- ** Predicates on types + isTyVarTy, isFunTy, isCoercionTy, + isCoercionTy_maybe, isForAllTy, + isForAllTy_ty, isForAllTy_co, + isPiTy, isTauTy, isFamFreeTy, + isCoVarType, + + isValidJoinPointType, + tyConAppNeedsKindSig, + + -- *** Levity and boxity + isLiftedType_maybe, + isLiftedTypeKind, isUnliftedTypeKind, + isLiftedRuntimeRep, isUnliftedRuntimeRep, + isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType, + isAlgType, isDataFamilyAppType, + isPrimitiveType, isStrictType, + isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, + dropRuntimeRepArgs, + getRuntimeRep, + + -- * Main data types representing Kinds + Kind, + + -- ** Finding the kind of a type + typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly, + tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind, + tcIsRuntimeTypeKind, + + -- ** Common Kind + liftedTypeKind, + + -- * Type free variables + tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoVarsOfType, tyCoVarsOfTypes, + tyCoVarsOfTypeDSet, + coVarsOfType, + coVarsOfTypes, + + noFreeVarsOfType, + splitVisVarsOfType, splitVisVarsOfTypes, + expandTypeSynonyms, + typeSize, occCheckExpand, + + -- ** Closing over kinds + closeOverKindsDSet, closeOverKindsList, + closeOverKinds, + + -- * Well-scoped lists of variables + scopedSort, tyCoVarsOfTypeWellScoped, + tyCoVarsOfTypesWellScoped, + + -- * Type comparison + eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, + nonDetCmpTypesX, nonDetCmpTc, + eqVarBndrs, + + -- * Forcing evaluation of types + seqType, seqTypes, + + -- * Other views onto Types + coreView, tcView, + + tyConsOfType, + + -- * Main type substitution data types + TvSubstEnv, -- Representation widely visible + TCvSubst(..), -- Representation visible to a few friends + + -- ** Manipulating type substitutions + emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, + + mkTCvSubst, zipTvSubst, mkTvSubstPrs, + zipTCvSubst, + notElemTCvSubst, + getTvSubstEnv, setTvSubstEnv, + zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs, + extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + extendTCvSubst, extendCvSubst, + extendTvSubst, extendTvSubstBinderAndInScope, + extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + extendTvSubstWithClone, + extendTCvSubstWithClone, + isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, + isEmptyTCvSubst, unionTCvSubst, + + -- ** Performing substitution on types and kinds + substTy, substTys, substTyWith, substTysWith, substTheta, + substTyAddInScope, + substTyUnchecked, substTysUnchecked, substThetaUnchecked, + substTyWithUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, + substVarBndr, substVarBndrs, + cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, + + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, + tidyOpenTyCoVar, tidyOpenTyCoVars, + tidyTyCoVarOcc, + tidyTopType, + tidyKind, + tidyTyCoVarBinder, tidyTyCoVarBinders, + + -- * Kinds + isConstraintKindCon, + classifiesTypeWithValues, + isKindLevPoly + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import BasicTypes + +-- We import the representation and primitive functions from GHC.Core.TyCo.Rep. +-- Many things are reexported, but not the representation! + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Tidy +import GHC.Core.TyCo.FVs + +-- friends: +import Var +import VarEnv +import VarSet +import UniqSet + +import GHC.Core.TyCon +import TysPrim +import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind + , typeSymbolKind, liftedTypeKind + , liftedTypeKindTyCon + , constraintKind ) +import Name( Name ) +import PrelNames +import GHC.Core.Coercion.Axiom +import {-# SOURCE #-} GHC.Core.Coercion + ( mkNomReflCo, mkGReflCo, mkReflCo + , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo + , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo + , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo + , mkKindCo, mkSubCo, mkFunCo, mkAxiomInstCo + , decomposePiCos, coercionKind, coercionLKind + , coercionRKind, coercionType + , isReflexiveCo, seqCo ) + +-- others +import Util +import FV +import Outputable +import FastString +import Pair +import ListSetOps +import Unique ( nonDetCmpUnique ) + +import Maybes ( orElse ) +import Data.Maybe ( isJust ) +import Control.Monad ( guard ) + +-- $type_classification +-- #type_classification# +-- +-- Types are one of: +-- +-- [Unboxed] Iff its representation is other than a pointer +-- Unboxed types are also unlifted. +-- +-- [Lifted] Iff it has bottom as an element. +-- Closures always have lifted types: i.e. any +-- let-bound identifier in Core must have a lifted +-- type. Operationally, a lifted object is one that +-- can be entered. +-- Only lifted types may be unified with a type variable. +-- +-- [Algebraic] Iff it is a type with one or more constructors, whether +-- declared with @data@ or @newtype@. +-- An algebraic type is one that can be deconstructed +-- with a case expression. This is /not/ the same as +-- lifted types, because we also include unboxed +-- tuples in this classification. +-- +-- [Data] Iff it is a type declared with @data@, or a boxed tuple. +-- +-- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. +-- +-- Currently, all primitive types are unlifted, but that's not necessarily +-- the case: for example, @Int@ could be primitive. +-- +-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed +-- but unlifted (such as @ByteArray#@). The only primitive types that we +-- classify as algebraic are the unboxed tuples. +-- +-- Some examples of type classifications that may make this a bit clearer are: +-- +-- @ +-- Type primitive boxed lifted algebraic +-- ----------------------------------------------------------------------------- +-- Int# Yes No No No +-- ByteArray# Yes Yes No No +-- (\# a, b \#) Yes No No Yes +-- (\# a | b \#) Yes No No Yes +-- ( a, b ) No Yes Yes Yes +-- [a] No Yes Yes Yes +-- @ + +-- $representation_types +-- A /source type/ is a type that is a separate type as far as the type checker is +-- concerned, but which has a more low-level representation as far as Core-to-Core +-- passes and the rest of the back end is concerned. +-- +-- You don't normally have to worry about this, as the utility functions in +-- this module will automatically convert a source into a representation type +-- if they are spotted, to the best of its abilities. If you don't want this +-- to happen, use the equivalent functions from the "TcType" module. + +{- +************************************************************************ +* * + Type representation +* * +************************************************************************ + +Note [coreView vs tcView] +~~~~~~~~~~~~~~~~~~~~~~~~~ +So far as the typechecker is concerned, 'Constraint' and 'TYPE +LiftedRep' are distinct kinds. + +But in Core these two are treated as identical. + +We implement this by making 'coreView' convert 'Constraint' to 'TYPE +LiftedRep' on the fly. The function tcView (used in the type checker) +does not do this. + +See also #11715, which tracks removing this inconsistency. + +-} + +-- | Gives the typechecker view of a type. This unwraps synonyms but +-- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into +-- TYPE LiftedRep. Returns Nothing if no unwrapping happens. +-- See also Note [coreView vs tcView] +{-# INLINE tcView #-} +tcView :: Type -> Maybe Type +tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + -- The free vars of 'rhs' should all be bound by 'tenv', so it's + -- ok to use 'substTy' here. + -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. + -- Its important to use mkAppTys, rather than (foldl AppTy), + -- because the function part might well return a + -- partially-applied type constructor; indeed, usually will! +tcView _ = Nothing + +{-# INLINE coreView #-} +coreView :: Type -> Maybe Type +-- ^ This function Strips off the /top layer only/ of a type synonym +-- application (if any) its underlying representation type. +-- Returns Nothing if there is nothing to look through. +-- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@. +-- +-- By being non-recursive and inlined, this case analysis gets efficiently +-- joined onto the case analysis that the caller is already doing +coreView ty@(TyConApp tc tys) + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + -- This equation is exactly like tcView + + -- At the Core level, Constraint = Type + -- See Note [coreView vs tcView] + | isConstraintKindCon tc + = ASSERT2( null tys, ppr ty ) + Just liftedTypeKind + +coreView _ = Nothing + +----------------------------------------------- +expandTypeSynonyms :: Type -> Type +-- ^ Expand out all type synonyms. Actually, it'd suffice to expand out +-- just the ones that discard type variables (e.g. type Funny a = Int) +-- But we don't know which those are currently, so we just expand all. +-- +-- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, +-- not in the kinds of any TyCon or TyVar mentioned in the type. +-- +-- Keep this synchronized with 'synonymTyConsOfType' +expandTypeSynonyms ty + = go (mkEmptyTCvSubst in_scope) ty + where + in_scope = mkInScopeSet (tyCoVarsOfType ty) + + go subst (TyConApp tc tys) + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys + = let subst' = mkTvSubst in_scope (mkVarEnv tenv) + -- Make a fresh substitution; rhs has nothing to + -- do with anything that has happened so far + -- NB: if you make changes here, be sure to build an + -- /idempotent/ substitution, even in the nested case + -- type T a b = a -> b + -- type S x y = T y x + -- (#11665) + in mkAppTys (go subst' rhs) tys' + | otherwise + = TyConApp tc expanded_tys + where + expanded_tys = (map (go subst) tys) + + go _ (LitTy l) = LitTy l + go subst (TyVarTy tv) = substTyVar subst tv + go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) + go subst ty@(FunTy _ arg res) + = ty { ft_arg = go subst arg, ft_res = go subst res } + go subst (ForAllTy (Bndr tv vis) t) + = let (subst', tv') = substVarBndrUsing go subst tv in + ForAllTy (Bndr tv' vis) (go subst' t) + go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) + go subst (CoercionTy co) = mkCoercionTy (go_co subst co) + + go_mco _ MRefl = MRefl + go_mco subst (MCo co) = MCo (go_co subst co) + + go_co subst (Refl ty) + = mkNomReflCo (go subst ty) + go_co subst (GRefl r ty mco) + = mkGReflCo r (go subst ty) (go_mco subst mco) + -- NB: coercions are always expanded upon creation + go_co subst (TyConAppCo r tc args) + = mkTyConAppCo r tc (map (go_co subst) args) + go_co subst (AppCo co arg) + = mkAppCo (go_co subst co) (go_co subst arg) + go_co subst (ForAllCo tv kind_co co) + = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in + mkForAllCo tv' kind_co' (go_co subst' co) + go_co subst (FunCo r co1 co2) + = mkFunCo r (go_co subst co1) (go_co subst co2) + go_co subst (CoVarCo cv) + = substCoVar subst cv + go_co subst (AxiomInstCo ax ind args) + = mkAxiomInstCo ax ind (map (go_co subst) args) + go_co subst (UnivCo p r t1 t2) + = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) + go_co subst (SymCo co) + = mkSymCo (go_co subst co) + go_co subst (TransCo co1 co2) + = mkTransCo (go_co subst co1) (go_co subst co2) + go_co subst (NthCo r n co) + = mkNthCo r n (go_co subst co) + go_co subst (LRCo lr co) + = mkLRCo lr (go_co subst co) + go_co subst (InstCo co arg) + = mkInstCo (go_co subst co) (go_co subst arg) + go_co subst (KindCo co) + = mkKindCo (go_co subst co) + go_co subst (SubCo co) + = mkSubCo (go_co subst co) + go_co subst (AxiomRuleCo ax cs) + = AxiomRuleCo ax (map (go_co subst) cs) + go_co _ (HoleCo h) + = pprPanic "expandTypeSynonyms hit a hole" (ppr h) + + go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) + go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) + go_prov _ p@(PluginProv _) = p + + -- the "False" and "const" are to accommodate the type of + -- substForAllCoBndrUsing, which is general enough to + -- handle coercion optimization (which sometimes swaps the + -- order of a coercion) + go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst + + +-- | Extract the RuntimeRep classifier of a type from its kind. For example, +-- @kindRep * = LiftedRep@; Panics if this is not possible. +-- Treats * and Constraint as the same +kindRep :: HasDebugCallStack => Kind -> Type +kindRep k = case kindRep_maybe k of + Just r -> r + Nothing -> pprPanic "kindRep" (ppr k) + +-- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. +-- For example, @kindRep_maybe * = Just LiftedRep@ +-- Returns 'Nothing' if the kind is not of form (TYPE rr) +-- Treats * and Constraint as the same +kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type +kindRep_maybe kind + | Just kind' <- coreView kind = kindRep_maybe kind' + | TyConApp tc [arg] <- kind + , tc `hasKey` tYPETyConKey = Just arg + | otherwise = Nothing + +-- | This version considers Constraint to be the same as *. Returns True +-- if the argument is equivalent to Type/Constraint and False otherwise. +-- See Note [Kind Constraint and kind Type] +isLiftedTypeKind :: Kind -> Bool +isLiftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isLiftedRuntimeRep rep + Nothing -> False + +isLiftedRuntimeRep :: Type -> Bool +-- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep +-- False of type variables (a :: RuntimeRep) +-- and of other reps e.g. (IntRep :: RuntimeRep) +isLiftedRuntimeRep rep + | Just rep' <- coreView rep = isLiftedRuntimeRep rep' + | TyConApp rr_tc args <- rep + , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True + | otherwise = False + +-- | Returns True if the kind classifies unlifted types and False otherwise. +-- Note that this returns False for levity-polymorphic kinds, which may +-- be specialized to a kind that classifies unlifted types. +isUnliftedTypeKind :: Kind -> Bool +isUnliftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isUnliftedRuntimeRep rep + Nothing -> False + +isUnliftedRuntimeRep :: Type -> Bool +-- True of definitely-unlifted RuntimeReps +-- False of (LiftedRep :: RuntimeRep) +-- and of variables (a :: RuntimeRep) +isUnliftedRuntimeRep rep + | Just rep' <- coreView rep = isUnliftedRuntimeRep rep' + | TyConApp rr_tc _ <- rep -- NB: args might be non-empty + -- e.g. TupleRep [r1, .., rn] + = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) + -- Avoid searching all the unlifted RuntimeRep type cons + -- In the RuntimeRep data type, only LiftedRep is lifted + -- But be careful of type families (F tys) :: RuntimeRep + | otherwise {- Variables, applications -} + = False + +-- | Is this the type 'RuntimeRep'? +isRuntimeRepTy :: Type -> Bool +isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' +isRuntimeRepTy (TyConApp tc args) + | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True +isRuntimeRepTy _ = False + +-- | Is a tyvar of type 'RuntimeRep'? +isRuntimeRepVar :: TyVar -> Bool +isRuntimeRepVar = isRuntimeRepTy . tyVarKind + + +{- ********************************************************************* +* * + mapType +* * +************************************************************************ + +These functions do a map-like operation over types, performing some operation +on all variables and binding sites. Primarily used for zonking. + +Note [Efficiency for mapCoercion ForAllCo case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As noted in Note [Forall coercions] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant. +It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches +the left-hand kind of the coercion. This is convenient lots of the time, but +not when mapping a function over a coercion. + +The problem is that tcm_tybinder will affect the TyCoVar's kind and +mapCoercion will affect the Coercion, and we hope that the results will be +the same. Even if they are the same (which should generally happen with +correct algorithms), then there is an efficiency issue. In particular, +this problem seems to make what should be a linear algorithm into a potentially +exponential one. But it's only going to be bad in the case where there's +lots of foralls in the kinds of other foralls. Like this: + + forall a : (forall b : (forall c : ...). ...). ... + +This construction seems unlikely. So we'll do the inefficient, easy way +for now. + +Note [Specialising mappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These INLINABLE pragmas are indispensable. mapType/mapCoercion are used +to implement zonking, and it's vital that they get specialised to the TcM +monad. This specialisation happens automatically (that is, without a +SPECIALISE pragma) as long as the definitions are INLINABLE. For example, +this one change made a 20% allocation difference in perf/compiler/T5030. + +-} + +-- | This describes how a "map" operation over a type/coercion should behave +data TyCoMapper env m + = TyCoMapper + { tcm_tyvar :: env -> TyVar -> m Type + , tcm_covar :: env -> CoVar -> m Coercion + , tcm_hole :: env -> CoercionHole -> m Coercion + -- ^ What to do with coercion holes. + -- See Note [Coercion holes] in GHC.Core.TyCo.Rep. + + , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar) + -- ^ The returned env is used in the extended scope + + , tcm_tycon :: TyCon -> m TyCon + -- ^ This is used only for TcTyCons + -- a) To zonk TcTyCons + -- b) To turn TcTyCons into TyCons. + -- See Note [Type checking recursive type and class declarations] + -- in TcTyClsDecls + } + +{-# INLINABLE mapType #-} -- See Note [Specialising mappers] +mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type +mapType mapper@(TyCoMapper { tcm_tyvar = tyvar + , tcm_tycobinder = tycobinder + , tcm_tycon = tycon }) + env ty + = go ty + where + go (TyVarTy tv) = tyvar env tv + go (AppTy t1 t2) = mkAppTy <$> go t1 <*> go t2 + go ty@(LitTy {}) = return ty + go (CastTy ty co) = mkCastTy <$> go ty <*> mapCoercion mapper env co + go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co + + go ty@(FunTy _ arg res) + = do { arg' <- go arg; res' <- go res + ; return (ty { ft_arg = arg', ft_res = res' }) } + + go ty@(TyConApp tc tys) + | isTcTyCon tc + = do { tc' <- tycon tc + ; mkTyConApp tc' <$> mapM go tys } + + -- Not a TcTyCon + | null tys -- Avoid allocation in this very + = return ty -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConApp tc <$> mapM go tys + + go (ForAllTy (Bndr tv vis) inner) + = do { (env', tv') <- tycobinder env tv vis + ; inner' <- mapType mapper env' inner + ; return $ ForAllTy (Bndr tv' vis) inner' } + +{-# INLINABLE mapCoercion #-} -- See Note [Specialising mappers] +mapCoercion :: Monad m + => TyCoMapper env m -> env -> Coercion -> m Coercion +mapCoercion mapper@(TyCoMapper { tcm_covar = covar + , tcm_hole = cohole + , tcm_tycobinder = tycobinder + , tcm_tycon = tycon }) + env co + = go co + where + go_mco MRefl = return MRefl + go_mco (MCo co) = MCo <$> (go co) + + go (Refl ty) = Refl <$> mapType mapper env ty + go (GRefl r ty mco) = mkGReflCo r <$> mapType mapper env ty <*> (go_mco mco) + go (TyConAppCo r tc args) + = do { tc' <- if isTcTyCon tc + then tycon tc + else return tc + ; mkTyConAppCo r tc' <$> mapM go args } + go (AppCo c1 c2) = mkAppCo <$> go c1 <*> go c2 + go (ForAllCo tv kind_co co) + = do { kind_co' <- go kind_co + ; (env', tv') <- tycobinder env tv Inferred + ; co' <- mapCoercion mapper env' co + ; return $ mkForAllCo tv' kind_co' co' } + -- See Note [Efficiency for mapCoercion ForAllCo case] + go (FunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 + go (CoVarCo cv) = covar env cv + go (AxiomInstCo ax i args) + = mkAxiomInstCo ax i <$> mapM go args + go (HoleCo hole) = cohole env hole + go (UnivCo p r t1 t2) + = mkUnivCo <$> go_prov p <*> pure r + <*> mapType mapper env t1 <*> mapType mapper env t2 + go (SymCo co) = mkSymCo <$> go co + go (TransCo c1 c2) = mkTransCo <$> go c1 <*> go c2 + go (AxiomRuleCo r cos) = AxiomRuleCo r <$> mapM go cos + go (NthCo r i co) = mkNthCo r i <$> go co + go (LRCo lr co) = mkLRCo lr <$> go co + go (InstCo co arg) = mkInstCo <$> go co <*> go arg + go (KindCo co) = mkKindCo <$> go co + go (SubCo co) = mkSubCo <$> go co + + go_prov (PhantomProv co) = PhantomProv <$> go co + go_prov (ProofIrrelProv co) = ProofIrrelProv <$> go co + go_prov p@(PluginProv _) = return p + + +{- +************************************************************************ +* * +\subsection{Constructor-specific functions} +* * +************************************************************************ + + +--------------------------------------------------------------------- + TyVarTy + ~~~~~~~ +-} + +-- | 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 :: String -> Type -> TyVar +getTyVar msg ty = case getTyVar_maybe ty of + Just tv -> tv + Nothing -> panic ("getTyVar: " ++ msg) + +isTyVarTy :: Type -> Bool +isTyVarTy ty = isJust (getTyVar_maybe ty) + +-- | Attempts to obtain the type variable underlying a 'Type' +getTyVar_maybe :: Type -> Maybe TyVar +getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' + | otherwise = repGetTyVar_maybe ty + +-- | If the type is a tyvar, possibly under a cast, returns it, along +-- with the coercion. Thus, the co is :: kind tv ~N kind ty +getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) +getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty' +getCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) +getCastedTyVar_maybe (TyVarTy tv) + = Just (tv, mkReflCo Nominal (tyVarKind tv)) +getCastedTyVar_maybe _ = Nothing + +-- | Attempts to obtain the type variable underlying a 'Type', without +-- any expansion +repGetTyVar_maybe :: Type -> Maybe TyVar +repGetTyVar_maybe (TyVarTy tv) = Just tv +repGetTyVar_maybe _ = Nothing + +{- +--------------------------------------------------------------------- + AppTy + ~~~~~ +We need to be pretty careful with AppTy to make sure we obey the +invariant that a TyConApp is always visibly so. mkAppTy maintains the +invariant: use it. + +Note [Decomposing fat arrow c=>t] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can we unify (a b) with (Eq a => ty)? If we do so, we end up with +a partial application like ((=>) Eq a) which doesn't make sense in +source Haskell. In contrast, we *can* unify (a b) with (t1 -> t2). +Here's an example (#9858) of how you might do it: + i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep + i p = typeRep p + + j = i (Proxy :: Proxy (Eq Int => Int)) +The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, +but suppose we want that. But then in the call to 'i', we end +up decomposing (Eq Int => Int), and we definitely don't want that. + +This really only applies to the type checker; in Core, '=>' and '->' +are the same, as are 'Constraint' and '*'. But for now I've put +the test in repSplitAppTy_maybe, which applies throughout, because +the other calls to splitAppTy are in GHC.Core.Unify, which is also used by +the type checker (e.g. when matching type-function equations). + +-} + +-- | Applies a type to another, as in e.g. @k a@ +mkAppTy :: Type -> Type -> Type + -- See Note [Respecting definitional equality], invariant (EQ1). +mkAppTy (CastTy fun_ty co) arg_ty + | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty] + = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co + +mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) +mkAppTy ty1 ty2 = AppTy ty1 ty2 + -- Note that the TyConApp could be an + -- under-saturated type synonym. GHC allows that; e.g. + -- type Foo k = k a -> k a + -- type Id x = x + -- foo :: Foo Id -> Foo Id + -- + -- Here Id is partially applied in the type sig for Foo, + -- but once the type synonyms are expanded all is well + -- + -- Moreover in TcHsTypes.tcInferApps we build up a type + -- (T t1 t2 t3) one argument at a type, thus forming + -- (T t1), (T t1 t2), etc + +mkAppTys :: Type -> [Type] -> Type +mkAppTys ty1 [] = ty1 +mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy + -- Why do this? See (EQ1) of + -- Note [Respecting definitional equality] + -- in GHC.Core.TyCo.Rep + = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers + where + (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys + (args_to_cast, leftovers) = splitAtList arg_cos arg_tys + casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos +mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) +mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2 + +------------- +splitAppTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempt to take a type application apart, whether it is a +-- function, type constructor, or plain type application. Note +-- that type family applications are NEVER unsaturated by this! +splitAppTy_maybe ty | Just ty' <- coreView ty + = splitAppTy_maybe ty' +splitAppTy_maybe ty = repSplitAppTy_maybe ty + +------------- +repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that +-- any Core view stuff is already done +repSplitAppTy_maybe (FunTy _ ty1 ty2) + = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + +repSplitAppTy_maybe (AppTy ty1 ty2) + = Just (ty1, ty2) + +repSplitAppTy_maybe (TyConApp tc tys) + | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! + +repSplitAppTy_maybe _other = Nothing + +-- This one doesn't break apart (c => t). +-- See Note [Decomposing fat arrow c=>t] +-- Defined here to avoid module loops between Unify and TcType. +tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that +-- any coreView stuff is already done. Refuses to look through (c => t) +tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 }) + | InvisArg <- af + = Nothing -- See Note [Decomposing fat arrow c=>t] + + | otherwise + = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + +tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +tcRepSplitAppTy_maybe (TyConApp tc tys) + | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! +tcRepSplitAppTy_maybe _other = Nothing + +------------- +splitAppTy :: Type -> (Type, Type) +-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', +-- and panics if this is not possible +splitAppTy ty = case splitAppTy_maybe ty of + Just pr -> pr + Nothing -> panic "splitAppTy" + +------------- +splitAppTys :: Type -> (Type, [Type]) +-- ^ Recursively splits a type as far as is possible, leaving a residual +-- type being applied to and the type arguments applied to it. Never fails, +-- even if that means returning an empty list of type applications. +splitAppTys ty = split ty ty [] + where + split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args + split _ (AppTy ty arg) args = split ty ty (arg:args) + split _ (TyConApp tc tc_args) args + = let -- keep type families saturated + n | mustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split _ (FunTy _ ty1 ty2) args + = ASSERT( null args ) + (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + + split orig_ty _ args = (orig_ty, args) + +-- | Like 'splitAppTys', but doesn't look through type synonyms +repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) +repSplitAppTys ty = split ty [] + where + split (AppTy ty arg) args = split ty (arg:args) + split (TyConApp tc tc_args) args + = let n | mustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split (FunTy _ ty1 ty2) args + = ASSERT( null args ) + (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + + split ty args = (ty, args) + +{- + LitTy + ~~~~~ +-} + +mkNumLitTy :: Integer -> Type +mkNumLitTy n = LitTy (NumTyLit n) + +-- | Is this a numeric literal. We also look through type synonyms. +isNumLitTy :: Type -> Maybe Integer +isNumLitTy ty | Just ty1 <- coreView ty = isNumLitTy ty1 +isNumLitTy (LitTy (NumTyLit n)) = Just n +isNumLitTy _ = Nothing + +mkStrLitTy :: FastString -> Type +mkStrLitTy s = LitTy (StrTyLit s) + +-- | Is this a symbol literal. We also look through type synonyms. +isStrLitTy :: Type -> Maybe FastString +isStrLitTy ty | Just ty1 <- coreView ty = isStrLitTy ty1 +isStrLitTy (LitTy (StrTyLit s)) = Just s +isStrLitTy _ = Nothing + +-- | Is this a type literal (symbol or numeric). +isLitTy :: Type -> Maybe TyLit +isLitTy ty | Just ty1 <- coreView ty = isLitTy ty1 +isLitTy (LitTy l) = Just l +isLitTy _ = Nothing + +-- | Is this type a custom user error? +-- If so, give us the kind and the error message. +userTypeError_maybe :: Type -> Maybe Type +userTypeError_maybe t + = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t + -- There may be more than 2 arguments, if the type error is + -- used as a type constructor (e.g. at kind `Type -> Type`). + + ; guard (tyConName tc == errorMessageTypeErrorFamName) + ; return msg } + +-- | Render a type corresponding to a user type error into a SDoc. +pprUserTypeErrorTy :: Type -> SDoc +pprUserTypeErrorTy ty = + case splitTyConApp_maybe ty of + + -- Text "Something" + Just (tc,[txt]) + | tyConName tc == typeErrorTextDataConName + , Just str <- isStrLitTy txt -> ftext str + + -- ShowType t + Just (tc,[_k,t]) + | tyConName tc == typeErrorShowTypeDataConName -> ppr t + + -- t1 :<>: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorAppendDataConName -> + pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 + + -- t1 :$$: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorVAppendDataConName -> + pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 + + -- An unevaluated type function + _ -> ppr ty + + + + +{- +--------------------------------------------------------------------- + FunTy + ~~~~~ + +Note [Representation of function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Functions (e.g. Int -> Char) can be thought of as being applications +of funTyCon (known in Haskell surface syntax as (->)), + + (->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b -> Type + +However, for efficiency's sake we represent saturated applications of (->) +with FunTy. For instance, the type, + + (->) r1 r2 a b + +is equivalent to, + + FunTy (Anon a) b + +Note how the RuntimeReps are implied in the FunTy representation. For this +reason we must be careful when recontructing the TyConApp representation (see, +for instance, splitTyConApp_maybe). + +In the compiler we maintain the invariant that all saturated applications of +(->) are represented with FunTy. + +See #11714. +-} + +splitFunTy :: Type -> (Type, Type) +-- ^ Attempts to extract the argument and result types from a type, and +-- panics if that is not possible. See also 'splitFunTy_maybe' +splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' +splitFunTy (FunTy _ arg res) = (arg, res) +splitFunTy other = pprPanic "splitFunTy" (ppr other) + +splitFunTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempts to extract the argument and result types from a type +splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' +splitFunTy_maybe (FunTy _ arg res) = Just (arg, res) +splitFunTy_maybe _ = Nothing + +splitFunTys :: Type -> ([Type], Type) +splitFunTys ty = split [] ty ty + where + split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' + split args _ (FunTy _ arg res) = split (arg:args) res res + split args orig_ty _ = (reverse args, orig_ty) + +funResultTy :: Type -> Type +-- ^ Extract the function result type and panic if that is not possible +funResultTy ty | Just ty' <- coreView ty = funResultTy ty' +funResultTy (FunTy { ft_res = res }) = res +funResultTy ty = pprPanic "funResultTy" (ppr ty) + +funArgTy :: Type -> Type +-- ^ Extract the function argument type and panic if that is not possible +funArgTy ty | Just ty' <- coreView ty = funArgTy ty' +funArgTy (FunTy { ft_arg = arg }) = arg +funArgTy ty = pprPanic "funArgTy" (ppr ty) + +-- ^ Just like 'piResultTys' but for a single argument +-- Try not to iterate 'piResultTy', because it's inefficient to substitute +-- one variable at a time; instead use 'piResultTys" +piResultTy :: HasDebugCallStack => Type -> Type -> Type +piResultTy ty arg = case piResultTy_maybe ty arg of + Just res -> res + Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) + +piResultTy_maybe :: Type -> Type -> Maybe Type +-- We don't need a 'tc' version, because +-- this function behaves the same for Type and Constraint +piResultTy_maybe ty arg + | Just ty' <- coreView ty = piResultTy_maybe ty' arg + + | FunTy { ft_res = res } <- ty + = Just res + + | ForAllTy (Bndr tv _) res <- ty + = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfTypes [arg,res] + in Just (substTy (extendTCvSubst empty_subst tv arg) res) + + | otherwise + = Nothing + +-- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) +-- where f :: f_ty +-- 'piResultTys' is interesting because: +-- 1. 'f_ty' may have more for-alls than there are args +-- 2. Less obviously, it may have fewer for-alls +-- For case 2. think of: +-- piResultTys (forall a.a) [forall b.b, Int] +-- This really can happen, but only (I think) in situations involving +-- undefined. For example: +-- undefined :: forall a. a +-- Term: undefined @(forall b. b->b) @Int +-- This term should have type (Int -> Int), but notice that +-- there are more type args than foralls in 'undefined's type. + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint + +-- This is a heavily used function (e.g. from typeKind), +-- so we pay attention to efficiency, especially in the special case +-- where there are no for-alls so we are just dropping arrows from +-- a function type/kind. +piResultTys :: HasDebugCallStack => Type -> [Type] -> Type +piResultTys ty [] = ty +piResultTys ty orig_args@(arg:args) + | Just ty' <- coreView ty + = piResultTys ty' orig_args + + | FunTy { ft_res = res } <- ty + = piResultTys res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst init_subst tv arg) res args + + | otherwise + = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) + where + init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) + + go :: TCvSubst -> Type -> [Type] -> Type + go subst ty [] = substTyUnchecked subst ty + + go subst ty all_args@(arg:args) + | Just ty' <- coreView ty + = go subst ty' all_args + + | FunTy { ft_res = res } <- ty + = go subst res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst subst tv arg) res args + + | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] + = go init_subst + (substTy subst ty) + all_args + + | otherwise + = -- We have not run out of arguments, but the function doesn't + -- have the right kind to apply to them; so panic. + -- Without the explicit isEmptyVarEnv test, an ill-kinded type + -- would give an infinite loop, which is very unhelpful + -- c.f. #15473 + pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) + +applyTysX :: [TyVar] -> Type -> [Type] -> Type +-- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys +-- Assumes that (/\tvs. body_ty) is closed +applyTysX tvs body_ty arg_tys + = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff ) + ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff ) + mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty) + (drop n_tvs arg_tys) + where + pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] + n_tvs = length tvs + + + +{- Note [Care with kind instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + T :: forall k. k +and we are finding the kind of + T (forall b. b -> b) * Int +Then + T (forall b. b->b) :: k[ k :-> forall b. b->b] + :: forall b. b -> b +So + T (forall b. b->b) * :: (b -> b)[ b :-> *] + :: * -> * + +In other words we must instantiate the forall! + +Similarly (#15428) + S :: forall k f. k -> f k +and we are finding the kind of + S * (* ->) Int Bool +We have + S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)] + :: * -> * -> * +So again we must instantiate. + +The same thing happens in GHC.CoreToIface.toIfaceAppArgsX. + +-------------------------------------- +Note [mkTyConApp and Type] + +Whilst benchmarking it was observed in #17292 that GHC allocated a lot +of `TyConApp` constructors. Upon further inspection a large number of these +TyConApp constructors were all duplicates of `Type` applied to no arguments. + +``` +(From a sample of 100000 TyConApp closures) +0x45f3523 - 28732 - `Type` +0x420b840702 - 9629 - generic type constructors +0x42055b7e46 - 9596 +0x420559b582 - 9511 +0x420bb15a1e - 9509 +0x420b86c6ba - 9501 +0x42055bac1e - 9496 +0x45e68fd - 538 - `TYPE ...` +``` + +Therefore in `mkTyConApp` we have a special case for `Type` to ensure that +only one `TyConApp 'Type []` closure is allocated during the course of +compilation. In order to avoid a potentially expensive series of checks in +`mkTyConApp` only this egregious case is special cased at the moment. + + +--------------------------------------------------------------------- + TyConApp + ~~~~~~~~ +-} + +-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon + , [_rep1,_rep2,ty1,ty2] <- tys + -- The FunTyCon (->) is always a visible one + = FunTy { ft_af = VisArg, ft_arg = ty1, ft_res = ty2 } + -- Note [mkTyConApp and Type] + | tycon == liftedTypeKindTyCon + = ASSERT2( null tys, ppr tycon $$ ppr tys ) + liftedTypeKindTyConApp + | otherwise + = TyConApp tycon tys + +-- This is a single, global definition of the type `Type` +-- Defined here so it is only allocated once. +-- See Note [mkTyConApp and Type] +liftedTypeKindTyConApp :: Type +liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon [] + +-- splitTyConApp "looks through" synonyms, because they don't +-- mean a distinct type, but all other type-constructor applications +-- including functions are returned as Just .. + +-- | Retrieve the tycon heading this type, if there is one. Does /not/ +-- look through synonyms. +tyConAppTyConPicky_maybe :: Type -> Maybe TyCon +tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc +tyConAppTyConPicky_maybe (FunTy {}) = Just funTyCon +tyConAppTyConPicky_maybe _ = Nothing + + +-- | The same as @fst . splitTyConApp@ +tyConAppTyCon_maybe :: Type -> Maybe TyCon +tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty' +tyConAppTyCon_maybe (TyConApp tc _) = Just tc +tyConAppTyCon_maybe (FunTy {}) = Just funTyCon +tyConAppTyCon_maybe _ = Nothing + +tyConAppTyCon :: Type -> TyCon +tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) + +-- | The same as @snd . splitTyConApp@ +tyConAppArgs_maybe :: Type -> Maybe [Type] +tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty' +tyConAppArgs_maybe (TyConApp _ tys) = Just tys +tyConAppArgs_maybe (FunTy _ arg res) + | Just rep1 <- getRuntimeRep_maybe arg + , Just rep2 <- getRuntimeRep_maybe res + = Just [rep1, rep2, arg, res] +tyConAppArgs_maybe _ = Nothing + +tyConAppArgs :: Type -> [Type] +tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) + +tyConAppArgN :: Int -> Type -> Type +-- Executing Nth +tyConAppArgN n ty + = case tyConAppArgs_maybe ty of + Just tys -> tys `getNth` n + Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor. Panics if that is not possible. +-- See also 'splitTyConApp_maybe' +splitTyConApp :: Type -> (TyCon, [Type]) +splitTyConApp ty = case splitTyConApp_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "splitTyConApp" (ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor +splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' +splitTyConApp_maybe ty = repSplitTyConApp_maybe ty + +-- | Split a type constructor application into its type constructor and +-- applied types. Note that this may fail in the case of a 'FunTy' with an +-- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind +-- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your +-- type before using this function. +-- +-- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. +tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) +-- Defined here to avoid module loops between Unify and TcType. +tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' +tcSplitTyConApp_maybe ty = repSplitTyConApp_maybe ty + +------------------- +repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +-- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This +-- assumes the synonyms have already been dealt with. +-- +-- Moreover, for a FunTy, it only succeeds if the argument types +-- have enough info to extract the runtime-rep arguments that +-- the funTyCon requires. This will usually be true; +-- but may be temporarily false during canonicalization: +-- see Note [FunTy and decomposing tycon applications] in TcCanonical +-- +repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +repSplitTyConApp_maybe (FunTy _ arg res) + | Just arg_rep <- getRuntimeRep_maybe arg + , Just res_rep <- getRuntimeRep_maybe res + = Just (funTyCon, [arg_rep, res_rep, arg, res]) +repSplitTyConApp_maybe _ = Nothing + +------------------- +-- | Attempts to tease a list type apart and gives the type of the elements if +-- successful (looks through type synonyms) +splitListTyConApp_maybe :: Type -> Maybe Type +splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of + Just (tc,[e]) | tc == listTyCon -> Just e + _other -> Nothing + +newTyConInstRhs :: TyCon -> [Type] -> Type +-- ^ Unwrap one 'layer' of newtype on a type constructor and its +-- arguments, using an eta-reduced version of the @newtype@ if possible. +-- This requires tys to have at least @newTyConInstArity tycon@ elements. +newTyConInstRhs tycon tys + = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs ) + applyTysX tvs rhs tys + where + (tvs, rhs) = newTyConEtadRhs tycon + +{- +--------------------------------------------------------------------- + CastTy + ~~~~~~ +A casted type has its *kind* casted into something new. +-} + +splitCastTy_maybe :: Type -> Maybe (Type, Coercion) +splitCastTy_maybe ty | Just ty' <- coreView ty = splitCastTy_maybe ty' +splitCastTy_maybe (CastTy ty co) = Just (ty, co) +splitCastTy_maybe _ = Nothing + +-- | Make a 'CastTy'. The Coercion must be nominal. Checks the +-- Coercion for reflexivity, dropping it if it's reflexive. +-- See Note [Respecting definitional equality] in GHC.Core.TyCo.Rep +mkCastTy :: Type -> Coercion -> Type +mkCastTy ty co | isReflexiveCo co = ty -- (EQ2) from the Note +-- NB: Do the slow check here. This is important to keep the splitXXX +-- functions working properly. Otherwise, we may end up with something +-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) +-- fails under splitFunTy_maybe. This happened with the cheaper check +-- in test dependent/should_compile/dynamic-paper. + +mkCastTy (CastTy ty co1) co2 + -- (EQ3) from the Note + = mkCastTy ty (co1 `mkTransCo` co2) + -- call mkCastTy again for the reflexivity check + +mkCastTy (ForAllTy (Bndr tv vis) inner_ty) co + -- (EQ4) from the Note + | isTyVar tv + , let fvs = tyCoVarsOfCo co + = -- have to make sure that pushing the co in doesn't capture the bound var! + if tv `elemVarSet` fvs + then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) + (subst, tv') = substVarBndr empty_subst tv + in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mkCastTy` co) + else ForAllTy (Bndr tv vis) (inner_ty `mkCastTy` co) + +mkCastTy ty co = CastTy ty co + +tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder] +-- Return the tyConBinders in TyCoBinder form +tyConBindersTyCoBinders = map to_tyb + where + to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) + to_tyb (Bndr tv (AnonTCB af)) = Anon af (varType tv) + +-- | Drop the cast on a type, if any. If there is no +-- cast, just return the original type. This is rarely what +-- you want. The CastTy data constructor (in GHC.Core.TyCo.Rep) has the +-- invariant that another CastTy is not inside. See the +-- data constructor for a full description of this invariant. +-- Since CastTy cannot be nested, the result of discardCast +-- cannot be a CastTy. +discardCast :: Type -> Type +discardCast (CastTy ty _) = ASSERT(not (isCastTy ty)) ty + where + isCastTy CastTy{} = True + isCastTy _ = False +discardCast ty = ty + + +{- +-------------------------------------------------------------------- + CoercionTy + ~~~~~~~~~~ +CoercionTy allows us to inject coercions into types. A CoercionTy +should appear only in the right-hand side of an application. +-} + +mkCoercionTy :: Coercion -> Type +mkCoercionTy = CoercionTy + +isCoercionTy :: Type -> Bool +isCoercionTy (CoercionTy _) = True +isCoercionTy _ = False + +isCoercionTy_maybe :: Type -> Maybe Coercion +isCoercionTy_maybe (CoercionTy co) = Just co +isCoercionTy_maybe _ = Nothing + +stripCoercionTy :: Type -> Coercion +stripCoercionTy (CoercionTy co) = co +stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) + +{- +--------------------------------------------------------------------- + SynTy + ~~~~~ + +Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms wherever possible. Thus + + type Foo a = a -> a + +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) + +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in TcBinds.hs. + + +--------------------------------------------------------------------- + ForAllTy + ~~~~~~~~ +-} + +-- | Make a dependent forall over an 'Inferred' variable +mkTyCoInvForAllTy :: TyCoVar -> Type -> Type +mkTyCoInvForAllTy tv ty + | isCoVar tv + , not (tv `elemVarSet` tyCoVarsOfType ty) + = mkVisFunTy (varType tv) ty + | otherwise + = ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar +mkInvForAllTy :: TyVar -> Type -> Type +mkInvForAllTy tv ty = ASSERT( isTyVar tv ) + ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Inferred', a common case +mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type +mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs + +-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar +mkInvForAllTys :: [TyVar] -> Type -> Type +mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs + +-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', +-- a common case +mkSpecForAllTy :: TyVar -> Type -> Type +mkSpecForAllTy tv ty = ASSERT( isTyVar tv ) + -- covar is always Inferred, so input should be tyvar + ForAllTy (Bndr tv Specified) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Specified', a common case +mkSpecForAllTys :: [TyVar] -> Type -> Type +mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs + +-- | Like mkForAllTys, but assumes all variables are dependent and visible +mkVisForAllTys :: [TyVar] -> Type -> Type +mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) + -- covar is always Inferred, so all inputs should be tyvar + mkForAllTys [ Bndr tv Required | tv <- tvs ] + +mkLamType :: Var -> Type -> Type +-- ^ Makes a @(->)@ type or an implicit forall type, depending +-- on whether it is given a type variable or a term variable. +-- This is used, for example, when producing the type of a lambda. +-- Always uses Inferred binders. +mkLamTypes :: [Var] -> Type -> Type +-- ^ 'mkLamType' for multiple type or value arguments + +mkLamType v body_ty + | isTyVar v + = ForAllTy (Bndr v Inferred) body_ty + + | isCoVar v + , v `elemVarSet` tyCoVarsOfType body_ty + = ForAllTy (Bndr v Required) body_ty + + | isPredTy arg_ty -- See Note [mkLamType: dictionary arguments] + = mkInvisFunTy arg_ty body_ty + + | otherwise + = mkVisFunTy arg_ty body_ty + where + arg_ty = varType v + +mkLamTypes vs ty = foldr mkLamType ty vs + +{- Note [mkLamType: dictionary arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have (\ (d :: Ord a). blah), we want to give it type + (Ord a => blah_ty) +with a fat arrow; that is, using mkInvisFunTy, not mkVisFunTy. + +Why? After all, we are in Core, where (=>) and (->) behave the same. +Yes, but the /specialiser/ does treat dictionary arguments specially. +Suppose we do w/w on 'foo' in module A, thus (#11272, #6056) + foo :: Ord a => Int -> blah + foo a d x = case x of I# x' -> $wfoo @a d x' + + $wfoo :: Ord a => Int# -> blah + +Now in module B we see (foo @Int dOrdInt). The specialiser will +specialise this to $sfoo, where + $sfoo :: Int -> blah + $sfoo x = case x of I# x' -> $wfoo @Int dOrdInt x' + +Now we /must/ also specialise $wfoo! But it wasn't user-written, +and has a type built with mkLamTypes. + +Conclusion: the easiest thing is to make mkLamType build + (c => ty) +when the argument is a predicate type. See GHC.Core.TyCo.Rep +Note [Types for coercions, predicates, and evidence] +-} + +-- | Given a list of type-level vars and the free vars of a result kind, +-- makes TyCoBinders, preferring anonymous binders +-- if the variable is, in fact, not dependent. +-- e.g. mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k) +-- We want (k:*) Named, (b:k) Anon, (c:k) Anon +-- +-- All non-coercion binders are /visible/. +mkTyConBindersPreferAnon :: [TyVar] -- ^ binders + -> TyCoVarSet -- ^ free variables of result + -> [TyConBinder] +mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars) + fst (go vars) + where + go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars + go [] = ([], inner_tkvs) + go (v:vs) | v `elemVarSet` fvs + = ( Bndr v (NamedTCB Required) : binders + , fvs `delVarSet` v `unionVarSet` kind_vars ) + | otherwise + = ( Bndr v (AnonTCB VisArg) : binders + , fvs `unionVarSet` kind_vars ) + where + (binders, fvs) = go vs + kind_vars = tyCoVarsOfType $ tyVarKind v + +-- | Take a ForAllTy apart, returning the list of tycovars and the result type. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitForAllTys :: Type -> ([TyCoVar], Type) +splitForAllTys ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like 'splitForAllTys', but only splits a 'ForAllTy' if +-- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility +-- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided +-- as an argument to this function. +splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVar], Type) +splitForAllTysSameVis supplied_argf ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy (Bndr tv argf) ty) tvs + | argf `sameVis` supplied_argf = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like splitForAllTys, but split only for tyvars. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitTyVarForAllTys :: Type -> ([TyVar], Type) +splitTyVarForAllTys ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Checks whether this is a proper forall (with a named binder) +isForAllTy :: Type -> Bool +isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty' +isForAllTy (ForAllTy {}) = True +isForAllTy _ = False + +-- | Like `isForAllTy`, but returns True only if it is a tyvar binder +isForAllTy_ty :: Type -> Bool +isForAllTy_ty ty | Just ty' <- coreView ty = isForAllTy_ty ty' +isForAllTy_ty (ForAllTy (Bndr tv _) _) | isTyVar tv = True +isForAllTy_ty _ = False + +-- | Like `isForAllTy`, but returns True only if it is a covar binder +isForAllTy_co :: Type -> Bool +isForAllTy_co ty | Just ty' <- coreView ty = isForAllTy_co ty' +isForAllTy_co (ForAllTy (Bndr tv _) _) | isCoVar tv = True +isForAllTy_co _ = False + +-- | Is this a function or forall? +isPiTy :: Type -> Bool +isPiTy ty | Just ty' <- coreView ty = isPiTy ty' +isPiTy (ForAllTy {}) = True +isPiTy (FunTy {}) = True +isPiTy _ = False + +-- | Is this a function? +isFunTy :: Type -> Bool +isFunTy ty | Just ty' <- coreView ty = isFunTy ty' +isFunTy (FunTy {}) = True +isFunTy _ = False + +-- | Take a forall type apart, or panics if that is not possible. +splitForAllTy :: Type -> (TyCoVar, Type) +splitForAllTy ty + | Just answer <- splitForAllTy_maybe ty = answer + | otherwise = pprPanic "splitForAllTy" (ppr ty) + +-- | Drops all ForAllTys +dropForAlls :: Type -> Type +dropForAlls ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy _ res) = go res + go res = res + +-- | Attempts to take a forall type apart, but only if it's a proper forall, +-- with a named binder +splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy (Bndr tv _) ty) = Just (tv, ty) + go _ = Nothing + +-- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder. +splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_ty_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy (Bndr tv _) ty) | isTyVar tv = Just (tv, ty) + go _ = Nothing + +-- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder. +splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_co_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy (Bndr tv _) ty) | isCoVar tv = Just (tv, ty) + go _ = Nothing + +-- | Attempts to take a forall type apart; works with proper foralls and +-- functions +splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type) +splitPiTy_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy bndr ty) = Just (Named bndr, ty) + go (FunTy { ft_af = af, ft_arg = arg, ft_res = res}) + = Just (Anon af arg, res) + go _ = Nothing + +-- | Takes a forall type apart, or panics +splitPiTy :: Type -> (TyCoBinder, Type) +splitPiTy ty + | Just answer <- splitPiTy_maybe ty = answer + | otherwise = pprPanic "splitPiTy" (ppr ty) + +-- | Split off all TyCoBinders to a type, splitting both proper foralls +-- and functions +splitPiTys :: Type -> ([TyCoBinder], Type) +splitPiTys ty = split ty ty [] + where + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs = split res res (Named b : bs) + split _ (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) bs + = split res res (Anon af arg : bs) + split orig_ty _ bs = (reverse bs, orig_ty) + +-- | Like 'splitPiTys' but split off only /named/ binders +-- and returns TyCoVarBinders rather than TyCoBinders +splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type) +splitForAllVarBndrs ty = split ty ty [] + where + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs = split res res (b:bs) + split orig_ty _ bs = (reverse bs, orig_ty) +{-# INLINE splitForAllVarBndrs #-} + +invisibleTyBndrCount :: Type -> Int +-- Returns the number of leading invisible forall'd binders in the type +-- Includes invisible predicate arguments; e.g. for +-- e.g. forall {k}. (k ~ *) => k -> k +-- returns 2 not 1 +invisibleTyBndrCount ty = length (fst (splitPiTysInvisible ty)) + +-- Like splitPiTys, but returns only *invisible* binders, including constraints +-- Stops at the first visible binder +splitPiTysInvisible :: Type -> ([TyCoBinder], Type) +splitPiTysInvisible ty = split ty ty [] + where + split orig_ty ty bs + | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs + | Bndr _ vis <- b + , isInvisibleArgFlag vis = split res res (Named b : bs) + split _ (FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res }) bs + = split res res (Anon InvisArg arg : bs) + split orig_ty _ bs = (reverse bs, orig_ty) + +splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type) +-- Same as splitPiTysInvisible, but stop when +-- - you have found 'n' TyCoBinders, +-- - or you run out of invisible binders +splitPiTysInvisibleN n ty = split n ty ty [] + where + split n orig_ty ty bs + | n == 0 = (reverse bs, orig_ty) + | Just ty' <- coreView ty = split n orig_ty ty' bs + | ForAllTy b res <- ty + , Bndr _ vis <- b + , isInvisibleArgFlag vis = split (n-1) res res (Named b : bs) + | FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res } <- ty + = split (n-1) res res (Anon InvisArg arg : bs) + | otherwise = (reverse bs, orig_ty) + +-- | Given a 'TyCon' and a list of argument types, filter out any invisible +-- (i.e., 'Inferred' or 'Specified') arguments. +filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] +filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys + +-- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred' +-- arguments. +filterOutInferredTypes :: TyCon -> [Type] -> [Type] +filterOutInferredTypes tc tys = + filterByList (map (/= Inferred) $ tyConArgFlags tc tys) tys + +-- | Given a 'TyCon' and a list of argument types, partition the arguments +-- into: +-- +-- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and +-- +-- 2. 'Required' (i.e., visible) arguments +partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) +partitionInvisibleTypes tc tys = + partitionByList (map isInvisibleArgFlag $ tyConArgFlags tc tys) tys + +-- | Given a list of things paired with their visibilities, partition the +-- things into (invisible things, visible things). +partitionInvisibles :: [(a, ArgFlag)] -> ([a], [a]) +partitionInvisibles = partitionWith pick_invis + where + pick_invis :: (a, ArgFlag) -> Either a a + pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing + | otherwise = Right thing + +-- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Wrinkle: consider the following scenario: +-- +-- > T :: forall k. k -> k +-- > tyConArgFlags T [forall m. m -> m -> m, S, R, Q] +-- +-- After substituting, we get +-- +-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n +-- +-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, +-- and @Q@ is visible. +tyConArgFlags :: TyCon -> [Type] -> [ArgFlag] +tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc) + +-- | Given a 'Type' and a list of argument types to which the 'Type' is +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Most of the time, the arguments will be 'Required', but not always. Consider +-- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is +-- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely +-- this sort of higher-rank situation in which 'appTyArgFlags' comes in handy, +-- since @f Type Bool@ would be represented in Core using 'AppTy's. +-- (See also #15792). +appTyArgFlags :: Type -> [Type] -> [ArgFlag] +appTyArgFlags ty = fun_kind_arg_flags (typeKind ty) + +-- | Given a function kind and a list of argument types (where each argument's +-- kind aligns with the corresponding position in the argument kind), determine +-- each argument's visibility ('Inferred', 'Specified', or 'Required'). +fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag] +fun_kind_arg_flags = go emptyTCvSubst + where + go subst ki arg_tys + | Just ki' <- coreView ki = go subst ki' arg_tys + go _ _ [] = [] + go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys) + = argf : go subst' res_ki arg_tys + where + subst' = extendTvSubst subst tv arg_ty + go subst (TyVarTy tv) arg_tys + | Just ki <- lookupTyVar subst tv = go subst ki arg_tys + -- This FunTy case is important to handle kinds with nested foralls, such + -- as this kind (inspired by #16518): + -- + -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type + -- + -- Here, we want to get the following ArgFlags: + -- + -- [Inferred, Specified, Required, Required, Specified, Required] + -- forall {k1}. forall k2. k1 -> k2 -> forall k3. k3 -> Type + go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys) + = argf : go subst res_ki arg_tys + where + argf = case af of + VisArg -> Required + InvisArg -> Inferred + go _ _ arg_tys = map (const Required) arg_tys + -- something is ill-kinded. But this can happen + -- when printing errors. Assume everything is Required. + +-- @isTauTy@ tests if a type has no foralls +isTauTy :: Type -> Bool +isTauTy ty | Just ty' <- coreView ty = isTauTy ty' +isTauTy (TyVarTy _) = True +isTauTy (LitTy {}) = True +isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy _ a b) = isTauTy a && isTauTy b +isTauTy (ForAllTy {}) = False +isTauTy (CastTy ty _) = isTauTy ty +isTauTy (CoercionTy _) = False -- Not sure about this + +{- +%************************************************************************ +%* * + TyCoBinders +%* * +%************************************************************************ +-} + +-- | Make an anonymous binder +mkAnonBinder :: AnonArgFlag -> Type -> TyCoBinder +mkAnonBinder = Anon + +-- | Does this binder bind a variable that is /not/ erased? Returns +-- 'True' for anonymous binders. +isAnonTyCoBinder :: TyCoBinder -> Bool +isAnonTyCoBinder (Named {}) = False +isAnonTyCoBinder (Anon {}) = True + +tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar +tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv +tyCoBinderVar_maybe _ = Nothing + +tyCoBinderType :: TyCoBinder -> Type +tyCoBinderType (Named tvb) = binderType tvb +tyCoBinderType (Anon _ ty) = ty + +tyBinderType :: TyBinder -> Type +tyBinderType (Named (Bndr tv _)) + = ASSERT( isTyVar tv ) + tyVarKind tv +tyBinderType (Anon _ ty) = ty + +-- | Extract a relevant type, if there is one. +binderRelevantType_maybe :: TyCoBinder -> Maybe Type +binderRelevantType_maybe (Named {}) = Nothing +binderRelevantType_maybe (Anon _ ty) = Just ty + +{- +************************************************************************ +* * +\subsection{Type families} +* * +************************************************************************ +-} + +mkFamilyTyConApp :: TyCon -> [Type] -> Type +-- ^ Given a family instance TyCon and its arg types, return the +-- corresponding family type. E.g: +-- +-- > data family T a +-- > data instance T (Maybe b) = MkT b +-- +-- Where the instance tycon is :RTL, so: +-- +-- > mkFamilyTyConApp :RTL Int = T (Maybe Int) +mkFamilyTyConApp tc tys + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let tvs = tyConTyVars tc + fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys ) + zipTvSubst tvs tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tc tys + +-- | Get the type on the LHS of a coercion induced by a type/data +-- family instance. +coAxNthLHS :: CoAxiom br -> Int -> Type +coAxNthLHS ax ind = + mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) + +isFamFreeTy :: Type -> Bool +isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' +isFamFreeTy (TyVarTy _) = True +isFamFreeTy (LitTy {}) = True +isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc +isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b +isFamFreeTy (FunTy _ a b) = isFamFreeTy a && isFamFreeTy b +isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty +isFamFreeTy (CastTy ty _) = isFamFreeTy ty +isFamFreeTy (CoercionTy _) = False -- Not sure about this + +-- | Does this type classify a core (unlifted) Coercion? +-- At either role nominal or representational +-- (t1 ~# t2) or (t1 ~R# t2) +-- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep +isCoVarType :: Type -> Bool + -- ToDo: should we check saturation? +isCoVarType ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + | otherwise + = False + +buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> KnotTied Type -> TyCon +-- This function is here beucase 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 + where + is_tau = isTauTy rhs + is_fam_free = isFamFreeTy rhs + +{- +************************************************************************ +* * +\subsection{Liftedness} +* * +************************************************************************ +-} + +-- | Returns Just True if this type is surely lifted, Just False +-- if it is surely unlifted, Nothing if we can't be sure (i.e., it is +-- levity polymorphic), and panics if the kind does not have the shape +-- TYPE r. +isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool +isLiftedType_maybe ty = go (getRuntimeRep ty) + where + go rr | Just rr' <- coreView rr = go rr' + | isLiftedRuntimeRep rr = Just True + | TyConApp {} <- rr = Just False -- Everything else is unlifted + | otherwise = Nothing -- levity polymorphic + +-- | See "Type#type_classification" for what an unlifted type is. +-- Panics on levity polymorphic types; See 'mightBeUnliftedType' for +-- a more approximate predicate that behaves better in the presence of +-- levity polymorphism. +isUnliftedType :: HasDebugCallStack => Type -> Bool + -- isUnliftedType returns True for forall'd unlifted types: + -- x :: forall a. Int# + -- I found bindings like these were getting floated to the top level. + -- They are pretty bogus types, mind you. It would be better never to + -- construct them +isUnliftedType ty + = not (isLiftedType_maybe ty `orElse` + pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))) + +-- | Returns: +-- +-- * 'False' if the type is /guaranteed/ lifted or +-- * 'True' if it is unlifted, OR we aren't sure (e.g. in a levity-polymorphic case) +mightBeUnliftedType :: Type -> Bool +mightBeUnliftedType ty + = case isLiftedType_maybe ty of + Just is_lifted -> not is_lifted + Nothing -> True + +-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) +isRuntimeRepKindedTy :: Type -> Bool +isRuntimeRepKindedTy = isRuntimeRepTy . typeKind + +-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. +-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: +-- +-- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep +-- , String, Int# ] == [String, Int#] +-- +dropRuntimeRepArgs :: [Type] -> [Type] +dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not +-- possible. +getRuntimeRep_maybe :: HasDebugCallStack + => Type -> Maybe Type +getRuntimeRep_maybe = kindRep_maybe . typeKind + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. +getRuntimeRep :: HasDebugCallStack => Type -> Type +getRuntimeRep ty + = case getRuntimeRep_maybe ty of + Just r -> r + Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +isUnboxedTupleType :: Type -> Bool +isUnboxedTupleType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey + -- NB: Do not use typePrimRep, as that can't tell the difference between + -- unboxed tuples and unboxed sums + + +isUnboxedSumType :: Type -> Bool +isUnboxedSumType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey + +-- | See "Type#type_classification" for what an algebraic type is. +-- Should only be applied to /types/, as opposed to e.g. partially +-- saturated type constructors +isAlgType :: Type -> Bool +isAlgType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isAlgTyCon tc + _other -> False + +-- | Check whether a type is a data family type +isDataFamilyAppType :: Type -> Bool +isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of + Just tc -> isDataFamilyTyCon tc + _ -> False + +-- | Computes whether an argument (or let right hand side) should +-- be computed strictly or lazily, based only on its type. +-- Currently, it's just 'isUnliftedType'. Panics on levity-polymorphic types. +isStrictType :: HasDebugCallStack => Type -> Bool +isStrictType = isUnliftedType + +isPrimitiveType :: Type -> Bool +-- ^ Returns true of types that are opaque to Haskell. +isPrimitiveType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isPrimTyCon tc + _ -> False + +{- +************************************************************************ +* * +\subsection{Join points} +* * +************************************************************************ +-} + +-- | Determine whether a type could be the type of a join point of given total +-- arity, according to the polymorphism rule. A join point cannot be polymorphic +-- in its return type, since given +-- join j @a @b x y z = e1 in e2, +-- the types of e1 and e2 must be the same, and a and b are not in scope for e2. +-- (See Note [The polymorphism rule of join points] in GHC.Core.) Returns False +-- also if the type simply doesn't have enough arguments. +-- +-- Note that we need to know how many arguments (type *and* value) the putative +-- join point takes; for instance, if +-- j :: forall a. a -> Int +-- then j could be a binary join point returning an Int, but it could *not* be a +-- unary join point returning a -> Int. +-- +-- TODO: See Note [Excess polymorphism and join points] +isValidJoinPointType :: JoinArity -> Type -> Bool +isValidJoinPointType arity ty + = valid_under emptyVarSet arity ty + where + valid_under tvs arity ty + | arity == 0 + = isEmptyVarSet (tvs `intersectVarSet` tyCoVarsOfType ty) + | Just (t, ty') <- splitForAllTy_maybe ty + = valid_under (tvs `extendVarSet` t) (arity-1) ty' + | Just (_, res_ty) <- splitFunTy_maybe ty + = valid_under tvs (arity-1) res_ty + | otherwise + = False + +{- Note [Excess polymorphism and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In principle, if a function would be a join point except that it fails +the polymorphism rule (see Note [The polymorphism rule of join points] in +GHC.Core), it can still be made a join point with some effort. This is because +all tail calls must return the same type (they return to the same context!), and +thus if the return type depends on an argument, that argument must always be the +same. + +For instance, consider: + + let f :: forall a. a -> Char -> [a] + f @a x c = ... f @a y 'a' ... + in ... f @Int 1 'b' ... f @Int 2 'c' ... + +(where the calls are tail calls). `f` fails the polymorphism rule because its +return type is [a], where [a] is bound. But since the type argument is always +'Int', we can rewrite it as: + + let f' :: Int -> Char -> [Int] + f' x c = ... f' y 'a' ... + in ... f' 1 'b' ... f 2 'c' ... + +and now we can make f' a join point: + + join f' :: Int -> Char -> [Int] + f' x c = ... jump f' y 'a' ... + in ... jump f' 1 'b' ... jump f' 2 'c' ... + +It's not clear that this comes up often, however. TODO: Measure how often and +add this analysis if necessary. See #14620. + + +************************************************************************ +* * +\subsection{Sequencing on types} +* * +************************************************************************ +-} + +seqType :: Type -> () +seqType (LitTy n) = n `seq` () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy _ t1 t2) = seqType t1 `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty +seqType (CastTy ty co) = seqType ty `seq` seqCo co +seqType (CoercionTy co) = seqCo co + +seqTypes :: [Type] -> () +seqTypes [] = () +seqTypes (ty:tys) = seqType ty `seq` seqTypes tys + +{- +************************************************************************ +* * + Comparison for types + (We don't use instances so that we know where it happens) +* * +************************************************************************ + +Note [Equality on AppTys] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In our cast-ignoring equality, we want to say that the following two +are equal: + + (Maybe |> co) (Int |> co') ~? Maybe Int + +But the left is an AppTy while the right is a TyConApp. The solution is +to use repSplitAppTy_maybe to break up the TyConApp into its pieces and +then continue. Easy to do, but also easy to forget to do. + +-} + +eqType :: Type -> Type -> Bool +-- ^ Type equality on source types. Does not look through @newtypes@ or +-- 'PredType's, but it does look through type synonyms. +-- This first checks that the kinds of the types are equal and then +-- checks whether the types are equal, ignoring casts and coercions. +-- (The kind check is a recursive call, but since all kinds have type +-- @Type@, there is no need to check the types of kinds.) +-- See also Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. +eqType t1 t2 = isEqual $ nonDetCmpType t1 t2 + -- It's OK to use nonDetCmpType here and eqType is deterministic, + -- nonDetCmpType does equality deterministically + +-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. +eqTypeX :: RnEnv2 -> Type -> Type -> Bool +eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2 + -- It's OK to use nonDetCmpType here and eqTypeX is deterministic, + -- nonDetCmpTypeX does equality deterministically + +-- | Type equality on lists of types, looking through type synonyms +-- but not newtypes. +eqTypes :: [Type] -> [Type] -> Bool +eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2 + -- It's OK to use nonDetCmpType here and eqTypes is deterministic, + -- nonDetCmpTypes does equality deterministically + +eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 +-- Check that the var lists are the same length +-- and have matching kinds; if so, extend the RnEnv2 +-- Returns Nothing if they don't match +eqVarBndrs env [] [] + = Just env +eqVarBndrs env (tv1:tvs1) (tv2:tvs2) + | eqTypeX env (varType tv1) (varType tv2) + = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 +eqVarBndrs _ _ _= Nothing + +-- Now here comes the real worker + +{- +Note [nonDetCmpType nondeterminism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX +uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for +ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, +comparing type variables is nondeterministic, note the call to nonDetCmpVar in +nonDetCmpTypeX. +See Note [Unique Determinism] for more details. +-} + +nonDetCmpType :: Type -> Type -> Ordering +nonDetCmpType t1 t2 + -- we know k1 and k2 have the same kind, because they both have kind *. + = nonDetCmpTypeX rn_env t1 t2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) + +nonDetCmpTypes :: [Type] -> [Type] -> Ordering +nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) + +-- | An ordering relation between two 'Type's (known below as @t1 :: k1@ +-- and @t2 :: k2@) +data TypeOrdering = TLT -- ^ @t1 < t2@ + | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, + -- therefore we can conclude @k1 ~ k2@ + | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so + -- they may differ in kind. + | TGT -- ^ @t1 > t2@ + deriving (Eq, Ord, Enum, Bounded) + +nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse + -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep +nonDetCmpTypeX env orig_t1 orig_t2 = + case go env orig_t1 orig_t2 of + -- If there are casts then we also need to do a comparison of the kinds of + -- the types being compared + TEQX -> toOrdering $ go env k1 k2 + ty_ordering -> toOrdering ty_ordering + where + k1 = typeKind orig_t1 + k2 = typeKind orig_t2 + + toOrdering :: TypeOrdering -> Ordering + toOrdering TLT = LT + toOrdering TEQ = EQ + toOrdering TEQX = EQ + toOrdering TGT = GT + + liftOrdering :: Ordering -> TypeOrdering + liftOrdering LT = TLT + liftOrdering EQ = TEQ + liftOrdering GT = TGT + + thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering + thenCmpTy TEQ rel = rel + thenCmpTy TEQX rel = hasCast rel + thenCmpTy rel _ = rel + + hasCast :: TypeOrdering -> TypeOrdering + hasCast TEQ = TEQX + hasCast rel = rel + + -- Returns both the resulting ordering relation between the two types + -- and whether either contains a cast. + go :: RnEnv2 -> Type -> Type -> TypeOrdering + go env t1 t2 + | Just t1' <- coreView t1 = go env t1' t2 + | Just t2' <- coreView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) + = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 + go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2) + = go env (varType tv1) (varType tv2) + `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 + -- See Note [Equality on AppTys] + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- repSplitAppTy_maybe ty2 + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- repSplitAppTy_maybe ty1 + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env (FunTy _ s1 t1) (FunTy _ s2 t2) + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) + = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 + go _ (LitTy l1) (LitTy l2) = liftOrdering (compare l1 l2) + go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 + go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 + + go _ (CoercionTy {}) (CoercionTy {}) = TEQ + + -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy + go _ ty1 ty2 + = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) + where get_rank :: Type -> Int + get_rank (CastTy {}) + = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) + get_rank (TyVarTy {}) = 0 + get_rank (CoercionTy {}) = 1 + get_rank (AppTy {}) = 3 + get_rank (LitTy {}) = 4 + get_rank (TyConApp {}) = 5 + get_rank (FunTy {}) = 6 + get_rank (ForAllTy {}) = 7 + + gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering + gos _ [] [] = TEQ + gos _ [] _ = TLT + gos _ _ [] = TGT + gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 + +------------- +nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering +nonDetCmpTypesX _ [] [] = EQ +nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 + `thenCmp` + nonDetCmpTypesX env tys1 tys2 +nonDetCmpTypesX _ [] _ = LT +nonDetCmpTypesX _ _ [] = GT + +------------- +-- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as +-- recognized by Kind.isConstraintKindCon) which is considered a synonym for +-- 'Type' in Core. +-- See Note [Kind Constraint and kind Type] in Kind. +-- See Note [nonDetCmpType nondeterminism] +nonDetCmpTc :: TyCon -> TyCon -> Ordering +nonDetCmpTc tc1 tc2 + = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) ) + u1 `nonDetCmpUnique` u2 + where + u1 = tyConUnique tc1 + u2 = tyConUnique tc2 + +{- +************************************************************************ +* * + The kind of a type +* * +************************************************************************ + +Note [typeKind vs tcTypeKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have two functions to get the kind of a type + + * typeKind ignores the distinction between Constraint and * + * tcTypeKind respects the distinction between Constraint and * + +tcTypeKind is used by the type inference engine, for which Constraint +and * are different; after that we use typeKind. + +See also Note [coreView vs tcView] + +Note [Kinding rules for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In typeKind we consider Constraint and (TYPE LiftedRep) to be identical. +We then have + + t1 : TYPE rep1 + t2 : TYPE rep2 + (FUN) ---------------- + t1 -> t2 : Type + + ty : TYPE rep + `a` is not free in rep +(FORALL) ----------------------- + forall a. ty : TYPE rep + +In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct: + + t1 : TYPE rep1 + t2 : TYPE rep2 + (FUN) ---------------- + t1 -> t2 : Type + + t1 : Constraint + t2 : TYPE rep + (PRED1) ---------------- + t1 => t2 : Type + + t1 : Constraint + t2 : Constraint + (PRED2) --------------------- + t1 => t2 : Constraint + + ty : TYPE rep + `a` is not free in rep +(FORALL1) ----------------------- + forall a. ty : TYPE rep + + ty : Constraint +(FORALL2) ------------------------- + forall a. ty : Constraint + +Note that: +* The only way we distinguish '->' from '=>' is by the fact + that the argument is a PredTy. Both are FunTys + +Note [Phantom type variables in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type K (r :: RuntimeRep) = Type -- Note 'r' is unused + data T r :: K r -- T :: forall r -> K r + foo :: forall r. T r + +The body of the forall in foo's type has kind (K r), and +normally it would make no sense to have + forall r. (ty :: K r) +because the kind of the forall would escape the binding +of 'r'. But in this case it's fine because (K r) exapands +to Type, so we expliclity /permit/ the type + forall r. T r + +To accommodate such a type, in typeKind (forall a.ty) we use +occCheckExpand to expand any type synonyms in the kind of 'ty' +to eliminate 'a'. See kinding rule (FORALL) in +Note [Kinding rules for types] + +And in TcValidity.checkEscapingKind, we use also use +occCheckExpand, for the same reason. +-} + +----------------------------- +typeKind :: HasDebugCallStack => Type -> Kind +-- No need to expand synonyms +typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys +typeKind (LitTy l) = typeLiteralKind l +typeKind (FunTy {}) = liftedTypeKind +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (CastTy _ty co) = coercionRKind co +typeKind (CoercionTy co) = coercionType co + +typeKind (AppTy fun arg) + = go fun [arg] + where + -- Accumulate the type arguments, so we can call piResultTys, + -- rather than a succession of calls to piResultTy (which is + -- asymptotically costly as the number of arguments increases) + go (AppTy fun arg) args = go fun (arg:args) + go fun args = piResultTys (typeKind fun) args + +typeKind ty@(ForAllTy {}) + = case occCheckExpand tvs body_kind of + -- We must make sure tv does not occur in kind + -- As it is already out of scope! + -- See Note [Phantom type variables in kinds] + Just k' -> k' + Nothing -> pprPanic "typeKind" + (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) + where + (tvs, body) = splitTyVarForAllTys ty + body_kind = typeKind body + +--------------------------------------------- +-- Utilities to be used in GHC.Core.Unify, +-- which uses "tc" functions +--------------------------------------------- + +tcTypeKind :: HasDebugCallStack => Type -> Kind +-- No need to expand synonyms +tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys +tcTypeKind (LitTy l) = typeLiteralKind l +tcTypeKind (TyVarTy tyvar) = tyVarKind tyvar +tcTypeKind (CastTy _ty co) = coercionRKind co +tcTypeKind (CoercionTy co) = coercionType co + +tcTypeKind (FunTy { ft_af = af, ft_res = res }) + | InvisArg <- af + , tcIsConstraintKind (tcTypeKind res) + = constraintKind -- Eq a => Ord a :: Constraint + | otherwise -- Eq a => a -> a :: TYPE LiftedRep + = liftedTypeKind -- Eq a => Array# Int :: Type LiftedRep (not TYPE PtrRep) + +tcTypeKind (AppTy fun arg) + = go fun [arg] + where + -- Accumulate the type arguments, so we can call piResultTys, + -- rather than a succession of calls to piResultTy (which is + -- asymptotically costly as the number of arguments increases) + go (AppTy fun arg) args = go fun (arg:args) + go fun args = piResultTys (tcTypeKind fun) args + +tcTypeKind ty@(ForAllTy {}) + | tcIsConstraintKind body_kind + = constraintKind + + | otherwise + = case occCheckExpand tvs body_kind of + -- We must make sure tv does not occur in kind + -- As it is already out of scope! + -- See Note [Phantom type variables in kinds] + Just k' -> k' + Nothing -> pprPanic "tcTypeKind" + (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) + where + (tvs, body) = splitTyVarForAllTys ty + body_kind = tcTypeKind body + + +isPredTy :: HasDebugCallStack => Type -> Bool +-- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep +isPredTy ty = tcIsConstraintKind (tcTypeKind ty) + +-- tcIsConstraintKind stuff only makes sense in the typechecker +-- After that Constraint = Type +-- See Note [coreView vs tcView] +-- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh) +tcIsConstraintKind :: Kind -> Bool +tcIsConstraintKind ty + | Just (tc, args) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here + , isConstraintKindCon tc + = ASSERT2( null args, ppr ty ) True + + | otherwise + = False + +-- | Is this kind equivalent to @*@? +-- +-- This considers 'Constraint' to be distinct from @*@. For a version that +-- treats them as the same type, see 'isLiftedTypeKind'. +tcIsLiftedTypeKind :: Kind -> Bool +tcIsLiftedTypeKind ty + | Just (tc, [arg]) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here + , tc `hasKey` tYPETyConKey + = isLiftedRuntimeRep arg + | otherwise + = False + +-- | Is this kind equivalent to @TYPE r@ (for some unknown r)? +-- +-- This considers 'Constraint' to be distinct from @*@. +tcIsRuntimeTypeKind :: Kind -> Bool +tcIsRuntimeTypeKind ty + | Just (tc, _) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here + , tc `hasKey` tYPETyConKey + = True + | otherwise + = False + +tcReturnsConstraintKind :: Kind -> Bool +-- True <=> the Kind ultimately returns a Constraint +-- E.g. * -> Constraint +-- forall k. k -> Constraint +tcReturnsConstraintKind kind + | Just kind' <- tcView kind = tcReturnsConstraintKind kind' +tcReturnsConstraintKind (ForAllTy _ ty) = tcReturnsConstraintKind ty +tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty +tcReturnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc +tcReturnsConstraintKind _ = False + +-------------------------- +typeLiteralKind :: TyLit -> Kind +typeLiteralKind (NumTyLit {}) = typeNatKind +typeLiteralKind (StrTyLit {}) = typeSymbolKind + +-- | Returns True if a type is levity polymorphic. Should be the same +-- as (isKindLevPoly . typeKind) but much faster. +-- Precondition: The type has kind (TYPE blah) +isTypeLevPoly :: Type -> Bool +isTypeLevPoly = go + where + go ty@(TyVarTy {}) = check_kind ty + go ty@(AppTy {}) = check_kind ty + go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False + | otherwise = check_kind ty + go (ForAllTy _ ty) = go ty + go (FunTy {}) = False + go (LitTy {}) = False + go ty@(CastTy {}) = check_kind ty + go ty@(CoercionTy {}) = pprPanic "isTypeLevPoly co" (ppr ty) + + check_kind = isKindLevPoly . typeKind + +-- | Looking past all pi-types, is the end result potentially levity polymorphic? +-- Example: True for (forall r (a :: TYPE r). String -> a) +-- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type) +resultIsLevPoly :: Type -> Bool +resultIsLevPoly = isTypeLevPoly . snd . splitPiTys + + +{- ********************************************************************** +* * + Occurs check expansion +%* * +%********************************************************************* -} + +{- Note [Occurs check expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid +of occurrences of tv outside type function arguments, if that is +possible; otherwise, it returns Nothing. + +For example, suppose we have + type F a b = [a] +Then + occCheckExpand b (F Int b) = Just [Int] +but + occCheckExpand a (F a Int) = Nothing + +We don't promise to do the absolute minimum amount of expanding +necessary, but we try not to do expansions we don't need to. We +prefer doing inner expansions first. For example, + type F a b = (a, Int, a, [a]) + type G b = Char +We have + occCheckExpand b (F (G b)) = Just (F Char) +even though we could also expand F to get rid of b. +-} + +occCheckExpand :: [Var] -> Type -> Maybe Type +-- See Note [Occurs check expansion] +-- We may have needed to do some type synonym unfolding in order to +-- get rid of the variable (or forall), so we also return the unfolded +-- version of the type, which is guaranteed to be syntactically free +-- of the given type variable. If the type is already syntactically +-- free of the variable, then the same type is returned. +occCheckExpand vs_to_avoid ty + | null vs_to_avoid -- Efficient shortcut + = Just ty -- Can happen, eg. GHC.Core.Utils.mkSingleAltCase + + | otherwise + = go (mkVarSet vs_to_avoid, emptyVarEnv) ty + where + go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type + -- The VarSet is the set of variables we are trying to avoid + -- The VarEnv carries mappings necessary + -- because of kind expansion + go cxt@(as, env) (TyVarTy tv') + | tv' `elemVarSet` as = Nothing + | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'') + | otherwise = do { tv'' <- go_var cxt tv' + ; return (mkTyVarTy tv'') } + + go _ ty@(LitTy {}) = return ty + go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (mkAppTy ty1' ty2') } + go cxt ty@(FunTy _ ty1 ty2) + = do { ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (ty { ft_arg = ty1', ft_res = ty2' }) } + go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) + = do { ki' <- go cxt (varType tv) + ; let tv' = setVarType tv ki' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go (as', env') body_ty + ; return (ForAllTy (Bndr tv' vis) body') } + + -- For a type constructor application, first try expanding away the + -- offending variable from the arguments. If that doesn't work, next + -- see if the type constructor is a type synonym, and if so, expand + -- it and try again. + go cxt ty@(TyConApp tc tys) + = case mapM (go cxt) tys of + Just tys' -> return (mkTyConApp tc tys') + Nothing | Just ty' <- tcView ty -> go cxt ty' + | otherwise -> Nothing + -- Failing that, try to expand a synonym + + go cxt (CastTy ty co) = do { ty' <- go cxt ty + ; co' <- go_co cxt co + ; return (mkCastTy ty' co') } + go cxt (CoercionTy co) = do { co' <- go_co cxt co + ; return (mkCoercionTy co') } + + ------------------ + go_var cxt v = do { k' <- go cxt (varType v) + ; return (setVarType v k') } + -- Works for TyVar and CoVar + -- See Note [Occurrence checking: look inside kinds] + + ------------------ + go_mco _ MRefl = return MRefl + go_mco ctx (MCo co) = MCo <$> go_co ctx co + + ------------------ + go_co cxt (Refl ty) = do { ty' <- go cxt ty + ; return (mkNomReflCo ty') } + go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco + ; ty' <- go cxt ty + ; return (mkGReflCo r ty' mco') } + -- Note: Coercions do not contain type synonyms + go_co cxt (TyConAppCo r tc args) = do { args' <- mapM (go_co cxt) args + ; return (mkTyConAppCo r tc args') } + go_co cxt (AppCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (mkAppCo co' arg') } + go_co cxt@(as, env) (ForAllCo tv kind_co body_co) + = do { kind_co' <- go_co cxt kind_co + ; let tv' = setVarType tv $ + coercionLKind kind_co' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go_co (as', env') body_co + ; return (ForAllCo tv' kind_co' body') } + go_co cxt (FunCo r co1 co2) = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; return (mkFunCo r co1' co2') } + go_co cxt@(as,env) (CoVarCo c) + | c `elemVarSet` as = Nothing + | Just c' <- lookupVarEnv env c = return (mkCoVarCo c') + | otherwise = do { c' <- go_var cxt c + ; return (mkCoVarCo c') } + go_co cxt (HoleCo h) = do { c' <- go_var cxt (ch_co_var h) + ; return (HoleCo (h { ch_co_var = c' })) } + go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args + ; return (mkAxiomInstCo ax ind args') } + go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov cxt p + ; ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (mkUnivCo p' r ty1' ty2') } + go_co cxt (SymCo co) = do { co' <- go_co cxt co + ; return (mkSymCo co') } + go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; return (mkTransCo co1' co2') } + go_co cxt (NthCo r n co) = do { co' <- go_co cxt co + ; return (mkNthCo r n co') } + go_co cxt (LRCo lr co) = do { co' <- go_co cxt co + ; return (mkLRCo lr co') } + go_co cxt (InstCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (mkInstCo co' arg') } + go_co cxt (KindCo co) = do { co' <- go_co cxt co + ; return (mkKindCo co') } + go_co cxt (SubCo co) = do { co' <- go_co cxt co + ; return (mkSubCo co') } + go_co cxt (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co cxt) cs + ; return (mkAxiomRuleCo ax cs') } + + ------------------ + go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co + go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co + go_prov _ p@(PluginProv _) = return p + + +{- +%************************************************************************ +%* * + Miscellaneous functions +%* * +%************************************************************************ + +-} +-- | All type constructors occurring in the type; looking through type +-- synonyms, but not newtypes. +-- When it finds a Class, it returns the class TyCon. +tyConsOfType :: Type -> UniqSet TyCon +tyConsOfType ty + = go ty + where + go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy {}) = emptyUniqSet + go (LitTy {}) = emptyUniqSet + go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys + go (AppTy a b) = go a `unionUniqSets` go b + go (FunTy _ a b) = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon + go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) + go (CastTy ty co) = go ty `unionUniqSets` go_co co + go (CoercionTy co) = go_co co + + go_co (Refl ty) = go ty + go_co (GRefl _ ty mco) = go ty `unionUniqSets` go_mco mco + go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args + go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg + go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co + go_co (FunCo _ co1 co2) = go_co co1 `unionUniqSets` go_co co2 + go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args + go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 + go_co (CoVarCo {}) = emptyUniqSet + go_co (HoleCo {}) = emptyUniqSet + go_co (SymCo co) = go_co co + go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 + go_co (NthCo _ _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + go_co (AxiomRuleCo _ cs) = go_cos cs + + go_mco MRefl = emptyUniqSet + go_mco (MCo co) = go_co co + + go_prov (PhantomProv co) = go_co co + go_prov (ProofIrrelProv co) = go_co co + go_prov (PluginProv _) = emptyUniqSet + -- this last case can happen from the tyConsOfType used from + -- checkTauTvUpdate + + go_s tys = foldr (unionUniqSets . go) emptyUniqSet tys + go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos + + go_tc tc = unitUniqSet tc + go_ax ax = go_tc $ coAxiomTyCon ax + +-- | Find the result 'Kind' of a type synonym, +-- after applying it to its 'arity' number of type variables +-- Actually this function works fine on data types too, +-- but they'd always return '*', so we never need to ask +synTyConResKind :: TyCon -> Kind +synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon)) + +-- | Retrieve the free variables in this type, splitting them based +-- on whether they are used visibly or invisibly. Invisible ones come +-- first. +splitVisVarsOfType :: Type -> Pair TyCoVarSet +splitVisVarsOfType orig_ty = Pair invis_vars vis_vars + where + Pair invis_vars1 vis_vars = go orig_ty + invis_vars = invis_vars1 `minusVarSet` vis_vars + + go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) + go (AppTy t1 t2) = go t1 `mappend` go t2 + go (TyConApp tc tys) = go_tc tc tys + go (FunTy _ t1 t2) = go t1 `mappend` go t2 + go (ForAllTy (Bndr tv _) ty) + = ((`delVarSet` tv) <$> go ty) `mappend` + (invisible (tyCoVarsOfType $ varType tv)) + go (LitTy {}) = mempty + go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) + go (CoercionTy co) = invisible $ tyCoVarsOfCo co + + invisible vs = Pair vs emptyVarSet + + go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in + invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis + +splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet +splitVisVarsOfTypes = foldMap splitVisVarsOfType + +modifyJoinResTy :: Int -- Number of binders to skip + -> (Type -> Type) -- Function to apply to result type + -> Type -- Type of join point + -> Type -- New type +-- INVARIANT: If any of the first n binders are foralls, those tyvars cannot +-- appear in the original result type. See isValidJoinPointType. +modifyJoinResTy orig_ar f orig_ty + = go orig_ar orig_ty + where + go 0 ty = f ty + go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty + = mkPiTy arg_bndr (go (n-1) res_ty) + | otherwise + = pprPanic "modifyJoinResTy" (ppr orig_ar <+> ppr orig_ty) + +setJoinResTy :: Int -- Number of binders to skip + -> Type -- New result type + -> Type -- Type of join point + -> Type -- New type +-- INVARIANT: Same as for modifyJoinResTy +setJoinResTy ar new_res_ty ty + = modifyJoinResTy ar (const new_res_ty) ty + +{- +************************************************************************ +* * + Functions over Kinds +* * +************************************************************************ + +Note [Kind Constraint and kind Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The kind Constraint is the kind of classes and other type constraints. +The special thing about types of kind Constraint is that + * They are displayed with double arrow: + f :: Ord a => a -> a + * They are implicitly instantiated at call sites; so the type inference + engine inserts an extra argument of type (Ord a) at every call site + to f. + +However, once type inference is over, there is *no* distinction between +Constraint and Type. Indeed we can have coercions between the two. Consider + class C a where + op :: a -> a +For this single-method class we may generate a newtype, which in turn +generates an axiom witnessing + C a ~ (a -> a) +so on the left we have Constraint, and on the right we have Type. +See #7451. + +Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with +distinct uniques, they are treated as equal at all times except +during type inference. +-} + +isConstraintKindCon :: TyCon -> Bool +isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey + +-- | Tests whether the given kind (which should look like @TYPE x@) +-- is something other than a constructor tree (that is, constructors at every node). +-- E.g. True of TYPE k, TYPE (F Int) +-- False of TYPE 'LiftedRep +isKindLevPoly :: Kind -> Bool +isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k ) + -- the isLiftedTypeKind check is necessary b/c of Constraint + go k + where + go ty | Just ty' <- coreView ty = go ty' + go TyVarTy{} = True + go AppTy{} = True -- it can't be a TyConApp + go (TyConApp tc tys) = isFamilyTyCon tc || any go tys + go ForAllTy{} = True + go (FunTy _ t1 t2) = go t1 || go t2 + go LitTy{} = False + go CastTy{} = True + go CoercionTy{} = True + + _is_type = classifiesTypeWithValues k + +----------------------------------------- +-- Subkinding +-- The tc variants are used during type-checking, where ConstraintKind +-- is distinct from all other kinds +-- After type-checking (in core), Constraint and liftedTypeKind are +-- indistinguishable + +-- | Does this classify a type allowed to have values? Responds True to things +-- like *, #, TYPE Lifted, TYPE v, Constraint. +classifiesTypeWithValues :: Kind -> Bool +-- ^ True of any sub-kind of OpenTypeKind +classifiesTypeWithValues k = isJust (kindRep_maybe k) + +{- +%************************************************************************ +%* * + Pretty-printing +%* * +%************************************************************************ + +Most pretty-printing is either in GHC.Core.TyCo.Rep or GHC.Iface.Type. + +-} + +-- | Does a 'TyCon' (that is applied to some number of arguments) need to be +-- ascribed with an explicit kind signature to resolve ambiguity if rendered as +-- a source-syntax type? +-- (See @Note [When does a tycon application need an explicit kind signature?]@ +-- for a full explanation of what this function checks for.) +tyConAppNeedsKindSig + :: Bool -- ^ Should specified binders count towards injective positions in + -- the kind of the TyCon? (If you're using visible kind + -- applications, then you want True here. + -> TyCon + -> Int -- ^ The number of args the 'TyCon' is applied to. + -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the + -- number of arguments) +tyConAppNeedsKindSig spec_inj_pos tc n_args + | LT <- listLengthCmp tc_binders n_args + = False + | otherwise + = let (dropped_binders, remaining_binders) + = splitAt n_args tc_binders + result_kind = mkTyConKind remaining_binders tc_res_kind + result_vars = tyCoVarsOfType result_kind + dropped_vars = fvVarSet $ + mapUnionFV injective_vars_of_binder dropped_binders + + in not (subVarSet result_vars dropped_vars) + where + tc_binders = tyConBinders tc + tc_res_kind = tyConResKind tc + + -- Returns the variables that would be fixed by knowing a TyConBinder. See + -- Note [When does a tycon application need an explicit kind signature?] + -- for a more detailed explanation of what this function does. + injective_vars_of_binder :: TyConBinder -> FV + injective_vars_of_binder (Bndr tv vis) = + case vis of + AnonTCB VisArg -> injectiveVarsOfType False -- conservative choice + (varType tv) + NamedTCB argf | source_of_injectivity argf + -> unitFV tv `unionFV` + injectiveVarsOfType False (varType tv) + _ -> emptyFV + + source_of_injectivity Required = True + source_of_injectivity Specified = spec_inj_pos + source_of_injectivity Inferred = False + +{- +Note [When does a tycon application need an explicit kind signature?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a couple of places in GHC where we convert Core Types into forms that +more closely resemble user-written syntax. These include: + +1. Template Haskell Type reification (see, for instance, TcSplice.reify_tc_app) +2. Converting Types to LHsTypes (in GHC.Hs.Utils.typeToLHsType, or in Haddock) + +This conversion presents a challenge: how do we ensure that the resulting type +has enough kind information so as not to be ambiguous? To better motivate this +question, consider the following Core type: + + -- Foo :: Type -> Type + type Foo = Proxy Type + +There is nothing ambiguous about the RHS of Foo in Core. But if we were to, +say, reify it into a TH Type, then it's tempting to just drop the invisible +Type argument and simply return `Proxy`. But now we've lost crucial kind +information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` +or `Proxy Int` or something else! We've inadvertently introduced ambiguity. + +Unlike in other situations in GHC, we can't just turn on +-fprint-explicit-kinds, as we need to produce something which has the same +structure as a source-syntax type. Moreover, we can't rely on visible kind +application, since the first kind argument to Proxy is inferred, not specified. +Our solution is to annotate certain tycons with their kinds whenever they +appear in applied form in order to resolve the ambiguity. For instance, we +would reify the RHS of Foo like so: + + type Foo = (Proxy :: Type -> Type) + +We need to devise an algorithm that determines precisely which tycons need +these explicit kind signatures. We certainly don't want to annotate _every_ +tycon with a kind signature, or else we might end up with horribly bloated +types like the following: + + (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) + +We only want to annotate tycons that absolutely require kind signatures in +order to resolve some sort of ambiguity, and nothing more. + +Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type +require a kind signature? It might require it when we need to fill in any of +T's omitted arguments. By "omitted argument", we mean one that is dropped when +reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and +specified arguments (e.g., TH reification in TcSplice), and sometimes the +omitted arguments are only the inferred ones (e.g., in GHC.Hs.Utils.typeToLHsType, +which reifies specified arguments through visible kind application). +Regardless, the key idea is that _some_ arguments are going to be omitted after +reification, and the only mechanism we have at our disposal for filling them in +is through explicit kind signatures. + +What do we mean by "fill in"? Let's consider this small example: + + T :: forall {k}. Type -> (k -> Type) -> k + +Moreover, we have this application of T: + + T @{j} Int aty + +When we reify this type, we omit the inferred argument @{j}. Is it fixed by the +other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then +we'll generate an equality constraint (kappa -> Type) and, assuming we can +solve it, that will fix `kappa`. (Here, `kappa` is the unification variable +that we instantiate `k` with.) + +Therefore, for any application of a tycon T to some arguments, the Question We +Must Answer is: + +* Given the first n arguments of T, do the kinds of the non-omitted arguments + fill in the omitted arguments? + +(This is still a bit hand-wavey, but we'll refine this question incrementally +as we explain more of the machinery underlying this process.) + +Answering this question is precisely the role that the `injectiveVarsOfType` +and `injective_vars_of_binder` functions exist to serve. If an omitted argument +`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing +`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a +bit.) + +More formally, if +`a` is in `injectiveVarsOfType ty` +and S1(ty) ~ S2(ty), +then S1(a) ~ S2(a), +where S1 and S2 are arbitrary substitutions. + +For example, is `F` is a non-injective type family, then + + injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} + +Now that we know what this function does, here is a second attempt at the +Question We Must Answer: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. Do the injective + variables of these binders fill in the remainder of T's kind? + +Alright, we're getting closer. Next, we need to clarify what the injective +variables of a tycon binder are. This the role that the +`injective_vars_of_binder` function serves. Here is what this function does for +each form of tycon binder: + +* Anonymous binders are injective positions. For example, in the promoted data + constructor '(:): + + '(:) :: forall a. a -> [a] -> [a] + + The second and third tyvar binders (of kinds `a` and `[a]`) are both + anonymous, so if we had '(:) 'True '[], then the kinds of 'True and + '[] would contribute to the kind of '(:) 'True '[]. Therefore, + injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. + (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) +* Named binders: + - Inferred binders are never injective positions. For example, in this data + type: + + data Proxy a + Proxy :: forall {k}. k -> Type + + If we had Proxy 'True, then the kind of 'True would not contribute to the + kind of Proxy 'True. Therefore, + injective_vars_of_binder(forall {k}. ...) = {}. + - Required binders are injective positions. For example, in this data type: + + data Wurble k (a :: k) :: k + Wurble :: forall k -> k -> k + + The first tyvar binder (of kind `forall k`) has required visibility, so if + we had Wurble (Maybe a) Nothing, then the kind of Maybe a would + contribute to the kind of Wurble (Maybe a) Nothing. Hence, + injective_vars_of_binder(forall a -> ...) = {a}. + - Specified binders /might/ be injective positions, depending on how you + approach things. Continuing the '(:) example: + + '(:) :: forall a. a -> [a] -> [a] + + Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind + of '(:) 'True '[], since it's not explicitly instantiated by the user. But + if visible kind application is enabled, then this is possible, since the + user can write '(:) @Bool 'True '[]. (In that case, + injective_vars_of_binder(forall a. ...) = {a}.) + + There are some situations where using visible kind application is appropriate + (e.g., GHC.Hs.Utils.typeToLHsType) and others where it is not (e.g., TH + reification), so the `injective_vars_of_binder` function is parametrized by + a Bool which decides if specified binders should be counted towards + injective positions or not. + +Now that we've defined injective_vars_of_binder, we can refine the Question We +Must Answer once more: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the remainder of T's kind? + +If the answer to this question is "no", then (T ty_1 ... ty_n) needs an +explicit kind signature, since T's kind has kind variables leftover that +aren't fixed by the non-omitted arguments. + +One last sticking point: what does "the remainder of T's kind" mean? You might +be tempted to think that it corresponds to all of the arguments in the kind of +T that would normally be instantiated by omitted arguments. But this isn't +quite right, strictly speaking. Consider the following (silly) example: + + S :: forall {k}. Type -> Type + +And suppose we have this application of S: + + S Int Bool + +The Int argument would be omitted, and +injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which +might suggest that (S Bool) needs an explicit kind signature. But +(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature +only affects the /result/ of the application, not all of the individual +arguments. So adding a kind signature here won't make a difference. Therefore, +the fourth (and final) iteration of the Question We Must Answer is: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the kind of (T ty_1 ... ty_n)? + +Phew, that was a lot of work! + +How can be sure that this is correct? That is, how can we be sure that in the +event that we leave off a kind annotation, that one could infer the kind of the +tycon application from its arguments? It's essentially a proof by induction: if +we can infer the kinds of every subtree of a type, then the whole tycon +application will have an inferrable kind--unless, of course, the remainder of +the tycon application's kind has uninstantiated kind variables. + +What happens if T is oversaturated? That is, if T's kind has fewer than n +arguments, in the case that the concrete application instantiates a result +kind variable with an arrow kind? If we run out of arguments, we do not attach +a kind annotation. This should be a rare case, indeed. Here is an example: + + data T1 :: k1 -> k2 -> * + data T2 :: k1 -> k2 -> * + + type family G (a :: k) :: k + type instance G T1 = T2 + + type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above + +Here G's kind is (forall k. k -> k), and the desugared RHS of that last +instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to +the algorithm above, there are 3 arguments to G so we should peel off 3 +arguments in G's kind. But G's kind has only two arguments. This is the +rare special case, and we choose not to annotate the application of G with +a kind signature. After all, we needn't do this, since that instance would +be reified as: + + type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool + +So the kind of G isn't ambiguous anymore due to the explicit kind annotation +on its argument. See #8953 and test th/T8953. +-} diff --git a/compiler/GHC/Core/Type.hs-boot b/compiler/GHC/Core/Type.hs-boot new file mode 100644 index 0000000000..e2d479be7d --- /dev/null +++ b/compiler/GHC/Core/Type.hs-boot @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Core.Type where + +import GhcPrelude +import GHC.Core.TyCon +import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Coercion ) +import Util + +isPredTy :: HasDebugCallStack => Type -> Bool +isCoercionTy :: Type -> Bool + +mkAppTy :: Type -> Type -> Type +mkCastTy :: Type -> Coercion -> Type +piResultTy :: HasDebugCallStack => Type -> Type -> Type + +eqType :: Type -> Type -> Bool + +coreView :: Type -> Maybe Type +tcView :: Type -> Maybe Type +isRuntimeRepTy :: Type -> Bool +isLiftedTypeKind :: Type -> Bool + +splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) + +partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index a895df36c0..b6e507a7b0 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -54,12 +54,12 @@ import GHC.Core.Arity ( manifestArity ) import GHC.Core.Utils import Id import Demand ( isBottomingSig ) -import DataCon +import GHC.Core.DataCon import Literal import PrimOp import IdInfo import BasicTypes ( Arity, InlineSpec(..), inlinePragmaSpec ) -import Type +import GHC.Core.Type import PrelNames import TysPrim ( realWorldStatePrimTy ) import Bag diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs new file mode 100644 index 0000000000..fa188fc022 --- /dev/null +++ b/compiler/GHC/Core/Unify.hs @@ -0,0 +1,1592 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Core.Unify ( + tcMatchTy, tcMatchTyKi, + tcMatchTys, tcMatchTyKis, + tcMatchTyX, tcMatchTysX, tcMatchTyKisX, + tcMatchTyX_BM, ruleMatchTyKiX, + + -- * Rough matching + roughMatchTcs, instanceCantMatch, + typesCantMatch, + + -- Side-effect free unification + tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, + tcUnifyTysFG, tcUnifyTyWithTFs, + BindFlag(..), + UnifyResult, UnifyResultM(..), + + -- Matching a type against a lifted type (coercion) + liftCoMatch + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Var +import VarEnv +import VarSet +import Name( Name ) +import GHC.Core.Type hiding ( getTvSubstEnv ) +import GHC.Core.Coercion hiding ( getCvSubstEnv ) +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) +import GHC.Core.TyCo.Subst ( mkTvSubst ) +import FV( FV, fvVarSet, fvVarList ) +import Util +import Pair +import Outputable +import UniqFM +import UniqSet + +import Control.Monad +import qualified Control.Monad.Fail as MonadFail +import Control.Applicative hiding ( empty ) +import qualified Control.Applicative + +{- + +Unification is much tricker than you might think. + +1. The substitution we generate binds the *template type variables* + which are given to us explicitly. + +2. We want to match in the presence of foralls; + e.g (forall a. t1) ~ (forall b. t2) + + That is what the RnEnv2 is for; it does the alpha-renaming + that makes it as if a and b were the same variable. + Initialising the RnEnv2, so that it can generate a fresh + binder when necessary, entails knowing the free variables of + both types. + +3. We must be careful not to bind a template type variable to a + locally bound variable. E.g. + (forall a. x) ~ (forall b. b) + where x is the template type variable. Then we do not want to + bind x to a/b! This is a kind of occurs check. + The necessary locals accumulate in the RnEnv2. + +Note [tcMatchTy vs tcMatchTyKi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module offers two variants of matching: with kinds and without. +The TyKi variant takes two types, of potentially different kinds, +and matches them. Along the way, it necessarily also matches their +kinds. The Ty variant instead assumes that the kinds are already +eqType and so skips matching up the kinds. + +How do you choose between them? + +1. If you know that the kinds of the two types are eqType, use + the Ty variant. It is more efficient, as it does less work. + +2. If the kinds of variables in the template type might mention type families, + use the Ty variant (and do other work to make sure the kinds + work out). These pure unification functions do a straightforward + syntactic unification and do no complex reasoning about type + families. Note that the types of the variables in instances can indeed + mention type families, so instance lookup must use the Ty variant. + + (Nothing goes terribly wrong -- no panics -- if there might be type + families in kinds in the TyKi variant. You just might get match + failure even though a reducing a type family would lead to success.) + +3. Otherwise, if you're sure that the variable kinds do not mention + type families and you're not already sure that the kind of the template + equals the kind of the target, then use the TyKi version. +-} + +-- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1)) +-- @s@ such that @s(t1)@ equals @t2@. +-- The returned substitution might bind coercion variables, +-- if the variable is an argument to a GADT constructor. +-- +-- Precondition: typeKind ty1 `eqType` typeKind ty2 +-- +-- We don't pass in a set of "template variables" to be bound +-- by the match, because tcMatchTy (and similar functions) are +-- always used on top-level types, so we can bind any of the +-- free variables of the LHS. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTy :: Type -> Type -> Maybe TCvSubst +tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] + +tcMatchTyX_BM :: (TyVar -> BindFlag) -> TCvSubst + -> Type -> Type -> Maybe TCvSubst +tcMatchTyX_BM bind_me subst ty1 ty2 + = tc_match_tys_x bind_me False subst [ty1] [ty2] + +-- | Like 'tcMatchTy', but allows the kinds of the types to differ, +-- and thus matches them as well. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKi :: Type -> Type -> Maybe TCvSubst +tcMatchTyKi ty1 ty2 + = tc_match_tys (const BindMe) True [ty1] [ty2] + +-- | This is similar to 'tcMatchTy', but extends a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyX :: TCvSubst -- ^ Substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TCvSubst +tcMatchTyX subst ty1 ty2 + = tc_match_tys_x (const BindMe) False subst [ty1] [ty2] + +-- | Like 'tcMatchTy' but over a list of types. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTys :: [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot; in principle the template + -- variables could be free in the target +tcMatchTys tys1 tys2 + = tc_match_tys (const BindMe) False tys1 tys2 + +-- | Like 'tcMatchTyKi' but over a list of types. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKis :: [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTyKis tys1 tys2 + = tc_match_tys (const BindMe) True tys1 tys2 + +-- | Like 'tcMatchTys', but extending a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTysX :: TCvSubst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTysX subst tys1 tys2 + = tc_match_tys_x (const BindMe) False subst tys1 tys2 + +-- | Like 'tcMatchTyKis', but extending a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKisX :: TCvSubst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTyKisX subst tys1 tys2 + = tc_match_tys_x (const BindMe) True subst tys1 tys2 + +-- | Same as tc_match_tys_x, but starts with an empty substitution +tc_match_tys :: (TyVar -> BindFlag) + -> Bool -- ^ match kinds? + -> [Type] + -> [Type] + -> Maybe TCvSubst +tc_match_tys bind_me match_kis tys1 tys2 + = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2 + where + in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) + +-- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' +tc_match_tys_x :: (TyVar -> BindFlag) + -> Bool -- ^ match kinds? + -> TCvSubst + -> [Type] + -> [Type] + -> Maybe TCvSubst +tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 + = case tc_unify_tys bind_me + False -- Matching, not unifying + False -- Not an injectivity check + match_kis + (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of + Unifiable (tv_env', cv_env') + -> Just $ TCvSubst in_scope tv_env' cv_env' + _ -> Nothing + +-- | This one is called from the expression matcher, +-- which already has a MatchEnv in hand +ruleMatchTyKiX + :: TyCoVarSet -- ^ template variables + -> RnEnv2 + -> TvSubstEnv -- ^ type substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TvSubstEnv +ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target +-- See Note [Kind coercions in Unify] + = case tc_unify_tys (matchBindFun tmpl_tvs) False False + True -- <-- this means to match the kinds + rn_env tenv emptyCvSubstEnv [tmpl] [target] of + Unifiable (tenv', _) -> Just tenv' + _ -> Nothing + +matchBindFun :: TyCoVarSet -> TyVar -> BindFlag +matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem + + +{- ********************************************************************* +* * + Rough matching +* * +********************************************************************* -} + +-- See Note [Rough match] field in GHC.Core.InstEnv + +roughMatchTcs :: [Type] -> [Maybe Name] +roughMatchTcs tys = map rough tys + where + rough ty + | Just (ty', _) <- splitCastTy_maybe ty = rough ty' + | Just (tc,_) <- splitTyConApp_maybe ty = Just (tyConName tc) + | otherwise = Nothing + +instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot +-- possibly be instantiated to actual, nor vice versa; +-- False is non-committal +instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as +instanceCantMatch _ _ = False -- Safe + +itemCantMatch :: Maybe Name -> Maybe Name -> Bool +itemCantMatch (Just t) (Just a) = t /= a +itemCantMatch _ _ = False + + +{- +************************************************************************ +* * + GADTs +* * +************************************************************************ + +Note [Pruning dead case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider data T a where + T1 :: T Int + T2 :: T a + + newtype X = MkX Int + newtype Y = MkY Char + + type family F a + type instance F Bool = Int + +Now consider case x of { T1 -> e1; T2 -> e2 } + +The question before the house is this: if I know something about the type +of x, can I prune away the T1 alternative? + +Suppose x::T Char. It's impossible to construct a (T Char) using T1, + Answer = YES we can prune the T1 branch (clearly) + +Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated +to 'Bool', in which case x::T Int, so + ANSWER = NO (clearly) + +We see here that we want precisely the apartness check implemented within +tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely +apart. Note that since we are simply dropping dead code, a conservative test +suffices. +-} + +-- | Given a list of pairs of types, are any two members of a pair surely +-- apart, even after arbitrary type function evaluation and substitution? +typesCantMatch :: [(Type,Type)] -> Bool +-- See Note [Pruning dead case alternatives] +typesCantMatch prs = any (uncurry cant_match) prs + where + cant_match :: Type -> Type -> Bool + cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of + SurelyApart -> True + _ -> False + +{- +************************************************************************ +* * + Unification +* * +************************************************************************ + +Note [Fine-grained unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- +no substitution to finite types makes these match. But, a substitution to +*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ]. +Why do we care? Consider these two type family instances: + +type instance F x x = Int +type instance F [y] y = Bool + +If we also have + +type instance Looper = [Looper] + +then the instances potentially overlap. The solution is to use unification +over infinite terms. This is possible (see [1] for lots of gory details), but +a full algorithm is a little more power than we need. Instead, we make a +conservative approximation and just omit the occurs check. + +[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf + +tcUnifyTys considers an occurs-check problem as the same as general unification +failure. + +tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check +failure ("MaybeApart"), or general failure ("SurelyApart"). + +See also #8162. + +It's worth noting that unification in the presence of infinite types is not +complete. This means that, sometimes, a closed type family does not reduce +when it should. See test case indexed-types/should_fail/Overlap15 for an +example. + +Note [The substitution in MaybeApart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? +Because consider unifying these: + +(a, a, Int) ~ (b, [b], Bool) + +If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we +apply the subst we have so far and discover that we need [b |-> [b]]. Because +this fails the occurs check, we say that the types are MaybeApart (see above +Note [Fine-grained unification]). But, we can't stop there! Because if we +continue, we discover that Int is SurelyApart from Bool, and therefore the +types are apart. This has practical consequences for the ability for closed +type family applications to reduce. See test case +indexed-types/should_compile/Overlap14. + +Note [Unifying with skolems] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we discover that two types unify if and only if a skolem variable is +substituted, we can't properly unify the types. But, that skolem variable +may later be instantiated with a unifyable type. So, we return maybeApart +in these cases. +-} + +-- | Simple unification of two types; all type variables are bindable +-- Precondition: the kinds are already equal +tcUnifyTy :: Type -> Type -- All tyvars are bindable + -> Maybe TCvSubst + -- A regular one-shot (idempotent) substitution +tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2] + +-- | Like 'tcUnifyTy', but also unifies the kinds +tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst +tcUnifyTyKi t1 t2 = tcUnifyTyKis (const BindMe) [t1] [t2] + +-- | Unify two types, treating type family applications as possibly unifying +-- with anything and looking through injective type family applications. +-- Precondition: kinds are the same +tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; + -- False <=> do one-way matching. + -- See end of sec 5.2 from the paper + -> Type -> Type -> Maybe TCvSubst +-- This algorithm is an implementation of the "Algorithm U" presented in +-- the paper "Injective type families for Haskell", Figures 2 and 3. +-- The code is incorporated with the standard unifier for convenience, but +-- its operation should match the specification in the paper. +tcUnifyTyWithTFs twoWay t1 t2 + = case tc_unify_tys (const BindMe) twoWay True False + rn_env emptyTvSubstEnv emptyCvSubstEnv + [t1] [t2] of + Unifiable (subst, _) -> Just $ maybe_fix subst + MaybeApart (subst, _) -> Just $ maybe_fix subst + -- we want to *succeed* in questionable cases. This is a + -- pre-unification algorithm. + SurelyApart -> Nothing + where + in_scope = mkInScopeSet $ tyCoVarsOfTypes [t1, t2] + rn_env = mkRnEnv2 in_scope + + maybe_fix | twoWay = niFixTCvSubst + | otherwise = mkTvSubst in_scope -- when matching, don't confuse + -- domain with range + +----------------- +tcUnifyTys :: (TyCoVar -> BindFlag) + -> [Type] -> [Type] + -> Maybe TCvSubst + -- ^ A regular one-shot (idempotent) substitution + -- that unifies the erased types. See comments + -- for 'tcUnifyTysFG' + +-- The two types may have common type variables, and indeed do so in the +-- second call to tcUnifyTys in FunDeps.checkClsFD +tcUnifyTys bind_fn tys1 tys2 + = case tcUnifyTysFG bind_fn tys1 tys2 of + Unifiable result -> Just result + _ -> Nothing + +-- | Like 'tcUnifyTys' but also unifies the kinds +tcUnifyTyKis :: (TyCoVar -> BindFlag) + -> [Type] -> [Type] + -> Maybe TCvSubst +tcUnifyTyKis bind_fn tys1 tys2 + = case tcUnifyTyKisFG bind_fn tys1 tys2 of + Unifiable result -> Just result + _ -> Nothing + +-- This type does double-duty. It is used in the UM (unifier monad) and to +-- return the final result. See Note [Fine-grained unification] +type UnifyResult = UnifyResultM TCvSubst +data UnifyResultM a = Unifiable a -- the subst that unifies the types + | MaybeApart a -- the subst has as much as we know + -- it must be part of a most general unifier + -- See Note [The substitution in MaybeApart] + | SurelyApart + deriving Functor + +instance Applicative UnifyResultM where + pure = Unifiable + (<*>) = ap + +instance Monad UnifyResultM where + + SurelyApart >>= _ = SurelyApart + MaybeApart x >>= f = case f x of + Unifiable y -> MaybeApart y + other -> other + Unifiable x >>= f = f x + +instance Alternative UnifyResultM where + empty = SurelyApart + + a@(Unifiable {}) <|> _ = a + _ <|> b@(Unifiable {}) = b + a@(MaybeApart {}) <|> _ = a + _ <|> b@(MaybeApart {}) = b + SurelyApart <|> SurelyApart = SurelyApart + +instance MonadPlus UnifyResultM + +-- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose +-- domain elements all respond 'BindMe' to @bind_tv@) such that +-- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned +-- Coercions. This version requires that the kinds of the types are the same, +-- if you unify left-to-right. +tcUnifyTysFG :: (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tcUnifyTysFG bind_fn tys1 tys2 + = tc_unify_tys_fg False bind_fn tys1 tys2 + +tcUnifyTyKisFG :: (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tcUnifyTyKisFG bind_fn tys1 tys2 + = tc_unify_tys_fg True bind_fn tys1 tys2 + +tc_unify_tys_fg :: Bool + -> (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tc_unify_tys_fg match_kis bind_fn tys1 tys2 + = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env + emptyTvSubstEnv emptyCvSubstEnv + tys1 tys2 + ; return $ niFixTCvSubst env } + where + vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 + env = mkRnEnv2 $ mkInScopeSet vars + +-- | This function is actually the one to call the unifier -- a little +-- too general for outside clients, though. +tc_unify_tys :: (TyVar -> BindFlag) + -> AmIUnifying -- ^ True <=> unify; False <=> match + -> Bool -- ^ True <=> doing an injectivity check + -> Bool -- ^ True <=> treat the kinds as well + -> RnEnv2 + -> TvSubstEnv -- ^ substitution to extend + -> CvSubstEnv + -> [Type] -> [Type] + -> UnifyResultM (TvSubstEnv, CvSubstEnv) +-- NB: It's tempting to ASSERT here that, if we're not matching kinds, then +-- the kinds of the types should be the same. However, this doesn't work, +-- as the types may be a dependent telescope, where later types have kinds +-- that mention variables occurring earlier in the list of types. Here's an +-- example (from typecheck/should_fail/T12709): +-- template: [rep :: RuntimeRep, a :: TYPE rep] +-- target: [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep] +-- We can see that matching the first pair will make the kinds of the second +-- pair equal. Yet, we still don't need a separate pass to unify the kinds +-- of these types, so it's appropriate to use the Ty variant of unification. +-- See also Note [tcMatchTy vs tcMatchTyKi]. +tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2 + = initUM tv_env cv_env $ + do { when match_kis $ + unify_tys env kis1 kis2 + ; unify_tys env tys1 tys2 + ; (,) <$> getTvSubstEnv <*> getCvSubstEnv } + where + env = UMEnv { um_bind_fun = bind_fn + , um_skols = emptyVarSet + , um_unif = unif + , um_inj_tf = inj_check + , um_rn_env = rn_env } + + kis1 = map typeKind tys1 + kis2 = map typeKind tys2 + +instance Outputable a => Outputable (UnifyResultM a) where + ppr SurelyApart = text "SurelyApart" + ppr (Unifiable x) = text "Unifiable" <+> ppr x + ppr (MaybeApart x) = text "MaybeApart" <+> ppr x + +{- +************************************************************************ +* * + Non-idempotent substitution +* * +************************************************************************ + +Note [Non-idempotent substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During unification we use a TvSubstEnv/CvSubstEnv pair that is + (a) non-idempotent + (b) loop-free; ie repeatedly applying it yields a fixed point + +Note [Finding the substitution fixpoint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Finding the fixpoint of a non-idempotent substitution arising from a +unification is much trickier than it looks, because of kinds. Consider + T k (H k (f:k)) ~ T * (g:*) +If we unify, we get the substitution + [ k -> * + , g -> H k (f:k) ] +To make it idempotent we don't want to get just + [ k -> * + , g -> H * (f:k) ] +We also want to substitute inside f's kind, to get + [ k -> * + , g -> H k (f:*) ] +If we don't do this, we may apply the substitution to something, +and get an ill-formed type, i.e. one where typeKind will fail. +This happened, for example, in #9106. + +It gets worse. In #14164 we wanted to take the fixpoint of +this substitution + [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6) + (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6)) + , a_aY6 :-> a_aXQ ] + +We have to apply the substitution for a_aY6 two levels deep inside +the invocation of F! We don't have a function that recursively +applies substitutions inside the kinds of variable occurrences (and +probably rightly so). + +So, we work as follows: + + 1. Start with the current substitution (which we are + trying to fixpoint + [ xs :-> F a (z :: a) (rest :: G a (z :: a)) + , a :-> b ] + + 2. Take all the free vars of the range of the substitution: + {a, z, rest, b} + NB: the free variable finder closes over + the kinds of variable occurrences + + 3. If none are in the domain of the substitution, stop. + We have found a fixpoint. + + 4. Remove the variables that are bound by the substitution, leaving + {z, rest, b} + + 5. Do a topo-sort to put them in dependency order: + [ b :: *, z :: a, rest :: G a z ] + + 6. Apply the substitution left-to-right to the kinds of these + tyvars, extending it each time with a new binding, so we + finish up with + [ xs :-> ..as before.. + , a :-> b + , b :-> b :: * + , z :-> z :: b + , rest :-> rest :: G b (z :: b) ] + Note that rest now has the right kind + + 7. Apply this extended substitution (once) to the range of + the /original/ substitution. (Note that we do the + extended substitution would go on forever if you tried + to find its fixpoint, because it maps z to z.) + + 8. And go back to step 1 + +In Step 6 we use the free vars from Step 2 as the initial +in-scope set, because all of those variables appear in the +range of the substitution, so they must all be in the in-scope +set. But NB that the type substitution engine does not look up +variables in the in-scope set; it is used only to ensure no +shadowing. +-} + +niFixTCvSubst :: TvSubstEnv -> TCvSubst +-- Find the idempotent fixed point of the non-idempotent substitution +-- This is surprisingly tricky: +-- see Note [Finding the substitution fixpoint] +-- ToDo: use laziness instead of iteration? +niFixTCvSubst tenv + | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv) + | otherwise = subst + where + range_fvs :: FV + range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv) + -- It's OK to use nonDetEltsUFM here because the + -- order of range_fvs, range_tvs is immaterial + + range_tvs :: [TyVar] + range_tvs = fvVarList range_fvs + + not_fixpoint = any in_domain range_tvs + in_domain tv = tv `elemVarEnv` tenv + + free_tvs = scopedSort (filterOut in_domain range_tvs) + + -- See Note [Finding the substitution fixpoint], Step 6 + init_in_scope = mkInScopeSet (fvVarSet range_fvs) + subst = foldl' add_free_tv + (mkTvSubst init_in_scope tenv) + free_tvs + + add_free_tv :: TCvSubst -> TyVar -> TCvSubst + add_free_tv subst tv + = extendTvSubst subst tv (mkTyVarTy tv') + where + tv' = updateTyVarKind (substTy subst) tv + +niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet +-- Apply the non-idempotent substitution to a set of type variables, +-- remembering that the substitution isn't necessarily idempotent +-- This is used in the occurs check, before extending the substitution +niSubstTvSet tsubst tvs + = nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs + -- It's OK to nonDetFoldUFM here because we immediately forget the + -- ordering by creating a set. + where + get tv + | Just ty <- lookupVarEnv tsubst tv + = niSubstTvSet tsubst (tyCoVarsOfType ty) + + | otherwise + = unitVarSet tv + +{- +************************************************************************ +* * + unify_ty: the main workhorse +* * +************************************************************************ + +Note [Specification of unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The pure unifier, unify_ty, defined in this module, tries to work out +a substitution to make two types say True to eqType. NB: eqType is +itself not purely syntactic; it accounts for CastTys; +see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + +Unlike the "impure unifiers" in the typechecker (the eager unifier in +TcUnify, and the constraint solver itself in TcCanonical), the pure +unifier It does /not/ work up to ~. + +The algorithm implemented here is rather delicate, and we depend on it +to uphold certain properties. This is a summary of these required +properties. Any reference to "flattening" refers to the flattening +algorithm in GHC.Core.FamInstEnv (See Note [Flattening] in GHC.Core.FamInstEnv), not +the flattening algorithm in the solver. + +Notation: + θ,φ substitutions + ξ type-function-free types + τ,σ other types + τ♭ type τ, flattened + + ≡ eqType + +(U1) Soundness. + If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂). + θ is a most general unifier for τ₁ and τ₂. + +(U2) Completeness. + If (unify ξ₁ ξ₂) = SurelyApart, + then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂). + +These two properties are stated as Property 11 in the "Closed Type Families" +paper (POPL'14). Below, this paper is called [CTF]. + +(U3) Apartness under substitution. + If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart, + for any θ. (Property 12 from [CTF]) + +(U4) Apart types do not unify. + If (unify ξ τ♭) = SurelyApart, then there exists no θ + such that θ(ξ) = θ(τ). (Property 13 from [CTF]) + +THEOREM. Completeness w.r.t ~ + If (unify τ₁♭ τ₂♭) = SurelyApart, + then there exists no proof that (τ₁ ~ τ₂). + +PROOF. See appendix of [CTF]. + + +The unification algorithm is used for type family injectivity, as described +in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run +in this mode, it has the following properties. + +(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even + after arbitrary type family reductions. Note that σ and τ are + not flattened here. + +(I2) If (unify σ τ) = MaybeApart θ, and if some + φ exists such that φ(σ) ~ φ(τ), then φ extends θ. + + +Furthermore, the RULES matching algorithm requires this property, +but only when using this algorithm for matching: + +(M1) If (match σ τ) succeeds with θ, then all matchable tyvars + in σ are bound in θ. + + Property M1 means that we must extend the substitution with, + say (a ↦ a) when appropriate during matching. + See also Note [Self-substitution when matching]. + +(M2) Completeness of matching. + If θ(σ) = τ, then (match σ τ) = Unifiable φ, + where θ is an extension of φ. + +Sadly, property M2 and I2 conflict. Consider + +type family F1 a b where + F1 Int Bool = Char + F1 Double String = Char + +Consider now two matching problems: + +P1. match (F1 a Bool) (F1 Int Bool) +P2. match (F1 a Bool) (F1 Double String) + +In case P1, we must find (a ↦ Int) to satisfy M2. +In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note +that the correct mapping for I2 is (a ↦ Int). There is no way to discover +this, but we mustn't map a to anything else!) + +We thus must parameterize the algorithm over whether it's being used +for an injectivity check (refrain from looking at non-injective arguments +to type families) or not (do indeed look at those arguments). This is +implemented by the uf_inj_tf field of UmEnv. + +(It's all a question of whether or not to include equation (7) from Fig. 2 +of [ITF].) + +This extra parameter is a bit fiddly, perhaps, but seemingly less so than +having two separate, almost-identical algorithms. + +Note [Self-substitution when matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should happen when we're *matching* (not unifying) a1 with a1? We +should get a substitution [a1 |-> a1]. A successful match should map all +the template variables (except ones that disappear when expanding synonyms). +But when unifying, we don't want to do this, because we'll then fall into +a loop. + +This arrangement affects the code in three places: + - If we're matching a refined template variable, don't recur. Instead, just + check for equality. That is, if we know [a |-> Maybe a] and are matching + (a ~? Maybe Int), we want to just fail. + + - Skip the occurs check when matching. This comes up in two places, because + matching against variables is handled separately from matching against + full-on types. + +Note that this arrangement was provoked by a real failure, where the same +unique ended up in the template as in the target. (It was a rule firing when +compiling Data.List.NonEmpty.) + +Note [Matching coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + type family F a + + data G a where + MkG :: F a ~ Bool => G a + + type family Foo (x :: G a) :: F a + type instance Foo MkG = False + +We would like that to be accepted. For that to work, we need to introduce +a coercion variable on the left and then use it on the right. Accordingly, +at use sites of Foo, we need to be able to use matching to figure out the +value for the coercion. (See the desugared version: + + axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c) + +) We never want this action to happen during *unification* though, when +all bets are off. + +Note [Kind coercions in Unify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to match/unify while ignoring casts. But, we can't just ignore +them completely, or we'll end up with ill-kinded substitutions. For example, +say we're matching `a` with `ty |> co`. If we just drop the cast, we'll +return [a |-> ty], but `a` and `ty` might have different kinds. We can't +just match/unify their kinds, either, because this might gratuitously +fail. After all, `co` is the witness that the kinds are the same -- they +may look nothing alike. + +So, we pass a kind coercion to the match/unify worker. This coercion witnesses +the equality between the substed kind of the left-hand type and the substed +kind of the right-hand type. Note that we do not unify kinds at the leaves +(as we did previously). We thus have + +INVARIANT: In the call + unify_ty ty1 ty2 kco +it must be that subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)), where +`subst` is the ambient substitution in the UM monad. + +To get this coercion, we first have to match/unify +the kinds before looking at the types. Happily, we need look only one level +up, as all kinds are guaranteed to have kind *. + +When we're working with type applications (either TyConApp or AppTy) we +need to worry about establishing INVARIANT, as the kinds of the function +& arguments aren't (necessarily) included in the kind of the result. +When unifying two TyConApps, this is easy, because the two TyCons are +the same. Their kinds are thus the same. As long as we unify left-to-right, +we'll be sure to unify types' kinds before the types themselves. (For example, +think about Proxy :: forall k. k -> *. Unifying the first args matches up +the kinds of the second args.) + +For AppTy, we must unify the kinds of the functions, but once these are +unified, we can continue unifying arguments without worrying further about +kinds. + +The interface to this module includes both "...Ty" functions and +"...TyKi" functions. The former assume that INVARIANT is already +established, either because the kinds are the same or because the +list of types being passed in are the well-typed arguments to some +type constructor (see two paragraphs above). The latter take a separate +pre-pass over the kinds to establish INVARIANT. Sometimes, it's important +not to take the second pass, as it caused #12442. + +We thought, at one point, that this was all unnecessary: why should +casts be in types in the first place? But they are sometimes. In +dependent/should_compile/KindEqualities2, we see, for example the +constraint Num (Int |> (blah ; sym blah)). We naturally want to find +a dictionary for that constraint, which requires dealing with +coercions in this manner. + +Note [Matching in the presence of casts (1)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When matching, it is crucial that no variables from the template +end up in the range of the matching substitution (obviously!). +When unifying, that's not a constraint; instead we take the fixpoint +of the substitution at the end. + +So what should we do with this, when matching? + unify_ty (tmpl |> co) tgt kco + +Previously, wrongly, we pushed 'co' in the (horrid) accumulating +'kco' argument like this: + unify_ty (tmpl |> co) tgt kco + = unify_ty tmpl tgt (kco ; co) + +But that is obviously wrong because 'co' (from the template) ends +up in 'kco', which in turn ends up in the range of the substitution. + +This all came up in #13910. Because we match tycon arguments +left-to-right, the ambient substitution will already have a matching +substitution for any kinds; so there is an easy fix: just apply +the substitution-so-far to the coercion from the LHS. + +Note that + +* When matching, the first arg of unify_ty is always the template; + we never swap round. + +* The above argument is distressingly indirect. We seek a + better way. + +* One better way is to ensure that type patterns (the template + in the matching process) have no casts. See #14119. + +Note [Matching in the presence of casts (2)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is another wrinkle (#17395). Suppose (T :: forall k. k -> Type) +and we are matching + tcMatchTy (T k (a::k)) (T j (b::j)) + +Then we'll match k :-> j, as expected. But then in unify_tys +we invoke + unify_tys env (a::k) (b::j) (Refl j) + +Although we have unified k and j, it's very important that we put +(Refl j), /not/ (Refl k) as the fourth argument to unify_tys. +If we put (Refl k) we'd end up with the substitution + a :-> b |> Refl k +which is bogus because one of the template variables, k, +appears in the range of the substitution. Eek. + +Similar care is needed in unify_ty_app. + + +Note [Polykinded tycon applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose T :: forall k. Type -> K +and we are unifying + ty1: T @Type Int :: Type + ty2: T @(Type->Type) Int Int :: Type + +These two TyConApps have the same TyCon at the front but they +(legitimately) have different numbers of arguments. They +are surelyApart, so we can report that without looking any +further (see #15704). +-} + +-------------- unify_ty: the main workhorse ----------- + +type AmIUnifying = Bool -- True <=> Unifying + -- False <=> Matching + +unify_ty :: UMEnv + -> Type -> Type -- Types to be unified and a co + -> CoercionN -- A coercion between their kinds + -- See Note [Kind coercions in Unify] + -> UM () +-- See Note [Specification of unification] +-- Respects newtypes, PredTypes + +unify_ty env ty1 ty2 kco + -- TODO: More commentary needed here + | Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco + | Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco + | CastTy ty1' co <- ty1 = if um_unif env + then unify_ty env ty1' ty2 (co `mkTransCo` kco) + else -- See Note [Matching in the presence of casts (1)] + do { subst <- getSubst env + ; let co' = substCo subst co + ; unify_ty env ty1' ty2 (co' `mkTransCo` kco) } + | CastTy ty2' co <- ty2 = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co) + +unify_ty env (TyVarTy tv1) ty2 kco + = uVar env tv1 ty2 kco +unify_ty env ty1 (TyVarTy tv2) kco + | um_unif env -- If unifying, can swap args + = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) + +unify_ty env ty1 ty2 _kco + | Just (tc1, tys1) <- mb_tc_app1 + , Just (tc2, tys2) <- mb_tc_app2 + , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2) + = if isInjectiveTyCon tc1 Nominal + then unify_tys env tys1 tys2 + else do { let inj | isTypeFamilyTyCon tc1 + = case tyConInjectivityInfo tc1 of + NotInjective -> repeat False + Injective bs -> bs + | otherwise + = repeat False + + (inj_tys1, noninj_tys1) = partitionByList inj tys1 + (inj_tys2, noninj_tys2) = partitionByList inj tys2 + + ; unify_tys env inj_tys1 inj_tys2 + ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] + don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 } + + | Just (tc1, _) <- mb_tc_app1 + , not (isGenerativeTyCon tc1 Nominal) + -- E.g. unify_ty (F ty1) b = MaybeApart + -- because the (F ty1) behaves like a variable + -- NB: if unifying, we have already dealt + -- with the 'ty2 = variable' case + = maybeApart + + | Just (tc2, _) <- mb_tc_app2 + , not (isGenerativeTyCon tc2 Nominal) + , um_unif env + -- E.g. unify_ty [a] (F ty2) = MaybeApart, when unifying (only) + -- because the (F ty2) behaves like a variable + -- NB: we have already dealt with the 'ty1 = variable' case + = maybeApart + + where + mb_tc_app1 = tcSplitTyConApp_maybe ty1 + mb_tc_app2 = tcSplitTyConApp_maybe ty2 + + -- Applications need a bit of care! + -- They can match FunTy and TyConApp, so use splitAppTy_maybe + -- NB: we've already dealt with type variables, + -- so if one type is an App the other one jolly well better be too +unify_ty env (AppTy ty1a ty1b) ty2 _kco + | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 + = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + +unify_ty env ty1 (AppTy ty2a ty2b) _kco + | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 + = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + +unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () + +unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco + = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind) + ; let env' = umRnBndr2 env tv1 tv2 + ; unify_ty env' ty1 ty2 kco } + +-- See Note [Matching coercion variables] +unify_ty env (CoercionTy co1) (CoercionTy co2) kco + = do { c_subst <- getCvSubstEnv + ; case co1 of + CoVarCo cv + | not (um_unif env) + , not (cv `elemVarEnv` c_subst) + , BindMe <- tvBindFlag env cv + -> do { checkRnEnv env (tyCoVarsOfCo co2) + ; let (co_l, co_r) = decomposeFunCo Nominal kco + -- cv :: t1 ~ t2 + -- co2 :: s1 ~ s2 + -- co_l :: t1 ~ s1 + -- co_r :: t2 ~ s2 + ; extendCvEnv cv (co_l `mkTransCo` + co2 `mkTransCo` + mkSymCo co_r) } + _ -> return () } + +unify_ty _ _ _ _ = surelyApart + +unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () +unify_ty_app env ty1 ty1args ty2 ty2args + | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 + , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2 + = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) + + | otherwise + = do { let ki1 = typeKind ty1 + ki2 = typeKind ty2 + -- See Note [Kind coercions in Unify] + ; unify_ty env ki1 ki2 (mkNomReflCo liftedTypeKind) + ; unify_ty env ty1 ty2 (mkNomReflCo ki2) + -- Very important: 'ki2' not 'ki1' + -- See Note [Matching in the presence of casts (2)] + ; unify_tys env ty1args ty2args } + +unify_tys :: UMEnv -> [Type] -> [Type] -> UM () +unify_tys env orig_xs orig_ys + = go orig_xs orig_ys + where + go [] [] = return () + go (x:xs) (y:ys) + -- See Note [Kind coercions in Unify] + = do { unify_ty env x y (mkNomReflCo $ typeKind y) + -- Very important: 'y' not 'x' + -- See Note [Matching in the presence of casts (2)] + ; go xs ys } + go _ _ = surelyApart + -- Possibly different saturations of a polykinded tycon + -- See Note [Polykinded tycon applications] + +--------------------------------- +uVar :: UMEnv + -> InTyVar -- Variable to be unified + -> Type -- with this Type + -> Coercion -- :: kind tv ~N kind ty + -> UM () + +uVar env tv1 ty kco + = do { -- Apply the ambient renaming + let tv1' = umRnOccL env tv1 + + -- Check to see whether tv1 is refined by the substitution + ; subst <- getTvSubstEnv + ; case (lookupVarEnv subst tv1') of + Just ty' | um_unif env -- Unifying, so call + -> unify_ty env ty' ty kco -- back into unify + | otherwise + -> -- Matching, we don't want to just recur here. + -- this is because the range of the subst is the target + -- type, not the template type. So, just check for + -- normal type equality. + guard ((ty' `mkCastTy` kco) `eqType` ty) + Nothing -> uUnrefined env tv1' ty ty kco } -- No, continue + +uUnrefined :: UMEnv + -> OutTyVar -- variable to be unified + -> Type -- with this Type + -> Type -- (version w/ expanded synonyms) + -> Coercion -- :: kind tv ~N kind ty + -> UM () + +-- We know that tv1 isn't refined + +uUnrefined env tv1' ty2 ty2' kco + | Just ty2'' <- coreView ty2' + = uUnrefined env tv1' ty2 ty2'' kco -- Unwrap synonyms + -- This is essential, in case we have + -- type Foo a = a + -- and then unify a ~ Foo a + + | TyVarTy tv2 <- ty2' + = do { let tv2' = umRnOccR env tv2 + ; unless (tv1' == tv2' && um_unif env) $ do + -- If we are unifying a ~ a, just return immediately + -- Do not extend the substitution + -- See Note [Self-substitution when matching] + + -- Check to see whether tv2 is refined + { subst <- getTvSubstEnv + ; case lookupVarEnv subst tv2 of + { Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco + ; _ -> + + do { -- So both are unrefined + -- Bind one or the other, depending on which is bindable + ; let b1 = tvBindFlag env tv1' + b2 = tvBindFlag env tv2' + ty1 = mkTyVarTy tv1' + ; case (b1, b2) of + (BindMe, _) -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) + (_, BindMe) | um_unif env + -> bindTv (umSwapRn env) tv2 (ty1 `mkCastTy` kco) + + _ | tv1' == tv2' -> return () + -- How could this happen? If we're only matching and if + -- we're comparing forall-bound variables. + + _ -> maybeApart -- See Note [Unification with skolems] + }}}} + +uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable + = case tvBindFlag env tv1' of + Skolem -> maybeApart -- See Note [Unification with skolems] + BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) + +bindTv :: UMEnv -> OutTyVar -> Type -> UM () +-- OK, so we want to extend the substitution with tv := ty +-- But first, we must do a couple of checks +bindTv env tv1 ty2 + = do { let free_tvs2 = tyCoVarsOfType ty2 + + -- Make sure tys mentions no local variables + -- E.g. (forall a. b) ~ (forall a. [a]) + -- We should not unify b := [a]! + ; checkRnEnv env free_tvs2 + + -- Occurs check, see Note [Fine-grained unification] + -- Make sure you include 'kco' (which ty2 does) #14846 + ; occurs <- occursCheck env tv1 free_tvs2 + + ; if occurs then maybeApart + else extendTvEnv tv1 ty2 } + +occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool +occursCheck env tv free_tvs + | um_unif env + = do { tsubst <- getTvSubstEnv + ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) } + + | otherwise -- Matching; no occurs check + = return False -- See Note [Self-substitution when matching] + +{- +%************************************************************************ +%* * + Binding decisions +* * +************************************************************************ +-} + +data BindFlag + = BindMe -- A regular type variable + + | Skolem -- This type variable is a skolem constant + -- Don't bind it; it only matches itself + deriving Eq + +{- +************************************************************************ +* * + Unification monad +* * +************************************************************************ +-} + +data UMEnv + = UMEnv { um_unif :: AmIUnifying + + , um_inj_tf :: Bool + -- Checking for injectivity? + -- See (end of) Note [Specification of unification] + + , um_rn_env :: RnEnv2 + -- Renaming InTyVars to OutTyVars; this eliminates + -- shadowing, and lines up matching foralls on the left + -- and right + + , um_skols :: TyVarSet + -- OutTyVars bound by a forall in this unification; + -- Do not bind these in the substitution! + -- See the function tvBindFlag + + , um_bind_fun :: TyVar -> BindFlag + -- User-supplied BindFlag function, + -- for variables not in um_skols + } + +data UMState = UMState + { um_tv_env :: TvSubstEnv + , um_cv_env :: CvSubstEnv } + +newtype UM a = UM { unUM :: UMState -> UnifyResultM (UMState, a) } + deriving (Functor) + +instance Applicative UM where + pure a = UM (\s -> pure (s, a)) + (<*>) = ap + +instance Monad UM where +#if !MIN_VERSION_base(4,13,0) + fail = MonadFail.fail +#endif + m >>= k = UM (\state -> + do { (state', v) <- unUM m state + ; unUM (k v) state' }) + +-- need this instance because of a use of 'guard' above +instance Alternative UM where + empty = UM (\_ -> Control.Applicative.empty) + m1 <|> m2 = UM (\state -> + unUM m1 state <|> + unUM m2 state) + +instance MonadPlus UM + +instance MonadFail.MonadFail UM where + fail _ = UM (\_ -> SurelyApart) -- failed pattern match + +initUM :: TvSubstEnv -- subst to extend + -> CvSubstEnv + -> UM a -> UnifyResultM a +initUM subst_env cv_subst_env um + = case unUM um state of + Unifiable (_, subst) -> Unifiable subst + MaybeApart (_, subst) -> MaybeApart subst + SurelyApart -> SurelyApart + where + state = UMState { um_tv_env = subst_env + , um_cv_env = cv_subst_env } + +tvBindFlag :: UMEnv -> OutTyVar -> BindFlag +tvBindFlag env tv + | tv `elemVarSet` um_skols env = Skolem + | otherwise = um_bind_fun env tv + +getTvSubstEnv :: UM TvSubstEnv +getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state) + +getCvSubstEnv :: UM CvSubstEnv +getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) + +getSubst :: UMEnv -> UM TCvSubst +getSubst env = do { tv_env <- getTvSubstEnv + ; cv_env <- getCvSubstEnv + ; let in_scope = rnInScopeSet (um_rn_env env) + ; return (mkTCvSubst in_scope (tv_env, cv_env)) } + +extendTvEnv :: TyVar -> Type -> UM () +extendTvEnv tv ty = UM $ \state -> + Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ()) + +extendCvEnv :: CoVar -> Coercion -> UM () +extendCvEnv cv co = UM $ \state -> + Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ()) + +umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv +umRnBndr2 env v1 v2 + = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' } + where + (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2 + +checkRnEnv :: UMEnv -> VarSet -> UM () +checkRnEnv env varset + | isEmptyVarSet skol_vars = return () + | varset `disjointVarSet` skol_vars = return () + | otherwise = maybeApart + -- ToDo: why MaybeApart? + -- I think SurelyApart would be right + where + skol_vars = um_skols env + -- NB: That isEmptyVarSet guard is a critical optimization; + -- it means we don't have to calculate the free vars of + -- the type, often saving quite a bit of allocation. + +-- | Converts any SurelyApart to a MaybeApart +don'tBeSoSure :: UM () -> UM () +don'tBeSoSure um = UM $ \ state -> + case unUM um state of + SurelyApart -> MaybeApart (state, ()) + other -> other + +umRnOccL :: UMEnv -> TyVar -> TyVar +umRnOccL env v = rnOccL (um_rn_env env) v + +umRnOccR :: UMEnv -> TyVar -> TyVar +umRnOccR env v = rnOccR (um_rn_env env) v + +umSwapRn :: UMEnv -> UMEnv +umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } + +maybeApart :: UM () +maybeApart = UM (\state -> MaybeApart (state, ())) + +surelyApart :: UM a +surelyApart = UM (\_ -> SurelyApart) + +{- +%************************************************************************ +%* * + Matching a (lifted) type against a coercion +%* * +%************************************************************************ + +This section defines essentially an inverse to liftCoSubst. It is defined +here to avoid a dependency from Coercion on this module. + +-} + +data MatchEnv = ME { me_tmpls :: TyVarSet + , me_env :: RnEnv2 } + +-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if +-- @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@, +-- where @==@ there means that the result of 'liftCoSubst' has the same +-- type as the original co; but may be different under the hood. +-- That is, it matches a type against a coercion of the same +-- "shape", and returns a lifting substitution which could have been +-- used to produce the given coercion from the given type. +-- Note that this function is incomplete -- it might return Nothing +-- when there does indeed exist a possible lifting context. +-- +-- This function is incomplete in that it doesn't respect the equality +-- in `eqType`. That is, it's possible that this will succeed for t1 and +-- fail for t2, even when t1 `eqType` t2. That's because it depends on +-- there being a very similar structure between the type and the coercion. +-- This incompleteness shouldn't be all that surprising, especially because +-- it depends on the structure of the coercion, which is a silly thing to do. +-- +-- The lifting context produced doesn't have to be exacting in the roles +-- of the mappings. This is because any use of the lifting context will +-- also require a desired role. Thus, this algorithm prefers mapping to +-- nominal coercions where it can do so. +liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext +liftCoMatch tmpls ty co + = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co + ; cenv2 <- ty_co_match menv cenv1 ty co + (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) + ; return (LC (mkEmptyTCvSubst in_scope) cenv2) } + where + menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } + in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) + -- Like tcMatchTy, assume all the interesting variables + -- in ty are in tmpls + + ki = typeKind ty + ki_co = promoteCoercion co + ki_ki_co = mkNomReflCo liftedTypeKind + + Pair co_lkind co_rkind = coercionKind ki_co + +-- | 'ty_co_match' does all the actual work for 'liftCoMatch'. +ty_co_match :: MatchEnv -- ^ ambient helpful info + -> LiftCoEnv -- ^ incoming subst + -> Type -- ^ ty, type to match + -> Coercion -- ^ co, coercion to match against + -> Coercion -- ^ :: kind of L type of substed ty ~N L kind of co + -> Coercion -- ^ :: kind of R type of substed ty ~N R kind of co + -> Maybe LiftCoEnv +ty_co_match menv subst ty co lkco rkco + | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco + + -- handle Refl case: + | tyCoVarsOfType ty `isNotInDomainOf` subst + , Just (ty', _) <- isReflCo_maybe co + , ty `eqType` ty' + = Just subst + + where + isNotInDomainOf :: VarSet -> VarEnv a -> Bool + isNotInDomainOf set env + = noneSet (\v -> elemVarEnv v env) set + + noneSet :: (Var -> Bool) -> VarSet -> Bool + noneSet f = allVarSet (not . f) + +ty_co_match menv subst ty co lkco rkco + | CastTy ty' co' <- ty + -- See Note [Matching in the presence of casts (1)] + = let empty_subst = mkEmptyTCvSubst (rnInScopeSet (me_env menv)) + substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co' + substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co' + in + ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco) + (substed_co_r `mkTransCo` rkco) + + | SymCo co' <- co + = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco + + -- Match a type variable against a non-refl coercion +ty_co_match menv subst (TyVarTy tv1) co lkco rkco + | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1 + = if eqCoercionX (nukeRnEnvL rn_env) co1' co + then Just subst + else Nothing -- no match since tv1 matches two different coercions + + | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var + = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) + then Nothing -- occurs check failed + else Just $ extendVarEnv subst tv1' $ + castCoercionKindI co (mkSymCo lkco) (mkSymCo rkco) + + | otherwise + = Nothing + + where + rn_env = me_env menv + tv1' = rnOccL rn_env tv1 + + -- just look through SubCo's. We don't really care about roles here. +ty_co_match menv subst ty (SubCo co) lkco rkco + = ty_co_match menv subst ty co lkco rkco + +ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco + | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy + = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] +ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco + | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + -- yes, the one from Type, not TcType; this is for coercion optimization + = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] + +ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco + = ty_co_match_tc menv subst tc1 tys tc2 cos +ty_co_match menv subst (FunTy _ ty1 ty2) co _lkco _rkco + -- Despite the fact that (->) is polymorphic in four type variables (two + -- runtime rep and two types), we shouldn't need to explicitly unify the + -- runtime reps here; unifying the types themselves should be sufficient. + -- See Note [Representation of function types]. + | Just (tc, [_,_,co1,co2]) <- splitTyConAppCo_maybe co + , tc == funTyCon + = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2] + in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos + +ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1) + (ForAllCo tv2 kind_co2 co2) + lkco rkco + | isTyVar tv1 && isTyVar tv2 + = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 + ki_ki_co ki_ki_co + ; let rn_env0 = me_env menv + rn_env1 = rnBndr2 rn_env0 tv1 tv2 + menv' = menv { me_env = rn_env1 } + ; ty_co_match menv' subst1 ty1 co2 lkco rkco } + where + ki_ki_co = mkNomReflCo liftedTypeKind + +-- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1) +-- (ForAllCo cv2 kind_co2 co2) +-- lkco rkco +-- | isCoVar cv1 && isCoVar cv2 +-- We seems not to have enough information for this case +-- 1. Given: +-- cv1 :: (s1 :: k1) ~r (s2 :: k2) +-- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) +-- eta1 = mkNthCo role 2 (downgradeRole r Nominal kind_co2) +-- :: s1' ~ t1 +-- eta2 = mkNthCo role 3 (downgradeRole r Nominal kind_co2) +-- :: s2' ~ t2 +-- Wanted: +-- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 +-- subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4 +-- Question: How do we get kcoi? +-- 2. Given: +-- lkco :: <*> -- See Note [Weird typing rule for ForAllTy] in GHC.Core.Type +-- rkco :: <*> +-- Wanted: +-- ty_co_match menv' subst2 ty1 co2 lkco' rkco' +-- Question: How do we get lkco' and rkco'? + +ty_co_match _ subst (CoercionTy {}) _ _ _ + = Just subst -- don't inspect coercions + +ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco + = ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co) + +ty_co_match menv subst ty co1 lkco rkco + | Just (CastTy t co, r) <- isReflCo_maybe co1 + -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us + -- t |> co ~ t ; <t> ; t ~ t |> co + -- But transitive coercions are not helpful. Therefore we deal + -- with it here: we do recursion on the smaller reflexive coercion, + -- while propagating the correct kind coercions. + = let kco' = mkSymCo co + in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco') + (rkco `mkTransCo` kco') + + +ty_co_match menv subst ty co lkco rkco + | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco + | otherwise = Nothing + +ty_co_match_tc :: MatchEnv -> LiftCoEnv + -> TyCon -> [Type] + -> TyCon -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_tc menv subst tc1 tys1 tc2 cos2 + = do { guard (tc1 == tc2) + ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos } + where + Pair lkcos rkcos + = traverse (fmap mkNomReflCo . coercionKind) cos2 + +ty_co_match_app :: MatchEnv -> LiftCoEnv + -> Type -> [Type] -> Coercion -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_app menv subst ty1 ty1args co2 co2args + | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 + , Just (co2', co2a) <- splitAppCo_maybe co2 + = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) + + | otherwise + = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co + ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2 + ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco + ; let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) co2args + ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos } + where + ki1 = typeKind ty1 + ki2 = promoteCoercion co2 + ki_ki_co = mkNomReflCo liftedTypeKind + +ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] + -> [Coercion] -> [Coercion] -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_args _ subst [] [] _ _ = Just subst +ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos) + = do { subst' <- ty_co_match menv subst ty arg lkco rkco + ; ty_co_match_args menv subst' tys args lkcos rkcos } +ty_co_match_args _ _ _ _ _ _ = Nothing + +pushRefl :: Coercion -> Maybe Coercion +pushRefl co = + case (isReflCo_maybe co) of + Just (AppTy ty1 ty2, Nominal) + -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2)) + Just (FunTy _ ty1 ty2, r) + | Just rep1 <- getRuntimeRep_maybe ty1 + , Just rep2 <- getRuntimeRep_maybe ty2 + -> Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2 + , mkReflCo r ty1, mkReflCo r ty2 ]) + Just (TyConApp tc tys, r) + -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) + Just (ForAllTy (Bndr tv _) ty, r) + -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty)) + -- NB: NoRefl variant. Otherwise, we get a loop! + _ -> Nothing diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 0a9d923a32..d84bcdd774 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -74,16 +74,16 @@ import VarEnv import VarSet import Name import Literal -import DataCon +import GHC.Core.DataCon import PrimOp import Id import IdInfo import PrelNames( absentErrorIdKey ) -import Type -import Predicate -import TyCoRep( TyCoBinder(..), TyBinder ) -import Coercion -import TyCon +import GHC.Core.Type as Type +import GHC.Core.Predicate +import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) +import GHC.Core.Coercion +import GHC.Core.TyCon import Unique import Outputable import TysPrim diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index 7285f192ce..99a90c92e9 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -37,14 +37,14 @@ import GHC.Core.Ppr import Literal import PrimOp import GHC.Core.FVs -import Type +import GHC.Core.Type import GHC.Types.RepType -import DataCon -import TyCon +import GHC.Core.DataCon +import GHC.Core.TyCon import Util import VarSet import TysPrim -import TyCoPpr ( pprType ) +import GHC.Core.TyCo.Ppr ( pprType ) import ErrUtils import Unique import FastString diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 3aad60b025..ee24c60bee 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -48,28 +48,28 @@ module GHC.CoreToIface import GhcPrelude import GHC.Iface.Syntax -import DataCon +import GHC.Core.DataCon import Id import IdInfo import GHC.Core -import TyCon hiding ( pprPromotionQuote ) -import CoAxiom +import GHC.Core.TyCon hiding ( pprPromotionQuote ) +import GHC.Core.Coercion.Axiom import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) import TysWiredIn ( heqTyCon ) import MkId ( noinlineIdName ) import PrelNames import Name import BasicTypes -import Type -import PatSyn +import GHC.Core.Type +import GHC.Core.PatSyn import Outputable import FastString import Util import Var import VarEnv import VarSet -import TyCoRep -import TyCoTidy ( tidyCo ) +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Tidy ( tidyCo ) import Demand ( isTopSig ) import Cpr ( topCprSig ) @@ -345,12 +345,12 @@ toIfaceAppArgsX fr kind ty_args VisArg -> Required InvisArg -> Inferred -- It's rare for a kind to have a constraint argument, but - -- it can happen. See Note [AnonTCB InvisArg] in TyCon. + -- it can happen. See Note [AnonTCB InvisArg] in GHC.Core.TyCon. go env ty ts@(t1:ts1) | not (isEmptyTCvSubst env) = go (zapTCvSubst env) (substTy env ty) ts - -- See Note [Care with kind instantiation] in Type.hs + -- See Note [Care with kind instantiation] in GHC.Core.Type | otherwise = -- There's a kind error in the type we are trying to print diff --git a/compiler/GHC/CoreToIface.hs-boot b/compiler/GHC/CoreToIface.hs-boot index 24fb1a148b..7daa190405 100644 --- a/compiler/GHC/CoreToIface.hs-boot +++ b/compiler/GHC/CoreToIface.hs-boot @@ -1,14 +1,14 @@ module GHC.CoreToIface where -import {-# SOURCE #-} TyCoRep ( Type, TyLit, Coercion ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion ) import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceForAllBndr , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) import Var ( TyCoVarBinder ) import VarEnv ( TidyEnv ) -import TyCon ( TyCon ) +import GHC.Core.TyCon ( TyCon ) import VarSet( VarSet ) --- For TyCoRep +-- For GHC.Core.TyCo.Rep toIfaceTypeX :: VarSet -> Type -> IfaceType toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 55771b30a9..786792ea0f 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -23,13 +23,13 @@ import GHC.Core.Utils ( exprType, findDefault, isJoinBind import GHC.Core.Arity ( manifestArity ) import GHC.Stg.Syntax -import Type +import GHC.Core.Type import GHC.Types.RepType -import TyCon +import GHC.Core.TyCon import MkId ( coercionTokenId ) import Id import IdInfo -import DataCon +import GHC.Core.DataCon import CostCentre import VarEnv import Module @@ -449,7 +449,7 @@ coreToStgExpr e0@(Case scrut bndr _ alts) = do vars_alt (con, binders, rhs) | DataAlt c <- con, c == unboxedUnitDataCon = -- This case is a bit smelly. - -- See Note [Nullary unboxed tuple] in Type.hs + -- See Note [Nullary unboxed tuple] in GHC.Core.Type -- where a nullary tuple is mapped to (State# World#) ASSERT( null binders ) do { rhs2 <- coreToStgExpr rhs diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 859892cfbe..3ec35595e0 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -31,11 +31,11 @@ import CoreMonad ( CoreToDo(..) ) import GHC.Core.Lint ( endPassIO ) import GHC.Core import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here -import Type +import GHC.Core.Type import Literal -import Coercion +import GHC.Core.Coercion import TcEnv -import TyCon +import GHC.Core.TyCon import Demand import Var import VarSet @@ -43,7 +43,7 @@ import VarEnv import Id import IdInfo import TysWiredIn -import DataCon +import GHC.Core.DataCon import BasicTypes import Module import UniqSupply diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs index 81552a46f6..0fbb10bb89 100644 --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -45,11 +45,11 @@ import Id import GHC.Core import GHCi.RemoteTypes import SrcLoc -import Type +import GHC.Core.Type import System.Process import BasicTypes import Module -import TyCon +import GHC.Core.TyCon import CostCentre import GHC.Stg.Syntax import Stream diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 844baedce4..ed47655982 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -94,11 +94,11 @@ import GHCi.RemoteTypes ( ForeignHValue ) import GHC.CoreToByteCode ( byteCodeGen, coreExprToBCOs ) import GHC.Runtime.Linker import GHC.Core.Op.Tidy ( tidyExpr ) -import Type ( Type, Kind ) +import GHC.Core.Type ( Type, Kind ) import GHC.Core.Lint ( lintInteractiveExpr ) import VarEnv ( emptyTidyEnv ) import Panic -import ConLike +import GHC.Core.ConLike import ApiAnnotation import Module @@ -131,7 +131,7 @@ import GHC.Stg.Pipeline ( stg2stg ) import qualified GHC.StgToCmm as StgToCmm ( codeGen ) import CostCentre import ProfInit -import TyCon +import GHC.Core.TyCon import Name import NameSet import GHC.Cmm @@ -140,8 +140,8 @@ import GHC.Cmm.Info.Build import GHC.Cmm.Pipeline import GHC.Cmm.Info import GHC.Driver.CodeOutput -import InstEnv -import FamInstEnv +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv import Fingerprint ( Fingerprint ) import GHC.Driver.Hooks import TcEnv diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index e879133467..b9a32d340d 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -2140,7 +2140,7 @@ joinObjectFiles dflags o_files output_fn = do SysTools.Option "-nostdlib", SysTools.Option "-Wl,-r" ] - -- See Note [No PIE while linking] in DynFlags + -- See Note [No PIE while linking] in GHC.Driver.Session ++ (if toolSettings_ccSupportsNoPie toolSettings' then [SysTools.Option "-no-pie"] else []) diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs index 33a431a8f5..c2699f23e9 100644 --- a/compiler/GHC/Driver/Types.hs +++ b/compiler/GHC/Driver/Types.hs @@ -164,8 +164,8 @@ import GHC.Hs import RdrName import Avail import Module -import InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) -import FamInstEnv +import GHC.Core.InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) +import GHC.Core.FamInstEnv import GHC.Core ( CoreProgram, RuleBase, CoreRule ) import Name import NameEnv @@ -173,24 +173,25 @@ import VarSet import Var import Id import IdInfo ( IdDetails(..), RecSelParent(..)) -import Type +import GHC.Core.Type import ApiAnnotation ( ApiAnns ) import Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) -import Class -import TyCon -import CoAxiom -import ConLike -import DataCon -import PatSyn +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) import TysWiredIn import GHC.Driver.Packages hiding ( Version(..) ) import GHC.Driver.CmdLine import GHC.Driver.Session -import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) -import GHC.Driver.Phases ( Phase, HscSource(..), hscSourceString - , isHsBootOrSig, isHsigFile ) +import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) +import GHC.Driver.Phases + ( Phase, HscSource(..), hscSourceString + , isHsBootOrSig, isHsigFile ) import qualified GHC.Driver.Phases as Phase import BasicTypes import GHC.Iface.Syntax diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 3c815821f5..70da7903fc 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -34,7 +34,7 @@ import GHC.Hs.Extension import GHC.Hs.Types import GHC.Core import TcEvidence -import Type +import GHC.Core.Type import NameSet import BasicTypes import Outputable diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index b09e0d9eea..84a9bb4dca 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -103,19 +103,19 @@ import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, HsSplice, pprExpr, import GHC.Hs.Binds import GHC.Hs.Types import GHC.Hs.Doc -import TyCon +import GHC.Core.TyCon import BasicTypes -import Coercion +import GHC.Core.Coercion import ForeignCall import GHC.Hs.Extension import NameSet -- others: -import Class +import GHC.Core.Class import Outputable import Util import SrcLoc -import Type +import GHC.Core.Type import Bag import Maybes @@ -447,7 +447,7 @@ Default methods - If there is a default method name at all, it's recorded in the ClassOpSig (in GHC.Hs.Binds), in the DefMethInfo field. - (DefMethInfo is defined in Class.hs) + (DefMethInfo is defined in GHC.Core.Class) Source-code class decls and interface-code class decls are treated subtly differently, which has given me a great deal of confusion over the years. @@ -631,7 +631,7 @@ The idea is that the associated type is really a top-level decl in its own right. However we are careful to use the same name 'a', so that we can match things up. -c.f. Note [Associated type tyvar names] in Class.hs +c.f. Note [Associated type tyvar names] in GHC.Core.Class Note [Family instance declaration binders] -} @@ -1057,7 +1057,7 @@ other argument: Here injectivity annotation would consist of two comma-separated injectivity conditions. -See also Note [Injective type families] in TyCon +See also Note [Injective type families] in GHC.Core.TyCon -} -- | Located type Family Result Signature diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs index 5bdfc8668e..71a951a30a 100644 --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -23,7 +23,7 @@ import BasicTypes import FastString import NameSet import Name -import DataCon +import GHC.Core.DataCon import SrcLoc import GHC.Hs import OccName hiding (occName) diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 724087eb96..551401be6c 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -41,12 +41,12 @@ import GHC.Core import Name import NameSet import BasicTypes -import ConLike +import GHC.Core.ConLike import SrcLoc import Util import Outputable import FastString -import Type +import GHC.Core.Type import TysWiredIn (mkTupleStr) import TcType (TcType) import {-# SOURCE #-} TcRnTypes (TcLclEnv) diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs index dac9f4de93..fa538f3089 100644 --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -25,7 +25,7 @@ import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr ) import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit, negateFractionalLit,SourceText(..),pprWithSourceText, PprPrec(..), topPrec ) -import Type +import GHC.Core.Type import Outputable import FastString import GHC.Hs.Extension diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 76735b2f97..c427d977ed 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -61,11 +61,11 @@ import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import TysWiredIn import Var import RdrName ( RdrName ) -import ConLike -import DataCon -import TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCon import Outputable -import Type +import GHC.Core.Type import SrcLoc import Bag -- collect ev vars from pats import Maybes diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs index d25e25b209..354611836c 100644 --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -81,10 +81,10 @@ import GHC.Hs.Extension import Id ( Id ) import Name( Name, NamedThing(getName) ) import RdrName ( RdrName ) -import DataCon( HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..) ) +import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..), + SrcStrictness(..), SrcUnpackedness(..) ) import TysWiredIn( mkTupleStr ) -import Type +import GHC.Core.Type import GHC.Hs.Doc import BasicTypes import SrcLoc diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index b1bdb089cf..b3a327c4c6 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -112,12 +112,12 @@ import GHC.Hs.Extension import TcEvidence import RdrName import Var -import TyCoRep -import Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) +import GHC.Core.TyCo.Rep +import GHC.Core.Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) import TysWiredIn ( unitTy ) import TcType -import DataCon -import ConLike +import GHC.Core.DataCon +import GHC.Core.ConLike import Id import Name import NameSet hiding ( unitFV ) diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index d467e559cd..e006b20de6 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -30,8 +30,8 @@ import TcRnDriver ( runTcInteractive ) import Id import IdInfo import Name -import Type -import TyCon ( tyConDataCons ) +import GHC.Core.Type +import GHC.Core.TyCon ( tyConDataCons ) import Avail import GHC.Core import GHC.Core.FVs ( exprsSomeFreeVarsList ) @@ -45,9 +45,9 @@ import GHC.HsToCore.Binds import GHC.HsToCore.Foreign.Decl import PrelNames import TysPrim -import Coercion +import GHC.Core.Coercion import TysWiredIn -import DataCon ( dataConWrapId ) +import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make import Module import NameSet diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 24a7f89fb1..27502bfda4 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -37,7 +37,7 @@ import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalB dsSyntaxExpr ) import TcType -import Type ( splitPiTy ) +import GHC.Core.Type( splitPiTy ) import TcEvidence import GHC.Core import GHC.Core.FVs @@ -46,7 +46,7 @@ import GHC.Core.Make import GHC.HsToCore.Binds (dsHsWrapper) import Id -import ConLike +import GHC.Core.ConLike import TysWiredIn import BasicTypes import PrelNames diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 9c65603d53..950cabed37 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -45,14 +45,14 @@ import GHC.Core.Arity ( etaExpand ) import GHC.Core.Unfold import GHC.Core.FVs import Digraph -import Predicate +import GHC.Core.Predicate import PrelNames -import TyCon +import GHC.Core.TyCon import TcEvidence import TcType -import Type -import Coercion +import GHC.Core.Type +import GHC.Core.Coercion import TysWiredIn ( typeNatKind, typeSymbolKind ) import Id import MkId(proxyHashId) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 575bb51105..7bb1886bff 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -19,12 +19,12 @@ import GHCi.RemoteTypes import Data.Array import GHC.ByteCode.Types import GHC.Stack.CCS -import Type +import GHC.Core.Type import GHC.Hs import Module import Outputable import GHC.Driver.Session -import ConLike +import GHC.Core.ConLike import Control.Monad import SrcLoc import ErrUtils @@ -39,7 +39,7 @@ import VarSet import Data.List import FastString import GHC.Driver.Types -import TyCon +import GHC.Core.TyCon import BasicTypes import MonadUtils import Maybes diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 36ab7eee9d..24dbe364b2 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -35,7 +35,7 @@ import GHC.HsToCore.Monad import GHC.HsToCore.PmCheck ( checkGuardMatches ) import Name import NameEnv -import FamInstEnv( topNormaliseType ) +import GHC.Core.FamInstEnv( topNormaliseType ) import GHC.HsToCore.Quote import GHC.Hs @@ -44,7 +44,7 @@ import GHC.Hs import TcType import TcEvidence import TcRnMonad -import Type +import GHC.Core.Type import GHC.Core import GHC.Core.Utils import GHC.Core.Make @@ -54,9 +54,9 @@ import CostCentre import Id import MkId import Module -import ConLike -import DataCon -import TyCoPpr( pprWithTYPE ) +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCo.Ppr( pprWithTYPE ) import TysWiredIn import PrelNames import BasicTypes @@ -66,7 +66,7 @@ import SrcLoc import Util import Bag import Outputable -import PatSyn +import GHC.Core.PatSyn import Control.Monad import Data.List.NonEmpty ( nonEmpty ) @@ -673,7 +673,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields -- Be sure to use user_tvs (which may be ordered -- differently than `univ_tvs ++ ex_tvs) above. -- See Note [DataCon user type variable binders] - -- in DataCon. + -- in GHC.Core.DataCon. rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args -- Tediously wrap the application in a cast diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index 72b3d996f0..705101caf3 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -31,16 +31,16 @@ import GHC.Core.Utils import GHC.Core.Make import MkId import ForeignCall -import DataCon +import GHC.Core.DataCon import GHC.HsToCore.Utils import TcType -import Type +import GHC.Core.Type import Id ( Id ) -import Coercion +import GHC.Core.Coercion import PrimOp import TysPrim -import TyCon +import GHC.Core.TyCon import TysWiredIn import BasicTypes import Literal diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 686380ee39..e7f49191cf 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -26,16 +26,16 @@ import GHC.HsToCore.Foreign.Call import GHC.HsToCore.Monad import GHC.Hs -import DataCon +import GHC.Core.DataCon import GHC.Core.Unfold import Id import Literal import Module import Name -import Type +import GHC.Core.Type import GHC.Types.RepType -import TyCon -import Coercion +import GHC.Core.TyCon +import GHC.Core.Coercion import TcEnv import TcType diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs index 8a1637afbc..49beaf1da4 100644 --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -26,7 +26,7 @@ import GHC.Core.Utils (bindNonRec) import GHC.HsToCore.Monad import GHC.HsToCore.Utils import GHC.HsToCore.PmCheck.Types ( Deltas, initDeltas ) -import Type ( Type ) +import GHC.Core.Type ( Type ) import Util import SrcLoc import Outputable diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index 281795c8ac..1259780573 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -29,7 +29,7 @@ import GHC.HsToCore.Utils import GHC.Driver.Session import GHC.Core.Utils import Id -import Type +import GHC.Core.Type import TysWiredIn import GHC.HsToCore.Match import PrelNames diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 78329e5493..f456323ccb 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -43,14 +43,14 @@ import GHC.HsToCore.Binds import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils import Id -import ConLike -import DataCon -import PatSyn +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn import GHC.HsToCore.Match.Constructor import GHC.HsToCore.Match.Literal -import Type -import Coercion ( eqCoercion ) -import TyCon( isNewTyCon ) +import GHC.Core.Type +import GHC.Core.Coercion ( eqCoercion ) +import GHC.Core.TyCon ( isNewTyCon ) import TysWiredIn import SrcLoc import Maybes diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs index 3785fde948..cae2dababd 100644 --- a/compiler/GHC/HsToCore/Match/Constructor.hs +++ b/compiler/GHC/HsToCore/Match/Constructor.hs @@ -22,7 +22,7 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( match ) import GHC.Hs import GHC.HsToCore.Binds -import ConLike +import GHC.Core.ConLike import BasicTypes ( Origin(..) ) import TcType import GHC.HsToCore.Monad diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 6c3a2d7a7e..c25785d064 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -36,12 +36,12 @@ import GHC.Hs import Id import GHC.Core import GHC.Core.Make -import TyCon -import DataCon +import GHC.Core.TyCon +import GHC.Core.DataCon import TcHsSyn ( shortCutLit ) import TcType import Name -import Type +import GHC.Core.Type import PrelNames import TysWiredIn import TysPrim diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 4893d13bb1..bded17de2f 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -55,7 +55,7 @@ module GHC.HsToCore.Monad ( import GhcPrelude import TcRnMonad -import FamInstEnv +import GHC.Core.FamInstEnv import GHC.Core import GHC.Core.Make ( unitExpr ) import GHC.Core.Utils ( exprType, isExprLevPoly ) @@ -67,15 +67,15 @@ import RdrName import GHC.Driver.Types import Bag import BasicTypes ( Origin ) -import DataCon -import ConLike -import TyCon +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.TyCon import GHC.HsToCore.PmCheck.Types import Id import Module import Outputable import SrcLoc -import Type +import GHC.Core.Type import UniqSupply import Name import NameEnv diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index efe9a80871..3891be649d 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -34,17 +34,17 @@ import GHC.Driver.Session import GHC.Hs import TcHsSyn import Id -import ConLike +import GHC.Core.ConLike import Name import FamInst import TysWiredIn import SrcLoc import Util import Outputable -import DataCon -import TyCon +import GHC.Core.DataCon +import GHC.Core.TyCon import Var (EvVar) -import Coercion +import GHC.Core.Coercion import TcEvidence import TcType (evVarPred) import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr) @@ -54,8 +54,8 @@ import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) import GHC.HsToCore.Monad import Bag import OrdList -import TyCoRep -import Type +import GHC.Core.TyCo.Rep +import GHC.Core.Type import GHC.HsToCore.Utils (isTrueLHsExpr) import Maybes import qualified GHC.LanguageExtensions as LangExt @@ -539,7 +539,7 @@ translatePat fam_insts x pat = case pat of SumPat _ty p alt arity -> do (y, grds) <- translateLPatV fam_insts p let sum_con = sumDataCon alt arity - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon pure $ vanillaConGrd x sum_con [y] : grds -- -------------------------------------------------------------------------- diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs index e278de4823..5d47b9f3be 100644 --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -53,22 +53,22 @@ import FastString import SrcLoc import ListSetOps (unionLists) import Maybes -import ConLike -import DataCon -import PatSyn -import TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.TyCon import TysWiredIn import TysPrim (tYPETyCon) -import TyCoRep -import Type -import TcSimplify (tcNormalise, tcCheckSatisfiability) -import Unify (tcMatchTy) -import TcRnTypes (completeMatchConLikes) -import Coercion +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import TcSimplify (tcNormalise, tcCheckSatisfiability) +import GHC.Core.Unify (tcMatchTy) +import TcRnTypes (completeMatchConLikes) +import GHC.Core.Coercion import MonadUtils hiding (foldlM) import GHC.HsToCore.Monad hiding (foldlM) import FamInst -import FamInstEnv +import GHC.Core.FamInstEnv import Control.Monad (guard, mzero, when) import Control.Monad.Trans.Class (lift) @@ -985,7 +985,7 @@ storing required arguments along with the PmAltConLike in 'vi_neg'. -- | Guess the universal argument types of a ConLike from an instantiation of -- its result type. Rather easy for DataCons, but not so much for PatSynCons. --- See Note [Pattern synonym result type] in PatSyn.hs. +-- See Note [Pattern synonym result type] in GHC.Core.PatSyn. guessConLikeUnivTyArgsFromResTy :: FamInstEnvs -> Type -> ConLike -> Maybe [Type] guessConLikeUnivTyArgsFromResTy env res_ty (RealDataCon _) = do (tc, tc_args) <- splitTyConApp_maybe res_ty @@ -997,7 +997,7 @@ guessConLikeUnivTyArgsFromResTy env res_ty (RealDataCon _) = do guessConLikeUnivTyArgsFromResTy _ res_ty (PatSynCon ps) = do -- We are successful if we managed to instantiate *every* univ_tv of con. -- This is difficult and bound to fail in some cases, see - -- Note [Pattern synonym result type] in PatSyn.hs. So we just try our best + -- Note [Pattern synonym result type] in GHC.Core.PatSyn. So we just try our best -- here and be sure to return an instantiation when we can substitute every -- universally quantified type variable. -- We *could* instantiate all the other univ_tvs just to fresh variables, I diff --git a/compiler/GHC/HsToCore/PmCheck/Ppr.hs b/compiler/GHC/HsToCore/PmCheck/Ppr.hs index a3b5cbede4..7ea416bde9 100644 --- a/compiler/GHC/HsToCore/PmCheck/Ppr.hs +++ b/compiler/GHC/HsToCore/PmCheck/Ppr.hs @@ -16,8 +16,8 @@ import BasicTypes import Id import VarEnv import UniqDFM -import ConLike -import DataCon +import GHC.Core.ConLike +import GHC.Core.DataCon import TysWiredIn import Outputable import Control.Monad.Trans.RWS.CPS diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs b/compiler/GHC/HsToCore/PmCheck/Types.hs index 783c22738d..2f42d36370 100644 --- a/compiler/GHC/HsToCore/PmCheck/Types.hs +++ b/compiler/GHC/HsToCore/PmCheck/Types.hs @@ -46,12 +46,12 @@ import VarEnv import UniqDSet import UniqDFM import Name -import DataCon -import ConLike +import GHC.Core.DataCon +import GHC.Core.ConLike import Outputable import Maybes -import Type -import TyCon +import GHC.Core.Type +import GHC.Core.TyCon import Literal import GHC.Core import GHC.Core.Map diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index fe06404b22..4ae93bcee8 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -49,7 +49,7 @@ import Name hiding( isVarOcc, isTcOcc, varName, tcName ) import THNames import NameEnv import TcType -import TyCon +import GHC.Core.TyCon import TysWiredIn import GHC.Core import GHC.Core.Make @@ -68,9 +68,9 @@ import MonadUtils import TcEvidence import Control.Monad.Trans.Reader import Control.Monad.Trans.Class -import Class +import GHC.Core.Class import GHC.Driver.Types ( MonadThings ) -import DataCon +import GHC.Core.DataCon import Var import GHC.HsToCore.Binds diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index ce1096995a..eccd37b719 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -60,15 +60,15 @@ import GHC.Core.Make import MkId import Id import Literal -import TyCon -import DataCon -import PatSyn -import Type -import Coercion +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Core.Type +import GHC.Core.Coercion import TysPrim import TysWiredIn import BasicTypes -import ConLike +import GHC.Core.ConLike import UniqSet import UniqSupply import Module @@ -331,7 +331,7 @@ mkPatSynCase var ty alt fail = do alt_result = match_result} = alt (matcher, needs_void_lam) = patSynMatcher psyn - -- See Note [Matchers and builders for pattern synonyms] in PatSyns + -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn -- on these extra Void# arguments ensure_unstrict cont | needs_void_lam = Lam voidArgId cont | otherwise = cont diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs index 687989f0a6..f7cea99b94 100644 --- a/compiler/GHC/Iface/Env.hs +++ b/compiler/GHC/Iface/Env.hs @@ -26,7 +26,7 @@ import GhcPrelude import TcRnMonad import GHC.Driver.Types -import Type +import GHC.Core.Type import Var import Name import Avail diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index b40454ee38..d726a15c7b 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -22,9 +22,9 @@ import Avail ( Avails ) import Bag ( Bag, bagToList ) import BasicTypes import BooleanFormula -import Class ( FunDep ) +import GHC.Core.Class ( FunDep ) import GHC.Core.Utils ( exprType ) -import ConLike ( conLikeName ) +import GHC.Core.ConLike ( conLikeName ) import GHC.HsToCore ( deSugarExpr ) import FieldLabel import GHC.Hs @@ -35,7 +35,7 @@ import Name ( Name, nameSrcSpan, setNameLoc ) import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import SrcLoc import TcHsSyn ( hsLitType, hsPatType ) -import Type ( mkVisFunTys, Type ) +import GHC.Core.Type ( mkVisFunTys, Type ) import TysWiredIn ( mkListTy, mkSumTy ) import Var ( Id, Var, setVarName, varName, varType ) import TcRnTypes diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs index 0f962c7164..2caffe56b3 100644 --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -14,9 +14,9 @@ import Name hiding (varName) import Outputable ( renderWithStyle, ppr, defaultUserStyle, initSDocContext ) import SrcLoc import GHC.CoreToIface -import TyCon -import TyCoRep -import Type +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type import Var import VarEnv diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 829b35d0ec..7858fc6ce4 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -55,10 +55,10 @@ import PrimOp ( allThePrimOps, primOpFixity, primOpOcc ) import MkId ( seqId ) import TysPrim ( funTyConName ) import GHC.Core.Rules -import TyCon +import GHC.Core.TyCon import Annotations -import InstEnv -import FamInstEnv +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv import Name import NameEnv import Avail diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 45a7ee08e6..f903892f9a 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -32,15 +32,15 @@ import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies ) import Id import Annotations import GHC.Core -import Class -import TyCon -import CoAxiom -import ConLike -import DataCon -import Type +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Type import TcType -import InstEnv -import FamInstEnv +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv import TcRnMonad import GHC.Hs import GHC.Driver.Types @@ -416,7 +416,7 @@ coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches -- 2nd parameter is the list of branch LHSs, in case of a closed type family, -- for conversion from incompatible branches to incompatible indices. -- For an open type family the list should be empty. --- See Note [Storing compatibility] in CoAxiom +-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch coAxBranchToIfaceBranch tc lhs_s (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 6028a94204..0890c6ffa0 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -1117,7 +1117,7 @@ data IfaceDeclExtras | IfaceDataExtras (Maybe Fixity) -- Fixity of the tycon itself (if it exists) [IfaceInstABI] -- Local class and family instances of this tycon - -- See Note [Orphans] in InstEnv + -- See Note [Orphans] in GHC.Core.InstEnv [AnnPayload] -- Annotations of the type itself [IfaceIdExtras] -- For each constructor: fixity, RULES and annotations @@ -1125,7 +1125,7 @@ data IfaceDeclExtras (Maybe Fixity) -- Fixity of the class itself (if it exists) [IfaceInstABI] -- Local instances of this class *or* -- of its associated data types - -- See Note [Orphans] in InstEnv + -- See Note [Orphans] in GHC.Core.InstEnv [AnnPayload] -- Annotations of the type itself [IfaceIdExtras] -- For each class method: fixity, RULES and annotations [IfExtName] -- Default methods. If a module diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index ebc88c272b..1812c34d6b 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -49,10 +49,10 @@ import BinFingerprint import GHC.Core( IsOrphan, isOrphan ) import Demand import Cpr -import Class +import GHC.Core.Class import FieldLabel import NameSet -import CoAxiom ( BranchIndex ) +import GHC.Core.Coercion.Axiom ( BranchIndex ) import Name import CostCentre import Literal @@ -66,9 +66,9 @@ import Fingerprint import Binary import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) import Var( VarBndr(..), binderVar ) -import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) +import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) import Util( dropList, filterByList, notNull, unzipWith, debugIsOn ) -import DataCon (SrcStrictness(..), SrcUnpackedness(..)) +import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import Lexeme (isLexSym) import TysWiredIn ( constraintKindTyConName ) import Util (seqList) @@ -222,7 +222,7 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] , ifaxbRoles :: [Role] , ifaxbRHS :: IfaceType , ifaxbIncomps :: [BranchIndex] } - -- See Note [Storing compatibility] in CoAxiom + -- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom data IfaceConDecls = IfAbstractTyCon -- c.f TyCon.AbstractTyCon @@ -254,7 +254,7 @@ data IfaceConDecl -- set of tyvars (*not* covars) of ifConExTCvs, unioned -- with the set of ifBinders (from the parent IfaceDecl) -- whose tyvars do not appear in ifConEqSpec - -- See Note [DataCon user type variable binders] in DataCon + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon ifConEqSpec :: IfaceEqSpec, -- Equality constraints ifConCtxt :: IfaceContext, -- Non-stupid context ifConArgTys :: [IfaceType], -- Arg types @@ -281,7 +281,7 @@ data IfaceClsInst ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst ifDFun :: IfExtName, -- The dfun ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: IsOrphan } -- See Note [Orphans] in InstEnv + ifInstOrph :: IsOrphan } -- See Note [Orphans] in GHC.Core.InstEnv -- There's always a separate IfaceDecl for the DFun, which gives -- its IdInfo with its full type and version number. -- The instance declarations taken together have a version number, @@ -1200,7 +1200,7 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent -- 3. Pretty-print the data type constructor applied to its arguments. -- This process will omit any invisible arguments, such as coercion -- variables, if necessary. (See Note - -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.) + -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.) ppr_tc_app gadt_subst = pprPrefixIfDeclBndr how_much (occName tycon) <+> pprParendIfaceAppArgs diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index c305f60dd3..0472dee50b 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -27,8 +27,8 @@ import GHC.Core.Stats (coreBindsStats, CoreStats(..)) import GHC.Core.Seq (seqBinds) import GHC.Core.Lint import GHC.Core.Rules -import PatSyn -import ConLike +import GHC.Core.PatSyn +import GHC.Core.ConLike import GHC.Core.Arity ( exprArity, exprBotStrictness_maybe ) import StaticPtrTable import VarEnv @@ -37,8 +37,8 @@ import Var import Id import MkId ( mkDictSelRhs ) import IdInfo -import InstEnv -import Type ( tidyTopType ) +import GHC.Core.InstEnv +import GHC.Core.Type ( tidyTopType ) import Demand ( appIsBottom, isTopSig, isBottomingSig ) import Cpr ( mkCprSig, botCpr ) import BasicTypes @@ -49,9 +49,9 @@ import Avail import GHC.Iface.Env import TcEnv import TcRnMonad -import DataCon -import TyCon -import Class +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.Class import Module import GHC.Driver.Types import Maybes @@ -1349,7 +1349,7 @@ mustExposeTyCon no_trim_types exports tc | null data_cons -- Ditto if there are no data constructors = True -- (NB: empty data types do not count as enumerations - -- see Note [Enumeration types] in TyCon + -- see Note [Enumeration types] in GHC.Core.TyCon | any exported_con data_cons -- Expose rep if any datacon or field is exported = True diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 0ff9235d12..8b154248ab 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -64,10 +64,10 @@ import GhcPrelude import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon , liftedRepDataConTyCon, tupleTyConName ) -import {-# SOURCE #-} Type ( isRuntimeRepTy ) +import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy ) -import TyCon hiding ( pprPromotionQuote ) -import CoAxiom +import GHC.Core.TyCon hiding ( pprPromotionQuote ) +import GHC.Core.Coercion.Axiom import Var import PrelNames import Name @@ -567,7 +567,7 @@ stripInvisArgs (PrintExplicitKinds False) tys = suppress_invis tys -- Keep recursing through the remainder of the arguments, as it's -- possible that there are remaining invisible ones. -- See the "In type declarations" section of Note [VarBndrs, - -- TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. + -- TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. | otherwise -> suppress_invis ts @@ -675,7 +675,7 @@ kind application syntax to distinguish the two cases: Here, @{k} indicates that `k` is an inferred argument, and @k indicates that `k` is a specified argument. (See -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep for +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for a lengthier explanation on what "inferred" and "specified" mean.) ************************************************************************ @@ -776,7 +776,7 @@ pprIfaceTyConBinders suppress_sig = sep . map go case vis of AnonTCB VisArg -> ppr_bndr (UseBndrParens True) AnonTCB InvisArg -> char '@' <> braces (ppr_bndr (UseBndrParens False)) - -- The above case is rare. (See Note [AnonTCB InvisArg] in TyCon.) + -- The above case is rare. (See Note [AnonTCB InvisArg] in GHC.Core.TyCon.) -- Should we print these differently? NamedTCB Required -> ppr_bndr (UseBndrParens True) NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True) @@ -967,7 +967,7 @@ defaultRuntimeRepVars ty = go False emptyFsEnv ty go in_kind _ ty@(IfaceFreeTyVar tv) -- See Note [Defaulting RuntimeRep variables], about free vars - | in_kind && Type.isRuntimeRepTy (tyVarKind tv) + | in_kind && GHC.Core.Type.isRuntimeRepTy (tyVarKind tv) = IfaceTyConApp liftedRep IA_Nil | otherwise = ty @@ -1175,7 +1175,7 @@ criteria are met: utterly misleading. See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] - in TyCoRep. + in GHC.Core.TyCo.Rep. N.B. Until now (Aug 2018) we didn't check anything for coercion variables. @@ -1252,7 +1252,7 @@ pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _) pprSpaceIfPromotedTyCon _ = id --- See equivalent function in TyCoRep.hs +-- See equivalent function in GHC.Core.TyCo.Rep.hs pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc -- Given a type-level list (t1 ': t2), see if we can print -- it in list notation [t1, ...]. @@ -1462,7 +1462,7 @@ ppr_iface_tc_app pp ctxt_prec tc tys pprSum :: Arity -> PromotionFlag -> IfaceAppArgs -> SDoc pprSum _arity is_promoted args = -- drop the RuntimeRep vars. - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon let tys = appArgsIfaceTypes args args' = drop (length tys `div` 2) tys in pprPromotionQuoteI is_promoted @@ -1489,7 +1489,7 @@ pprTuple ctxt_prec sort promoted args = | otherwise -> -- drop the RuntimeRep vars. - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon let tys = appArgsIfaceTypes args args' = case sort of UnboxedTuple -> drop (length tys `div` 2) tys diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 1af97d1b6b..ebf3aa588d 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -33,15 +33,15 @@ import GHC.Iface.Env import BuildTyCl import TcRnMonad import TcType -import Type -import Coercion -import CoAxiom -import TyCoRep -- needs to build types & coercions in a knot -import TyCoSubst ( substTyCoVars ) +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom +import GHC.Core.TyCo.Rep -- needs to build types & coercions in a knot +import GHC.Core.TyCo.Subst ( substTyCoVars ) import GHC.Driver.Types import Annotations -import InstEnv -import FamInstEnv +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv import GHC.Core import GHC.Core.Utils import GHC.Core.Unfold @@ -50,10 +50,10 @@ import GHC.Core.Make import Id import MkId import IdInfo -import Class -import TyCon -import ConLike -import DataCon +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon import PrelNames import TysWiredIn import Literal @@ -867,7 +867,7 @@ tc_ax_branch prev_branches , ifaxbRoles = roles, ifaxbIncomps = incomps }) = bindIfaceTyConBinders_AT (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs -> - -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom + -- The _AT variant is needed here; see Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom bindIfaceIds cv_bndrs $ \ cvs -> do { tc_lhs <- tcIfaceAppArgs lhs ; tc_rhs <- tcIfaceType rhs @@ -1176,7 +1176,7 @@ tcIfaceTupleTy sort is_promoted args kind_args = map typeKind args' ; return (mkTyConApp tc (kind_args ++ args')) } } --- See Note [Unboxed tuple RuntimeRep vars] in TyCon +-- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr) -> TupleSort -> Arity -- the number of args. *not* the tuple arity. diff --git a/compiler/GHC/IfaceToCore.hs-boot b/compiler/GHC/IfaceToCore.hs-boot index aea03c8d5d..32e13c80d1 100644 --- a/compiler/GHC/IfaceToCore.hs-boot +++ b/compiler/GHC/IfaceToCore.hs-boot @@ -3,10 +3,10 @@ module GHC.IfaceToCore where import GhcPrelude import GHC.Iface.Syntax ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule , IfaceAnnotation, IfaceCompleteMatch ) -import TyCoRep ( TyThing ) -import TcRnTypes ( IfL ) -import InstEnv ( ClsInst ) -import FamInstEnv ( FamInst ) +import GHC.Core.TyCo.Rep ( TyThing ) +import TcRnTypes ( IfL ) +import GHC.Core.InstEnv ( ClsInst ) +import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core ( CoreRule ) import GHC.Driver.Types ( CompleteMatch ) import Annotations ( Annotation ) diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs index 3de7a1b045..ee6a946cbb 100644 --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -10,11 +10,11 @@ module GHC.Plugins( module GHC.Driver.Plugins, module RdrName, module OccName, module Name, module Var, module Id, module IdInfo, - module CoreMonad, module GHC.Core, module Literal, module DataCon, + module CoreMonad, module GHC.Core, module Literal, module GHC.Core.DataCon, module GHC.Core.Utils, module GHC.Core.Make, module GHC.Core.FVs, module GHC.Core.Subst, module GHC.Core.Rules, module Annotations, module GHC.Driver.Session, module GHC.Driver.Packages, - module Module, module Type, module TyCon, module Coercion, + module Module, module GHC.Core.Type, module GHC.Core.TyCon, module GHC.Core.Coercion, module TysWiredIn, module GHC.Driver.Types, module BasicTypes, module VarSet, module VarEnv, module NameSet, module NameEnv, module UniqSet, module UniqFM, module FiniteMap, @@ -40,7 +40,7 @@ import IdInfo import CoreMonad import GHC.Core import Literal -import DataCon +import GHC.Core.DataCon import GHC.Core.Utils import GHC.Core.Make import GHC.Core.FVs @@ -57,11 +57,11 @@ import GHC.Driver.Packages -- Important GHC types import Module -import Type hiding {- conflict with GHC.Core.Subst -} +import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -} ( substTy, extendTvSubst, extendTvSubstList, isInScope ) -import Coercion hiding {- conflict with GHC.Core.Subst -} +import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -} ( substCo ) -import TyCon +import GHC.Core.TyCon import TysWiredIn import GHC.Driver.Types import BasicTypes hiding ( Version {- conflicts with Packages.Version -} ) diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index d66226579b..a860bdb53f 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -60,9 +60,9 @@ import NameSet import NameEnv import Avail import Module -import ConLike -import DataCon -import TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCon import ErrUtils ( MsgDoc ) import PrelNames ( rOOT_MAIN ) import BasicTypes ( pprWarningTxtForMsg, TopLevelFlag(..), TupleSort(..) ) diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 999389bb02..b04260e3df 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -35,7 +35,7 @@ module GHC.Rename.Names ( import GhcPrelude import GHC.Driver.Session -import TyCoPpr +import GHC.Core.TyCo.Ppr import GHC.Hs import TcEnv import GHC.Rename.Env @@ -61,8 +61,8 @@ import Util import FastString import FastStringEnv import Id -import Type -import PatSyn +import GHC.Core.Type +import GHC.Core.PatSyn import qualified GHC.LanguageExtensions as LangExt import Control.Monad diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 0f8041447b..34450620f0 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -73,7 +73,7 @@ import Outputable import SrcLoc import Literal ( inCharRange ) import TysWiredIn ( nilDataCon ) -import DataCon +import GHC.Core.DataCon import qualified GHC.LanguageExtensions as LangExt import Control.Monad ( when, ap, guard ) diff --git a/compiler/GHC/Rename/Types.hs b/compiler/GHC/Rename/Types.hs index a2d887bad0..d633ac6593 100644 --- a/compiler/GHC/Rename/Types.hs +++ b/compiler/GHC/Rename/Types.hs @@ -1462,7 +1462,7 @@ must come after any variables mentioned in their kinds. The k comes first because a depends on k, even though the k appears later than the a in the code. Thus, GHC does ScopedSort on the variables. -See Note [ScopedSort] in Type. +See Note [ScopedSort] in GHC.Core.Type. Implicitly bound variables are collected by any function which returns a FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 998bd974d9..45bd55b31a 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -43,7 +43,7 @@ import TcRnMonad import Name import NameSet import NameEnv -import DataCon +import GHC.Core.DataCon import SrcLoc import Outputable import Util diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index 0b2ce71122..5ad6a2c6f0 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -30,7 +30,7 @@ import Name import Var hiding ( varName ) import VarSet import UniqSet -import Type +import GHC.Core.Type import GHC import Outputable import GHC.Core.Ppr.TyThing diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 2a51656a95..6ef575490f 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -58,17 +58,17 @@ import GHC.Driver.Monad import GHC.Driver.Main import GHC.Hs import GHC.Driver.Types -import InstEnv -import GHC.Iface.Env ( newInteractiveBinder ) -import FamInstEnv ( FamInst ) -import GHC.Core.FVs ( orphNamesOfFamInst ) -import TyCon -import Type hiding( typeKind ) +import GHC.Core.InstEnv +import GHC.Iface.Env ( newInteractiveBinder ) +import GHC.Core.FamInstEnv ( FamInst ) +import GHC.Core.FVs ( orphNamesOfFamInst ) +import GHC.Core.TyCon +import GHC.Core.Type hiding( typeKind ) import GHC.Types.RepType import TcType import Constraint import TcOrigin -import Predicate +import GHC.Core.Predicate import Var import Id import Name hiding ( varName ) diff --git a/compiler/GHC/Runtime/Eval/Types.hs b/compiler/GHC/Runtime/Eval/Types.hs index 93072075c0..f1e3308f70 100644 --- a/compiler/GHC/Runtime/Eval/Types.hs +++ b/compiler/GHC/Runtime/Eval/Types.hs @@ -20,7 +20,7 @@ import Id import Name import Module import RdrName -import Type +import GHC.Core.Type import SrcLoc import Exception diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index c9905b5801..0daea2181b 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -32,10 +32,10 @@ import GHCi.RemoteTypes import GHC.Driver.Types import GHCi.Message ( fromSerializableException ) -import DataCon -import Type +import GHC.Core.DataCon +import GHC.Core.Type import GHC.Types.RepType -import qualified Unify as U +import qualified GHC.Core.Unify as U import Var import TcRnMonad import TcType @@ -44,7 +44,7 @@ import TcHsSyn ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) import TcUnify import TcEnv -import TyCon +import GHC.Core.TyCon import Name import OccName import Module @@ -833,7 +833,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 go ptr_i arr_i (ty:tys) | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty , isUnboxedTupleTyCon tc - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon = do (ptr_i, arr_i, terms0) <- go ptr_i arr_i (dropRuntimeRepArgs elem_tys) (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 81c332a655..44737c48ed 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -40,9 +40,9 @@ import PrelNames ( pluginTyConName, frontendPluginTyConName ) import GHC.Driver.Types import GHCi.RemoteTypes ( HValue ) -import Type ( Type, eqType, mkTyConTy ) -import TyCoPpr ( pprTyThingCategory ) -import TyCon ( TyCon ) +import GHC.Core.Type ( Type, eqType, mkTyConTy ) +import GHC.Core.TyCo.Ppr ( pprTyThingCategory ) +import GHC.Core.TyCon ( TyCon ) import Name ( Name, nameModule_maybe ) import Id ( idType ) import Module ( Module, ModuleName ) diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs index ec497a8a59..ea9c8e61fa 100644 --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -88,7 +88,7 @@ module GHC.Stg.CSE (stgCse) where import GhcPrelude -import DataCon +import GHC.Core.DataCon import Id import GHC.Stg.Syntax import Outputable diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs index 8cc84172d2..8c0a6d27fc 100644 --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -34,7 +34,7 @@ import Outputable import OrdList import GHC.Stg.Subst import GHC.Stg.Syntax -import Type +import GHC.Core.Type import UniqSupply import Util import VarEnv diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 471bbf763e..3d06815832 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -47,11 +47,11 @@ import BasicTypes ( TopLevelFlag(..), isTopLevel ) import CostCentre ( isCurrentCCS ) import Id ( Id, idType, isJoinId, idName ) import VarSet -import DataCon +import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) import Name ( getSrcLoc, nameIsLocalOrFrom ) import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) -import Type +import GHC.Core.Type import GHC.Types.RepType import SrcLoc import Outputable diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 1b8381b1b7..534cdbfbcb 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -68,7 +68,7 @@ import CostCentre ( CostCentreStack ) import Data.ByteString ( ByteString ) import Data.Data ( Data ) import Data.List ( intersperse ) -import DataCon +import GHC.Core.DataCon import GHC.Driver.Session import ForeignCall ( ForeignCall ) import Id @@ -80,9 +80,9 @@ import GHC.Driver.Packages ( isDynLinkName ) import GHC.Platform import GHC.Core.Ppr( {- instances -} ) import PrimOp ( PrimOp, PrimCall ) -import TyCon ( PrimRep(..), TyCon ) -import Type ( Type ) -import GHC.Types.RepType ( typePrimRep1 ) +import GHC.Core.TyCon ( PrimRep(..), TyCon ) +import GHC.Core.Type ( Type ) +import GHC.Types.RepType ( typePrimRep1 ) import Util import Data.List.NonEmpty ( NonEmpty, toList ) diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index cf47d204af..98738470b2 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -204,7 +204,7 @@ import GhcPrelude import BasicTypes import GHC.Core -import DataCon +import GHC.Core.DataCon import FastString (FastString, mkFastString) import Id import Literal @@ -214,7 +214,7 @@ import MonadUtils (mapAccumLM) import Outputable import GHC.Types.RepType import GHC.Stg.Syntax -import Type +import GHC.Core.Type import TysPrim (intPrimTy,wordPrimTy,word64PrimTy) import TysWiredIn import UniqSupply diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index e5aaf7f5b6..1100cf4705 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -38,8 +38,8 @@ import CostCentre import Id import IdInfo import GHC.Types.RepType -import DataCon -import TyCon +import GHC.Core.DataCon +import GHC.Core.TyCon import Module import Outputable import Stream diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs index bd9abbfdea..26532b974d 100644 --- a/compiler/GHC/StgToCmm/ArgRep.hs +++ b/compiler/GHC/StgToCmm/ArgRep.hs @@ -19,9 +19,9 @@ import GhcPrelude import GHC.StgToCmm.Closure ( idPrimRep ) -import GHC.Runtime.Heap.Layout ( WordOff ) +import GHC.Runtime.Heap.Layout ( WordOff ) import Id ( Id ) -import TyCon ( PrimRep(..), primElemRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) import BasicTypes ( RepArity ) import Constants ( wORD64_SIZE ) import GHC.Driver.Session diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index d42a7f4764..7bb73111a9 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -76,12 +76,12 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import Id import IdInfo -import DataCon +import GHC.Core.DataCon import Name -import Type -import TyCoRep +import GHC.Core.Type +import GHC.Core.TyCo.Rep import TcType -import TyCon +import GHC.Core.TyCon import GHC.Types.RepType import BasicTypes import Outputable diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 199417ad34..43e2ab8e9a 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -36,7 +36,7 @@ import GHC.Cmm.Graph import GHC.Runtime.Heap.Layout import CostCentre import Module -import DataCon +import GHC.Core.DataCon import GHC.Driver.Session import FastString import Id diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs index a0c49e69ee..fe886644c4 100644 --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -26,7 +26,7 @@ module GHC.StgToCmm.Env ( import GhcPrelude -import TyCon +import GHC.Core.TyCon import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure @@ -42,7 +42,7 @@ import GHC.Cmm.Graph import Name import Outputable import GHC.Stg.Syntax -import Type +import GHC.Core.Type import TysPrim import UniqFM import Util diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index cf0d4be8bc..f8e2cbd73d 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -37,15 +37,15 @@ import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Core -import DataCon -import GHC.Driver.Session ( mAX_PTR_TAG ) +import GHC.Core.DataCon +import GHC.Driver.Session ( mAX_PTR_TAG ) import ForeignCall import Id import PrimOp -import TyCon -import Type ( isUnliftedType ) -import GHC.Types.RepType ( isVoidTy, countConRepArgs ) -import CostCentre ( CostCentreStack, currentCCS ) +import GHC.Core.TyCon +import GHC.Core.Type ( isUnliftedType ) +import GHC.Types.RepType ( isVoidTy, countConRepArgs ) +import CostCentre ( CostCentreStack, currentCCS ) import Maybes import Util import FastString diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs index 04b8478c0f..b083736b20 100644 --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -32,7 +32,7 @@ import GHC.Cmm.BlockId (newBlockId) import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Graph -import Type +import GHC.Core.Type import GHC.Types.RepType import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout @@ -43,7 +43,7 @@ import Outputable import UniqSupply import BasicTypes -import TyCoRep +import GHC.Core.TyCo.Rep import TysPrim import Util (zipEqual) diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index 1438077fd5..cf2024fa31 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -50,7 +50,7 @@ import GHC.Cmm.Info import GHC.Cmm.CLabel import GHC.Stg.Syntax import Id -import TyCon ( PrimRep(..), primRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), primRepSizeB ) import BasicTypes ( RepArity ) import GHC.Driver.Session import Module diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index d9ab05eebb..2555d764db 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -43,8 +43,8 @@ import GHC.Cmm.Graph import GHC.Stg.Syntax import GHC.Cmm import Module ( rtsUnitId ) -import Type ( Type, tyConAppTyCon ) -import TyCon +import GHC.Core.Type ( Type, tyConAppTyCon ) +import GHC.Core.TyCon import GHC.Cmm.CLabel import GHC.Cmm.Utils import PrimOp diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index 4257f02886..5968b9a944 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -131,8 +131,8 @@ import GHC.Driver.Session -- Turgid imports for showTypeCategory import PrelNames import TcType -import TyCon -import Predicate +import GHC.Core.TyCon +import GHC.Core.Predicate import Data.Maybe import qualified Data.Char diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 310bf70a7c..e576c2d95e 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -64,8 +64,8 @@ import GHC.StgToCmm.CgUtils import ForeignCall import IdInfo -import Type -import TyCon +import GHC.Core.Type +import GHC.Core.TyCon import GHC.Runtime.Heap.Layout import Module import Literal diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 7c9077d516..b881186799 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -34,8 +34,8 @@ import Module import RdrHsSyn import OccName import SrcLoc -import Type -import qualified Coercion ( Role(..) ) +import GHC.Core.Type +import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import TysWiredIn import BasicTypes as Hs import ForeignCall diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs index cdda659688..3a76dde256 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -26,13 +26,13 @@ module GHC.Types.RepType import GhcPrelude import BasicTypes (Arity, RepArity) -import DataCon +import GHC.Core.DataCon import Outputable import PrelNames -import Coercion -import TyCon -import TyCoRep -import Type +import GHC.Core.Coercion +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type import Util import TysPrim import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind ) |