diff options
Diffstat (limited to 'compiler/types')
| -rw-r--r-- | compiler/types/Class.hs | 20 | ||||
| -rw-r--r-- | compiler/types/CoAxiom.hs | 34 | ||||
| -rw-r--r-- | compiler/types/Coercion.hs | 2495 | ||||
| -rw-r--r-- | compiler/types/Coercion.hs-boot | 46 | ||||
| -rw-r--r-- | compiler/types/FamInstEnv.hs | 511 | ||||
| -rw-r--r-- | compiler/types/InstEnv.hs | 24 | ||||
| -rw-r--r-- | compiler/types/Kind.hs | 297 | ||||
| -rw-r--r-- | compiler/types/OptCoercion.hs | 568 | ||||
| -rw-r--r-- | compiler/types/TyCoRep.hs | 2496 | ||||
| -rw-r--r-- | compiler/types/TyCoRep.hs-boot (renamed from compiler/types/TypeRep.hs-boot) | 9 | ||||
| -rw-r--r-- | compiler/types/TyCon.hs | 211 | ||||
| -rw-r--r-- | compiler/types/Type.hs | 1895 | ||||
| -rw-r--r-- | compiler/types/Type.hs-boot | 15 | ||||
| -rw-r--r-- | compiler/types/TypeRep.hs | 1020 | ||||
| -rw-r--r-- | compiler/types/Unify.hs | 1237 |
15 files changed, 6658 insertions, 4220 deletions
diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs index a1d5a400dd..bb7cdaf124 100644 --- a/compiler/types/Class.hs +++ b/compiler/types/Class.hs @@ -17,19 +17,22 @@ module Class ( mkClass, classTyVars, classArity, classKey, className, classATs, classATItems, classTyCon, classMethods, classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, - classAllSelIds, classSCSelId, classMinimalDef, classHasFds + classAllSelIds, classSCSelId, classMinimalDef, classHasFds, + naturallyCoherentClass ) where #include "HsVersions.h" import {-# SOURCE #-} TyCon ( TyCon, tyConName, tyConUnique ) -import {-# SOURCE #-} TypeRep ( Type, PredType ) +import {-# SOURCE #-} TyCoRep ( Type, PredType ) import Var import Name import BasicTypes import Unique import Util import SrcLoc +import PrelNames ( eqTyConKey, coercibleTyConKey, typeableClassKey, + heqTyConKey ) import Outputable import FastString import BooleanFormula (BooleanFormula) @@ -51,7 +54,7 @@ data Class = Class { classTyCon :: TyCon, -- The data type constructor for -- dictionaries of this class - -- See Note [ATyCon for classes] in TypeRep + -- See Note [ATyCon for classes] in TyCoRep className :: Name, -- Just the cached name of the TyCon classKey :: Unique, -- Cached unique of TyCon @@ -59,7 +62,7 @@ data Class classTyVars :: [TyVar], -- The class kind and type variables; -- identical to those of the TyCon - classFunDeps :: [FunDep TyVar], -- The functional dependencies + classFunDeps :: [FunDep TyVar], -- The functional dependencies -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) -- We need value-level selectors for both the dictionary @@ -255,6 +258,15 @@ classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, classATStuff = ats, classOpStuff = op_stuff}) = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) +-- | If a class is "naturally coherent", then we needn't worry at all, in any +-- way, about overlapping/incoherent instances. Just solve the thing! +naturallyCoherentClass :: Class -> Bool +naturallyCoherentClass cls + = cls `hasKey` heqTyConKey || + cls `hasKey` eqTyConKey || + cls `hasKey` coercibleTyConKey || + cls `hasKey` typeableClassKey + {- ************************************************************************ * * diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs index 5b049a40f9..01c6502f5e 100644 --- a/compiler/types/CoAxiom.hs +++ b/compiler/types/CoAxiom.hs @@ -18,7 +18,8 @@ module CoAxiom ( coAxiomName, coAxiomArity, coAxiomBranches, coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, - coAxiomSingleBranch, coAxBranchTyVars, coAxBranchRoles, + coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars, + coAxBranchRoles, coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, placeHolderIncomps, @@ -28,7 +29,7 @@ module CoAxiom ( BuiltInSynFamily(..), trivialBuiltInFamily ) where -import {-# SOURCE #-} TypeRep ( Type ) +import {-# SOURCE #-} TyCoRep ( Type ) import {-# SOURCE #-} TyCon ( TyCon ) import Outputable import FastString @@ -64,9 +65,9 @@ type family F a where This will give rise to this axiom: -axF :: { F [Int] ~ Bool - ; forall (a :: *). F [a] ~ Double - ; forall (k :: BOX) (a :: k -> *) (b :: k). F (a b) ~ Char +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 @@ -222,6 +223,10 @@ data CoAxBranch -- See Note [CoAxiom locations] , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh -- See Note [CoAxBranch type variables] + , 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 @@ -247,7 +252,9 @@ coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index coAxiomArity :: CoAxiom br -> BranchIndex -> Arity coAxiomArity ax index - = length $ cab_tvs $ coAxiomNthBranch 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 @@ -275,6 +282,9 @@ coAxiomTyCon = co_ax_tc coAxBranchTyVars :: CoAxBranch -> [TyVar] coAxBranchTyVars = cab_tvs +coAxBranchCoVars :: CoAxBranch -> [CoVar] +coAxBranchCoVars = cab_cvs + coAxBranchLHS :: CoAxBranch -> [Type] coAxBranchLHS = cab_lhs @@ -395,6 +405,13 @@ instance Typeable br => Data.Data (CoAxiom br) where 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 <+> ppr lhs <+> + text "=>" <+> ppr rhs + {- ************************************************************************ * * @@ -408,7 +425,7 @@ Roles are defined here to avoid circular dependencies. -- See Note [Roles] in Coercion -- defined here to avoid cyclic dependency with Coercion data Role = Nominal | Representational | Phantom - deriving (Eq, Data.Data, Data.Typeable) + deriving (Eq, Ord, Data.Data, Data.Typeable) -- These names are slurped into the parser code. Changing these strings -- will change the **surface syntax** that GHC accepts! If you want to @@ -457,10 +474,9 @@ type Eqn = Pair Type -- | For now, we work only with nominal equality. data CoAxiomRule = CoAxiomRule { coaxrName :: FastString - , coaxrTypeArity :: Int -- number of type argumentInts , coaxrAsmpRoles :: [Role] -- roles of parameter equations , coaxrRole :: Role -- role of resulting equation - , coaxrProves :: [Type] -> [Eqn] -> Maybe Eqn + , coaxrProves :: [Eqn] -> Maybe Eqn -- ^ 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 diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs index 9aff2c4407..277936960f 100644 --- a/compiler/types/Coercion.hs +++ b/compiler/types/Coercion.hs @@ -1,6 +1,8 @@ --- (c) The University of Glasgow 2006 +{- +(c) The University of Glasgow 2006 +-} -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes, CPP, DeriveDataTypeable, MultiWayIf #-} -- | Module for (a) type kinds and (b) type coercions, -- as used in System FC. See 'CoreSyn.Expr' for @@ -8,27 +10,36 @@ -- module Coercion ( -- * Main data type - Coercion(..), CoercionN, CoercionR, - Var, CoVar, - LeftOrRight(..), pickLR, + Coercion, CoercionN, CoercionR, CoercionP, + UnivCoProvenance, CoercionHole, LeftOrRight(..), + Var, CoVar, TyCoVar, Role(..), ltRole, -- ** Functions over coercions - coVarKind, coVarRole, - coercionType, coercionKind, coercionKinds, isReflCo, - isReflCo_maybe, coercionRole, coercionKindRole, + coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole, + coercionType, coercionKind, coercionKinds, mkCoercionType, + coercionRole, coercionKindRole, -- ** Constructing coercions - mkReflCo, mkCoVarCo, - mkAxInstCo, mkUnbranchedAxInstCo, mkAxInstLHS, mkAxInstRHS, - mkUnbranchedAxInstRHS, + mkReflCo, mkRepReflCo, mkNomReflCo, + mkCoVarCo, mkCoVarCos, + mkAxInstCo, mkUnbranchedAxInstCo, + mkAxInstRHS, mkUnbranchedAxInstRHS, + mkAxInstLHS, mkUnbranchedAxInstLHS, mkPiCo, mkPiCos, mkCoCast, - mkSymCo, mkTransCo, mkNthCo, mkNthCoRole, mkLRCo, - mkInstCo, mkAppCo, mkAppCoFlexible, mkTyConAppCo, mkFunCo, - mkForAllCo, mkUnsafeCo, mkUnivCo, mkSubCo, mkPhantomCo, - mkNewTypeCo, downgradeRole, - mkAxiomRuleCo, + mkSymCo, mkTransCo, mkTransAppCo, + mkNthCo, mkNthCoRole, mkLRCo, + mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunCos, + mkForAllCo, mkForAllCos, mkHomoForAllCos, mkHomoForAllCos_NoRefl, + mkPhantomCo, mkHomoPhantomCo, toPhantomCo, + mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo, + mkNewTypeCo, mkAxiomInstCo, mkProofIrrelCo, + downgradeRole, maybeSubCo, mkAxiomRuleCo, + mkCoherenceCo, mkCoherenceRightCo, mkCoherenceLeftCo, + mkKindCo, castCoercionKind, + + mkHeteroCoercionType, -- ** Decomposition instNewTyCon_maybe, @@ -38,506 +49,109 @@ module Coercion ( topNormaliseNewType_maybe, topNormaliseTypeX_maybe, decomposeCo, getCoVar_maybe, + splitTyConAppCo_maybe, splitAppCo_maybe, splitForAllCo_maybe, - nthRole, tyConRolesX, - setNominalRole_maybe, + + nthRole, tyConRolesX, setNominalRole_maybe, + + pickLR, + + isReflCo, isReflCo_maybe, -- ** Coercion variables - mkCoVar, isCoVar, isCoVarType, coVarName, setCoVarName, setCoVarUnique, + mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, + isCoVar_maybe, -- ** Free variables - tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, coercionSize, - tyCoVarsOfCoAcc, tyCoVarsOfCosAcc, + tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, + tyCoVarsOfCoAcc, tyCoVarsOfCosAcc, tyCoVarsOfCoDSet, + coercionSize, -- ** Substitution CvSubstEnv, emptyCvSubstEnv, - CvSubst(..), emptyCvSubst, Coercion.lookupTyVar, lookupCoVar, - isEmptyCvSubst, zapCvSubstEnv, getCvInScope, - substCo, substCos, substCoVar, substCoVars, - substCoWithTy, substCoWithTys, - cvTvSubst, tvCvSubst, mkCvSubst, zipOpenCvSubst, - substTy, extendTvSubst, - extendCvSubstAndInScope, extendTvSubstAndInScope, - substTyVarBndr, substCoVarBndr, + lookupCoVar, + substCo, substCos, substCoVar, substCoVars, substCoWith, + substCoVarBndr, + extendTCvSubstAndInScope, getCvSubstEnv, -- ** Lifting - liftCoMatch, liftCoSubstTyVar, liftCoSubstWith, + liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, + emptyLiftingContext, extendLiftingContext, + liftCoSubstVarBndrCallback, isMappedByLC, + + mkSubstLiftingContext, zapLiftingContext, + substForAllCoBndrCallbackLC, lcTCvSubst, lcInScopeSet, + + LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, + substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, -- ** Comparison - coreEqCoercion, coreEqCoercion2, + eqCoercion, eqCoercionX, -- ** Forcing evaluation of coercions seqCo, -- * Pretty-printing - pprCo, pprParendCo, + pprCo, pprParendCo, pprCoBndr, pprCoAxiom, pprCoAxBranch, pprCoAxBranchHdr, -- * Tidying tidyCo, tidyCos, -- * Other - applyCo, + promoteCoercion ) where #include "HsVersions.h" -import Unify ( MatchEnv(..), matchList ) -import TypeRep -import qualified Type -import Type hiding( substTy, substTyVarBndr, extendTvSubst ) +import TyCoRep +import Type import TyCon import CoAxiom import Var import VarEnv -import VarSet -import Binary -import Maybes ( orElse ) -import Name ( Name, NamedThing(..), nameUnique, nameModule, getSrcSpan ) -import OccName ( parenSymOcc ) +import Name hiding ( varName ) import Util import BasicTypes import Outputable import Unique import Pair import SrcLoc -import PrelNames ( funTyConKey, eqPrimTyConKey, eqReprPrimTyConKey ) +import PrelNames +import TysPrim ( eqPhantPrimTyCon ) +import ListSetOps +import Maybes + #if __GLASGOW_HASKELL__ < 709 import Control.Applicative hiding ( empty ) +import Prelude hiding ( and ) import Data.Traversable (traverse, sequenceA) +import Data.Foldable ( and ) #endif +import Control.Monad (foldM) import FastString -import ListSetOps -import FV - -import qualified Data.Data as Data hiding ( TyCon ) import Control.Arrow ( first ) +import Data.Function ( on ) -{- -************************************************************************ -* * - Coercions -* * -************************************************************************ --} +----------------------------------------------------------------- +-- These synonyms are very useful as documentation -type CoercionR = Coercion -- A coercion at Representation role ~R -type CoercionN = Coercion -- A coercion at Nominal role ~N - --- | 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 coreSyn/CoreLint.hs -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 :: "e" -> _ -> e - Refl Role 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 (Refl Representational _), not (SubCo (Refl 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 Coercion -- lift AppTy - -- AppCo :: e -> N -> e - - -- See Note [Forall coercions] - | ForAllCo TyVar Coercion -- forall a. g - -- :: _ -> e -> e - - -- These are special - | CoVarCo CoVar -- :: _ -> (N or R) - -- result role depends on the tycon of the variable's type - - -- AxiomInstCo :: e -> _ -> [N] -> e - | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] - -- See also [CoAxiom index] +type CoercionN = Coercion -- nominal coercion +type CoercionR = Coercion -- representational coercion +type CoercionP = Coercion -- phantom coercion + +{- +%************************************************************************ +%* * -- 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] - -- see Note [UnivCo] - | UnivCo FastString Role Type Type -- :: "e" -> _ -> _ -> e - -- the FastString is just a note for provenance - | SymCo Coercion -- :: e -> e - | TransCo Coercion Coercion -- :: e -> e -> e - - -- The number of types and coercions should match exactly the expectations - -- of the CoAxiomRule (i.e., the rule is fully saturated). - | AxiomRuleCo CoAxiomRule [Type] [Coercion] - - -- These are destructors - - | NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) - -- and (F t0 ... tn), assuming F is injective. - -- :: _ -> e -> ?? (inverse of TyConAppCo, see Note [TyConAppCo roles]) - -- See Note [NthCo and newtypes] - - | LRCo LeftOrRight Coercion -- Decomposes (t_left t_right) - -- :: _ -> N -> N - | InstCo Coercion Type - -- :: e -> _ -> e - - | SubCo Coercion -- Turns a ~N into a ~R - -- :: N -> R - deriving (Data.Data, Data.Typeable) - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data LeftOrRight = CLeft | CRight - deriving( Eq, Data.Data, Data.Typeable ) - -instance Binary LeftOrRight where - put_ bh CLeft = putByte bh 0 - put_ bh CRight = putByte bh 1 - - get bh = do { h <- getByte bh - ; case h of - 0 -> return CLeft - _ -> return CRight } - -pickLR :: LeftOrRight -> (a,a) -> a -pickLR CLeft (l,_) = l -pickLR CRight (_,r) = r - -{- -Note [Refl invariant] -~~~~~~~~~~~~~~~~~~~~~ -Coercions have the following invariant - Refl is always lifted as far as possible. - -You might think that a consequencs 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 [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. -Currently, the situation is as follows: - - ForAllCo TyVar Coercion - -represents a coercion between polymorphic types, with the rule - - v : k g : t1 ~ t2 - ---------------------------------------------- - ForAllCo v g : (all v:k . t1) ~ (all v:k . t2) - -Note that it's only necessary to coerce between polymorphic types -where the type variables have identical kinds, because equality on -kinds is trivial. - -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 [Kind coercions] -~~~~~~~~~~~~~~~~~~~~~ -Suppose T :: * -> *, and g :: A ~ B -Then the coercion - TyConAppCo T [g] T g : T A ~ T B - -Now suppose S :: forall k. k -> *, and g :: A ~ B -Then the coercion - TyConAppCo S [Refl *, g] T <*> g : T * A ~ T * B - -Notice that the arguments to TyConAppCo are coercions, but the first -represents a *kind* coercion. Now, we don't allow any non-trivial kind -coercions, so it's an invariant that any such kind coercions are Refl. -Lint checks this. - -However it's inconvenient to insist that these kind coercions are always -*structurally* (Refl k), because the key function exprIsConApp_maybe -pushes coercions into constructor arguments, so - C k ty e |> g -may turn into - C (Nth 0 g) .... -Now (Nth 0 g) will optimise to Refl, but perhaps not instantly. - -Note [Roles] -~~~~~~~~~~~~ -Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated -in Trac #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see -http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation - -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 [UnivCo] -~~~~~~~~~~~~~ -The UnivCo ("universal coercion") serves two rather separate functions: - - the implementation for unsafeCoerce# - - placeholder for phantom parameters in a TyConAppCo - -At Representational, it asserts that two (possibly unrelated) -types have the same representation and can be casted to one another. -This form is necessary for unsafeCoerce#. - -For optimisation purposes, it is convenient to allow UnivCo to appear -at Nominal role. If we have - -data Foo a = MkFoo (F a) -- F is a type family - -and we want an unsafe coercion from Foo Int to Foo Bool, then it would -be nice to have (TyConAppCo Foo (UnivCo Nominal Int Bool)). So, we allow -Nominal UnivCo's. - -At Phantom role, it is used as an argument to TyConAppCo in the place -of a phantom parameter (a type parameter unused in the type definition). - -For example: - -data Q a = MkQ Int - -We want a coercion for (Q Bool) ~R (Q Char). - -(TyConAppCo Representational Q [UnivCo Phantom Bool Char]) does the trick. - -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 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). - -************************************************************************ -* * \subsection{Coercion variables} -* * -************************************************************************ +%* * +%************************************************************************ -} coVarName :: CoVar -> Name @@ -549,141 +163,37 @@ setCoVarUnique = setVarUnique setCoVarName :: CoVar -> Name -> CoVar setCoVarName = setVarName -isCoVar :: Var -> Bool -isCoVar v = isCoVarType (varType v) - -isCoVarType :: Type -> Bool -isCoVarType ty -- Tests for t1 ~# t2, the unboxed equality - = case splitTyConApp_maybe ty of - Just (tc,tys) -> (tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey) - && tys `lengthAtLeast` 2 - Nothing -> False - -tyCoVarsOfCo :: Coercion -> VarSet -tyCoVarsOfCo co = runFVSet $ tyCoVarsOfCoAcc co --- Extracts type and coercion variables from a coercion - -tyCoVarsOfCos :: [Coercion] -> VarSet -tyCoVarsOfCos cos = runFVSet $ tyCoVarsOfCosAcc cos - -tyCoVarsOfCoAcc :: Coercion -> FV -tyCoVarsOfCoAcc (Refl _ ty) fv_cand in_scope acc = - tyVarsOfTypeAcc ty fv_cand in_scope acc -tyCoVarsOfCoAcc (TyConAppCo _ _ cos) fv_cand in_scope acc = - tyCoVarsOfCosAcc cos fv_cand in_scope acc -tyCoVarsOfCoAcc (AppCo co1 co2) fv_cand in_scope acc = - (tyCoVarsOfCoAcc co1 `unionFV` tyCoVarsOfCoAcc co2) fv_cand in_scope acc -tyCoVarsOfCoAcc (ForAllCo tv co) fv_cand in_scope acc = - delFV tv (tyCoVarsOfCoAcc co) fv_cand in_scope acc -tyCoVarsOfCoAcc (CoVarCo v) fv_cand in_scope acc = oneVar v fv_cand in_scope acc -tyCoVarsOfCoAcc (AxiomInstCo _ _ cos) fv_cand in_scope acc = - tyCoVarsOfCosAcc cos fv_cand in_scope acc -tyCoVarsOfCoAcc (UnivCo _ _ ty1 ty2) fv_cand in_scope acc = - (tyVarsOfTypeAcc ty1 `unionFV` tyVarsOfTypeAcc ty2) fv_cand in_scope acc -tyCoVarsOfCoAcc (SymCo co) fv_cand in_scope acc = - tyCoVarsOfCoAcc co fv_cand in_scope acc -tyCoVarsOfCoAcc (TransCo co1 co2) fv_cand in_scope acc = - (tyCoVarsOfCoAcc co1 `unionFV` tyCoVarsOfCoAcc co2) fv_cand in_scope acc -tyCoVarsOfCoAcc (NthCo _ co) fv_cand in_scope acc = - tyCoVarsOfCoAcc co fv_cand in_scope acc -tyCoVarsOfCoAcc (LRCo _ co) fv_cand in_scope acc = - tyCoVarsOfCoAcc co fv_cand in_scope acc -tyCoVarsOfCoAcc (InstCo co ty) fv_cand in_scope acc = - (tyCoVarsOfCoAcc co `unionFV` tyVarsOfTypeAcc ty) fv_cand in_scope acc -tyCoVarsOfCoAcc (SubCo co) fv_cand in_scope acc = - tyCoVarsOfCoAcc co fv_cand in_scope acc -tyCoVarsOfCoAcc (AxiomRuleCo _ ts cs) fv_cand in_scope acc = - (tyVarsOfTypesAcc ts `unionFV` tyCoVarsOfCosAcc cs) fv_cand in_scope acc - -tyCoVarsOfCosAcc :: [Coercion] -> FV -tyCoVarsOfCosAcc (co:cos) fv_cand in_scope acc = - (tyCoVarsOfCoAcc co `unionFV` tyCoVarsOfCosAcc cos) fv_cand in_scope acc -tyCoVarsOfCosAcc [] fv_cand in_scope acc = noVars fv_cand in_scope acc - -coVarsOfCo :: Coercion -> VarSet --- Extract *coerction* variables only. Tiresome to repeat the code, but easy. -coVarsOfCo (Refl _ _) = emptyVarSet -coVarsOfCo (TyConAppCo _ _ cos) = coVarsOfCos cos -coVarsOfCo (AppCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 -coVarsOfCo (ForAllCo _ co) = coVarsOfCo co -coVarsOfCo (CoVarCo v) = unitVarSet v -coVarsOfCo (AxiomInstCo _ _ cos) = coVarsOfCos cos -coVarsOfCo (UnivCo _ _ _ _) = emptyVarSet -coVarsOfCo (SymCo co) = coVarsOfCo co -coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 -coVarsOfCo (NthCo _ co) = coVarsOfCo co -coVarsOfCo (LRCo _ co) = coVarsOfCo co -coVarsOfCo (InstCo co _) = coVarsOfCo co -coVarsOfCo (SubCo co) = coVarsOfCo co -coVarsOfCo (AxiomRuleCo _ _ cos) = coVarsOfCos cos - -coVarsOfCos :: [Coercion] -> VarSet -coVarsOfCos = mapUnionVarSet coVarsOfCo - coercionSize :: Coercion -> Int -coercionSize (Refl _ ty) = typeSize ty -coercionSize (TyConAppCo _ _ cos) = 1 + sum (map coercionSize cos) -coercionSize (AppCo co1 co2) = coercionSize co1 + coercionSize co2 -coercionSize (ForAllCo _ co) = 1 + coercionSize co -coercionSize (CoVarCo _) = 1 -coercionSize (AxiomInstCo _ _ cos) = 1 + sum (map coercionSize cos) -coercionSize (UnivCo _ _ ty1 ty2) = typeSize ty1 + typeSize ty2 -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 ty) = 1 + coercionSize co + typeSize ty -coercionSize (SubCo co) = 1 + coercionSize co -coercionSize (AxiomRuleCo _ tys cos) = 1 + sum (map typeSize tys) - + sum (map coercionSize cos) +coercionSize (Refl _ ty) = typeSize ty +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 (CoVarCo _) = 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 (CoherenceCo c1 c2) = 1 + coercionSize c1 + coercionSize c2 +coercionSize (KindCo co) = 1 + coercionSize co +coercionSize (SubCo co) = 1 + coercionSize co +coercionSize (AxiomRuleCo _ cs) = 1 + sum (map coercionSize cs) + +provSize :: UnivCoProvenance -> Int +provSize UnsafeCoerceProv = 1 +provSize (PhantomProv co) = 1 + coercionSize co +provSize (ProofIrrelProv co) = 1 + coercionSize co +provSize (PluginProv _) = 1 +provSize (HoleProv h) = pprPanic "provSize hits a hole" (ppr h) {- -************************************************************************ -* * - Tidying coercions -* * -************************************************************************ --} - -tidyCo :: TidyEnv -> Coercion -> Coercion -tidyCo env@(_, subst) co - = go co - where - go (Refl r ty) = Refl r (tidyType env ty) - 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 co) = ForAllCo tvp $! (tidyCo envp co) - where - (envp, tvp) = tidyTyVarBndr env tv - go (CoVarCo cv) = case lookupVarEnv subst cv of - Nothing -> CoVarCo cv - Just cv' -> CoVarCo cv' - go (AxiomInstCo con ind cos) = let args = tidyCos env cos - in args `seqList` AxiomInstCo con ind args - go (UnivCo s r ty1 ty2) = (UnivCo s r $! tidyType env ty1) $! tidyType env ty2 - go (SymCo co) = SymCo $! go co - go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 - go (NthCo d co) = NthCo d $! go co - go (LRCo lr co) = LRCo lr $! go co - go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty - go (SubCo co) = SubCo $! go co - - go (AxiomRuleCo ax tys cos) = let tys1 = map (tidyType env) tys - cos1 = tidyCos env cos - in tys1 `seqList` cos1 `seqList` - AxiomRuleCo ax tys1 cos1 - - -tidyCos :: TidyEnv -> [Coercion] -> [Coercion] -tidyCos env = map (tidyCo env) - -{- -************************************************************************ -* * +%************************************************************************ +%* * Pretty-printing coercions -* * -************************************************************************ +%* * +%************************************************************************ @pprCo@ is the standard @Coercion@ printer; the overloaded @ppr@ function is defined to use this. @pprParendCo@ is the same, except it @@ -692,8 +202,7 @@ puts parens around the type, except for the atomic cases. very high. -} -instance Outputable Coercion where - ppr = pprCo +-- Outputable instances are in TyCoRep, to avoid orphans pprCo, pprParendCo :: Coercion -> SDoc pprCo co = ppr_co TopPrec co @@ -705,47 +214,44 @@ ppr_co _ (Refl r ty) = angleBrackets (ppr ty) <> ppr_role r ppr_co p co@(TyConAppCo _ tc [_,_]) | tc `hasKey` funTyConKey = ppr_fun_co p co -ppr_co _ (TyConAppCo r tc cos) = pprTcApp TyConPrec ppr_co tc cos <> ppr_role r -ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $ - pprCo co1 <+> ppr_co TyConPrec co2 -ppr_co p co@(ForAllCo {}) = ppr_forall_co p co -ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) -ppr_co p (AxiomInstCo con index cos) +ppr_co _ (TyConAppCo r tc cos) = pprTcAppCo TyConPrec ppr_co tc cos <> ppr_role r +ppr_co p (AppCo co arg) = maybeParen p TyConPrec $ + pprCo co <+> ppr_co TyConPrec arg +ppr_co p co@(ForAllCo {}) = ppr_forall_co p co +ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) +ppr_co p (AxiomInstCo con index args) = pprPrefixApp p (ppr (getName con) <> brackets (ppr index)) - (map (ppr_co TyConPrec) cos) + (map (ppr_co TyConPrec) args) ppr_co p co@(TransCo {}) = maybeParen p FunPrec $ case trans_co_list co [] of [] -> panic "ppr_co" (co:cos) -> sep ( ppr_co FunPrec co : [ char ';' <+> ppr_co FunPrec co | co <- cos]) -ppr_co p (InstCo co ty) = maybeParen p TyConPrec $ - pprParendCo co <> ptext (sLit "@") <> pprType ty - -ppr_co p (UnivCo s r ty1 ty2) = pprPrefixApp p (ptext (sLit "UnivCo") <+> ftext s <+> ppr r) - [pprParendType ty1, pprParendType ty2] -ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co] -ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <> int n) [pprParendCo co] -ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co] -ppr_co p (SubCo co) = pprPrefixApp p (ptext (sLit "Sub")) [pprParendCo co] -ppr_co p (AxiomRuleCo co ts cs) = maybeParen p TopPrec $ - ppr_axiom_rule_co co ts cs +ppr_co p (InstCo co arg) = maybeParen p TyConPrec $ + pprParendCo co <> ptext (sLit "@") <> ppr_co TopPrec arg -ppr_axiom_rule_co :: CoAxiomRule -> [Type] -> [Coercion] -> SDoc -ppr_axiom_rule_co co ts ps = ppr (coaxrName co) <> ppTs ts $$ nest 2 (ppPs ps) +ppr_co p (UnivCo UnsafeCoerceProv r ty1 ty2) + = pprPrefixApp p (ptext (sLit "UnsafeCo") <+> ppr r) + [pprParendType ty1, pprParendType ty2] +ppr_co _ (UnivCo p r t1 t2)= angleBrackets ( ppr t1 <> comma <+> ppr t2 ) <> ppr_role r <> ppr_prov where - ppTs [] = Outputable.empty - ppTs [t] = ptext (sLit "@") <> ppr_type TopPrec t - ppTs ts = ptext (sLit "@") <> - parens (hsep $ punctuate comma $ map pprType ts) - - ppPs [] = Outputable.empty - ppPs [p] = pprParendCo p - ppPs (p : ps) = ptext (sLit "(") <+> pprCo p $$ - vcat [ ptext (sLit ",") <+> pprCo q | q <- ps ] $$ - ptext (sLit ")") - + ppr_prov = case p of + HoleProv h -> ppr h + PhantomProv kind_co -> braces (ppr kind_co) + _ -> empty +ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co] +ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <> int n) [pprParendCo co] +ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co] +ppr_co p (CoherenceCo c1 c2) = maybeParen p TyConPrec $ + (ppr_co FunPrec c1) <+> (ptext (sLit "|>")) <+> + (ppr_co FunPrec c2) +ppr_co p (KindCo co) = pprPrefixApp p (ptext (sLit "kind")) [pprParendCo co] +ppr_co p (SubCo co) = pprPrefixApp p (ptext (sLit "Sub")) [pprParendCo co] +ppr_co p (AxiomRuleCo co cs) = maybeParen p TopPrec $ ppr_axiom_rule_co co cs +ppr_axiom_rule_co :: CoAxiomRule -> [Coercion] -> SDoc +ppr_axiom_rule_co co ps = ppr (coaxrName co) <+> parens (interpp'SP ps) ppr_role :: Role -> SDoc ppr_role r = underscore <> pp_role @@ -758,27 +264,24 @@ trans_co_list :: Coercion -> [Coercion] -> [Coercion] trans_co_list (TransCo co1 co2) cos = trans_co_list co1 (trans_co_list co2 cos) trans_co_list co cos = co : cos -instance Outputable LeftOrRight where - ppr CLeft = ptext (sLit "Left") - ppr CRight = ptext (sLit "Right") - ppr_fun_co :: TyPrec -> Coercion -> SDoc ppr_fun_co p co = pprArrowChain p (split co) where split :: Coercion -> [SDoc] - split (TyConAppCo _ f [arg,res]) + split (TyConAppCo _ f [arg, res]) | f `hasKey` funTyConKey = ppr_co FunPrec arg : split res split co = [ppr_co TopPrec co] ppr_forall_co :: TyPrec -> Coercion -> SDoc -ppr_forall_co p ty +ppr_forall_co p (ForAllCo tv h co) = maybeParen p FunPrec $ - sep [pprForAll tvs, ppr_co TopPrec rho] - where - (tvs, rho) = split1 [] ty - split1 tvs (ForAllCo tv ty) = split1 (tv:tvs) ty - split1 tvs ty = (reverse tvs, ty) + sep [pprCoBndr (tyVarName tv) h, ppr_co TopPrec co] +ppr_forall_co _ _ = panic "ppr_forall_co" + +pprCoBndr :: Name -> Coercion -> SDoc +pprCoBndr name eta = + forAllLit <+> parens (ppr name <+> dcolon <+> ppr eta) <> dot pprCoAxiom :: CoAxiom br -> SDoc pprCoAxiom ax@(CoAxiom { co_ax_branches = branches }) @@ -800,11 +303,12 @@ ppr_co_ax_branch :: (TyCon -> Type -> SDoc) -> CoAxiom br -> CoAxBranch -> SDoc ppr_co_ax_branch ppr_rhs (CoAxiom { co_ax_tc = fam_tc, co_ax_name = name }) (CoAxBranch { cab_tvs = tvs + , cab_cvs = cvs , cab_lhs = lhs , cab_rhs = rhs , cab_loc = loc }) = foldr1 (flip hangNotEmpty 2) - [ pprUserForAll tvs + [ pprUserForAll (map (flip mkNamedBinder Invisible) (tvs ++ cvs)) , pprTypeApp fam_tc lhs <+> equals <+> ppr_rhs fam_tc rhs , text "-- Defined" <+> pprLoc loc ] where @@ -817,11 +321,11 @@ ppr_co_ax_branch ppr_rhs quotes (ppr (nameModule name)) {- -************************************************************************ -* * - Functions over Kinds -* * -************************************************************************ +%************************************************************************ +%* * + Destructing coercions +%* * +%************************************************************************ -} -- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into @@ -838,35 +342,61 @@ getCoVar_maybe :: Coercion -> Maybe CoVar getCoVar_maybe (CoVarCo cv) = Just cv getCoVar_maybe _ = Nothing --- first result has role equal to input; second result is Nominal +-- | 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 (Refl r ty) + = 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 _ = 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 co1 co2) = Just (co1, co2) -splitAppCo_maybe (TyConAppCo r tc cos) - | mightBeUnsaturatedTyCon tc || cos `lengthExceeds` tyConArity tc - , Just (cos', co') <- snocView cos - , Just co'' <- setNominalRole_maybe co' - = Just (mkTyConAppCo r tc cos', co'') -- Never create unsaturated type family apps! +splitAppCo_maybe (AppCo co arg) = Just (co, arg) +splitAppCo_maybe (TyConAppCo r tc args) + | mightBeUnsaturatedTyCon tc || args `lengthExceeds` tyConArity tc + -- Never create unsaturated type family apps! + , Just (args', arg') <- snocView args + , Just arg'' <- setNominalRole_maybe arg' + = Just ( mkTyConAppCo r tc args', arg'' ) -- Use mkTyConAppCo to preserve the invariant -- that identity coercions are always represented by Refl + splitAppCo_maybe (Refl r ty) | Just (ty1, ty2) <- splitAppTy_maybe ty - = Just (Refl r ty1, Refl Nominal ty2) + = Just (mkReflCo r ty1, mkNomReflCo ty2) splitAppCo_maybe _ = Nothing -splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion) -splitForAllCo_maybe (ForAllCo tv co) = Just (tv, co) -splitForAllCo_maybe _ = Nothing +splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co) +splitForAllCo_maybe _ = Nothing ------------------------------------------------------- -- and some coercion kind stuff -coVarKind :: CoVar -> (Type,Type) +coVarTypes :: CoVar -> (Type,Type) +coVarTypes cv + | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv + = (ty1, ty2) + +coVarKindsTypesRole :: CoVar -> (Kind,Kind,Type,Type,Role) +coVarKindsTypesRole cv + | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv) + = let role + | tc `hasKey` eqPrimTyConKey = Nominal + | tc `hasKey` eqReprPrimTyConKey = Representational + | otherwise = panic "coVarKindsTypesRole" + in (k1,k2,ty1,ty2,role) + | otherwise = pprPanic "coVarKindsTypesRole, non coercion variable" + (ppr cv $$ ppr (varType cv)) + +coVarKind :: CoVar -> Type coVarKind cv - | Just (tc, [_kind,ty1,ty2]) <- splitTyConApp_maybe (varType cv) - = ASSERT(tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey) - (ty1,ty2) - | otherwise = panic "coVarKind, non coercion variable" + = ASSERT( isCoVar cv ) + varType cv coVarRole :: CoVar -> Role coVarRole cv @@ -875,7 +405,7 @@ coVarRole cv | tc `hasKey` eqReprPrimTyConKey = Representational | otherwise - = pprPanic "coVarRole: unknown tycon" (ppr cv) + = pprPanic "coVarRole: unknown tycon" (ppr cv <+> dcolon <+> ppr (varType cv)) where tc = case tyConAppTyCon_maybe (varType cv) of @@ -887,22 +417,34 @@ coVarRole cv mkCoercionType :: Role -> Type -> Type -> Type mkCoercionType Nominal = mkPrimEqPred mkCoercionType Representational = mkReprPrimEqPred -mkCoercionType Phantom = panic "mkCoercionType" +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" isReflCo :: Coercion -> Bool -isReflCo (Refl {}) = True -isReflCo _ = False +isReflCo (Refl {}) = True +isReflCo _ = False -isReflCo_maybe :: Coercion -> Maybe Type -isReflCo_maybe (Refl _ ty) = Just ty -isReflCo_maybe _ = Nothing +isReflCo_maybe :: Coercion -> Maybe (Type, Role) +isReflCo_maybe (Refl r ty) = Just (ty, r) +isReflCo_maybe _ = Nothing {- -************************************************************************ -* * +%************************************************************************ +%* * Building coercions -* * -************************************************************************ +%* * +%************************************************************************ + +These "smart constructors" maintain the invariants listed in the definition +of Coercion, and they perform very basic optimizations. Note [Role twiddling functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -925,18 +467,19 @@ 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. +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. +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 @@ -944,110 +487,63 @@ not. Indeed, `unsafeCoerce` is implemented via a representational UnivCo. (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. +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. --} +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. -mkCoVarCo :: CoVar -> Coercion --- cv :: s ~# t -mkCoVarCo cv - | ty1 `eqType` ty2 = Refl (coVarRole cv) ty1 - | otherwise = CoVarCo cv - where - (ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv +Note [mkTransAppCo] +~~~~~~~~~~~~~~~~~~~ +Suppose we have -mkReflCo :: Role -> Type -> Coercion -mkReflCo = Refl + co1 :: a ~R Maybe + co2 :: b ~R Int -mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> Coercion --- mkAxInstCo can legitimately be called over-staturated; --- i.e. with more type arguments than the coercion requires -mkAxInstCo role ax index tys - | arity == n_tys = downgradeRole role ax_role $ AxiomInstCo ax_br index rtys - | otherwise = ASSERT( arity < n_tys ) - downgradeRole role ax_role $ - foldl AppCo (AxiomInstCo ax_br index (take arity rtys)) - (drop arity rtys) - where - n_tys = length tys - ax_br = toBranchedAxiom ax - branch = coAxiomNthBranch ax_br index - arity = length $ coAxBranchTyVars branch - arg_roles = coAxBranchRoles branch - rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys - ax_role = coAxiomRole ax +and we want --- to be used only with unbranched axioms -mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched -> [Type] -> Coercion -mkUnbranchedAxInstCo role ax tys - = mkAxInstCo role ax 0 tys + co3 :: a b ~R Maybe Int -mkAxInstLHS, mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> 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)) -mkAxInstLHS ax index tys - | CoAxBranch { cab_tvs = tvs, cab_lhs = lhs } <- coAxiomNthBranch ax index - , (tys1, tys2) <- splitAtList tvs tys - = ASSERT( tvs `equalLength` tys1 ) - mkTyConApp (coAxiomTyCon ax) (substTysWith tvs tys1 lhs ++ tys2) +This seems sensible enough. But, we can't let (co3 = co1 co2), because +that's ill-roled! Note that mkAppCo requires a *nominal* second coercion. -mkAxInstRHS ax index tys - | CoAxBranch { cab_tvs = tvs, cab_rhs = rhs } <- coAxiomNthBranch ax index - , (tys1, tys2) <- splitAtList tvs tys - = ASSERT( tvs `equalLength` tys1 ) - mkAppTys (substTyWith tvs tys1 rhs) tys2 +The way around this is to use transitivity: -mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> Type -mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 + co3 = (co1 <b>_N) ; (Maybe co2) :: a b ~R Maybe Int --- | 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 -> Coercion -> Coercion -mkAppCo co1 co2 = mkAppCoFlexible co1 Nominal co2 --- 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 types/TypeRep.hs. +Or, it's possible everything is the other way around: --- | Apply a 'Coercion' to another 'Coercion'. --- The second 'Coercion's role is given, making this more flexible than --- 'mkAppCo'. -mkAppCoFlexible :: Coercion -> Role -> Coercion -> Coercion -mkAppCoFlexible (Refl r ty1) _ (Refl _ ty2) - = Refl r (mkAppTy ty1 ty2) -mkAppCoFlexible (Refl r ty1) r2 co2 - | Just (tc, tys) <- splitTyConApp_maybe ty1 - -- Expand type synonyms; a TyConAppCo can't have a type synonym (Trac #9102) - = TyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) - where - zip_roles (r1:_) [] = [downgradeRole r1 r2 co2] - zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys - zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... -mkAppCoFlexible (TyConAppCo r tc cos) r2 co - = case r of - Nominal -> ASSERT( r2 == Nominal ) - TyConAppCo Nominal tc (cos ++ [co]) - Representational -> TyConAppCo Representational tc (cos ++ [co']) - where new_role = (tyConRolesX Representational tc) !! (length cos) - co' = downgradeRole new_role r2 co - Phantom -> TyConAppCo Phantom tc (cos ++ [mkPhantomCo co]) + co1' :: Maybe ~R a + co2' :: Int ~R b -mkAppCoFlexible co1 _r2 co2 = ASSERT( _r2 == Nominal ) - AppCo co1 co2 +and we want + co3' :: Maybe Int ~R a b --- | 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 +then + + co3' = (Maybe co2') ; (co1' <b>_N) + +This is exactly what `mkTransAppCo` builds for us. Information for all +the arguments tends to be to hand at call sites, so it's quicker than +using, say, coercionKind. + +-} + +mkReflCo :: Role -> Type -> Coercion +mkReflCo r ty + = Refl r ty + +-- | Make a representational reflexive coercion +mkRepReflCo :: Type -> Coercion +mkRepReflCo = mkReflCo Representational + +-- | Make a nominal reflexive coercion +mkNomReflCo :: Type -> Coercion +mkNomReflCo = mkReflCo Nominal -- | Apply a type constructor to a list of coercions. It is the -- caller's responsibility to get the roles correct on argument coercions. @@ -1055,10 +551,10 @@ mkTyConAppCo :: Role -> TyCon -> [Coercion] -> Coercion mkTyConAppCo r tc cos -- Expand type synonyms | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos - = mkAppCos (liftCoSubst r tv_co_prs rhs_ty) leftover_cos + = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos - | Just tys <- traverse isReflCo_maybe cos - = Refl r (mkTyConApp tc tys) -- See Note [Refl invariant] + | Just tys_roles <- traverse isReflCo_maybe cos + = Refl r (mkTyConApp tc (map fst tys_roles)) -- See Note [Refl invariant] | otherwise = TyConAppCo r tc cos @@ -1066,13 +562,258 @@ mkTyConAppCo r tc cos mkFunCo :: Role -> Coercion -> Coercion -> Coercion mkFunCo r co1 co2 = mkTyConAppCo r funTyCon [co1, co2] --- | Make a 'Coercion' which binds a variable within an inner 'Coercion' -mkForAllCo :: Var -> Coercion -> Coercion --- note that a TyVar should be used here, not a CoVar (nor a TcTyVar) -mkForAllCo tv (Refl r ty) = ASSERT( isTyVar tv ) Refl r (mkForAllTy tv ty) -mkForAllCo tv co = ASSERT( isTyVar tv ) ForAllCo tv co +-- | Make nested function 'Coercion's +mkFunCos :: Role -> [Coercion] -> Coercion -> Coercion +mkFunCos r cos res_co = foldr (mkFunCo r) res_co cos -------------------------------- +-- | 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 (Refl r ty1) arg + | Just (ty2, _) <- isReflCo_maybe arg + = Refl r (mkAppTy ty1 ty2) + + | Just (tc, tys) <- splitTyConApp_maybe ty1 + -- Expand type synonyms; a TyConAppCo can't have a type synonym (Trac #9102) + = TyConAppCo 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 -> TyConAppCo Nominal tc (args ++ [arg]) + Representational -> TyConAppCo Representational tc (args ++ [arg']) + where new_role = (tyConRolesX Representational tc) !! (length args) + arg' = downgradeRole new_role Nominal arg + Phantom -> TyConAppCo 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 TyCoRep. + +-- | 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 + +-- | Like `mkAppCo`, but allows the second coercion to be other than +-- nominal. See Note [mkTransAppCo]. Role r3 cannot be more stringent +-- than either r1 or r2. +mkTransAppCo :: Role -- ^ r1 + -> Coercion -- ^ co1 :: ty1a ~r1 ty1b + -> Type -- ^ ty1a + -> Type -- ^ ty1b + -> Role -- ^ r2 + -> Coercion -- ^ co2 :: ty2a ~r2 ty2b + -> Type -- ^ ty2a + -> Type -- ^ ty2b + -> Role -- ^ r3 + -> Coercion -- ^ :: ty1a ty2a ~r3 ty1b ty2b +mkTransAppCo r1 co1 ty1a ty1b r2 co2 ty2a ty2b r3 +-- How incredibly fiddly! Is there a better way?? + = case (r1, r2, r3) of + (_, _, Phantom) + -> mkPhantomCo kind_co (mkAppTy ty1a ty2a) (mkAppTy ty1b ty2b) + where -- ty1a :: k1a -> k2a + -- ty1b :: k1b -> k2b + -- ty2a :: k1a + -- ty2b :: k1b + -- ty1a ty2a :: k2a + -- ty1b ty2b :: k2b + kind_co1 = mkKindCo co1 -- :: k1a -> k2a ~N k1b -> k2b + kind_co = mkNthCo 1 kind_co1 -- :: k2a ~N k2b + + (_, _, Nominal) + -> ASSERT( r1 == Nominal && r2 == Nominal ) + mkAppCo co1 co2 + (Nominal, Nominal, Representational) + -> mkSubCo (mkAppCo co1 co2) + (_, Nominal, Representational) + -> ASSERT( r1 == Representational ) + mkAppCo co1 co2 + (Nominal, Representational, Representational) + -> go (mkSubCo co1) + (_ , _, Representational) + -> ASSERT( r1 == Representational && r2 == Representational ) + go co1 + where + go co1_repr + | Just (tc1b, tys1b) <- splitTyConApp_maybe ty1b + , nextRole ty1b == r2 + = (mkAppCo co1_repr (mkNomReflCo ty2a)) `mkTransCo` + (mkTyConAppCo Representational tc1b + (zipWith mkReflCo (tyConRolesX Representational tc1b) tys1b + ++ [co2])) + + | Just (tc1a, tys1a) <- splitTyConApp_maybe ty1a + , nextRole ty1a == r2 + = (mkTyConAppCo Representational tc1a + (zipWith mkReflCo (tyConRolesX Representational tc1a) tys1a + ++ [co2])) + `mkTransCo` + (mkAppCo co1_repr (mkNomReflCo ty2b)) + + | otherwise + = pprPanic "mkTransAppCo" (vcat [ ppr r1, ppr co1, ppr ty1a, ppr ty1b + , ppr r2, ppr co2, ppr ty2a, ppr ty2b + , ppr r3 ]) + +-- | Make a Coercion from a tyvar, a kind coercion, and a body coercion. +-- The kind of the tyvar should be the left-hand kind of the kind coercion. +mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion +mkForAllCo tv kind_co co + | Refl r ty <- co + , Refl {} <- kind_co + = Refl r (mkNamedForAllTy tv Invisible ty) + | otherwise + = ForAllCo tv kind_co co + +-- | Make nested ForAllCos +mkForAllCos :: [(TyVar, Coercion)] -> Coercion -> Coercion +mkForAllCos bndrs (Refl r ty) + = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in + foldl (flip $ uncurry ForAllCo) + (Refl r $ mkInvForAllTys (reverse (map fst refls_rev'd)) ty) + non_refls_rev'd +mkForAllCos bndrs co = foldr (uncurry ForAllCo) co bndrs + +-- | Make a Coercion quantified over a type variable; +-- the variable has the same type in both sides of the coercion +mkHomoForAllCos :: [TyVar] -> Coercion -> Coercion +mkHomoForAllCos tvs (Refl r ty) + = Refl r (mkInvForAllTys tvs ty) +mkHomoForAllCos tvs ty = mkHomoForAllCos_NoRefl tvs ty + +-- | Like 'mkHomoForAllCos', but doesn't check if the inner coercion +-- is reflexive. +mkHomoForAllCos_NoRefl :: [TyVar] -> Coercion -> Coercion +mkHomoForAllCos_NoRefl tvs orig_co = foldr go orig_co tvs + where + go tv co = ForAllCo tv (mkNomReflCo (tyVarKind tv)) co + +mkCoVarCo :: CoVar -> Coercion +-- cv :: s ~# t +mkCoVarCo cv + | ty1 `eqType` ty2 = Refl (coVarRole cv) ty1 + | otherwise = CoVarCo cv + where + (ty1, ty2) = coVarTypes cv + +mkCoVarCos :: [CoVar] -> [Coercion] +mkCoVarCos = map mkCoVarCo + +-- | 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; just checks to see if it should produce Refl +mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion +mkAxiomInstCo ax index args + = ASSERT( coAxiomArity ax index == length args ) + 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 + +-- | Manufacture an unsafe coercion from thin air. +-- Currently (May 14) this is used only to implement the +-- @unsafeCoerce#@ primitive. Optimise by pushing +-- down through type constructors. +mkUnsafeCo :: Role -> Type -> Type -> Coercion +mkUnsafeCo role ty1 ty2 + = mkUnivCo UnsafeCoerceProv role ty1 ty2 + +-- | Make a coercion from a coercion hole +mkHoleCo :: CoercionHole -> Role + -> Type -> Type -> Coercion +mkHoleCo h r t1 t2 = mkUnivCo (HoleProv h) r t1 t2 + +-- | 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 = Refl 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 @@ -1081,16 +822,16 @@ 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@(Refl {}) = co -mkSymCo (UnivCo s r ty1 ty2) = UnivCo s r ty2 ty1 -mkSymCo (SymCo co) = co -mkSymCo co = SymCo co +mkSymCo co@(Refl {}) = 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. mkTransCo :: Coercion -> Coercion -> Coercion -mkTransCo (Refl {}) co = co -mkTransCo co (Refl {}) = co -mkTransCo co1 co2 = TransCo co1 co2 +mkTransCo co1 (Refl {}) = co1 +mkTransCo (Refl {}) co2 = co2 +mkTransCo co1 co2 = TransCo co1 co2 -- the Role is the desired one. It is the caller's responsibility to make -- sure this request is reasonable @@ -1102,69 +843,99 @@ mkNthCoRole role n co nth_role = coercionRole nth_co mkNthCo :: Int -> Coercion -> Coercion -mkNthCo n (Refl r ty) = ASSERT( ok_tc_app ty n ) - Refl r' (tyConAppArgN n ty) +mkNthCo 0 (Refl _ ty) + | Just (tv, _) <- splitForAllTy_maybe ty + = Refl Nominal (tyVarKind tv) +mkNthCo n (Refl r ty) + = ASSERT( ok_tc_app ty n ) + mkReflCo r' (tyConAppArgN n ty) where tc = tyConAppTyCon ty r' = nthRole r tc n -mkNthCo n co = ASSERT( ok_tc_app _ty1 n && ok_tc_app _ty2 n ) - NthCo n co - where - Pair _ty1 _ty2 = coercionKind co + 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 + +mkNthCo n (TyConAppCo _ _ cos) = cos `getNth` n +mkNthCo n co = NthCo n co mkLRCo :: LeftOrRight -> Coercion -> Coercion mkLRCo lr (Refl eq ty) = Refl eq (pickLR lr (splitAppTy ty)) mkLRCo lr co = LRCo lr co -ok_tc_app :: Type -> Int -> Bool -ok_tc_app ty n = case splitTyConApp_maybe ty of - Just (_, tys) -> tys `lengthExceeds` n - Nothing -> False - --- | Instantiates a 'Coercion' with a 'Type' argument. -mkInstCo :: Coercion -> Type -> Coercion -mkInstCo co ty = InstCo co ty - --- | Manufacture an unsafe coercion from thin air. --- Currently (May 14) this is used only to implement the --- @unsafeCoerce#@ primitive. Optimise by pushing --- down through type constructors. -mkUnsafeCo :: Type -> Type -> Coercion -mkUnsafeCo = mkUnivCo (fsLit "mkUnsafeCo") Representational - -mkUnivCo :: FastString -> Role -> Type -> Type -> Coercion -mkUnivCo prov role ty1 ty2 - | ty1 `eqType` ty2 = Refl role ty1 - | otherwise = UnivCo prov role ty1 ty2 - -mkAxiomRuleCo :: CoAxiomRule -> [Type] -> [Coercion] -> Coercion -mkAxiomRuleCo = AxiomRuleCo +-- | Instantiates a 'Coercion'. +mkInstCo :: Coercion -> Coercion -> Coercion +mkInstCo (ForAllCo tv _kind_co body_co) (Refl _ arg) + = substCoWith [tv] [arg] body_co +mkInstCo co arg = InstCo co arg + +-- This could work harder to produce Refl coercions, but that would be +-- quite inefficient. Seems better not to try. +mkCoherenceCo :: Coercion -> Coercion -> Coercion +mkCoherenceCo co1 (Refl {}) = co1 +mkCoherenceCo (CoherenceCo co1 co2) co3 + = CoherenceCo co1 (co2 `mkTransCo` co3) +mkCoherenceCo co1 co2 = CoherenceCo co1 co2 + +-- | A CoherenceCo c1 c2 applies the coercion c2 to the left-hand type +-- in the kind of c1. This function uses sym to get the coercion on the +-- right-hand type of c1. Thus, if c1 :: s ~ t, then mkCoherenceRightCo c1 c2 +-- has the kind (s ~ (t |> c2)) down through type constructors. +-- The second coercion must be representational. +mkCoherenceRightCo :: Coercion -> Coercion -> Coercion +mkCoherenceRightCo c1 c2 = mkSymCo (mkCoherenceCo (mkSymCo c1) c2) + +-- | An explictly directed synonym of mkCoherenceCo. The second +-- coercion must be representational. +mkCoherenceLeftCo :: Coercion -> Coercion -> Coercion +mkCoherenceLeftCo = mkCoherenceCo + +infixl 5 `mkCoherenceCo` +infixl 5 `mkCoherenceRightCo` +infixl 5 `mkCoherenceLeftCo` + +mkKindCo :: Coercion -> Coercion +mkKindCo (Refl _ ty) = Refl Nominal (typeKind ty) +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. + , typeKind ty1 `eqType` typeKind ty2 + = Refl Nominal (typeKind ty1) + | otherwise + = KindCo co -- input coercion is Nominal; see also Note [Role twiddling functions] mkSubCo :: Coercion -> Coercion mkSubCo (Refl Nominal ty) = Refl Representational ty mkSubCo (TyConAppCo Nominal tc cos) = TyConAppCo Representational tc (applyRoles tc cos) -mkSubCo (UnivCo s Nominal ty1 ty2) = UnivCo s Representational ty1 ty2 mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) SubCo co --- only *downgrades* a role. See Note [Role twiddling functions] -downgradeRole_maybe :: Role -- desired role - -> Role -- current role - -> Coercion - -> Maybe Coercion +-- | 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 Representational Nominal co = Just (mkSubCo co) downgradeRole_maybe Nominal Representational _ = Nothing downgradeRole_maybe Phantom Phantom co = Just co -downgradeRole_maybe Phantom _ co = Just (mkPhantomCo co) +downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) downgradeRole_maybe _ Phantom _ = Nothing downgradeRole_maybe _ _ co = Just co --- panics if the requested conversion is not a downgrade. --- See also Note [Role twiddling functions] +-- | 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 @@ -1173,49 +944,95 @@ downgradeRole r1 r2 co Just co' -> co' Nothing -> pprPanic "downgradeRole" (ppr co) --- Converts a coercion to be nominal, if possible. --- See also Note [Role twiddling functions] +-- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. +-- Note that the input coercion should always be nominal. +maybeSubCo :: EqRel -> Coercion -> Coercion +maybeSubCo NomEq = id +maybeSubCo ReprEq = mkSubCo + + +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 (Refl {}) g _ = Refl r (CoercionTy g) +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 :: Coercion -> Maybe Coercion setNominalRole_maybe co | Nominal <- coercionRole co = Just co setNominalRole_maybe (SubCo co) = Just co setNominalRole_maybe (Refl _ ty) = Just $ Refl Nominal ty -setNominalRole_maybe (TyConAppCo Representational tc coes) - = do { cos' <- mapM setNominalRole_maybe coes +setNominalRole_maybe (TyConAppCo Representational tc cos) + = do { cos' <- mapM setNominalRole_maybe cos ; return $ TyConAppCo Nominal tc cos' } -setNominalRole_maybe (UnivCo s Representational ty1 ty2) = Just $ UnivCo s Nominal ty1 ty2 - -- We do *not* promote UnivCo Phantom, as that's unsafe. - -- UnivCo Nominal is no more unsafe than UnivCo Representational +setNominalRole_maybe (SymCo co) + = SymCo <$> setNominalRole_maybe co setNominalRole_maybe (TransCo co1 co2) = TransCo <$> setNominalRole_maybe co1 <*> setNominalRole_maybe co2 setNominalRole_maybe (AppCo co1 co2) = AppCo <$> setNominalRole_maybe co1 <*> pure co2 -setNominalRole_maybe (ForAllCo tv co) - = ForAllCo tv <$> setNominalRole_maybe co +setNominalRole_maybe (ForAllCo tv kind_co co) + = ForAllCo tv kind_co <$> setNominalRole_maybe co setNominalRole_maybe (NthCo n co) = NthCo n <$> setNominalRole_maybe co -setNominalRole_maybe (InstCo co ty) - = InstCo <$> setNominalRole_maybe co <*> pure ty +setNominalRole_maybe (InstCo co arg) + = InstCo <$> setNominalRole_maybe co <*> pure arg +setNominalRole_maybe (CoherenceCo co1 co2) + = CoherenceCo <$> setNominalRole_maybe co1 <*> pure co2 +setNominalRole_maybe (UnivCo prov _ co1 co2) + | case prov of UnsafeCoerceProv -> True -- it's always unsafe + PhantomProv _ -> False -- should always be phantom + ProofIrrelProv _ -> True -- it's always safe + PluginProv _ -> False -- who knows? This choice is conservative. + HoleProv _ -> False -- no no no. + = Just $ UnivCo prov Nominal co1 co2 setNominalRole_maybe _ = 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 + +-- | Make a phantom coercion between two types of the same kind. +mkHomoPhantomCo :: Type -> Type -> Coercion +mkHomoPhantomCo t1 t2 + = ASSERT( k1 `eqType` typeKind t2 ) + mkPhantomCo (mkNomReflCo k1) t1 t2 + where + k1 = typeKind t1 + -- takes any coercion and turns it into a Phantom coercion -mkPhantomCo :: Coercion -> Coercion -mkPhantomCo co - | Just ty <- isReflCo_maybe co = Refl Phantom ty - | Pair ty1 ty2 <- coercionKind co = UnivCo (fsLit "mkPhantomCo") Phantom ty1 ty2 - -- don't optimise here... wait for OptCoercion - --- All input coercions are assumed to be Nominal, --- or, if Role is Phantom, the Coercion can be Phantom, too. -applyRole :: Role -> Coercion -> Coercion -applyRole Nominal = id -applyRole Representational = mkSubCo -applyRole Phantom = mkPhantomCo +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 applyRole (tyConRolesX Representational tc) cos + = zipWith (\r -> downgradeRole r Nominal) (tyConRolesX Representational tc) cos -- the Role parameter is the Role of the TyConAppCo -- defined here because this is intimiately concerned with the implementation @@ -1228,7 +1045,7 @@ nthRole :: Role -> TyCon -> Int -> Role nthRole Nominal _ _ = Nominal nthRole Phantom _ _ = Phantom nthRole Representational tc n - = (tyConRolesX Representational tc) !! n + = (tyConRolesX Representational tc) `getNth` n ltRole :: Role -> Role -> Bool -- Is one role "less" than another? @@ -1239,7 +1056,144 @@ 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 -> Coercion + +-- 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 _ ty -> ASSERT( False ) + mkNomReflCo (typeKind ty) + + 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 _ _ g + -> promoteCoercion g + + CoVarCo {} + -> mkKindCo co + + AxiomInstCo {} + -> mkKindCo co + + UnivCo UnsafeCoerceProv _ t1 t2 + -> mkUnsafeCo Nominal (typeKind t1) (typeKind t2) + UnivCo (PhantomProv kco) _ _ _ + -> kco + UnivCo (ProofIrrelProv kco) _ _ _ + -> kco + UnivCo (PluginProv _) _ _ _ + -> mkKindCo co + UnivCo (HoleProv _) _ _ _ + -> mkKindCo co + + SymCo g + -> mkSymCo (promoteCoercion g) + + TransCo co1 co2 + -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) + + NthCo n co1 + | Just (_, args) <- splitTyConAppCo_maybe co1 + , n < length args + -> 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 _ + -> promoteCoercion g + + CoherenceCo g h + -> mkSymCo h `mkTransCo` promoteCoercion g + + KindCo _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + + SubCo g + -> promoteCoercion g + + AxiomRuleCo {} + -> mkKindCo co + + 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. The result role matches is representational. +instCoercion :: Pair Type -- type of the first coercion + -> Coercion -- ^ must be nominal + -> Coercion + -> Maybe Coercion +instCoercion (Pair lty rty) g w + | isForAllTy lty && isForAllTy rty + , Just w' <- setNominalRole_maybe w + = Just $ mkInstCo g w' + | isFunTy lty && isFunTy rty + = Just $ mkNthCo 1 g -- extract result type, which is the 2nd argument to (->) + | otherwise -- one forall, one funty... + = Nothing + where + +instCoercions :: Coercion -> [Coercion] -> Maybe Coercion +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 h1 h2, where g :: t1 ~ t2, has type (t1 |> h1) ~ (t2 |> h2) +-- The second and third coercions must be nominal. +castCoercionKind :: Coercion -> Coercion -> Coercion -> Coercion +castCoercionKind g h1 h2 + = g `mkCoherenceLeftCo` h1 `mkCoherenceRightCo` h2 + -- See note [Newtype coercions] in TyCon + -- | 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 @@ -1253,9 +1207,10 @@ mkNewTypeCo name tycon tvs roles rhs_ty , co_ax_role = Representational , co_ax_tc = tycon , co_ax_branches = unbranched branch } - where branch = CoAxBranch { cab_loc = getSrcSpan name - , cab_tvs = tvs - , cab_lhs = mkTyVarTys tvs + where branch = CoAxBranch { cab_loc = getSrcSpan name + , cab_tvs = tvs + , cab_cvs = [] + , cab_lhs = mkTyVarTys tvs , cab_roles = roles , cab_rhs = rhs_ty , cab_incomps = [] } @@ -1264,28 +1219,32 @@ mkPiCos :: Role -> [Var] -> Coercion -> Coercion mkPiCos r vs co = foldr (mkPiCo r) co vs mkPiCo :: Role -> Var -> Coercion -> Coercion -mkPiCo r v co | isTyVar v = mkForAllCo v co +mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co | otherwise = mkFunCo r (mkReflCo r (varType v)) co --- The first coercion *must* be Nominal. +-- The second coercion is sometimes lifted (~) and sometimes unlifted (~#). +-- So, we have to make sure to supply the right parameter to decomposeCo. +-- mkCoCast (c :: s1 ~# t1) (g :: (s1 ~# s2) ~# (t1 ~# t2)) :: s2 ~# t2 +-- Both coercions *must* have the same role. mkCoCast :: Coercion -> Coercion -> Coercion --- (mkCoCast (c :: s1 ~# t1) (g :: (s1 ~# t1) ~# (s2 ~# t2) mkCoCast c g = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 where -- g :: (s1 ~# s2) ~# (t1 ~# t2) -- g1 :: s1 ~# t1 -- g2 :: s2 ~# t2 - [_reflk, g1, g2] = decomposeCo 3 g - -- Remember, (~#) :: forall k. k -> k -> * - -- so it takes *three* arguments, not two + (_, args) = splitTyConApp (pFst $ coercionKind g) + n_args = length args + co_list = decomposeCo n_args g + g1 = co_list `getNth` (n_args - 2) + g2 = co_list `getNth` (n_args - 1) {- -************************************************************************ -* * +%************************************************************************ +%* * Newtypes -* * -************************************************************************ +%* * +%************************************************************************ -} -- | If @co :: T ts ~ rep_ty@ then: @@ -1297,8 +1256,7 @@ 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) + = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) | otherwise = Nothing @@ -1330,8 +1288,8 @@ modifyStepResultCo :: (Coercion -> Coercion) modifyStepResultCo f (NS_Step rec_nts ty co) = NS_Step rec_nts ty (f co) modifyStepResultCo _ result = result --- | Try one stepper and then try the next, --- if the first doesn't make progress. +-- | 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 -> NormaliseStepper -> NormaliseStepper @@ -1383,9 +1341,9 @@ topNormaliseTypeX_maybe stepper 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@, or responds False to ok_tc. Specifically, here's the invariant: +-- a @newtype@. Specifically, here's the invariant: -- --- > topNormaliseNewType_maybe ty = Just (co, ty') +-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') -- -- then (a) @co : ty0 ~ ty'@. -- (b) ty' is not a newtype. @@ -1397,242 +1355,32 @@ topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) -- 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 --- topNormaliseNewType_maybe ty = topNormaliseTypeX_maybe unwrapNewTypeStepper ty {- -************************************************************************ -* * - Equality of coercions -* * -************************************************************************ +%************************************************************************ +%* * + Comparison of coercions +%* * +%************************************************************************ -} --- | Determines syntactic equality of coercions -coreEqCoercion :: Coercion -> Coercion -> Bool -coreEqCoercion co1 co2 = coreEqCoercion2 rn_env co1 co2 - where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2)) - -coreEqCoercion2 :: RnEnv2 -> Coercion -> Coercion -> Bool -coreEqCoercion2 env (Refl eq1 ty1) (Refl eq2 ty2) = eq1 == eq2 && eqTypeX env ty1 ty2 -coreEqCoercion2 env (TyConAppCo eq1 tc1 cos1) (TyConAppCo eq2 tc2 cos2) - = eq1 == eq2 && tc1 == tc2 && all2 (coreEqCoercion2 env) cos1 cos2 - -coreEqCoercion2 env (AppCo co11 co12) (AppCo co21 co22) - = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22 - -coreEqCoercion2 env (ForAllCo v1 co1) (ForAllCo v2 co2) - = coreEqCoercion2 (rnBndr2 env v1 v2) co1 co2 - -coreEqCoercion2 env (CoVarCo cv1) (CoVarCo cv2) - = rnOccL env cv1 == rnOccR env cv2 - -coreEqCoercion2 env (AxiomInstCo con1 ind1 cos1) (AxiomInstCo con2 ind2 cos2) - = con1 == con2 - && ind1 == ind2 - && all2 (coreEqCoercion2 env) cos1 cos2 - --- the provenance string is just a note, so don't use in comparisons -coreEqCoercion2 env (UnivCo _ r1 ty11 ty12) (UnivCo _ r2 ty21 ty22) - = r1 == r2 && eqTypeX env ty11 ty21 && eqTypeX env ty12 ty22 - -coreEqCoercion2 env (SymCo co1) (SymCo co2) - = coreEqCoercion2 env co1 co2 - -coreEqCoercion2 env (TransCo co11 co12) (TransCo co21 co22) - = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22 - -coreEqCoercion2 env (NthCo d1 co1) (NthCo d2 co2) - = d1 == d2 && coreEqCoercion2 env co1 co2 -coreEqCoercion2 env (LRCo d1 co1) (LRCo d2 co2) - = d1 == d2 && coreEqCoercion2 env co1 co2 - -coreEqCoercion2 env (InstCo co1 ty1) (InstCo co2 ty2) - = coreEqCoercion2 env co1 co2 && eqTypeX env ty1 ty2 - -coreEqCoercion2 env (SubCo co1) (SubCo co2) - = coreEqCoercion2 env co1 co2 - -coreEqCoercion2 env (AxiomRuleCo a1 ts1 cs1) (AxiomRuleCo a2 ts2 cs2) - = a1 == a2 && all2 (eqTypeX env) ts1 ts2 && all2 (coreEqCoercion2 env) cs1 cs2 - -coreEqCoercion2 _ _ _ = False - -{- -************************************************************************ -* * - Substitution of coercions -* * -************************************************************************ --} - --- | A substitution of 'Coercion's for 'CoVar's (OR 'TyVar's, when --- doing a \"lifting\" substitution) -type CvSubstEnv = VarEnv Coercion - -emptyCvSubstEnv :: CvSubstEnv -emptyCvSubstEnv = emptyVarEnv - -data CvSubst - = CvSubst InScopeSet -- The in-scope type variables - TvSubstEnv -- Substitution of types - CvSubstEnv -- Substitution of coercions - -instance Outputable CvSubst where - ppr (CvSubst ins tenv cenv) - = brackets $ sep[ ptext (sLit "CvSubst"), - nest 2 (ptext (sLit "In scope:") <+> ppr ins), - nest 2 (ptext (sLit "Type env:") <+> ppr tenv), - nest 2 (ptext (sLit "Coercion env:") <+> ppr cenv) ] - -emptyCvSubst :: CvSubst -emptyCvSubst = CvSubst emptyInScopeSet emptyVarEnv emptyVarEnv - -isEmptyCvSubst :: CvSubst -> Bool -isEmptyCvSubst (CvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv - -getCvInScope :: CvSubst -> InScopeSet -getCvInScope (CvSubst in_scope _ _) = in_scope - -zapCvSubstEnv :: CvSubst -> CvSubst -zapCvSubstEnv (CvSubst in_scope _ _) = CvSubst in_scope emptyVarEnv emptyVarEnv - -cvTvSubst :: CvSubst -> TvSubst -cvTvSubst (CvSubst in_scope tvs _) = TvSubst in_scope tvs - -tvCvSubst :: TvSubst -> CvSubst -tvCvSubst (TvSubst in_scope tenv) = CvSubst in_scope tenv emptyCvSubstEnv - -extendTvSubst :: CvSubst -> TyVar -> Type -> CvSubst -extendTvSubst (CvSubst in_scope tenv cenv) tv ty - = CvSubst in_scope (extendVarEnv tenv tv ty) cenv - -extendTvSubstAndInScope :: CvSubst -> TyVar -> Type -> CvSubst -extendTvSubstAndInScope (CvSubst in_scope tenv cenv) tv ty - = CvSubst (in_scope `extendInScopeSetSet` tyVarsOfType ty) - (extendVarEnv tenv tv ty) - cenv - -extendCvSubstAndInScope :: CvSubst -> CoVar -> Coercion -> CvSubst --- Also extends the in-scope set -extendCvSubstAndInScope (CvSubst in_scope tenv cenv) cv co - = CvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfCo co) - tenv - (extendVarEnv cenv cv co) +-- | Syntactic equality of coercions +eqCoercion :: Coercion -> Coercion -> Bool +eqCoercion = eqType `on` coercionType -substCoVarBndr :: CvSubst -> CoVar -> (CvSubst, CoVar) -substCoVarBndr subst@(CvSubst in_scope tenv cenv) old_var - = ASSERT( isCoVar old_var ) - (CvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) - where - -- When we substitute (co :: t1 ~ t2) we may get the identity (co :: t ~ t) - -- In that case, mkCoVarCo will return a ReflCoercion, and - -- we want to substitute that (not new_var) for old_var - new_co = mkCoVarCo new_var - no_change = new_var == old_var && not (isReflCo new_co) - - 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) (substTy subst (varType old_var)) - -- It's important to do the substitution for coercions, - -- because they can have free type variables - -substTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar) -substTyVarBndr (CvSubst in_scope tenv cenv) old_var - = case Type.substTyVarBndr (TvSubst in_scope tenv) old_var of - (TvSubst in_scope' tenv', new_var) -> (CvSubst in_scope' tenv' cenv, new_var) - -mkCvSubst :: InScopeSet -> [(Var,Coercion)] -> CvSubst -mkCvSubst in_scope prs = CvSubst in_scope Type.emptyTvSubstEnv (mkVarEnv prs) - -zipOpenCvSubst :: [Var] -> [Coercion] -> CvSubst -zipOpenCvSubst vs cos - | debugIsOn && (length vs /= length cos) - = pprTrace "zipOpenCvSubst" (ppr vs $$ ppr cos) emptyCvSubst - | otherwise - = CvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv (zipVarEnv vs cos) - -substCoWithTy :: InScopeSet -> TyVar -> Type -> Coercion -> Coercion -substCoWithTy in_scope tv ty = substCoWithTys in_scope [tv] [ty] - -substCoWithTys :: InScopeSet -> [TyVar] -> [Type] -> Coercion -> Coercion -substCoWithTys in_scope tvs tys co - | debugIsOn && (length tvs /= length tys) - = pprTrace "substCoWithTys" (ppr tvs $$ ppr tys) co - | otherwise - = ASSERT( length tvs == length tys ) - substCo (CvSubst in_scope (zipVarEnv tvs tys) emptyVarEnv) co - --- | Substitute within a 'Coercion' -substCo :: CvSubst -> Coercion -> Coercion -substCo subst co | isEmptyCvSubst subst = co - | otherwise = subst_co subst co - --- | Substitute within several 'Coercion's -substCos :: CvSubst -> [Coercion] -> [Coercion] -substCos subst cos | isEmptyCvSubst subst = cos - | otherwise = map (substCo subst) cos - -substTy :: CvSubst -> Type -> Type -substTy subst = Type.substTy (cvTvSubst subst) - -subst_co :: CvSubst -> Coercion -> Coercion -subst_co subst co - = go co - where - go_ty :: Type -> Type - go_ty = Coercion.substTy subst - - go :: Coercion -> Coercion - go (Refl eq ty) = Refl eq $! go_ty ty - go (TyConAppCo eq tc cos) = let args = map go cos - in args `seqList` TyConAppCo eq tc args - go (AppCo co1 co2) = mkAppCo (go co1) $! go co2 - go (ForAllCo tv co) = case substTyVarBndr subst tv of - (subst', tv') -> - ForAllCo tv' $! subst_co subst' co - go (CoVarCo cv) = substCoVar subst cv - go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! map go cos - go (UnivCo s r ty1 ty2) = (UnivCo s r $! go_ty ty1) $! go_ty ty2 - go (SymCo co) = mkSymCo (go co) - go (TransCo co1 co2) = mkTransCo (go co1) (go co2) - go (NthCo d co) = mkNthCo d (go co) - go (LRCo lr co) = mkLRCo lr (go co) - go (InstCo co ty) = mkInstCo (go co) $! go_ty ty - go (SubCo co) = mkSubCo (go co) - go (AxiomRuleCo co ts cs) = let ts1 = map go_ty ts - cs1 = map go cs - in ts1 `seqList` cs1 `seqList` - AxiomRuleCo co ts1 cs1 - - - -substCoVar :: CvSubst -> CoVar -> Coercion -substCoVar (CvSubst in_scope _ cenv) cv - | Just co <- lookupVarEnv cenv cv = co - | Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1 - | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv $$ ppr in_scope) - ASSERT( isCoVar cv ) CoVarCo cv - -substCoVars :: CvSubst -> [CoVar] -> [Coercion] -substCoVars subst cvs = map (substCoVar subst) cvs - -lookupTyVar :: CvSubst -> TyVar -> Maybe Type -lookupTyVar (CvSubst _ tenv _) tv = lookupVarEnv tenv tv - -lookupCoVar :: CvSubst -> Var -> Maybe Coercion -lookupCoVar (CvSubst _ _ cenv) v = lookupVarEnv cenv v +-- | Compare two 'Coercion's, with respect to an RnEnv2 +eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool +eqCoercionX env = eqTypeX env `on` coercionType {- -************************************************************************ -* * +%************************************************************************ +%* * "Lifting" substitution - [(TyVar,Coercion)] -> Type -> Coercion -* * -************************************************************************ + [(TyCoVar,Coercion)] -> Type -> Coercion +%* * +%************************************************************************ Note [Lifting coercions over types: liftCoSubst] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1657,265 +1405,286 @@ The crucial operation is that we * and substitute g' for a thus giving *coercion*. This is what liftCoSubst does. -Note [Substituting kinds in liftCoSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to take care with kind polymorphism. Suppose - K :: forall k (a:k). (forall b:k. a -> b) -> T k a - -Now given (K @kk1 @ty1 v) |> g) where - g :: T kk1 ty1 ~ T kk2 ty2 -we want to compute - (forall b:k a->b) [ Nth 0 g/k, Nth 1 g/a ] -Notice that we MUST substitute for 'k'; this happens in -liftCoSubstTyVarBndr. But what should we substitute? -We need to take b's kind 'k' and return a Kind, not a Coercion! - -Happily we can do this because we know that all kind coercions -((Nth 0 g) in this case) are Refl. So we need a special purpose - subst_kind: LiftCoSubst -> Kind -> Kind -that expects a Refl coercion (or something equivalent to Refl) -when it looks up a kind variable. +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 -} -- ---------------------------------------------------- -- See Note [Lifting coercions over types: liftCoSubst] -- ---------------------------------------------------- -data LiftCoSubst = LCS InScopeSet LiftCoEnv +data LiftingContext = LC TCvSubst LiftCoEnv + -- in optCoercion, we need to lift when optimizing InstCo. + -- See Note [Optimising InstCo] in OptCoercion + -- We thus propagate the substitution from OptCoercion here. + +instance Outputable LiftingContext where + ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) type LiftCoEnv = VarEnv Coercion - -- Maps *type variables* to *coercions* + -- Maps *type variables* to *coercions*. -- That's the whole point of this function! -liftCoSubstWith :: Role -> [TyVar] -> [Coercion] -> Type -> Coercion +-- 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 + -> [TyVar] -- existentially quantified tyvars + -> [Type] -- types 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, substTyVars (lcSubstRight psi) exs) + +liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion +-- NB: This really can be called with CoVars, when optimising axioms. liftCoSubstWith r tvs cos ty - = liftCoSubst r (zipEqual "liftCoSubstWith" tvs cos) ty - -liftCoSubst :: Role -> [(TyVar,Coercion)] -> Type -> Coercion -liftCoSubst r prs ty - | null prs = Refl r ty - | otherwise = ty_co_subst (LCS (mkInScopeSet (tyCoVarsOfCos (map snd prs))) - (mkVarEnv prs)) r 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 :: Role -> LiftingContext -> Type -> Coercion +liftCoSubst r lc@(LC subst env) ty + | isEmptyVarEnv env = Refl 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 /type/ mapping. +extendLiftingContext :: LiftingContext -- ^ original LC + -> TyVar -- ^ new variable to map... + -> Coercion -- ^ ...to this lifted version + -> LiftingContext +extendLiftingContext (LC subst env) tv arg + = ASSERT( isTyVar tv ) + LC subst (extendVarEnv env tv arg) + +-- | Extend a lifting context with existential-variable bindings. +-- This follows the lifting context extension definition in the +-- "FC with Explicit Kind Equality" paper. +extendLiftingContextEx :: LiftingContext -- ^ original lifting context + -> [(TyVar,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. + = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) + (extendVarEnv env v (mkSymCo $ mkCoherenceCo + (mkNomReflCo ty) + (ty_co_subst lc Nominal (tyVarKind v)))) + in extendLiftingContextEx lc' rest + +-- | 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 +substForAllCoBndrCallbackLC :: Bool + -> (Coercion -> Coercion) + -> LiftingContext -> TyVar -> Coercion + -> (LiftingContext, TyVar, Coercion) +substForAllCoBndrCallbackLC sym sco (LC subst lc_env) tv co + = (LC subst' lc_env, tv', co') + where + (subst', tv', co') = substForAllCoBndrCallback 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' - --- The Role parameter is the _desired_ role -ty_co_subst :: LiftCoSubst -> Role -> Type -> Coercion -ty_co_subst subst role ty +ty_co_subst :: LiftingContext -> Role -> Type -> Coercion +ty_co_subst lc role ty = go role ty where - go Phantom ty = lift_phantom ty - go role (TyVarTy tv) = liftCoSubstTyVar subst role tv - `orElse` Refl role (TyVarTy tv) - -- A type variable from a non-cloned forall - -- won't be in the substitution - go role (AppTy ty1 ty2) = mkAppCo (go role ty1) (go Nominal ty2) - go role (TyConApp tc tys) = mkTyConAppCo role tc - (zipWith go (tyConRolesX role tc) tys) - -- IA0_NOTE: Do we need to do anything - -- about kind instantiations? I don't think - -- so. see Note [Kind coercions] - go role (FunTy ty1 ty2) = mkFunCo role (go role ty1) (go role ty2) - go role (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' role ty) - where - (subst', v') = liftCoSubstTyVarBndr subst v - go role ty@(LitTy {}) = ASSERT( role == Nominal ) - mkReflCo role ty - - lift_phantom ty = mkUnivCo (fsLit "lift_phantom") - Phantom (liftCoSubstLeft subst ty) - (liftCoSubstRight subst ty) + go :: Role -> Type -> Coercion + 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 (ForAllTy (Anon ty1) ty2) + = mkFunCo r (go r ty1) (go r ty2) + go r (ForAllTy (Named v _) ty) + = let (lc', v', h) = liftCoSubstVarBndr lc v in + mkForAllCo v' h $! ty_co_subst lc' r ty + go r ty@(LitTy {}) = ASSERT( r == Nominal ) + mkReflCo r ty + go r (CastTy ty co) = castCoercionKind (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 (i.e., return Nothing) for two separate reasons: - 1) The variable is not in the substutition - 2) The coercion found is of too low a role +~~~~~~~~~~~~~~~~~~~~~~~~~ +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 OptCoercion. From liftCoSubst, the so-called lifting -lemma guarantees that the roles work out. If we fail for reason 2) in this +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 for reason 2) is fine. matchAxiom is trying to find a set of coercions -that match, but it may fail, and this is healthy behavior. Bottom line: if -you find that liftCoSubst is doing weird things (like leaving out-of-scope -variables lying around), disable coercion optimization (bypassing matchAxiom) -and use downgradeRole instead of downgradeRole_maybe. The panic will then happen, -and you may learn something useful. +failing is fine. matchAxiom is trying to find a set of coercions +that match, but it may fail, and this is healthy behavior. -} -liftCoSubstTyVar :: LiftCoSubst -> Role -> TyVar -> Maybe Coercion -liftCoSubstTyVar (LCS _ cenv) r tv - = do { co <- lookupVarEnv cenv tv - ; let co_role = coercionRole co -- could theoretically take this as - -- a parameter, but painful - ; downgradeRole_maybe r co_role co } -- see Note [liftCoSubstTyVar] +-- 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 -liftCoSubstTyVarBndr :: LiftCoSubst -> TyVar -> (LiftCoSubst, TyVar) -liftCoSubstTyVarBndr subst@(LCS in_scope cenv) old_var - = (LCS (in_scope `extendInScopeSet` new_var) new_cenv, new_var) + | otherwise + = Just $ Refl r (substTyVar subst v) + +liftCoSubstVarBndr :: LiftingContext -> TyVar + -> (LiftingContext, TyVar, Coercion) +liftCoSubstVarBndr lc tv + = let (lc', tv', h, _) = liftCoSubstVarBndrCallback callback lc tv in + (lc', tv', h) + where + callback lc' ty' = (ty_co_subst lc' Nominal ty', ()) + +-- the callback must produce a nominal coercion +liftCoSubstVarBndrCallback :: (LiftingContext -> Type -> (Coercion, a)) + -> LiftingContext -> TyVar + -> (LiftingContext, TyVar, Coercion, a) +liftCoSubstVarBndrCallback fun lc@(LC subst cenv) old_var + = ( LC (subst `extendTCvInScope` new_var) new_cenv + , new_var, eta, stuff ) where - new_cenv | no_change = delVarEnv cenv old_var - | otherwise = extendVarEnv cenv old_var (Refl Nominal (TyVarTy new_var)) + old_kind = tyVarKind old_var + (eta, stuff) = fun lc old_kind + Pair k1 _ = coercionKind eta + new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) - no_change = no_kind_change && (new_var == old_var) + lifted = Refl Nominal (TyVarTy new_var) + new_cenv = extendVarEnv cenv old_var lifted - new_var1 = uniqAway in_scope old_var +-- | Is a var in the domain of a lifting context? +isMappedByLC :: TyCoVar -> LiftingContext -> Bool +isMappedByLC tv (LC _ env) = tv `elemVarEnv` env - old_ki = tyVarKind old_var - no_kind_change = isEmptyVarSet (tyVarsOfType old_ki) - new_var | no_kind_change = new_var1 - | otherwise = setTyVarKind new_var1 (subst_kind subst old_ki) +-- 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 --- map every variable to the type on the *left* of its mapped coercion -liftCoSubstLeft :: LiftCoSubst -> Type -> Type -liftCoSubstLeft (LCS in_scope cenv) ty - = Type.substTy (mkTvSubst in_scope (mapVarEnv (pFst . coercionKind) cenv)) ty +-- Ditto, but for t2 and g2 +substRightCo :: LiftingContext -> Coercion -> Coercion +substRightCo lc co + = substCo (lcSubstRight lc) co --- same, but to the type on the right -liftCoSubstRight :: LiftCoSubst -> Type -> Type -liftCoSubstRight (LCS in_scope cenv) ty - = Type.substTy (mkTvSubst in_scope (mapVarEnv (pSnd . coercionKind) cenv)) ty +-- | Apply "sym" to all coercions in a 'LiftCoEnv' +swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv +swapLiftCoEnv = mapVarEnv mkSymCo -subst_kind :: LiftCoSubst -> Kind -> Kind --- See Note [Substituting kinds in liftCoSubst] -subst_kind subst@(LCS _ cenv) kind - = go kind - where - go (LitTy n) = n `seq` LitTy n - go (TyVarTy kv) = subst_kv kv - go (TyConApp tc tys) = let args = map go tys - in args `seqList` TyConApp tc args - - go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) - go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) - go (ForAllTy tv ty) = case liftCoSubstTyVarBndr subst tv of - (subst', tv') -> - ForAllTy tv' $! (subst_kind subst' ty) - - subst_kv kv - | Just co <- lookupVarEnv cenv kv - , let co_kind = coercionKind co - = ASSERT2( pFst co_kind `eqKind` pSnd co_kind, ppr kv $$ ppr co ) - pFst co_kind - | otherwise - = TyVarTy kv - --- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if --- @liftCoMatch vars ty co == Just s@, then @tyCoSubst s ty == co@. --- 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. -liftCoMatch :: TyVarSet -> Type -> Coercion -> Maybe LiftCoSubst -liftCoMatch tmpls ty co - = case ty_co_match menv emptyVarEnv ty co of - Just cenv -> Just (LCS in_scope cenv) - Nothing -> Nothing - 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 - --- | 'ty_co_match' does all the actual work for 'liftCoMatch'. -ty_co_match :: MatchEnv -> LiftCoEnv -> Type -> Coercion -> Maybe LiftCoEnv -ty_co_match menv subst ty co - | Just ty' <- coreView ty = ty_co_match menv subst ty' co - - -- Match a type variable against a non-refl coercion -ty_co_match menv cenv (TyVarTy tv1) co - | Just co1' <- lookupVarEnv cenv tv1' -- tv1' is already bound to co1 - = if coreEqCoercion2 (nukeRnEnvL rn_env) co1' co - then Just cenv - 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) (varSetElems (tyCoVarsOfCo co)) - then Nothing -- occurs check failed - else return (extendVarEnv cenv tv1' co) - -- BAY: I don't think we need to do any kind matching here yet - -- (compare 'match'), but we probably will when moving to SHE. - - | otherwise -- tv1 is not a template ty var, so the only thing it - -- can match is a reflexivity coercion for itself. - -- But that case is dealt with already - = Nothing +lcSubstLeft :: LiftingContext -> TCvSubst +lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env - where - rn_env = me_env menv - tv1' = rnOccL rn_env tv1 - -ty_co_match menv subst (AppTy ty1 ty2) co - | Just (co1, co2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy - = do { subst' <- ty_co_match menv subst ty1 co1 - ; ty_co_match menv subst' ty2 co2 } +lcSubstRight :: LiftingContext -> TCvSubst +lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env -ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) - | tc1 == tc2 = ty_co_matches menv subst tys cos +liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstLeft = liftEnvSubst pFst -ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo _ tc cos) - | tc == funTyCon = ty_co_matches menv subst [ty1,ty2] cos +liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstRight = liftEnvSubst pSnd -ty_co_match menv subst (ForAllTy tv1 ty) (ForAllCo tv2 co) - = ty_co_match menv' subst ty co +liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubst selector subst lc_env + = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst where - menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 } - -ty_co_match menv subst ty co - | Just co' <- pushRefl co = ty_co_match menv subst ty co' - | otherwise = Nothing + pairs = varEnvToList lc_env + (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) -ty_co_matches :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion] -> Maybe LiftCoEnv -ty_co_matches menv = matchList (ty_co_match menv) +-- | Extract the underlying substitution from the LiftingContext +lcTCvSubst :: LiftingContext -> TCvSubst +lcTCvSubst (LC subst _) = subst -pushRefl :: Coercion -> Maybe Coercion -pushRefl (Refl Nominal (AppTy ty1 ty2)) - = Just (AppCo (Refl Nominal ty1) (Refl Nominal ty2)) -pushRefl (Refl r (FunTy ty1 ty2)) - = Just (TyConAppCo r funTyCon [Refl r ty1, Refl r ty2]) -pushRefl (Refl r (TyConApp tc tys)) - = Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) -pushRefl (Refl r (ForAllTy tv ty)) = Just (ForAllCo tv (Refl r ty)) -pushRefl _ = Nothing +-- | Get the 'InScopeSet' from a 'LiftingContext' +lcInScopeSet :: LiftingContext -> InScopeSet +lcInScopeSet (LC subst _) = getTCvInScope subst {- -************************************************************************ -* * +%************************************************************************ +%* * Sequencing on coercions -* * -************************************************************************ +%* * +%************************************************************************ -} seqCo :: Coercion -> () -seqCo (Refl eq ty) = eq `seq` seqType ty -seqCo (TyConAppCo eq tc cos) = eq `seq` tc `seq` seqCos cos +seqCo (Refl r ty) = r `seq` seqType ty +seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (ForAllCo tv co) = seqType (tyVarKind tv) `seq` seqCo co +seqCo (ForAllCo tv k co) = seqType (tyVarKind tv) `seq` seqCo k + `seq` seqCo co seqCo (CoVarCo cv) = cv `seq` () seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos -seqCo (UnivCo s r ty1 ty2) = s `seq` r `seq` seqType ty1 `seq` seqType ty2 +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 n co) = n `seq` seqCo co seqCo (LRCo lr co) = lr `seq` seqCo co -seqCo (InstCo co ty) = seqCo co `seq` seqType ty +seqCo (InstCo co arg) = seqCo co `seq` seqCo arg +seqCo (CoherenceCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (KindCo co) = seqCo co seqCo (SubCo co) = seqCo co -seqCo (AxiomRuleCo _ ts cs) = seqTypes ts `seq` seqCos cs +seqCo (AxiomRuleCo _ cs) = seqCos cs + +seqProv :: UnivCoProvenance -> () +seqProv UnsafeCoerceProv = () +seqProv (PhantomProv co) = seqCo co +seqProv (ProofIrrelProv co) = seqCo co +seqProv (PluginProv _) = () +seqProv (HoleProv _) = () seqCos :: [Coercion] -> () seqCos [] = () seqCos (co:cos) = seqCo co `seq` seqCos cos {- -************************************************************************ -* * +%************************************************************************ +%* * The kind of a type, and of a coercion -* * -************************************************************************ +%* * +%************************************************************************ Note [Computing a coercion kind and role] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1933,7 +1702,7 @@ the kind is all you want. coercionType :: Coercion -> Type coercionType co = case coercionKindRole co of - (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 + (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 ------------------ -- | If it is the case that @@ -1945,35 +1714,63 @@ coercionType co = case coercionKindRole co of coercionKind :: Coercion -> Pair Type coercionKind co = go co where - go (Refl _ ty) = Pair ty ty - go (TyConAppCo _ tc cos) = mkTyConApp tc <$> (sequenceA $ map go cos) - go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 - go (ForAllCo tv co) = mkForAllTy tv <$> go co - go (CoVarCo cv) = toPair $ coVarKind cv + go (Refl _ ty) = Pair ty ty + go (TyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos) + go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 + go (ForAllCo tv1 k_co co) + = let Pair _ k2 = go k_co + tv2 = setTyVarKind tv1 k2 + Pair ty1 ty2 = go co + ty2' = substTyWith [tv1] [TyVarTy tv2 `mkCastTy` mkSymCo k_co] ty2 in + mkNamedForAllTy <$> Pair tv1 tv2 <*> pure Invisible <*> Pair ty1 ty2' + go (CoVarCo cv) = toPair $ coVarTypes cv go (AxiomInstCo ax ind cos) - | CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind - , Pair tys1 tys2 <- sequenceA (map go cos) - = ASSERT( cos `equalLength` tvs ) -- Invariant of AxiomInstCo: cos should - -- exactly saturate the axiom branch - Pair (substTyWith tvs tys1 (mkTyConApp (coAxiomTyCon ax) lhs)) - (substTyWith tvs tys2 rhs) - go (UnivCo _ _ ty1 ty2) = Pair ty1 ty2 - go (SymCo co) = swap $ go co - go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) - go (NthCo d co) = tyConAppArgN d <$> go co - go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co - go (InstCo aco ty) = go_app aco [ty] - go (SubCo co) = go co - go (AxiomRuleCo ax tys cos) = - case coaxrProves ax tys (map go cos) of - Just res -> res - Nothing -> panic "coercionKind: Malformed coercion" - - go_app :: Coercion -> [Type] -> Pair Type + | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind + , let Pair tycos1 tycos2 = sequenceA (map go cos) + (tys1, cotys1) = splitAtList tvs tycos1 + (tys2, cotys2) = splitAtList tvs tycos2 + cos1 = map stripCoercionTy cotys1 + cos2 = map stripCoercionTy cotys2 + = ASSERT( cos `equalLength` (tvs ++ cvs) ) + -- Invariant of AxiomInstCo: cos should + -- exactly saturate the axiom branch + Pair (substTyWith tvs tys1 $ + substTyWithCoVars cvs cos1 $ + mkTyConApp (coAxiomTyCon ax) lhs) + (substTyWith tvs tys2 $ + substTyWithCoVars cvs cos2 rhs) + go (UnivCo _ _ ty1 ty2) = Pair ty1 ty2 + go (SymCo co) = swap $ go co + go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) + go g@(NthCo d co) + | Just argss <- traverse tyConAppArgs_maybe tys + = ASSERT( and $ ((d <) . length) <$> argss ) + (`getNth` d) <$> argss + + | d == 0 + , Just splits <- traverse splitForAllTy_maybe tys + = (tyVarKind . fst) <$> splits + + | otherwise + = pprPanic "coercionKind" (ppr g) + where + tys = go co + go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co + go (InstCo aco arg) = go_app aco [arg] + go (CoherenceCo g h) + = let Pair ty1 ty2 = go g in + Pair (mkCastTy ty1 h) ty2 + go (KindCo co) = typeKind <$> go co + go (SubCo co) = go co + go (AxiomRuleCo ax cos) = expectJust "coercionKind" $ + coaxrProves ax (map go cos) + + go_app :: Coercion -> [Coercion] -> Pair Type -- Collect up all the arguments and apply all at once -- See Note [Nested InstCos] - go_app (InstCo co ty) tys = go_app co (ty:tys) - go_app co tys = (`applyTys` tys) <$> go co + go_app (InstCo co arg) args = go_app co (arg:args) + go_app co args = applyTys <$> go co <*> (sequenceA $ map go args) -- | Apply 'coercionKind' to multiple 'Coercion's coercionKinds :: [Coercion] -> Pair [Type] @@ -1990,35 +1787,50 @@ coercionKindRole = go go (AppCo co1 co2) = let (tys1, r1) = go co1 in (mkAppTy <$> tys1 <*> coercionKind co2, r1) - go (ForAllCo tv co) - = let (tys, r) = go co in - (mkForAllTy tv <$> tys, r) - go (CoVarCo cv) = (toPair $ coVarKind cv, coVarRole cv) + go (ForAllCo tv1 k_co co) + = let Pair _ k2 = coercionKind k_co + tv2 = setTyVarKind tv1 k2 + (Pair ty1 ty2, r) = go co + ty2' = substTyWith [tv1] [TyVarTy tv2 `mkCastTy` mkSymCo k_co] ty2 in + (mkNamedForAllTy <$> Pair tv1 tv2 <*> pure Invisible <*> Pair ty1 ty2', r) + go (CoVarCo cv) = (toPair $ coVarTypes cv, coVarRole cv) go co@(AxiomInstCo ax _ _) = (coercionKind co, coAxiomRole ax) - go (UnivCo _ r ty1 ty2) = (Pair ty1 ty2, r) + go (UnivCo _ r ty1 ty2) = (Pair ty1 ty2, r) go (SymCo co) = first swap $ go co go (TransCo co1 co2) = let (tys1, r) = go co1 in (Pair (pFst tys1) (pSnd $ coercionKind co2), r) go (NthCo d co) - = let (Pair t1 t2, r) = go co - (tc1, args1) = splitTyConApp t1 - (_tc2, args2) = splitTyConApp t2 + | Just (tv1, _) <- splitForAllTy_maybe ty1 + = ASSERT( d == 0 ) + let (tv2, _) = splitForAllTy ty2 in + (tyVarKind <$> Pair tv1 tv2, Nominal) + + | otherwise + = let (tc1, args1) = splitTyConApp ty1 + (_tc2, args2) = splitTyConApp ty2 in ASSERT( tc1 == _tc2 ) ((`getNth` d) <$> Pair args1 args2, nthRole r tc1 d) + + where + (Pair ty1 ty2, r) = go co go co@(LRCo {}) = (coercionKind co, Nominal) - go (InstCo co ty) = go_app co [ty] + go (InstCo co arg) = go_app co [arg] + go (CoherenceCo co1 co2) + = let (Pair t1 t2, r) = go co1 in + (Pair (t1 `mkCastTy` co2) t2, r) + go co@(KindCo {}) = (coercionKind co, Nominal) go (SubCo co) = (coercionKind co, Representational) - go co@(AxiomRuleCo ax _ _) = (coercionKind co, coaxrRole ax) + go co@(AxiomRuleCo ax _) = (coercionKind co, coaxrRole ax) - go_app :: Coercion -> [Type] -> (Pair Type, Role) + go_app :: Coercion -> [Coercion] -> (Pair Type, Role) -- Collect up all the arguments and apply all at once -- See Note [Nested InstCos] - go_app (InstCo co ty) tys = go_app co (ty:tys) - go_app co tys + go_app (InstCo co arg) args = go_app co (arg:args) + go_app co args = let (pair, r) = go co in - ((`applyTys` tys) <$> pair, r) + (applyTys <$> pair <*> (sequenceA $ map coercionKind args), r) -- | Retrieve the role from a coercion. coercionRole :: Coercion -> Role @@ -2042,18 +1854,5 @@ But this is a *quadratic* algorithm, and the blew up Trac #5631. So it's very important to do the substitution simultaneously. cf Type.applyTys (which in fact we call here) --} -applyCo :: Type -> Coercion -> Type --- Gives the type of (e co) where e :: (a~b) => ty -applyCo ty co | Just ty' <- coreView ty = applyCo ty' co -applyCo (FunTy _ ty) _ = ty -applyCo _ _ = panic "applyCo" - -{- -Note [Kind coercions] -~~~~~~~~~~~~~~~~~~~~~ -Kind coercions are only of the form: Refl kind. They are only used to -instantiate kind polymorphic type constructors in TyConAppCo. Remember -that kind instantiation only happens with TyConApp, not AppTy. -} diff --git a/compiler/types/Coercion.hs-boot b/compiler/types/Coercion.hs-boot new file mode 100644 index 0000000000..29f814a628 --- /dev/null +++ b/compiler/types/Coercion.hs-boot @@ -0,0 +1,46 @@ +module Coercion where + +import {-# SOURCE #-} TyCoRep +import {-# SOURCE #-} TyCon + +import CoAxiom +import Var +import Outputable +import Pair + +mkReflCo :: Role -> Type -> Coercion +mkTyConAppCo :: Role -> TyCon -> [Coercion] -> Coercion +mkAppCo :: Coercion -> Coercion -> Coercion +mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion +mkCoVarCo :: CoVar -> Coercion +mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkUnsafeCo :: Role -> Type -> Type -> Coercion +mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion +mkSymCo :: Coercion -> Coercion +mkTransCo :: Coercion -> Coercion -> Coercion +mkNthCo :: Int -> Coercion -> Coercion +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkInstCo :: Coercion -> Coercion -> Coercion +mkCoherenceCo :: Coercion -> Coercion -> Coercion +mkKindCo :: Coercion -> Coercion +mkSubCo :: Coercion -> Coercion +mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion + +mkFunCos :: Role -> [Coercion] -> Coercion -> Coercion + +isReflCo :: Coercion -> Bool +coVarKindsTypesRole :: CoVar -> (Kind, Kind, Type, Type, Role) +coVarRole :: CoVar -> Role + +mkCoercionType :: Role -> Type -> Type -> Type + +data LiftingContext +liftCoSubst :: Role -> LiftingContext -> Type -> Coercion +coercionSize :: Coercion -> Int +seqCo :: Coercion -> () + +coercionKind :: Coercion -> Pair Type +coercionType :: Coercion -> Type + +pprCo :: Coercion -> SDoc diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs index a60b1c231c..b5d3c21d0a 100644 --- a/compiler/types/FamInstEnv.hs +++ b/compiler/types/FamInstEnv.hs @@ -30,7 +30,7 @@ module FamInstEnv ( -- Normalisation topNormaliseType, topNormaliseType_maybe, normaliseType, normaliseTcApp, - reduceTyFamApp_maybe, chooseBranch, + reduceTyFamApp_maybe, -- Flattening flattenTys @@ -42,13 +42,14 @@ import InstEnv import Unify import Type import TcType ( orphNamesOfTypes ) -import TypeRep +import TyCoRep import TyCon import Coercion import CoAxiom import VarSet import VarEnv import Name +import PrelNames ( eqPrimTyConKey ) import UniqFM import Outputable import Maybes @@ -60,6 +61,8 @@ import Pair import SrcLoc import NameSet import FastString +import MonadUtils +import Control.Monad import Data.Function ( on ) {- @@ -107,8 +110,11 @@ data FamInst -- See Note [FamInsts and CoAxioms] -- See Note [Template tyvars are fresh] in InstEnv -- INVARIANT: fi_tvs = coAxiomTyVars fi_axiom - , fi_tys :: [Type] -- The LHS type patterns - -- May be eta-reduced; see Note [Eta reduction for data families] + , fi_cvs :: [CoVar] -- Template covars for full match + + , 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 } @@ -285,6 +291,7 @@ mkImportedFamInst fam mb_tcs axiom fi_fam = fam, fi_tcs = mb_tcs, fi_tvs = tvs, + fi_cvs = cvs, fi_tys = tys, fi_rhs = rhs, fi_axiom = axiom, @@ -293,6 +300,7 @@ mkImportedFamInst fam mb_tcs axiom -- 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 @@ -593,19 +601,22 @@ Instead we must tidy those kind variables. See Trac #7524. -- all axiom roles are Nominal, as this is only used with type families mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars + -> [CoVar] -- possibly stale covars -> [Type] -- LHS patterns -> Type -- RHS -> SrcSpan -> CoAxBranch -mkCoAxBranch tvs lhs rhs loc +mkCoAxBranch tvs cvs lhs rhs loc = CoAxBranch { cab_tvs = tvs1 + , cab_cvs = cvs1 , cab_lhs = tidyTypes env lhs , cab_roles = map (const Nominal) tvs1 , cab_rhs = tidyType env rhs , cab_loc = loc , cab_incomps = placeHolderIncomps } where - (env, tvs1) = tidyTyVarBndrs emptyTidyEnv tvs + (env1, tvs1) = tidyTyCoVarBndrs emptyTidyEnv tvs + (env, cvs1) = tidyTyCoVarBndrs env1 cvs -- See Note [Tidy axioms when we build them] -- all of the following code is here to avoid mutual dependencies with @@ -630,12 +641,12 @@ mkUnbranchedCoAxiom ax_name fam_tc branch , co_ax_branches = unbranched (branch { cab_incomps = [] }) } mkSingleCoAxiom :: Role -> Name - -> [TyVar] -> TyCon -> [Type] -> Type + -> [TyVar] -> [CoVar] -> TyCon -> [Type] -> Type -> CoAxiom Unbranched -- Make a single-branch CoAxiom, incluidng 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 fam_tc lhs_tys rhs_ty +mkSingleCoAxiom role ax_name 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 @@ -643,7 +654,7 @@ mkSingleCoAxiom role ax_name tvs fam_tc lhs_tys rhs_ty , co_ax_implicit = False , co_ax_branches = unbranched (branch { cab_incomps = [] }) } where - branch = mkCoAxBranch tvs lhs_tys rhs_ty (getSrcSpan ax_name) + branch = mkCoAxBranch tvs cvs lhs_tys rhs_ty (getSrcSpan ax_name) {- ************************************************************************ @@ -674,13 +685,15 @@ we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. -- 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 }) - = ptext (sLit "match with") <+> parens (ppr inst) <+> ppr tys + , fim_tys = tys + , fim_cos = cos }) + = ptext (sLit "match with") <+> parens (ppr inst) <+> ppr tys <+> ppr cos lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc @@ -719,7 +732,7 @@ lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) -- In example above, fam tys' = F [b] my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ - = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs, + = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs, (ppr fam <+> ppr tys) $$ (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap @@ -880,7 +893,7 @@ Note [Family instance overlap conflicts] type MatchFun = FamInst -- The FamInst template -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst -> [Type] -- Target to match against - -> Maybe TvSubst + -> Maybe TCvSubst lookup_fam_inst_env' -- The worker, local to this module :: MatchFun @@ -895,8 +908,8 @@ lookup_fam_inst_env' match_fun ie fam match_tys where find [] = [] - find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, - fi_tys = tpl_tys }) : rest) + 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 @@ -904,7 +917,10 @@ lookup_fam_inst_env' match_fun ie fam match_tys -- 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_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 @@ -1012,68 +1028,76 @@ reduceTyFamApp_maybe :: FamInstEnvs -- -- 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 + 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 = fam_inst - , fim_tys = inst_tys } : _ <- lookupFamInstEnv envs tc tys + , 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 ax = famInstAxiom fam_inst - co = mkUnbranchedAxInstCo role ax inst_tys - ty = pSnd (coercionKind co) + + = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos + ty = pSnd (coercionKind co) in Just (co, ty) | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc - , Just (ind, inst_tys) <- chooseBranch ax tys - = let co = mkAxInstCo role ax ind inst_tys - ty = pSnd (coercionKind co) + , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys + = let co = mkAxInstCo role ax ind inst_tys inst_cos + ty = pSnd (coercionKind co) in Just (co, ty) | Just ax <- isBuiltInSynFamTyCon_maybe tc , Just (coax,ts,ty) <- sfMatchFam ax tys - = let co = mkAxiomRuleCo coax ts [] + = 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]) +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) <- findBranch (fromBranches branches) target_tys - ; return (ind, inst_tys ++ extra_tys) } + ; (ind, inst_tys, inst_cos) + <- findBranch (fromBranches branches) target_tys + ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) } -- The axiom must *not* be oversaturated findBranch :: [CoAxBranch] -- branches to check -> [Type] -- target types - -> Maybe (BranchIndex, [Type]) + -> Maybe (BranchIndex, [Type], [Coercion]) + -- coercions relate requested types to returned axiom LHS at role N findBranch branches target_tys = go 0 branches where - go ind (branch@(CoAxBranch { cab_tvs = tpl_tvs, cab_lhs = tpl_lhs + go ind (branch@(CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs + , cab_lhs = tpl_lhs , cab_incomps = incomps }) : rest) = let in_scope = mkInScopeSet (unionVarSets $ - map (tyVarsOfTypes . coAxBranchLHS) incomps) + map (tyCoVarsOfTypes . coAxBranchLHS) incomps) -- See Note [Flattening] below flattened_target = flattenTys in_scope target_tys - in case tcMatchTys (mkVarSet tpl_tvs) tpl_lhs target_tys of + in case tcMatchTys (mkVarSet (tpl_tvs ++ tpl_cvs)) 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 - Just (ind, substTyVars subst tpl_tvs) + ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) + Just (ind, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) -- failure. keep looking _ -> go (ind+1) rest @@ -1106,6 +1130,46 @@ apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps }) 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 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 liftCoSubstVarBndrCallback, 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. + -} topNormaliseType :: FamInstEnvs -> Type -> Type @@ -1137,70 +1201,179 @@ topNormaliseType_maybe env ty tyFamStepper rec_nts tc tys -- Try to step a type/data familiy = let (args_co, ntys) = normaliseTcArgs env Representational tc tys in + -- NB: It's OK to use normaliseTcArgs here instead of + -- normalise_tc_args (which takes the LiftingContext described + -- in Note [Normalising types]) because the reduceTyFamApp below + -- works only at top level. We'll never recur in this function + -- after reducing the kind of a bound tyvar. + case reduceTyFamApp_maybe env Representational tc ntys of Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co) - Nothing -> NS_Done + _ -> NS_Done --------------- normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) -- See comments on normaliseType for the arguments of this function normaliseTcApp env role tc tys - | isTypeSynonymTyCon tc - , Just (tenv, rhs, ntys') <- expandSynTyCon_maybe tc ntys - , (co2, ninst_rhs) <- normaliseType env role (Type.substTy (mkTopTvSubst tenv) rhs) - = if isReflCo co2 then (args_co, mkTyConApp tc ntys) - else (args_co `mkTransCo` co2, mkAppTys ninst_rhs ntys') - - | Just (first_co, ty') <- reduceTyFamApp_maybe env role tc ntys - , (rest_co,nty) <- normaliseType env role ty' - = (args_co `mkTransCo` first_co `mkTransCo` rest_co, nty) - - | otherwise -- No unique matching family instance exists; + = 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 + = do { (args_co, ntys) <- normalise_tc_args tc tys + ; case expandSynTyCon_maybe tc ntys of + { Just (tenv, rhs, ntys') -> + do { (co2, ninst_rhs) + <- normalise_type (substTy (mkTopTCvSubst tenv) rhs) + ; return $ + if isReflCo co2 + then (args_co, mkTyConApp tc ntys) + else (args_co `mkTransCo` co2, mkAppTys ninst_rhs ntys') } + ; Nothing -> + do { env <- getEnv + ; role <- getRole + ; case reduceTyFamApp_maybe env role tc ntys of + Just (first_co, ty') + -> do { (rest_co,nty) <- normalise_type ty' + ; return ( args_co `mkTransCo` first_co `mkTransCo` rest_co + , nty ) } + _ -> -- No unique matching family instance exists; -- we do not do anything - = (args_co, mkTyConApp tc ntys) - - where - (args_co, ntys) = normaliseTcArgs env role tc tys - + return (args_co, mkTyConApp tc ntys) }}} --------------- -normaliseTcArgs :: FamInstEnvs -- environment with family instances - -> Role -- desired role of output coercion - -> TyCon -> [Type] -- tc tys - -> (Coercion, [Type]) -- (co, new_tys), where - -- co :: tc tys ~ tc new_tys +-- | Normalise arguments to a tycon +normaliseTcArgs :: FamInstEnvs -- ^ env't with family instances + -> Role -- ^ desired role of output coercion + -> TyCon -- ^ tc + -> [Type] -- ^ tys + -> (Coercion, [Type]) -- ^ co :: tc tys ~ tc new_tys normaliseTcArgs env role tc tys - = (mkTyConAppCo role tc cois, ntys) + = initNormM env role (tyCoVarsOfTypes tys) $ + normalise_tc_args tc tys + +normalise_tc_args :: TyCon -> [Type] -- tc tys + -> NormM (Coercion, [Type]) -- (co, new_tys), where + -- co :: tc tys ~ tc new_tys +normalise_tc_args tc tys + = do { role <- getRole + ; (cois, ntys) <- zipWithAndUnzipM normalise_type_role + tys (tyConRolesX role tc) + ; return (mkTyConAppCo role tc cois, ntys) } where - (cois, ntys) = zipWithAndUnzip (normaliseType env) (tyConRolesX role tc) tys + normalise_type_role ty r = withRole r $ normalise_type ty --------------- -normaliseType :: FamInstEnvs -- environment with family instances - -> Role -- desired role of output coercion - -> Type -- old type - -> (Coercion, Type) -- (coercion,new type), where - -- co :: old-type ~ new_type +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 to not to disturb type synonyms if possible -normaliseType env role (TyConApp tc tys) - = normaliseTcApp env role tc tys -normaliseType _env role ty@(LitTy {}) = (mkReflCo role ty, ty) -normaliseType env role (AppTy ty1 ty2) - = let (coi1,nty1) = normaliseType env role ty1 - (coi2,nty2) = normaliseType env Nominal ty2 - in (mkAppCo coi1 coi2, mkAppTy nty1 nty2) -normaliseType env role (FunTy ty1 ty2) - = let (coi1,nty1) = normaliseType env role ty1 - (coi2,nty2) = normaliseType env role ty2 - in (mkFunCo role coi1 coi2, mkFunTy nty1 nty2) -normaliseType env role (ForAllTy tyvar ty1) - = let (coi,nty1) = normaliseType env role ty1 - in (mkForAllCo tyvar coi, ForAllTy tyvar nty1) -normaliseType _ role ty@(TyVarTy _) - = (mkReflCo role ty,ty) +normalise_type + = go + 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) + = do { (co, nty1) <- go ty1 + ; (arg, nty2) <- withRole Nominal $ go ty2 + ; return (mkAppCo co arg, mkAppTy nty1 nty2) } + go (ForAllTy (Anon ty1) ty2) + = do { (co1, nty1) <- go ty1 + ; (co2, nty2) <- go ty2 + ; r <- getRole + ; return (mkFunCo r co1 co2, mkFunTy nty1 nty2) } + go (ForAllTy (Named tyvar vis) ty) + = do { (lc', tv', h, ki') <- normalise_tyvar_bndr tyvar + ; (co, nty) <- withLC lc' $ normalise_type ty + ; let tv2 = setTyVarKind tv' ki' + ; return (mkForAllCo tv' h co, mkNamedForAllTy 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 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 ) } + +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, pSnd $ coercionKind co) + Nothing -> (mkReflCo r ty, ty) } + where ty = mkTyVarTy tv + +normalise_tyvar_bndr :: TyVar -> NormM (LiftingContext, TyVar, Coercion, Kind) +normalise_tyvar_bndr tv + = do { lc1 <- getLC + ; env <- getEnv + ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal + ; return $ liftCoSubstVarBndrCallback callback lc1 tv } + +-- | a monad for the normalisation functions, reading 'FamInstEnvs', +-- a 'LiftingContext', and a 'Role'. +newtype NormM a = NormM { runNormM :: + FamInstEnvs -> LiftingContext -> Role -> a } + +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 + return = pure + ma >>= fmb = NormM $ \env lc r -> + let a = runNormM ma env lc r in + runNormM (fmb a) env lc r + +instance Functor NormM where + fmap = liftM +instance Applicative NormM where + pure x = NormM $ \ _ _ _ -> x + (<*>) = ap {- ************************************************************************ @@ -1242,11 +1415,20 @@ is! Flattening as done below ensures this. flattenTys is defined here because of module dependencies. -} -type FlattenMap = TypeMap TyVar +data FlattenEnv = FlattenEnv { fe_type_map :: TypeMap TyVar + , fe_in_scope :: InScopeSet + , fe_subst :: TCvSubst } + +emptyFlattenEnv :: InScopeSet -> FlattenEnv +emptyFlattenEnv in_scope + = FlattenEnv { fe_type_map = emptyTypeMap + , fe_in_scope = in_scope + , fe_subst = mkTCvSubst in_scope ( emptyTvSubstEnv + , emptyCvSubstEnv ) } -- See Note [Flattening] flattenTys :: InScopeSet -> [Type] -> [Type] -flattenTys in_scope tys = snd $ coreFlattenTys all_in_scope emptyTypeMap tys +flattenTys in_scope tys = snd $ coreFlattenTys env tys where -- when we hit a type function, we replace it with a fresh variable -- but, we need to make sure that this fresh variable isn't mentioned @@ -1254,75 +1436,158 @@ flattenTys in_scope tys = snd $ coreFlattenTys all_in_scope emptyTypeMap tys -- a forall. That way, we can ensure consistency both within and outside -- of that forall. all_in_scope = in_scope `extendInScopeSetSet` allTyVarsInTys tys + env = emptyFlattenEnv all_in_scope -coreFlattenTys :: InScopeSet -> FlattenMap -> [Type] -> (FlattenMap, [Type]) -coreFlattenTys in_scope = go [] +coreFlattenTys :: FlattenEnv -> [Type] -> (FlattenEnv, [Type]) +coreFlattenTys = go [] where - go rtys m [] = (m, reverse rtys) - go rtys m (ty : tys) - = let (m', ty') = coreFlattenTy in_scope m ty in - go (ty' : rtys) m' tys + go rtys env [] = (env, reverse rtys) + go rtys env (ty : tys) + = let (env', ty') = coreFlattenTy env ty in + go (ty' : rtys) env' tys -coreFlattenTy :: InScopeSet -> FlattenMap -> Type -> (FlattenMap, Type) -coreFlattenTy in_scope = go +coreFlattenTy :: FlattenEnv -> Type -> (FlattenEnv, Type) +coreFlattenTy = go where - go m ty | Just ty' <- coreView ty = go m ty' + go env ty | Just ty' <- coreView ty = go env ty' - go m ty@(TyVarTy {}) = (m, ty) - go m (AppTy ty1 ty2) = let (m1, ty1') = go m ty1 - (m2, ty2') = go m1 ty2 in - (m2, AppTy ty1' ty2') - go m (TyConApp tc tys) + go env (TyVarTy tv) = (env, substTyVar (fe_subst env) tv) + 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) - = let (m', tv) = coreFlattenTyFamApp in_scope m tc tys in - (m', mkTyVarTy tv) + = let (env', tv) = coreFlattenTyFamApp env tc tys in + (env', mkTyVarTy tv) | otherwise - = let (m', tys') = coreFlattenTys in_scope m tys in - (m', mkTyConApp tc tys') + = let (env', tys') = coreFlattenTys env tys in + (env', mkTyConApp tc tys') - go m (FunTy ty1 ty2) = let (m1, ty1') = go m ty1 - (m2, ty2') = go m1 ty2 in - (m2, FunTy ty1' ty2') + go env (ForAllTy (Anon ty1) ty2) = let (env1, ty1') = go env ty1 + (env2, ty2') = go env1 ty2 in + (env2, mkFunTy ty1' ty2') - -- Note to RAE: this will have to be changed with kind families - go m (ForAllTy tv ty) = let (m', ty') = go m ty in - (m', ForAllTy tv ty') + go env (ForAllTy (Named tv vis) ty) + = let (env1, tv') = coreFlattenVarBndr env tv + (env2, ty') = go env1 ty in + (env2, mkNamedForAllTy tv' vis ty') - go m ty@(LitTy {}) = (m, ty) + go env ty@(LitTy {}) = (env, ty) -coreFlattenTyFamApp :: InScopeSet -> FlattenMap + go env (CastTy ty co) = let (env1, ty') = go env ty + (env2, co') = coreFlattenCo env1 co in + (env2, CastTy ty' co') + + go env (CoercionTy co) = let (env', co') = coreFlattenCo 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 :: FlattenEnv -> Coercion -> (FlattenEnv, Coercion) +coreFlattenCo env co + = (env2, mkCoVarCo covar) + where + (env1, kind') = coreFlattenTy env (coercionType co) + fresh_name = mkFlattenFreshCoName + in_scope = fe_in_scope env1 + covar = uniqAway in_scope $ mkCoVar fresh_name kind' + env2 = env1 { fe_in_scope = in_scope `extendInScopeSet` covar } + +coreFlattenVarBndr :: FlattenEnv -> TyVar -> (FlattenEnv, TyVar) +coreFlattenVarBndr env tv + | kind' `eqType` kind + = ( env { fe_subst = extendTCvSubst old_subst tv (mkTyVarTy tv) } + -- override any previous binding for tv + , tv) + | otherwise + = let new_tv = uniqAway (fe_in_scope env) (setTyVarKind tv kind') + new_subst = extendTCvSubst old_subst tv (mkTyVarTy new_tv) + new_is = extendInScopeSet old_in_scope new_tv + in + (env' { fe_in_scope = new_is + , fe_subst = new_subst }, new_tv) + where + kind = tyVarKind tv + (env', kind') = coreFlattenTy env kind + old_subst = fe_subst env + old_in_scope = fe_in_scope env + +coreFlattenTyFamApp :: FlattenEnv -> TyCon -- type family tycon -> [Type] -- args - -> (FlattenMap, TyVar) -coreFlattenTyFamApp in_scope m fam_tc fam_args - = case lookupTypeMap m fam_ty of - Just tv -> (m, tv) + -> (FlattenEnv, TyVar) +coreFlattenTyFamApp env fam_tc fam_args + = case lookupTypeMap type_map fam_ty of + Just tv -> (env, tv) -- we need fresh variables here, but this is called far from -- any good source of uniques. So, we just use the fam_tc's unique -- and trust uniqAway to avoid clashes. Recall that the in_scope set -- contains *all* tyvars, even locally bound ones elsewhere in the -- overall type, so this really is fresh. - Nothing -> let tyvar_name = mkSysTvName (getUnique fam_tc) (fsLit "fl") - tv = uniqAway in_scope $ mkTyVar tyvar_name (typeKind fam_ty) - m' = extendTypeMap m fam_ty tv in - (m', tv) - where fam_ty = TyConApp fam_tc fam_args - + Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc + tv = uniqAway in_scope $ mkTyVar tyvar_name + (typeKind fam_ty) + env' = env { fe_type_map = extendTypeMap type_map fam_ty tv + , fe_in_scope = extendInScopeSet in_scope tv } + in (env', tv) + where fam_ty = mkTyConApp fam_tc fam_args + FlattenEnv { fe_type_map = type_map + , fe_in_scope = in_scope } = env + +-- | Get the set of all type variables mentioned anywhere in the list +-- of types. These variables are not necessarily free. allTyVarsInTys :: [Type] -> VarSet allTyVarsInTys [] = emptyVarSet allTyVarsInTys (ty:tys) = allTyVarsInTy ty `unionVarSet` allTyVarsInTys tys +-- | Get the set of all type variables mentioned anywhere in a type. allTyVarsInTy :: Type -> VarSet allTyVarsInTy = go where go (TyVarTy tv) = unitVarSet tv go (AppTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) go (TyConApp _ tys) = allTyVarsInTys tys - go (FunTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) - go (ForAllTy tv ty) = (go (tyVarKind tv)) `unionVarSet` - unitVarSet tv `unionVarSet` - (go ty) -- don't remove tv + go (ForAllTy bndr ty) = + caseBinder bndr (\tv -> unitVarSet tv) (const emptyVarSet) + `unionVarSet` go (binderType bndr) `unionVarSet` go ty + -- don't remove the tv from the set! go (LitTy {}) = emptyVarSet + go (CastTy ty co) = go ty `unionVarSet` go_co co + go (CoercionTy co) = go_co co + + go_co (Refl _ ty) = go ty + go_co (TyConAppCo _ _ args) = go_cos args + go_co (AppCo co arg) = go_co co `unionVarSet` go_co arg + go_co (ForAllCo tv h co) + = unionVarSets [unitVarSet tv, go_co co, go_co h] + go_co (CoVarCo cv) = unitVarSet cv + go_co (AxiomInstCo _ _ cos) = go_cos cos + go_co (UnivCo p _ t1 t2) = go_prov p `unionVarSet` go t1 `unionVarSet` go t2 + go_co (SymCo co) = go_co co + go_co (TransCo c1 c2) = go_co c1 `unionVarSet` go_co c2 + go_co (NthCo _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co arg) = go_co co `unionVarSet` go_co arg + go_co (CoherenceCo c1 c2) = go_co c1 `unionVarSet` go_co c2 + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + go_co (AxiomRuleCo _ cs) = go_cos cs + + go_cos = foldr (unionVarSet . go_co) emptyVarSet + + go_prov UnsafeCoerceProv = emptyVarSet + go_prov (PhantomProv co) = go_co co + go_prov (ProofIrrelProv co) = go_co co + go_prov (PluginProv _) = emptyVarSet + go_prov (HoleProv _) = emptyVarSet + +mkFlattenFreshTyName :: Uniquable a => a -> Name +mkFlattenFreshTyName unq + = mkSysTvName (getUnique unq) (fsLit "flt") + +mkFlattenFreshCoName :: Name +mkFlattenFreshCoName + = mkSystemVarName (deriveUnique eqPrimTyConKey 71) (fsLit "flc") diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index b0ee31e0cb..c3cd916051 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -21,7 +21,7 @@ module InstEnv ( InstEnvs(..), VisibleOrphanModules, InstEnv, emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalClsInstHead, - extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts, + extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, memberInstEnv, instIsVisible, classInstances, orphNamesOfClsInst, instanceBindFun, instanceCantMatch, roughMatchTcs @@ -261,9 +261,10 @@ mkImportedInstance cls_nm mb_tcs dfun oflag orphan roughMatchTcs :: [Type] -> [Maybe Name] roughMatchTcs tys = map rough tys where - rough ty = case tcSplitTyConApp_maybe ty of - Just (tc,_) -> Just (tyConName tc) - Nothing -> Nothing + rough ty + | Just (ty', _) <- tcSplitCastTy_maybe ty = rough ty' + | Just (tc,_) <- tcSplitTyConApp_maybe ty = Just (tyConName tc) + | otherwise = Nothing instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot @@ -676,7 +677,6 @@ where the 'Nothing' indicates that 'b' can be freely instantiated. -- |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]) @@ -711,6 +711,7 @@ lookupInstEnv' ie vis_mods cls tys where rough_tcs = roughMatchTcs tys all_tvs = all isNothing rough_tcs + -------------- lookup env = case lookupUFM env cls of Nothing -> ([],[]) -- No instances for this class @@ -728,7 +729,7 @@ lookupInstEnv' ie vis_mods cls tys = find ms us rest | Just subst <- tcMatchTys tpl_tv_set tpl_tys tys - = find ((item, map (lookup_tv subst) tpl_tvs) : ms) us rest + = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest -- Does not match, so next check whether the things unify -- See Note [Overlapping instances] and Note [Incoherent instances] @@ -736,7 +737,7 @@ lookupInstEnv' ie vis_mods cls tys = find ms us rest | otherwise - = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tv_set, + = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set, (ppr cls <+> ppr tys <+> ppr all_tvs) $$ (ppr tpl_tvs <+> ppr tpl_tys) ) @@ -749,13 +750,6 @@ lookupInstEnv' ie vis_mods cls tys where tpl_tv_set = mkVarSet tpl_tvs - ---------------- - lookup_tv :: TvSubst -> TyVar -> DFunInstType - -- See Note [DFunInstType: instantiating types] - lookup_tv subst tv = case lookupTyVar subst tv of - Just ty -> Just ty - Nothing -> Nothing - --------------- -- This is the common way to call this function. lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions @@ -936,7 +930,7 @@ incoherent instances as long as there are others. ************************************************************************ -} -instanceBindFun :: TyVar -> BindFlag +instanceBindFun :: TyCoVar -> BindFlag instanceBindFun tv | isTcTyVar tv && isOverlappableTyVar tv = Skolem | otherwise = BindMe -- Note [Binding when looking up instances] diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs index 342cab503c..1ce0bbf0ed 100644 --- a/compiler/types/Kind.hs +++ b/compiler/types/Kind.hs @@ -3,57 +3,30 @@ {-# LANGUAGE CPP #-} module Kind ( -- * Main data type - SuperKind, Kind, typeKind, - - -- Kinds - anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, - mkArrowKind, mkArrowKinds, - - -- Kind constructors... - anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, - unliftedTypeKindTyCon, constraintKindTyCon, - - -- Super Kinds - superKind, superKindTyCon, - - pprKind, pprParendKind, - - -- ** Deconstructing Kinds - kindAppResult, tyConResKind, - splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe, + Kind, typeKind, -- ** Predicates on Kinds - isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - isConstraintKind, isConstraintOrLiftedKind, returnsConstraintKind, - isKind, isKindVar, - isSuperKind, isSuperKindTyCon, - isLiftedTypeKindCon, isConstraintKindCon, - isAnyKind, isAnyKindCon, + isLiftedTypeKind, isUnliftedTypeKind, + isConstraintKind, + returnsTyCon, returnsConstraintKind, + isConstraintKindCon, okArrowArgKind, okArrowResultKind, - isSubOpenTypeKind, isSubOpenTypeKindKey, - isSubKind, isSubKindCon, - tcIsSubKind, tcIsSubKindCon, - defaultKind, defaultKind_maybe, - - -- ** Functions on variables - kiVarsOfKind, kiVarsOfKinds - + classifiesTypeWithValues, + isStarKind, isStarKindSynonymTyCon, + isLevityPolymorphic, isLevityPolymorphic_maybe ) where #include "HsVersions.h" -import {-# SOURCE #-} Type ( typeKind, substKiWith, eqKind ) +import {-# SOURCE #-} Type ( typeKind, coreViewOneStarKind ) -import TypeRep -import TysPrim +import TyCoRep import TyCon -import VarSet +import Var import PrelNames -import Outputable -import Maybes( orElse ) -import Util -import FastString +import Data.Maybe +import Util ( (<&&>) ) {- ************************************************************************ @@ -84,219 +57,73 @@ See Trac #7451. Bottom line: although '*' and 'Constraint' are distinct TyCons, with distinct uniques, they are treated as equal at all times except -during type inference. Hence cmpTc treats them as equal. +during type inference. -} --- | Essentially 'funResultTy' on kinds handling pi-types too -kindFunResult :: SDoc -> Kind -> KindOrType -> Kind -kindFunResult _ (FunTy _ res) _ = res -kindFunResult _ (ForAllTy kv res) arg = substKiWith [kv] [arg] res -#ifdef DEBUG -kindFunResult doc k _ = pprPanic "kindFunResult" (ppr k $$ doc) -#else --- Without DEBUG, doc becomes an unsed arg, and will be optimised away -kindFunResult _ _ _ = panic "kindFunResult" -#endif - -kindAppResult :: SDoc -> Kind -> [Type] -> Kind -kindAppResult _ k [] = k -kindAppResult doc k (a:as) = kindAppResult doc (kindFunResult doc k a) as - --- | Essentially 'splitFunTys' on kinds -splitKindFunTys :: Kind -> ([Kind],Kind) -splitKindFunTys (FunTy a r) = case splitKindFunTys r of - (as, k) -> (a:as, k) -splitKindFunTys k = ([], k) - -splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind) -splitKindFunTy_maybe (FunTy a r) = Just (a,r) -splitKindFunTy_maybe _ = Nothing +isConstraintKind :: Kind -> Bool +isConstraintKindCon :: TyCon -> Bool --- | Essentially 'splitFunTysN' on kinds -splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) -splitKindFunTysN 0 k = ([], k) -splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of - (as, k) -> (a:as, k) -splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k) - --- | Find the result 'Kind' of a type synonym or a type family, --- 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 -tyConResKind :: TyCon -> Kind -tyConResKind tycon = - kindAppResult (ptext (sLit "tyConResKind") <+> ppr tycon) - (tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon)) - --- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -isOpenTypeKind, isUnliftedTypeKind, - isConstraintKind, isAnyKind, isConstraintOrLiftedKind :: Kind -> Bool - -isOpenTypeKindCon, isUnliftedTypeKindCon, - isSubOpenTypeKindCon, isConstraintKindCon, - isLiftedTypeKindCon, isAnyKindCon, isSuperKindTyCon :: TyCon -> Bool - - -isLiftedTypeKindCon tc = tyConUnique tc == liftedTypeKindTyConKey -isAnyKindCon tc = tyConUnique tc == anyKindTyConKey -isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey -isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey -isSuperKindTyCon tc = tyConUnique tc == superKindTyConKey - -isAnyKind (TyConApp tc _) = isAnyKindCon tc -isAnyKind _ = False - -isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc -isOpenTypeKind _ = False - -isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc -isUnliftedTypeKind _ = False isConstraintKind (TyConApp tc _) = isConstraintKindCon tc isConstraintKind _ = False -isConstraintOrLiftedKind (TyConApp tc _) - = isConstraintKindCon tc || isLiftedTypeKindCon tc -isConstraintOrLiftedKind _ = False +-- | Does the given type "end" in the given tycon? For example @k -> [a] -> *@ +-- ends in @*@ and @Maybe a -> [a]@ ends in @[]@. +returnsTyCon :: Unique -> Type -> Bool +returnsTyCon tc_u (ForAllTy _ ty) = returnsTyCon tc_u ty +returnsTyCon tc_u (TyConApp tc' _) = tc' `hasKey` tc_u +returnsTyCon _ _ = False returnsConstraintKind :: Kind -> Bool -returnsConstraintKind (ForAllTy _ k) = returnsConstraintKind k -returnsConstraintKind (FunTy _ k) = returnsConstraintKind k -returnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc -returnsConstraintKind _ = False +returnsConstraintKind = returnsTyCon constraintKindTyConKey + +-- | Tests whether the given type looks like "TYPE v", where v is a variable. +isLevityPolymorphic :: Kind -> Bool +isLevityPolymorphic = isJust . isLevityPolymorphic_maybe + +-- | Retrieves a levity variable in the given kind, if the kind is of the +-- form "TYPE v". +isLevityPolymorphic_maybe :: Kind -> Maybe TyVar +isLevityPolymorphic_maybe k + | Just k' <- coreViewOneStarKind k = isLevityPolymorphic_maybe k' +isLevityPolymorphic_maybe (TyConApp tc [TyVarTy v]) + | tc `hasKey` tYPETyConKey + = Just v +isLevityPolymorphic_maybe _ = Nothing -------------------------------------------- -- Kinding for arrow (->) -- Says when a kind is acceptable on lhs or rhs of an arrow -- arg -> res -okArrowArgKindCon, okArrowResultKindCon :: TyCon -> Bool -okArrowArgKindCon = isSubOpenTypeKindCon -okArrowResultKindCon = isSubOpenTypeKindCon - okArrowArgKind, okArrowResultKind :: Kind -> Bool -okArrowArgKind (TyConApp kc []) = okArrowArgKindCon kc -okArrowArgKind _ = False - -okArrowResultKind (TyConApp kc []) = okArrowResultKindCon kc -okArrowResultKind _ = False +okArrowArgKind = classifiesTypeWithValues <&&> (not . isLevityPolymorphic) +okArrowResultKind = classifiesTypeWithValues ----------------------------------------- -- Subkinding --- The tc variants are used during type-checking, where we don't want the --- Constraint kind to be a subkind of anything --- After type-checking (in core), Constraint is a subkind of openTypeKind - -isSubOpenTypeKind :: Kind -> Bool +-- 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 -isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc -isSubOpenTypeKind _ = False - -isSubOpenTypeKindCon kc = isSubOpenTypeKindKey (tyConUnique kc) - -isSubOpenTypeKindKey :: Unique -> Bool -isSubOpenTypeKindKey uniq - = uniq == openTypeKindTyConKey - || uniq == unliftedTypeKindTyConKey - || uniq == liftedTypeKindTyConKey - || uniq == constraintKindTyConKey -- Needed for error (Num a) "blah" - -- and so that (Ord a -> Eq a) is well-kinded - -- and so that (# Eq a, Ord b #) is well-kinded - -- See Note [Kind Constraint and kind *] - --- | Is this a kind (i.e. a type-of-types)? -isKind :: Kind -> Bool -isKind k = isSuperKind (typeKind k) - -isSubKind :: Kind -> Kind -> Bool --- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@ --- Sub-kinding is extremely simple and does not look --- under arrrows or type constructors - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -isSubKind k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) - | isPromotedTyCon kc1 || isPromotedTyCon kc2 - -- handles promoted kinds (List *, Nat, etc.) - = eqKind k1 k2 - - | otherwise -- handles usual kinds (*, #, (#), etc.) - = ASSERT2( null k1s && null k2s, ppr k1 <+> ppr k2 ) - kc1 `isSubKindCon` kc2 - -isSubKind k1 k2 = eqKind k1 k2 - -isSubKindCon :: TyCon -> TyCon -> Bool --- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -isSubKindCon kc1 kc2 - | kc1 == kc2 = True - | isOpenTypeKindCon kc2 = isSubOpenTypeKindCon kc1 - | isConstraintKindCon kc1 = isLiftedTypeKindCon kc2 - | isLiftedTypeKindCon kc1 = isConstraintKindCon kc2 - -- See Note [Kind Constraint and kind *] - | otherwise = False - -------------------------- --- Hack alert: we need a tiny variant for the typechecker --- Reason: f :: Int -> (a~b) --- g :: forall (c::Constraint). Int -> c --- h :: Int => Int --- We want to reject these, even though Constraint is --- a sub-kind of OpenTypeKind. It must be a sub-kind of OpenTypeKind --- *after* the typechecker --- a) So that (Ord a -> Eq a) is a legal type --- b) So that the simplifer can generate (error (Eq a) "urk") --- Moreover, after the type checker, Constraint and * --- are identical; see Note [Kind Constraint and kind *] --- --- Easiest way to reject is simply to make Constraint a compliete --- below OpenTypeKind when type checking - -tcIsSubKind :: Kind -> Kind -> Bool -tcIsSubKind k1 k2 - | isConstraintKind k1 = isConstraintKind k2 - | isConstraintKind k2 = isConstraintKind k1 - | otherwise = isSubKind k1 k2 - -tcIsSubKindCon :: TyCon -> TyCon -> Bool -tcIsSubKindCon kc1 kc2 - | isConstraintKindCon kc1 = isConstraintKindCon kc2 - | isConstraintKindCon kc2 = isConstraintKindCon kc1 - | otherwise = isSubKindCon kc1 kc2 - -------------------------- -defaultKind :: Kind -> Kind -defaultKind_maybe :: Kind -> Maybe Kind --- ^ Used when generalising: default OpenKind and ArgKind to *. --- See "Type#kind_subtyping" for more information on what that means - --- When we generalise, we make generic type variables whose kind is --- simple (* or *->* etc). So generic type variables (other than --- built-in constants like 'error') always have simple kinds. This is important; --- consider --- f x = True --- We want f to get type --- f :: forall (a::*). a -> Bool --- Not --- f :: forall (a::ArgKind). a -> Bool --- because that would allow a call like (f 3#) as well as (f True), --- and the calling conventions differ. --- This defaulting is done in TcMType.zonkTcTyVarBndr. --- --- The test is really whether the kind is strictly above '*' -defaultKind_maybe (TyConApp kc _args) - | isOpenTypeKindCon kc = ASSERT( null _args ) Just liftedTypeKind -defaultKind_maybe _ = Nothing - -defaultKind k = defaultKind_maybe k `orElse` k - --- Returns the free kind variables in a kind -kiVarsOfKind :: Kind -> VarSet -kiVarsOfKind = tyVarsOfType - -kiVarsOfKinds :: [Kind] -> VarSet -kiVarsOfKinds = tyVarsOfTypes +classifiesTypeWithValues t | Just t' <- coreViewOneStarKind t = classifiesTypeWithValues t' +classifiesTypeWithValues (TyConApp tc [_]) = tc `hasKey` tYPETyConKey +classifiesTypeWithValues _ = False + +-- | Is this kind equivalent to *? +isStarKind :: Kind -> Bool +isStarKind k | Just k' <- coreViewOneStarKind k = isStarKind k' +isStarKind (TyConApp tc [TyConApp l []]) = tc `hasKey` tYPETyConKey + && l `hasKey` liftedDataConKey +isStarKind _ = False + -- See Note [Kind Constraint and kind *] + +-- | Is the tycon @Constraint@? +isStarKindSynonymTyCon :: TyCon -> Bool +isStarKindSynonymTyCon tc = tc `hasKey` constraintKindTyConKey diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs index e112a20bf2..f68bc8cb04 100644 --- a/compiler/types/OptCoercion.hs +++ b/compiler/types/OptCoercion.hs @@ -1,53 +1,40 @@ -- (c) The University of Glasgow 2006 {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns -fno-warn-incomplete-patterns #-} + -- Inexplicably, this module takes 10GB of memory to compile with the new + -- (Nov '15) pattern-match check. This needs to be fixed. But we need + -- to be able to compile in the meantime. module OptCoercion ( optCoercion, checkAxInstCo ) where #include "HsVersions.h" +import TyCoRep import Coercion -import Type hiding( substTyVarBndr, substTy, extendTvSubst ) -import TcType ( exactTyVarsOfType ) +import Type hiding( substTyVarBndr, substTy, extendTCvSubst ) +import TcType ( exactTyCoVarsOfType ) import TyCon import CoAxiom -import Var import VarSet -import FamInstEnv ( flattenTys ) import VarEnv import StaticFlags ( opt_NoOptCoercion ) import Outputable +import FamInstEnv ( flattenTys ) import Pair +import ListSetOps ( getNth ) import FastString import Util import Unify -import ListSetOps import InstEnv import Control.Monad ( zipWithM ) {- -************************************************************************ -* * +%************************************************************************ +%* * Optimising coercions -* * -************************************************************************ - -Note [Subtle shadowing in coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Supose we optimising a coercion - optCoercion (forall (co_X5:t1~t2). ...co_B1...) -The co_X5 is a wild-card; the bound variable of a coercion for-all -should never appear in the body of the forall. Indeed we often -write it like this - optCoercion ( (t1~t2) => ...co_B1... ) - -Just because it's a wild-card doesn't mean we are free to choose -whatever variable we like. For example it'd be wrong for optCoercion -to return - forall (co_B1:t1~t2). ...co_B1... -because now the co_B1 (which is really free) has been captured, and -subsequent substitutions will go wrong. That's why we can't use -mkCoPredTy in the ForAll case, where this note appears. +%* * +%************************************************************************ Note [Optimising coercion optimisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -64,21 +51,66 @@ 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] +~~~~~~~~~~~~~~~~~~~~~~~~ +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 `mkCoherenceRightCo` 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 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. + -} -optCoercion :: CvSubst -> Coercion -> NormalCo +optCoercion :: TCvSubst -> Coercion -> NormalCo -- ^ optCoercion applies a substitution to a coercion, -- *and* optimises it to reduce its size optCoercion env co | opt_NoOptCoercion = substCo env co - | otherwise = opt_co1 env False co + | debugIsOn = let out_co = opt_co1 lc False co + Pair in_ty1 in_ty2 = coercionKind co + Pair out_ty1 out_ty2 = coercionKind out_co + in + ASSERT2( substTy env in_ty1 `eqType` out_ty1 && + substTy env in_ty2 `eqType` out_ty2 + , 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 +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 - -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types) type NormalNonIdCo = NormalCo -- Extra invariant: not the identity @@ -88,39 +120,16 @@ type SymFlag = Bool -- | Do we force the result to be representational? type ReprFlag = Bool --- | Optimize a coercion, making no assumptions. -opt_co1 :: CvSubst +-- | 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 -{- -opt_co env sym co - = pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $ - co1 `seq` - pprTrace "opt_co done }" (ppr co1) $ - (WARN( not same_co_kind, ppr co <+> dcolon <+> ppr (coercionType co) - $$ ppr co1 <+> dcolon <+> ppr (coercionType co1) ) - WARN( not (coreEqCoercion co1 simple_result), - (text "env=" <+> ppr env) $$ - (text "input=" <+> ppr co) $$ - (text "simple=" <+> ppr simple_result) $$ - (text "opt=" <+> ppr co1) ) - co1) - where - co1 = opt_co' env sym co - same_co_kind = s1 `eqType` s2 && t1 `eqType` t2 - Pair s t = coercionKind (substCo env co) - (s1,t1) | sym = (t,s) - | otherwise = (s,t) - Pair s2 t2 = coercionKind co1 - - simple_result | sym = mkSymCo (substCo env co) - | otherwise = substCo env co --} -- See Note [Optimising coercion optimisation] -- | Optimize a coercion, knowing the coercion's role. No other assumptions. -opt_co2 :: CvSubst +opt_co2 :: LiftingContext -> SymFlag -> Role -- ^ The role of the input coercion -> Coercion -> NormalCo @@ -129,22 +138,41 @@ 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 :: CvSubst -> 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 env sym True r co +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 env sym False r co - +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 :: CvSubst -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo +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 _r ty) - = ASSERT( r == _r ) - Refl (chooseRole rep r) (substTy env ty) + = 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 (SymCo co) = opt_co4 env (not sym) rep r 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 ) @@ -156,7 +184,7 @@ opt_co4 env sym rep r g@(TyConAppCo _r tc cos) (repeat Nominal) cos) (False, Nominal) -> - mkTyConAppCo Nominal tc (map (opt_co4 env sym False Nominal) cos) + 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] @@ -165,18 +193,21 @@ opt_co4 env sym rep r g@(TyConAppCo _r tc cos) cos) (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) -opt_co4 env sym rep r (AppCo co1 co2) = mkAppCo (opt_co4 env sym rep r co1) - (opt_co4 env sym False Nominal co2) -opt_co4 env sym rep r (ForAllCo tv co) - = case substTyVarBndr env tv of - (env', tv') -> mkForAllCo tv' (opt_co4 env' sym rep r co) +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 (CoVarCo cv) - | Just co <- lookupCoVar env cv - = opt_co4 (zapCvSubstEnv env) sym rep r co + | Just co <- lookupCoVar (lcTCvSubst env) cv + = opt_co4_wrap (zapLiftingContext env) sym rep r co - | Just cv1 <- lookupInScope (getCvInScope env) cv + | Just cv1 <- lookupInScope (lcInScopeSet env) cv = ASSERT( isCoVar cv1 ) wrapRole rep r $ wrapSym sym (CoVarCo cv1) -- cv1 might have a substituted kind! @@ -199,109 +230,167 @@ opt_co4 env sym rep r (AxiomInstCo con ind cos) cos) -- Note that the_co does *not* have sym pushed into it -opt_co4 env sym rep r (UnivCo s _r oty1 oty2) +opt_co4 env sym _ r (UnivCo prov _r t1 t2) = ASSERT( r == _r ) - opt_univ env s (chooseRole rep r) a b - where - (a,b) = if sym then (oty2,oty1) else (oty1,oty2) + opt_univ env sym prov 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 env sym rep r co1 - co2' = opt_co4 env sym rep r co2 - in_scope = getCvInScope env + 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 co@(NthCo {}) = opt_nth_co env sym rep r co opt_co4 env sym rep r (LRCo lr co) | Just pr_co <- splitAppCo_maybe co = ASSERT( r == Nominal ) - opt_co4 env sym rep Nominal (pickLR lr pr_co) + 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 (zapCvSubstEnv env) False True Nominal (pickLR lr pr_co) - else pickLR lr pr_co + 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 env sym False Nominal co + co' = opt_co4_wrap env sym False Nominal co -opt_co4 env sym rep r (InstCo co ty) - -- See if the first arg is already a forall - -- ...then we can just extend the current substitution - | Just (tv, co_body) <- splitForAllCo_maybe co - = opt_co4 (extendTvSubst env tv ty') sym rep r co_body + pick_lr CLeft (l, _) = l + pick_lr CRight (_, r) = r - -- See if it is a forall after optimization - -- If so, do an inefficient one-variable substitution - | Just (tv, co'_body) <- splitForAllCo_maybe co' - = substCoWithTy (getCvInScope env) tv ty' co'_body +-- See Note [Optimising InstCo] +opt_co4 env sym rep r (InstCo co1 arg) + -- forall over type... + | Just (tv, kind_co, co_body) <- splitForAllCo_maybe co1 + = opt_co4_wrap (extendLiftingContext env tv + (arg' `mkCoherenceRightCo` mkSymCo kind_co)) + sym rep r co_body - | otherwise = InstCo co' ty' + -- 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_maybe co1' + = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' + (arg' `mkCoherenceRightCo` mkSymCo kind_co')) + False False r' co_body' + + | otherwise = InstCo co1' arg' where - co' = opt_co4 env sym rep r co - ty' = substTy env ty + co1' = opt_co4_wrap env sym rep r co1 + r' = chooseRole rep r + arg' = opt_co4_wrap env sym False Nominal arg + +opt_co4 env sym rep r (CoherenceCo co1 co2) + | TransCo col1 cor1 <- co1 + = opt_co4_wrap env sym rep r (mkTransCo (mkCoherenceCo col1 co2) cor1) + + | TransCo col1' cor1' <- co1' + = if sym then opt_trans in_scope col1' + (optCoercion (zapTCvSubst (lcTCvSubst env)) + (mkCoherenceRightCo cor1' co2')) + else opt_trans in_scope (mkCoherenceCo col1' co2') cor1' + + | otherwise + = wrapSym sym $ CoherenceCo (opt_co4_wrap env False rep r co1) co2' + where co1' = opt_co4_wrap env sym rep r co1 + co2' = opt_co4_wrap env False False Nominal co2 + in_scope = lcInScopeSet env + +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 env sym True Nominal co + opt_co4_wrap env sym True Nominal co --- XXX: We could add another field to CoAxiomRule that --- would allow us to do custom simplifications. -opt_co4 env sym rep r (AxiomRuleCo co ts cs) +-- 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 (map (substTy env) ts) - (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) - + AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) ------------- -- | Optimize a phantom coercion. The input coercion may not necessarily -- be a phantom, but the output sure will be. -opt_phantom :: CvSubst -> SymFlag -> Coercion -> NormalCo +opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo opt_phantom env sym co - = if sym - then opt_univ env (fsLit "opt_phantom") Phantom ty2 ty1 - else opt_univ env (fsLit "opt_phantom") Phantom ty1 ty2 + = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 where Pair ty1 ty2 = coercionKind co -opt_univ :: CvSubst -> FastString -> Role -> Type -> Type -> Coercion -opt_univ env prov role oty1 oty2 +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 - = mkTyConAppCo role tc1 (zipWith3 (opt_univ env prov) (tyConRolesX role tc1) tys1 tys2) + -- 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' - | Just (l1, r1) <- splitAppTy_maybe oty1 - , Just (l2, r2) <- splitAppTy_maybe oty2 - , typeKind l1 `eqType` typeKind l2 -- kind(r1) == kind(r2) by consequence - = let role' = if role == Phantom then Phantom else Nominal in - -- role' is to comform to mkAppCo's precondition - mkAppCo (opt_univ env prov role l1 l2) (opt_univ env prov role' r1 r2) + -- can't optimize the AppTy case because we can't build the kind coercions. | Just (tv1, ty1) <- splitForAllTy_maybe oty1 , Just (tv2, ty2) <- splitForAllTy_maybe oty2 - , tyVarKind tv1 `eqType` tyVarKind tv2 -- rule out a weird unsafeCo - = case substTyVarBndr2 env tv1 tv2 of { (env1, env2, tv') -> - let ty1' = substTy env1 ty1 - ty2' = substTy env2 ty2 in - mkForAllCo tv' (opt_univ (zapCvSubstEnv2 env1 env2) prov role ty1' ty2') } + -- 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') | otherwise - = mkUnivCo prov role (substTy env oty1) (substTy env oty2) + = let ty1 = substTy (lcSubstLeft env) oty1 + ty2 = substTy (lcSubstRight env) oty2 + (a, b) | sym = (ty2, ty1) + | otherwise = (ty1, ty2) + in + mkUnivCo prov' role a b + + where + prov' = case prov of + UnsafeCoerceProv -> prov + PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco + ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco + PluginProv _ -> prov + HoleProv h -> pprPanic "opt_univ fell into a hole" (ppr h) + ------------- -- NthCo must be handled separately, because it's the one case where we can't -- tell quickly what the component coercion's role is from the containing -- coercion. To avoid repeated coercionRole calls as opt_co1 calls opt_co2, -- we just look for nested NthCo's, which can happen in practice. -opt_nth_co :: CvSubst -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo +opt_nth_co :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo opt_nth_co env sym rep r = go [] where go ns (NthCo n co) = go (n:ns) co @@ -311,9 +400,24 @@ opt_nth_co env sym rep r = go [] go ns co = opt_nths ns co + -- try to resolve 1 Nth + push_nth n (Refl r1 ty) + | Just (tc, args) <- splitTyConApp_maybe ty + = Just (Refl (nthRole r1 tc n) (args `getNth` n)) + | n == 0 + , Just (tv, _) <- splitForAllTy_maybe ty + = Just (Refl Nominal (tyVarKind tv)) + push_nth n (TyConAppCo _ _ cos) + = Just (cos `getNth` n) + push_nth 0 (ForAllCo _ eta _) + = Just eta + push_nth _ _ = Nothing + -- input coercion is *not* yet sym'd or opt'd - opt_nths [] co = opt_co4 env sym rep r co - opt_nths (n:ns) (TyConAppCo _ _ cos) = opt_nths ns (cos `getNth` n) + opt_nths [] co = opt_co4_wrap env sym rep r co + opt_nths (n:ns) co + | Just co' <- push_nth n co + = opt_nths ns co' -- here, the co isn't a TyConAppCo, so we opt it, hoping to get -- a TyConAppCo as output. We don't know the role, so we use @@ -327,9 +431,11 @@ opt_nth_co env sym rep r = go [] opt_nths' [] co = if rep && (r == Nominal) -- propagate the SubCo: - then opt_co4 (zapCvSubstEnv env) False True r co + then opt_co4_wrap (zapLiftingContext env) False True r co else co - opt_nths' (n:ns) (TyConAppCo _ _ cos) = opt_nths' ns (cos `getNth` n) + opt_nths' (n:ns) co + | Just co' <- push_nth n co + = opt_nths' ns co' opt_nths' ns co = wrapRole rep r (mk_nths ns co) mk_nths [] co = co @@ -388,60 +494,81 @@ opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) -- Push transitivity inside instantiation opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) - | ty1 `eqType` 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 UnsafeCoerceProv UnsafeCoerceProv = Just UnsafeCoerceProv + 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 $ - TyConAppCo r1 tc1 (opt_transList is cos1 cos2) + mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) = fireTransRule "TrPushApp" in_co1 in_co2 $ - mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + mkAppCo (opt_trans is co1a co2a) + (opt_trans is co1b co2b) -- Eta rules opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 | Just cos2 <- etaTyConAppCo_maybe tc co2 = ASSERT( length cos1 == length cos2 ) fireTransRule "EtaCompL" co1 co2 $ - TyConAppCo r tc (opt_transList is cos1 cos2) + 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( length cos1 == length cos2 ) fireTransRule "EtaCompR" co1 co2 $ - TyConAppCo r tc (opt_transList is cos1 cos2) + mkTyConAppCo r tc (opt_transList is cos1 cos2) opt_trans_rule is co1@(AppCo co1a co1b) co2 | Just (co2a,co2b) <- etaAppCo_maybe co2 = fireTransRule "EtaAppL" co1 co2 $ - mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + mkAppCo (opt_trans is co1a co2a) + (opt_trans is co1b co2b) opt_trans_rule is co1 co2@(AppCo co2a co2b) | Just (co1a,co1b) <- etaAppCo_maybe co1 = fireTransRule "EtaAppR" co1 co2 $ - mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + mkAppCo (opt_trans is co1a co2a) + (opt_trans is co1b co2b) -- Push transitivity inside forall opt_trans_rule is co1 co2 - | Just (tv1,r1) <- splitForAllCo_maybe co1 - , Just (tv2,r2) <- etaForAllCo_maybe co2 - , let r2' = substCoWithTy is' tv2 (mkTyVarTy tv1) r2 - is' = is `extendInScopeSet` tv1 - = fireTransRule "EtaAllL" co1 co2 $ - mkForAllCo tv1 (opt_trans2 is' r1 r2') - - | Just (tv2,r2) <- splitForAllCo_maybe co2 - , Just (tv1,r1) <- etaForAllCo_maybe co1 - , let r1' = substCoWithTy is' tv1 (mkTyVarTy tv2) r1 - is' = is `extendInScopeSet` tv2 - = fireTransRule "EtaAllR" co1 co2 $ - mkForAllCo tv1 (opt_trans2 is' r1' r2) + | ForAllCo tv1 eta1 r1 <- co1 + , Just (tv2,eta2,r2) <- etaForAllCo_maybe co2 + = push_trans tv1 eta1 r1 tv2 eta2 r2 + + | ForAllCo tv2 eta2 r2 <- co2 + , Just (tv1,eta1,r1) <- etaForAllCo_maybe co1 + = push_trans tv1 eta1 r1 tv2 eta2 r2 + + where + push_trans tv1 eta1 r1 tv2 eta2 r2 + = fireTransRule "EtaAllTy" co1 co2 $ + mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` tv1 + r2' = substCoWith [tv2] [TyVarTy tv1] r2 -- Push transitivity inside axioms opt_trans_rule is co1 co2 @@ -449,32 +576,32 @@ opt_trans_rule is co1 co2 -- See Note [Why call checkAxInstCo during optimisation] -- TrPushSymAxR | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , Just cos2 <- matchAxiom sym con ind co2 , 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 - , Just cos2 <- matchAxiom sym con ind co2 , 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 - , Just cos1 <- matchAxiom (not sym) con ind co1 , 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 - , Just cos1 <- matchAxiom (not sym) con ind co1 , 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 @@ -486,20 +613,28 @@ opt_trans_rule is co1 co2 , ind1 == ind2 , sym1 == not sym2 , let branch = coAxiomNthBranch con1 ind1 - qtvs = coAxBranchTyVars branch + qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch lhs = coAxNthLHS con1 ind1 rhs = coAxBranchRHS branch - pivot_tvs = exactTyVarsOfType (if sym2 then rhs else lhs) + pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs) , all (`elemVarSet` pivot_tvs) qtvs = fireTransRule "TrPushAxSym" co1 co2 $ if sym2 - then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym - else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs -- TrPushSymAx + -- 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 is co1 co2 + | Just (lco, lh) <- isCohRight_maybe co1 + , Just (rco, rh) <- isCohLeft_maybe co2 + , (coercionType lh) `eqType` (coercionType rh) + = opt_trans_rule is lco rco + opt_trans_rule _ co1 co2 -- Identity rule | (Pair ty1 _, r) <- coercionKindRole co1 , Pair _ ty2 <- coercionKind co2 @@ -524,9 +659,9 @@ type instance where Equal a a = True Equal a b = False -- -Equal :: forall k::BOX. k -> k -> Bool -axEqual :: { forall k::BOX. forall a::k. Equal k a a ~ True - ; forall k::BOX. forall a::k. forall b::k. Equal k 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 @@ -579,14 +714,17 @@ checkAxInstCo :: Coercion -> Maybe CoAxBranch -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] in CoreLint checkAxInstCo (AxiomInstCo ax ind cos) - = let branch = coAxiomNthBranch ax ind - tvs = coAxBranchTyVars branch - incomps = coAxBranchIncomps branch - tys = map (pFst . coercionKind) cos - subst = zipOpenTvSubst tvs tys + = let branch = coAxiomNthBranch ax ind + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + incomps = coAxBranchIncomps branch + (tys, cotys) = splitAtList tvs (map (pFst . coercionKind) cos) + co_args = map stripCoercionTy cotys + subst = zipOpenTCvSubst tvs tys `composeTCvSubst` + zipOpenTCvSubstCoVars cvs co_args target = Type.substTys subst (coAxBranchLHS branch) in_scope = mkInScopeSet $ - unionVarSets (map (tyVarsOfTypes . coAxBranchLHS) incomps) + unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps) flattened_target = flattenTys in_scope target in check_no_conflict flattened_target incomps where @@ -600,6 +738,7 @@ checkAxInstCo (AxiomInstCo ax ind cos) = Just b checkAxInstCo _ = Nothing + ----------- wrapSym :: SymFlag -> Coercion -> Coercion wrapSym sym co | sym = SymCo co @@ -619,18 +758,7 @@ chooseRole :: ReprFlag -> Role chooseRole True _ = Representational chooseRole _ r = r ------------ --- takes two tyvars and builds env'ts to map them to the same tyvar -substTyVarBndr2 :: CvSubst -> TyVar -> TyVar - -> (CvSubst, CvSubst, TyVar) -substTyVarBndr2 env tv1 tv2 - = case substTyVarBndr env tv1 of - (env1, tv1') -> (env1, extendTvSubstAndInScope env tv2 (mkTyVarTy tv1'), tv1') - -zapCvSubstEnv2 :: CvSubst -> CvSubst -> CvSubst -zapCvSubstEnv2 env1 env2 = mkCvSubst (is1 `unionInScope` is2) [] - where is1 = getCvInScope env1 - is2 = getCvInScope env2 + ----------- isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) isAxiom_maybe (SymCo co) @@ -642,16 +770,32 @@ isAxiom_maybe _ = Nothing matchAxiom :: Bool -- True = match LHS, False = match RHS -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion] --- If we succeed in matching, then *all the quantified type variables are bound* --- E.g. if tvs = [a,b], lhs/rhs = [b], we'll fail matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co - = let (CoAxBranch { cab_tvs = qtvs - , cab_roles = roles - , cab_lhs = lhs - , cab_rhs = rhs }) = coAxiomNthBranch ax ind in - case liftCoMatch (mkVarSet qtvs) (if sym then (mkTyConApp tc lhs) else rhs) co of - Nothing -> Nothing - Just subst -> zipWithM (liftCoSubstTyVar subst) roles qtvs + | 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 + +------------- +-- destruct a CoherenceCo +isCohLeft_maybe :: Coercion -> Maybe (Coercion, Coercion) +isCohLeft_maybe (CoherenceCo co1 co2) = Just (co1, co2) +isCohLeft_maybe _ = Nothing + +-- destruct a (sym (co1 |> co2)). +-- if isCohRight_maybe co = Just (co1, co2), then (sym co1) `mkCohRightCo` co2 = co +isCohRight_maybe :: Coercion -> Maybe (Coercion, Coercion) +isCohRight_maybe (SymCo (CoherenceCo co1 co2)) = Just (mkSymCo co1, co2) +isCohRight_maybe _ = Nothing ------------- compatible_co :: Coercion -> Coercion -> Bool @@ -663,17 +807,43 @@ compatible_co co1 co2 Pair x2 _ = coercionKind co2 ------------- -etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion) --- Try to make the coercion be of form (forall tv. co) +{- +etaForAllCo_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 `mkCoherenceRightCo` ForAllKindCo g)) + +Call the kind coercion h1 and the body coercion h2. We can see that + + h2 : t1 ~ t2[a2 |-> (a1 |> h2)] + +According to the typing rule for ForAllCo, we get that + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h2)][a1 |-> a1 |> sym h2]) + +or + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) + +as desired. +-} +etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +-- Try to make the coercion be of form (forall tv:kind_co. co) etaForAllCo_maybe co - | Just (tv, r) <- splitForAllCo_maybe co - = Just (tv, r) + | ForAllCo tv kind_co r <- co + = Just (tv, kind_co, r) | Pair ty1 ty2 <- coercionKind co , Just (tv1, _) <- splitForAllTy_maybe ty1 - , Just (tv2, _) <- splitForAllTy_maybe ty2 - , tyVarKind tv1 `eqKind` tyVarKind tv2 - = Just (tv1, mkInstCo co (mkTyVarTy tv1)) + , isForAllTy ty2 + , let kind_co = mkNthCo 0 co + = Just ( tv1, kind_co + , mkInstCo co (mkNomReflCo (TyVarTy tv1) `mkCoherenceRightCo` kind_co) ) | otherwise = Nothing @@ -688,7 +858,9 @@ etaAppCo_maybe co | (Pair ty1 ty2, Nominal) <- coercionKindRole co , Just (_,t1) <- splitAppTy_maybe ty1 , Just (_,t2) <- splitAppTy_maybe ty2 - , typeKind t1 `eqType` typeKind t2 -- Note [Eta for AppCo] + , let isco1 = isCoercionTy t1 + , let isco2 = isCoercionTy t2 + , isco1 == isco2 = Just (LRCo CLeft co, LRCo CRight co) | otherwise = Nothing @@ -738,4 +910,10 @@ because if g is well-kinded then kind (s1 t2) = kind (s2 t2) and these two imply kind s1 = kind s2 + -} + +optForAllCoBndr :: LiftingContext -> Bool + -> TyVar -> Coercion -> (LiftingContext, TyVar, Coercion) +optForAllCoBndr env sym + = substForAllCoBndrCallbackLC sym (opt_co4_wrap env sym False Nominal) env diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs new file mode 100644 index 0000000000..c25bd11d94 --- /dev/null +++ b/compiler/types/TyCoRep.hs @@ -0,0 +1,2496 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +\section[TyCoRep]{Type and Coercion - friends' interface} + +Note [The Type-related module hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Class + CoAxiom + TyCon imports Class, CoAxiom + TyCoRep imports Class, CoAxiom, TyCon + TysPrim imports TyCoRep ( including mkTyConTy ) + Kind imports TysPrim ( mainly for primitive kinds ) + Type imports Kind + Coercion imports Type +-} + +-- We expose the relevant stuff from this module via the Type module +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable, MultiWayIf #-} + +module TyCoRep ( + TyThing(..), + Type(..), + TyBinder(..), + TyLit(..), + KindOrType, Kind, + PredType, ThetaType, -- Synonyms + VisibilityFlag(..), + + -- Coercions + Coercion(..), LeftOrRight(..), + UnivCoProvenance(..), CoercionHole(..), + + -- Functions over types + mkTyConTy, mkTyVarTy, mkTyVarTys, + mkFunTy, mkFunTys, + isLiftedTypeKind, isUnliftedTypeKind, + isCoercionType, isLevityTy, isLevityVar, + + -- Functions over binders + binderType, delBinderVar, + + -- Functions over coercions + pickLR, + + -- Pretty-printing + pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, + pprTyThing, pprTyThingCategory, pprSigmaType, + pprTheta, pprForAll, pprForAllImplicit, pprUserForAll, + pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprTyLit, + TyPrec(..), maybeParen, pprTcAppCo, pprTcAppTy, + pprPrefixApp, pprArrowChain, ppr_type, + pprDataCons, + + -- Free variables + tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet, + tyCoVarsOfTypeAcc, tyCoVarsOfTypeList, + tyCoVarsOfTypesAcc, tyCoVarsOfTypesList, + closeOverKindsDSet, closeOverKindsAcc, + coVarsOfType, coVarsOfTypes, + coVarsOfCo, coVarsOfCos, + tyCoVarsOfCo, tyCoVarsOfCos, + tyCoVarsOfCoDSet, + tyCoVarsOfCoAcc, tyCoVarsOfCosAcc, + tyCoVarsOfCoList, tyCoVarsOfProv, + closeOverKinds, + tyCoVarsOfTelescope, + + -- Substitutions + TCvSubst(..), TvSubstEnv, CvSubstEnv, + emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, + emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, mkTCvSubst, getTvSubstEnv, + getCvSubstEnv, getTCvInScope, isInScope, notElemTCvSubst, + setTvSubstEnv, setCvSubstEnv, zapTCvSubst, + extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + extendTCvSubst, extendTCvSubstAndInScope, extendTCvSubstList, + extendTCvSubstBinder, + unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet, + mkOpenTCvSubst, zipOpenTCvSubst, zipOpenTCvSubstCoVars, + zipOpenTCvSubstBinders, + mkTopTCvSubst, zipTopTCvSubst, + + substTelescope, + substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, + substCoWith, + substTy, + substTyWithBinders, + substTys, substTheta, + lookupTyVar, substTyVarBndr, + substCo, substCos, substCoVar, substCoVars, lookupCoVar, + substCoVarBndr, cloneTyVarBndr, cloneTyVarBndrs, + substTyVar, substTyVars, + substForAllCoBndr, + substTyVarBndrCallback, substForAllCoBndrCallback, + substCoVarBndrCallback, + + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyTyCoVarBndr, tidyTyCoVarBndrs, tidyFreeTyCoVars, + tidyOpenTyCoVar, tidyOpenTyCoVars, + tidyTyVarOcc, + tidyTopType, + tidyKind, + tidyCo, tidyCos + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} DataCon( dataConTyCon, dataConFullSig + , DataCon, eqSpecTyVar ) +import {-# SOURCE #-} Type( isPredTy, isCoercionTy, mkAppTy + , partitionInvisibles ) + -- Transitively pulls in a LOT of stuff, better to break the loop + +import {-# SOURCE #-} Coercion +import {-# SOURCE #-} ConLike ( ConLike(..) ) + +-- friends: +import Var +import VarEnv +import VarSet +import Name hiding ( varName ) +import BasicTypes +import TyCon +import Class +import CoAxiom +import FV + +-- others +import PrelNames +import Binary +import Outputable +import DynFlags +import StaticFlags ( opt_PprStyle_Debug ) +import FastString +import Pair +import UniqSupply +import ListSetOps +import Util + +-- libraries +import qualified Data.Data as Data hiding ( TyCon ) +import Data.List +import Data.IORef ( IORef ) -- for CoercionHole + +{- +%************************************************************************ +%* * +\subsection{The data type} +%* * +%************************************************************************ +-} + +-- | The key representation of types within the compiler + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data Type + -- See Note [Non-trivial definitional equality] + = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) + + | AppTy -- See Note [AppTy rep] + Type + Type -- ^ Type application to something other than a 'TyCon'. Parameters: + -- + -- 1) Function: must /not/ be a 'TyConApp', + -- must be another 'AppTy', or 'TyVarTy' + -- + -- 2) Argument type + + | TyConApp -- See Note [AppTy rep] + 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 + TyBinder + Type -- ^ A Π type. + -- This includes arrow types, constructed with + -- @ForAllTy (Anon ...)@. + + | LitTy TyLit -- ^ Type literals are similar to type constructors. + + | CastTy + Type + Coercion -- ^ A kind cast. The coercion is always nominal. + -- INVARIANT: The cast is never refl. + -- INVARIANT: The cast is "pushed down" as far as it + -- can go. See Note [Pushing down casts] + + | 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, Data.Typeable) + + +-- 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, Data.Typeable) + +-- | A 'TyBinder' represents an argument to a function. TyBinders can be dependent +-- ('Named') or nondependent ('Anon'). They may also be visible or not. +data TyBinder + = Named TyVar VisibilityFlag + | Anon Type -- visibility is determined by the type (Constraint vs. *) + deriving (Data.Typeable, Data.Data) + +-- | Is something required to appear in source Haskell ('Visible') or +-- prohibited from appearing in source Haskell ('Invisible')? +data VisibilityFlag = Visible | Invisible + deriving (Eq, Data.Typeable, Data.Data) + +instance Binary VisibilityFlag where + put_ bh Visible = putByte bh 0 + put_ bh Invisible = putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> return Visible + _ -> return Invisible + +type KindOrType = Type -- See Note [Arguments to type constructors] + +-- | The key type representing kinds in the compiler. +type Kind = Type + +{- +Note [The kind invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The kinds + # UnliftedTypeKind + OpenKind super-kind of *, # + +can never appear under an arrow or type constructor in a kind; they +can only be at the top level of a kind. It follows that primitive TyCons, +which have a naughty pseudo-kind + State# :: * -> # +must always be saturated, so that we can never get a type whose kind +has a UnliftedTypeKind or ArgTypeKind underneath an arrow. + +Nor can we abstract over a type variable with any of these kinds. + + k :: = kk | # | ArgKind | (#) | OpenKind + kk :: = * | kk -> kk | T kk1 ... kkn + +So a type variable can only be abstracted kk. + +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 [Pushing down casts] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (a :: k1 -> *), (b :: k1), and (co :: * ~ q). +The type (a b |> co) is `eqType` to ((a |> co') b), where +co' = (->) <k1> co. Thus, to make this visible to functions +that inspect types, we always push down coercions, preferring +the second form. Note that this also applies to TyConApps! + +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. 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. + +------------------------------------- + Note [PredTy] +-} + +-- | A type of the form @p@ of kind @Constraint@ 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 +-} + +-- named with "Only" to prevent naive use of mkTyVarTy +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 + +infixr 3 `mkFunTy` -- Associates to the right +-- | Make an arrow type +mkFunTy :: Type -> Type -> Type +mkFunTy arg res + = ForAllTy (Anon arg) res + +-- | Make nested arrow types +mkFunTys :: [Type] -> Type -> Type +mkFunTys tys ty = foldr mkFunTy ty tys + +-- | Does this type classify a core Coercion? +isCoercionType :: Type -> Bool +isCoercionType (TyConApp tc tys) + | (tc `hasKey` eqPrimTyConKey) || (tc `hasKey` eqReprPrimTyConKey) + , length tys == 4 + = True +isCoercionType _ = False + +binderType :: TyBinder -> Type +binderType (Named v _) = varType v +binderType (Anon ty) = ty + +-- | Remove the binder's variable from the set, if the binder has +-- a variable. +delBinderVar :: VarSet -> TyBinder -> VarSet +delBinderVar vars (Named tv _) = vars `delVarSet` tv +delBinderVar vars (Anon {}) = vars + +-- | Remove the binder's variable from the set, if the binder has +-- a variable. +delBinderVarFV :: TyBinder -> FV -> FV +delBinderVarFV (Named tv _) vars fv_cand in_scope acc = delFV tv vars fv_cand in_scope acc +delBinderVarFV (Anon {}) vars fv_cand in_scope acc = vars fv_cand in_scope acc + +-- | Create the plain type constructor type which has been applied to no type arguments at all. +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = TyConApp tycon [] + +{- +Some basic functions, put here to break loops eg with the pretty printer +-} + +isLiftedTypeKind :: Kind -> Bool +isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindTyConName (tyConName tc) +isLiftedTypeKind (TyConApp tc [TyConApp lev []]) + = tc `hasKey` tYPETyConKey && lev `hasKey` liftedDataConKey +isLiftedTypeKind _ = False + +isUnliftedTypeKind :: Kind -> Bool +isUnliftedTypeKind (TyConApp tc []) = tc `hasKey` unliftedTypeKindTyConKey +isUnliftedTypeKind (TyConApp tc [TyConApp lev []]) + = tc `hasKey` tYPETyConKey && lev `hasKey` unliftedDataConKey +isUnliftedTypeKind _ = False + +-- | Is this the type 'Levity'? +isLevityTy :: Type -> Bool +isLevityTy (TyConApp tc []) = tc `hasKey` levityTyConKey +isLevityTy _ = False + +-- | Is a tyvar of type 'Levity'? +isLevityVar :: TyVar -> Bool +isLevityVar = isLevityTy . tyVarKind + +{- +%************************************************************************ +%* * + 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 coreSyn/CoreLint.hs +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 :: "e" -> _ -> e + Refl Role 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 (Refl Representational _), not (SubCo (Refl 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 Coercion -- lift AppTy + -- AppCo :: e -> N -> e + + -- See Note [Forall coercions] + | ForAllCo TyVar Coercion Coercion + -- ForAllCo :: _ -> N -> e -> e + + -- These are special + | CoVarCo CoVar -- :: _ -> (N or R) + -- result role depends on the tycon of the variable's type + + -- AxiomInstCo :: e -> _ -> [N] -> 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] + + | UnivCo UnivCoProvenance Role Type Type + -- :: _ -> "e" -> _ -> _ -> e + + | SymCo Coercion -- :: e -> e + | TransCo Coercion Coercion -- :: e -> e -> e + + -- The number coercions should match exactly the expectations + -- of the CoAxiomRule (i.e., the rule is fully saturated). + | AxiomRuleCo CoAxiomRule [Coercion] + + | NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + -- :: _ -> e -> ?? (inverse of TyConAppCo, see Note [TyConAppCo roles]) + -- Using NthCo on a ForAllCo gives an N coercion always + -- See Note [NthCo and newtypes] + + | LRCo LeftOrRight Coercion -- Decomposes (t_left t_right) + -- :: _ -> N -> N + | InstCo Coercion Coercion + -- :: e -> N -> e + -- See Note [InstCo roles] + + -- Coherence applies a coercion to the left-hand type of another coercion + -- See Note [Coherence] + | CoherenceCo Coercion Coercion + -- :: e -> N -> e + + -- Extract a kind coercion from a (heterogeneous) type coercion + -- NB: all kind coercions are Nominal + | KindCo Coercion + -- :: e -> N + + | SubCo Coercion -- Turns a ~N into a ~R + -- :: N -> R + + deriving (Data.Data, Data.Typeable) + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data LeftOrRight = CLeft | CRight + deriving( Eq, Data.Data, Data.Typeable ) + +instance Binary LeftOrRight where + put_ bh CLeft = putByte bh 0 + put_ bh CRight = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return CLeft + _ -> return CRight } + +pickLR :: LeftOrRight -> (a,a) -> a +pickLR CLeft (l,_) = l +pickLR CRight (_,r) = r + +{- +%************************************************************************ +%* * + UnivCo Provenance +%* * +%************************************************************************ + +Note [Coercion holes] +~~~~~~~~~~~~~~~~~~~~~ +During typechecking, 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. So, instead of creating a coercion +variable and then solving for the variable, we use a coercion hole, which +is just an unnamed mutable cell. During type-checking, the holes are filled +in. The Unique carried with a coercion hole is used solely for debugging. +Coercion holes can be compared for equality only like other coercions: +only by looking at the types coerced. + +Holes should never appear in Core. 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. (This is quite like +the fact that Type can, technically, store TcTyVars but never do.) + +Note that we don't use holes for other evidence because other evidence wants +to be shared. But coercions are entirely erased, so there's little benefit +to sharing. + +Note [ProofIrrelProv] +~~~~~~~~~~~~~~~~~~~~~ +A ProofIreelProv 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 co1 a1) ~ ('MkG co2 a2). 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>] + +-} + +-- | 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. To make better sense of these, we tag a UnivCo with a +-- UnivCoProvenance. This provenance is rarely consulted and is more +-- for debugging info than anything else. +-- An important exception to this rule is that we also use a UnivCo +-- for coercion holes. See Note [Coercion holes]. +data UnivCoProvenance + = UnsafeCoerceProv -- ^ From @unsafeCoerce#@. These are unsound. + | PhantomProv Coercion -- ^ From the need to create a phantom coercion; + -- the UnivCo must be Phantom. The Coercion stored is + -- the (nominal) kind coercion between the types + | ProofIrrelProv Coercion -- ^ From the fact that any two coercions are + -- considered equivalent. See Note [ProofIrrelProv] + | PluginProv String -- ^ From a plugin, which asserts that this coercion + -- is sound. The string is for the use of the plugin. + | HoleProv CoercionHole -- ^ See Note [Coercion holes] + deriving (Data.Data, Data.Typeable) + +instance Outputable UnivCoProvenance where + ppr UnsafeCoerceProv = text "(unsafeCoerce#)" + ppr (PhantomProv _) = text "(phantom)" + ppr (ProofIrrelProv _) = text "(proof irrel.)" + ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) + ppr (HoleProv hole) = parens (text "hole" <> ppr hole) + +-- | A coercion to be filled in by the type-checker. See Note [Coercion holes] +data CoercionHole + = CoercionHole { chUnique :: Unique -- ^ used only for debugging + , chCoercion :: (IORef (Maybe Coercion)) + } + deriving (Data.Typeable) + +instance Data.Data CoercionHole where + -- don't traverse? + toConstr _ = abstractConstr "CoercionHole" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoercionHole" + +instance Outputable CoercionHole where + ppr (CoercionHole u _) = braces (ppr u) + +{- +Note [Refl invariant] +~~~~~~~~~~~~~~~~~~~~~ +Invariant 1: + +Coercions have the following invariant + Refl is always lifted as far as possible. + +You might think that a consequencs 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 [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 TyVar 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 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 impedence mismatch +in a bunch of places. So we use tv1. When we need tv2, we can use +setTyVarKind. + +Note [Coherence] +~~~~~~~~~~~~~~~~ +The Coherence typing rule is thus: + + g1 : s ~ t s : k1 g2 : k1 ~ k2 + ------------------------------------ + CoherenceCo g1 g2 : (s |> g2) ~ t + +While this looks (and is) unsymmetric, a combination of other coercion +combinators can make the symmetric version. + +For role information, see Note [Roles and kind coercions]. + +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 Trac #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see +http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation + +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 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 [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. + +%************************************************************************ +%* * + Free variables of types and coercions +%* * +%************************************************************************ +-} + +-- | Returns free variables of a type, including kind variables as +-- a non-deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfType :: Type -> TyCoVarSet +tyCoVarsOfType ty = runFVSet $ tyCoVarsOfTypeAcc ty + +-- | `tyVarsOfType` 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 +tyCoVarsOfTypeDSet ty = runFVDSet $ tyCoVarsOfTypeAcc ty + +-- | `tyVarsOfType` 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] +tyCoVarsOfTypeList ty = runFVList $ tyCoVarsOfTypeAcc ty + +-- | The worker for `tyVarsOfType` and `tyVarsOfTypeList`. +-- 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. +tyCoVarsOfTypeAcc :: Type -> FV +tyCoVarsOfTypeAcc (TyVarTy v) fv_cand in_scope acc = (oneVar v `unionFV` tyCoVarsOfTypeAcc (tyVarKind v)) fv_cand in_scope acc +tyCoVarsOfTypeAcc (TyConApp _ tys) fv_cand in_scope acc = tyCoVarsOfTypesAcc tys fv_cand in_scope acc +tyCoVarsOfTypeAcc (LitTy {}) fv_cand in_scope acc = noVars fv_cand in_scope acc +tyCoVarsOfTypeAcc (AppTy fun arg) fv_cand in_scope acc = (tyCoVarsOfTypeAcc fun `unionFV` tyCoVarsOfTypeAcc arg) fv_cand in_scope acc +tyCoVarsOfTypeAcc (ForAllTy bndr ty) fv_cand in_scope acc + = (delBinderVarFV bndr (tyCoVarsOfTypeAcc ty) + `unionFV` tyCoVarsOfTypeAcc (binderType bndr)) fv_cand in_scope acc +tyCoVarsOfTypeAcc (CastTy ty co) fv_cand in_scope acc = (tyCoVarsOfTypeAcc ty `unionFV` tyCoVarsOfCoAcc co) fv_cand in_scope acc +tyCoVarsOfTypeAcc (CoercionTy co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc + +-- | Returns free variables of types, including kind variables as +-- a non-deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypes :: [Type] -> TyCoVarSet +tyCoVarsOfTypes tys = runFVSet $ tyCoVarsOfTypesAcc tys + +-- | Returns free variables of types, including kind variables as +-- a deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet +tyCoVarsOfTypesDSet tys = runFVDSet $ tyCoVarsOfTypesAcc 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] +tyCoVarsOfTypesList tys = runFVList $ tyCoVarsOfTypesAcc tys + +tyCoVarsOfTypesAcc :: [Type] -> FV +tyCoVarsOfTypesAcc (ty:tys) fv_cand in_scope acc = (tyCoVarsOfTypeAcc ty `unionFV` tyCoVarsOfTypesAcc tys) fv_cand in_scope acc +tyCoVarsOfTypesAcc [] fv_cand in_scope acc = noVars fv_cand in_scope acc + +tyCoVarsOfCo :: Coercion -> TyCoVarSet +tyCoVarsOfCo co = runFVSet $ tyCoVarsOfCoAcc co + +-- | Get a deterministic set of the vars free in a coercion +tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet +tyCoVarsOfCoDSet co = runFVDSet $ tyCoVarsOfCoAcc co + +tyCoVarsOfCoList :: Coercion -> [TyCoVar] +tyCoVarsOfCoList co = runFVList $ tyCoVarsOfCoAcc co + +tyCoVarsOfCoAcc :: Coercion -> FV +-- Extracts type and coercion variables from a coercion +tyCoVarsOfCoAcc (Refl _ ty) fv_cand in_scope acc = tyCoVarsOfTypeAcc ty fv_cand in_scope acc +tyCoVarsOfCoAcc (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoVarsOfCosAcc cos fv_cand in_scope acc +tyCoVarsOfCoAcc (AppCo co arg) fv_cand in_scope acc + = (tyCoVarsOfCoAcc co `unionFV` tyCoVarsOfCoAcc arg) fv_cand in_scope acc +tyCoVarsOfCoAcc (ForAllCo tv kind_co co) fv_cand in_scope acc + = (delFV tv (tyCoVarsOfCoAcc co) `unionFV` tyCoVarsOfCoAcc kind_co) fv_cand in_scope acc +tyCoVarsOfCoAcc (CoVarCo v) fv_cand in_scope acc + = (oneVar v `unionFV` tyCoVarsOfTypeAcc (varType v)) fv_cand in_scope acc +tyCoVarsOfCoAcc (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoVarsOfCosAcc cos fv_cand in_scope acc +tyCoVarsOfCoAcc (UnivCo p _ t1 t2) fv_cand in_scope acc + = (tyCoVarsOfProvAcc p `unionFV` tyCoVarsOfTypeAcc t1 + `unionFV` tyCoVarsOfTypeAcc t2) fv_cand in_scope acc +tyCoVarsOfCoAcc (SymCo co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfCoAcc (TransCo co1 co2) fv_cand in_scope acc = (tyCoVarsOfCoAcc co1 `unionFV` tyCoVarsOfCoAcc co2) fv_cand in_scope acc +tyCoVarsOfCoAcc (NthCo _ co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfCoAcc (LRCo _ co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfCoAcc (InstCo co arg) fv_cand in_scope acc = (tyCoVarsOfCoAcc co `unionFV` tyCoVarsOfCoAcc arg) fv_cand in_scope acc +tyCoVarsOfCoAcc (CoherenceCo c1 c2) fv_cand in_scope acc = (tyCoVarsOfCoAcc c1 `unionFV` tyCoVarsOfCoAcc c2) fv_cand in_scope acc +tyCoVarsOfCoAcc (KindCo co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfCoAcc (SubCo co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfCoAcc (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoVarsOfCosAcc cs fv_cand in_scope acc + +tyCoVarsOfProv :: UnivCoProvenance -> TyCoVarSet +tyCoVarsOfProv prov = runFVSet $ tyCoVarsOfProvAcc prov + +tyCoVarsOfProvAcc :: UnivCoProvenance -> FV +tyCoVarsOfProvAcc UnsafeCoerceProv fv_cand in_scope acc = noVars fv_cand in_scope acc +tyCoVarsOfProvAcc (PhantomProv co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfProvAcc (ProofIrrelProv co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfProvAcc (PluginProv _) fv_cand in_scope acc = noVars fv_cand in_scope acc +tyCoVarsOfProvAcc (HoleProv _) fv_cand in_scope acc = noVars fv_cand in_scope acc + +tyCoVarsOfCos :: [Coercion] -> TyCoVarSet +tyCoVarsOfCos cos = runFVSet $ tyCoVarsOfCosAcc cos + +tyCoVarsOfCosAcc :: [Coercion] -> FV +tyCoVarsOfCosAcc [] fv_cand in_scope acc = noVars fv_cand in_scope acc +tyCoVarsOfCosAcc (co:cos) fv_cand in_scope acc = (tyCoVarsOfCoAcc co `unionFV` tyCoVarsOfCosAcc cos) fv_cand in_scope acc + +coVarsOfType :: Type -> CoVarSet +coVarsOfType (TyVarTy v) = coVarsOfType (tyVarKind v) +coVarsOfType (TyConApp _ tys) = coVarsOfTypes tys +coVarsOfType (LitTy {}) = emptyVarSet +coVarsOfType (AppTy fun arg) = coVarsOfType fun `unionVarSet` coVarsOfType arg +coVarsOfType (ForAllTy bndr ty) + = coVarsOfType ty `delBinderVar` bndr + `unionVarSet` coVarsOfType (binderType bndr) +coVarsOfType (CastTy ty co) = coVarsOfType ty `unionVarSet` coVarsOfCo co +coVarsOfType (CoercionTy co) = coVarsOfCo co + +coVarsOfTypes :: [Type] -> TyCoVarSet +coVarsOfTypes tys = mapUnionVarSet coVarsOfType tys + +coVarsOfCo :: Coercion -> CoVarSet +-- Extract *coercion* variables only. Tiresome to repeat the code, but easy. +coVarsOfCo (Refl _ ty) = coVarsOfType ty +coVarsOfCo (TyConAppCo _ _ args) = coVarsOfCos args +coVarsOfCo (AppCo co arg) = coVarsOfCo co `unionVarSet` coVarsOfCo arg +coVarsOfCo (ForAllCo tv kind_co co) + = coVarsOfCo co `delVarSet` tv `unionVarSet` coVarsOfCo kind_co +coVarsOfCo (CoVarCo v) = unitVarSet v `unionVarSet` coVarsOfType (varType v) +coVarsOfCo (AxiomInstCo _ _ args) = coVarsOfCos args +coVarsOfCo (UnivCo p _ t1 t2) = coVarsOfProv p `unionVarSet` coVarsOfTypes [t1, t2] +coVarsOfCo (SymCo co) = coVarsOfCo co +coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 +coVarsOfCo (NthCo _ co) = coVarsOfCo co +coVarsOfCo (LRCo _ co) = coVarsOfCo co +coVarsOfCo (InstCo co arg) = coVarsOfCo co `unionVarSet` coVarsOfCo arg +coVarsOfCo (CoherenceCo c1 c2) = coVarsOfCos [c1, c2] +coVarsOfCo (KindCo co) = coVarsOfCo co +coVarsOfCo (SubCo co) = coVarsOfCo co +coVarsOfCo (AxiomRuleCo _ cs) = coVarsOfCos cs + +coVarsOfProv :: UnivCoProvenance -> CoVarSet +coVarsOfProv UnsafeCoerceProv = emptyVarSet +coVarsOfProv (PhantomProv co) = coVarsOfCo co +coVarsOfProv (ProofIrrelProv co) = coVarsOfCo co +coVarsOfProv (PluginProv _) = emptyVarSet +coVarsOfProv (HoleProv _) = emptyVarSet + +coVarsOfCos :: [Coercion] -> CoVarSet +coVarsOfCos cos = mapUnionVarSet coVarsOfCo cos + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a non-deterministic set. +closeOverKinds :: TyVarSet -> TyVarSet +closeOverKinds = runFVSet . closeOverKindsAcc . varSetElems + +-- | 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. +closeOverKindsAcc :: [TyVar] -> FV +closeOverKindsAcc tvs = + mapUnionFV (tyCoVarsOfTypeAcc . tyVarKind) tvs `unionFV` someVars tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministic set. +closeOverKindsDSet :: DTyVarSet -> DTyVarSet +closeOverKindsDSet = runFVDSet . closeOverKindsAcc . dVarSetElems + +-- | Gets the free vars of a telescope, scoped over a given free var set. +tyCoVarsOfTelescope :: [Var] -> TyCoVarSet -> TyCoVarSet +tyCoVarsOfTelescope [] fvs = fvs +tyCoVarsOfTelescope (v:vs) fvs = tyCoVarsOfTelescope vs fvs + `delVarSet` v + `unionVarSet` tyCoVarsOfType (varType v) +{- +%************************************************************************ +%* * + 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. + +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) + deriving (Eq, Ord) + +instance Outputable TyThing where + ppr = pprTyThing + +pprTyThing :: TyThing -> SDoc +pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) + +pprTyThingCategory :: TyThing -> SDoc +pprTyThingCategory (ATyCon tc) + | isClassTyCon tc = ptext (sLit "Class") + | otherwise = ptext (sLit "Type constructor") +pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom") +pprTyThingCategory (AnId _) = ptext (sLit "Identifier") +pprTyThingCategory (AConLike (RealDataCon _)) = ptext (sLit "Data constructor") +pprTyThingCategory (AConLike (PatSynCon _)) = ptext (sLit "Pattern synonym") + + +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) = getName cl + +{- +%************************************************************************ +%* * + 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 [Apply Once] + -- and Note [Extending the TvSubstEnv] + -- and Note [Substituting types and coercions] + +-- | A substitution of 'Type's for 'TyVar's +-- and 'Kind's for 'KindVar's +type TvSubstEnv = TyVarEnv Type + -- A TvSubstEnv is used both inside a TCvSubst (with the apply-once + -- invariant discussed in Note [Apply 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 [Apply 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 TCvSubst 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 substTyVarBndr, 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 + +getTvSubstEnv :: TCvSubst -> TvSubstEnv +getTvSubstEnv (TCvSubst _ env _) = env + +getCvSubstEnv :: TCvSubst -> CvSubstEnv +getCvSubstEnv (TCvSubst _ _ env) = env + +getTCvInScope :: TCvSubst -> InScopeSet +getTCvInScope (TCvSubst in_scope _ _) = in_scope + +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 + +extendSubstEnvs :: (TvSubstEnv, CvSubstEnv) -> Var -> Type + -> (TvSubstEnv, CvSubstEnv) +extendSubstEnvs (tenv, cenv) v ty + | isTyVar v + = ASSERT( not $ isCoercionTy ty ) + (extendVarEnv tenv v ty, cenv) + + -- NB: v might *not* be a proper covar, because it might be lifted. + -- This happens in tcCoercionToCoercion + | CoercionTy co <- ty + = (tenv, extendVarEnv cenv v co) + | otherwise + = pprPanic "extendSubstEnvs" (ppr v <+> ptext (sLit "|->") <+> ppr ty) + +extendTCvSubst :: TCvSubst -> Var -> Type -> TCvSubst +extendTCvSubst (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst in_scope tenv' cenv' + where (tenv', cenv') = extendSubstEnvs (tenv, cenv) tv ty + +extendTCvSubstAndInScope :: TCvSubst -> TyCoVar -> Type -> TCvSubst +-- Also extends the in-scope set +extendTCvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) + tenv' cenv' + where (tenv', cenv') = extendSubstEnvs (tenv, cenv) tv ty + +extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTCvSubstList subst tvs tys + = foldl2 extendTCvSubst subst tvs tys + +extendTCvSubstBinder :: TCvSubst -> TyBinder -> Type -> TCvSubst +extendTCvSubstBinder env (Anon {}) _ = env +extendTCvSubstBinder env (Named tv _) ty = extendTCvSubst env tv ty + +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) + +-- mkOpenTCvSubst and zipOpenTCvSubst 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 + +-- Note [Generating the in-scope set for a substitution] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we want to substitute [a -> ty1, b -> ty2] I used to +-- think it was enough to generate an in-scope set that includes +-- fv(ty1,ty2). But that's not enough; we really should also take the +-- free vars of the type we are substituting into! Example: +-- (forall b. (a,b,x)) [a -> List b] +-- Then if we use the in-scope set {b}, there is a danger we will rename +-- the forall'd variable to 'x' by mistake, getting this: +-- (forall x. (List b, x, x)) +-- Urk! This means looking at all the calls to mkOpenTCvSubst.... + + +-- | Generates an in-scope set from the free variables in a list of types +-- and a list of coercions +mkTyCoInScopeSet :: [Type] -> [Coercion] -> InScopeSet +mkTyCoInScopeSet tys cos + = mkInScopeSet (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos) + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment, hence "open" +mkOpenTCvSubst :: TvSubstEnv -> CvSubstEnv -> TCvSubst +mkOpenTCvSubst tenv cenv + = TCvSubst (mkTyCoInScopeSet (varEnvElts tenv) (varEnvElts cenv)) tenv cenv + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment, hence "open". No CoVars, please! +zipOpenTCvSubst :: [TyVar] -> [Type] -> TCvSubst +zipOpenTCvSubst tyvars tys + | debugIsOn && (length tyvars /= length tys) + = pprTrace "zipOpenTCvSubst" (ppr tyvars $$ ppr tys) emptyTCvSubst + | otherwise + = TCvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv emptyCvSubstEnv + where tenv = zipTyEnv tyvars tys + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment, hence "open". +zipOpenTCvSubstCoVars :: [CoVar] -> [Coercion] -> TCvSubst +zipOpenTCvSubstCoVars cvs cos + | debugIsOn && (length cvs /= length cos) + = pprTrace "zipOpenTCvSubstCoVars" (ppr cvs $$ ppr cos) emptyTCvSubst + | otherwise + = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv + where cenv = zipCoEnv cvs cos + + +-- | Create an open TCvSubst combining the binders and types provided. +-- NB: It is OK if the lists are of different lengths. +zipOpenTCvSubstBinders :: [TyBinder] -> [Type] -> TCvSubst +zipOpenTCvSubstBinders bndrs tys + = TCvSubst is tenv emptyCvSubstEnv + where + is = mkInScopeSet (tyCoVarsOfTypes tys) + (tvs, tys') = unzip [ (tv, ty) | (Named tv _, ty) <- zip bndrs tys ] + tenv = zipTyEnv tvs tys' + +-- | Called when doing top-level substitutions. Here we expect that the +-- free vars of the range of the substitution will be empty. +mkTopTCvSubst :: [(TyCoVar, Type)] -> TCvSubst +mkTopTCvSubst prs = TCvSubst emptyInScopeSet tenv cenv + where (tenv, cenv) = foldl extend (emptyTvSubstEnv, emptyCvSubstEnv) prs + extend envs (v, ty) = extendSubstEnvs envs v ty + +-- | Makes a subst with an empty in-scope-set. No CoVars, please! +zipTopTCvSubst :: [TyVar] -> [Type] -> TCvSubst +zipTopTCvSubst tyvars tys + | debugIsOn && (length tyvars /= length tys) + = pprTrace "zipTopTCvSubst" (ppr tyvars $$ ppr tys) emptyTCvSubst + | otherwise + = TCvSubst emptyInScopeSet tenv emptyCvSubstEnv + where tenv = zipTyEnv tyvars tys + +zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv +zipTyEnv tyvars tys + = 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 :: [CoVar] -> [Coercion] -> CvSubstEnv +zipCoEnv cvs cos = mkVarEnv (zipEqual "zipCoEnv" cvs cos) + +instance Outputable TCvSubst where + ppr (TCvSubst ins tenv cenv) + = brackets $ sep[ ptext (sLit "TCvSubst"), + nest 2 (ptext (sLit "In scope:") <+> ppr ins), + nest 2 (ptext (sLit "Type env:") <+> ppr tenv), + nest 2 (ptext (sLit "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]) + +-} + +-- | Create a substitution from tyvars to types, but later types may depend +-- on earlier ones. Return the substed types and the built substitution. +substTelescope :: [TyCoVar] -> [Type] -> ([Type], TCvSubst) +substTelescope = go_subst emptyTCvSubst + where + go_subst :: TCvSubst -> [TyCoVar] -> [Type] -> ([Type], TCvSubst) + go_subst subst [] [] = ([], subst) + go_subst subst (tv:tvs) (k:ks) + = let k' = substTy subst k in + liftFst (k' :) $ go_subst (extendTCvSubst subst tv k') tvs ks + go_subst _ _ _ = panic "substTelescope" + + +-- | Type substitution making use of an 'TCvSubst' that +-- is assumed to be open, see 'zipOpenTCvSubst' +substTyWith :: [TyVar] -> [Type] -> Type -> Type +substTyWith tvs tys = ASSERT( length tvs == length tys ) + substTy (zipOpenTCvSubst tvs tys) + +-- | Coercion substitution making use of an 'TCvSubst' that +-- is assumed to be open, see 'zipOpenTCvSubst' +substCoWith :: [TyVar] -> [Type] -> Coercion -> Coercion +substCoWith tvs tys = ASSERT( length tvs == length tys ) + substCo (zipOpenTCvSubst tvs tys) + +-- | Substitute covars within a type +substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type +substTyWithCoVars cvs cos = substTy (zipOpenTCvSubstCoVars cvs cos) + +-- | Type substitution making use of an 'TCvSubst' that +-- is assumed to be open, see 'zipOpenTCvSubst' +substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] +substTysWith tvs tys = ASSERT( length tvs == length tys ) + substTys (zipOpenTCvSubst tvs tys) + +-- | Type substitution making use of an 'TCvSubst' that +-- is assumed to be open, see 'zipOpenTCvSubst' +substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] +substTysWithCoVars cvs cos = ASSERT( length cvs == length cos ) + substTys (zipOpenTCvSubstCoVars cvs cos) + +-- | Type substitution using 'Binder's. Anonymous binders +-- simply ignore their matching type. +substTyWithBinders :: [TyBinder] -> [Type] -> Type -> Type +substTyWithBinders bndrs tys = ASSERT( length bndrs == length tys ) + substTy (zipOpenTCvSubstBinders bndrs tys) + +-- | Substitute within a 'Type' +substTy :: TCvSubst -> Type -> Type +substTy subst ty | isEmptyTCvSubst subst = ty + | otherwise = subst_ty subst ty + +-- | Substitute within several 'Type's +substTys :: TCvSubst -> [Type] -> [Type] +substTys subst tys | isEmptyTCvSubst subst = tys + | otherwise = map (subst_ty subst) tys + +-- | Substitute within a 'ThetaType' +substTheta :: TCvSubst -> ThetaType -> ThetaType +substTheta = substTys + +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 (ForAllTy (Anon arg) res) + = (ForAllTy $! (Anon $! go arg)) $! go res + go (ForAllTy (Named tv vis) ty) + = case substTyVarBndr subst tv of + (subst', tv') -> + (ForAllTy $! ((Named $! tv') vis)) $! + (subst_ty subst' ty) + go (LitTy n) = LitTy $! n + go (CastTy ty co) = (CastTy $! (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 + +lookupTyVar :: TCvSubst -> TyVar -> Maybe Type + -- See Note [Extending the TCvSubst] +lookupTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + lookupVarEnv tenv tv + +-- | Substitute within a 'Coercion' +substCo :: TCvSubst -> Coercion -> Coercion +substCo subst co | isEmptyTCvSubst subst = co + | otherwise = subst_co subst co + +-- | Substitute within several 'Coercion's +substCos :: TCvSubst -> [Coercion] -> [Coercion] +substCos subst cos | isEmptyTCvSubst subst = cos + | otherwise = map (substCo subst) cos + +subst_co :: TCvSubst -> Coercion -> Coercion +subst_co subst co + = go co + where + go_ty :: Type -> Type + go_ty = subst_ty subst + + go :: Coercion -> Coercion + go (Refl r ty) = mkReflCo r $! go_ty ty + 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 substForAllCoBndr subst tv kind_co of { (subst', tv', kind_co') -> + ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co } + 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 d co) = mkNthCo d $! (go co) + go (LRCo lr co) = mkLRCo lr $! (go co) + go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg + go (CoherenceCo co1 co2) = (mkCoherenceCo $! (go co1)) $! (go co2) + 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_prov UnsafeCoerceProv = UnsafeCoerceProv + go_prov (PhantomProv kco) = PhantomProv (go kco) + go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) + go_prov p@(PluginProv _) = p + go_prov p@(HoleProv _) = p + -- NB: this last case is a little suspicious, but we need it. Originally, + -- there was a panic here, but it triggered from deeplySkolemise. Because + -- we only skolemise tyvars that are manually bound, this operation makes + -- sense, even over a coercion with holes. + +substForAllCoBndr :: TCvSubst -> TyVar -> Coercion -> (TCvSubst, TyVar, Coercion) +substForAllCoBndr subst + = substForAllCoBndrCallback False (substCo subst) subst + +-- See Note [Sym and ForAllCo] +substForAllCoBndrCallback :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyVar -> Coercion + -> (TCvSubst, TyVar, Coercion) +substForAllCoBndrCallback sym sco (TCvSubst in_scope tenv cenv) + old_var old_kind_co + = ( 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 = isEmptyVarSet (tyCoVarsOfCo 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 new_ki1 _ = coercionKind new_kind_co + + new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) + +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 :: TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndr = substTyVarBndrCallback substTy + +-- | Substitute a tyvar in a binding position, returning an +-- extended subst and a new tyvar. +substTyVarBndrCallback :: (TCvSubst -> Type -> Type) -- ^ the subst function + -> TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndrCallback subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT2( _no_capture, pprTvBndr old_var $$ pprTvBndr 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` tyCoVarsOfTypes (varEnvElts tenv)) + -- Assertion check that we are not capturing something in the substitution + + old_ki = tyVarKind old_var + no_kind_change = isEmptyVarSet (tyCoVarsOfType 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 $ updateTyVarKind (subst_fn subst) old_var + -- The uniqAway part makes sure the new variable is not already in scope + +substCoVarBndr :: TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndr = substCoVarBndrCallback False substTy + +substCoVarBndrCallback :: Bool -- apply "sym" to the covar? + -> (TCvSubst -> Type -> Type) + -> TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndrCallback sym subst_fun subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT( isCoVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + where + -- When we substitute (co :: t1 ~ t2) we may get the identity (co :: t ~ t) + -- In that case, mkCoVarCo will return a ReflCoercion, and + -- we want to substitute that (not new_var) for old_var + new_co = (if sym then mkSymCo else id) $ mkCoVarCo new_var + no_kind_change = isEmptyVarSet (tyCoVarsOfTypes [t1, t2]) + no_change = new_var == old_var && not (isReflCo new_co) && 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_fun subst t1 + t2' = subst_fun subst t2 + new_var_type = uncurry (mkCoercionType role) (if sym then (t2', t1') else (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 (TCvSubst in_scope tv_env cv_env) tv uniq + | isTyVar tv + = (TCvSubst (extendInScopeSet in_scope tv') + (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') + | otherwise + = (TCvSubst (extendInScopeSet in_scope tv') + tv_env (extendVarEnv cv_env tv (mkCoVarCo tv')), tv') + where + tv' = setVarUnique tv uniq -- Simply set the unique; the kind + -- has no type variables to worry about + +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' + +{- +%************************************************************************ +%* * + 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 [Precedence in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't keep the fixity of type operators in the operator. So the pretty printer +operates the following precedene structre: + Type constructor application binds more tightly than + Oerator applications which bind more tightly than + Function arrow + +So we might see a :+: T b -> c +meaning (a :+: (T b)) -> c + +Maybe operator applications should bind a bit less tightly? + +Anyway, that's the current story, and it is used consistently for Type and HsType +-} + +data TyPrec -- See Note [Prededence in types] + = TopPrec -- No parens + | FunPrec -- Function args; no parens for tycon apps + | TyOpPrec -- Infix operator + | TyConPrec -- Tycon args; no parens for atomic + deriving( Eq, Ord ) + +maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = parens pretty + +------------------ +pprType, pprParendType :: Type -> SDoc +pprType ty = ppr_type TopPrec ty +pprParendType ty = ppr_type TyConPrec ty + +pprTyLit :: TyLit -> SDoc +pprTyLit = ppr_tylit TopPrec + +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType + +------------ +pprClassPred :: Class -> [Type] -> SDoc +pprClassPred clas tys = pprTypeApp (classTyCon clas) tys + +------------ +pprTheta :: ThetaType -> SDoc +pprTheta [pred] = ppr_type TopPrec pred -- I'm in two minds about this +pprTheta theta = parens (sep (punctuate comma (map (ppr_type TopPrec) theta))) + +pprThetaArrowTy :: ThetaType -> SDoc +pprThetaArrowTy [] = empty +pprThetaArrowTy [pred] = ppr_type TyOpPrec pred <+> darrow + -- TyOpPrec: Num a => a -> a does not need parens + -- bug (a :~: b) => a -> b currently does + -- Trac # 9658 +pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) preds))) + <+> darrow + -- Notice 'fsep' here rather that 'sep', so that + -- type contexts don't get displayed in a giant column + -- Rather than + -- instance (Eq a, + -- Eq b, + -- Eq c, + -- Eq d, + -- Eq e, + -- Eq f, + -- Eq g, + -- Eq h, + -- Eq i, + -- Eq j, + -- Eq k, + -- Eq l) => + -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) + -- we get + -- + -- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, + -- Eq j, Eq k, Eq l) => + -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) + +------------------ +instance Outputable Type where + ppr ty = pprType ty + +instance Outputable TyLit where + ppr = pprTyLit + +------------------ + -- OK, here's the main printer + +ppr_type :: TyPrec -> Type -> SDoc +ppr_type _ (TyVarTy tv) = ppr_tvar tv + +ppr_type p (TyConApp tc tys) = pprTyTcApp p tc tys +ppr_type p (LitTy l) = ppr_tylit p l +ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty + +ppr_type p (AppTy t1 t2) + = if_print_coercions + ppr_app_ty + (case split_app_tys t1 [t2] of + (CastTy head _, args) -> ppr_type p (mk_app_tys head args) + _ -> ppr_app_ty) + where + ppr_app_ty = maybeParen p TyConPrec $ + ppr_type FunPrec t1 <+> ppr_type TyConPrec t2 + + split_app_tys (AppTy ty1 ty2) args = split_app_tys ty1 (ty2:args) + split_app_tys head args = (head, args) + + mk_app_tys (TyConApp tc tys1) tys2 = TyConApp tc (tys1 ++ tys2) + mk_app_tys ty1 tys2 = foldl AppTy ty1 tys2 + +ppr_type p (CastTy ty co) + = if_print_coercions + (parens (ppr_type TopPrec ty <+> ptext (sLit "|>") <+> ppr co)) + (ppr_type p ty) + +ppr_type _ (CoercionTy co) + = if_print_coercions + (parens (ppr co)) + (text "<>") + +ppr_forall_type :: TyPrec -> Type -> SDoc +ppr_forall_type p ty + = maybeParen p FunPrec $ ppr_sigma_type True ty + -- True <=> we always print the foralls on *nested* quantifiers + -- Opt_PrintExplicitForalls only affects top-level quantifiers + -- False <=> we don't print an extra-constraints wildcard + +ppr_tvar :: TyVar -> SDoc +ppr_tvar tv -- Note [Infix type variables] + = parenSymOcc (getOccName tv) (ppr tv) + +ppr_tylit :: TyPrec -> TyLit -> SDoc +ppr_tylit _ tl = + case tl of + NumTyLit n -> integer n + StrTyLit s -> text (show s) + +if_print_coercions :: SDoc -- if printing coercions + -> SDoc -- otherwise + -> SDoc +if_print_coercions yes no + = sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + if gopt Opt_PrintExplicitCoercions dflags + || dumpStyle style || debugStyle style + then yes + else no + +------------------- +ppr_sigma_type :: Bool -> Type -> SDoc +-- First Bool <=> Show the foralls unconditionally +-- Second Bool <=> Show an extra-constraints wildcard +ppr_sigma_type show_foralls_unconditionally ty + = sep [ if show_foralls_unconditionally + then pprForAll bndrs + else pprUserForAll bndrs + , pprThetaArrowTy ctxt + , pprArrowChain TopPrec (ppr_fun_tail tau) ] + where + (bndrs, rho) = split1 [] ty + (ctxt, tau) = split2 [] rho + + split1 bndrs (ForAllTy bndr@(Named {}) ty) = split1 (bndr:bndrs) ty + split1 bndrs ty = (reverse bndrs, ty) + + split2 ps (ForAllTy (Anon ty1) ty2) | isPredTy ty1 = split2 (ty1:ps) ty2 + split2 ps ty = (reverse ps, ty) + + -- We don't want to lose synonyms, so we mustn't use splitFunTys here. + ppr_fun_tail (ForAllTy (Anon ty1) ty2) + | not (isPredTy ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2 + ppr_fun_tail other_ty = [ppr_type TopPrec other_ty] + +pprSigmaType :: Type -> SDoc +pprSigmaType ty = ppr_sigma_type False ty + +pprUserForAll :: [TyBinder] -> SDoc +-- Print a user-level forall; see Note [When to print foralls] +pprUserForAll bndrs + = sdocWithDynFlags $ \dflags -> + ppWhen (any bndr_has_kind_var bndrs || gopt Opt_PrintExplicitForalls dflags) $ + pprForAll bndrs + where + bndr_has_kind_var bndr + = not (isEmptyVarSet (tyCoVarsOfType (binderType bndr))) + +pprForAllImplicit :: [TyVar] -> SDoc +pprForAllImplicit tvs = pprForAll (zipWith Named tvs (repeat Invisible)) + +-- | Render the "forall ... ." or "forall ... ->" bit of a type. +-- Do not pass in anonymous binders! +pprForAll :: [TyBinder] -> SDoc +pprForAll [] = empty +pprForAll bndrs@(Named _ vis : _) + = add_separator (forAllLit <+> doc) <+> pprForAll bndrs' + where + (bndrs', doc) = ppr_tv_bndrs bndrs vis + + add_separator stuff = case vis of + Invisible -> stuff <> dot + Visible -> stuff <+> arrow +pprForAll bndrs = pprPanic "pprForAll: anonymous binder" (ppr bndrs) + +pprTvBndrs :: [TyVar] -> SDoc +pprTvBndrs tvs = sep (map pprTvBndr tvs) + +-- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. +-- Returns both the list of not-yet-rendered binders and the doc. +-- No anonymous binders here! +ppr_tv_bndrs :: [TyBinder] + -> VisibilityFlag -- ^ visibility of the first binder in the list + -> ([TyBinder], SDoc) +ppr_tv_bndrs all_bndrs@(Named tv vis : bndrs) vis1 + | vis == vis1 = let (bndrs', doc) = ppr_tv_bndrs bndrs vis1 in + (bndrs', pprTvBndr tv <+> doc) + | otherwise = (all_bndrs, empty) +ppr_tv_bndrs [] _ = ([], empty) +ppr_tv_bndrs bndrs _ = pprPanic "ppr_tv_bndrs: anonymous binder" (ppr bndrs) + +pprTvBndr :: TyVar -> SDoc +pprTvBndr tv + | isLiftedTypeKind kind = ppr_tvar tv + | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) + where + kind = tyVarKind tv + +instance Outputable TyBinder where + ppr (Named v Visible) = ppr v + ppr (Named v Invisible) = braces (ppr v) + ppr (Anon ty) = text "[anon]" <+> ppr ty + +instance Outputable VisibilityFlag where + ppr Visible = text "[vis]" + ppr Invisible = text "[invis]" + +----------------- +instance Outputable Coercion where -- defined here to avoid orphans + ppr = pprCo +instance Outputable LeftOrRight where + ppr CLeft = ptext (sLit "Left") + ppr CRight = ptext (sLit "Right") + +{- +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 Trac #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 pprTvBndr. + +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 Trac #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 + forAllDoc = pprUserForAll $ map (\tv -> Named tv Invisible) $ + ((univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs) + thetaDoc = pprThetaArrowTy theta + argsDoc = hsep (fmap pprParendType arg_tys) + + +pprTypeApp :: TyCon -> [Type] -> SDoc +pprTypeApp tc tys = pprTyTcApp TopPrec tc tys + -- We have to use ppr on the TyCon (not its name) + -- so that we get promotion quotes in the right place + +pprTyTcApp :: TyPrec -> TyCon -> [Type] -> SDoc +-- Used for types only; so that we can make a +-- special case for type-level lists +pprTyTcApp p tc tys + | tc `hasKey` ipTyConKey + , [LitTy (StrTyLit n),ty] <- tys + = maybeParen p FunPrec $ + char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty + + | tc `hasKey` consDataConKey + , [_kind,ty1,ty2] <- tys + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PrintExplicitKinds dflags then ppr_deflt + else pprTyList p ty1 ty2 + + | not opt_PprStyle_Debug + , tc `hasKey` errorMessageTypeErrorFamKey + = text "(TypeError ...)" -- Suppress detail unles you _really_ want to see + + | tc `hasKey` tYPETyConKey + , [TyConApp lev_tc []] <- tys + = if | lev_tc `hasKey` liftedDataConKey -> char '*' + | lev_tc `hasKey` unliftedDataConKey -> char '#' + | otherwise -> ppr_deflt + + | otherwise + = ppr_deflt + where + ppr_deflt = pprTcAppTy p ppr_type tc tys + +pprTcAppTy :: TyPrec -> (TyPrec -> Type -> SDoc) -> TyCon -> [Type] -> SDoc +pprTcAppTy = pprTcApp id + +pprTcAppCo :: TyPrec -> (TyPrec -> Coercion -> SDoc) + -> TyCon -> [Coercion] -> SDoc +pprTcAppCo = pprTcApp (pFst . coercionKind) + +pprTcApp :: (a -> Type) -> TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc +-- Used for both types and coercions, hence polymorphism +pprTcApp _ _ pp tc [ty] + | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) + | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) + +pprTcApp to_type p pp tc tys + | Just sort <- tyConTuple_maybe tc + , let arity = tyConArity tc + , arity == length tys + , let num_to_drop = case sort of UnboxedTuple -> arity `div` 2 + _ -> 0 + = pprTupleApp p pp tc sort (drop num_to_drop tys) + + | Just dc <- isPromotedDataCon_maybe tc + , let dc_tc = dataConTyCon dc + , Just tup_sort <- tyConTuple_maybe dc_tc + , let arity = tyConArity dc_tc -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3 + ty_args = drop arity tys -- Drop the kind args + , ty_args `lengthIs` arity -- Result is saturated + = pprPromotionQuote tc <> + (tupleParens tup_sort $ pprWithCommas (pp TopPrec) ty_args) + + | otherwise + = sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + pprTcApp_help to_type p pp tc tys dflags style + where + +pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) + -> TyCon -> TupleSort -> [a] -> SDoc +-- Print a saturated tuple +pprTupleApp p pp tc sort tys + | null tys + , ConstraintTuple <- sort + = if opt_PprStyle_Debug then ptext (sLit "(%%)") + else maybeParen p FunPrec $ + ptext (sLit "() :: Constraint") + | otherwise + = pprPromotionQuote tc <> + tupleParens sort (pprWithCommas (pp TopPrec) tys) + +pprTcApp_help :: (a -> Type) -> TyPrec -> (TyPrec -> a -> SDoc) + -> TyCon -> [a] -> DynFlags -> PprStyle -> SDoc +-- This one has accss to the DynFlags +pprTcApp_help to_type p pp tc tys dflags style + | print_prefix + = pprPrefixApp p pp_tc (map (pp TyConPrec) tys_wo_kinds) + + | [ty1,ty2] <- tys_wo_kinds -- Infix, two arguments; + -- we know nothing of precedence though + = pprInfixApp p pp pp_tc ty1 ty2 + + | tc_name `hasKey` starKindTyConKey + || tc_name `hasKey` unicodeStarKindTyConKey + || tc_name `hasKey` unliftedTypeKindTyConKey + = pp_tc -- Do not wrap *, # in parens + + | otherwise + = pprPrefixApp p (parens pp_tc) (map (pp TyConPrec) tys_wo_kinds) + where + tc_name = tyConName tc + + -- With the solver working in unlifted equality, it will want to + -- to print unlifted equality constraints sometimes. But these are + -- confusing to users. So fix them up here. + (print_prefix, pp_tc) + | (tc `hasKey` eqPrimTyConKey || tc `hasKey` heqTyConKey) && not print_eqs + = (False, text "~") + | tc `hasKey` eqReprPrimTyConKey && not print_eqs + = (True, text "Coercible") + | otherwise + = (not (isSymOcc (nameOccName tc_name)), ppr tc) + + print_eqs = gopt Opt_PrintEqualityRelations dflags || + dumpStyle style || + debugStyle style + tys_wo_kinds = suppressInvisibles to_type dflags tc tys + +------------------ +-- | Given a 'TyCon',and the args to which it is applied, +-- suppress the args that are implicit +suppressInvisibles :: (a -> Type) -> DynFlags -> TyCon -> [a] -> [a] +suppressInvisibles to_type dflags tc xs + | gopt Opt_PrintExplicitKinds dflags = xs + | otherwise = snd $ partitionInvisibles tc to_type xs + +---------------- +pprTyList :: TyPrec -> Type -> Type -> SDoc +-- Given a type-level list (t1 ': t2), see if we can print +-- it in list notation [t1, ...]. +pprTyList p ty1 ty2 + = case gather ty2 of + (arg_tys, Nothing) -> char '\'' <> brackets (fsep (punctuate comma + (map (ppr_type TopPrec) (ty1:arg_tys)))) + (arg_tys, Just tl) -> maybeParen p FunPrec $ + hang (ppr_type FunPrec ty1) + 2 (fsep [ colon <+> ppr_type FunPrec ty | ty <- arg_tys ++ [tl]]) + where + gather :: Type -> ([Type], Maybe Type) + -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] + -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl + gather (TyConApp tc tys) + | tc `hasKey` consDataConKey + , [_kind, ty1,ty2] <- tys + , (args, tl) <- gather ty2 + = (ty1:args, tl) + | tc `hasKey` nilDataConKey + = ([], Nothing) + gather ty = ([], Just ty) + +---------------- +pprInfixApp :: TyPrec -> (TyPrec -> a -> SDoc) -> SDoc -> a -> a -> SDoc +pprInfixApp p pp pp_tc ty1 ty2 + = maybeParen p TyOpPrec $ + sep [pp TyOpPrec ty1, pprInfixVar True pp_tc <+> pp TyOpPrec ty2] + +pprPrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc +pprPrefixApp p pp_fun pp_tys + | null pp_tys = pp_fun + | otherwise = maybeParen p TyConPrec $ + hang pp_fun 2 (sep pp_tys) +---------------- +pprArrowChain :: TyPrec -> [SDoc] -> SDoc +-- pprArrowChain p [a,b,c] generates a -> b -> c +pprArrowChain _ [] = empty +pprArrowChain p (arg:args) = maybeParen p FunPrec $ + sep [arg, sep (map (arrow <+>) args)] + +{- +%************************************************************************ +%* * +\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. +tidyTyCoVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyTyCoVarBndrs env tvs = mapAccumL tidyTyCoVarBndr env tvs + +tidyTyCoVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +tidyTyCoVarBndr tidy_env@(occ_env, subst) tyvar + = case tidyOccName occ_env occ1 of + (tidy', occ') -> ((tidy', subst'), tyvar') + where + subst' = extendVarEnv subst tyvar tyvar' + tyvar' = setTyVarKind (setTyVarName tyvar name') kind' + name' = tidyNameOcc name occ' + kind' = tidyKind tidy_env (tyVarKind tyvar) + where + name = tyVarName tyvar + occ = getOccName name + -- System Names are for unification variables; + -- 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 + occ1 | isSystemName name + = if isTyVar tyvar + then mkTyVarOcc (occNameString occ ++ "0") + else mkVarOcc (occNameString occ ++ "0") + | otherwise = occ + +--------------- +tidyFreeTyCoVars :: TidyEnv -> TyCoVarSet -> TidyEnv +-- ^ Add the free 'TyVar's to the env in tidy form, +-- so that we can tidy the type they are free in +tidyFreeTyCoVars (full_occ_env, var_env) tyvars + = fst (tidyOpenTyCoVars (full_occ_env, var_env) (varSetElems 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 'tidyTyCoVarBndr' +tidyOpenTyCoVar env@(_, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> tidyTyCoVarBndr env tyvar -- Treat it as a binder + +--------------- +tidyTyVarOcc :: TidyEnv -> TyVar -> TyVar +tidyTyVarOcc (_, subst) tv + = case lookupVarEnv subst tv of + Nothing -> 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 (tidyTyVarOcc 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 (ForAllTy (Anon fun) arg) + = (ForAllTy $! (Anon $! (tidyType env fun))) $! (tidyType env arg) +tidyType env (ForAllTy (Named tv vis) ty) + = (ForAllTy $! ((Named $! tvp) $! vis)) $! (tidyType envp ty) + where + (envp, tvp) = tidyTyCoVarBndr env tv +tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) +tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) + +--------------- +-- | Grabs the free type variables, tidies them +-- and then uses 'tidyType' to work over the type itself +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty + = (env', tidyType (trimmed_occ_env, var_env) ty) + where + (env'@(_, var_env), tvs') = tidyOpenTyCoVars env (tyCoVarsOfTypeList ty) + trimmed_occ_env = initTidyOccEnv (map getOccName tvs') + -- The idea here was that we restrict the new TidyEnv to the + -- _free_ vars of the type, so that we don't gratuitously rename + -- the _bound_ variables of the type. + +--------------- +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys = mapAccumL tidyOpenType env tys + +--------------- +-- | 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 (Refl r ty) = Refl r (tidyType env ty) + 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) = tidyTyCoVarBndr 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 (CoVarCo cv) = case lookupVarEnv subst cv of + Nothing -> CoVarCo cv + Just cv' -> CoVarCo cv' + 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 d co) = NthCo d $! go co + go (LRCo lr co) = LRCo lr $! go co + go (InstCo co ty) = (InstCo $! go co) $! go ty + go (CoherenceCo co1 co2) = (CoherenceCo $! go co1) $! go co2 + 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 UnsafeCoerceProv = UnsafeCoerceProv + go_prov (PhantomProv co) = PhantomProv (go co) + go_prov (ProofIrrelProv co) = ProofIrrelProv (go co) + go_prov p@(PluginProv _) = p + go_prov p@(HoleProv _) = p + +tidyCos :: TidyEnv -> [Coercion] -> [Coercion] +tidyCos env = map (tidyCo env) diff --git a/compiler/types/TypeRep.hs-boot b/compiler/types/TyCoRep.hs-boot index 7233c5d239..76a5abf2f1 100644 --- a/compiler/types/TypeRep.hs-boot +++ b/compiler/types/TyCoRep.hs-boot @@ -1,15 +1,18 @@ -module TypeRep where +module TyCoRep where import Outputable (Outputable) import Data.Data (Data,Typeable) data Type +data TyBinder data TyThing -data TvSubst +data Coercion +data LeftOrRight +data UnivCoProvenance +data TCvSubst type PredType = Type type Kind = Type -type SuperKind = Type type ThetaType = [PredType] instance Outputable Type diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index fd0d5e5aac..356e2ea9dc 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -14,7 +14,7 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, AlgTyConFlav(..), isNoParent, - FamTyConFlav(..), Role(..), Promoted(..), Injectivity(..), + FamTyConFlav(..), Role(..), Injectivity(..), -- ** Field labels tyConFieldLabels, tyConFieldLabelEnv, @@ -30,19 +30,18 @@ module TyCon( mkSynonymTyCon, mkFamilyTyCon, mkPromotedDataCon, - mkPromotedTyCon, + mkTcTyCon, -- ** Predicates on TyCons - isAlgTyCon, + isAlgTyCon, isVanillaAlgTyCon, isClassTyCon, isFamInstTyCon, isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isTypeSynonymTyCon, mightBeUnsaturatedTyCon, - isPromotedDataCon, isPromotedTyCon, - isPromotedDataCon_maybe, isPromotedTyCon_maybe, - promotableTyCon_maybe, isPromotableTyCon, promoteTyCon, + isPromotedDataCon, isPromotedDataCon_maybe, + isKindTyCon, isLiftedTypeKindTyConName, isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, isEnumerationTyCon, @@ -58,6 +57,7 @@ module TyCon( isRecursiveTyCon, isImplicitTyCon, isTyConWithSrcDataCons, + isTcTyCon, -- ** Extracting information out of TyCons tyConName, @@ -105,7 +105,7 @@ module TyCon( #include "HsVersions.h" -import {-# SOURCE #-} TypeRep ( Kind, Type, PredType ) +import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType ) import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars, dataConFieldLabels ) import Binary @@ -318,6 +318,17 @@ 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 levity vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The contents of an unboxed tuple may be boxed or unboxed. Accordingly, +the kind of the unboxed tuple constructor is sort-polymorphic. For example, + + (#,#) :: forall (v :: Levity) (w :: Levity). TYPE v -> TYPE w -> # + +These extra tyvars (v and w) cause some delicate processing around tuples, +where we used to be able to assume that the tycon arity and the +datacon arity were the same. + Note [Injective type families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -454,11 +465,10 @@ data TyCon algTcRec :: RecFlag, -- ^ Tells us whether the data type is part -- of a mutually-recursive group or not - algTcParent :: AlgTyConFlav, -- ^ Gives the class or family declaration + algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration -- 'TyCon' for derived 'TyCon's representing -- class or family instances, respectively. - tcPromoted :: Promoted TyCon -- ^ Promoted TyCon, if any } -- | Represents type synonyms @@ -580,16 +590,12 @@ data TyCon tcRepName :: TyConRepName } - -- | Represents promoted type constructor. - | PromotedTyCon { - tyConUnique :: Unique, -- ^ Same Unique as the type constructor - tyConName :: Name, -- ^ Same Name as the type constructor - tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times - tyConKind :: Kind, -- ^ Always TysPrim.superKind - ty_con :: TyCon, -- ^ Corresponding type constructor - tcRepName :: TyConRepName - } - + -- | These exist only during a recursive type/class type-checking knot. + | TcTyCon { + tyConUnique :: Unique, + tyConName :: Name, + tyConKind :: Kind + } deriving Typeable @@ -656,10 +662,6 @@ data AlgTyConRhs -- again check Trac #1072. } --- | Isomorphic to Maybe, but used when the question is --- whether or not something is promoted -data Promoted a = NotPromoted | Promoted a - -- | 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! @@ -683,7 +685,7 @@ data AlgTyConFlav | UnboxedAlgTyCon -- | Type constructors representing a class dictionary. - -- See Note [ATyCon for classes] in TypeRep + -- See Note [ATyCon for classes] in TyCoRep | ClassTyCon Class -- INVARIANT: the classTyCon of this Class is the -- current tycon @@ -746,7 +748,7 @@ isNoParent _ = False data Injectivity = NotInjective - | Injective [Bool] -- Length is 1-1 with tyConTyVars (incl kind vars) + | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) deriving( Eq ) -- | Information pertaining to the expansion of a type synonym (@type@) @@ -756,7 +758,7 @@ data FamTyConFlav -- -- These are introduced by either a top level declaration: -- - -- > data T a :: * + -- > data family T a :: * -- -- Or an associated data type declaration, within a class declaration: -- @@ -797,27 +799,13 @@ nothing for the axiom to prove! Note [Promoted data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A data constructor can be promoted to become a type constructor, -via the PromotedTyCon alternative in TyCon. - -* Only data constructors with - (a) no kind polymorphism - (b) no constraints in its type (eg GADTs) - are promoted. Existentials are ok; see Trac #7347. +All data constructors can be promoted to become a type constructor, +via the PromotedDataCon alternative in 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) -* The *kind* of a promoted DataCon may be polymorphic. Example: - type of DataCon Just :: forall (a:*). a -> Maybe a - kind of (promoted) tycon Just :: forall (a:box). a -> Maybe a - The kind is not identical to the type, because of the */box - kind signature on the forall'd variable; so the tyConKind field of - PromotedTyCon is not identical to the dataConUserType of the - DataCon. But it's the same modulo changing the variable kinds, - done by DataCon.promoteType. - * Small note: We promote the *user* type of the DataCon. Eg data T = MkT {-# UNPACK #-} !(Bool, Bool) The promoted kind is @@ -924,8 +912,6 @@ tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) = Just rep_nm tyConRepName_maybe (PromotedDataCon { tcRepName = rep_nm }) = Just rep_nm -tyConRepName_maybe (PromotedTyCon { tcRepName = rep_nm }) - = Just rep_nm tyConRepName_maybe _ = Nothing @@ -1113,7 +1099,7 @@ 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 reccomended to use 'TypeRep.funTyCon' if you want +-- corresponding 'TyCon'. It is reccomended to use 'TyCoRep.funTyCon' if you want -- this functionality mkFunTyCon :: Name -> Kind -> Name -> TyCon mkFunTyCon name kind rep_nm @@ -1143,9 +1129,8 @@ mkAlgTyCon :: Name -- (e.g. vanilla, type family) -> RecFlag -- ^ Is the 'TyCon' recursive? -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? - -> Promoted TyCon -- ^ Promoted version -> TyCon -mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_tc +mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -1159,8 +1144,7 @@ mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_t algTcFields = fieldsOfAlgTcRhs rhs, algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, algTcRec = is_rec, - algTcGadtSyntax = gadt_syn, - tcPromoted = prom_tc + algTcGadtSyntax = gadt_syn } -- | Simpler specialization of 'mkAlgTyCon' for classes @@ -1170,7 +1154,6 @@ mkClassTyCon name kind tyvars roles rhs clas is_rec tc_rep_name = mkAlgTyCon name kind tyvars roles Nothing [] rhs (ClassTyCon clas tc_rep_name) is_rec False - NotPromoted -- Class TyCons are not promoted mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' @@ -1178,10 +1161,9 @@ mkTupleTyCon :: Name -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' -> DataCon -> TupleSort -- ^ Whether the tuple is boxed or unboxed - -> Promoted TyCon -- ^ Promoted version -> AlgTyConFlav -> TyCon -mkTupleTyCon name kind arity tyvars con sort prom_tc parent +mkTupleTyCon name kind arity tyvars con sort parent = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -1196,19 +1178,32 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc parent algTcFields = emptyFsEnv, algTcParent = parent, algTcRec = NonRecursive, - algTcGadtSyntax = False, - tcPromoted = prom_tc + algTcGadtSyntax = False } +-- | Makes a tycon suitable for use during type-checking. +-- The only real need for this is for printing error messages during +-- a recursive type/class type-checking knot. It has a kind because +-- TcErrors sometimes calls typeKind. +-- See also Note [Kind checking recursive type and class declarations] +-- in TcTyClsDecls. +mkTcTyCon :: Name -> Kind -> TyCon +mkTcTyCon name kind + = TcTyCon { tyConUnique = getUnique name + , tyConName = name + , tyConKind = kind } + -- | Create an unlifted primitive 'TyCon', such as @Int#@ mkPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon mkPrimTyCon name kind roles rep = mkPrimTyCon' name kind roles rep True Nothing -- | Kind constructors -mkKindTyCon :: Name -> Kind -> Name -> TyCon -mkKindTyCon name kind rep_nm - = mkPrimTyCon' name kind [] VoidRep True (Just rep_nm) +mkKindTyCon :: Name -> Kind -> [Role] -> Name -> TyCon +mkKindTyCon name kind roles rep_nm + = tc + where + tc = mkPrimTyCon' name kind roles VoidRep False (Just rep_nm) -- | Create a lifted primitive 'TyCon' such as @RealWorld@ mkLiftedPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon @@ -1277,23 +1272,6 @@ mkPromotedDataCon con name rep_name kind roles where arity = length roles --- | Create a promoted type constructor 'TyCon' --- Somewhat dodgily, we give it the same Name --- as the type constructor itself -mkPromotedTyCon :: TyCon -> Kind -> TyCon -mkPromotedTyCon tc kind - = PromotedTyCon { - tyConName = getName tc, - tyConUnique = getUnique tc, - tyConArity = tyConArity tc, - tyConKind = kind, - ty_con = tc, - tcRepName = case tyConRepName_maybe tc of - Just rep_nm -> rep_nm - Nothing -> pprPanic "mkPromotedTyCon" (ppr tc) - -- Promoted TyCons always have a TyConRepName - } - isFunTyCon :: TyCon -> Bool isFunTyCon (FunTyCon {}) = True isFunTyCon _ = False @@ -1339,6 +1317,12 @@ 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 @@ -1371,21 +1355,24 @@ isInjectiveTyCon (AlgTyCon {}) Nominal = True isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational = isGenInjAlgRhs rhs isInjectiveTyCon (SynonymTyCon {}) _ = False -isInjectiveTyCon (FamilyTyCon {famTcFlav = flav}) Nominal = isDataFamFlav flav -isInjectiveTyCon (FamilyTyCon {}) Representational = False +isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) + Nominal = True +isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) _ = and inj +isInjectiveTyCon (FamilyTyCon {}) _ = False isInjectiveTyCon (PrimTyCon {}) _ = True isInjectiveTyCon (PromotedDataCon {}) _ = True -isInjectiveTyCon (PromotedTyCon {ty_con = tc}) r - = isInjectiveTyCon tc r +isInjectiveTyCon tc@(TcTyCon {}) _ + = pprPanic "isInjectiveTyCon sees a TcTyCon" (ppr tc) -- | '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 equalities] in TcCanonical isGenerativeTyCon :: TyCon -> Role -> Bool -isGenerativeTyCon = isInjectiveTyCon - -- as it happens, generativity and injectivity coincide, but there's - -- no a priori reason this must be the case +isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True +isGenerativeTyCon (FamilyTyCon {}) _ = False + -- in all other cases, injectivity implies generativitiy +isGenerativeTyCon tc r = isInjectiveTyCon tc r -- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective -- with respect to representational equality? @@ -1544,8 +1531,8 @@ isClosedSynFamilyTyConWithAxiom_maybe (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing --- | Try to read the injectivity information from a FamilyTyCon. Only --- FamilyTyCons can be injective so for every other TyCon this function panics. +-- | Try to read the injectivity information from a FamilyTyCon. +-- For every other TyCon this function panics. familyTyConInjectivityInfo :: TyCon -> Injectivity familyTyConInjectivityInfo (FamilyTyCon { famTcInj = inj }) = inj familyTyConInjectivityInfo _ = panic "familyTyConInjectivityInfo" @@ -1605,30 +1592,6 @@ isRecursiveTyCon :: TyCon -> Bool isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True isRecursiveTyCon _ = False -promotableTyCon_maybe :: TyCon -> Promoted TyCon -promotableTyCon_maybe (AlgTyCon { tcPromoted = prom }) = prom -promotableTyCon_maybe _ = NotPromoted - -isPromotableTyCon :: TyCon -> Bool -isPromotableTyCon tc = case promotableTyCon_maybe tc of - Promoted {} -> True - NotPromoted -> False - -promoteTyCon :: TyCon -> TyCon -promoteTyCon tc = case promotableTyCon_maybe tc of - Promoted prom_tc -> prom_tc - NotPromoted -> pprPanic "promoteTyCon" (ppr tc) - --- | Is this a PromotedTyCon? -isPromotedTyCon :: TyCon -> Bool -isPromotedTyCon (PromotedTyCon {}) = True -isPromotedTyCon _ = False - --- | Retrieves the promoted TyCon if this is a PromotedTyCon; -isPromotedTyCon_maybe :: TyCon -> Maybe TyCon -isPromotedTyCon_maybe (PromotedTyCon { ty_con = tc }) = Just tc -isPromotedTyCon_maybe _ = Nothing - -- | Is this a PromotedDataCon? isPromotedDataCon :: TyCon -> Bool isPromotedDataCon (PromotedDataCon {}) = True @@ -1639,6 +1602,22 @@ 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 = isLiftedTypeKindTyConName (tyConName tc) || + tc `hasKey` constraintKindTyConKey || + tc `hasKey` tYPETyConKey || + tc `hasKey` levityTyConKey || + tc `hasKey` liftedDataConKey || + tc `hasKey` unliftedDataConKey + +isLiftedTypeKindTyConName :: Name -> Bool +isLiftedTypeKindTyConName + = (`hasKey` liftedTypeKindTyConKey) <||> + (`hasKey` starKindTyConKey) <||> + (`hasKey` unicodeStarKindTyConKey) + -- | Identifies implicit tycons that, in particular, do not go into interface -- files (because they are implicitly reconstructed when the interface is -- read). @@ -1658,17 +1637,23 @@ isImplicitTyCon :: TyCon -> Bool isImplicitTyCon (FunTyCon {}) = True isImplicitTyCon (PrimTyCon {}) = True isImplicitTyCon (PromotedDataCon {}) = True -isImplicitTyCon (PromotedTyCon {}) = True isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) | TupleTyCon {} <- rhs = isWiredInName name | otherwise = False isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent isImplicitTyCon (SynonymTyCon {}) = False +isImplicitTyCon tc@(TcTyCon {}) + = pprPanic "isImplicitTyCon sees a TcTyCon" (ppr tc) 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 + {- ----------------------------------------------- -- Expand type-constructor applications @@ -1795,7 +1780,7 @@ tyConRoles tc ; FamilyTyCon {} -> const_role Nominal ; PrimTyCon { tcRoles = roles } -> roles ; PromotedDataCon { tcRoles = roles } -> roles - ; PromotedTyCon {} -> const_role Nominal + ; TcTyCon {} -> pprPanic "tyConRoles sees a TcTyCon" (ppr tc) } where const_role r = replicate (tyConArity tc) r @@ -1956,18 +1941,14 @@ tyConFlavour (SynonymTyCon {}) = "type synonym" tyConFlavour (FunTyCon {}) = "built-in type" tyConFlavour (PrimTyCon {}) = "built-in type" tyConFlavour (PromotedDataCon {}) = "promoted data constructor" -tyConFlavour (PromotedTyCon {}) = "promoted type constructor" +tyConFlavour tc@(TcTyCon {}) + = pprPanic "tyConFlavour sees a TcTyCon" (ppr tc) 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 - - PromotedTyCon {} -> ifPprDebug (char '\'') - -- However, we don't quote TyCons in kinds, except with -dppr-debug - -- e.g. type family T a :: Bool -> * - -- cf Trac #5952. _ -> empty instance NamedThing TyCon where diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 50d3a7e2c3..d8064167a9 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -14,34 +14,53 @@ module Type ( -- $type_classification -- $representation_types - TyThing(..), Type, KindOrType, PredType, ThetaType, - Var, TyVar, isTyVar, + TyThing(..), Type, VisibilityFlag(..), KindOrType, PredType, ThetaType, + Var, TyVar, isTyVar, TyCoVar, TyBinder, -- ** Constructing and deconstructing types - mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, + getCastedTyVar_maybe, tyVarKind, mkAppTy, mkAppTys, splitAppTy, splitAppTys, - splitAppTy_maybe, repSplitAppTy_maybe, + splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN, - funResultTy, funArgTy, zipFunTys, + funResultTy, funArgTy, mkTyConApp, mkTyConTy, - tyConAppTyCon_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, + tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, + tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole, - splitTyConArgs, splitListTyConApp_maybe, - - mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - mkPiKinds, mkPiType, mkPiTypes, - applyTy, applyTys, applyTysD, applyTysX, dropForAlls, + splitListTyConApp_maybe, + repSplitTyConApp_maybe, + + mkForAllTy, mkForAllTys, mkInvForAllTys, mkVisForAllTys, + mkNamedForAllTy, + splitForAllTy_maybe, splitForAllTys, splitForAllTy, + splitPiTy_maybe, splitPiTys, splitPiTy, + splitNamedPiTys, + mkPiType, mkPiTypes, mkPiTypesPreferFunTy, + piResultTy, piResultTys, + applyTys, applyTysD, applyTysX, dropForAlls, mkNumLitTy, isNumLitTy, mkStrLitTy, isStrLitTy, + mkCastTy, mkCoercionTy, + userTypeError_maybe, pprUserTypeErrorTy, coAxNthLHS, + stripCoercionTy, splitCoercionType_maybe, + + splitPiTysInvisible, filterOutInvisibleTypes, + filterOutInvisibleTyVars, partitionInvisibles, + synTyConResKind, + tyConBinders, + + -- Analyzing types + TyCoMapper(..), mapType, mapCoercion, -- (Newtypes) newTyConInstRhs, @@ -49,9 +68,11 @@ module Type ( -- Pred types mkFamilyTyConApp, isDictLikeTy, - mkEqPred, mkCoerciblePred, mkPrimEqPred, mkReprPrimEqPred, + mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, + equalityTyCon, + mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, mkClassPred, - isClassPred, isEqPred, + isClassPred, isEqPred, isNomEqPred, isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, isCTupleClass, @@ -61,46 +82,58 @@ module Type ( getEqPredTys, getEqPredTys_maybe, getEqPredRole, predTypeEqRel, + -- ** Binders + mkNamedBinder, mkAnonBinder, isNamedBinder, isAnonBinder, + isIdLikeBinder, binderVisibility, binderVar_maybe, + binderVar, binderRelevantType_maybe, caseBinder, + partitionBinders, partitionBindersIntoBinders, + binderType, isVisibleBinder, isInvisibleBinder, + -- ** Common type constructors funTyCon, -- ** Predicates on types - isTypeVar, isKindVar, allDistinctTyVars, isForAllTy, - isTyVarTy, isFunTy, isDictTy, isPredTy, isVoidTy, + allDistinctTyVars, + isTyVarTy, isFunTy, isDictTy, isPredTy, isVoidTy, isCoercionTy, + isCoercionTy_maybe, isCoercionType, isForAllTy, + isPiTy, -- (Lifting and boxity) isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, isPrimitiveType, isStrictType, + isLevityTy, isLevityVar, getLevity, getLevityFromKind, -- * Main data types representing Kinds - -- $kind_subtyping - Kind, SimpleKind, MetaKindVar, + Kind, -- ** Finding the kind of a type typeKind, - -- ** Common Kinds and SuperKinds - anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, - constraintKind, superKind, - - -- ** Common Kind type constructors - liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - constraintKindTyCon, anyKindTyCon, + -- ** Common Kind + liftedTypeKind, unliftedTypeKind, -- * Type free variables - tyVarsOfType, tyVarsOfTypes, closeOverKinds, + tyCoVarsOfType, tyCoVarsOfTypes, tyCoVarsOfTypeAcc, + tyCoVarsOfTypeDSet, + coVarsOfType, + coVarsOfTypes, closeOverKinds, + splitDepVarsOfType, splitDepVarsOfTypes, + splitVisVarsOfType, splitVisVarsOfTypes, expandTypeSynonyms, - typeSize, varSetElemsKvsFirst, + typeSize, + + -- * Well-scoped lists of variables + varSetElemsWellScoped, toposortTyVars, tyCoVarsOfTypeWellScoped, -- * Type comparison - eqType, eqTypeX, eqTypes, cmpType, cmpTypes, - eqPred, eqPredX, cmpPred, eqKind, eqTyVarBndrs, + eqType, eqTypeX, eqTypes, cmpType, cmpTypes, cmpTypeX, cmpTypesX, cmpTc, + eqVarBndrs, -- * Forcing evaluation of types seqType, seqTypes, -- * Other views onto Types - coreView, + coreView, coreViewOneStarKind, UnaryType, RepType(..), flattenRepType, repType, tyConsOfType, @@ -110,50 +143,52 @@ module Type ( -- * Main type substitution data types TvSubstEnv, -- Representation widely visible - TvSubst(..), -- Representation visible to a few friends + TCvSubst(..), -- Representation visible to a few friends -- ** Manipulating type substitutions - emptyTvSubstEnv, emptyTvSubst, + emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, - mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, + mkTCvSubst, mkOpenTCvSubst, zipOpenTCvSubst, zipTopTCvSubst, mkTopTCvSubst, + notElemTCvSubst, getTvSubstEnv, setTvSubstEnv, - zapTvSubstEnv, getTvInScope, - extendTvInScope, extendTvInScopeList, - extendTvSubst, extendTvSubstList, - isInScope, composeTvSubst, zipTyEnv, - isEmptyTvSubst, unionTvSubst, + zapTCvSubst, getTCvInScope, + extendTCvInScope, extendTCvInScopeList, + extendTCvSubst, extendTCvSubstList, + isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, + isEmptyTCvSubst, unionTCvSubst, -- ** Performing substitution on types and kinds substTy, substTys, substTyWith, substTysWith, substTheta, - substTyVar, substTyVars, substTyVarBndr, - cloneTyVarBndr, cloneTyVarBndrs, deShadowTy, lookupTyVar, - substKiWith, substKisWith, + substTyVarBndr, substTyVar, substTyVars, + cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, substTelescope, -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, - pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType, + pprTvBndr, pprTvBndrs, pprForAll, pprForAllImplicit, pprUserForAll, + pprSigmaType, pprTheta, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprSourceTyCon, TyPrec(..), maybeParen, + pprTyVar, pprTcAppTy, pprPrefixApp, pprArrowChain, -- * Tidying type related things up for printing tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, tidyOpenKind, - tidyTyVarBndr, tidyTyVarBndrs, tidyFreeTyVars, - tidyOpenTyVar, tidyOpenTyVars, + tidyTyCoVarBndr, tidyTyCoVarBndrs, tidyFreeTyCoVars, + tidyOpenTyCoVar, tidyOpenTyCoVars, tidyTyVarOcc, tidyTopType, - tidyKind, + tidyKind ) where #include "HsVersions.h" --- We import the representation and primitive functions from TypeRep. +-- We import the representation and primitive functions from TyCoRep. -- Many things are reexported, but not the representation! import Kind -import TypeRep +import TyCoRep -- friends: import Var @@ -164,32 +199,31 @@ import NameEnv import Class import TyCon import TysPrim -import {-# SOURCE #-} TysWiredIn ( eqTyCon, listTyCon, coercibleTyCon, typeNatKind, typeSymbolKind ) -import PrelNames ( eqTyConKey, coercibleTyConKey, - ipTyConKey, openTypeKindTyConKey, - constraintKindTyConKey, liftedTypeKindTyConKey, - errorMessageTypeErrorFamName, - typeErrorTextDataConName, - typeErrorShowTypeDataConName, - typeErrorAppendDataConName, - typeErrorVAppendDataConName - ) +import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind + , typeSymbolKind, liftedTypeKind ) +import PrelNames import CoAxiom +import {-# SOURCE #-} Coercion -- others -import Unique ( Unique, hasKey ) -import UniqSupply ( UniqSupply, takeUniqFromSupply ) import BasicTypes ( Arity, RepArity ) import Util -import ListSetOps ( getNth ) import Outputable import FastString +import Pair +import ListSetOps +import Digraph import Maybes ( orElse ) -import Data.Maybe ( isJust ) +import Data.Maybe ( isJust, mapMaybe ) import Control.Monad ( guard ) +import Control.Arrow ( first, second ) -infixr 3 `mkFunTy` -- Associates to the right +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ( Applicative, (<*>), (<$>), pure ) +import Data.Monoid ( Monoid(..) ) +import Data.Foldable ( foldMap ) +#endif -- $type_classification -- #type_classification# @@ -263,30 +297,225 @@ coreView :: Type -> Maybe Type -- By being non-recursive and inlined, this case analysis gets efficiently -- joined onto the case analysis that the caller is already doing coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + = Just (mkAppTys (substTy (mkTopTCvSubst tenv) rhs) tys') -- Its important to use mkAppTys, rather than (foldl AppTy), -- because the function part might well return a -- partially-applied type constructor; indeed, usually will! coreView _ = Nothing +-- | Like 'coreView', but it also "expands" @Constraint@ to become +-- @TYPE Lifted@. +coreViewOneStarKind :: Type -> Maybe Type +coreViewOneStarKind = go Nothing + where + go _ t | Just t' <- coreView t = go (Just t') t' + go _ (TyConApp tc []) | isStarKindSynonymTyCon tc = go (Just t') t' + where t' = liftedTypeKind + go res _ = res + ----------------------------------------------- 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 ty - = go ty + = go (mkEmptyTCvSubst (mkTyCoInScopeSet [ty] [])) ty where - go (TyConApp tc tys) + go subst (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + = let subst' = unionTCvSubst subst (mkTopTCvSubst tenv) in + go subst' (mkAppTys rhs tys') | otherwise - = TyConApp tc (map go tys) - go (LitTy l) = LitTy l - go (TyVarTy tv) = TyVarTy tv - go (AppTy t1 t2) = mkAppTy (go t1) (go t2) - go (FunTy t1 t2) = FunTy (go t1) (go t2) - go (ForAllTy tv t) = ForAllTy tv (go t) + = TyConApp tc (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 (ForAllTy (Anon arg) res) + = mkFunTy (go subst arg) (go subst res) + go subst (ForAllTy (Named tv vis) t) + = let (subst', tv') = substTyVarBndrCallback go subst tv in + ForAllTy (Named 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_co subst (Refl r ty) + = mkReflCo r (go subst ty) + -- 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 (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 n co) + = mkNthCo 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 (CoherenceCo co1 co2) + = mkCoherenceCo (go_co subst co1) (go_co subst co2) + 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_prov _ UnsafeCoerceProv = UnsafeCoerceProv + 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 + go_prov _ (HoleProv h) = pprPanic "expandTypeSynonyms hit a hole" (ppr h) + + -- the "False" and "const" are to accommodate the type of + -- substForAllCoBndrCallback, which is general enough to + -- handle coercion optimization (which sometimes swaps the + -- order of a coercion) + go_cobndr subst = substForAllCoBndrCallback False (go_co subst) subst + +{- +************************************************************************ +* * + Analyzing types +* * +************************************************************************ + +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 TyCoRep, a ForAllCo is a bit redundant. +It stores a TyVar and a Coercion, where the kind of the TyVar 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 TyVar'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_smart :: Bool -- ^ Should the new type be created with smart + -- constructors? + , tcm_tyvar :: env -> TyVar -> m Type + , tcm_covar :: env -> CoVar -> m Coercion + , tcm_hole :: env -> CoercionHole -> Role + -> Type -> Type -> m Coercion + -- ^ What to do with coercion holes. See Note [Coercion holes] in + -- TyCoRep. + + , tcm_tybinder :: env -> TyVar -> VisibilityFlag -> m (env, TyVar) + -- ^ The returned env is used in the extended scope + } + +{-# INLINABLE mapType #-} -- See Note [Specialising mappers] +mapType :: (Applicative m, Monad m) => TyCoMapper env m -> env -> Type -> m Type +mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar + , tcm_tybinder = tybinder }) + env ty + = go ty + where + go (TyVarTy tv) = tyvar env tv + go (AppTy t1 t2) = mkappty <$> go t1 <*> go t2 + go (TyConApp tc tys) = mktyconapp tc <$> mapM go tys + go (ForAllTy (Anon arg) res) = mkfunty <$> go arg <*> go res + go (ForAllTy (Named tv vis) inner) + = do { (env', tv') <- tybinder env tv vis + ; inner' <- mapType mapper env' inner + ; return $ ForAllTy (Named tv' vis) inner' } + go ty@(LitTy {}) = return ty + go (CastTy ty co) = mkcastty <$> go ty <*> mapCoercion mapper env co + go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co + + (mktyconapp, mkappty, mkcastty, mkfunty) + | smart = (mkTyConApp, mkAppTy, mkCastTy, mkFunTy) + | otherwise = (TyConApp, AppTy, CastTy, ForAllTy . Anon) + +{-# INLINABLE mapCoercion #-} -- See Note [Specialising mappers] +mapCoercion :: (Applicative m, Monad m) + => TyCoMapper env m -> env -> Coercion -> m Coercion +mapCoercion mapper@(TyCoMapper { tcm_smart = smart, tcm_covar = covar + , tcm_hole = cohole, tcm_tybinder = tybinder }) + env co + = go co + where + go (Refl r ty) = Refl r <$> mapType mapper env ty + go (TyConAppCo r tc args) + = 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') <- tybinder env tv Invisible + ; co' <- mapCoercion mapper env' co + ; return $ mkforallco tv' kind_co' co' } + -- See Note [Efficiency for mapCoercion ForAllCo case] + go (CoVarCo cv) = covar env cv + go (AxiomInstCo ax i args) + = mkaxiominstco ax i <$> mapM go args + go (UnivCo (HoleProv hole) r t1 t2) + = cohole env hole r t1 t2 + 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 i co) = mknthco i <$> go co + go (LRCo lr co) = mklrco lr <$> go co + go (InstCo co arg) = mkinstco <$> go co <*> go arg + go (CoherenceCo c1 c2) = mkcoherenceco <$> go c1 <*> go c2 + go (KindCo co) = mkkindco <$> go co + go (SubCo co) = mksubco <$> go co + + go_prov UnsafeCoerceProv = return UnsafeCoerceProv + go_prov (PhantomProv co) = PhantomProv <$> go co + go_prov (ProofIrrelProv co) = ProofIrrelProv <$> go co + go_prov p@(PluginProv _) = return p + go_prov (HoleProv _) = panic "mapCoercion" + + ( mktyconappco, mkappco, mkaxiominstco, mkunivco + , mksymco, mktransco, mknthco, mklrco, mkinstco, mkcoherenceco + , mkkindco, mksubco, mkforallco) + | smart + = ( mkTyConAppCo, mkAppCo, mkAxiomInstCo, mkUnivCo + , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo, mkCoherenceCo + , mkKindCo, mkSubCo, mkForAllCo ) + | otherwise + = ( TyConAppCo, AppCo, AxiomInstCo, UnivCo + , SymCo, TransCo, NthCo, LRCo, InstCo, CoherenceCo + , KindCo, SubCo, ForAllCo ) {- ************************************************************************ @@ -314,8 +543,22 @@ 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' -getTyVar_maybe (TyVarTy tv) = Just tv -getTyVar_maybe _ = Nothing + | 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 ~R kind type +getCastedTyVar_maybe :: Type -> Maybe (TyVar, Coercion) +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 allDistinctTyVars :: [KindOrType] -> Bool allDistinctTyVars tkvs = go emptyVarSet tkvs @@ -354,6 +597,7 @@ 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 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@ @@ -387,15 +631,30 @@ splitAppTy_maybe ty = repSplitAppTy_maybe ty repSplitAppTy_maybe :: 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) - | isConstraintKind (typeKind ty1) = Nothing -- See Note [Decomposing fat arrow c=>t] - | otherwise = Just (TyConApp funTyCon [ty1], ty2) +repSplitAppTy_maybe (ForAllTy (Anon ty1) ty2) + = Just (TyConApp funTyCon [ty1], ty2) repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) repSplitAppTy_maybe (TyConApp tc tys) | mightBeUnsaturatedTyCon 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 braek 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 (ForAllTy (Anon ty1) ty2) + | isConstraintKind (typeKind ty1) = Nothing -- See Note [Decomposing fat arrow c=>t] + | otherwise = Just (TyConApp funTyCon [ty1], ty2) +tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +tcRepSplitAppTy_maybe (TyConApp tc tys) + | mightBeUnsaturatedTyCon 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', @@ -420,7 +679,7 @@ splitAppTys ty = split ty ty [] (tc_args1, tc_args2) = splitAt n tc_args in (TyConApp tc tc_args1, tc_args2 ++ args) - split _ (FunTy ty1 ty2) args = ASSERT( null args ) + split _ (ForAllTy (Anon ty1) ty2) args = ASSERT( null args ) (TyConApp funTyCon [], [ty1,ty2]) split orig_ty _ args = (orig_ty, args) @@ -490,14 +749,9 @@ pprUserTypeErrorTy ty = --------------------------------------------------------------------- FunTy ~~~~~ --} - -mkFunTy :: Type -> Type -> Type --- ^ Creates a function type from the given argument and result type -mkFunTy arg res = FunTy arg res -mkFunTys :: [Type] -> Type -> Type -mkFunTys tys ty = foldr mkFunTy ty tys +Function types are represented with (ForAllTy (Anon ...) ...) +-} isFunTy :: Type -> Bool isFunTy ty = isJust (splitFunTy_maybe ty) @@ -506,21 +760,21 @@ 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 (ForAllTy (Anon 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 +splitFunTy_maybe (ForAllTy (Anon 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) + split args _ (ForAllTy (Anon arg) res) = split (arg:args) res res + split args orig_ty _ = (reverse args, orig_ty) splitFunTysN :: Int -> Type -> ([Type], Type) -- ^ Split off exactly the given number argument types, and panics if that is not possible @@ -530,31 +784,27 @@ splitFunTysN n ty = ASSERT2( isFunTy ty, int n <+> ppr ty ) case splitFunTysN (n-1) res of { (args, res) -> (arg:args, res) }} --- | Splits off argument types from the given type and associating --- them with the things in the input list from left to right. The --- final result type is returned, along with the resulting pairs of --- objects and types, albeit with the list of pairs in reverse order. --- Panics if there are not enough argument types for the input list. -zipFunTys :: Outputable a => [a] -> Type -> ([(a, Type)], Type) -zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty - where - split acc [] nty _ = (reverse acc, nty) - split acc xs nty ty - | Just ty' <- coreView ty = split acc xs nty ty' - split acc (x:xs) _ (FunTy arg res) = split ((x,arg):acc) xs res res - split _ _ _ _ = pprPanic "zipFunTys" (ppr orig_xs <+> ppr 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 _arg res) = res -funResultTy ty = pprPanic "funResultTy" (ppr ty) +funResultTy ty = piResultTy ty (pprPanic "funResultTy" (ppr ty)) + +-- | Essentially 'funResultTy' on kinds handling pi-types too +piResultTy :: Type -> Type -> Type +piResultTy ty arg | Just ty' <- coreView ty = piResultTy ty' arg +piResultTy (ForAllTy (Anon _) res) _ = res +piResultTy (ForAllTy (Named tv _) res) arg = substTyWith [tv] [arg] res +piResultTy ty arg = pprPanic "piResultTy" + (ppr ty $$ ppr arg) + +-- | Fold 'piResultTy' over many types +piResultTys :: Type -> [Type] -> Type +piResultTys = foldl piResultTy 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 arg _res) = arg -funArgTy ty = pprPanic "funArgTy" (ppr ty) +funArgTy (ForAllTy (Anon arg) _res) = arg +funArgTy ty = pprPanic "funArgTy" (ppr ty) {- --------------------------------------------------------------------- @@ -567,7 +817,7 @@ funArgTy ty = pprPanic "funArgTy" (ppr ty) mkTyConApp :: TyCon -> [Type] -> Type mkTyConApp tycon tys | isFunTyCon tycon, [ty1,ty2] <- tys - = FunTy ty1 ty2 + = ForAllTy (Anon ty1) ty2 | otherwise = TyConApp tycon tys @@ -576,12 +826,20 @@ mkTyConApp tycon tys -- 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 (ForAllTy (Anon _) _) = 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_maybe (TyConApp tc _) = Just tc +tyConAppTyCon_maybe (ForAllTy (Anon _) _) = Just funTyCon +tyConAppTyCon_maybe _ = Nothing tyConAppTyCon :: Type -> TyCon tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) @@ -589,10 +847,9 @@ tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr -- | 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 [arg,res] -tyConAppArgs_maybe _ = Nothing - +tyConAppArgs_maybe (TyConApp _ tys) = Just tys +tyConAppArgs_maybe (ForAllTy (Anon arg) res) = Just [arg,res] +tyConAppArgs_maybe _ = Nothing tyConAppArgs :: Type -> [Type] tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) @@ -601,7 +858,7 @@ tyConAppArgN :: Int -> Type -> Type -- Executing Nth tyConAppArgN n ty = case tyConAppArgs_maybe ty of - Just tys -> ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n + Just tys -> ASSERT2( n < length tys, ppr n <+> ppr tys ) tys `getNth` n Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) -- | Attempts to tease a type apart into a type constructor and the application @@ -616,9 +873,14 @@ splitTyConApp ty = case splitTyConApp_maybe ty of -- of a number of arguments to that constructor splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' -splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) -splitTyConApp_maybe _ = Nothing +splitTyConApp_maybe ty = repSplitTyConApp_maybe ty + +-- | Like 'splitTyConApp_maybe', but doesn't look through synonyms. This +-- assumes the synonyms have already been dealt with. +repSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) +repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +repSplitTyConApp_maybe (ForAllTy (Anon arg) res) = Just (funTyCon, [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) @@ -641,14 +903,6 @@ nextRole ty | otherwise = Nominal -splitTyConArgs :: TyCon -> [KindOrType] -> ([Kind], [Type]) --- Given a tycon app (T k1 .. kn t1 .. tm), split the kind and type args --- TyCons always have prenex kinds -splitTyConArgs tc kts - = splitAtList kind_vars kts - where - (kind_vars, _) = splitForAllTys (tyConKind tc) - 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. @@ -661,6 +915,125 @@ newTyConInstRhs tycon tys {- --------------------------------------------------------------------- + CastTy + ~~~~~~ +A casted type has its *kind* casted into something new. + +Note [Weird typing rule for ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Here is the (truncated) typing rule for the dependent ForAllTy: + +inner : kind +------------------------------------ +ForAllTy (Named tv vis) inner : kind + +Note that neither the inner type nor for ForAllTy itself have to have +kind *! But, it means that we should push any kind casts through the +ForAllTy. The only trouble is avoiding capture. + +-} + +-- | Make a 'CastTy'. The Coercion must be nominal. +mkCastTy :: Type -> Coercion -> Type +-- Running example: +-- T :: forall k1. k1 -> forall k2. k2 -> Bool -> Maybe k1 -> * +-- co :: * ~R X (maybe X is a newtype around *) +-- ty = T Nat 3 Symbol "foo" True (Just 2) +-- +-- We wish to "push" the cast down as far as possible. See also +-- Note [Pushing down casts] in TyCoRep. Here is where we end +-- up: +-- +-- (T Nat 3 Symbol |> <Symbol> -> <Bool> -> <Maybe Nat> -> co) +-- "foo" True (Just 2) +-- +-- General approach: +-- +mkCastTy ty (Refl {}) = ty +mkCastTy (CastTy ty co1) co2 = mkCastTy ty (co1 `mkTransCo` co2) +-- See Note [Weird typing rule for ForAllTy] +mkCastTy (ForAllTy (Named tv vis) inner_ty) co + = -- have to make sure that pushing the co in doesn't capture the bound var + let fvs = tyCoVarsOfCo co + empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) + (subst, tv') = substTyVarBndr empty_subst tv + in + ForAllTy (Named tv' vis) (substTy subst inner_ty `mkCastTy` co) +mkCastTy ty co = -- NB: don't check if the coercion "from" type matches here; + -- there may be unzonked variables about + let result = split_apps [] ty co in + ASSERT2( CastTy ty co `eqType` result + , ppr ty <+> dcolon <+> ppr (typeKind ty) $$ + ppr co <+> dcolon <+> ppr (coercionKind co) $$ + ppr result <+> dcolon <+> ppr (typeKind result) ) + result + where + -- split_apps breaks apart any type applications, so we can see how far down + -- to push the cast + split_apps args (AppTy t1 t2) co + = split_apps (t2:args) t1 co + split_apps args (TyConApp tc tc_args) co + | mightBeUnsaturatedTyCon tc + = affix_co (tyConKind tc) (mkTyConTy tc) (tc_args `chkAppend` args) co + | otherwise -- not decomposable... but it may still be oversaturated + = let (non_decomp_args, decomp_args) = splitAt (tyConArity tc) tc_args + saturated_tc = mkTyConApp tc non_decomp_args + in + affix_co (typeKind saturated_tc) saturated_tc (decomp_args `chkAppend` args) co + + split_apps args (ForAllTy (Anon arg) res) co + = affix_co (tyConKind funTyCon) (mkTyConTy funTyCon) + (arg : res : args) co + split_apps args ty co + = affix_co (typeKind ty) ty args co + + -- having broken everything apart, this figures out the point at which there + -- are no more dependent quantifications, and puts the cast there + affix_co _ ty [] co = no_double_casts ty co + affix_co kind ty args co + -- if kind contains any dependent quantifications, we can't push. + -- apply arguments until it doesn't + = let (bndrs, _inner_ki) = splitPiTys kind + (no_dep_bndrs, some_dep_bndrs) = spanEnd isAnonBinder bndrs + (some_dep_args, rest_args) = splitAtList some_dep_bndrs args + dep_subst = zipOpenTCvSubstBinders some_dep_bndrs some_dep_args + used_no_dep_bndrs = takeList rest_args no_dep_bndrs + rest_arg_tys = substTys dep_subst (map binderType used_no_dep_bndrs) + co' = mkFunCos Nominal + (map (mkReflCo Nominal) rest_arg_tys) + co + in + ((ty `mkAppTys` some_dep_args) `no_double_casts` co') `mkAppTys` rest_args + + no_double_casts (CastTy ty co1) co2 = CastTy ty (co1 `mkTransCo` co2) + no_double_casts ty co = CastTy ty co + +{- +-------------------------------------------------------------------- + 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 ~~~~~ @@ -699,6 +1072,10 @@ type UnaryType = Type data RepType = UbxTupleRep [UnaryType] -- INVARIANT: never an empty list (see Note [Nullary unboxed tuple]) | UnaryRep UnaryType +instance Outputable RepType where + ppr (UbxTupleRep tys) = ptext (sLit "UbxTupleRep") <+> ppr tys + ppr (UnaryRep ty) = ptext (sLit "UnaryRep") <+> ppr ty + flattenRepType :: RepType -> [UnaryType] flattenRepType (UbxTupleRep tys) = tys flattenRepType (UnaryRep ty) = [ty] @@ -709,6 +1086,7 @@ flattenRepType (UnaryRep ty) = [ty] -- 2. Synonyms -- 3. Predicates -- 4. All newtypes, including recursive ones, but not newtype families +-- 5. Casts -- -- It's useful in the back end of the compiler. repType :: Type -> RepType @@ -720,8 +1098,8 @@ repType ty | Just ty' <- coreView ty = go rec_nts ty' - go rec_nts (ForAllTy _ ty) -- Drop foralls - = go rec_nts ty + go rec_nts (ForAllTy (Named {}) ty2) -- Drop type foralls + = go rec_nts ty2 go rec_nts (TyConApp tc tys) -- Expand newtypes | isNewTyCon tc @@ -732,29 +1110,18 @@ repType ty | isUnboxedTupleTyCon tc = if null tys then UnaryRep voidPrimTy -- See Note [Nullary unboxed tuple] - else UbxTupleRep (concatMap (flattenRepType . go rec_nts) tys) + else UbxTupleRep (concatMap (flattenRepType . go rec_nts) non_levity_tys) + where + -- See Note [Unboxed tuple levity vars] in TyCon + non_levity_tys = drop (length tys `div` 2) tys - go _ ty = UnaryRep ty + go rec_nts (CastTy ty _) + = go rec_nts ty + go _ ty@(CoercionTy _) + = pprPanic "repType" (ppr ty) --- | 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 -> NameEnv TyCon -tyConsOfType ty - = go ty - where - go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim - go ty | Just ty' <- coreView ty = go ty' - go (TyVarTy {}) = emptyNameEnv - go (LitTy {}) = emptyNameEnv - go (TyConApp tc tys) = go_tc tc tys - go (AppTy a b) = go a `plusNameEnv` go b - go (FunTy a b) = go a `plusNameEnv` go b - go (ForAllTy _ ty) = go ty - - go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc - go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys + go _ ty = UnaryRep ty -- ToDo: this could be moved to the code generator, using splitTyConApp instead -- of inspecting the type directly. @@ -764,18 +1131,19 @@ typePrimRep :: UnaryType -> PrimRep typePrimRep ty = case repType ty of UbxTupleRep _ -> pprPanic "typePrimRep: UbxTupleRep" (ppr ty) - UnaryRep rep -> case rep of - TyConApp tc _ -> tyConPrimRep tc - FunTy _ _ -> PtrRep - AppTy _ _ -> PtrRep -- See Note [AppTy rep] - TyVarTy _ -> PtrRep - _ -> pprPanic "typePrimRep: UnaryRep" (ppr ty) + UnaryRep rep -> go rep + where go (TyConApp tc _) = tyConPrimRep tc + go (ForAllTy _ _) = PtrRep + go (AppTy _ _) = PtrRep -- See Note [AppTy rep] + go (TyVarTy _) = PtrRep + go (CastTy ty _) = go ty + go _ = pprPanic "typePrimRep: UnaryRep" (ppr ty) typeRepArity :: Arity -> Type -> RepArity typeRepArity 0 _ = 0 typeRepArity n ty = case repType ty of - UnaryRep (FunTy ty1 ty2) -> length (flattenRepType (repType ty1)) + typeRepArity (n - 1) ty2 - _ -> pprPanic "typeRepArity: arity greater than type can handle" (ppr (n, ty)) + UnaryRep (ForAllTy bndr ty) -> length (flattenRepType (repType (binderType bndr))) + typeRepArity (n - 1) ty + _ -> pprPanic "typeRepArity: arity greater than type can handle" (ppr (n, ty, repType ty)) isVoidTy :: Type -> Bool -- True if the type has zero width @@ -789,86 +1157,201 @@ Note [AppTy rep] Types of the form 'f a' must be of kind *, not #, so we are guaranteed that they are represented by pointers. The reason is that f must have kind (kk -> kk) and kk cannot be unlifted; see Note [The kind invariant] -in TypeRep. +in TyCoRep. --------------------------------------------------------------------- ForAllTy ~~~~~~~~ -} -mkForAllTy :: TyVar -> Type -> Type -mkForAllTy tyvar ty - = ForAllTy tyvar ty +mkForAllTy :: TyBinder -> Type -> Type +mkForAllTy = ForAllTy + +-- | Make a dependent forall. +mkNamedForAllTy :: TyVar -> VisibilityFlag -> Type -> Type +mkNamedForAllTy tv vis = ASSERT( isTyVar tv ) + ForAllTy (Named tv vis) -- | Wraps foralls over the type using the provided 'TyVar's from left to right -mkForAllTys :: [TyVar] -> Type -> Type +mkForAllTys :: [TyBinder] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars -mkPiKinds :: [TyVar] -> Kind -> Kind --- mkPiKinds [k1, k2, (a:k1 -> *)] k2 --- returns forall k1 k2. (k1 -> *) -> k2 -mkPiKinds [] res = res -mkPiKinds (tv:tvs) res - | isKindVar tv = ForAllTy tv (mkPiKinds tvs res) - | otherwise = FunTy (tyVarKind tv) (mkPiKinds tvs res) +-- | Like mkForAllTys, but assumes all variables are dependent and invisible, +-- a common case +mkInvForAllTys :: [TyVar] -> Type -> Type +mkInvForAllTys tvs = ASSERT( all isTyVar tvs ) + mkForAllTys (map (flip Named Invisible) tvs) + +-- | Like mkForAllTys, but assumes all variables are dependent and visible +mkVisForAllTys :: [TyVar] -> Type -> Type +mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) + mkForAllTys (map (flip Named Visible) tvs) mkPiType :: Var -> Type -> Type --- ^ Makes a @(->)@ type or a forall type, depending +-- ^ 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. mkPiTypes :: [Var] -> Type -> Type -- ^ 'mkPiType' for multiple type or value arguments mkPiType v ty - | isId v = mkFunTy (varType v) ty - | otherwise = mkForAllTy v ty + | isTyVar v = mkForAllTy (Named v Invisible) ty + | otherwise = mkForAllTy (Anon (varType v)) ty mkPiTypes vs ty = foldr mkPiType ty vs -isForAllTy :: Type -> Bool -isForAllTy (ForAllTy _ _) = True -isForAllTy _ = False +-- | Given a list of type-level vars, makes ForAllTys, preferring +-- anonymous binders if the variable is, in fact, not dependent. +-- All binders are /visible/. +mkPiTypesPreferFunTy :: [TyVar] -> Type -> Type +mkPiTypesPreferFunTy vars inner_ty = fst $ go vars inner_ty + where + go :: [TyVar] -> Type -> (Type, VarSet) -- also returns the free vars + go [] ty = (ty, tyCoVarsOfType ty) + go (v:vs) ty + = if v `elemVarSet` fvs + then ( mkForAllTy (Named v Visible) qty + , fvs `delVarSet` v `unionVarSet` kind_vars ) + else ( mkForAllTy (Anon (tyVarKind v)) qty + , fvs `unionVarSet` kind_vars ) + where + (qty, fvs) = go vs ty + kind_vars = tyCoVarsOfType $ tyVarKind v + +-- | Take a ForAllTy apart, returning the list of tyvars 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 -> ([TyVar], Type) +splitForAllTys ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy (Named tv _) ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Split off all TyBinders to a type, splitting both proper foralls +-- and functions +splitPiTys :: Type -> ([TyBinder], 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 (b:bs) + split orig_ty _ bs = (reverse bs, orig_ty) + +-- | Like 'splitPiTys' but split off only /named/ binders. +splitNamedPiTys :: Type -> ([TyBinder], Type) +splitNamedPiTys ty = split ty ty [] + where + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b@(Named {}) res) bs = split res res (b:bs) + split orig_ty _ bs = (reverse bs, orig_ty) --- | Attempts to take a forall type apart, returning the bound type variable --- and the remainder of the type +-- | Checks whether this is a proper forall (with a named binder) +isForAllTy :: Type -> Bool +isForAllTy (ForAllTy (Named {}) _) = True +isForAllTy _ = False + +-- | Is this a function or forall? +isPiTy :: Type -> Bool +isPiTy (ForAllTy {}) = True +isPiTy _ = False + +-- | Take a forall type apart, or panics if that is not possible. +splitForAllTy :: Type -> (TyVar, Type) +splitForAllTy ty + | Just answer <- splitForAllTy_maybe ty = answer + | otherwise = pprPanic "splitForAllTy" (ppr ty) + +-- | Attempts to take a forall type apart, but only if it's a proper forall, +-- with a named binder splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) splitForAllTy_maybe ty = splitFAT_m ty where splitFAT_m ty | Just ty' <- coreView ty = splitFAT_m ty' - splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) - splitFAT_m _ = Nothing + splitFAT_m (ForAllTy (Named tv _) ty) = Just (tv, ty) + splitFAT_m _ = Nothing --- | Attempts to take a forall type apart, returning all the immediate such bound --- type variables and the remainder of the type. Always succeeds, even if that means --- returning an empty list of 'TyVar's -splitForAllTys :: Type -> ([TyVar], Type) -splitForAllTys ty = split ty ty [] - where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) +-- | Attempts to take a forall type apart; works with proper foralls and +-- functions +splitPiTy_maybe :: Type -> Maybe (TyBinder, Type) +splitPiTy_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy bndr ty) = Just (bndr, ty) + go _ = Nothing + +-- | Takes a forall type apart, or panics +splitPiTy :: Type -> (TyBinder, Type) +splitPiTy ty + | Just answer <- splitPiTy_maybe ty = answer + | otherwise = pprPanic "splitPiTy" (ppr ty) --- | Equivalent to @snd . splitForAllTys@ +-- | Drops all non-anonymous ForAllTys dropForAlls :: Type -> Type -dropForAlls ty = snd (splitForAllTys ty) +dropForAlls ty | Just ty' <- coreView ty = dropForAlls ty' + | otherwise = go ty + where + go (ForAllTy (Named {}) res) = go res + go res = res -{- --- (mkPiType now in CoreUtils) +-- | Given a tycon and its arguments, filters out any invisible arguments +filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] +filterOutInvisibleTypes tc tys = snd $ partitionInvisibles tc id tys -applyTy, applyTys -~~~~~~~~~~~~~~~~~ --} +-- | Like 'filterOutInvisibles', but works on 'TyVar's +filterOutInvisibleTyVars :: TyCon -> [TyVar] -> [TyVar] +filterOutInvisibleTyVars tc tvs = snd $ partitionInvisibles tc mkTyVarTy tvs --- | Instantiate a forall type with one or more type arguments. --- Used when we have a polymorphic function applied to type args: +-- | Given a tycon and a list of things (which correspond to arguments), +-- partitions the things into the invisible ones and the visible ones. +-- The callback function is necessary for this scenario: +-- +-- > T :: forall k. k -> k +-- > partitionInvisibles T [forall m. m -> m -> m, S, R, Q] +-- +-- After substituting, we get -- --- > f t1 t2 +-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n -- --- We use @applyTys type-of-f [t1,t2]@ to compute the type of the expression. --- Panics if no application is possible. -applyTy :: Type -> KindOrType -> Type -applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg -applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty -applyTy _ _ = panic "applyTy" +-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, +-- and @Q@ is visible. +-- +-- If you're absolutely sure that your tycon's kind doesn't end in a variable, +-- it's OK if the callback function panics, as that's the only time it's +-- consulted. +partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a]) +partitionInvisibles tc get_ty = go emptyTCvSubst (tyConKind tc) + where + go _ _ [] = ([], []) + go subst (ForAllTy bndr res_ki) (x:xs) + | isVisibleBinder bndr = second (x :) (go subst' res_ki xs) + | otherwise = first (x :) (go subst' res_ki xs) + where + subst' = extendTCvSubstBinder subst bndr (get_ty x) + go subst (TyVarTy tv) xs + | Just ki <- lookupTyVar subst tv = go subst ki xs + go _ _ xs = ([], xs) -- something is ill-kinded. But this can happen + -- when printing errors. Assume everything is visible. + +-- like splitPiTys, but returns only *invisible* binders, including constraints +splitPiTysInvisible :: Type -> ([TyBinder], Type) +splitPiTysInvisible ty = split ty ty [] + where + split orig_ty ty bndrs + | Just ty' <- coreView ty = split orig_ty ty' bndrs + split _ (ForAllTy bndr ty) bndrs + | isInvisibleBinder bndr + = split ty ty (bndr:bndrs) + + split orig_ty _ bndrs + = (reverse bndrs, orig_ty) + +tyConBinders :: TyCon -> [TyBinder] +tyConBinders = fst . splitPiTys . tyConKind + +{- +applyTys +~~~~~~~~~~~~~~~~~ +-} applyTys :: Type -> [KindOrType] -> Type -- ^ This function is interesting because: @@ -895,19 +1378,19 @@ applyTys ty args = applyTysD empty ty args applyTysD :: SDoc -> Type -> [Type] -> Type -- Debug version applyTysD _ orig_fun_ty [] = orig_fun_ty applyTysD doc orig_fun_ty arg_tys - | n_tvs == n_args -- The vastly common case - = substTyWith tvs arg_tys rho_ty - | n_tvs > n_args -- Too many for-alls - = substTyWith (take n_args tvs) arg_tys - (mkForAllTys (drop n_args tvs) rho_ty) + | n_bndrs == n_args -- The vastly common case + = substTyWithBinders bndrs arg_tys rho_ty + | n_bndrs > n_args -- Too many for-alls + = substTyWithBinders (take n_args bndrs) arg_tys + (mkForAllTys (drop n_args bndrs) rho_ty) | otherwise -- Too many type args - = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty $$ ppr arg_tys ) -- Zero case gives infinite loop! - applyTysD doc (substTyWith tvs (take n_tvs arg_tys) rho_ty) - (drop n_tvs arg_tys) + = ASSERT2( n_bndrs > 0, doc $$ ppr orig_fun_ty $$ ppr arg_tys ) -- Zero case gives infinite loop! + applyTysD doc (substTyWithBinders bndrs (take n_bndrs arg_tys) rho_ty) + (drop n_bndrs arg_tys) where - (tvs, rho_ty) = splitForAllTys orig_fun_ty - n_tvs = length tvs - n_args = length arg_tys + (bndrs, rho_ty) = splitPiTys orig_fun_ty + n_bndrs = length bndrs + n_args = length arg_tys applyTysX :: [TyVar] -> Type -> [Type] -> Type -- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys @@ -919,8 +1402,96 @@ applyTysX tvs body_ty arg_tys n_tvs = length tvs {- -************************************************************************ -* * +%************************************************************************ +%* * + TyBinders +%* * +%************************************************************************ +-} + +-- | Make a named binder +mkNamedBinder :: Var -> VisibilityFlag -> TyBinder +mkNamedBinder = Named + +-- | Make an anonymous binder +mkAnonBinder :: Type -> TyBinder +mkAnonBinder = Anon + +isNamedBinder :: TyBinder -> Bool +isNamedBinder (Named {}) = True +isNamedBinder _ = False + +isAnonBinder :: TyBinder -> Bool +isAnonBinder (Anon {}) = True +isAnonBinder _ = False + +-- | Does this binder bind a variable that is /not/ erased? Returns +-- 'True' for anonymous binders. +isIdLikeBinder :: TyBinder -> Bool +isIdLikeBinder (Named {}) = False +isIdLikeBinder (Anon {}) = True + +-- | Does this type, when used to the left of an arrow, require +-- a visible argument? This checks to see if the kind of the type +-- is constraint. +isVisibleType :: Type -> Bool +isVisibleType = not . isPredTy + +binderVisibility :: TyBinder -> VisibilityFlag +binderVisibility (Named _ vis) = vis +binderVisibility (Anon ty) + | isVisibleType ty = Visible + | otherwise = Invisible + +-- | Does this binder bind an invisible argument? +isInvisibleBinder :: TyBinder -> Bool +isInvisibleBinder (Named _ vis) = vis == Invisible +isInvisibleBinder (Anon ty) = isPredTy ty + +-- | Does this binder bind a visible argument? +isVisibleBinder :: TyBinder -> Bool +isVisibleBinder = not . isInvisibleBinder + +-- | Extract a bound variable in a binder, if any +binderVar_maybe :: TyBinder -> Maybe Var +binderVar_maybe (Named v _) = Just v +binderVar_maybe (Anon {}) = Nothing + +-- | Extract a bound variable in a binder, or panics +binderVar :: String -- ^ printed if there is a panic + -> TyBinder -> Var +binderVar _ (Named v _) = v +binderVar e (Anon t) = pprPanic ("binderVar (" ++ e ++ ")") (ppr t) + +-- | Extract a relevant type, if there is one. +binderRelevantType_maybe :: TyBinder -> Maybe Type +binderRelevantType_maybe (Named {}) = Nothing +binderRelevantType_maybe (Anon ty) = Just ty + +-- | Like 'maybe', but for binders. +caseBinder :: TyBinder -- ^ binder to scrutinize + -> (TyVar -> a) -- ^ named case + -> (Type -> a) -- ^ anonymous case + -> a +caseBinder (Named v _) f _ = f v +caseBinder (Anon t) _ d = d t + +-- | Break apart a list of binders into tyvars and anonymous types. +partitionBinders :: [TyBinder] -> ([TyVar], [Type]) +partitionBinders = partitionWith named_or_anon + where + named_or_anon bndr = caseBinder bndr Left Right + +-- | Break apart a list of binders into a list of named binders and +-- a list of anonymous types. +partitionBindersIntoBinders :: [TyBinder] -> ([TyBinder], [Type]) +partitionBindersIntoBinders = partitionWith named_or_anon + where + named_or_anon bndr = caseBinder bndr (\_ -> Left bndr) Right + +{- +%************************************************************************ +%* * Pred * * ************************************************************************ @@ -928,33 +1499,50 @@ applyTysX tvs body_ty arg_tys Predicates on PredType -} +-- | Is the type suitable to classify a given/wanted in the typechecker? isPredTy :: Type -> Bool -- NB: isPredTy is used when printing types, which can happen in debug printing -- during type checking of not-fully-zonked types. So it's not cool to say -- isConstraintKind (typeKind ty) because absent zonking the type might -- be ill-kinded, and typeKind crashes -- Hence the rather tiresome story here + -- + -- NB: This must return "True" to *unlifted* coercions, which are not + -- of kind Constraint! isPredTy ty = go ty [] where go :: Type -> [KindOrType] -> Bool go (AppTy ty1 ty2) args = go ty1 (ty2 : args) - go (TyConApp tc tys) args = go_k (tyConKind tc) (tys ++ args) + go (TyConApp tc tys) args + | tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + , [_,_,_,_] <- all_args + = True + + | otherwise + = go_k (tyConKind tc) all_args + where + all_args = tys ++ args go (TyVarTy tv) args = go_k (tyVarKind tv) args go _ _ = False go_k :: Kind -> [KindOrType] -> Bool -- True <=> kind is k1 -> .. -> kn -> Constraint - go_k k [] = isConstraintKind k - go_k (FunTy _ k1) (_ :args) = go_k k1 args - go_k (ForAllTy kv k1) (k2:args) = go_k (substKiWith [kv] [k2] k1) args + go_k k [] = isConstraintKind k + go_k (ForAllTy bndr k1) (arg:args) + = go_k (substTyWithBinders [bndr] [arg] k1) args go_k _ _ = False -- Typeable * Int :: Constraint -isClassPred, isEqPred, isIPPred :: PredType -> Bool +isClassPred, isEqPred, isNomEqPred, isIPPred :: PredType -> Bool isClassPred ty = case tyConAppTyCon_maybe ty of Just tyCon | isClassTyCon tyCon -> True _ -> False isEqPred ty = case tyConAppTyCon_maybe ty of - Just tyCon -> tyCon `hasKey` eqTyConKey + Just tyCon -> tyCon `hasKey` eqPrimTyConKey + || tyCon `hasKey` eqReprPrimTyConKey + _ -> False + +isNomEqPred ty = case tyConAppTyCon_maybe ty of + Just tyCon -> tyCon `hasKey` eqPrimTyConKey _ -> False isIPPred ty = case tyConAppTyCon_maybe ty of @@ -984,34 +1572,49 @@ Make PredTypes --------------------- Equality types --------------------------------- -} --- | Creates a type equality predicate -mkEqPred :: Type -> Type -> PredType -mkEqPred ty1 ty2 - = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 $$ ppr k $$ ppr (typeKind ty2) ) - TyConApp eqTyCon [k, ty1, ty2] - where - k = typeKind ty1 - -mkCoerciblePred :: Type -> Type -> PredType -mkCoerciblePred ty1 ty2 - = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 $$ ppr k $$ ppr (typeKind ty2) ) - TyConApp coercibleTyCon [k, ty1, ty2] - where - k = typeKind ty1 +-- | 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. +-- Invariant: the types are not Coercions mkPrimEqPred :: Type -> Type -> Type -mkPrimEqPred ty1 ty2 - = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) - TyConApp eqPrimTyCon [k, ty1, ty2] +mkPrimEqPred ty1 ty2 + = TyConApp eqPrimTyCon [k1, k2, ty1, ty2] where - k = typeKind ty1 + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Creates a primite type equality predicate with explicit kinds +mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type +mkHeteroPrimEqPred k1 k2 ty1 ty2 = TyConApp 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 + = TyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] + +-- | Try to split up a coercion type into the types that it coerces +splitCoercionType_maybe :: Type -> Maybe (Type, Type) +splitCoercionType_maybe ty + = do { (tc, [_, _, ty1, ty2]) <- splitTyConApp_maybe ty + ; guard $ tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + ; return (ty1, ty2) } mkReprPrimEqPred :: Type -> Type -> Type mkReprPrimEqPred ty1 ty2 - = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) - TyConApp eqReprPrimTyCon [k, ty1, ty2] + = TyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] where - k = typeKind ty1 + k1 = typeKind ty1 + k2 = typeKind ty2 + +equalityTyCon :: Role -> TyCon +equalityTyCon Nominal = eqPrimTyCon +equalityTyCon Representational = eqReprPrimTyCon +equalityTyCon Phantom = eqPhantPrimTyCon -- --------------------- Dictionary types --------------------------------- @@ -1082,17 +1685,12 @@ data PredTree = ClassPred Class [Type] classifyPredType :: PredType -> PredTree classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of - Just (tc, tys) | tc `hasKey` coercibleTyConKey - , let [_, ty1, ty2] = tys - -> EqPred ReprEq ty1 ty2 - Just (tc, tys) | tc `hasKey` eqTyConKey - , let [_, ty1, ty2] = tys - -> EqPred NomEq ty1 ty2 - -- NB: Coercible is also a class, so this check must come *after* - -- the Coercible check - Just (tc, tys) | Just clas <- tyConClass_maybe tc - -> ClassPred clas tys - _ -> IrredPred ev_ty + 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 + _ -> IrredPred ev_ty getClassPredTys :: PredType -> (Class, [Type]) getClassPredTys ty = case getClassPredTys_maybe ty of @@ -1107,33 +1705,28 @@ getClassPredTys_maybe ty = case splitTyConApp_maybe ty of getEqPredTys :: PredType -> (Type, Type) getEqPredTys ty = case splitTyConApp_maybe ty of - Just (tc, (_ : ty1 : ty2 : tys)) -> - ASSERT( null tys && (tc `hasKey` eqTyConKey - || tc `hasKey` coercibleTyConKey) ) - (ty1, ty2) + 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` eqTyConKey -> Just (Nominal, ty1, ty2) - | tc `hasKey` coercibleTyConKey -> Just (Representational, ty1, ty2) + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqPrimTyConKey -> Just (Nominal, ty1, ty2) + | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2) _ -> Nothing getEqPredRole :: PredType -> Role -getEqPredRole ty - = case splitTyConApp_maybe ty of - Just (tc, [_, _, _]) - | tc `hasKey` eqTyConKey -> Nominal - | tc `hasKey` coercibleTyConKey -> Representational - _ -> pprPanic "getEqPredRole" (ppr ty) +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` coercibleTyConKey + , tc `hasKey` eqReprPrimTyConKey = ReprEq | otherwise = NomEq @@ -1146,13 +1739,49 @@ predTypeEqRel ty ************************************************************************ -} +-- NB: This function 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 _ t) = 1 + typeSize t -typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) +typeSize (LitTy {}) = 1 +typeSize (TyVarTy {}) = 1 +typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (ForAllTy b t) = typeSize (binderType b) + typeSize t +typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) +typeSize (CastTy ty co) = typeSize ty + coercionSize co +typeSize (CoercionTy co) = coercionSize co + +{- +%************************************************************************ +%* * + Well-scoped tyvars +* * +************************************************************************ +-} + +-- | Do a topological sort on a list of tyvars. This is a deterministic +-- sorting operation (that is, doesn't depend on Uniques). +toposortTyVars :: [TyVar] -> [TyVar] +toposortTyVars tvs = reverse $ + [ tv | (tv, _, _) <- topologicalSortG $ + graphFromEdgedVertices nodes ] + where + var_ids :: VarEnv Int + var_ids = mkVarEnv (zip tvs [1..]) + + nodes = [ ( tv + , lookupVarEnv_NF var_ids tv + , mapMaybe (lookupVarEnv var_ids) + (tyCoVarsOfTypeList (tyVarKind tv)) ) + | tv <- tvs ] + +-- | Extract a well-scoped list of variables from a set of variables. +varSetElemsWellScoped :: VarSet -> [Var] +varSetElemsWellScoped = toposortTyVars . varSetElems + +-- | Get the free vars of a type in scoped order +tyCoVarsOfTypeWellScoped :: Type -> [TyVar] +tyCoVarsOfTypeWellScoped = toposortTyVars . tyCoVarsOfTypeList {- ************************************************************************ @@ -1176,7 +1805,7 @@ mkFamilyTyConApp tc tys | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc , let tvs = tyConTyVars tc fam_subst = ASSERT2( length tvs == length tys, ppr tc <+> ppr tys ) - zipTopTvSubst tvs tys + zipTopTCvSubst tvs tys = mkTyConApp fam_tc (substTys fam_subst fam_tys) | otherwise = mkTyConApp tc tys @@ -1217,9 +1846,29 @@ isUnLiftedType :: Type -> Bool -- construct them isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty' -isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty -isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc -isUnLiftedType _ = False +isUnLiftedType (ForAllTy (Named {}) ty) = isUnLiftedType ty +isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc +isUnLiftedType _ = False + +-- | Extract the levity classifier of a type. Panics if this is not possible. +getLevity :: String -- ^ Printed in case of an error + -> Type -> Type +getLevity err ty = getLevityFromKind err (typeKind ty) + +-- | Extract the levity classifier of a type from its kind. +-- For example, getLevityFromKind * = Lifted; getLevityFromKind # = Unlifted. +-- Panics if this is not possible. +getLevityFromKind :: String -- ^ Printed in case of an error + -> Type -> Type +getLevityFromKind err = go + where + go k | Just k' <- coreViewOneStarKind k = go k' + go k + | Just (tc, [arg]) <- splitTyConApp_maybe k + , tc `hasKey` tYPETyConKey + = arg + go k = pprPanic "getLevity" (text err $$ + ppr k <+> dcolon <+> ppr (typeKind k)) isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = case tyConAppTyCon_maybe ty of @@ -1270,12 +1919,13 @@ isPrimitiveType ty = case splitTyConApp_maybe ty of -} 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 tv ty) = seqType (tyVarKind tv) `seq` seqType ty +seqType (LitTy n) = n `seq` () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy bndr ty) = seqType (binderType bndr) `seq` seqType ty +seqType (CastTy ty co) = seqType ty `seq` seqCo co +seqType (CoercionTy co) = seqCo co seqTypes :: [Type] -> () seqTypes [] = () @@ -1288,101 +1938,113 @@ seqTypes (ty:tys) = seqType ty `seq` seqTypes tys (We don't use instances so that we know where it happens) * * ************************************************************************ --} -eqKind :: Kind -> Kind -> Bool --- Watch out for horrible hack: See Note [Comparison with OpenTypeKind] -eqKind = eqType +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. --- Watch out for horrible hack: See Note [Comparison with OpenTypeKind] +-- 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 TyCoRep. eqType t1 t2 = isEqual $ cmpType t1 t2 -instance Eq Type where - (==) = eqType - +-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. eqTypeX :: RnEnv2 -> Type -> Type -> Bool eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 +-- | Type equality on lists of types, looking through type synonyms +-- but not newtypes. eqTypes :: [Type] -> [Type] -> Bool eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 -eqPred :: PredType -> PredType -> Bool -eqPred = eqType - -eqPredX :: RnEnv2 -> PredType -> PredType -> Bool -eqPredX env p1 p2 = isEqual $ cmpTypeX env p1 p2 - -eqTyVarBndrs :: RnEnv2 -> [TyVar] -> [TyVar] -> Maybe RnEnv2 --- Check that the tyvar lists are the same length +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 -eqTyVarBndrs env [] [] +eqVarBndrs env [] [] = Just env -eqTyVarBndrs env (tv1:tvs1) (tv2:tvs2) +eqVarBndrs env (tv1:tvs1) (tv2:tvs2) | eqTypeX env (tyVarKind tv1) (tyVarKind tv2) - = eqTyVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 -eqTyVarBndrs _ _ _= Nothing + = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 +eqVarBndrs _ _ _= Nothing -- Now here comes the real worker cmpType :: Type -> Type -> Ordering --- Watch out for horrible hack: See Note [Comparison with OpenTypeKind] -cmpType t1 t2 = cmpTypeX rn_env t1 t2 +cmpType t1 t2 + -- we know k1 and k2 have the same kind, because they both have kind *. + = cmpTypeX rn_env t1 t2 where - rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2)) + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) cmpTypes :: [Type] -> [Type] -> Ordering cmpTypes ts1 ts2 = cmpTypesX rn_env ts1 ts2 where - rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2)) - -cmpPred :: PredType -> PredType -> Ordering -cmpPred p1 p2 = cmpTypeX rn_env p1 p2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType p1 `unionVarSet` tyVarsOfType p2)) + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse -cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2 - | Just t2' <- coreView t2 = cmpTypeX env t1 t2' --- We expand predicate types, because in Core-land we have --- lots of definitions like --- fOrdBool :: Ord Bool --- fOrdBool = D:Ord .. .. .. --- So the RHS has a data type - -cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` rnOccR env tv2 -cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX env (tyVarKind tv1) (tyVarKind tv2) - `thenCmp` cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 -cmpTypeX env (AppTy s1 t1) (AppTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 -cmpTypeX env (FunTy s1 t1) (FunTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 -cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `cmpTc` tc2) `thenCmp` cmpTypesX env tys1 tys2 -cmpTypeX _ (LitTy l1) (LitTy l2) = compare l1 l2 - - -- Deal with the rest: TyVarTy < AppTy < FunTy < LitTy < TyConApp < ForAllTy < PredTy -cmpTypeX _ (AppTy _ _) (TyVarTy _) = GT - -cmpTypeX _ (FunTy _ _) (TyVarTy _) = GT -cmpTypeX _ (FunTy _ _) (AppTy _ _) = GT - -cmpTypeX _ (LitTy _) (TyVarTy _) = GT -cmpTypeX _ (LitTy _) (AppTy _ _) = GT -cmpTypeX _ (LitTy _) (FunTy _ _) = GT - -cmpTypeX _ (TyConApp _ _) (TyVarTy _) = GT -cmpTypeX _ (TyConApp _ _) (AppTy _ _) = GT -cmpTypeX _ (TyConApp _ _) (FunTy _ _) = GT -cmpTypeX _ (TyConApp _ _) (LitTy _) = GT - -cmpTypeX _ (ForAllTy _ _) (TyVarTy _) = GT -cmpTypeX _ (ForAllTy _ _) (AppTy _ _) = GT -cmpTypeX _ (ForAllTy _ _) (FunTy _ _) = GT -cmpTypeX _ (ForAllTy _ _) (LitTy _) = GT -cmpTypeX _ (ForAllTy _ _) (TyConApp _ _) = GT - -cmpTypeX _ _ _ = LT + -- See Note [Non-trivial definitional equality] in TyCoRep +cmpTypeX env orig_t1 orig_t2 = go env k1 k2 `thenCmp` go env orig_t1 orig_t2 + where + k1 = typeKind orig_t1 + k2 = typeKind orig_t2 + + go env t1 t2 | Just t1' <- coreViewOneStarKind t1 = go env t1' t2 + go env t1 t2 | Just t2' <- coreViewOneStarKind t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) + = rnOccL env tv1 `compare` rnOccR env tv2 + go env (ForAllTy (Named tv1 _) t1) (ForAllTy (Named tv2 _) t2) + = go env (tyVarKind tv1) (tyVarKind tv2) + `thenCmp` 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 `thenCmp` go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- repSplitAppTy_maybe ty1 + = go env s1 s2 `thenCmp` go env t1 t2 + go env (ForAllTy (Anon s1) t1) (ForAllTy (Anon s2) t2) + = go env s1 s2 `thenCmp` go env t1 t2 + go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) + = (tc1 `cmpTc` tc2) `thenCmp` gos env tys1 tys2 + go _ (LitTy l1) (LitTy l2) = compare l1 l2 + go env (CastTy t1 _) t2 = go env t1 t2 + go env t1 (CastTy t2 _) = go env t1 t2 + go _ (CoercionTy {}) (CoercionTy {}) = EQ + + -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy + go _ ty1 ty2 + = (get_rank ty1) `compare` (get_rank ty2) + where get_rank :: Type -> Int + get_rank (CastTy {}) + = pprPanic "cmpTypeX.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 (ForAllTy (Anon {}) _) = 6 + get_rank (ForAllTy (Named {}) _) = 7 + + gos _ [] [] = EQ + gos _ [] _ = LT + gos _ _ [] = GT + gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmp` gos env tys1 tys2 ------------- cmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering @@ -1392,353 +2054,16 @@ cmpTypesX _ [] _ = LT cmpTypesX _ _ [] = GT ------------- +-- | Compare two 'TyCon's. NB: This should /never/ see the "star synonyms", +-- as recognized by Kind.isStarKindSynonymTyCon. See Note +-- [Kind Constraint and kind *] in Kind. cmpTc :: TyCon -> TyCon -> Ordering --- Here we treat * and Constraint as equal --- See Note [Kind Constraint and kind *] in Kinds.hs --- --- Also we treat OpenTypeKind as equal to either * or # --- See Note [Comparison with OpenTypeKind] cmpTc tc1 tc2 - | u1 == openTypeKindTyConKey, isSubOpenTypeKindKey u2 = EQ - | u2 == openTypeKindTyConKey, isSubOpenTypeKindKey u1 = EQ - | otherwise = nu1 `compare` nu2 + = ASSERT( not (isStarKindSynonymTyCon tc1) && not (isStarKindSynonymTyCon tc2) ) + u1 `compare` u2 where u1 = tyConUnique tc1 - nu1 = if u1==constraintKindTyConKey then liftedTypeKindTyConKey else u1 u2 = tyConUnique tc2 - nu2 = if u2==constraintKindTyConKey then liftedTypeKindTyConKey else u2 - -{- -Note [Comparison with OpenTypeKind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In PrimOpWrappers we have things like - PrimOpWrappers.mkWeak# = /\ a b c. Prim.mkWeak# a b c -where - Prim.mkWeak# :: forall (a:Open) b c. a -> b -> c - -> State# RealWorld -> (# State# RealWorld, Weak# b #) -Now, eta reduction will turn the definition into - PrimOpWrappers.mkWeak# = Prim.mkWeak# -which is kind-of OK, but now the types aren't really equal. So HACK HACK -we pretend (in Core) that Open is equal to * or #. I hate this. - -Note [cmpTypeX] -~~~~~~~~~~~~~~~ - -When we compare foralls, we should look at the kinds. But if we do so, -we get a corelint error like the following (in -libraries/ghc-prim/GHC/PrimopWrappers.hs): - - Binder's type: forall (o_abY :: *). - o_abY - -> GHC.Prim.State# GHC.Prim.RealWorld - -> GHC.Prim.State# GHC.Prim.RealWorld - Rhs type: forall (a_12 :: ?). - a_12 - -> GHC.Prim.State# GHC.Prim.RealWorld - -> GHC.Prim.State# GHC.Prim.RealWorld - -This is why we don't look at the kind. Maybe we should look if the -kinds are compatible. - --- cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) --- = cmpTypeX env (tyVarKind tv1) (tyVarKind tv2) `thenCmp` --- cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 - -************************************************************************ -* * - Type substitutions -* * -************************************************************************ --} - -emptyTvSubstEnv :: TvSubstEnv -emptyTvSubstEnv = emptyVarEnv - -composeTvSubst :: InScopeSet -> TvSubstEnv -> TvSubstEnv -> TvSubstEnv --- ^ @(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@ -composeTvSubst in_scope env1 env2 - = env1 `plusVarEnv` mapVarEnv (substTy subst1) env2 - -- 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 = TvSubst in_scope env1 - -emptyTvSubst :: TvSubst -emptyTvSubst = TvSubst emptyInScopeSet emptyTvSubstEnv - -isEmptyTvSubst :: TvSubst -> Bool - -- See Note [Extending the TvSubstEnv] in TypeRep -isEmptyTvSubst (TvSubst _ tenv) = isEmptyVarEnv tenv - -mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst -mkTvSubst = TvSubst - -getTvSubstEnv :: TvSubst -> TvSubstEnv -getTvSubstEnv (TvSubst _ env) = env - -getTvInScope :: TvSubst -> InScopeSet -getTvInScope (TvSubst in_scope _) = in_scope - -isInScope :: Var -> TvSubst -> Bool -isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope - -notElemTvSubst :: CoVar -> TvSubst -> Bool -notElemTvSubst v (TvSubst _ tenv) = not (v `elemVarEnv` tenv) - -setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst -setTvSubstEnv (TvSubst in_scope _) tenv = TvSubst in_scope tenv - -zapTvSubstEnv :: TvSubst -> TvSubst -zapTvSubstEnv (TvSubst in_scope _) = TvSubst in_scope emptyVarEnv - -extendTvInScope :: TvSubst -> Var -> TvSubst -extendTvInScope (TvSubst in_scope tenv) var = TvSubst (extendInScopeSet in_scope var) tenv - -extendTvInScopeList :: TvSubst -> [Var] -> TvSubst -extendTvInScopeList (TvSubst in_scope tenv) vars = TvSubst (extendInScopeSetList in_scope vars) tenv - -extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst -extendTvSubst (TvSubst in_scope tenv) tv ty = TvSubst in_scope (extendVarEnv tenv tv ty) - -extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst -extendTvSubstList (TvSubst in_scope tenv) tvs tys - = TvSubst in_scope (extendVarEnvList tenv (tvs `zip` tys)) - -unionTvSubst :: TvSubst -> TvSubst -> TvSubst --- Works when the ranges are disjoint -unionTvSubst (TvSubst in_scope1 tenv1) (TvSubst in_scope2 tenv2) - = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) ) - TvSubst (in_scope1 `unionInScope` in_scope2) - (tenv1 `plusVarEnv` tenv2) - --- mkOpenTvSubst and zipOpenTvSubst 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 - --- Note [Generating the in-scope set for a substitution] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- If we want to substitute [a -> ty1, b -> ty2] I used to --- think it was enough to generate an in-scope set that includes --- fv(ty1,ty2). But that's not enough; we really should also take the --- free vars of the type we are substituting into! Example: --- (forall b. (a,b,x)) [a -> List b] --- Then if we use the in-scope set {b}, there is a danger we will rename --- the forall'd variable to 'x' by mistake, getting this: --- (forall x. (List b, x, x) --- Urk! This means looking at all the calls to mkOpenTvSubst.... - - --- | Generates the in-scope set for the 'TvSubst' from the types in the incoming --- environment, hence "open" -mkOpenTvSubst :: TvSubstEnv -> TvSubst -mkOpenTvSubst tenv = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts tenv))) tenv - --- | Generates the in-scope set for the 'TvSubst' from the types in the incoming --- environment, hence "open" -zipOpenTvSubst :: [TyVar] -> [Type] -> TvSubst -zipOpenTvSubst tyvars tys - | debugIsOn && (length tyvars /= length tys) - = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst - | otherwise - = TvSubst (mkInScopeSet (tyVarsOfTypes tys)) (zipTyEnv tyvars tys) - --- | Called when doing top-level substitutions. Here we expect that the --- free vars of the range of the substitution will be empty. -mkTopTvSubst :: [(TyVar, Type)] -> TvSubst -mkTopTvSubst prs = TvSubst emptyInScopeSet (mkVarEnv prs) - -zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst -zipTopTvSubst tyvars tys - | debugIsOn && (length tyvars /= length tys) - = pprTrace "zipTopTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst - | otherwise - = TvSubst emptyInScopeSet (zipTyEnv tyvars tys) - -zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv -zipTyEnv tyvars tys - | debugIsOn && (length tyvars /= length tys) - = pprTrace "zipTyEnv" (ppr tyvars $$ ppr tys) emptyVarEnv - | otherwise - = zip_ty_env tyvars tys emptyVarEnv - --- Later substitutions in the list over-ride earlier ones, --- but there should be no loops -zip_ty_env :: [TyVar] -> [Type] -> TvSubstEnv -> TvSubstEnv -zip_ty_env [] [] env = env -zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendVarEnv env tv ty) - -- 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" -zip_ty_env tvs tys env = pprTrace "Var/Type length mismatch: " (ppr tvs $$ ppr tys) env --- zip_ty_env _ _ env = env - -instance Outputable TvSubst where - ppr (TvSubst ins tenv) - = brackets $ sep[ ptext (sLit "TvSubst"), - nest 2 (ptext (sLit "In scope:") <+> ppr ins), - nest 2 (ptext (sLit "Type env:") <+> ppr tenv) ] - -{- -************************************************************************ -* * - Performing type or kind substitutions -* * -************************************************************************ --} - --- | Type substitution making use of an 'TvSubst' that --- is assumed to be open, see 'zipOpenTvSubst' -substTyWith :: [TyVar] -> [Type] -> Type -> Type -substTyWith tvs tys = ASSERT( length tvs == length tys ) - substTy (zipOpenTvSubst tvs tys) - -substKiWith :: [KindVar] -> [Kind] -> Kind -> Kind -substKiWith = substTyWith - --- | Type substitution making use of an 'TvSubst' that --- is assumed to be open, see 'zipOpenTvSubst' -substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] -substTysWith tvs tys = ASSERT( length tvs == length tys ) - substTys (zipOpenTvSubst tvs tys) - -substKisWith :: [KindVar] -> [Kind] -> [Kind] -> [Kind] -substKisWith = substTysWith - --- | Substitute within a 'Type' -substTy :: TvSubst -> Type -> Type -substTy subst ty | isEmptyTvSubst subst = ty - | otherwise = subst_ty subst ty - --- | Substitute within several 'Type's -substTys :: TvSubst -> [Type] -> [Type] -substTys subst tys | isEmptyTvSubst subst = tys - | otherwise = map (subst_ty subst) tys - --- | Substitute within a 'ThetaType' -substTheta :: TvSubst -> ThetaType -> ThetaType -substTheta subst theta - | isEmptyTvSubst subst = theta - | otherwise = map (substTy subst) theta - --- | Remove any nested binders mentioning the 'TyVar's in the 'TyVarSet' -deShadowTy :: TyVarSet -> Type -> Type -deShadowTy tvs ty - = subst_ty (mkTvSubst in_scope emptyTvSubstEnv) ty - where - in_scope = mkInScopeSet tvs - -subst_ty :: TvSubst -> 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 (LitTy n) = n `seq` LitTy n - go (TyVarTy tv) = substTyVar subst tv - go (TyConApp tc tys) = let args = map go tys - in args `seqList` TyConApp tc args - - go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) - 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 (ForAllTy tv ty) = case substTyVarBndr subst tv of - (subst', tv') -> - ForAllTy tv' $! (subst_ty subst' ty) - -substTyVar :: TvSubst -> TyVar -> Type -substTyVar (TvSubst _ tenv) tv - | Just ty <- lookupVarEnv tenv tv = ty -- See Note [Apply Once] - | otherwise = ASSERT( isTyVar tv ) TyVarTy tv -- in TypeRep - -- We do not require that the tyvar is in scope - -- Reason: we do quite a bit of (substTyWith [tv] [ty] tau) - -- and it's a nuisance to bring all the free vars of tau into - -- scope --- and then force that thunk at every tyvar - -- Instead we have an ASSERT in substTyVarBndr to check for capture - -substTyVars :: TvSubst -> [TyVar] -> [Type] -substTyVars subst tvs = map (substTyVar subst) tvs - -lookupTyVar :: TvSubst -> TyVar -> Maybe Type - -- See Note [Extending the TvSubst] in TypeRep -lookupTyVar (TvSubst _ tenv) tv = lookupVarEnv tenv tv - -substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) -substTyVarBndr subst@(TvSubst in_scope tenv) old_var - = ASSERT2( _no_capture, ppr old_var $$ ppr subst ) - (TvSubst (in_scope `extendInScopeSet` new_var) new_env, 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` tyVarsOfTypes (varEnvElts tenv)) - -- Assertion check that we are not capturing something in the substitution - - old_ki = tyVarKind old_var - no_kind_change = isEmptyVarSet (tyVarsOfType 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 TvSubst] in TypeRep - -- - -- 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 $ updateTyVarKind (substTy subst) old_var - -- The uniqAway part makes sure the new variable is not already in scope - -cloneTyVarBndr :: TvSubst -> TyVar -> Unique -> (TvSubst, TyVar) -cloneTyVarBndr (TvSubst in_scope tv_env) tv uniq - = (TvSubst (extendInScopeSet in_scope tv') - (extendVarEnv tv_env tv (mkTyVarTy tv')), tv') - where - tv' = setVarUnique tv uniq -- Simply set the unique; the kind - -- has no type variables to worry about - -cloneTyVarBndrs :: TvSubst -> [TyVar] -> UniqSupply -> (TvSubst, [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' - -{- ----------------------------------------------------- --- Kind Stuff - -Kinds -~~~~~ - -For the description of subkinding in GHC, see - http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeType#Kinds --} - -type MetaKindVar = TyVar -- invariant: MetaKindVar will always be a - -- TcTyVar with details MetaTv (TauTv ...) ... --- meta kind var constructors and functions are in TcType - -type SimpleKind = Kind {- ************************************************************************ @@ -1749,31 +2074,14 @@ type SimpleKind = Kind -} typeKind :: Type -> Kind -typeKind orig_ty = go orig_ty - where - - go ty@(TyConApp tc tys) - | isPromotedTyCon tc - = ASSERT( tyConArity tc == length tys ) superKind - | otherwise - = kindAppResult (ptext (sLit "typeKind 1") <+> ppr ty $$ ppr orig_ty) - (tyConKind tc) tys - - go ty@(AppTy fun arg) = kindAppResult (ptext (sLit "typeKind 2") <+> ppr ty $$ ppr orig_ty) - (go fun) [arg] - go (LitTy l) = typeLiteralKind l - go (ForAllTy _ ty) = go ty - go (TyVarTy tyvar) = tyVarKind tyvar - go _ty@(FunTy _arg res) - -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), - -- not unliftedTypeKind (#) - -- The only things that can be after a function arrow are - -- (a) types (of kind openTypeKind or its sub-kinds) - -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) - | isSuperKind k = k - | otherwise = ASSERT2( isSubOpenTypeKind k, ppr _ty $$ ppr k ) liftedTypeKind - where - k = go res +typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys +typeKind (AppTy fun arg) = piResultTy (typeKind fun) arg +typeKind (LitTy l) = typeLiteralKind l +typeKind (ForAllTy (Anon _) _) = liftedTypeKind +typeKind (ForAllTy _ ty) = typeKind ty +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (CastTy _ty co) = pSnd $ coercionKind co +typeKind (CoercionTy co) = coercionType co typeLiteralKind :: TyLit -> Kind typeLiteralKind l = @@ -1781,28 +2089,127 @@ typeLiteralKind l = NumTyLit _ -> typeNatKind StrTyLit _ -> typeSymbolKind +-- | Print a tyvar with its kind +pprTyVar :: TyVar -> SDoc +pprTyVar tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) + {- -Kind inference -~~~~~~~~~~~~~~ -During kind inference, a kind variable unifies only with -a "simple kind", sk - sk ::= * | sk1 -> sk2 -For example - data T a = MkT a (T Int#) -fails. We give T the kind (k -> *), and the kind variable k won't unify -with # (the kind of Int#). - -Type inference -~~~~~~~~~~~~~~ -When creating a fresh internal type variable, we give it a kind to express -constraints on it. E.g. in (\x->e) we make up a fresh type variable for x, -with kind ??. - -During unification we only bind an internal type variable to a type -whose kind is lower in the sub-kind hierarchy than the kind of the tyvar. - -When unifying two internal type variables, we collect their kind constraints by -finding the GLB of the two. Since the partial order is a tree, they only -have a glb if one is a sub-kind of the other. In that case, we bind the -less-informative one to the more informative one. Neat, eh? +%************************************************************************ +%* * + 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 -> NameEnv TyCon +tyConsOfType ty + = go ty + where + go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy {}) = emptyNameEnv + go (LitTy {}) = emptyNameEnv + go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys + go (AppTy a b) = go a `plusNameEnv` go b + go (ForAllTy (Anon a) b) = go a `plusNameEnv` go b `plusNameEnv` go_tc funTyCon + go (ForAllTy (Named tv _) ty) = go ty `plusNameEnv` go (tyVarKind tv) + go (CastTy ty co) = go ty `plusNameEnv` go_co co + go (CoercionTy co) = go_co co + + go_co (Refl _ ty) = go ty + go_co (TyConAppCo _ tc args) = go_tc tc `plusNameEnv` go_cos args + go_co (AppCo co arg) = go_co co `plusNameEnv` go_co arg + go_co (ForAllCo _ kind_co co) = go_co kind_co `plusNameEnv` go_co co + go_co (CoVarCo {}) = emptyNameEnv + go_co (AxiomInstCo ax _ args) = go_ax ax `plusNameEnv` go_cos args + go_co (UnivCo p _ t1 t2) = go_prov p `plusNameEnv` go t1 `plusNameEnv` go t2 + go_co (SymCo co) = go_co co + go_co (TransCo co1 co2) = go_co co1 `plusNameEnv` 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 `plusNameEnv` go_co arg + go_co (CoherenceCo co1 co2) = go_co co1 `plusNameEnv` go_co co2 + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + go_co (AxiomRuleCo _ cs) = go_cos cs + + go_prov UnsafeCoerceProv = emptyNameEnv + go_prov (PhantomProv co) = go_co co + go_prov (ProofIrrelProv co) = go_co co + go_prov (PluginProv _) = emptyNameEnv + go_prov (HoleProv h) = pprPanic "tyConsOfType hit a hole" (ppr h) + + go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys + go_cos cos = foldr (plusNameEnv . go_co) emptyNameEnv cos + + go_tc tc = unitNameEnv (tyConName tc) 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 the variable was used in a dependent context. It's possible +-- for a variable to be reported twice, if it's used both dependently +-- and non-dependently. (This isn't the most precise analysis, because +-- it's used in the typechecking knot. It might list some dependent +-- variables as also non-dependent.) +splitDepVarsOfType :: Type -> Pair TyCoVarSet +splitDepVarsOfType = go + where + go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) + (unitVarSet tv) + go (AppTy t1 t2) = go t1 `mappend` go t2 + go (TyConApp _ tys) = foldMap go tys + go (ForAllTy (Anon arg) res) = go arg `mappend` go res + go (ForAllTy (Named tv _) ty) + = let Pair kvs tvs = go ty in + Pair (kvs `delVarSet` tv `unionVarSet` tyCoVarsOfType (tyVarKind tv)) + (tvs `delVarSet` tv) + go (LitTy {}) = mempty + go (CastTy ty co) = go ty `mappend` Pair (tyCoVarsOfCo co) + emptyVarSet + go (CoercionTy co) = go_co co + + go_co co = let Pair ty1 ty2 = coercionKind co in + go ty1 `mappend` go ty2 -- NB: the Pairs separate along different + -- dimensions here. Be careful! + +-- | Like 'splitDepVarsOfType', but over a list of types +splitDepVarsOfTypes :: [Type] -> Pair TyCoVarSet +splitDepVarsOfTypes = foldMap splitDepVarsOfType + +-- | 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 (ForAllTy (Anon t1) t2) = go t1 `mappend` go t2 + go (ForAllTy (Named tv _) ty) + = ((`delVarSet` tv) <$> go ty) `mappend` + (invisible (tyCoVarsOfType $ tyVarKind 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) = partitionInvisibles tc id tys in + invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis + +splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet +splitVisVarsOfTypes = foldMap splitVisVarsOfType diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot index 587454e357..aa12398bd7 100644 --- a/compiler/types/Type.hs-boot +++ b/compiler/types/Type.hs-boot @@ -1,9 +1,16 @@ module Type where -import {-# SOURCE #-} TypeRep( Type, Kind ) -import Var +import TyCon +import {-# SOURCE #-} TyCoRep( Type, Kind ) isPredTy :: Type -> Bool +isCoercionTy :: Type -> Bool + +mkAppTy :: Type -> Type -> Type +piResultTy :: Type -> Type -> Type typeKind :: Type -> Kind -substKiWith :: [KindVar] -> [Kind] -> Kind -> Kind -eqKind :: Kind -> Kind -> Bool +eqType :: Type -> Type -> Bool + +coreViewOneStarKind :: Type -> Maybe Type + +partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a]) diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs deleted file mode 100644 index f13ca8aa1e..0000000000 --- a/compiler/types/TypeRep.hs +++ /dev/null @@ -1,1020 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[TypeRep]{Type - friends' interface} - -Note [The Type-related module hierarchy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Class - TyCon imports Class - TypeRep - TysPrim imports TypeRep ( including mkTyConTy ) - Kind imports TysPrim ( mainly for primitive kinds ) - Type imports Kind - Coercion imports Type --} - -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, - DeriveTraversable #-} -{-# OPTIONS_HADDOCK hide #-} --- We expose the relevant stuff from this module via the Type module - -module TypeRep ( - TyThing(..), - Type(..), - TyLit(..), - KindOrType, Kind, SuperKind, - PredType, ThetaType, -- Synonyms - - -- Functions over types - mkTyConTy, mkTyVarTy, mkTyVarTys, - isLiftedTypeKind, isSuperKind, isTypeVar, isKindVar, - - -- Pretty-printing - pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, - pprTyThing, pprTyThingCategory, pprSigmaType, - pprTheta, pprForAll, pprUserForAll, - pprThetaArrowTy, pprClassPred, - pprKind, pprParendKind, pprTyLit, suppressKinds, - TyPrec(..), maybeParen, pprTcApp, - pprPrefixApp, pprArrowChain, ppr_type, - pprDataCons, - - -- Free variables - tyVarsOfType, tyVarsOfTypes, closeOverKinds, varSetElemsKvsFirst, - tyVarsOfTypeAcc, tyVarsOfTypeList, tyVarsOfTypesAcc, tyVarsOfTypesList, - tyVarsOfTypeDSet, tyVarsOfTypesDSet, - closeOverKindsDSet, closeOverKindsAcc, - - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyOpenKind, - tidyTyVarBndr, tidyTyVarBndrs, tidyFreeTyVars, - tidyOpenTyVar, tidyOpenTyVars, - tidyTyVarOcc, - tidyTopType, - tidyKind, - - -- Substitutions - TvSubst(..), TvSubstEnv - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} DataCon( DataCon, dataConTyCon, dataConFullSig ) -import {-# SOURCE #-} ConLike ( ConLike(..) ) -import {-# SOURCE #-} Type( isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop - --- friends: -import Var -import VarEnv -import VarSet -import Name -import BasicTypes -import TyCon -import Class -import CoAxiom -import FV - --- others -import PrelNames -import Outputable -import FastString -import ListSetOps -import Util -import DynFlags -import StaticFlags( opt_PprStyle_Debug ) - --- libraries -import Data.List( mapAccumL, partition ) -import qualified Data.Data as Data hiding ( TyCon ) - -{- -************************************************************************ -* * -\subsection{The data type} -* * -************************************************************************ --} - --- | The key representation of types within the compiler - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Type - = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) - - | AppTy -- See Note [AppTy rep] - Type - Type -- ^ Type application to something other than a 'TyCon'. Parameters: - -- - -- 1) Function: must /not/ be a 'TyConApp', - -- must be another 'AppTy', or 'TyVarTy' - -- - -- 2) Argument type - - | TyConApp -- See Note [AppTy rep] - 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. - - | FunTy - Type - Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@ - -- See Note [Equality-constrained types] - - | ForAllTy - Var -- Type or kind variable - Type -- ^ A polymorphic type - - | LitTy TyLit -- ^ Type literals are similar to type constructors. - - deriving (Data.Data, Data.Typeable) - - --- 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, Data.Typeable) - -type KindOrType = Type -- See Note [Arguments to type constructors] - --- | The key type representing kinds in the compiler. --- Invariant: a kind is always in one of these forms: --- --- > FunTy k1 k2 --- > TyConApp PrimTyCon [...] --- > TyVar kv -- (during inference only) --- > ForAll ... -- (for top-level coercions) -type Kind = Type - --- | "Super kinds", used to help encode 'Kind's as types. --- Invariant: a super kind is always of this form: --- --- > TyConApp SuperKindTyCon ... -type SuperKind = Type - -{- -Note [The kind invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The kinds - # UnliftedTypeKind - OpenKind super-kind of *, # - -can never appear under an arrow or type constructor in a kind; they -can only be at the top level of a kind. It follows that primitive TyCons, -which have a naughty pseudo-kind - State# :: * -> # -must always be saturated, so that we can never get a type whose kind -has a UnliftedTypeKind or ArgTypeKind underneath an arrow. - -Nor can we abstract over a type variable with any of these kinds. - - k :: = kk | # | ArgKind | (#) | OpenKind - kk :: = * | kk -> kk | T kk1 ... kkn - -So a type variable can only be abstracted kk. - -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 [Equality-constrained types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type forall ab. (a ~ [b]) => blah -is encoded like this: - - ForAllTy (a:*) $ ForAllTy (b:*) $ - FunTy (TyConApp (~) [a, [b]]) $ - blah - -------------------------------------- - Note [PredTy] --} - --- | A type of the form @p@ of kind @Constraint@ 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 = TyVarTy - -mkTyVarTys :: [TyVar] -> [Type] -mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy - --- | Create the plain type constructor type which has been applied to no type arguments at all. -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = TyConApp tycon [] - --- Some basic functions, put here to break loops eg with the pretty printer - -isLiftedTypeKind :: Kind -> Bool -isLiftedTypeKind (TyConApp tc []) = tc `hasKey` liftedTypeKindTyConKey -isLiftedTypeKind _ = False - --- | Is this a super-kind (i.e. a type-of-kinds)? -isSuperKind :: Type -> Bool -isSuperKind (TyConApp skc []) = skc `hasKey` superKindTyConKey -isSuperKind _ = False - -isTypeVar :: Var -> Bool -isTypeVar v = isTKVar v && not (isSuperKind (varType v)) - -isKindVar :: Var -> Bool -isKindVar v = isTKVar v && isSuperKind (varType v) - -{- -************************************************************************ -* * - Free variables of types and coercions -* * -************************************************************************ --} - --- | Returns free variables of a type, including kind variables as --- a non-deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyVarsOfType :: Type -> VarSet -tyVarsOfType ty = runFVSet $ tyVarsOfTypeAcc ty - --- | `tyVarsOfType` 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. -tyVarsOfTypeList :: Type -> [TyVar] -tyVarsOfTypeList ty = runFVList $ tyVarsOfTypeAcc ty - --- | `tyVarsOfType` 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. -tyVarsOfTypeDSet :: Type -> DTyVarSet -tyVarsOfTypeDSet ty = runFVDSet $ tyVarsOfTypeAcc ty - --- | Returns free variables of types, including kind variables as --- a non-deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyVarsOfTypes :: [Type] -> TyVarSet -tyVarsOfTypes tys = runFVSet $ tyVarsOfTypesAcc tys - --- | Returns free variables of types, including kind variables as --- a deterministically ordered list. For type synonyms it does /not/ expand the --- synonym. -tyVarsOfTypesList :: [Type] -> [TyVar] -tyVarsOfTypesList tys = runFVList $ tyVarsOfTypesAcc tys - --- | Returns free variables of types, including kind variables as --- a deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyVarsOfTypesDSet :: [Type] -> DTyVarSet -tyVarsOfTypesDSet tys = runFVDSet $ tyVarsOfTypesAcc tys - - --- | The worker for `tyVarsOfType` and `tyVarsOfTypeList`. --- 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. -tyVarsOfTypeAcc :: Type -> FV -tyVarsOfTypeAcc (TyVarTy v) fv_cand in_scope acc = oneVar v fv_cand in_scope acc -tyVarsOfTypeAcc (TyConApp _ tys) fv_cand in_scope acc = - tyVarsOfTypesAcc tys fv_cand in_scope acc -tyVarsOfTypeAcc (LitTy {}) fv_cand in_scope acc = noVars fv_cand in_scope acc -tyVarsOfTypeAcc (FunTy arg res) fv_cand in_scope acc = - (tyVarsOfTypeAcc arg `unionFV` tyVarsOfTypeAcc res) fv_cand in_scope acc -tyVarsOfTypeAcc (AppTy fun arg) fv_cand in_scope acc = - (tyVarsOfTypeAcc fun `unionFV` tyVarsOfTypeAcc arg) fv_cand in_scope acc -tyVarsOfTypeAcc (ForAllTy tyvar ty) fv_cand in_scope acc = - (delFV tyvar (tyVarsOfTypeAcc ty) `unionFV` - tyVarsOfTypeAcc (tyVarKind tyvar)) fv_cand in_scope acc - -tyVarsOfTypesAcc :: [Type] -> FV -tyVarsOfTypesAcc (ty:tys) fv_cand in_scope acc = - (tyVarsOfTypeAcc ty `unionFV` tyVarsOfTypesAcc tys) fv_cand in_scope acc -tyVarsOfTypesAcc [] fv_cand in_scope acc = noVars fv_cand in_scope acc - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a non-deterministic set. -closeOverKinds :: TyVarSet -> TyVarSet -closeOverKinds = runFVSet . closeOverKindsAcc . varSetElems - --- | 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. -closeOverKindsAcc :: [TyVar] -> FV -closeOverKindsAcc tvs = - mapUnionFV (tyVarsOfTypeAcc . tyVarKind) tvs `unionFV` someVars tvs - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a deterministic set. -closeOverKindsDSet :: DTyVarSet -> DTyVarSet -closeOverKindsDSet = runFVDSet . closeOverKindsAcc . dVarSetElems - -varSetElemsKvsFirst :: VarSet -> [TyVar] --- {k1,a,k2,b} --> [k1,k2,a,b] -varSetElemsKvsFirst set - = kvs ++ tvs - where - (kvs, tvs) = partition isKindVar (varSetElems set) - -{- -************************************************************************ -* * - 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. - -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) - deriving (Eq, Ord) - -instance Outputable TyThing where - ppr = pprTyThing - -pprTyThing :: TyThing -> SDoc -pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) - -pprTyThingCategory :: TyThing -> SDoc -pprTyThingCategory (ATyCon tc) - | isClassTyCon tc = ptext (sLit "Class") - | otherwise = ptext (sLit "Type constructor") -pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom") -pprTyThingCategory (AnId _) = ptext (sLit "Identifier") -pprTyThingCategory (AConLike (RealDataCon _)) = ptext (sLit "Data constructor") -pprTyThingCategory (AConLike (PatSynCon _)) = ptext (sLit "Pattern synonym") - - -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) = getName cl - -{- -************************************************************************ -* * - Substitutions - Data type defined here to avoid unnecessary mutual recursion -* * -************************************************************************ --} - --- | Type substitution --- --- #tvsubst_invariant# --- The following invariants must hold of a 'TvSubst': --- --- 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 TvSubst - = TvSubst InScopeSet -- The in-scope type and kind variables - TvSubstEnv -- Substitutes both type and kind variables - -- See Note [Apply Once] - -- and Note [Extending the TvSubstEnv] - --- | A substitution of 'Type's for 'TyVar's --- and 'Kind's for 'KindVar's -type TvSubstEnv = TyVarEnv Type - -- A TvSubstEnv is used both inside a TvSubst (with the apply-once - -- invariant discussed in Note [Apply 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 - -{- -Note [Apply Once] -~~~~~~~~~~~~~~~~~ -We use TvSubsts 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 TvSubst must be applied precisely once *** - *************************************************** - -A TvSubst is not idempotent, but, unlike the non-idempotent substitution -we use during unifications, it must not be repeatedly applied. - -Note [Extending the TvSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #tvsubst_invariant# for the invariants that must hold. - -This invariant allows a short-cut when the TvSubstEnv is empty: -if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt 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 substTyVarBndr, 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 - - - -************************************************************************ -* * - 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 [Precedence in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't keep the fixity of type operators in the operator. So the pretty printer -operates the following precedene structre: - Type constructor application binds more tightly than - Oerator applications which bind more tightly than - Function arrow - -So we might see a :+: T b -> c -meaning (a :+: (T b)) -> c - -Maybe operator applications should bind a bit less tightly? - -Anyway, that's the current story, and it is used consistently for Type and HsType --} - -data TyPrec -- See Note [Prededence in types] - - = TopPrec -- No parens - | FunPrec -- Function args; no parens for tycon apps - | TyOpPrec -- Infix operator - | TyConPrec -- Tycon args; no parens for atomic - deriving( Eq, Ord ) - -maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = parens pretty - ------------------- -pprType, pprParendType :: Type -> SDoc -pprType ty = ppr_type TopPrec ty -pprParendType ty = ppr_type TyConPrec ty - -pprTyLit :: TyLit -> SDoc -pprTyLit = ppr_tylit TopPrec - -pprKind, pprParendKind :: Kind -> SDoc -pprKind = pprType -pprParendKind = pprParendType - ------------- -pprClassPred :: Class -> [Type] -> SDoc -pprClassPred clas tys = pprTypeApp (classTyCon clas) tys - ------------- -pprTheta :: ThetaType -> SDoc -pprTheta [pred] = ppr_type TopPrec pred -- I'm in two minds about this -pprTheta theta = parens (sep (punctuate comma (map (ppr_type TopPrec) theta))) - -pprThetaArrowTy :: ThetaType -> SDoc -pprThetaArrowTy [] = empty -pprThetaArrowTy [pred] = ppr_type TyOpPrec pred <+> darrow - -- TyOpPrec: Num a => a -> a does not need parens - -- bug (a :~: b) => a -> b currently does - -- Trac # 9658 -pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) preds))) - <+> darrow - -- Notice 'fsep' here rather that 'sep', so that - -- type contexts don't get displayed in a giant column - -- Rather than - -- instance (Eq a, - -- Eq b, - -- Eq c, - -- Eq d, - -- Eq e, - -- Eq f, - -- Eq g, - -- Eq h, - -- Eq i, - -- Eq j, - -- Eq k, - -- Eq l) => - -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) - -- we get - -- - -- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, - -- Eq j, Eq k, Eq l) => - -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) - ------------------- -instance Outputable Type where - ppr ty = pprType ty - -instance Outputable TyLit where - ppr = pprTyLit - ------------------- - -- OK, here's the main printer - -ppr_type :: TyPrec -> Type -> SDoc -ppr_type _ (TyVarTy tv) = ppr_tvar tv -ppr_type p (TyConApp tc tys) = pprTyTcApp p tc tys -ppr_type p (LitTy l) = ppr_tylit p l -ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty - -ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ - ppr_type FunPrec t1 <+> ppr_type TyConPrec t2 - -ppr_type p fun_ty@(FunTy ty1 ty2) - | isPredTy ty1 - = ppr_forall_type p fun_ty - | otherwise - = pprArrowChain p (ppr_type FunPrec ty1 : ppr_fun_tail ty2) - where - -- We don't want to lose synonyms, so we mustn't use splitFunTys here. - ppr_fun_tail (FunTy ty1 ty2) - | not (isPredTy ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2 - ppr_fun_tail other_ty = [ppr_type TopPrec other_ty] - - -ppr_forall_type :: TyPrec -> Type -> SDoc -ppr_forall_type p ty - = maybeParen p FunPrec $ ppr_sigma_type True ty - -- True <=> we always print the foralls on *nested* quantifiers - -- Opt_PrintExplicitForalls only affects top-level quantifiers - -- False <=> we don't print an extra-constraints wildcard - -ppr_tvar :: TyVar -> SDoc -ppr_tvar tv -- Note [Infix type variables] - = parenSymOcc (getOccName tv) (ppr tv) - -ppr_tylit :: TyPrec -> TyLit -> SDoc -ppr_tylit _ tl = - case tl of - NumTyLit n -> integer n - StrTyLit s -> text (show s) - -------------------- -ppr_sigma_type :: Bool -> Type -> SDoc --- First Bool <=> Show the foralls unconditionally --- Second Bool <=> Show an extra-constraints wildcard -ppr_sigma_type show_foralls_unconditionally ty - = sep [ if show_foralls_unconditionally - then pprForAll tvs - else pprUserForAll tvs - , pprThetaArrowTy ctxt - , pprType tau ] - where - (tvs, rho) = split1 [] ty - (ctxt, tau) = split2 [] rho - - split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty - split1 tvs ty = (reverse tvs, ty) - - split2 ps (ty1 `FunTy` ty2) | isPredTy ty1 = split2 (ty1:ps) ty2 - split2 ps ty = (reverse ps, ty) - -pprSigmaType :: Type -> SDoc -pprSigmaType ty = ppr_sigma_type False ty - -pprUserForAll :: [TyVar] -> SDoc --- Print a user-level forall; see Note [When to print foralls] -pprUserForAll tvs - = sdocWithDynFlags $ \dflags -> - ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $ - pprForAll tvs - where - tv_has_kind_var tv = not (isEmptyVarSet (tyVarsOfType (tyVarKind tv))) - -pprForAll :: [TyVar] -> SDoc -pprForAll [] = empty -pprForAll tvs = forAllLit <+> pprTvBndrs tvs <> dot - -pprTvBndrs :: [TyVar] -> SDoc -pprTvBndrs tvs = sep (map pprTvBndr tvs) - -pprTvBndr :: TyVar -> SDoc -pprTvBndr tv - | isLiftedTypeKind kind = ppr_tvar tv - | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) - where - kind = tyVarKind tv - -{- -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 Trac #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 pprTvBndr. - -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 Trac #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 - forAllDoc = pprUserForAll ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) - thetaDoc = pprThetaArrowTy theta - argsDoc = hsep (fmap pprParendType arg_tys) - -pprTypeApp :: TyCon -> [Type] -> SDoc -pprTypeApp tc tys = pprTyTcApp TopPrec tc tys - -- We have to use ppr on the TyCon (not its name) - -- so that we get promotion quotes in the right place - -pprTyTcApp :: TyPrec -> TyCon -> [Type] -> SDoc --- Used for types only; so that we can make a --- special case for type-level lists -pprTyTcApp p tc tys - | tc `hasKey` ipTyConKey - , [LitTy (StrTyLit n),ty] <- tys - = maybeParen p FunPrec $ - char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty - - | tc `hasKey` consDataConKey - , [_kind,ty1,ty2] <- tys - = sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitKinds dflags then pprTcApp p ppr_type tc tys - else pprTyList p ty1 ty2 - - | not opt_PprStyle_Debug - , tc `hasKey` errorMessageTypeErrorFamKey - = text "(TypeError ...)" -- Suppress detail unles you _really_ want to see it - - | otherwise - = pprTcApp p ppr_type tc tys - -pprTcApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc --- Used for both types and coercions, hence polymorphism -pprTcApp _ pp tc [ty] - | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) - | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) - - -pprTcApp p pp tc tys - | Just sort <- tyConTuple_maybe tc - , tyConArity tc == length tys - = pprTupleApp p pp tc sort tys - - | Just dc <- isPromotedDataCon_maybe tc - , let dc_tc = dataConTyCon dc - , Just tup_sort <- tyConTuple_maybe dc_tc - , let arity = tyConArity dc_tc -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3 - ty_args = drop arity tys -- Drop the kind args - , ty_args `lengthIs` arity -- Result is saturated - = pprPromotionQuote tc <> - (tupleParens tup_sort $ pprWithCommas (pp TopPrec) ty_args) - - | otherwise - = sdocWithDynFlags (pprTcApp_help p pp tc tys) - -pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> TupleSort -> [a] -> SDoc --- Print a saturated tuple -pprTupleApp p pp tc sort tys - | null tys - , ConstraintTuple <- sort - = if opt_PprStyle_Debug then ptext (sLit "(%%)") - else maybeParen p FunPrec $ - ptext (sLit "() :: Constraint") - | otherwise - = pprPromotionQuote tc <> - tupleParens sort (pprWithCommas (pp TopPrec) tys) - -pprTcApp_help :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> DynFlags -> SDoc --- This one has accss to the DynFlags -pprTcApp_help p pp tc tys dflags - | not (isSymOcc (nameOccName (tyConName tc))) - = pprPrefixApp p (ppr tc) (map (pp TyConPrec) tys_wo_kinds) - - | [ty1,ty2] <- tys_wo_kinds -- Infix, two arguments; - -- we know nothing of precedence though - = pprInfixApp p pp (ppr tc) ty1 ty2 - - | tc `hasKey` liftedTypeKindTyConKey - || tc `hasKey` unliftedTypeKindTyConKey - = ASSERT( null tys ) ppr tc -- Do not wrap *, # in parens - - | otherwise - = pprPrefixApp p (parens (ppr tc)) (map (pp TyConPrec) tys_wo_kinds) - where - tys_wo_kinds = suppressKinds dflags (tyConKind tc) tys - ------------------- -suppressKinds :: DynFlags -> Kind -> [a] -> [a] --- Given the kind of a TyCon, and the args to which it is applied, --- suppress the args that are kind args --- C.f. Note [Suppressing kinds] in IfaceType -suppressKinds dflags kind xs - | gopt Opt_PrintExplicitKinds dflags = xs - | otherwise = suppress kind xs - where - suppress (ForAllTy _ kind) (_ : xs) = suppress kind xs - suppress (FunTy _ res) (x:xs) = x : suppress res xs - suppress _ xs = xs - ----------------- -pprTyList :: TyPrec -> Type -> Type -> SDoc --- Given a type-level list (t1 ': t2), see if we can print --- it in list notation [t1, ...]. -pprTyList p ty1 ty2 - = case gather ty2 of - (arg_tys, Nothing) -> char '\'' <> brackets (fsep (punctuate comma - (map (ppr_type TopPrec) (ty1:arg_tys)))) - (arg_tys, Just tl) -> maybeParen p FunPrec $ - hang (ppr_type FunPrec ty1) - 2 (fsep [ colon <+> ppr_type FunPrec ty | ty <- arg_tys ++ [tl]]) - where - gather :: Type -> ([Type], Maybe Type) - -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] - -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl - gather (TyConApp tc tys) - | tc `hasKey` consDataConKey - , [_kind, ty1,ty2] <- tys - , (args, tl) <- gather ty2 - = (ty1:args, tl) - | tc `hasKey` nilDataConKey - = ([], Nothing) - gather ty = ([], Just ty) - ----------------- -pprInfixApp :: TyPrec -> (TyPrec -> a -> SDoc) -> SDoc -> a -> a -> SDoc -pprInfixApp p pp pp_tc ty1 ty2 - = maybeParen p TyOpPrec $ - sep [pp TyOpPrec ty1, pprInfixVar True pp_tc <+> pp TyOpPrec ty2] - -pprPrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc -pprPrefixApp p pp_fun pp_tys - | null pp_tys = pp_fun - | otherwise = maybeParen p TyConPrec $ - hang pp_fun 2 (sep pp_tys) - ----------------- -pprArrowChain :: TyPrec -> [SDoc] -> SDoc --- pprArrowChain p [a,b,c] generates a -> b -> c -pprArrowChain _ [] = empty -pprArrowChain p (arg:args) = maybeParen p FunPrec $ - sep [arg, sep (map (arrow <+>) args)] - -{- -************************************************************************ -* * -\subsection{TidyType} -* * -************************************************************************ - -Tidying is here because it has a special case for FlatSkol --} - --- | 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. -tidyTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) -tidyTyVarBndrs env tvs = mapAccumL tidyTyVarBndr env tvs - -tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) -tidyTyVarBndr tidy_env@(occ_env, subst) tyvar - = case tidyOccName occ_env occ1 of - (tidy', occ') -> ((tidy', subst'), tyvar') - where - subst' = extendVarEnv subst tyvar tyvar' - tyvar' = setTyVarKind (setTyVarName tyvar name') kind' - name' = tidyNameOcc name occ' - kind' = tidyKind tidy_env (tyVarKind tyvar) - where - name = tyVarName tyvar - occ = getOccName name - -- System Names are for unification variables; - -- 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 - occ1 | isSystemName name = mkTyVarOcc (occNameString occ ++ "0") - | otherwise = occ - - ---------------- -tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv --- ^ Add the free 'TyVar's to the env in tidy form, --- so that we can tidy the type they are free in -tidyFreeTyVars (full_occ_env, var_env) tyvars - = fst (tidyOpenTyVars (full_occ_env, var_env) (varSetElems tyvars)) - - --------------- -tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) -tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars - ---------------- -tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) --- ^ Treat a new 'TyVar' as a binder, and give it a fresh tidy name --- using the environment if one has not already been allocated. See --- also 'tidyTyVarBndr' -tidyOpenTyVar env@(_, subst) tyvar - = case lookupVarEnv subst tyvar of - Just tyvar' -> (env, tyvar') -- Already substituted - Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder - ---------------- -tidyTyVarOcc :: TidyEnv -> TyVar -> TyVar -tidyTyVarOcc (_, subst) tv - = case lookupVarEnv subst tv of - Nothing -> 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 (tidyTyVarOcc 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 (FunTy fun arg) = (FunTy $! (tidyType env fun)) $! (tidyType env arg) -tidyType env (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) - where - (envp, tvp) = tidyTyVarBndr env tv - ---------------- --- | Grabs the free type variables, tidies them --- and then uses 'tidyType' to work over the type itself -tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) -tidyOpenType env ty - = (env', tidyType (trimmed_occ_env, var_env) ty) - where - (env'@(_, var_env), tvs') = tidyOpenTyVars env (tyVarsOfTypeList ty) - trimmed_occ_env = initTidyOccEnv (map getOccName tvs') - -- The idea here was that we restrict the new TidyEnv to the - -- _free_ vars of the type, so that we don't gratuitously rename - -- the _bound_ variables of the type. - ---------------- -tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) -tidyOpenTypes env tys = mapAccumL tidyOpenType env tys - ---------------- --- | 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 diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs index 78e4936ab7..0c2469a9ed 100644 --- a/compiler/types/Unify.hs +++ b/compiler/types/Unify.hs @@ -1,23 +1,23 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP, DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} module Unify ( - -- Matching of types: - -- the "tc" prefix indicates that matching always - -- respects newtypes (rather than looking through them) - tcMatchTy, tcUnifyTyWithTFs, tcMatchTys, tcMatchTyX, tcMatchTysX, - ruleMatchTyX, tcMatchPreds, - - MatchEnv(..), matchList, + tcMatchTy, tcMatchTys, tcMatchTyX, tcMatchTysX, tcUnifyTyWithTFs, + ruleMatchTyX, typesCantMatch, -- Side-effect free unification - tcUnifyTy, tcUnifyTys, BindFlag(..), - - UnifyResultM(..), UnifyResult, tcUnifyTysFG + tcUnifyTy, tcUnifyTys, + tcUnifyTysFG, + BindFlag(..), + UnifyResult, UnifyResultM(..), + -- Matching a type against a lifted type (coercion) + liftCoMatch ) where #include "HsVersions.h" @@ -26,30 +26,27 @@ import Var import VarEnv import VarSet import Kind -import Type +import Type hiding ( getTvSubstEnv ) +import Coercion hiding ( getCvSubstEnv ) import TyCon -import TypeRep -import Util ( filterByList ) +import TyCoRep hiding ( getTvSubstEnv, getCvSubstEnv ) +import Util +import Pair import Outputable -import FastString (sLit) -import Control.Monad (liftM, foldM, ap) +import Control.Monad #if __GLASGOW_HASKELL__ > 710 import qualified Control.Monad.Fail as MonadFail #endif #if __GLASGOW_HASKELL__ < 709 -import Control.Applicative (Applicative(..)) +import Data.Traversable ( traverse ) #endif +import Control.Applicative hiding ( empty ) +import qualified Control.Applicative {- -************************************************************************ -* * - Matching -* * -************************************************************************ - -Matching is much tricker than you might think. +Unification is much tricker than you might think. 1. The substitution we generate binds the *template type variables* which are given to us explicitly. @@ -69,191 +66,93 @@ Matching is much tricker than you might think. 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. --} -data MatchEnv - = ME { me_tmpls :: VarSet -- Template variables - , me_env :: RnEnv2 -- Renaming envt for nested foralls - } -- In-scope set includes template variables - -- Nota Bene: MatchEnv isn't specific to Types. It is used - -- for matching terms and coercions as well as types - -tcMatchTy :: TyVarSet -- Template tyvars - -> Type -- Template - -> Type -- Target - -> Maybe TvSubst -- One-shot; in principle the template - -- variables could be free in the target -tcMatchTy tmpls ty1 ty2 - = tcMatchTyX tmpls init_subst ty1 ty2 - where - init_subst = mkTvSubst in_scope emptyTvSubstEnv - in_scope = mkInScopeSet (tmpls `unionVarSet` tyVarsOfType ty2) - -- We're assuming that all the interesting - -- tyvars in ty1 are in tmpls +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. 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 *. + +We thought, at one point, that this was all unnecessary: why should casts +be in types in the first place? But they do. 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. + +-} -tcMatchTys :: TyVarSet -- Template tyvars - -> [Type] -- Template - -> [Type] -- Target - -> Maybe TvSubst -- One-shot; in principle the template - -- variables could be free in the target +-- | @tcMatchTy tys t1 t2@ produces a substitution (over a subset of +-- the variables @tys@) @s@ such that @s(t1)@ equals @t2@. +-- The returned substitution might +-- bind coercion variables, if the variable is an argument to a GADT +-- constructor. +tcMatchTy :: TyCoVarSet -> Type -> Type -> Maybe TCvSubst +tcMatchTy tmpls ty1 ty2 = tcMatchTys tmpls [ty1] [ty2] + +-- | This is similar to 'tcMatchTy', but extends a substitution +tcMatchTyX :: TyCoVarSet -- ^ Template tyvars + -> TCvSubst -- ^ Substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TCvSubst +tcMatchTyX tmpls subst ty1 ty2 = tcMatchTysX tmpls subst [ty1] [ty2] + +-- | Like 'tcMatchTy' but over a list of types. +tcMatchTys :: TyCoVarSet -- ^ Template tyvars + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot; in principle the template + -- variables could be free in the target tcMatchTys tmpls tys1 tys2 - = tcMatchTysX tmpls init_subst tys1 tys2 - where - init_subst = mkTvSubst in_scope emptyTvSubstEnv - in_scope = mkInScopeSet (tmpls `unionVarSet` tyVarsOfTypes tys2) - -tcMatchTyX :: TyVarSet -- Template tyvars - -> TvSubst -- Substitution to extend - -> Type -- Template - -> Type -- Target - -> Maybe TvSubst -tcMatchTyX tmpls (TvSubst in_scope subst_env) ty1 ty2 - = case match menv subst_env ty1 ty2 of - Just subst_env' -> Just (TvSubst in_scope subst_env') - Nothing -> Nothing - where - menv = ME {me_tmpls = tmpls, me_env = mkRnEnv2 in_scope} - -tcMatchTysX :: TyVarSet -- Template tyvars - -> TvSubst -- Substitution to extend - -> [Type] -- Template - -> [Type] -- Target - -> Maybe TvSubst -- One-shot; in principle the template - -- variables could be free in the target -tcMatchTysX tmpls (TvSubst in_scope subst_env) tys1 tys2 - = case match_tys menv subst_env tys1 tys2 of - Just subst_env' -> Just (TvSubst in_scope subst_env') - Nothing -> Nothing - where - menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } - -tcMatchPreds - :: [TyVar] -- Bind these - -> [PredType] -> [PredType] - -> Maybe TvSubstEnv -tcMatchPreds tmpls ps1 ps2 - = matchList (match menv) emptyTvSubstEnv ps1 ps2 - where - menv = ME { me_tmpls = mkVarSet tmpls, me_env = mkRnEnv2 in_scope_tyvars } - in_scope_tyvars = mkInScopeSet (tyVarsOfTypes ps1 `unionVarSet` tyVarsOfTypes ps2) - --- This one is called from the expression matcher, which already has a MatchEnv in hand -ruleMatchTyX :: MatchEnv - -> TvSubstEnv -- Substitution to extend - -> Type -- Template - -> Type -- Target - -> Maybe TvSubstEnv - -ruleMatchTyX menv subst ty1 ty2 = match menv subst ty1 ty2 -- Rename for export - --- Now the internals of matching - --- | Workhorse matching function. Our goal is to find a substitution --- on all of the template variables (specified by @me_tmpls menv@) such --- that @ty1@ and @ty2@ unify. This substitution is accumulated in @subst@. --- If a variable is not a template variable, we don't attempt to find a --- substitution for it; it must match exactly on both sides. Furthermore, --- only @ty1@ can have template variables. --- --- This function handles binders, see 'RnEnv2' for more details on --- how that works. -match :: MatchEnv -- For the most part this is pushed downwards - -> TvSubstEnv -- Substitution so far: - -- Domain is subset of template tyvars - -- Free vars of range is subset of - -- in-scope set of the RnEnv2 - -> Type -> Type -- Template and target respectively - -> Maybe TvSubstEnv - -match menv subst ty1 ty2 | Just ty1' <- coreView ty1 = match menv subst ty1' ty2 - | Just ty2' <- coreView ty2 = match menv subst ty1 ty2' - -match menv subst (TyVarTy tv1) ty2 - | Just ty1' <- lookupVarEnv subst tv1' -- tv1' is already bound - = if eqTypeX (nukeRnEnvL rn_env) ty1' ty2 - -- ty1 has no locally-bound variables, hence nukeRnEnvL - then Just subst - else Nothing -- ty2 doesn't match - - | tv1' `elemVarSet` me_tmpls menv - = if any (inRnEnvR rn_env) (tyVarsOfTypeList ty2) - then Nothing -- Occurs check - -- ezyang: Is this really an occurs check? It seems - -- to just reject matching \x. A against \x. x (maintaining - -- the invariant that the free vars of the range of @subst@ - -- are a subset of the in-scope set in @me_env menv@.) - else do { subst1 <- match_kind menv subst (tyVarKind tv1) (typeKind ty2) - -- Note [Matching kinds] - ; return (extendVarEnv subst1 tv1' ty2) } - - | otherwise -- tv1 is not a template tyvar - = case ty2 of - TyVarTy tv2 | tv1' == rnOccR rn_env tv2 -> Just subst - _ -> Nothing + = tcMatchTysX tmpls (mkEmptyTCvSubst in_scope) tys1 tys2 where - rn_env = me_env menv - tv1' = rnOccL rn_env tv1 - -match menv subst (ForAllTy tv1 ty1) (ForAllTy tv2 ty2) - = do { subst' <- match_kind menv subst (tyVarKind tv1) (tyVarKind tv2) - ; match menv' subst' ty1 ty2 } - where -- Use the magic of rnBndr2 to go under the binders - menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 } - -match menv subst (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 = match_tys menv subst tys1 tys2 -match menv subst (FunTy ty1a ty1b) (FunTy ty2a ty2b) - = do { subst' <- match menv subst ty1a ty2a - ; match menv subst' ty1b ty2b } -match menv subst (AppTy ty1a ty1b) ty2 - | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 - -- 'repSplit' used because the coreView stuff is done above - = do { subst' <- match menv subst ty1a ty2a - ; match menv subst' ty1b ty2b } - -match _ subst (LitTy x) (LitTy y) | x == y = return subst - -match _ _ _ _ - = Nothing - - - --------------- -match_kind :: MatchEnv -> TvSubstEnv -> Kind -> Kind -> Maybe TvSubstEnv --- Match the kind of the template tyvar with the kind of Type --- Note [Matching kinds] -match_kind menv subst k1 k2 - | k2 `isSubKind` k1 - = return subst - - | otherwise - = match menv subst k1 k2 - --- Note [Matching kinds] --- ~~~~~~~~~~~~~~~~~~~~~ --- For ordinary type variables, we don't want (m a) to match (n b) --- if say (a::*) and (b::*->*). This is just a yes/no issue. --- --- For coercion kinds matters are more complicated. If we have a --- coercion template variable co::a~[b], where a,b are presumably also --- template type variables, then we must match co's kind against the --- kind of the actual argument, so as to give bindings to a,b. --- --- In fact I have no example in mind that *requires* this kind-matching --- to instantiate template type variables, but it seems like the right --- thing to do. C.f. Note [Matching variable types] in Rules.hs - --------------- -match_tys :: MatchEnv -> TvSubstEnv -> [Type] -> [Type] -> Maybe TvSubstEnv -match_tys menv subst tys1 tys2 = matchList (match menv) subst tys1 tys2 - --------------- -matchList :: (env -> a -> b -> Maybe env) - -> env -> [a] -> [b] -> Maybe env -matchList _ subst [] [] = Just subst -matchList fn subst (a:as) (b:bs) = do { subst' <- fn subst a b - ; matchList fn subst' as bs } -matchList _ _ _ _ = Nothing + in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfTypes tys2) + -- We're assuming that all the interesting + -- tyvars in tys1 are in tmpls + +-- | Like 'tcMatchTys', but extending a substitution +tcMatchTysX :: TyCoVarSet -- ^ Template tyvars + -> TCvSubst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTysX tmpls (TCvSubst in_scope tv_env cv_env) tys1 tys2 +-- See Note [Kind coercions in Unify] + = case tc_unify_tys (matchBindFun tmpls) False False + (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 +ruleMatchTyX + :: TyCoVarSet -- ^ template variables + -> RnEnv2 + -> TvSubstEnv -- ^ type substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TvSubstEnv +ruleMatchTyX tmpl_tvs rn_env tenv tmpl target +-- See Note [Kind coercions in Unify] + = case tc_unify_tys (matchBindFun tmpl_tvs) False False 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 {- ************************************************************************ @@ -296,7 +195,7 @@ suffices. -- apart, even after arbitrary type function evaluation and substitution? typesCantMatch :: [(Type,Type)] -> Bool -- See Note [Pruning dead case alternatives] -typesCantMatch prs = any (\(s,t) -> cant_match s t) prs +typesCantMatch prs = any (uncurry cant_match) prs where cant_match :: Type -> Type -> Bool cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of @@ -389,83 +288,51 @@ usages won't notice this design choice. -} tcUnifyTy :: Type -> Type -- All tyvars are bindable - -> Maybe TvSubst -- A regular one-shot (idempotent) substitution + -> Maybe TCvSubst + -- A regular one-shot (idempotent) substitution -- Simple unification of two types; all type variables are bindable -tcUnifyTy ty1 ty2 - = case initUM (const BindMe) (unify ty1 ty2) of - Unifiable subst -> Just subst - _other -> Nothing +tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2] -- | Unify two types, treating type family applications as possibly unifying -- with anything and looking through injective type family applications. -tcUnifyTyWithTFs :: Bool -> Type -> Type -> Maybe TvSubst --- This algorithm is a direct implementation of the "Algorithm U" presented in --- the paper "Injective type families for Haskell", Figures 2 and 3. Equation --- numbers in the comments refer to equations from the paper. -tcUnifyTyWithTFs twoWay t1 t2 = niFixTvSubst `fmap` go t1 t2 emptyTvSubstEnv - where - go :: Type -> Type -> TvSubstEnv -> Maybe TvSubstEnv - -- look through type synonyms - go t1 t2 theta | Just t1' <- coreView t1 = go t1' t2 theta - go t1 t2 theta | Just t2' <- coreView t2 = go t1 t2' theta - -- proper unification - go (TyVarTy tv) t2 theta - -- Equation (1) - | Just t1' <- lookupVarEnv theta tv - = go t1' t2 theta - | otherwise = let t2' = Type.substTy (niFixTvSubst theta) t2 - in if tv `elemVarEnv` tyVarsOfType t2' - -- Equation (2) - then Just theta - -- Equation (3) - else Just $ extendVarEnv theta tv t2' - -- Equation (4) - go t1 t2@(TyVarTy _) theta | twoWay = go t2 t1 theta - -- Equation (5) - go (AppTy s1 s2) ty theta | Just(t1, t2) <- splitAppTy_maybe ty = - go s1 t1 theta >>= go s2 t2 - go ty (AppTy s1 s2) theta | Just(t1, t2) <- splitAppTy_maybe ty = - go s1 t1 theta >>= go s2 t2 - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) theta - -- Equation (6) - | isAlgTyCon tc1 && isAlgTyCon tc2 && tc1 == tc2 - = let tys = zip tys1 tys2 - in foldM (\theta' (t1,t2) -> go t1 t2 theta') theta tys - - -- Equation (7) - | isTypeFamilyTyCon tc1 && isTypeFamilyTyCon tc2 && tc1 == tc2 - , Injective inj <- familyTyConInjectivityInfo tc1 - = let tys1' = filterByList inj tys1 - tys2' = filterByList inj tys2 - injTys = zip tys1' tys2' - in foldM (\theta' (t1,t2) -> go t1 t2 theta') theta injTys - - -- Equations (8) - | isTypeFamilyTyCon tc1 - = Just theta - - -- Equations (9) - | isTypeFamilyTyCon tc2, twoWay - = Just theta - - -- Equation (10) - go _ _ _ = Nothing +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 + rn_env emptyTvSubstEnv emptyCvSubstEnv + [t1] [t2] of + Unifiable (subst, _) -> Just $ niFixTCvSubst subst + MaybeApart (subst, _) -> Just $ niFixTCvSubst subst + -- we want to *succeed* in questionable cases. This is a + -- pre-unification algorithm. + SurelyApart -> Nothing + where + rn_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [t1, t2] ----------------- -tcUnifyTys :: (TyVar -> BindFlag) +tcUnifyTys :: (TyCoVar -> BindFlag) -> [Type] -> [Type] - -> Maybe TvSubst -- A regular one-shot (idempotent) substitution + -> 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 subst -> Just subst - _ -> Nothing + 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 TvSubst +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 an most general unifier @@ -473,17 +340,71 @@ data UnifyResultM a = Unifiable a -- the subst that unifies the types | SurelyApart deriving Functor --- See Note [Fine-grained unification] +instance Applicative UnifyResultM where + pure = Unifiable + (<*>) = ap + +instance Monad UnifyResultM where + return = pure + + 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 where + mzero = Control.Applicative.empty + mplus = (<|>) + +-- | @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. tcUnifyTysFG :: (TyVar -> BindFlag) -> [Type] -> [Type] -> UnifyResult tcUnifyTysFG bind_fn tys1 tys2 - = initUM bind_fn (unify_tys tys1 tys2) + = do { (env, _) <- tc_unify_tys bind_fn True False 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) + -> Bool -- ^ True <=> unify; False <=> match + -> Bool -- ^ True <=> doing an injectivity check + -> RnEnv2 + -> TvSubstEnv -- ^ substitution to extend + -> CvSubstEnv + -> [Type] -> [Type] + -> UnifyResultM (TvSubstEnv, CvSubstEnv) +tc_unify_tys bind_fn unif inj_check rn_env tv_env cv_env tys1 tys2 + = initUM bind_fn unif inj_check rn_env tv_env cv_env $ + do { unify_tys kis1 kis2 + ; unify_tys tys1 tys2 + ; (,) <$> getTvSubstEnv <*> getCvSubstEnv } + where + kis1 = map typeKind tys1 + kis2 = map typeKind tys2 instance Outputable a => Outputable (UnifyResultM a) where - ppr SurelyApart = ptext (sLit "SurelyApart") - ppr (Unifiable x) = ptext (sLit "Unifiable") <+> ppr x - ppr (MaybeApart x) = ptext (sLit "MaybeApart") <+> ppr x + ppr SurelyApart = text "SurelyApart" + ppr (Unifiable x) = text "Unifiable" <+> ppr x + ppr (MaybeApart x) = text "MaybeApart" <+> ppr x {- ************************************************************************ @@ -494,7 +415,7 @@ instance Outputable a => Outputable (UnifyResultM a) where Note [Non-idempotent substitution] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During unification we use a TvSubstEnv that is +During unification we use a TvSubstEnv/CvSubstEnv pair that is (a) non-idempotent (b) loop-free; ie repeatedly applying it yields a fixed point @@ -520,41 +441,48 @@ This is the reason for extending env with [f:k -> f:*], in the definition of env' in niFixTvSubst -} -niFixTvSubst :: TvSubstEnv -> TvSubst +niFixTCvSubst :: TvSubstEnv -> TCvSubst -- Find the idempotent fixed point of the non-idempotent substitution -- See Note [Finding the substitution fixpoint] -- ToDo: use laziness instead of iteration? -niFixTvSubst env = f env +niFixTCvSubst tenv = f tenv where - f env | not_fixpoint = f (mapVarEnv (substTy subst') env) - | otherwise = subst + f tenv + | not_fixpoint = f (mapVarEnv (substTy subst') tenv) + | otherwise = subst where - not_fixpoint = foldVarSet ((||) . in_domain) False all_range_tvs - in_domain tv = tv `elemVarEnv` env + not_fixpoint = foldVarSet ((||) . in_domain) False range_tvs + in_domain tv = tv `elemVarEnv` tenv - range_tvs = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet env - all_range_tvs = closeOverKinds range_tvs - subst = mkTvSubst (mkInScopeSet all_range_tvs) env + range_tvs = foldVarEnv (unionVarSet . tyCoVarsOfType) emptyVarSet tenv + subst = mkTCvSubst (mkInScopeSet range_tvs) + (tenv, emptyCvSubstEnv) -- env' extends env by replacing any free type with -- that same tyvar with a substituted kind -- See note [Finding the substitution fixpoint] - env' = extendVarEnvList env [ (rtv, mkTyVarTy $ setTyVarKind rtv $ - substTy subst $ tyVarKind rtv) - | rtv <- varSetElems range_tvs - , not (in_domain rtv) ] - subst' = mkTvSubst (mkInScopeSet all_range_tvs) env' - -niSubstTvSet :: TvSubstEnv -> TyVarSet -> TyVarSet + tenv' = extendVarEnvList tenv [ (rtv, mkTyVarTy $ + setTyVarKind rtv $ + substTy subst $ + tyVarKind rtv) + | rtv <- varSetElems range_tvs + , not (in_domain rtv) ] + subst' = mkTCvSubst (mkInScopeSet range_tvs) + (tenv', emptyCvSubstEnv) + +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 subst tvs +niSubstTvSet tsubst tvs = foldVarSet (unionVarSet . get) emptyVarSet tvs where - get tv = case lookupVarEnv subst tv of - Nothing -> unitVarSet tv - Just ty -> niSubstTvSet subst (tyVarsOfType ty) + get tv + | Just ty <- lookupVarEnv tsubst tv + = niSubstTvSet tsubst (tyCoVarsOfType ty) + + | otherwise + = unitVarSet tv {- ************************************************************************ @@ -562,25 +490,184 @@ niSubstTvSet subst tvs The workhorse * * ************************************************************************ + +Note [Specification of unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 FamInstEnv (See Note [Flattening] in 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 musn'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). + +(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 an 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. + -} -unify :: Type -> Type -> UM () +-- See Note [Specification of unification] +unify_ty :: Type -> Type -> Coercion -- Types to be unified and a co + -- between their kinds + -- See Note [Kind coercions in Unify] + -> UM () -- Respects newtypes, PredTypes --- in unify, any NewTcApps/Preds should be taken at face value -unify (TyVarTy tv1) ty2 = uVar tv1 ty2 -unify ty1 (TyVarTy tv2) = uVar tv2 ty1 +unify_ty ty1 ty2 kco + | Just ty1' <- coreView ty1 = unify_ty ty1' ty2 kco + | Just ty2' <- coreView ty2 = unify_ty ty1 ty2' kco + | CastTy ty1' co <- ty1 = unify_ty ty1' ty2 (co `mkTransCo` kco) + | CastTy ty2' co <- ty2 = unify_ty ty1 ty2' (kco `mkTransCo` mkSymCo co) -unify ty1 ty2 | Just ty1' <- coreView ty1 = unify ty1' ty2 -unify ty1 ty2 | Just ty2' <- coreView ty2 = unify ty1 ty2' +unify_ty (TyVarTy tv1) ty2 kco = uVar tv1 ty2 kco +unify_ty ty1 (TyVarTy tv2) kco + = do { unif <- amIUnifying + ; if unif + then umSwapRn $ uVar tv2 ty1 (mkSymCo kco) + else surelyApart } -- non-tv on left; tv on right: can't match. -unify ty1 ty2 +unify_ty ty1 ty2 _kco | Just (tc1, tys1) <- splitTyConApp_maybe ty1 , Just (tc2, tys2) <- splitTyConApp_maybe ty2 - = if tc1 == tc2 + = if tc1 == tc2 || (isStarKind ty1 && isStarKind ty2) then if isInjectiveTyCon tc1 Nominal then unify_tys tys1 tys2 - else don'tBeSoSure $ unify_tys tys1 tys2 + else do { let inj | isTypeFamilyTyCon tc1 + = case familyTyConInjectivityInfo 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 inj_tys1 inj_tys2 + ; inj_tf <- checkingInjectivity + ; unless inj_tf $ -- See (end of) Note [Specification of unification] + don'tBeSoSure $ unify_tys noninj_tys1 noninj_tys2 } else -- tc1 /= tc2 if isGenerativeTyCon tc1 Nominal && isGenerativeTyCon tc2 Nominal then surelyApart @@ -588,109 +675,168 @@ unify ty1 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 and Notes, + -- NB: we've already dealt with type variables, -- so if one type is an App the other one jolly well better be too -unify (AppTy ty1a ty1b) ty2 - | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 - = do { unify ty1a ty2a - ; unify ty1b ty2b } - -unify ty1 (AppTy ty2a ty2b) - | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 - = do { unify ty1a ty2a - ; unify ty1b ty2b } - -unify (LitTy x) (LitTy y) | x == y = return () - -unify _ _ = surelyApart - -- ForAlls?? +unify_ty (AppTy ty1a ty1b) ty2 _kco + | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 + = unify_ty_app ty1a ty1b ty2a ty2b + +unify_ty ty1 (AppTy ty2a ty2b) _kco + | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 + = unify_ty_app ty1a ty1b ty2a ty2b + +unify_ty (LitTy x) (LitTy y) _kco | x == y = return () + +unify_ty (ForAllTy (Named tv1 _) ty1) (ForAllTy (Named tv2 _) ty2) kco + = do { unify_ty (tyVarKind tv1) (tyVarKind tv2) (mkNomReflCo liftedTypeKind) + ; umRnBndr2 tv1 tv2 $ unify_ty ty1 ty2 kco } + +-- See Note [Matching coercion variables] +unify_ty (CoercionTy co1) (CoercionTy co2) kco + = do { unif <- amIUnifying + ; c_subst <- getCvSubstEnv + ; case co1 of + CoVarCo cv + | not unif + , not (cv `elemVarEnv` c_subst) + -> do { b <- tvBindFlagL cv + ; if b == BindMe + then do { checkRnEnvRCo co2 + ; let [_, _, co_l, co_r] = decomposeCo 4 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) } + else return () } + _ -> return () } + +unify_ty ty1 _ _ + | Just (tc1, _) <- splitTyConApp_maybe ty1 + , not (isGenerativeTyCon tc1 Nominal) + = maybeApart + +unify_ty _ ty2 _ + | Just (tc2, _) <- splitTyConApp_maybe ty2 + , not (isGenerativeTyCon tc2 Nominal) + = do { unif <- amIUnifying + ; if unif then maybeApart else surelyApart } + +unify_ty _ _ _ = surelyApart + +unify_ty_app :: Type -> Type -> Type -> Type -> UM () +unify_ty_app ty1a ty1b ty2a ty2b + = do { -- TODO (RAE): Remove this exponential behavior. + let ki1a = typeKind ty1a + ki2a = typeKind ty2a + ; unify_ty ki1a ki2a (mkNomReflCo liftedTypeKind) + ; let kind_co = mkNomReflCo ki1a + ; unify_ty ty1a ty2a kind_co + ; unify_ty ty1b ty2b (mkNthCo 0 kind_co) } ------------------------------- unify_tys :: [Type] -> [Type] -> UM () unify_tys orig_xs orig_ys = go orig_xs orig_ys where go [] [] = return () - go (x:xs) (y:ys) = do { unify x y - ; go xs ys } + go (x:xs) (y:ys) + = do { unify_ty x y (mkNomReflCo $ typeKind x) + ; go xs ys } go _ _ = maybeApart -- See Note [Lists of different lengths are MaybeApart] --------------------------------- -uVar :: TyVar -- Type variable to be unified - -> Type -- with this type +uVar :: TyVar -- Variable to be unified + -> Type -- with this Type + -> Coercion -- :: kind tv ~N kind ty -> UM () -uVar tv1 ty - = do { subst <- umGetTvSubstEnv - -- Check to see whether tv1 is refined by the substitution +uVar tv1 ty kco + = do { -- Check to see whether tv1 is refined by the substitution + subst <- getTvSubstEnv ; case (lookupVarEnv subst tv1) of - Just ty' -> unify ty' ty -- Yes, call back into unify' - Nothing -> uUnrefined subst tv1 ty ty } -- No, continue - -uUnrefined :: TvSubstEnv -- environment to extend (from the UM monad) - -> TyVar -- Type variable to be unified - -> Type -- with this type - -> Type -- (version w/ expanded synonyms) + Just ty' -> do { unif <- amIUnifying + ; if unif + then unify_ty ty' ty kco -- Yes, call back into unify + else -- when *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' `eqType` ty) } + Nothing -> uUnrefined tv1 ty ty kco } -- No, continue + +uUnrefined :: TyVar -- 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 subst tv1 ty2 ty2' +uUnrefined tv1 ty2 ty2' kco | Just ty2'' <- coreView ty2' - = uUnrefined subst tv1 ty2 ty2'' -- Unwrap synonyms + = uUnrefined tv1 ty2 ty2'' kco -- Unwrap synonyms -- This is essential, in case we have -- type Foo a = a -- and then unify a ~ Foo a -uUnrefined subst tv1 ty2 (TyVarTy tv2) - | tv1 == tv2 -- Same type variable - = return () - - -- Check to see whether tv2 is refined - | Just ty' <- lookupVarEnv subst tv2 - = uUnrefined subst tv1 ty' ty' - - | otherwise - - = do { -- So both are unrefined; unify the kinds - ; unify (tyVarKind tv1) (tyVarKind tv2) + | TyVarTy tv2 <- ty2' + = do { tv1' <- umRnOccL tv1 + ; tv2' <- umRnOccR tv2 + ; unif <- amIUnifying + -- See Note [Self-substitution when matching] + ; when (tv1' /= tv2' || not unif) $ do + { subst <- getTvSubstEnv + -- Check to see whether tv2 is refined + ; case lookupVarEnv subst tv2 of + { Just ty' | unif -> uUnrefined tv1 ty' ty' kco + ; _ -> do + { -- So both are unrefined -- And then bind one or the other, -- depending on which is bindable - -- NB: unlike TcUnify we do not have an elaborate sub-kinding - -- story. That is relevant only during type inference, and - -- (I very much hope) is not relevant here. - ; b1 <- tvBindFlag tv1 - ; b2 <- tvBindFlag tv2 - ; let ty1 = TyVarTy tv1 + ; b1 <- tvBindFlagL tv1 + ; b2 <- tvBindFlagR tv2 + ; let ty1 = mkTyVarTy tv1 ; case (b1, b2) of - (Skolem, Skolem) -> maybeApart -- See Note [Unification with skolems] - (BindMe, _) -> extendSubst tv1 ty2 - (_, BindMe) -> extendSubst tv2 ty1 } - -uUnrefined subst tv1 ty2 ty2' -- ty2 is not a type variable - | tv1 `elemVarSet` niSubstTvSet subst (tyVarsOfType ty2') - = maybeApart -- Occurs check - -- See Note [Fine-grained unification] - | otherwise - = do { unify k1 k2 - -- Note [Kinds Containing Only Literals] - ; bindTv tv1 ty2 } -- Bind tyvar to the synonym if poss - where - k1 = tyVarKind tv1 - k2 = typeKind ty2' + (BindMe, _) -> do { checkRnEnvR ty2 -- make sure ty2 is not a local + ; extendTvEnv tv1 (ty2 `mkCastTy` mkSymCo kco) } + (_, BindMe) | unif -> do { checkRnEnvL ty1 -- ditto for ty1 + ; extendTvEnv 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 tv1 ty2 ty2' kco -- ty2 is not a type variable + = do { occurs <- elemNiSubstSet tv1 (tyCoVarsOfType ty2') + ; unif <- amIUnifying + ; if unif && occurs -- See Note [Self-substitution when matching] + then maybeApart -- Occurs check, see Note [Fine-grained unification] + else do bindTv tv1 (ty2 `mkCastTy` mkSymCo kco) } + -- Bind tyvar to the synonym if poss + +elemNiSubstSet :: TyVar -> TyCoVarSet -> UM Bool +elemNiSubstSet v set + = do { tsubst <- getTvSubstEnv + ; return $ v `elemVarSet` niSubstTvSet tsubst set } bindTv :: TyVar -> Type -> UM () -bindTv tv ty -- ty is not a type variable - = do { b <- tvBindFlag tv +bindTv tv ty -- ty is not a variable + = do { checkRnEnvR ty -- make sure ty mentions no local variables + ; b <- tvBindFlagL tv ; case b of Skolem -> maybeApart -- See Note [Unification with skolems] - BindMe -> extendSubst tv ty + BindMe -> extendTvEnv tv ty } {- -************************************************************************ -* * +%************************************************************************ +%* * Binding decisions * * ************************************************************************ @@ -701,6 +847,7 @@ data BindFlag | Skolem -- This type variable is a skolem constant -- Don't bind it; it only matches itself + deriving Eq {- ************************************************************************ @@ -710,56 +857,336 @@ data BindFlag ************************************************************************ -} -newtype UM a = UM { unUM :: (TyVar -> BindFlag) - -> TvSubstEnv - -> UnifyResultM (a, TvSubstEnv) } +data UMEnv = UMEnv { um_bind_fun :: TyVar -> BindFlag + -- the user-supplied BindFlag function + , um_unif :: Bool -- unification (True) or matching? + , um_inj_tf :: Bool -- checking for injectivity? + -- See (end of) Note [Specification of unification] + , um_rn_env :: RnEnv2 } + +data UMState = UMState + { um_tv_env :: TvSubstEnv + , um_cv_env :: CvSubstEnv } + +newtype UM a = UM { unUM :: UMEnv -> UMState + -> UnifyResultM (UMState, a) } instance Functor UM where fmap = liftM instance Applicative UM where - pure a = UM (\_tvs subst -> Unifiable (a, subst)) - (<*>) = ap + pure a = UM (\_ s -> pure (s, a)) + (<*>) = ap instance Monad UM where return = pure - fail _ = UM (\_tvs _subst -> SurelyApart) -- failed pattern match - m >>= k = UM (\tvs subst -> case unUM m tvs subst of - Unifiable (v, subst') -> unUM (k v) tvs subst' - MaybeApart (v, subst') -> - case unUM (k v) tvs subst' of - Unifiable (v', subst'') -> MaybeApart (v', subst'') - other -> other - SurelyApart -> SurelyApart) + fail _ = UM (\_ _ -> SurelyApart) -- failed pattern match + m >>= k = UM (\env state -> + do { (state', v) <- unUM m env state + ; unUM (k v) env state' }) + +instance Alternative UM where + empty = UM (\_ _ -> mzero) + m1 <|> m2 = UM (\env state -> + unUM m1 env state <|> + unUM m2 env state) + + -- need this instance because of a use of 'guard' above +instance MonadPlus UM where + mzero = Control.Applicative.empty + mplus = (<|>) #if __GLASGOW_HASKELL__ > 710 instance MonadFail.MonadFail UM where fail _ = UM (\_tvs _subst -> SurelyApart) -- failed pattern match #endif --- returns an idempotent substitution -initUM :: (TyVar -> BindFlag) -> UM () -> UnifyResult -initUM badtvs um = fmap (niFixTvSubst . snd) $ unUM um badtvs emptyTvSubstEnv +initUM :: (TyVar -> BindFlag) + -> Bool -- True <=> unify; False <=> match + -> Bool -- True <=> doing an injectivity check + -> RnEnv2 + -> TvSubstEnv -- subst to extend + -> CvSubstEnv + -> UM a -> UnifyResultM a +initUM badtvs unif inj_tf rn_env subst_env cv_subst_env um + = case unUM um env state of + Unifiable (_, subst) -> Unifiable subst + MaybeApart (_, subst) -> MaybeApart subst + SurelyApart -> SurelyApart + where + env = UMEnv { um_bind_fun = badtvs + , um_unif = unif + , um_inj_tf = inj_tf + , um_rn_env = rn_env } + state = UMState { um_tv_env = subst_env + , um_cv_env = cv_subst_env } + +tvBindFlagL :: TyVar -> UM BindFlag +tvBindFlagL tv = UM $ \env state -> + Unifiable (state, if inRnEnvL (um_rn_env env) tv + then Skolem + else um_bind_fun env tv) + +tvBindFlagR :: TyVar -> UM BindFlag +tvBindFlagR tv = UM $ \env state -> + Unifiable (state, if inRnEnvR (um_rn_env env) tv + then Skolem + else 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) + +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 :: TyCoVar -> TyCoVar -> UM a -> UM a +umRnBndr2 v1 v2 thing = UM $ \env state -> + let rn_env' = rnBndr2 (um_rn_env env) v1 v2 in + unUM thing (env { um_rn_env = rn_env' }) state + +checkRnEnv :: (RnEnv2 -> Var -> Bool) -> VarSet -> UM () +checkRnEnv inRnEnv varset = UM $ \env state -> + if any (inRnEnv (um_rn_env env)) (varSetElems varset) + then MaybeApart (state, ()) + else Unifiable (state, ()) + +-- | Converts any SurelyApart to a MaybeApart +don'tBeSoSure :: UM () -> UM () +don'tBeSoSure um = UM $ \env state -> + case unUM um env state of + SurelyApart -> MaybeApart (state, ()) + other -> other -tvBindFlag :: TyVar -> UM BindFlag -tvBindFlag tv = UM (\tv_fn subst -> Unifiable (tv_fn tv, subst)) +checkRnEnvR :: Type -> UM () +checkRnEnvR ty = checkRnEnv inRnEnvR (tyCoVarsOfType ty) --- | Extend the TvSubstEnv in the UM monad -extendSubst :: TyVar -> Type -> UM () -extendSubst tv ty = UM (\_tv_fn subst -> Unifiable ((), extendVarEnv subst tv ty)) +checkRnEnvL :: Type -> UM () +checkRnEnvL ty = checkRnEnv inRnEnvL (tyCoVarsOfType ty) --- | Retrive the TvSubstEnv from the UM monad -umGetTvSubstEnv :: UM TvSubstEnv -umGetTvSubstEnv = UM $ \_tv_fn subst -> Unifiable (subst, subst) +checkRnEnvRCo :: Coercion -> UM () +checkRnEnvRCo co = checkRnEnv inRnEnvR (tyCoVarsOfCo co) --- | Converts any SurelyApart to a MaybeApart -don'tBeSoSure :: UM () -> UM () -don'tBeSoSure um = UM $ \tv_fn subst -> case unUM um tv_fn subst of - SurelyApart -> MaybeApart ((), subst) - other -> other +umRnOccL :: TyVar -> UM TyVar +umRnOccL v = UM $ \env state -> + Unifiable (state, rnOccL (um_rn_env env) v) + +umRnOccR :: TyVar -> UM TyVar +umRnOccR v = UM $ \env state -> + Unifiable (state, rnOccR (um_rn_env env) v) + +umSwapRn :: UM a -> UM a +umSwapRn thing = UM $ \env state -> + let rn_env' = rnSwap (um_rn_env env) in + unUM thing (env { um_rn_env = rn_env' }) state + +amIUnifying :: UM Bool +amIUnifying = UM $ \env state -> Unifiable (state, um_unif env) + +checkingInjectivity :: UM Bool +checkingInjectivity = UM $ \env state -> Unifiable (state, um_inj_tf env) maybeApart :: UM () -maybeApart = UM (\_tv_fn subst -> MaybeApart ((), subst)) +maybeApart = UM (\_ state -> MaybeApart (state, ())) surelyApart :: UM a -surelyApart = UM (\_tv_fn _subst -> SurelyApart) +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 @tyCoSubst s ty == co@, +-- where @==@ there means that the result of tyCoSubst 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' <- coreViewOneStarKind 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 = foldVarSet (\v rest -> rest && (not $ f v)) True + +ty_co_match menv subst ty co lkco rkco + | CastTy ty' co' <- ty + = ty_co_match menv subst ty' co (co' `mkTransCo` lkco) (co' `mkTransCo` rkco) + + | CoherenceCo co1 co2 <- co + = ty_co_match menv subst ty co1 (lkco `mkTransCo` mkSymCo co2) 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' $ + castCoercionKind 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 (ForAllTy (Anon ty1) ty2) (TyConAppCo _ tc cos) _lkco _rkco + = ty_co_match_tc menv subst funTyCon [ty1, ty2] tc cos + +ty_co_match menv subst (ForAllTy (Named tv1 _) ty1) + (ForAllCo tv2 kind_co2 co2) + lkco rkco + = 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 _ subst (CoercionTy {}) _ _ _ + = Just subst -- don't inspect coercions + +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 ty1a ty1b co2a co2b + = do { -- TODO (RAE): Remove this exponential behavior. + subst1 <- ty_co_match menv subst ki1a ki2a ki_ki_co ki_ki_co + ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2a + ; subst2 <- ty_co_match menv subst1 ty1a co2a lkco rkco + ; ty_co_match menv subst2 ty1b co2b (mkNthCo 0 lkco) (mkNthCo 0 rkco) } + where + ki1a = typeKind ty1a + ki2a = promoteCoercion co2a + 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 (Refl Nominal (AppTy ty1 ty2)) + = Just (AppCo (Refl Nominal ty1) (mkNomReflCo ty2)) +pushRefl (Refl r (ForAllTy (Anon ty1) ty2)) + = Just (TyConAppCo r funTyCon [mkReflCo r ty1, mkReflCo r ty2]) +pushRefl (Refl r (TyConApp tc tys)) + = Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) +pushRefl (Refl r (ForAllTy (Named tv _) ty)) + = Just (mkHomoForAllCos_NoRefl [tv] (Refl r ty)) + -- NB: NoRefl variant. Otherwise, we get a loop! +pushRefl (Refl r (CastTy ty co)) = Just (castCoercionKind (Refl r ty) co co) +pushRefl _ = Nothing |