diff options
Diffstat (limited to 'compiler/typecheck')
66 files changed, 2 insertions, 82236 deletions
diff --git a/compiler/typecheck/ClsInst.hs b/compiler/typecheck/ClsInst.hs deleted file mode 100644 index 3c33c59180..0000000000 --- a/compiler/typecheck/ClsInst.hs +++ /dev/null @@ -1,714 +0,0 @@ -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module ClsInst ( - matchGlobalInst, - ClsInstResult(..), - InstanceWhat(..), safeOverlap, instanceReturnsDictCon, - AssocInstInfo(..), isNotAssociated - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcEnv -import TcRnMonad -import TcType -import TcTypeable -import TcMType -import TcEvidence -import GHC.Core.Predicate -import GHC.Rename.Env( addUsedGRE ) -import GHC.Types.Name.Reader( lookupGRE_FieldLabel ) -import GHC.Core.InstEnv -import Inst( instDFunType ) -import FamInst( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst ) - -import TysWiredIn -import TysPrim( eqPrimTyCon, eqReprPrimTyCon ) -import PrelNames - -import GHC.Types.Id -import GHC.Core.Type -import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr ) - -import GHC.Types.Name ( Name, pprDefinedAt ) -import GHC.Types.Var.Env ( VarEnv ) -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Core.Class -import GHC.Driver.Session -import Outputable -import Util( splitAtList, fstOf3 ) -import Data.Maybe - -{- ******************************************************************* -* * - A helper for associated types within - class instance declarations -* * -**********************************************************************-} - --- | Extra information about the parent instance declaration, needed --- when type-checking associated types. The 'Class' is the enclosing --- class, the [TyVar] are the /scoped/ type variable of the instance decl. --- The @VarEnv Type@ maps class variables to their instance types. -data AssocInstInfo - = NotAssociated - | InClsInst { ai_class :: Class - , ai_tyvars :: [TyVar] -- ^ The /scoped/ tyvars of the instance - -- Why scoped? See bind_me in - -- TcValidity.checkConsistentFamInst - , ai_inst_env :: VarEnv Type -- ^ Maps /class/ tyvars to their instance types - -- See Note [Matching in the consistent-instantiation check] - } - -isNotAssociated :: AssocInstInfo -> Bool -isNotAssociated NotAssociated = True -isNotAssociated (InClsInst {}) = False - - -{- ******************************************************************* -* * - Class lookup -* * -**********************************************************************-} - --- | Indicates if Instance met the Safe Haskell overlapping instances safety --- check. --- --- See Note [Safe Haskell Overlapping Instances] in TcSimplify --- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -type SafeOverlapping = Bool - -data ClsInstResult - = NoInstance -- Definitely no instance - - | OneInst { cir_new_theta :: [TcPredType] - , cir_mk_ev :: [EvExpr] -> EvTerm - , cir_what :: InstanceWhat } - - | NotSure -- Multiple matches and/or one or more unifiers - -data InstanceWhat - = BuiltinInstance - | BuiltinEqInstance -- A built-in "equality instance"; see the - -- TcSMonad Note [Solved dictionaries] - | LocalInstance - | TopLevInstance { iw_dfun_id :: DFunId - , iw_safe_over :: SafeOverlapping } - -instance Outputable ClsInstResult where - ppr NoInstance = text "NoInstance" - ppr NotSure = text "NotSure" - ppr (OneInst { cir_new_theta = ev - , cir_what = what }) - = text "OneInst" <+> vcat [ppr ev, ppr what] - -instance Outputable InstanceWhat where - ppr BuiltinInstance = text "a built-in instance" - ppr BuiltinEqInstance = text "a built-in equality instance" - ppr LocalInstance = text "a locally-quantified instance" - ppr (TopLevInstance { iw_dfun_id = dfun }) - = hang (text "instance" <+> pprSigmaType (idType dfun)) - 2 (text "--" <+> pprDefinedAt (idName dfun)) - -safeOverlap :: InstanceWhat -> Bool -safeOverlap (TopLevInstance { iw_safe_over = so }) = so -safeOverlap _ = True - -instanceReturnsDictCon :: InstanceWhat -> Bool --- See Note [Solved dictionaries] in TcSMonad -instanceReturnsDictCon (TopLevInstance {}) = True -instanceReturnsDictCon BuiltinInstance = True -instanceReturnsDictCon BuiltinEqInstance = False -instanceReturnsDictCon LocalInstance = False - -matchGlobalInst :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcM ClsInstResult -matchGlobalInst dflags short_cut clas tys - | cls_name == knownNatClassName - = matchKnownNat dflags short_cut clas tys - | cls_name == knownSymbolClassName - = matchKnownSymbol dflags short_cut clas tys - | isCTupleClass clas = matchCTuple clas tys - | cls_name == typeableClassName = matchTypeable clas tys - | clas `hasKey` heqTyConKey = matchHeteroEquality tys - | clas `hasKey` eqTyConKey = matchHomoEquality tys - | clas `hasKey` coercibleTyConKey = matchCoercible tys - | cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys - | otherwise = matchInstEnv dflags short_cut clas tys - where - cls_name = className clas - - -{- ******************************************************************** -* * - Looking in the instance environment -* * -***********************************************************************-} - - -matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult -matchInstEnv dflags short_cut_solver clas tys - = do { instEnvs <- tcGetInstEnvs - ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy] - (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys - safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps) - ; traceTc "matchInstEnv" $ - vcat [ text "goal:" <+> ppr clas <+> ppr tys - , text "matches:" <+> ppr matches - , text "unify:" <+> ppr unify ] - ; case (matches, unify, safeHaskFail) of - - -- Nothing matches - ([], [], _) - -> do { traceTc "matchClass not matching" (ppr pred) - ; return NoInstance } - - -- A single match (& no safe haskell failure) - ([(ispec, inst_tys)], [], False) - | short_cut_solver -- Called from the short-cut solver - , isOverlappable ispec - -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT - -- then don't let the short-cut solver choose it, because a - -- later instance might overlap it. #14434 is an example - -- See Note [Shortcut solving: overlap] - -> do { traceTc "matchClass: ignoring overlappable" (ppr pred) - ; return NotSure } - - | otherwise - -> do { let dfun_id = instanceDFunId ispec - ; traceTc "matchClass success" $ - vcat [text "dict" <+> ppr pred, - text "witness" <+> ppr dfun_id - <+> ppr (idType dfun_id) ] - -- Record that this dfun is needed - ; match_one (null unsafeOverlaps) dfun_id inst_tys } - - -- More than one matches (or Safe Haskell fail!). Defer any - -- reactions of a multitude until we learn more about the reagent - _ -> do { traceTc "matchClass multiple matches, deferring choice" $ - vcat [text "dict" <+> ppr pred, - text "matches" <+> ppr matches] - ; return NotSure } } - where - pred = mkClassPred clas tys - -match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult - -- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv -match_one so dfun_id mb_inst_tys - = do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys) - ; (tys, theta) <- instDFunType dfun_id mb_inst_tys - ; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta) - ; return $ OneInst { cir_new_theta = theta - , cir_mk_ev = evDFunApp dfun_id tys - , cir_what = TopLevInstance { iw_dfun_id = dfun_id - , iw_safe_over = so } } } - - -{- Note [Shortcut solving: overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - instance {-# OVERLAPPABLE #-} C a where ... -and we are typechecking - f :: C a => a -> a - f = e -- Gives rise to [W] C a - -We don't want to solve the wanted constraint with the overlappable -instance; rather we want to use the supplied (C a)! That was the whole -point of it being overlappable! #14434 wwas an example. - -Alas even if the instance has no overlap flag, thus - instance C a where ... -there is nothing to stop it being overlapped. GHC provides no way to -declare an instance as "final" so it can't be overlapped. But really -only final instances are OK for short-cut solving. Sigh. #15135 -was a puzzling example. --} - - -{- ******************************************************************** -* * - Class lookup for CTuples -* * -***********************************************************************-} - -matchCTuple :: Class -> [Type] -> TcM ClsInstResult -matchCTuple clas tys -- (isCTupleClass clas) holds - = return (OneInst { cir_new_theta = tys - , cir_mk_ev = tuple_ev - , cir_what = BuiltinInstance }) - -- The dfun *is* the data constructor! - where - data_con = tyConSingleDataCon (classTyCon clas) - tuple_ev = evDFunApp (dataConWrapId data_con) tys - -{- ******************************************************************** -* * - Class lookup for Literals -* * -***********************************************************************-} - -{- -Note [KnownNat & KnownSymbol and EvLit] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A part of the type-level literals implementation are the classes -"KnownNat" and "KnownSymbol", which provide a "smart" constructor for -defining singleton values. Here is the key stuff from GHC.TypeLits - - class KnownNat (n :: Nat) where - natSing :: SNat n - - newtype SNat (n :: Nat) = SNat Integer - -Conceptually, this class has infinitely many instances: - - instance KnownNat 0 where natSing = SNat 0 - instance KnownNat 1 where natSing = SNat 1 - instance KnownNat 2 where natSing = SNat 2 - ... - -In practice, we solve `KnownNat` predicates in the type-checker -(see typecheck/TcInteract.hs) because we can't have infinitely many instances. -The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`. - -We make the following assumptions about dictionaries in GHC: - 1. The "dictionary" for classes with a single method---like `KnownNat`---is - a newtype for the type of the method, so using a evidence amounts - to a coercion, and - 2. Newtypes use the same representation as their definition types. - -So, the evidence for `KnownNat` is just a value of the representation type, -wrapped in two newtype constructors: one to make it into a `SNat` value, -and another to make it into a `KnownNat` dictionary. - -Also note that `natSing` and `SNat` are never actually exposed from the -library---they are just an implementation detail. Instead, users see -a more convenient function, defined in terms of `natSing`: - - natVal :: KnownNat n => proxy n -> Integer - -The reason we don't use this directly in the class is that it is simpler -and more efficient to pass around an integer rather than an entire function, -especially when the `KnowNat` evidence is packaged up in an existential. - -The story for kind `Symbol` is analogous: - * class KnownSymbol - * newtype SSymbol - * Evidence: a Core literal (e.g. mkNaturalExpr) - - -Note [Fabricating Evidence for Literals in Backpack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Let `T` be a type of kind `Nat`. When solving for a purported instance -of `KnownNat T`, ghc tries to resolve the type `T` to an integer `n`, -in which case the evidence `EvLit (EvNum n)` is generated on the -fly. It might appear that this is sufficient as users cannot define -their own instances of `KnownNat`. However, for backpack module this -would not work (see issue #15379). Consider the signature `Abstract` - -> signature Abstract where -> data T :: Nat -> instance KnownNat T - -and a module `Util` that depends on it: - -> module Util where -> import Abstract -> printT :: IO () -> printT = do print $ natVal (Proxy :: Proxy T) - -Clearly, we need to "use" the dictionary associated with `KnownNat T` -in the module `Util`, but it is too early for the compiler to produce -a real dictionary as we still have not fixed what `T` is. Only when we -mixin a concrete module - -> module Concrete where -> type T = 42 - -do we really get hold of the underlying integer. So the strategy that -we follow is the following - -1. If T is indeed available as a type alias for an integer constant, - generate the dictionary on the fly, failing which - -2. Look up the type class environment for the evidence. - -Finally actual code gets generate for Util only when a module like -Concrete gets "mixed-in" in place of the signature Abstract. As a -result all things, including the typeclass instances, in Concrete gets -reexported. So `KnownNat` gets resolved the normal way post-Backpack. - -A similar generation works for `KnownSymbol` as well - --} - -matchKnownNat :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcM ClsInstResult -matchKnownNat _ _ clas [ty] -- clas = KnownNat - | Just n <- isNumLitTy ty = do - et <- mkNaturalExpr n - makeLitDict clas ty et -matchKnownNat df sc clas tys = matchInstEnv df sc clas tys - -- See Note [Fabricating Evidence for Literals in Backpack] for why - -- this lookup into the instance environment is required. - -matchKnownSymbol :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcM ClsInstResult -matchKnownSymbol _ _ clas [ty] -- clas = KnownSymbol - | Just s <- isStrLitTy ty = do - et <- mkStringExprFS s - makeLitDict clas ty et -matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys - -- See Note [Fabricating Evidence for Literals in Backpack] for why - -- this lookup into the instance environment is required. - -makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult --- makeLitDict adds a coercion that will convert the literal into a dictionary --- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit] --- in TcEvidence. The coercion happens in 2 steps: --- --- Integer -> SNat n -- representation of literal to singleton --- SNat n -> KnownNat n -- singleton to dictionary --- --- The process is mirrored for Symbols: --- String -> SSymbol n --- SSymbol n -> KnownSymbol n -makeLitDict clas ty et - | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty] - -- co_dict :: KnownNat n ~ SNat n - , [ meth ] <- classMethods clas - , Just tcRep <- tyConAppTyCon_maybe -- SNat - $ funResultTy -- SNat n - $ dropForAlls -- KnownNat n => SNat n - $ idType meth -- forall n. KnownNat n => SNat n - , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] - -- SNat n ~ Integer - , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep)) - = return $ OneInst { cir_new_theta = [] - , cir_mk_ev = \_ -> ev_tm - , cir_what = BuiltinInstance } - - | otherwise - = pprPanic "makeLitDict" $ - text "Unexpected evidence for" <+> ppr (className clas) - $$ vcat (map (ppr . idType) (classMethods clas)) - -{- ******************************************************************** -* * - Class lookup for Typeable -* * -***********************************************************************-} - --- | Assumes that we've checked that this is the 'Typeable' class, --- and it was applied to the correct argument. -matchTypeable :: Class -> [Type] -> TcM ClsInstResult -matchTypeable clas [k,t] -- clas = Typeable - -- For the first two cases, See Note [No Typeable for polytypes or qualified types] - | isForAllTy k = return NoInstance -- Polytype - | isJust (tcSplitPredFunTy_maybe t) = return NoInstance -- Qualified type - - -- Now cases that do work - | k `eqType` typeNatKind = doTyLit knownNatClassName t - | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t - | tcIsConstraintKind t = doTyConApp clas t constraintKindTyCon [] - | Just (arg,ret) <- splitFunTy_maybe t = doFunTy clas t arg ret - | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] - , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks - | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt - -matchTypeable _ _ = return NoInstance - --- | Representation for a type @ty@ of the form @arg -> ret@. -doFunTy :: Class -> Type -> Type -> Type -> TcM ClsInstResult -doFunTy clas ty arg_ty ret_ty - = return $ OneInst { cir_new_theta = preds - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } - where - preds = map (mk_typeable_pred clas) [arg_ty, ret_ty] - mk_ev [arg_ev, ret_ev] = evTypeable ty $ - EvTypeableTrFun (EvExpr arg_ev) (EvExpr ret_ev) - mk_ev _ = panic "TcInteract.doFunTy" - - --- | Representation for type constructor applied to some kinds. --- 'onlyNamedBndrsApplied' has ensured that this application results in a type --- of monomorphic kind (e.g. all kind variables have been instantiated). -doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult -doTyConApp clas ty tc kind_args - | tyConIsTypeable tc - = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args) - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } - | otherwise - = return NoInstance - where - mk_ev kinds = evTypeable ty $ EvTypeableTyCon tc (map EvExpr kinds) - --- | Representation for TyCon applications of a concrete kind. We just use the --- kind itself, but first we must make sure that we've instantiated all kind- --- polymorphism, but no more. -onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool -onlyNamedBndrsApplied tc ks - = all isNamedTyConBinder used_bndrs && - not (any isNamedTyConBinder leftover_bndrs) - where - bndrs = tyConBinders tc - (used_bndrs, leftover_bndrs) = splitAtList ks bndrs - -doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult --- Representation for an application of a type to a type-or-kind. --- This may happen when the type expression starts with a type variable. --- Example (ignoring kind parameter): --- Typeable (f Int Char) --> --- (Typeable (f Int), Typeable Char) --> --- (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) --- Typeable f -doTyApp clas ty f tk - | isForAllTy (tcTypeKind f) - = return NoInstance -- We can't solve until we know the ctr. - | otherwise - = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk] - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } - where - mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2) - mk_ev _ = panic "doTyApp" - - --- Emit a `Typeable` constraint for the given type. -mk_typeable_pred :: Class -> Type -> PredType -mk_typeable_pred clas ty = mkClassPred clas [ tcTypeKind ty, ty ] - - -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal - -- we generate a sub-goal for the appropriate class. - -- See Note [Typeable for Nat and Symbol] -doTyLit :: Name -> Type -> TcM ClsInstResult -doTyLit kc t = do { kc_clas <- tcLookupClass kc - ; let kc_pred = mkClassPred kc_clas [ t ] - mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev) - mk_ev _ = panic "doTyLit" - ; return (OneInst { cir_new_theta = [kc_pred] - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance }) } - -{- Note [Typeable (T a b c)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For type applications we always decompose using binary application, -via doTyApp, until we get to a *kind* instantiation. Example - Proxy :: forall k. k -> * - -To solve Typeable (Proxy (* -> *) Maybe) we - - First decompose with doTyApp, - to get (Typeable (Proxy (* -> *))) and Typeable Maybe - - Then solve (Typeable (Proxy (* -> *))) with doTyConApp - -If we attempt to short-cut by solving it all at once, via -doTyConApp - -(this note is sadly truncated FIXME) - - -Note [No Typeable for polytypes or qualified types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not support impredicative typeable, such as - Typeable (forall a. a->a) - Typeable (Eq a => a -> a) - Typeable (() => Int) - Typeable (((),()) => Int) - -See #9858. For forall's the case is clear: we simply don't have -a TypeRep for them. For qualified but not polymorphic types, like -(Eq a => a -> a), things are murkier. But: - - * We don't need a TypeRep for these things. TypeReps are for - monotypes only. - - * Perhaps we could treat `=>` as another type constructor for `Typeable` - purposes, and thus support things like `Eq Int => Int`, however, - at the current state of affairs this would be an odd exception as - no other class works with impredicative types. - For now we leave it off, until we have a better story for impredicativity. - - -Note [Typeable for Nat and Symbol] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have special Typeable instances for Nat and Symbol. Roughly we -have this instance, implemented here by doTyLit: - instance KnownNat n => Typeable (n :: Nat) where - typeRep = typeNatTypeRep @n -where - Data.Typeable.Internals.typeNatTypeRep :: KnownNat a => TypeRep a - -Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a -runtime value 'n'; it turns it into a string with 'show' and uses -that to whiz up a TypeRep TyCon for 'n', with mkTypeLitTyCon. -See #10348. - -Because of this rule it's inadvisable (see #15322) to have a constraint - f :: (Typeable (n :: Nat)) => blah -in a function signature; it gives rise to overlap problems just as -if you'd written - f :: Eq [a] => blah --} - -{- ******************************************************************** -* * - Class lookup for lifted equality -* * -***********************************************************************-} - --- See also Note [The equality types story] in TysPrim -matchHeteroEquality :: [Type] -> TcM ClsInstResult --- Solves (t1 ~~ t2) -matchHeteroEquality args - = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ] - , cir_mk_ev = evDataConApp heqDataCon args - , cir_what = BuiltinEqInstance }) - -matchHomoEquality :: [Type] -> TcM ClsInstResult --- Solves (t1 ~ t2) -matchHomoEquality args@[k,t1,t2] - = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ] - , cir_mk_ev = evDataConApp eqDataCon args - , cir_what = BuiltinEqInstance }) -matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args) - --- See also Note [The equality types story] in TysPrim -matchCoercible :: [Type] -> TcM ClsInstResult -matchCoercible args@[k, t1, t2] - = return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ] - , cir_mk_ev = evDataConApp coercibleDataCon args - , cir_what = BuiltinEqInstance }) - where - args' = [k, k, t1, t2] -matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args) - - -{- ******************************************************************** -* * - Class lookup for overloaded record fields -* * -***********************************************************************-} - -{- -Note [HasField instances] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - data T y = MkT { foo :: [y] } - -and `foo` is in scope. Then GHC will automatically solve a constraint like - - HasField "foo" (T Int) b - -by emitting a new wanted - - T alpha -> [alpha] ~# T Int -> b - -and building a HasField dictionary out of the selector function `foo`, -appropriately cast. - -The HasField class is defined (in GHC.Records) thus: - - class HasField (x :: k) r a | x r -> a where - getField :: r -> a - -Since this is a one-method class, it is represented as a newtype. -Hence we can solve `HasField "foo" (T Int) b` by taking an expression -of type `T Int -> b` and casting it using the newtype coercion. -Note that - - foo :: forall y . T y -> [y] - -so the expression we construct is - - foo @alpha |> co - -where - - co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b - -is built from - - co1 :: (T alpha -> [alpha]) ~# (T Int -> b) - -which is the new wanted, and - - co2 :: (T Int -> b) ~# HasField "foo" (T Int) b - -which can be derived from the newtype coercion. - -If `foo` is not in scope, or has a higher-rank or existentially -quantified type, then the constraint is not solved automatically, but -may be solved by a user-supplied HasField instance. Similarly, if we -encounter a HasField constraint where the field is not a literal -string, or does not belong to the type, then we fall back on the -normal constraint solver behaviour. --} - --- See Note [HasField instances] -matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult -matchHasField dflags short_cut clas tys - = do { fam_inst_envs <- tcGetFamInstEnvs - ; rdr_env <- getGlobalRdrEnv - ; case tys of - -- We are matching HasField {k} x r a... - [_k_ty, x_ty, r_ty, a_ty] - -- x should be a literal string - | Just x <- isStrLitTy x_ty - -- r should be an applied type constructor - , Just (tc, args) <- tcSplitTyConApp_maybe r_ty - -- use representation tycon (if data family); it has the fields - , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args) - -- x should be a field of r - , Just fl <- lookupTyConFieldLabel x r_tc - -- the field selector should be in scope - , Just gre <- lookupGRE_FieldLabel rdr_env fl - - -> do { sel_id <- tcLookupId (flSelector fl) - ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id - - -- The first new wanted constraint equates the actual - -- type of the selector with the type (r -> a) within - -- the HasField x r a dictionary. The preds will - -- typically be empty, but if the datatype has a - -- "stupid theta" then we have to include it here. - ; let theta = mkPrimEqPred sel_ty (mkVisFunTy r_ty a_ty) : preds - - -- Use the equality proof to cast the selector Id to - -- type (r -> a), then use the newtype coercion to cast - -- it to a HasField dictionary. - mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co - where - co = mkTcSubCo (evTermCoercion (EvExpr ev1)) - `mkTcTransCo` mkTcSymCo co2 - mk_ev [] = panic "matchHasField.mk_ev" - - Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas) - tys - - tvs = mkTyVarTys (map snd tv_prs) - - -- The selector must not be "naughty" (i.e. the field - -- cannot have an existentially quantified type), and - -- it must not be higher-rank. - ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty - then do { addUsedGRE True gre - ; return OneInst { cir_new_theta = theta - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } } - else matchInstEnv dflags short_cut clas tys } - - _ -> matchInstEnv dflags short_cut clas tys } diff --git a/compiler/typecheck/Constraint.hs b/compiler/typecheck/Constraint.hs deleted file mode 100644 index 1ca3d4b405..0000000000 --- a/compiler/typecheck/Constraint.hs +++ /dev/null @@ -1,1819 +0,0 @@ -{- - -This module defines types and simple operations over constraints, -as used in the type-checker and constraint solver. - --} - -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module Constraint ( - -- QCInst - QCInst(..), isPendingScInst, - - -- Canonical constraints - Xi, Ct(..), Cts, CtIrredStatus(..), emptyCts, andCts, andManyCts, pprCts, - singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, - isEmptyCts, isCTyEqCan, isCFunEqCan, - isPendingScDict, superClassesMightHelp, getPendingWantedScs, - isCDictCan_Maybe, isCFunEqCan_maybe, - isCNonCanonical, isWantedCt, isDerivedCt, - isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt, - isUserTypeErrorCt, getUserTypeErrorMsg, - ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, - ctEvId, mkTcEqPredLikeEv, - mkNonCanonical, mkNonCanonicalCt, mkGivens, - mkIrredCt, - ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, - ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, - tyCoVarsOfCt, tyCoVarsOfCts, - tyCoVarsOfCtList, tyCoVarsOfCtsList, - - WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, - isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC, - addInsols, insolublesOnly, addSimples, addImplics, - tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, - tyCoVarsOfWCList, insolubleCt, insolubleEqCt, - isDroppableCt, insolubleImplic, - arisesFromGivens, - - Implication(..), implicationPrototype, - ImplicStatus(..), isInsolubleStatus, isSolvedStatus, - SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, - bumpSubGoalDepth, subGoalDepthExceeded, - CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, - ctLocTypeOrKind_maybe, - ctLocDepth, bumpCtLocDepth, isGivenLoc, - setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan, - pprCtLoc, - - -- CtEvidence - CtEvidence(..), TcEvDest(..), - mkKindLoc, toKindLoc, mkGivenLoc, - isWanted, isGiven, isDerived, isGivenOrWDeriv, - ctEvRole, - - wrapType, - - CtFlavour(..), ShadowInfo(..), ctEvFlavour, - CtFlavourRole, ctEvFlavourRole, ctFlavourRole, - eqCanRewrite, eqCanRewriteFR, eqMayRewriteFR, - eqCanDischargeFR, - funEqCanDischarge, funEqCanDischargeF, - - -- Pretty printing - pprEvVarTheta, - pprEvVars, pprEvVarWithType, - - -- holes - HoleSort(..), - - ) - where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TcRnTypes ( TcLclEnv, setLclEnvTcLevel, getLclEnvTcLevel - , setLclEnvLoc, getLclEnvLoc ) - -import GHC.Core.Predicate -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Types.Var - -import TcType -import TcEvidence -import TcOrigin - -import GHC.Core - -import GHC.Core.TyCo.Ppr -import GHC.Types.Name.Occurrence -import FV -import GHC.Types.Var.Set -import GHC.Driver.Session -import GHC.Types.Basic - -import Outputable -import GHC.Types.SrcLoc -import Bag -import Util - -import Control.Monad ( msum ) - -{- -************************************************************************ -* * -* Canonical constraints * -* * -* These are the constraints the low-level simplifier works with * -* * -************************************************************************ --} - --- The syntax of xi (ξ) types: --- xi ::= a | T xis | xis -> xis | ... | forall a. tau --- Two important notes: --- (i) No type families, unless we are under a ForAll --- (ii) Note that xi types can contain unexpanded type synonyms; --- however, the (transitive) expansions of those type synonyms --- will not contain any type functions, unless we are under a ForAll. --- We enforce the structure of Xi types when we flatten (TcCanonical) - -type Xi = Type -- In many comments, "xi" ranges over Xi - -type Cts = Bag Ct - -data Ct - -- Atomic canonical constraints - = CDictCan { -- e.g. Num xi - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - - cc_class :: Class, - cc_tyargs :: [Xi], -- cc_tyargs are function-free, hence Xi - - cc_pend_sc :: Bool -- See Note [The superclass story] in TcCanonical - -- True <=> (a) cc_class has superclasses - -- (b) we have not (yet) added those - -- superclasses as Givens - } - - | CIrredCan { -- These stand for yet-unusable predicates - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_status :: CtIrredStatus - - -- For the might-be-soluble case, the ctev_pred of the evidence is - -- of form (tv xi1 xi2 ... xin) with a tyvar at the head - -- or (tv1 ~ ty2) where the CTyEqCan kind invariant (TyEq:K) fails - -- or (F tys ~ ty) where the CFunEqCan kind invariant fails - -- See Note [CIrredCan constraints] - - -- The definitely-insoluble case is for things like - -- Int ~ Bool tycons don't match - -- a ~ [a] occurs check - } - - | CTyEqCan { -- tv ~ rhs - -- Invariants: - -- * See Note [inert_eqs: the inert equalities] in TcSMonad - -- * (TyEq:OC) tv not in deep tvs(rhs) (occurs check) - -- * (TyEq:F) If tv is a TauTv, then rhs has no foralls - -- (this avoids substituting a forall for the tyvar in other types) - -- * (TyEq:K) tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant] - -- * (TyEq:AFF) rhs (perhaps under the one cast) is *almost function-free*, - -- See Note [Almost function-free] - -- * (TyEq:N) If the equality is representational, rhs has no top-level newtype - -- See Note [No top-level newtypes on RHS of representational - -- equalities] in TcCanonical - -- * (TyEq:TV) If rhs (perhaps under the cast) is also a tv, then it is oriented - -- to give best chance of - -- unification happening; eg if rhs is touchable then lhs is too - -- See TcCanonical Note [Canonical orientation for tyvar/tyvar equality constraints] - -- * (TyEq:H) The RHS has no blocking coercion holes. See TcCanonical - -- Note [Equalities with incompatible kinds], wrinkle (2) - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_tyvar :: TcTyVar, - cc_rhs :: TcType, -- Not necessarily function-free (hence not Xi) - -- See invariants above - - cc_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev - } - - | CFunEqCan { -- F xis ~ fsk - -- Invariants: - -- * isTypeFamilyTyCon cc_fun - -- * tcTypeKind (F xis) = tyVarKind fsk; Note [Ct kind invariant] - -- * always Nominal role - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_fun :: TyCon, -- A type function - - cc_tyargs :: [Xi], -- cc_tyargs are function-free (hence Xi) - -- Either under-saturated or exactly saturated - -- *never* over-saturated (because if so - -- we should have decomposed) - - cc_fsk :: TcTyVar -- [G] always a FlatSkolTv - -- [W], [WD], or [D] always a FlatMetaTv - -- See Note [The flattening story] in TcFlatten - } - - | CNonCanonical { -- See Note [NonCanonical Semantics] in TcSMonad - cc_ev :: CtEvidence - } - - | CHoleCan { -- See Note [Hole constraints] - -- Treated as an "insoluble" constraint - -- See Note [Insoluble constraints] - cc_ev :: CtEvidence, - cc_occ :: OccName, -- The name of this hole - cc_hole :: HoleSort -- The sort of this hole (expr, type, ...) - } - - | CQuantCan QCInst -- A quantified constraint - -- NB: I expect to make more of the cases in Ct - -- look like this, with the payload in an - -- auxiliary type - ------------- -data QCInst -- A much simplified version of ClsInst - -- See Note [Quantified constraints] in TcCanonical - = QCI { qci_ev :: CtEvidence -- Always of type forall tvs. context => ty - -- Always Given - , qci_tvs :: [TcTyVar] -- The tvs - , qci_pred :: TcPredType -- The ty - , qci_pend_sc :: Bool -- Same as cc_pend_sc flag in CDictCan - -- Invariant: True => qci_pred is a ClassPred - } - -instance Outputable QCInst where - ppr (QCI { qci_ev = ev }) = ppr ev - ------------- --- | Used to indicate which sort of hole we have. -data HoleSort = ExprHole - -- ^ Either an out-of-scope variable or a "true" hole in an - -- expression (TypedHoles) - | TypeHole - -- ^ A hole in a type (PartialTypeSignatures) - ------------- --- | Used to indicate extra information about why a CIrredCan is irreducible -data CtIrredStatus - = InsolubleCIS -- this constraint will never be solved - | BlockedCIS -- this constraint is blocked on a coercion hole - -- The hole will appear in the ctEvPred of the constraint with this status - -- See Note [Equalities with incompatible kinds] in TcCanonical - -- Wrinkle (4a) - | OtherCIS - -instance Outputable CtIrredStatus where - ppr InsolubleCIS = text "(insoluble)" - ppr BlockedCIS = text "(blocked)" - ppr OtherCIS = text "(soluble)" - -{- Note [Hole constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -CHoleCan constraints are used for two kinds of holes, -distinguished by cc_hole: - - * For holes in expressions - e.g. f x = g _ x - - * For holes in type signatures - e.g. f :: _ -> _ - f x = [x,True] - -Note [CIrredCan constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CIrredCan constraints are used for constraints that are "stuck" - - we can't solve them (yet) - - we can't use them to solve other constraints - - but they may become soluble if we substitute for some - of the type variables in the constraint - -Example 1: (c Int), where c :: * -> Constraint. We can't do anything - with this yet, but if later c := Num, *then* we can solve it - -Example 2: a ~ b, where a :: *, b :: k, where k is a kind variable - We don't want to use this to substitute 'b' for 'a', in case - 'k' is subsequently unified with (say) *->*, because then - we'd have ill-kinded types floating about. Rather we want - to defer using the equality altogether until 'k' get resolved. - -Note [Ct/evidence invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field -of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for CDictCan, - ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct) -This holds by construction; look at the unique place where CDictCan is -built (in TcCanonical). - -In contrast, the type of the evidence *term* (ctev_dest / ctev_evar) in -the evidence may *not* be fully zonked; we are careful not to look at it -during constraint solving. See Note [Evidence field of CtEvidence]. - -Note [Ct kind invariant] -~~~~~~~~~~~~~~~~~~~~~~~~ -CTyEqCan and CFunEqCan both require that the kind of the lhs matches the kind -of the rhs. This is necessary because both constraints are used for substitutions -during solving. If the kinds differed, then the substitution would take a well-kinded -type to an ill-kinded one. - -Note [Almost function-free] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A type is *almost function-free* if it has no type functions (something that -responds True to isTypeFamilyTyCon), except (possibly) - * under a forall, or - * in a coercion (either in a CastTy or a CercionTy) - -The RHS of a CTyEqCan must be almost function-free, invariant (TyEq:AFF). -This is for two reasons: - -1. There cannot be a top-level function. If there were, the equality should - really be a CFunEqCan, not a CTyEqCan. - -2. Nested functions aren't too bad, on the other hand. However, consider this - scenario: - - type family F a = r | r -> a - - [D] F ty1 ~ fsk1 - [D] F ty2 ~ fsk2 - [D] fsk1 ~ [G Int] - [D] fsk2 ~ [G Bool] - - type instance G Int = Char - type instance G Bool = Char - - If it was the case that fsk1 = fsk2, then we could unifty ty1 and ty2 -- - good! They don't look equal -- but if we aggressively reduce that G Int and - G Bool they would become equal. The "almost function free" makes sure that - these redexes are exposed. - - Note that this equality does *not* depend on casts or coercions, and so - skipping these forms is OK. In addition, the result of a type family cannot - be a polytype, so skipping foralls is OK, too. We skip foralls because we - want the output of the flattener to be almost function-free. See Note - [Flattening under a forall] in TcFlatten. - - As I (Richard E) write this, it is unclear if the scenario pictured above - can happen -- I would expect the G Int and G Bool to be reduced. But - perhaps it can arise somehow, and maintaining almost function-free is cheap. - -Historical note: CTyEqCans used to require only condition (1) above: that no -type family was at the top of an RHS. But work on #16512 suggested that the -injectivity checks were not complete, and adding the requirement that functions -do not appear even in a nested fashion was easy (it was already true, but -unenforced). - -The almost-function-free property is checked by isAlmostFunctionFree in TcType. -The flattener (in TcFlatten) produces types that are almost function-free. - --} - -mkNonCanonical :: CtEvidence -> Ct -mkNonCanonical ev = CNonCanonical { cc_ev = ev } - -mkNonCanonicalCt :: Ct -> Ct -mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } - -mkIrredCt :: CtIrredStatus -> CtEvidence -> Ct -mkIrredCt status ev = CIrredCan { cc_ev = ev, cc_status = status } - -mkGivens :: CtLoc -> [EvId] -> [Ct] -mkGivens loc ev_ids - = map mk ev_ids - where - mk ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id - , ctev_pred = evVarPred ev_id - , ctev_loc = loc }) - -ctEvidence :: Ct -> CtEvidence -ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev -ctEvidence ct = cc_ev ct - -ctLoc :: Ct -> CtLoc -ctLoc = ctEvLoc . ctEvidence - -setCtLoc :: Ct -> CtLoc -> Ct -setCtLoc ct loc = ct { cc_ev = (cc_ev ct) { ctev_loc = loc } } - -ctOrigin :: Ct -> CtOrigin -ctOrigin = ctLocOrigin . ctLoc - -ctPred :: Ct -> PredType --- See Note [Ct/evidence invariant] -ctPred ct = ctEvPred (ctEvidence ct) - -ctEvId :: Ct -> EvVar --- The evidence Id for this Ct -ctEvId ct = ctEvEvId (ctEvidence ct) - --- | Makes a new equality predicate with the same role as the given --- evidence. -mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType -mkTcEqPredLikeEv ev - = case predTypeEqRel pred of - NomEq -> mkPrimEqPred - ReprEq -> mkReprPrimEqPred - where - pred = ctEvPred ev - --- | Get the flavour of the given 'Ct' -ctFlavour :: Ct -> CtFlavour -ctFlavour = ctEvFlavour . ctEvidence - --- | Get the equality relation for the given 'Ct' -ctEqRel :: Ct -> EqRel -ctEqRel = ctEvEqRel . ctEvidence - -instance Outputable Ct where - ppr ct = ppr (ctEvidence ct) <+> parens pp_sort - where - pp_sort = case ct of - CTyEqCan {} -> text "CTyEqCan" - CFunEqCan {} -> text "CFunEqCan" - CNonCanonical {} -> text "CNonCanonical" - CDictCan { cc_pend_sc = pend_sc } - | pend_sc -> text "CDictCan(psc)" - | otherwise -> text "CDictCan" - CIrredCan { cc_status = status } -> text "CIrredCan" <> ppr status - CHoleCan { cc_occ = occ } -> text "CHoleCan:" <+> ppr occ - CQuantCan (QCI { qci_pend_sc = pend_sc }) - | pend_sc -> text "CQuantCan(psc)" - | otherwise -> text "CQuantCan" - -{- -************************************************************************ -* * - Simple functions over evidence variables -* * -************************************************************************ --} - ----------------- Getting free tyvars ------------------------- - --- | Returns free variables of constraints as a non-deterministic set -tyCoVarsOfCt :: Ct -> TcTyCoVarSet -tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt - --- | Returns free variables of constraints as a deterministically ordered. --- list. See Note [Deterministic FV] in FV. -tyCoVarsOfCtList :: Ct -> [TcTyCoVar] -tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt - --- | Returns free variables of constraints as a composable FV computation. --- See Note [Deterministic FV] in FV. -tyCoFVsOfCt :: Ct -> FV -tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct) - -- This must consult only the ctPred, so that it gets *tidied* fvs if the - -- constraint has been tidied. Tidying a constraint does not tidy the - -- fields of the Ct, only the predicate in the CtEvidence. - --- | Returns free variables of a bag of constraints as a non-deterministic --- set. See Note [Deterministic FV] in FV. -tyCoVarsOfCts :: Cts -> TcTyCoVarSet -tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts - --- | Returns free variables of a bag of constraints as a deterministically --- ordered list. See Note [Deterministic FV] in FV. -tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] -tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts - --- | Returns free variables of a bag of constraints as a composable FV --- computation. See Note [Deterministic FV] in FV. -tyCoFVsOfCts :: Cts -> FV -tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV - --- | Returns free variables of WantedConstraints as a non-deterministic --- set. See Note [Deterministic FV] in FV. -tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC - --- | Returns free variables of WantedConstraints as a deterministically --- ordered list. See Note [Deterministic FV] in FV. -tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar] --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC - --- | Returns free variables of WantedConstraints as a composable FV --- computation. See Note [Deterministic FV] in FV. -tyCoFVsOfWC :: WantedConstraints -> FV --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic }) - = tyCoFVsOfCts simple `unionFV` - tyCoFVsOfBag tyCoFVsOfImplic implic - --- | Returns free variables of Implication as a composable FV computation. --- See Note [Deterministic FV] in FV. -tyCoFVsOfImplic :: Implication -> FV --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyCoFVsOfImplic (Implic { ic_skols = skols - , ic_given = givens - , ic_wanted = wanted }) - | isEmptyWC wanted - = emptyFV - | otherwise - = tyCoFVsVarBndrs skols $ - tyCoFVsVarBndrs givens $ - tyCoFVsOfWC wanted - -tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV -tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV - ---------------------------- -dropDerivedWC :: WantedConstraints -> WantedConstraints --- See Note [Dropping derived constraints] -dropDerivedWC wc@(WC { wc_simple = simples }) - = wc { wc_simple = dropDerivedSimples simples } - -- The wc_impl implications are already (recursively) filtered - --------------------------- -dropDerivedSimples :: Cts -> Cts --- Drop all Derived constraints, but make [W] back into [WD], --- so that if we re-simplify these constraints we will get all --- the right derived constraints re-generated. Forgetting this --- step led to #12936 -dropDerivedSimples simples = mapMaybeBag dropDerivedCt simples - -dropDerivedCt :: Ct -> Maybe Ct -dropDerivedCt ct - = case ctEvFlavour ev of - Wanted WOnly -> Just (ct' { cc_ev = ev_wd }) - Wanted _ -> Just ct' - _ | isDroppableCt ct -> Nothing - | otherwise -> Just ct - where - ev = ctEvidence ct - ev_wd = ev { ctev_nosh = WDeriv } - ct' = setPendingScDict ct -- See Note [Resetting cc_pend_sc] - -{- Note [Resetting cc_pend_sc] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we discard Derived constraints, in dropDerivedSimples, we must -set the cc_pend_sc flag to True, so that if we re-process this -CDictCan we will re-generate its derived superclasses. Otherwise -we might miss some fundeps. #13662 showed this up. - -See Note [The superclass story] in TcCanonical. --} - -isDroppableCt :: Ct -> Bool -isDroppableCt ct - = isDerived ev && not keep_deriv - -- Drop only derived constraints, and then only if they - -- obey Note [Dropping derived constraints] - where - ev = ctEvidence ct - loc = ctEvLoc ev - orig = ctLocOrigin loc - - keep_deriv - = case ct of - CHoleCan {} -> True - CIrredCan { cc_status = InsolubleCIS } -> keep_eq True - _ -> keep_eq False - - keep_eq definitely_insoluble - | isGivenOrigin orig -- Arising only from givens - = definitely_insoluble -- Keep only definitely insoluble - | otherwise - = case orig of - -- See Note [Dropping derived constraints] - -- For fundeps, drop wanted/wanted interactions - FunDepOrigin2 {} -> True -- Top-level/Wanted - FunDepOrigin1 _ orig1 _ _ orig2 _ - | g1 || g2 -> True -- Given/Wanted errors: keep all - | otherwise -> False -- Wanted/Wanted errors: discard - where - g1 = isGivenOrigin orig1 - g2 = isGivenOrigin orig2 - - _ -> False - -arisesFromGivens :: Ct -> Bool -arisesFromGivens ct - = case ctEvidence ct of - CtGiven {} -> True - CtWanted {} -> False - CtDerived { ctev_loc = loc } -> isGivenLoc loc - -isGivenLoc :: CtLoc -> Bool -isGivenLoc loc = isGivenOrigin (ctLocOrigin loc) - -{- Note [Dropping derived constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we discard derived constraints at the end of constraint solving; -see dropDerivedWC. For example - - * Superclasses: if we have an unsolved [W] (Ord a), we don't want to - complain about an unsolved [D] (Eq a) as well. - - * If we have [W] a ~ Int, [W] a ~ Bool, improvement will generate - [D] Int ~ Bool, and we don't want to report that because it's - incomprehensible. That is why we don't rewrite wanteds with wanteds! - - * We might float out some Wanteds from an implication, leaving behind - their insoluble Deriveds. For example: - - forall a[2]. [W] alpha[1] ~ Int - [W] alpha[1] ~ Bool - [D] Int ~ Bool - - The Derived is insoluble, but we very much want to drop it when floating - out. - -But (tiresomely) we do keep *some* Derived constraints: - - * Type holes are derived constraints, because they have no evidence - and we want to keep them, so we get the error report - - * We keep most derived equalities arising from functional dependencies - - Given/Given interactions (subset of FunDepOrigin1): - The definitely-insoluble ones reflect unreachable code. - - Others not-definitely-insoluble ones like [D] a ~ Int do not - reflect unreachable code; indeed if fundeps generated proofs, it'd - be a useful equality. See #14763. So we discard them. - - - Given/Wanted interacGiven or Wanted interacting with an - instance declaration (FunDepOrigin2) - - - Given/Wanted interactions (FunDepOrigin1); see #9612 - - - But for Wanted/Wanted interactions we do /not/ want to report an - error (#13506). Consider [W] C Int Int, [W] C Int Bool, with - a fundep on class C. We don't want to report an insoluble Int~Bool; - c.f. "wanteds do not rewrite wanteds". - -To distinguish these cases we use the CtOrigin. - -NB: we keep *all* derived insolubles under some circumstances: - - * They are looked at by simplifyInfer, to decide whether to - generalise. Example: [W] a ~ Int, [W] a ~ Bool - We get [D] Int ~ Bool, and indeed the constraints are insoluble, - and we want simplifyInfer to see that, even though we don't - ultimately want to generate an (inexplicable) error message from it - - -************************************************************************ -* * - CtEvidence - The "flavor" of a canonical constraint -* * -************************************************************************ --} - -isWantedCt :: Ct -> Bool -isWantedCt = isWanted . ctEvidence - -isGivenCt :: Ct -> Bool -isGivenCt = isGiven . ctEvidence - -isDerivedCt :: Ct -> Bool -isDerivedCt = isDerived . ctEvidence - -isCTyEqCan :: Ct -> Bool -isCTyEqCan (CTyEqCan {}) = True -isCTyEqCan _ = False - -isCDictCan_Maybe :: Ct -> Maybe Class -isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls -isCDictCan_Maybe _ = Nothing - -isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type]) -isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis) -isCFunEqCan_maybe _ = Nothing - -isCFunEqCan :: Ct -> Bool -isCFunEqCan (CFunEqCan {}) = True -isCFunEqCan _ = False - -isCNonCanonical :: Ct -> Bool -isCNonCanonical (CNonCanonical {}) = True -isCNonCanonical _ = False - -isHoleCt:: Ct -> Bool -isHoleCt (CHoleCan {}) = True -isHoleCt _ = False - -isOutOfScopeCt :: Ct -> Bool --- A Hole that does not have a leading underscore is --- simply an out-of-scope variable, and we treat that --- a bit differently when it comes to error reporting -isOutOfScopeCt (CHoleCan { cc_occ = occ }) = not (startsWithUnderscore occ) -isOutOfScopeCt _ = False - -isExprHoleCt :: Ct -> Bool -isExprHoleCt (CHoleCan { cc_hole = ExprHole }) = True -isExprHoleCt _ = False - -isTypeHoleCt :: Ct -> Bool -isTypeHoleCt (CHoleCan { cc_hole = TypeHole }) = True -isTypeHoleCt _ = False - - -{- Note [Custom type errors in constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When GHC reports a type-error about an unsolved-constraint, we check -to see if the constraint contains any custom-type errors, and if so -we report them. Here are some examples of constraints containing type -errors: - -TypeError msg -- The actual constraint is a type error - -TypError msg ~ Int -- Some type was supposed to be Int, but ended up - -- being a type error instead - -Eq (TypeError msg) -- A class constraint is stuck due to a type error - -F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err - -It is also possible to have constraints where the type error is nested deeper, -for example see #11990, and also: - -Eq (F (TypeError msg)) -- Here the type error is nested under a type-function - -- call, which failed to evaluate because of it, - -- and so the `Eq` constraint was unsolved. - -- This may happen when one function calls another - -- and the called function produced a custom type error. --} - --- | A constraint is considered to be a custom type error, if it contains --- custom type errors anywhere in it. --- See Note [Custom type errors in constraints] -getUserTypeErrorMsg :: Ct -> Maybe Type -getUserTypeErrorMsg ct = findUserTypeError (ctPred ct) - where - findUserTypeError t = msum ( userTypeError_maybe t - : map findUserTypeError (subTys t) - ) - - subTys t = case splitAppTys t of - (t,[]) -> - case splitTyConApp_maybe t of - Nothing -> [] - Just (_,ts) -> ts - (t,ts) -> t : ts - - - - -isUserTypeErrorCt :: Ct -> Bool -isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of - Just _ -> True - _ -> False - -isPendingScDict :: Ct -> Maybe Ct --- Says whether this is a CDictCan with cc_pend_sc is True, --- AND if so flips the flag -isPendingScDict ct@(CDictCan { cc_pend_sc = True }) - = Just (ct { cc_pend_sc = False }) -isPendingScDict _ = Nothing - -isPendingScInst :: QCInst -> Maybe QCInst --- Same as isPendingScDict, but for QCInsts -isPendingScInst qci@(QCI { qci_pend_sc = True }) - = Just (qci { qci_pend_sc = False }) -isPendingScInst _ = Nothing - -setPendingScDict :: Ct -> Ct --- Set the cc_pend_sc flag to True -setPendingScDict ct@(CDictCan { cc_pend_sc = False }) - = ct { cc_pend_sc = True } -setPendingScDict ct = ct - -superClassesMightHelp :: WantedConstraints -> Bool --- ^ True if taking superclasses of givens, or of wanteds (to perhaps --- expose more equalities or functional dependencies) might help to --- solve this constraint. See Note [When superclasses help] -superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics }) - = anyBag might_help_ct simples || anyBag might_help_implic implics - where - might_help_implic ic - | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic) - | otherwise = False - - might_help_ct ct = isWantedCt ct && not (is_ip ct) - - is_ip (CDictCan { cc_class = cls }) = isIPClass cls - is_ip _ = False - -getPendingWantedScs :: Cts -> ([Ct], Cts) -getPendingWantedScs simples - = mapAccumBagL get [] simples - where - get acc ct | Just ct' <- isPendingScDict ct - = (ct':acc, ct') - | otherwise - = (acc, ct) - -{- Note [When superclasses help] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -First read Note [The superclass story] in TcCanonical. - -We expand superclasses and iterate only if there is at unsolved wanted -for which expansion of superclasses (e.g. from given constraints) -might actually help. The function superClassesMightHelp tells if -doing this superclass expansion might help solve this constraint. -Note that - - * We look inside implications; maybe it'll help to expand the Givens - at level 2 to help solve an unsolved Wanted buried inside an - implication. E.g. - forall a. Ord a => forall b. [W] Eq a - - * Superclasses help only for Wanted constraints. Derived constraints - are not really "unsolved" and we certainly don't want them to - trigger superclass expansion. This was a good part of the loop - in #11523 - - * Even for Wanted constraints, we say "no" for implicit parameters. - we have [W] ?x::ty, expanding superclasses won't help: - - Superclasses can't be implicit parameters - - If we have a [G] ?x:ty2, then we'll have another unsolved - [D] ty ~ ty2 (from the functional dependency) - which will trigger superclass expansion. - - It's a bit of a special case, but it's easy to do. The runtime cost - is low because the unsolved set is usually empty anyway (errors - aside), and the first non-implicit-parameter will terminate the search. - - The special case is worth it (#11480, comment:2) because it - applies to CallStack constraints, which aren't type errors. If we have - f :: (C a) => blah - f x = ...undefined... - we'll get a CallStack constraint. If that's the only unsolved - constraint it'll eventually be solved by defaulting. So we don't - want to emit warnings about hitting the simplifier's iteration - limit. A CallStack constraint really isn't an unsolved - constraint; it can always be solved by defaulting. --} - -singleCt :: Ct -> Cts -singleCt = unitBag - -andCts :: Cts -> Cts -> Cts -andCts = unionBags - -listToCts :: [Ct] -> Cts -listToCts = listToBag - -ctsElts :: Cts -> [Ct] -ctsElts = bagToList - -consCts :: Ct -> Cts -> Cts -consCts = consBag - -snocCts :: Cts -> Ct -> Cts -snocCts = snocBag - -extendCtsList :: Cts -> [Ct] -> Cts -extendCtsList cts xs | null xs = cts - | otherwise = cts `unionBags` listToBag xs - -andManyCts :: [Cts] -> Cts -andManyCts = unionManyBags - -emptyCts :: Cts -emptyCts = emptyBag - -isEmptyCts :: Cts -> Bool -isEmptyCts = isEmptyBag - -pprCts :: Cts -> SDoc -pprCts cts = vcat (map ppr (bagToList cts)) - -{- -************************************************************************ -* * - Wanted constraints - These are forced to be in TcRnTypes because - TcLclEnv mentions WantedConstraints - WantedConstraint mentions CtLoc - CtLoc mentions ErrCtxt - ErrCtxt mentions TcM -* * -v%************************************************************************ --} - -data WantedConstraints - = WC { wc_simple :: Cts -- Unsolved constraints, all wanted - , wc_impl :: Bag Implication - } - -emptyWC :: WantedConstraints -emptyWC = WC { wc_simple = emptyBag, wc_impl = emptyBag } - -mkSimpleWC :: [CtEvidence] -> WantedConstraints -mkSimpleWC cts - = WC { wc_simple = listToBag (map mkNonCanonical cts) - , wc_impl = emptyBag } - -mkImplicWC :: Bag Implication -> WantedConstraints -mkImplicWC implic - = WC { wc_simple = emptyBag, wc_impl = implic } - -isEmptyWC :: WantedConstraints -> Bool -isEmptyWC (WC { wc_simple = f, wc_impl = i }) - = isEmptyBag f && isEmptyBag i - - --- | Checks whether a the given wanted constraints are solved, i.e. --- that there are no simple constraints left and all the implications --- are solved. -isSolvedWC :: WantedConstraints -> Bool -isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl} = - isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl - -andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints -andWC (WC { wc_simple = f1, wc_impl = i1 }) - (WC { wc_simple = f2, wc_impl = i2 }) - = WC { wc_simple = f1 `unionBags` f2 - , wc_impl = i1 `unionBags` i2 } - -unionsWC :: [WantedConstraints] -> WantedConstraints -unionsWC = foldr andWC emptyWC - -addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints -addSimples wc cts - = wc { wc_simple = wc_simple wc `unionBags` cts } - -- Consider: Put the new constraints at the front, so they get solved first - -addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints -addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } - -addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints -addInsols wc cts - = wc { wc_simple = wc_simple wc `unionBags` cts } - -insolublesOnly :: WantedConstraints -> WantedConstraints --- Keep only the definitely-insoluble constraints -insolublesOnly (WC { wc_simple = simples, wc_impl = implics }) - = WC { wc_simple = filterBag insolubleCt simples - , wc_impl = mapBag implic_insols_only implics } - where - implic_insols_only implic - = implic { ic_wanted = insolublesOnly (ic_wanted implic) } - -isSolvedStatus :: ImplicStatus -> Bool -isSolvedStatus (IC_Solved {}) = True -isSolvedStatus _ = False - -isInsolubleStatus :: ImplicStatus -> Bool -isInsolubleStatus IC_Insoluble = True -isInsolubleStatus IC_BadTelescope = True -isInsolubleStatus _ = False - -insolubleImplic :: Implication -> Bool -insolubleImplic ic = isInsolubleStatus (ic_status ic) - -insolubleWC :: WantedConstraints -> Bool -insolubleWC (WC { wc_impl = implics, wc_simple = simples }) - = anyBag insolubleCt simples - || anyBag insolubleImplic implics - -insolubleCt :: Ct -> Bool --- Definitely insoluble, in particular /excluding/ type-hole constraints --- Namely: a) an equality constraint --- b) that is insoluble --- c) and does not arise from a Given -insolubleCt ct - | isHoleCt ct = isOutOfScopeCt ct -- See Note [Insoluble holes] - | not (insolubleEqCt ct) = False - | arisesFromGivens ct = False -- See Note [Given insolubles] - | otherwise = True - -insolubleEqCt :: Ct -> Bool --- Returns True of /equality/ constraints --- that are /definitely/ insoluble --- It won't detect some definite errors like --- F a ~ T (F a) --- where F is a type family, which actually has an occurs check --- --- The function is tuned for application /after/ constraint solving --- i.e. assuming canonicalisation has been done --- E.g. It'll reply True for a ~ [a] --- but False for [a] ~ a --- and --- True for Int ~ F a Int --- but False for Maybe Int ~ F a Int Int --- (where F is an arity-1 type function) -insolubleEqCt (CIrredCan { cc_status = InsolubleCIS }) = True -insolubleEqCt _ = False - -instance Outputable WantedConstraints where - ppr (WC {wc_simple = s, wc_impl = i}) - = text "WC" <+> braces (vcat - [ ppr_bag (text "wc_simple") s - , ppr_bag (text "wc_impl") i ]) - -ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc -ppr_bag doc bag - | isEmptyBag bag = empty - | otherwise = hang (doc <+> equals) - 2 (foldr (($$) . ppr) empty bag) - -{- Note [Given insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14325, comment:) - class (a~b) => C a b - - foo :: C a c => a -> c - foo x = x - - hm3 :: C (f b) b => b -> f b - hm3 x = foo x - -In the RHS of hm3, from the [G] C (f b) b we get the insoluble -[G] f b ~# b. Then we also get an unsolved [W] C b (f b). -Residual implication looks like - forall b. C (f b) b => [G] f b ~# b - [W] C f (f b) - -We do /not/ want to set the implication status to IC_Insoluble, -because that'll suppress reports of [W] C b (f b). But we -may not report the insoluble [G] f b ~# b either (see Note [Given errors] -in TcErrors), so we may fail to report anything at all! Yikes. - -The same applies to Derived constraints that /arise from/ Givens. -E.g. f :: (C Int [a]) => blah -where a fundep means we get - [D] Int ~ [a] -By the same reasoning we must not suppress other errors (#15767) - -Bottom line: insolubleWC (called in TcSimplify.setImplicationStatus) - should ignore givens even if they are insoluble. - -Note [Insoluble holes] -~~~~~~~~~~~~~~~~~~~~~~ -Hole constraints that ARE NOT treated as truly insoluble: - a) type holes, arising from PartialTypeSignatures, - b) "true" expression holes arising from TypedHoles - -An "expression hole" or "type hole" constraint isn't really an error -at all; it's a report saying "_ :: Int" here. But an out-of-scope -variable masquerading as expression holes IS treated as truly -insoluble, so that it trumps other errors during error reporting. -Yuk! - -************************************************************************ -* * - Implication constraints -* * -************************************************************************ --} - -data Implication - = Implic { -- Invariants for a tree of implications: - -- see TcType Note [TcLevel and untouchable type variables] - - ic_tclvl :: TcLevel, -- TcLevel of unification variables - -- allocated /inside/ this implication - - ic_skols :: [TcTyVar], -- Introduced skolems - ic_info :: SkolemInfo, -- See Note [Skolems in an implication] - -- See Note [Shadowing in a constraint] - - ic_telescope :: Maybe SDoc, -- User-written telescope, if there is one - -- See Note [Checking telescopes] - - ic_given :: [EvVar], -- Given evidence variables - -- (order does not matter) - -- See Invariant (GivenInv) in TcType - - ic_no_eqs :: Bool, -- True <=> ic_givens have no equalities, for sure - -- False <=> ic_givens might have equalities - - ic_warn_inaccessible :: Bool, - -- True <=> -Winaccessible-code is enabled - -- at construction. See - -- Note [Avoid -Winaccessible-code when deriving] - -- in TcInstDcls - - ic_env :: TcLclEnv, - -- Records the TcLClEnv at the time of creation. - -- - -- The TcLclEnv gives the source location - -- and error context for the implication, and - -- hence for all the given evidence variables. - - ic_wanted :: WantedConstraints, -- The wanteds - -- See Invariang (WantedInf) in TcType - - ic_binds :: EvBindsVar, -- Points to the place to fill in the - -- abstraction and bindings. - - -- The ic_need fields keep track of which Given evidence - -- is used by this implication or its children - -- NB: including stuff used by nested implications that have since - -- been discarded - -- See Note [Needed evidence variables] - ic_need_inner :: VarSet, -- Includes all used Given evidence - ic_need_outer :: VarSet, -- Includes only the free Given evidence - -- i.e. ic_need_inner after deleting - -- (a) givens (b) binders of ic_binds - - ic_status :: ImplicStatus - } - -implicationPrototype :: Implication -implicationPrototype - = Implic { -- These fields must be initialised - ic_tclvl = panic "newImplic:tclvl" - , ic_binds = panic "newImplic:binds" - , ic_info = panic "newImplic:info" - , ic_env = panic "newImplic:env" - , ic_warn_inaccessible = panic "newImplic:warn_inaccessible" - - -- The rest have sensible default values - , ic_skols = [] - , ic_telescope = Nothing - , ic_given = [] - , ic_wanted = emptyWC - , ic_no_eqs = False - , ic_status = IC_Unsolved - , ic_need_inner = emptyVarSet - , ic_need_outer = emptyVarSet } - -data ImplicStatus - = IC_Solved -- All wanteds in the tree are solved, all the way down - { ics_dead :: [EvVar] } -- Subset of ic_given that are not needed - -- See Note [Tracking redundant constraints] in TcSimplify - - | IC_Insoluble -- At least one insoluble constraint in the tree - - | IC_BadTelescope -- solved, but the skolems in the telescope are out of - -- dependency order - - | IC_Unsolved -- Neither of the above; might go either way - -instance Outputable Implication where - ppr (Implic { ic_tclvl = tclvl, ic_skols = skols - , ic_given = given, ic_no_eqs = no_eqs - , ic_wanted = wanted, ic_status = status - , ic_binds = binds - , ic_need_inner = need_in, ic_need_outer = need_out - , ic_info = info }) - = hang (text "Implic" <+> lbrace) - 2 (sep [ text "TcLevel =" <+> ppr tclvl - , text "Skolems =" <+> pprTyVars skols - , text "No-eqs =" <+> ppr no_eqs - , text "Status =" <+> ppr status - , hang (text "Given =") 2 (pprEvVars given) - , hang (text "Wanted =") 2 (ppr wanted) - , text "Binds =" <+> ppr binds - , whenPprDebug (text "Needed inner =" <+> ppr need_in) - , whenPprDebug (text "Needed outer =" <+> ppr need_out) - , pprSkolInfo info ] <+> rbrace) - -instance Outputable ImplicStatus where - ppr IC_Insoluble = text "Insoluble" - ppr IC_BadTelescope = text "Bad telescope" - ppr IC_Unsolved = text "Unsolved" - ppr (IC_Solved { ics_dead = dead }) - = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead)) - -{- Note [Checking telescopes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When kind-checking a /user-written/ type, we might have a "bad telescope" -like this one: - data SameKind :: forall k. k -> k -> Type - type Foo :: forall a k (b :: k). SameKind a b -> Type - -The kind of 'a' mentions 'k' which is bound after 'a'. Oops. - -One approach to doing this would be to bring each of a, k, and b into -scope, one at a time, creating a separate implication constraint for -each one, and bumping the TcLevel. This would work, because the kind -of, say, a would be untouchable when k is in scope (and the constraint -couldn't float out because k blocks it). However, it leads to terrible -error messages, complaining about skolem escape. While it is indeed a -problem of skolem escape, we can do better. - -Instead, our approach is to bring the block of variables into scope -all at once, creating one implication constraint for the lot: - -* We make a single implication constraint when kind-checking - the 'forall' in Foo's kind, something like - forall a k (b::k). { wanted constraints } - -* Having solved {wanted}, before discarding the now-solved implication, - the constraint solver checks the dependency order of the skolem - variables (ic_skols). This is done in setImplicationStatus. - -* This check is only necessary if the implication was born from a - user-written signature. If, say, it comes from checking a pattern - match that binds existentials, where the type of the data constructor - is known to be valid (it in tcConPat), no need for the check. - - So the check is done if and only if ic_telescope is (Just blah). - -* If ic_telesope is (Just d), the d::SDoc displays the original, - user-written type variables. - -* Be careful /NOT/ to discard an implication with non-Nothing - ic_telescope, even if ic_wanted is empty. We must give the - constraint solver a chance to make that bad-telescope test! Hence - the extra guard in emitResidualTvConstraint; see #16247 - -Note [Needed evidence variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Th ic_need_evs field holds the free vars of ic_binds, and all the -ic_binds in nested implications. - - * Main purpose: if one of the ic_givens is not mentioned in here, it - is redundant. - - * solveImplication may drop an implication altogether if it has no - remaining 'wanteds'. But we still track the free vars of its - evidence binds, even though it has now disappeared. - -Note [Shadowing in a constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We assume NO SHADOWING in a constraint. Specifically - * The unification variables are all implicitly quantified at top - level, and are all unique - * The skolem variables bound in ic_skols are all freah when the - implication is created. -So we can safely substitute. For example, if we have - forall a. a~Int => ...(forall b. ...a...)... -we can push the (a~Int) constraint inwards in the "givens" without -worrying that 'b' might clash. - -Note [Skolems in an implication] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The skolems in an implication are not there to perform a skolem escape -check. That happens because all the environment variables are in the -untouchables, and therefore cannot be unified with anything at all, -let alone the skolems. - -Instead, ic_skols is used only when considering floating a constraint -outside the implication in TcSimplify.floatEqualities or -TcSimplify.approximateImplications - -Note [Insoluble constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some of the errors that we get during canonicalization are best -reported when all constraints have been simplified as much as -possible. For instance, assume that during simplification the -following constraints arise: - - [Wanted] F alpha ~ uf1 - [Wanted] beta ~ uf1 beta - -When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail -we will simply see a message: - 'Can't construct the infinite type beta ~ uf1 beta' -and the user has no idea what the uf1 variable is. - -Instead our plan is that we will NOT fail immediately, but: - (1) Record the "frozen" error in the ic_insols field - (2) Isolate the offending constraint from the rest of the inerts - (3) Keep on simplifying/canonicalizing - -At the end, we will hopefully have substituted uf1 := F alpha, and we -will be able to report a more informative error: - 'Can't construct the infinite type beta ~ F alpha beta' - -Insoluble constraints *do* include Derived constraints. For example, -a functional dependency might give rise to [D] Int ~ Bool, and we must -report that. If insolubles did not contain Deriveds, reportErrors would -never see it. - - -************************************************************************ -* * - Pretty printing -* * -************************************************************************ --} - -pprEvVars :: [EvVar] -> SDoc -- Print with their types -pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) - -pprEvVarTheta :: [EvVar] -> SDoc -pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) - -pprEvVarWithType :: EvVar -> SDoc -pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) - - - -wrapType :: Type -> [TyVar] -> [PredType] -> Type -wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty - - -{- -************************************************************************ -* * - CtEvidence -* * -************************************************************************ - -Note [Evidence field of CtEvidence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During constraint solving we never look at the type of ctev_evar/ctev_dest; -instead we look at the ctev_pred field. The evtm/evar field -may be un-zonked. - -Note [Bind new Givens immediately] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For Givens we make new EvVars and bind them immediately. Two main reasons: - * Gain sharing. E.g. suppose we start with g :: C a b, where - class D a => C a b - class (E a, F a) => D a - If we generate all g's superclasses as separate EvTerms we might - get selD1 (selC1 g) :: E a - selD2 (selC1 g) :: F a - selC1 g :: D a - which we could do more economically as: - g1 :: D a = selC1 g - g2 :: E a = selD1 g1 - g3 :: F a = selD2 g1 - - * For *coercion* evidence we *must* bind each given: - class (a~b) => C a b where .... - f :: C a b => .... - Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. - But that superclass selector can't (yet) appear in a coercion - (see evTermCoercion), so the easy thing is to bind it to an Id. - -So a Given has EvVar inside it rather than (as previously) an EvTerm. - --} - --- | A place for type-checking evidence to go after it is generated. --- Wanted equalities are always HoleDest; other wanteds are always --- EvVarDest. -data TcEvDest - = EvVarDest EvVar -- ^ bind this var to the evidence - -- EvVarDest is always used for non-type-equalities - -- e.g. class constraints - - | HoleDest CoercionHole -- ^ fill in this hole with the evidence - -- HoleDest is always used for type-equalities - -- See Note [Coercion holes] in GHC.Core.TyCo.Rep - -data CtEvidence - = CtGiven -- Truly given, not depending on subgoals - { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] - , ctev_evar :: EvVar -- See Note [Evidence field of CtEvidence] - , ctev_loc :: CtLoc } - - - | CtWanted -- Wanted goal - { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] - , ctev_dest :: TcEvDest - , ctev_nosh :: ShadowInfo -- See Note [Constraint flavours] - , ctev_loc :: CtLoc } - - | CtDerived -- A goal that we don't really have to solve and can't - -- immediately rewrite anything other than a derived - -- (there's no evidence!) but if we do manage to solve - -- it may help in solving other goals. - { ctev_pred :: TcPredType - , ctev_loc :: CtLoc } - -ctEvPred :: CtEvidence -> TcPredType --- The predicate of a flavor -ctEvPred = ctev_pred - -ctEvLoc :: CtEvidence -> CtLoc -ctEvLoc = ctev_loc - -ctEvOrigin :: CtEvidence -> CtOrigin -ctEvOrigin = ctLocOrigin . ctEvLoc - --- | Get the equality relation relevant for a 'CtEvidence' -ctEvEqRel :: CtEvidence -> EqRel -ctEvEqRel = predTypeEqRel . ctEvPred - --- | Get the role relevant for a 'CtEvidence' -ctEvRole :: CtEvidence -> Role -ctEvRole = eqRelRole . ctEvEqRel - -ctEvTerm :: CtEvidence -> EvTerm -ctEvTerm ev = EvExpr (ctEvExpr ev) - -ctEvExpr :: CtEvidence -> EvExpr -ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ }) - = Coercion $ ctEvCoercion ev -ctEvExpr ev = evId (ctEvEvId ev) - -ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion -ctEvCoercion (CtGiven { ctev_evar = ev_id }) - = mkTcCoVarCo ev_id -ctEvCoercion (CtWanted { ctev_dest = dest }) - | HoleDest hole <- dest - = -- ctEvCoercion is only called on type equalities - -- and they always have HoleDests - mkHoleCo hole -ctEvCoercion ev - = pprPanic "ctEvCoercion" (ppr ev) - -ctEvEvId :: CtEvidence -> EvVar -ctEvEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev -ctEvEvId (CtWanted { ctev_dest = HoleDest h }) = coHoleCoVar h -ctEvEvId (CtGiven { ctev_evar = ev }) = ev -ctEvEvId ctev@(CtDerived {}) = pprPanic "ctEvId:" (ppr ctev) - -instance Outputable TcEvDest where - ppr (HoleDest h) = text "hole" <> ppr h - ppr (EvVarDest ev) = ppr ev - -instance Outputable CtEvidence where - ppr ev = ppr (ctEvFlavour ev) - <+> pp_ev - <+> braces (ppr (ctl_depth (ctEvLoc ev))) <> dcolon - -- Show the sub-goal depth too - <+> ppr (ctEvPred ev) - where - pp_ev = case ev of - CtGiven { ctev_evar = v } -> ppr v - CtWanted {ctev_dest = d } -> ppr d - CtDerived {} -> text "_" - -isWanted :: CtEvidence -> Bool -isWanted (CtWanted {}) = True -isWanted _ = False - -isGiven :: CtEvidence -> Bool -isGiven (CtGiven {}) = True -isGiven _ = False - -isDerived :: CtEvidence -> Bool -isDerived (CtDerived {}) = True -isDerived _ = False - -{- -%************************************************************************ -%* * - CtFlavour -%* * -%************************************************************************ - -Note [Constraint flavours] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Constraints come in four flavours: - -* [G] Given: we have evidence - -* [W] Wanted WOnly: we want evidence - -* [D] Derived: any solution must satisfy this constraint, but - we don't need evidence for it. Examples include: - - superclasses of [W] class constraints - - equalities arising from functional dependencies - or injectivity - -* [WD] Wanted WDeriv: a single constraint that represents - both [W] and [D] - We keep them paired as one both for efficiency, and because - when we have a finite map F tys -> CFunEqCan, it's inconvenient - to have two CFunEqCans in the range - -The ctev_nosh field of a Wanted distinguishes between [W] and [WD] - -Wanted constraints are born as [WD], but are split into [W] and its -"shadow" [D] in TcSMonad.maybeEmitShadow. - -See Note [The improvement story and derived shadows] in TcSMonad --} - -data CtFlavour -- See Note [Constraint flavours] - = Given - | Wanted ShadowInfo - | Derived - deriving Eq - -data ShadowInfo - = WDeriv -- [WD] This Wanted constraint has no Derived shadow, - -- so it behaves like a pair of a Wanted and a Derived - | WOnly -- [W] It has a separate derived shadow - -- See Note [The improvement story and derived shadows] in TcSMonad - deriving( Eq ) - -isGivenOrWDeriv :: CtFlavour -> Bool -isGivenOrWDeriv Given = True -isGivenOrWDeriv (Wanted WDeriv) = True -isGivenOrWDeriv _ = False - -instance Outputable CtFlavour where - ppr Given = text "[G]" - ppr (Wanted WDeriv) = text "[WD]" - ppr (Wanted WOnly) = text "[W]" - ppr Derived = text "[D]" - -ctEvFlavour :: CtEvidence -> CtFlavour -ctEvFlavour (CtWanted { ctev_nosh = nosh }) = Wanted nosh -ctEvFlavour (CtGiven {}) = Given -ctEvFlavour (CtDerived {}) = Derived - --- | Whether or not one 'Ct' can rewrite another is determined by its --- flavour and its equality relation. See also --- Note [Flavours with roles] in TcSMonad -type CtFlavourRole = (CtFlavour, EqRel) - --- | Extract the flavour, role, and boxity from a 'CtEvidence' -ctEvFlavourRole :: CtEvidence -> CtFlavourRole -ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev) - --- | Extract the flavour and role from a 'Ct' -ctFlavourRole :: Ct -> CtFlavourRole --- Uses short-cuts to role for special cases -ctFlavourRole (CDictCan { cc_ev = ev }) - = (ctEvFlavour ev, NomEq) -ctFlavourRole (CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel }) - = (ctEvFlavour ev, eq_rel) -ctFlavourRole (CFunEqCan { cc_ev = ev }) - = (ctEvFlavour ev, NomEq) -ctFlavourRole (CHoleCan { cc_ev = ev }) - = (ctEvFlavour ev, NomEq) -- NomEq: CHoleCans can be rewritten by - -- by nominal equalities but empahatically - -- not by representational equalities -ctFlavourRole ct - = ctEvFlavourRole (ctEvidence ct) - -{- Note [eqCanRewrite] -~~~~~~~~~~~~~~~~~~~~~~ -(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form -tv ~ ty) can be used to rewrite ct2. It must satisfy the properties of -a can-rewrite relation, see Definition [Can-rewrite relation] in -TcSMonad. - -With the solver handling Coercible constraints like equality constraints, -the rewrite conditions must take role into account, never allowing -a representational equality to rewrite a nominal one. - -Note [Wanteds do not rewrite Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't allow Wanteds to rewrite Wanteds, because that can give rise -to very confusing type error messages. A good example is #8450. -Here's another - f :: a -> Bool - f x = ( [x,'c'], [x,True] ) `seq` True -Here we get - [W] a ~ Char - [W] a ~ Bool -but we do not want to complain about Bool ~ Char! - -Note [Deriveds do rewrite Deriveds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -However we DO allow Deriveds to rewrite Deriveds, because that's how -improvement works; see Note [The improvement story] in TcInteract. - -However, for now at least I'm only letting (Derived,NomEq) rewrite -(Derived,NomEq) and not doing anything for ReprEq. If we have - eqCanRewriteFR (Derived, NomEq) (Derived, _) = True -then we lose property R2 of Definition [Can-rewrite relation] -in TcSMonad - R2. If f1 >= f, and f2 >= f, - then either f1 >= f2 or f2 >= f1 -Consider f1 = (Given, ReprEq) - f2 = (Derived, NomEq) - f = (Derived, ReprEq) - -I thought maybe we could never get Derived ReprEq constraints, but -we can; straight from the Wanteds during improvement. And from a Derived -ReprEq we could conceivably get a Derived NomEq improvement (by decomposing -a type constructor with Nomninal role), and hence unify. --} - -eqCanRewrite :: EqRel -> EqRel -> Bool -eqCanRewrite NomEq _ = True -eqCanRewrite ReprEq ReprEq = True -eqCanRewrite ReprEq NomEq = False - -eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool --- Can fr1 actually rewrite fr2? --- Very important function! --- See Note [eqCanRewrite] --- See Note [Wanteds do not rewrite Wanteds] --- See Note [Deriveds do rewrite Deriveds] -eqCanRewriteFR (Given, r1) (_, r2) = eqCanRewrite r1 r2 -eqCanRewriteFR (Wanted WDeriv, NomEq) (Derived, NomEq) = True -eqCanRewriteFR (Derived, NomEq) (Derived, NomEq) = True -eqCanRewriteFR _ _ = False - -eqMayRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool --- Is it /possible/ that fr1 can rewrite fr2? --- This is used when deciding which inerts to kick out, --- at which time a [WD] inert may be split into [W] and [D] -eqMayRewriteFR (Wanted WDeriv, NomEq) (Wanted WDeriv, NomEq) = True -eqMayRewriteFR (Derived, NomEq) (Wanted WDeriv, NomEq) = True -eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2 - ------------------ -{- Note [funEqCanDischarge] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have two CFunEqCans with the same LHS: - (x1:F ts ~ f1) `funEqCanDischarge` (x2:F ts ~ f2) -Can we drop x2 in favour of x1, either unifying -f2 (if it's a flatten meta-var) or adding a new Given -(f1 ~ f2), if x2 is a Given? - -Answer: yes if funEqCanDischarge is true. --} - -funEqCanDischarge - :: CtEvidence -> CtEvidence - -> ( SwapFlag -- NotSwapped => lhs can discharge rhs - -- Swapped => rhs can discharge lhs - , Bool) -- True <=> upgrade non-discharded one - -- from [W] to [WD] --- See Note [funEqCanDischarge] -funEqCanDischarge ev1 ev2 - = ASSERT2( ctEvEqRel ev1 == NomEq, ppr ev1 ) - ASSERT2( ctEvEqRel ev2 == NomEq, ppr ev2 ) - -- CFunEqCans are all Nominal, hence asserts - funEqCanDischargeF (ctEvFlavour ev1) (ctEvFlavour ev2) - -funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool) -funEqCanDischargeF Given _ = (NotSwapped, False) -funEqCanDischargeF _ Given = (IsSwapped, False) -funEqCanDischargeF (Wanted WDeriv) _ = (NotSwapped, False) -funEqCanDischargeF _ (Wanted WDeriv) = (IsSwapped, True) -funEqCanDischargeF (Wanted WOnly) (Wanted WOnly) = (NotSwapped, False) -funEqCanDischargeF (Wanted WOnly) Derived = (NotSwapped, True) -funEqCanDischargeF Derived (Wanted WOnly) = (IsSwapped, True) -funEqCanDischargeF Derived Derived = (NotSwapped, False) - - -{- Note [eqCanDischarge] -~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have two identical CTyEqCan equality constraints -(i.e. both LHS and RHS are the same) - (x1:a~t) `eqCanDischarge` (xs:a~t) -Can we just drop x2 in favour of x1? - -Answer: yes if eqCanDischarge is true. - -Note that we do /not/ allow Wanted to discharge Derived. -We must keep both. Why? Because the Derived may rewrite -other Deriveds in the model whereas the Wanted cannot. - -However a Wanted can certainly discharge an identical Wanted. So -eqCanDischarge does /not/ define a can-rewrite relation in the -sense of Definition [Can-rewrite relation] in TcSMonad. - -We /do/ say that a [W] can discharge a [WD]. In evidence terms it -certainly can, and the /caller/ arranges that the otherwise-lost [D] -is spat out as a new Derived. -} - -eqCanDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool --- See Note [eqCanDischarge] -eqCanDischargeFR (f1,r1) (f2, r2) = eqCanRewrite r1 r2 - && eqCanDischargeF f1 f2 - -eqCanDischargeF :: CtFlavour -> CtFlavour -> Bool -eqCanDischargeF Given _ = True -eqCanDischargeF (Wanted _) (Wanted _) = True -eqCanDischargeF (Wanted WDeriv) Derived = True -eqCanDischargeF Derived Derived = True -eqCanDischargeF _ _ = False - - -{- -************************************************************************ -* * - SubGoalDepth -* * -************************************************************************ - -Note [SubGoalDepth] -~~~~~~~~~~~~~~~~~~~ -The 'SubGoalDepth' takes care of stopping the constraint solver from looping. - -The counter starts at zero and increases. It includes dictionary constraints, -equality simplification, and type family reduction. (Why combine these? Because -it's actually quite easy to mistake one for another, in sufficiently involved -scenarios, like ConstraintKinds.) - -The flag -freduction-depth=n fixes the maximium level. - -* The counter includes the depth of type class instance declarations. Example: - [W] d{7} : Eq [Int] - That is d's dictionary-constraint depth is 7. If we use the instance - $dfEqList :: Eq a => Eq [a] - to simplify it, we get - d{7} = $dfEqList d'{8} - where d'{8} : Eq Int, and d' has depth 8. - - For civilised (decidable) instance declarations, each increase of - depth removes a type constructor from the type, so the depth never - gets big; i.e. is bounded by the structural depth of the type. - -* The counter also increments when resolving -equalities involving type functions. Example: - Assume we have a wanted at depth 7: - [W] d{7} : F () ~ a - If there is a type function equation "F () = Int", this would be rewritten to - [W] d{8} : Int ~ a - and remembered as having depth 8. - - Again, without UndecidableInstances, this counter is bounded, but without it - can resolve things ad infinitum. Hence there is a maximum level. - -* Lastly, every time an equality is rewritten, the counter increases. Again, - rewriting an equality constraint normally makes progress, but it's possible - the "progress" is just the reduction of an infinitely-reducing type family. - Hence we need to track the rewrites. - -When compiling a program requires a greater depth, then GHC recommends turning -off this check entirely by setting -freduction-depth=0. This is because the -exact number that works is highly variable, and is likely to change even between -minor releases. Because this check is solely to prevent infinite compilation -times, it seems safe to disable it when a user has ascertained that their program -doesn't loop at the type level. - --} - --- | See Note [SubGoalDepth] -newtype SubGoalDepth = SubGoalDepth Int - deriving (Eq, Ord, Outputable) - -initialSubGoalDepth :: SubGoalDepth -initialSubGoalDepth = SubGoalDepth 0 - -bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth -bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1) - -maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth -maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m) - -subGoalDepthExceeded :: DynFlags -> SubGoalDepth -> Bool -subGoalDepthExceeded dflags (SubGoalDepth d) - = mkIntWithInf d > reductionDepth dflags - -{- -************************************************************************ -* * - CtLoc -* * -************************************************************************ - -The 'CtLoc' gives information about where a constraint came from. -This is important for decent error message reporting because -dictionaries don't appear in the original source code. -type will evolve... - --} - -data CtLoc = CtLoc { ctl_origin :: CtOrigin - , ctl_env :: TcLclEnv - , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure - , ctl_depth :: !SubGoalDepth } - - -- The TcLclEnv includes particularly - -- source location: tcl_loc :: RealSrcSpan - -- context: tcl_ctxt :: [ErrCtxt] - -- binder stack: tcl_bndrs :: TcBinderStack - -- level: tcl_tclvl :: TcLevel - -mkKindLoc :: TcType -> TcType -- original *types* being compared - -> CtLoc -> CtLoc -mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc) - (KindEqOrigin s1 (Just s2) (ctLocOrigin loc) - (ctLocTypeOrKind_maybe loc)) - --- | Take a CtLoc and moves it to the kind level -toKindLoc :: CtLoc -> CtLoc -toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } - -mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc -mkGivenLoc tclvl skol_info env - = CtLoc { ctl_origin = GivenOrigin skol_info - , ctl_env = setLclEnvTcLevel env tclvl - , ctl_t_or_k = Nothing -- this only matters for error msgs - , ctl_depth = initialSubGoalDepth } - -ctLocEnv :: CtLoc -> TcLclEnv -ctLocEnv = ctl_env - -ctLocLevel :: CtLoc -> TcLevel -ctLocLevel loc = getLclEnvTcLevel (ctLocEnv loc) - -ctLocDepth :: CtLoc -> SubGoalDepth -ctLocDepth = ctl_depth - -ctLocOrigin :: CtLoc -> CtOrigin -ctLocOrigin = ctl_origin - -ctLocSpan :: CtLoc -> RealSrcSpan -ctLocSpan (CtLoc { ctl_env = lcl}) = getLclEnvLoc lcl - -ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind -ctLocTypeOrKind_maybe = ctl_t_or_k - -setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc -setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (setLclEnvLoc lcl loc) - -bumpCtLocDepth :: CtLoc -> CtLoc -bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d } - -setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc -setCtLocOrigin ctl orig = ctl { ctl_origin = orig } - -updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc -updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd - = ctl { ctl_origin = upd orig } - -setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc -setCtLocEnv ctl env = ctl { ctl_env = env } - -pprCtLoc :: CtLoc -> SDoc --- "arising from ... at ..." --- Not an instance of Outputable because of the "arising from" prefix -pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl}) - = sep [ pprCtOrigin o - , text "at" <+> ppr (getLclEnvLoc lcl)] diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs deleted file mode 100644 index 1e983d0e24..0000000000 --- a/compiler/typecheck/FamInst.hs +++ /dev/null @@ -1,1057 +0,0 @@ --- The @FamInst@ type: family instance heads - -{-# LANGUAGE CPP, GADTs, ViewPatterns #-} - -module FamInst ( - FamInstEnvs, tcGetFamInstEnvs, - checkFamInstConsistency, tcExtendLocalFamInstEnv, - tcLookupDataFamInst, tcLookupDataFamInst_maybe, - tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe, - newFamInst, - - -- * Injectivity - reportInjectivityErrors, reportConflictingInjectivityErrs - ) where - -import GhcPrelude - -import GHC.Driver.Types -import GHC.Core.FamInstEnv -import GHC.Core.InstEnv( roughMatchTcs ) -import GHC.Core.Coercion -import GHC.Core.Lint -import TcEvidence -import GHC.Iface.Load -import TcRnMonad -import GHC.Types.SrcLoc as SrcLoc -import GHC.Core.TyCon -import TcType -import GHC.Core.Coercion.Axiom -import GHC.Driver.Session -import GHC.Types.Module -import Outputable -import Util -import GHC.Types.Name.Reader -import GHC.Core.DataCon ( dataConName ) -import Maybes -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen ) -import TcMType -import GHC.Types.Name -import Panic -import GHC.Types.Var.Set -import FV -import Bag( Bag, unionBags, unitBag ) -import Control.Monad -import Data.List ( sortBy ) -import Data.List.NonEmpty ( NonEmpty(..) ) -import Data.Function ( on ) - -import qualified GHC.LanguageExtensions as LangExt - -#include "HsVersions.h" - -{- Note [The type family instance consistency story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To preserve type safety we must ensure that for any given module, all -the type family instances used either in that module or in any module -it directly or indirectly imports are consistent. For example, consider - - module F where - type family F a - - module A where - import F( F ) - type instance F Int = Bool - f :: F Int -> Bool - f x = x - - module B where - import F( F ) - type instance F Int = Char - g :: Char -> F Int - g x = x - - module Bad where - import A( f ) - import B( g ) - bad :: Char -> Int - bad c = f (g c) - -Even though module Bad never mentions the type family F at all, by -combining the functions f and g that were type checked in contradictory -type family instance environments, the function bad is able to coerce -from one type to another. So when we type check Bad we must verify that -the type family instances defined in module A are consistent with those -defined in module B. - -How do we ensure that we maintain the necessary consistency? - -* Call a module which defines at least one type family instance a - "family instance module". This flag `mi_finsts` is recorded in the - interface file. - -* For every module we calculate the set of all of its direct and - indirect dependencies that are family instance modules. This list - `dep_finsts` is also recorded in the interface file so we can compute - this list for a module from the lists for its direct dependencies. - -* When type checking a module M we check consistency of all the type - family instances that are either provided by its `dep_finsts` or - defined in the module M itself. This is a pairwise check, i.e., for - every pair of instances we must check that they are consistent. - - - For family instances coming from `dep_finsts`, this is checked in - checkFamInstConsistency, called from tcRnImports. See Note - [Checking family instance consistency] for details on this check - (and in particular how we avoid having to do all these checks for - every module we compile). - - - That leaves checking the family instances defined in M itself - against instances defined in either M or its `dep_finsts`. This is - checked in `tcExtendLocalFamInstEnv'. - -There are four subtle points in this scheme which have not been -addressed yet. - -* We have checked consistency of the family instances *defined* by M - or its imports, but this is not by definition the same thing as the - family instances *used* by M or its imports. Specifically, we need to - ensure when we use a type family instance while compiling M that this - instance was really defined from either M or one of its imports, - rather than being an instance that we happened to know about from - reading an interface file in the course of compiling an unrelated - module. Otherwise, we'll end up with no record of the fact that M - depends on this family instance and type safety will be compromised. - See #13102. - -* It can also happen that M uses a function defined in another module - which is not transitively imported by M. Examples include the - desugaring of various overloaded constructs, and references inserted - by Template Haskell splices. If that function's definition makes use - of type family instances which are not checked against those visible - from M, type safety can again be compromised. See #13251. - -* When a module C imports a boot module B.hs-boot, we check that C's - type family instances are compatible with those visible from - B.hs-boot. However, C will eventually be linked against a different - module B.hs, which might define additional type family instances which - are inconsistent with C's. This can also lead to loss of type safety. - See #9562. - -* The call to checkFamConsistency for imported functions occurs very - early (in tcRnImports) and that causes problems if the imported - instances use type declared in the module being compiled. - See Note [Loading your own hi-boot file] in GHC.Iface.Load. --} - -{- -************************************************************************ -* * - Making a FamInst -* * -************************************************************************ --} - --- All type variables in a FamInst must be fresh. This function --- creates the fresh variables and applies the necessary substitution --- It is defined here to avoid a dependency from FamInstEnv on the monad --- code. - -newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst --- Freshen the type variables of the FamInst branches -newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc }) - = ASSERT2( tyCoVarsOfTypes lhs `subVarSet` tcv_set, text "lhs" <+> pp_ax ) - ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind ) - -- We used to have an assertion that the tyvars of the RHS were bound - -- by tcv_set, but in error situations like F Int = a that isn't - -- true; a later check in checkValidFamInst rejects it - do { (subst, tvs') <- freshenTyVarBndrs tvs - ; (subst, cvs') <- freshenCoVarBndrsX subst cvs - ; dflags <- getDynFlags - ; let lhs' = substTys subst lhs - rhs' = substTy subst rhs - tcvs' = tvs' ++ cvs' - ; ifErrsM (return ()) $ -- Don't lint when there are errors, because - -- errors might mean TcTyCons. - -- See Note [Recover from validity error] in TcTyClsDecls - when (gopt Opt_DoCoreLinting dflags) $ - -- Check that the types involved in this instance are well formed. - -- Do /not/ expand type synonyms, for the reasons discussed in - -- Note [Linting type synonym applications]. - case lintTypes dflags tcvs' (rhs':lhs') of - Nothing -> pure () - Just fail_msg -> pprPanic "Core Lint error in newFamInst" $ - vcat [ fail_msg - , ppr fam_tc - , ppr subst - , ppr tvs' - , ppr cvs' - , ppr lhs' - , ppr rhs' ] - ; return (FamInst { fi_fam = tyConName fam_tc - , fi_flavor = flavor - , fi_tcs = roughMatchTcs lhs - , fi_tvs = tvs' - , fi_cvs = cvs' - , fi_tys = lhs' - , fi_rhs = rhs' - , fi_axiom = axiom }) } - where - lhs_kind = tcTypeKind (mkTyConApp fam_tc lhs) - rhs_kind = tcTypeKind rhs - tcv_set = mkVarSet (tvs ++ cvs) - pp_ax = pprCoAxiom axiom - CoAxBranch { cab_tvs = tvs - , cab_cvs = cvs - , cab_lhs = lhs - , cab_rhs = rhs } = coAxiomSingleBranch axiom - - -{- -************************************************************************ -* * - Optimised overlap checking for family instances -* * -************************************************************************ - -Note [Checking family instance consistency] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For any two family instance modules that we import directly or indirectly, we -check whether the instances in the two modules are consistent, *unless* we can -be certain that the instances of the two modules have already been checked for -consistency during the compilation of modules that we import. - -Why do we need to check? Consider - module X1 where module X2 where - data T1 data T2 - type instance F T1 b = Int type instance F a T2 = Char - f1 :: F T1 a -> Int f2 :: Char -> F a T2 - f1 x = x f2 x = x - -Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char. -Notice that neither instance is an orphan. - -How do we know which pairs of modules have already been checked? For each -module M we directly import, we look up the family instance modules that M -imports (directly or indirectly), say F1, ..., FN. For any two modules -among M, F1, ..., FN, we know that the family instances defined in those -two modules are consistent--because we checked that when we compiled M. - -For every other pair of family instance modules we import (directly or -indirectly), we check that they are consistent now. (So that we can be -certain that the modules in our `GHC.Driver.Types.dep_finsts' are consistent.) - -There is some fancy footwork regarding hs-boot module loops, see -Note [Don't check hs-boot type family instances too early] - -Note [Checking family instance optimization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Checking family instance consistency] -we need to ensure that every pair of transitive imports that define type family -instances is consistent. - -Let's define df(A) = transitive imports of A that define type family instances -+ A, if A defines type family instances - -Then for every direct import A, df(A) is already consistent. - -Let's name the current module M. - -We want to make sure that df(M) is consistent. -df(M) = df(D_1) U df(D_2) U ... U df(D_i) where D_1 .. D_i are direct imports. - -We perform the check iteratively, maintaining a set of consistent modules 'C' -and trying to add df(D_i) to it. - -The key part is how to ensure that the union C U df(D_i) is consistent. - -Let's consider two modules: A and B from C U df(D_i). -There are nine possible ways to choose A and B from C U df(D_i): - - | A in C only | A in C and B in df(D_i) | A in df(D_i) only --------------------------------------------------------------------------------- -B in C only | Already checked | Already checked | Needs to be checked - | when checking C | when checking C | --------------------------------------------------------------------------------- -B in C and | Already checked | Already checked | Already checked when -B in df(D_i) | when checking C | when checking C | checking df(D_i) --------------------------------------------------------------------------------- -B in df(D_i) | Needs to be | Already checked | Already checked when -only | checked | when checking df(D_i) | checking df(D_i) - -That means to ensure that C U df(D_i) is consistent we need to check every -module from C - df(D_i) against every module from df(D_i) - C and -every module from df(D_i) - C against every module from C - df(D_i). -But since the checks are symmetric it suffices to pick A from C - df(D_i) -and B from df(D_i) - C. - -In other words these are the modules we need to check: - [ (m1, m2) | m1 <- C, m1 not in df(D_i) - , m2 <- df(D_i), m2 not in C ] - -One final thing to note here is that if there's lot of overlap between -subsequent df(D_i)'s then we expect those set differences to be small. -That situation should be pretty common in practice, there's usually -a set of utility modules that every module imports directly or indirectly. - -This is basically the idea from #13092, comment:14. --} - --- This function doesn't check ALL instances for consistency, --- only ones that aren't involved in recursive knot-tying --- loops; see Note [Don't check hs-boot type family instances too early]. --- We don't need to check the current module, this is done in --- tcExtendLocalFamInstEnv. --- See Note [The type family instance consistency story]. -checkFamInstConsistency :: [Module] -> TcM () -checkFamInstConsistency directlyImpMods - = do { (eps, hpt) <- getEpsAndHpt - ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) - ; let { -- Fetch the iface of a given module. Must succeed as - -- all directly imported modules must already have been loaded. - modIface mod = - case lookupIfaceByModule hpt (eps_PIT eps) mod of - Nothing -> panicDoc "FamInst.checkFamInstConsistency" - (ppr mod $$ pprHPT hpt) - Just iface -> iface - - -- Which family instance modules were checked for consistency - -- when we compiled `mod`? - -- Itself (if a family instance module) and its dep_finsts. - -- This is df(D_i) from - -- Note [Checking family instance optimization] - ; modConsistent :: Module -> [Module] - ; modConsistent mod = - if mi_finsts (mi_final_exts (modIface mod)) then mod:deps else deps - where - deps = dep_finsts . mi_deps . modIface $ mod - - ; hmiModule = mi_module . hm_iface - ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv - . md_fam_insts . hm_details - ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) - | hmi <- eltsHpt hpt] - - } - - ; checkMany hpt_fam_insts modConsistent directlyImpMods - } - where - -- See Note [Checking family instance optimization] - checkMany - :: ModuleEnv FamInstEnv -- home package family instances - -> (Module -> [Module]) -- given A, modules checked when A was checked - -> [Module] -- modules to process - -> TcM () - checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods - where - go :: [Module] -- list of consistent modules - -> ModuleSet -- set of consistent modules, same elements as the - -- list above - -> [Module] -- modules to process - -> TcM () - go _ _ [] = return () - go consistent consistent_set (mod:mods) = do - sequence_ - [ check hpt_fam_insts m1 m2 - | m1 <- to_check_from_mod - -- loop over toCheckFromMod first, it's usually smaller, - -- it may even be empty - , m2 <- to_check_from_consistent - ] - go consistent' consistent_set' mods - where - mod_deps_consistent = modConsistent mod - mod_deps_consistent_set = mkModuleSet mod_deps_consistent - consistent' = to_check_from_mod ++ consistent - consistent_set' = - extendModuleSetList consistent_set to_check_from_mod - to_check_from_consistent = - filterOut (`elemModuleSet` mod_deps_consistent_set) consistent - to_check_from_mod = - filterOut (`elemModuleSet` consistent_set) mod_deps_consistent - -- Why don't we just minusModuleSet here? - -- We could, but doing so means one of two things: - -- - -- 1. When looping over the cartesian product we convert - -- a set into a non-deterministicly ordered list. Which - -- happens to be fine for interface file determinism - -- in this case, today, because the order only - -- determines the order of deferred checks. But such - -- invariants are hard to keep. - -- - -- 2. When looping over the cartesian product we convert - -- a set into a deterministically ordered list - this - -- adds some additional cost of sorting for every - -- direct import. - -- - -- That also explains why we need to keep both 'consistent' - -- and 'consistentSet'. - -- - -- See also Note [ModuleEnv performance and determinism]. - check hpt_fam_insts m1 m2 - = do { env1' <- getFamInsts hpt_fam_insts m1 - ; env2' <- getFamInsts hpt_fam_insts m2 - -- We're checking each element of env1 against env2. - -- The cost of that is dominated by the size of env1, because - -- for each instance in env1 we look it up in the type family - -- environment env2, and lookup is cheap. - -- The code below ensures that env1 is the smaller environment. - ; let sizeE1 = famInstEnvSize env1' - sizeE2 = famInstEnvSize env2' - (env1, env2) = if sizeE1 < sizeE2 then (env1', env2') - else (env2', env1') - -- Note [Don't check hs-boot type family instances too early] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Family instance consistency checking involves checking that - -- the family instances of our imported modules are consistent with - -- one another; this might lead you to think that this process - -- has nothing to do with the module we are about to typecheck. - -- Not so! Consider the following case: - -- - -- -- A.hs-boot - -- type family F a - -- - -- -- B.hs - -- import {-# SOURCE #-} A - -- type instance F Int = Bool - -- - -- -- A.hs - -- import B - -- type family F a - -- - -- When typechecking A, we are NOT allowed to poke the TyThing - -- for F until we have typechecked the family. Thus, we - -- can't do consistency checking for the instance in B - -- (checkFamInstConsistency is called during renaming). - -- Failing to defer the consistency check lead to #11062. - -- - -- Additionally, we should also defer consistency checking when - -- type from the hs-boot file of the current module occurs on - -- the left hand side, as we will poke its TyThing when checking - -- for overlap. - -- - -- -- F.hs - -- type family F a - -- - -- -- A.hs-boot - -- import F - -- data T - -- - -- -- B.hs - -- import {-# SOURCE #-} A - -- import F - -- type instance F T = Int - -- - -- -- A.hs - -- import B - -- data T = MkT - -- - -- In fact, it is even necessary to defer for occurrences in - -- the RHS, because we may test for *compatibility* in event - -- of an overlap. - -- - -- Why don't we defer ALL of the checks to later? Well, many - -- instances aren't involved in the recursive loop at all. So - -- we might as well check them immediately; and there isn't - -- a good time to check them later in any case: every time - -- we finish kind-checking a type declaration and add it to - -- a context, we *then* consistency check all of the instances - -- which mentioned that type. We DO want to check instances - -- as quickly as possible, so that we aren't typechecking - -- values with inconsistent axioms in scope. - -- - -- See also Note [Tying the knot] - -- for why we are doing this at all. - ; let check_now = famInstEnvElts env1 - ; mapM_ (checkForConflicts (emptyFamInstEnv, env2)) check_now - ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now - } - -getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv -getFamInsts hpt_fam_insts mod - | Just env <- lookupModuleEnv hpt_fam_insts mod = return env - | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod) - ; eps <- getEps - ; return (expectJust "checkFamInstConsistency" $ - lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } - where - doc = ppr mod <+> text "is a family-instance module" - -{- -************************************************************************ -* * - Lookup -* * -************************************************************************ - --} - --- | If @co :: T ts ~ rep_ty@ then: --- --- > instNewTyCon_maybe T ts = Just (rep_ty, co) --- --- Checks for a newtype, and for being saturated --- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion -tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion) -tcInstNewTyCon_maybe = instNewTyCon_maybe - --- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if --- there is no data family to unwrap. --- Returns a Representational coercion -tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType] - -> (TyCon, [TcType], Coercion) -tcLookupDataFamInst fam_inst_envs tc tc_args - | Just (rep_tc, rep_args, co) - <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args - = (rep_tc, rep_args, co) - | otherwise - = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args)) - -tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType] - -> Maybe (TyCon, [TcType], Coercion) --- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a) --- and returns a coercion between the two: co :: F [a] ~R FList a. -tcLookupDataFamInst_maybe fam_inst_envs tc tc_args - | isDataFamilyTyCon tc - , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args - , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax - , fi_cvs = cvs }) - , fim_tys = rep_args - , fim_cos = rep_cos } <- match - , let rep_tc = dataFamInstRepTyCon rep_fam - co = mkUnbranchedAxInstCo Representational ax rep_args - (mkCoVarCos cvs) - = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in GHC.Core.FamInstEnv - Just (rep_tc, rep_args, co) - - | otherwise - = Nothing - --- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes, --- potentially looking through newtype /instances/. --- --- It is only used by the type inference engine (specifically, when --- solving representational equality), and hence it is careful to unwrap --- only if the relevant data constructor is in scope. That's why --- it get a GlobalRdrEnv argument. --- --- It is careful not to unwrap data/newtype instances if it can't --- continue unwrapping. Such care is necessary for proper error --- messages. --- --- It does not look through type families. --- It does not normalise arguments to a tycon. --- --- If the result is Just (rep_ty, (co, gres), rep_ty), then --- co : ty ~R rep_ty --- gres are the GREs for the data constructors that --- had to be in scope -tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs - -> GlobalRdrEnv - -> Type - -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type) -tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty --- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe - = topNormaliseTypeX stepper plus ty - where - plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion) - -> (Bag GlobalRdrElt, TcCoercion) - plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2 - , co1 `mkTransCo` co2 ) - - stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion) - stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance - - -- For newtype instances we take a double step or nothing, so that - -- we don't return the representation type of the newtype instance, - -- which would lead to terrible error messages - unwrap_newtype_instance rec_nts tc tys - | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys - = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $ - unwrap_newtype rec_nts tc' tys' - | otherwise = NS_Done - - unwrap_newtype rec_nts tc tys - | Just con <- newTyConDataCon_maybe tc - , Just gre <- lookupGRE_Name rdr_env (dataConName con) - -- This is where we check that the - -- data constructor is in scope - = mapStepResult (\co -> (unitBag gre, co)) $ - unwrapNewTypeStepper rec_nts tc tys - - | otherwise - = NS_Done - -{- -************************************************************************ -* * - Extending the family instance environment -* * -************************************************************************ --} - --- Add new locally-defined family instances, checking consistency with --- previous locally-defined family instances as well as all instances --- available from imported modules. This requires loading all of our --- imports that define family instances (if we haven't loaded them already). -tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a - --- If we weren't actually given any instances to add, then we don't want --- to go to the bother of loading family instance module dependencies. -tcExtendLocalFamInstEnv [] thing_inside = thing_inside - --- Otherwise proceed... -tcExtendLocalFamInstEnv fam_insts thing_inside - = do { -- Load family-instance modules "below" this module, so that - -- allLocalFamInst can check for consistency with them - -- See Note [The type family instance consistency story] - loadDependentFamInstModules fam_insts - - -- Now add the instances one by one - ; env <- getGblEnv - ; (inst_env', fam_insts') <- foldlM addLocalFamInst - (tcg_fam_inst_env env, tcg_fam_insts env) - fam_insts - - ; let env' = env { tcg_fam_insts = fam_insts' - , tcg_fam_inst_env = inst_env' } - ; setGblEnv env' thing_inside - } - -loadDependentFamInstModules :: [FamInst] -> TcM () --- Load family-instance modules "below" this module, so that --- allLocalFamInst can check for consistency with them --- See Note [The type family instance consistency story] -loadDependentFamInstModules fam_insts - = do { env <- getGblEnv - ; let this_mod = tcg_mod env - imports = tcg_imports env - - want_module mod -- See Note [Home package family instances] - | mod == this_mod = False - | home_fams_only = moduleUnitId mod == moduleUnitId this_mod - | otherwise = True - home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts - - ; loadModuleInterfaces (text "Loading family-instance modules") $ - filter want_module (imp_finsts imports) } - -{- Note [Home package family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Optimization: If we're only defining type family instances -for type families *defined in the home package*, then we -only have to load interface files that belong to the home -package. The reason is that there's no recursion between -packages, so modules in other packages can't possibly define -instances for our type families. - -(Within the home package, we could import a module M that -imports us via an hs-boot file, and thereby defines an -instance of a type family defined in this module. So we can't -apply the same logic to avoid reading any interface files at -all, when we define an instances for type family defined in -the current module. --} - --- Check that the proposed new instance is OK, --- and then add it to the home inst env --- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] --- in GHC.Core.FamInstEnv -addLocalFamInst :: (FamInstEnv,[FamInst]) - -> FamInst - -> TcM (FamInstEnv, [FamInst]) -addLocalFamInst (home_fie, my_fis) fam_inst - -- home_fie includes home package and this module - -- my_fies is just the ones from this module - = do { traceTc "addLocalFamInst" (ppr fam_inst) - - -- Unlike the case of class instances, don't override existing - -- instances in GHCi; it's unsound. See #7102. - - ; mod <- getModule - ; traceTc "alfi" (ppr mod) - - -- Fetch imported instances, so that we report - -- overlaps correctly. - -- Really we ought to only check consistency with - -- those instances which are transitively imported - -- by the current module, rather than every instance - -- we've ever seen. Fixing this is part of #13102. - ; eps <- getEps - ; let inst_envs = (eps_fam_inst_env eps, home_fie) - home_fie' = extendFamInstEnv home_fie fam_inst - - -- Check for conflicting instance decls and injectivity violations - ; ((), no_errs) <- askNoErrs $ - do { checkForConflicts inst_envs fam_inst - ; checkForInjectivityConflicts inst_envs fam_inst - ; checkInjectiveEquation fam_inst - } - - ; if no_errs then - return (home_fie', fam_inst : my_fis) - else - return (home_fie, my_fis) } - -{- -************************************************************************ -* * - Checking an instance against conflicts with an instance env -* * -************************************************************************ - -Check whether a single family instance conflicts with those in two instance -environments (one for the EPS and one for the HPT). --} - --- | Checks to make sure no two family instances overlap. -checkForConflicts :: FamInstEnvs -> FamInst -> TcM () -checkForConflicts inst_envs fam_inst - = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst - ; traceTc "checkForConflicts" $ - vcat [ ppr (map fim_instance conflicts) - , ppr fam_inst - -- , ppr inst_envs - ] - ; reportConflictInstErr fam_inst conflicts } - -checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM () - -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv, check 1B1. -checkForInjectivityConflicts instEnvs famInst - | isTypeFamilyTyCon tycon -- as opposed to data family tycon - , Injective inj <- tyConInjectivityInfo tycon - = let conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst in - reportConflictingInjectivityErrs tycon conflicts (coAxiomSingleBranch (fi_axiom famInst)) - - | otherwise - = return () - - where tycon = famInstTyCon famInst - --- | Check whether a new open type family equation can be added without --- violating injectivity annotation supplied by the user. Returns True when --- this is possible and False if adding this equation would violate injectivity --- annotation. This looks only at the one equation; it does not look for --- interaction between equations. Use checkForInjectivityConflicts for that. --- Does checks (2)-(4) of Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. -checkInjectiveEquation :: FamInst -> TcM () -checkInjectiveEquation famInst - | isTypeFamilyTyCon tycon - -- type family is injective in at least one argument - , Injective inj <- tyConInjectivityInfo tycon = do - { dflags <- getDynFlags - ; let axiom = coAxiomSingleBranch fi_ax - -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv - ; reportInjectivityErrors dflags fi_ax axiom inj - } - - -- if there was no injectivity annotation or tycon does not represent a - -- type family we report no conflicts - | otherwise - = return () - - where tycon = famInstTyCon famInst - fi_ax = fi_axiom famInst - --- | Report a list of injectivity errors together with their source locations. --- Looks only at one equation; does not look for conflicts *among* equations. -reportInjectivityErrors - :: DynFlags - -> CoAxiom br -- ^ Type family for which we generate errors - -> CoAxBranch -- ^ Currently checked equation (represented by axiom) - -> [Bool] -- ^ Injectivity annotation - -> TcM () -reportInjectivityErrors dflags fi_ax axiom inj - = ASSERT2( any id inj, text "No injective type variables" ) - do let lhs = coAxBranchLHS axiom - rhs = coAxBranchRHS axiom - fam_tc = coAxiomTyCon fi_ax - (unused_inj_tvs, unused_vis, undec_inst_flag) - = unusedInjTvsInRHS dflags fam_tc lhs rhs - inj_tvs_unused = not $ isEmptyVarSet unused_inj_tvs - tf_headed = isTFHeaded rhs - bare_variables = bareTvInRHSViolated lhs rhs - wrong_bare_rhs = not $ null bare_variables - - when inj_tvs_unused $ reportUnusedInjectiveVarsErr fam_tc unused_inj_tvs - unused_vis undec_inst_flag axiom - when tf_headed $ reportTfHeadedErr fam_tc axiom - when wrong_bare_rhs $ reportBareVariableInRHSErr fam_tc bare_variables axiom - --- | Is type headed by a type family application? -isTFHeaded :: Type -> Bool --- See Note [Verifying injectivity annotation], case 3. -isTFHeaded ty | Just ty' <- coreView ty - = isTFHeaded ty' -isTFHeaded ty | (TyConApp tc args) <- ty - , isTypeFamilyTyCon tc - = args `lengthIs` tyConArity tc -isTFHeaded _ = False - - --- | If a RHS is a bare type variable return a set of LHS patterns that are not --- bare type variables. -bareTvInRHSViolated :: [Type] -> Type -> [Type] --- See Note [Verifying injectivity annotation], case 2. -bareTvInRHSViolated pats rhs | isTyVarTy rhs - = filter (not . isTyVarTy) pats -bareTvInRHSViolated _ _ = [] - ------------------------------------------------------------------- --- Checking for the coverage condition for injective type families ------------------------------------------------------------------- - -{- -Note [Coverage condition for injective type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Injective Type Families paper describes how we can tell whether -or not a type family equation upholds the injectivity condition. -Briefly, consider the following: - - type family F a b = r | r -> a -- NB: b is not injective - - type instance F ty1 ty2 = ty3 - -We need to make sure that all variables mentioned in ty1 are mentioned in ty3 --- that's how we know that knowing ty3 determines ty1. But they can't be -mentioned just anywhere in ty3: they must be in *injective* positions in ty3. -For example: - - type instance F a Int = Maybe (G a) - -This is no good, if G is not injective. However, if G is indeed injective, -then this would appear to meet our needs. There is a trap here, though: while -knowing G a does indeed determine a, trying to compute a from G a might not -terminate. This is precisely the same problem that we have with functional -dependencies and their liberal coverage condition. Here is the test case: - - type family G a = r | r -> a - type instance G [a] = [G a] - [W] G alpha ~ [alpha] - -We see that the equation given applies, because G alpha equals a list. So we -learn that alpha must be [beta] for some beta. We then have - - [W] G [beta] ~ [[beta]] - -This can reduce to - - [W] [G beta] ~ [[beta]] - -which then decomposes to - - [W] G beta ~ [beta] - -right where we started. The equation G [a] = [G a] thus is dangerous: while -it does not violate the injectivity assumption, it might throw us into a loop, -with a particularly dastardly Wanted. - -We thus do what functional dependencies do: require -XUndecidableInstances to -accept this. - -Checking the coverage condition is not terribly hard, but we also want to produce -a nice error message. A nice error message has at least two properties: - -1. If any of the variables involved are invisible or are used in an invisible context, -we want to print invisible arguments (as -fprint-explicit-kinds does). - -2. If we fail to accept the equation because we're worried about non-termination, -we want to suggest UndecidableInstances. - -To gather the right information, we can talk about the *usage* of a variable. Every -variable is used either visibly or invisibly, and it is either not used at all, -in a context where acceptance requires UndecidableInstances, or in a context that -does not require UndecidableInstances. If a variable is used both visibly and -invisibly, then we want to remember the fact that it was used invisibly: printing -out invisibles will be helpful for the user to understand what is going on. -If a variable is used where we need -XUndecidableInstances and where we don't, -we can similarly just remember the latter. - -We thus define Visibility and NeedsUndecInstFlag below. These enumerations are -*ordered*, and we used their Ord instances. We then define VarUsage, which is just a pair -of a Visibility and a NeedsUndecInstFlag. (The visibility is irrelevant when a -variable is NotPresent, but this extra slack in the representation causes no -harm.) We finally define VarUsages as a mapping from variables to VarUsage. -Its Monoid instance combines two maps, using the Semigroup instance of VarUsage -to combine elements that are represented in both maps. In this way, we can -compositionally analyze types (and portions thereof). - -To do the injectivity check: - -1. We build VarUsages that represent the LHS (rather, the portion of the LHS -that is flagged as injective); each usage on the LHS is NotPresent, because we -have not yet looked at the RHS. - -2. We also build a VarUsage for the RHS, done by injTyVarUsages. - -3. We then combine these maps. Now, every variable in the injective components of the LHS -will be mapped to its correct usage (either NotPresent or perhaps needing --XUndecidableInstances in order to be seen as injective). - -4. We look up each var used in an injective argument on the LHS in -the map, making a list of tvs that should be determined by the RHS -but aren't. - -5. We then return the set of bad variables, whether any of the bad -ones were used invisibly, and whether any bad ones need -XUndecidableInstances. -If -XUndecidableInstances is enabled, than a var that needs the flag -won't be bad, so it won't appear in this list. - -6. We use all this information to produce a nice error message, (a) switching -on -fprint-explicit-kinds if appropriate and (b) telling the user about --XUndecidableInstances if appropriate. - --} - --- | Return the set of type variables that a type family equation is --- expected to be injective in but is not. Suppose we have @type family --- F a b = r | r -> a@. Then any variables that appear free in the first --- argument to F in an equation must be fixed by that equation's RHS. --- This function returns all such variables that are not indeed fixed. --- It also returns whether any of these variables appear invisibly --- and whether -XUndecidableInstances would help. --- See Note [Coverage condition for injective type families]. -unusedInjTvsInRHS :: DynFlags - -> TyCon -- type family - -> [Type] -- LHS arguments - -> Type -- the RHS - -> ( TyVarSet - , Bool -- True <=> one or more variable is used invisibly - , Bool ) -- True <=> suggest -XUndecidableInstances --- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. --- This function implements check (4) described there, further --- described in Note [Coverage condition for injective type families]. --- In theory (and modulo the -XUndecidableInstances wrinkle), --- instead of implementing this whole check in this way, we could --- attempt to unify equation with itself. We would reject exactly the same --- equations but this method gives us more precise error messages by returning --- precise names of variables that are not mentioned in the RHS. -unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs rhs = - -- Note [Coverage condition for injective type families], step 5 - (bad_vars, any_invisible, suggest_undec) - where - undec_inst = xopt LangExt.UndecidableInstances dflags - - inj_lhs = filterByList inj_list lhs - lhs_vars = tyCoVarsOfTypes inj_lhs - - rhs_inj_vars = fvVarSet $ injectiveVarsOfType undec_inst rhs - - bad_vars = lhs_vars `minusVarSet` rhs_inj_vars - - any_bad = not $ isEmptyVarSet bad_vars - - invis_vars = fvVarSet $ invisibleVarsOfTypes [mkTyConApp tycon lhs, rhs] - - any_invisible = any_bad && (bad_vars `intersectsVarSet` invis_vars) - suggest_undec = any_bad && - not undec_inst && - (lhs_vars `subVarSet` fvVarSet (injectiveVarsOfType True rhs)) - --- When the type family is not injective in any arguments -unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, False, False) - ---------------------------------------- --- Producing injectivity error messages ---------------------------------------- - --- | Report error message for a pair of equations violating an injectivity --- annotation. No error message if there are no branches. -reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM () -reportConflictingInjectivityErrs _ [] _ = return () -reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn - = addErrs [buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])] - where - herald = text "Type family equation right-hand sides overlap; this violates" $$ - text "the family's injectivity annotation:" - --- | Injectivity error herald common to all injectivity errors. -injectivityErrorHerald :: SDoc -injectivityErrorHerald = - text "Type family equation violates the family's injectivity annotation." - - --- | Report error message for equation with injective type variables unused in --- the RHS. Note [Coverage condition for injective type families], step 6 -reportUnusedInjectiveVarsErr :: TyCon - -> TyVarSet - -> Bool -- True <=> print invisible arguments - -> Bool -- True <=> suggest -XUndecidableInstances - -> CoAxBranch - -> TcM () -reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn - = let (loc, doc) = buildInjectivityError fam_tc - (injectivityErrorHerald $$ - herald $$ - text "In the type family equation:") - (tyfamEqn :| []) - in addErrAt loc (pprWithExplicitKindsWhen has_kinds doc) - where - herald = sep [ what <+> text "variable" <> - pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) - , text "cannot be inferred from the right-hand side." ] - $$ extra - - what | has_kinds = text "Type/kind" - | otherwise = text "Type" - - extra | undec_inst = text "Using UndecidableInstances might help" - | otherwise = empty - --- | Report error message for equation that has a type family call at the top --- level of RHS -reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM () -reportTfHeadedErr fam_tc branch - = addErrs [buildInjectivityError fam_tc - (injectivityErrorHerald $$ - text "RHS of injective type family equation cannot" <+> - text "be a type family:") - (branch :| [])] - --- | Report error message for equation that has a bare type variable in the RHS --- but LHS pattern is not a bare type variable. -reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM () -reportBareVariableInRHSErr fam_tc tys branch - = addErrs [buildInjectivityError fam_tc - (injectivityErrorHerald $$ - text "RHS of injective type family equation is a bare" <+> - text "type variable" $$ - text "but these LHS type and kind patterns are not bare" <+> - text "variables:" <+> pprQuotedList tys) - (branch :| [])] - -buildInjectivityError :: TyCon -> SDoc -> NonEmpty CoAxBranch -> (SrcSpan, SDoc) -buildInjectivityError fam_tc herald (eqn1 :| rest_eqns) - = ( coAxBranchSpan eqn1 - , hang herald - 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) ) - -reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () -reportConflictInstErr _ [] - = return () -- No conflicts -reportConflictInstErr fam_inst (match1 : _) - | FamInstMatch { fim_instance = conf_inst } <- match1 - , let sorted = sortBy (SrcLoc.leftmost_smallest `on` getSpan) [fam_inst, conf_inst] - fi1 = head sorted - span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) - = setSrcSpan span $ addErr $ - hang (text "Conflicting family instance declarations:") - 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) - | fi <- sorted - , let ax = famInstAxiom fi ]) - where - getSpan = getSrcSpan . famInstAxiom - -- The sortBy just arranges that instances are displayed in order - -- of source location, which reduced wobbling in error messages, - -- and is better for users - -tcGetFamInstEnvs :: TcM FamInstEnvs --- Gets both the external-package inst-env --- and the home-pkg inst env (includes module being compiled) -tcGetFamInstEnvs - = do { eps <- getEps; env <- getGblEnv - ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) } diff --git a/compiler/typecheck/Flattening-notes b/compiler/typecheck/Flattening-notes deleted file mode 100644 index 2aa9243743..0000000000 --- a/compiler/typecheck/Flattening-notes +++ /dev/null @@ -1,32 +0,0 @@ -ToDo: - -* inert_funeqs, inert_eqs: keep only the CtEvidence. - They are all CFunEqCans, CTyEqCans - -* Consider individual data types for CFunEqCan etc - -* Collapse CNonCanonical and CIrredCan - * RAE: I think it would be better to split off CNonCanonical into its own - type, and remove it completely from Ct. Then, we would keep CIrredCan - -The coercion solver -~~~~~~~~~~~~~~~~~~~~ -Our hope. In GHC currently drawn from {G,W,D}, but with the coercion -solver the flavours become pairs - { (k,l) | k <- {G,W,D}, l <- {Nom,Rep} } - -But can - a -(G,R)-> Int -rewrite - b -(G,R)-> T a -? - -Well, it depends on the roles at which T uses its arguments :-(. -So it may not be enough just to look at (flavour,role) pairs? - -RAE: This is true, but it is taken care of by being careful in the -flattening algorithm. Flattening (T a) looks at the roles of -T's parameters, and chooses the role for flattening `a` appropriately. -This is why there must be the [Role] parameter to flattenMany. -Of course, this non-uniform rewriting may gum up the proof works. - diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs deleted file mode 100644 index 42c06183f7..0000000000 --- a/compiler/typecheck/FunDeps.hs +++ /dev/null @@ -1,678 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 2000 - - -FunDeps - functional dependencies - -It's better to read it as: "if we know these, then we're going to know these" --} - -{-# LANGUAGE CPP #-} - -module FunDeps ( - FunDepEqn(..), pprEquation, - improveFromInstEnv, improveFromAnother, - checkInstCoverage, checkFunDeps, - pprFundeps - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Types.Name -import GHC.Types.Var -import GHC.Core.Class -import GHC.Core.Predicate -import GHC.Core.Type -import TcType( transSuperClasses ) -import GHC.Core.Coercion.Axiom( TypeEqn ) -import GHC.Core.Unify -import GHC.Core.InstEnv -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen ) -import FV -import Outputable -import ErrUtils( Validity(..), allValid ) -import GHC.Types.SrcLoc -import Util - -import Pair ( Pair(..) ) -import Data.List ( nubBy ) -import Data.Maybe -import Data.Foldable ( fold ) - -{- -************************************************************************ -* * -\subsection{Generate equations from functional dependencies} -* * -************************************************************************ - - -Each functional dependency with one variable in the RHS is responsible -for generating a single equality. For instance: - class C a b | a -> b -The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha -will generate the following FunDepEqn - FDEqn { fd_qtvs = [] - , fd_eqs = [Pair Bool alpha] - , fd_pred1 = C Int Bool - , fd_pred2 = C Int alpha - , fd_loc = ... } -However notice that a functional dependency may have more than one variable -in the RHS which will create more than one pair of types in fd_eqs. Example: - class C a b c | a -> b c - [Wanted] C Int alpha alpha - [Wanted] C Int Bool beta -Will generate: - FDEqn { fd_qtvs = [] - , fd_eqs = [Pair Bool alpha, Pair alpha beta] - , fd_pred1 = C Int Bool - , fd_pred2 = C Int alpha - , fd_loc = ... } - -INVARIANT: Corresponding types aren't already equal -That is, there exists at least one non-identity equality in FDEqs. - -Assume: - class C a b c | a -> b c - instance C Int x x -And: [Wanted] C Int Bool alpha -We will /match/ the LHS of fundep equations, producing a matching substitution -and create equations for the RHS sides. In our last example we'd have generated: - ({x}, [fd1,fd2]) -where - fd1 = FDEq 1 Bool x - fd2 = FDEq 2 alpha x -To ``execute'' the equation, make fresh type variable for each tyvar in the set, -instantiate the two types with these fresh variables, and then unify or generate -a new constraint. In the above example we would generate a new unification -variable 'beta' for x and produce the following constraints: - [Wanted] (Bool ~ beta) - [Wanted] (alpha ~ beta) - -Notice the subtle difference between the above class declaration and: - class C a b c | a -> b, a -> c -where we would generate: - ({x},[fd1]),({x},[fd2]) -This means that the template variable would be instantiated to different -unification variables when producing the FD constraints. - -Finally, the position parameters will help us rewrite the wanted constraint ``on the spot'' --} - -data FunDepEqn loc - = FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars - -- to fresh unification vars, - -- Non-empty only for FunDepEqns arising from instance decls - - , fd_eqs :: [TypeEqn] -- Make these pairs of types equal - , fd_pred1 :: PredType -- The FunDepEqn arose from - , fd_pred2 :: PredType -- combining these two constraints - , fd_loc :: loc } - -{- -Given a bunch of predicates that must hold, such as - - C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5 - -improve figures out what extra equations must hold. -For example, if we have - - class C a b | a->b where ... - -then improve will return - - [(t1,t2), (t4,t5)] - -NOTA BENE: - - * improve does not iterate. It's possible that when we make - t1=t2, for example, that will in turn trigger a new equation. - This would happen if we also had - C t1 t7, C t2 t8 - If t1=t2, we also get t7=t8. - - improve does *not* do this extra step. It relies on the caller - doing so. - - * The equations unify types that are not already equal. So there - is no effect iff the result of improve is empty --} - -instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type --- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys) -instFD (ls,rs) tvs tys - = (map lookup ls, map lookup rs) - where - env = zipVarEnv tvs tys - lookup tv = lookupVarEnv_NF env tv - -zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true - -> [Type] -> [Type] - -> [TypeEqn] --- Create a list of (Type,Type) pairs from two lists of types, --- making sure that the types are not already equal -zipAndComputeFDEqs discard (ty1:tys1) (ty2:tys2) - | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2 - | otherwise = Pair ty1 ty2 : zipAndComputeFDEqs discard tys1 tys2 -zipAndComputeFDEqs _ _ _ = [] - --- Improve a class constraint from another class constraint --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -improveFromAnother :: loc - -> PredType -- Template item (usually given, or inert) - -> PredType -- Workitem [that can be improved] - -> [FunDepEqn loc] --- Post: FDEqs always oriented from the other to the workitem --- Equations have empty quantified variables -improveFromAnother loc pred1 pred2 - | Just (cls1, tys1) <- getClassPredTys_maybe pred1 - , Just (cls2, tys2) <- getClassPredTys_maybe pred2 - , cls1 == cls2 - = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = loc } - | let (cls_tvs, cls_fds) = classTvsFds cls1 - , fd <- cls_fds - , let (ltys1, rs1) = instFD fd cls_tvs tys1 - (ltys2, rs2) = instFD fd cls_tvs tys2 - , eqTypes ltys1 ltys2 -- The LHSs match - , let eqs = zipAndComputeFDEqs eqType rs1 rs2 - , not (null eqs) ] - -improveFromAnother _ _ _ = [] - - --- Improve a class constraint from instance declarations --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -instance Outputable (FunDepEqn a) where - ppr = pprEquation - -pprEquation :: FunDepEqn a -> SDoc -pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) - = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs), - nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2 - | Pair t1 t2 <- pairs])] - -improveFromInstEnv :: InstEnvs - -> (PredType -> SrcSpan -> loc) - -> PredType - -> [FunDepEqn loc] -- Needs to be a FunDepEqn because - -- of quantified variables --- Post: Equations oriented from the template (matching instance) to the workitem! -improveFromInstEnv inst_env mk_loc pred - | Just (cls, tys) <- ASSERT2( isClassPred pred, ppr pred ) - getClassPredTys_maybe pred - , let (cls_tvs, cls_fds) = classTvsFds cls - instances = classInstances inst_env cls - rough_tcs = roughMatchTcs tys - = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs - , fd_pred1 = p_inst, fd_pred2 = pred - , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) } - | fd <- cls_fds -- Iterate through the fundeps first, - -- because there often are none! - , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs - -- Trim the rough_tcs based on the head of the fundep. - -- Remember that instanceCantMatch treats both arguments - -- symmetrically, so it's ok to trim the rough_tcs, - -- rather than trimming each inst_tcs in turn - , ispec <- instances - , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec - tys trimmed_tcs -- NB: orientation - , let p_inst = mkClassPred cls (is_tys ispec) - ] -improveFromInstEnv _ _ _ = [] - - -improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class - -> ClsInst -- An instance template - -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate - -> [([TyCoVar], [TypeEqn])] -- Empty or singleton - -improveClsFD clas_tvs fd - (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) - tys_actual rough_tcs_actual - --- Compare instance {a,b} C sx sp sy sq --- with wanted [W] C tx tp ty tq --- for fundep (x,y -> p,q) from class (C x p y q) --- If (sx,sy) unifies with (tx,ty), take the subst S - --- 'qtvs' are the quantified type variables, the ones which can be instantiated --- to make the types match. For example, given --- class C a b | a->b where ... --- instance C (Maybe x) (Tree x) where .. --- --- and a wanted constraint of form (C (Maybe t1) t2), --- then we will call checkClsFD with --- --- is_qtvs = {x}, is_tys = [Maybe x, Tree x] --- tys_actual = [Maybe t1, t2] --- --- We can instantiate x to t1, and then we want to force --- (Tree x) [t1/x] ~ t2 - - | instanceCantMatch rough_tcs_inst rough_tcs_actual - = [] -- Filter out ones that can't possibly match, - - | otherwise - = ASSERT2( equalLength tys_inst tys_actual && - equalLength tys_inst clas_tvs - , ppr tys_inst <+> ppr tys_actual ) - - case tcMatchTyKis ltys1 ltys2 of - Nothing -> [] - Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2) - -- Don't include any equations that already hold. - -- Reason: then we know if any actual improvement has happened, - -- in which case we need to iterate the solver - -- In making this check we must taking account of the fact that any - -- qtvs that aren't already instantiated can be instantiated to anything - -- at all - -- NB: We can't do this 'is-useful-equation' check element-wise - -- because of: - -- class C a b c | a -> b c - -- instance C Int x x - -- [Wanted] C Int alpha Int - -- We would get that x -> alpha (isJust) and x -> Int (isJust) - -- so we would produce no FDs, which is clearly wrong. - -> [] - - | null fdeqs - -> [] - - | otherwise - -> -- pprTrace "iproveClsFD" (vcat - -- [ text "is_tvs =" <+> ppr qtvs - -- , text "tys_inst =" <+> ppr tys_inst - -- , text "tys_actual =" <+> ppr tys_actual - -- , text "ltys1 =" <+> ppr ltys1 - -- , text "ltys2 =" <+> ppr ltys2 - -- , text "subst =" <+> ppr subst ]) $ - [(meta_tvs, fdeqs)] - -- We could avoid this substTy stuff by producing the eqn - -- (qtvs, ls1++rs1, ls2++rs2) - -- which will re-do the ls1/ls2 unification when the equation is - -- executed. What we're doing instead is recording the partial - -- work of the ls1/ls2 unification leaving a smaller unification problem - where - rtys1' = map (substTyUnchecked subst) rtys1 - - fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2 - -- Don't discard anything! - -- We could discard equal types but it's an overkill to call - -- eqType again, since we know for sure that /at least one/ - -- equation in there is useful) - - meta_tvs = [ setVarType tv (substTyUnchecked subst (varType tv)) - | tv <- qtvs, tv `notElemTCvSubst` subst ] - -- meta_tvs are the quantified type variables - -- that have not been substituted out - -- - -- Eg. class C a b | a -> b - -- instance C Int [y] - -- Given constraint C Int z - -- we generate the equation - -- ({y}, [y], z) - -- - -- But note (a) we get them from the dfun_id, so they are *in order* - -- because the kind variables may be mentioned in the - -- type variables' kinds - -- (b) we must apply 'subst' to the kinds, in case we have - -- matched out a kind variable, but not a type variable - -- whose kind mentions that kind variable! - -- #6015, #6068 - where - (ltys1, rtys1) = instFD fd clas_tvs tys_inst - (ltys2, rtys2) = instFD fd clas_tvs tys_actual - -{- -%************************************************************************ -%* * - The Coverage condition for instance declarations -* * -************************************************************************ - -Note [Coverage condition] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Example - class C a b | a -> b - instance theta => C t1 t2 - -For the coverage condition, we check - (normal) fv(t2) `subset` fv(t1) - (liberal) fv(t2) `subset` oclose(fv(t1), theta) - -The liberal version ensures the self-consistency of the instance, but -it does not guarantee termination. Example: - - class Mul a b c | a b -> c where - (.*.) :: a -> b -> c - - instance Mul Int Int Int where (.*.) = (*) - instance Mul Int Float Float where x .*. y = fromIntegral x * y - instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v - -In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]). -But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) ) - -But it is a mistake to accept the instance because then this defn: - f = \ b x y -> if b then x .*. [y] else y -makes instance inference go into a loop, because it requires the constraint - Mul a [b] b --} - -checkInstCoverage :: Bool -- Be liberal - -> Class -> [PredType] -> [Type] - -> Validity --- "be_liberal" flag says whether to use "liberal" coverage of --- See Note [Coverage Condition] below --- --- Return values --- Nothing => no problems --- Just msg => coverage problem described by msg - -checkInstCoverage be_liberal clas theta inst_taus - = allValid (map fundep_ok fds) - where - (tyvars, fds) = classTvsFds clas - fundep_ok fd - | and (isEmptyVarSet <$> undetermined_tvs) = IsValid - | otherwise = NotValid msg - where - (ls,rs) = instFD fd tyvars inst_taus - ls_tvs = tyCoVarsOfTypes ls - rs_tvs = splitVisVarsOfTypes rs - - undetermined_tvs | be_liberal = liberal_undet_tvs - | otherwise = conserv_undet_tvs - - closed_ls_tvs = oclose theta ls_tvs - liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs - conserv_undet_tvs = (`minusVarSet` ls_tvs) <$> rs_tvs - - undet_set = fold undetermined_tvs - - msg = pprWithExplicitKindsWhen - (isEmptyVarSet $ pSnd undetermined_tvs) $ - vcat [ -- text "ls_tvs" <+> ppr ls_tvs - -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs) - -- , text "theta" <+> ppr theta - -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs)) - -- , text "rs_tvs" <+> ppr rs_tvs - sep [ text "The" - <+> ppWhen be_liberal (text "liberal") - <+> text "coverage condition fails in class" - <+> quotes (ppr clas) - , nest 2 $ text "for functional dependency:" - <+> quotes (pprFunDep fd) ] - , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls - , nest 2 $ - (if isSingleton ls - then text "does not" - else text "do not jointly") - <+> text "determine rhs type"<>plural rs - <+> pprQuotedList rs ] - , text "Un-determined variable" <> pluralVarSet undet_set <> colon - <+> pprVarSet undet_set (pprWithCommas ppr) - , ppWhen (not be_liberal && - and (isEmptyVarSet <$> liberal_undet_tvs)) $ - text "Using UndecidableInstances might help" ] - -{- Note [Closing over kinds in coverage] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a fundep (a::k) -> b -Then if 'a' is instantiated to (x y), where x:k2->*, y:k2, -then fixing x really fixes k2 as well, and so k2 should be added to -the lhs tyvars in the fundep check. - -Example (#8391), using liberal coverage - data Foo a = ... -- Foo :: forall k. k -> * - class Bar a b | a -> b - instance Bar a (Foo a) - - In the instance decl, (a:k) does fix (Foo k a), but only if we notice - that (a:k) fixes k. #10109 is another example. - -Here is a more subtle example, from HList-0.4.0.0 (#10564) - - class HasFieldM (l :: k) r (v :: Maybe *) - | l r -> v where ... - class HasFieldM1 (b :: Maybe [*]) (l :: k) r v - | b l r -> v where ... - class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) - | e1 l -> r - - data Label :: k -> * - type family LabelsOf (a :: [*]) :: * - - instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b, - HasFieldM1 b l (r xs) v) - => HasFieldM l (r xs) v where - -Is the instance OK? Does {l,r,xs} determine v? Well: - - * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b, - plus the fundep "| el l -> r" in class HMameberM, - we get {l,k,xs} -> b - - * Note the 'k'!! We must call closeOverKinds on the seed set - ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b - fundep won't fire. This was the reason for #10564. - - * So starting from seeds {l,r,xs,k} we do oclose to get - first {l,r,xs,k,b}, via the HMemberM constraint, and then - {l,r,xs,k,b,v}, via the HasFieldM1 constraint. - - * And that fixes v. - -However, we must closeOverKinds whenever augmenting the seed set -in oclose! Consider #10109: - - data Succ a -- Succ :: forall k. k -> * - class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab - instance (Add a b ab) => Add (Succ {k1} (a :: k1)) - b - (Succ {k3} (ab :: k3}) - -We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}. -Now use the fundep to extend to {a,k1,b,k2,ab}. But we need to -closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all -the variables free in (Succ {k3} ab). - -Bottom line: - * closeOverKinds on initial seeds (done automatically - by tyCoVarsOfTypes in checkInstCoverage) - * and closeOverKinds whenever extending those seeds (in oclose) - -Note [The liberal coverage condition] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(oclose preds tvs) closes the set of type variables tvs, -wrt functional dependencies in preds. The result is a superset -of the argument set. For example, if we have - class C a b | a->b where ... -then - oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z} -because if we know x and y then that fixes z. - -We also use equality predicates in the predicates; if we have an -assumption `t1 ~ t2`, then we use the fact that if we know `t1` we -also know `t2` and the other way. - eg oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} - -oclose is used (only) when checking the coverage condition for -an instance declaration - -Note [Equality superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class (a ~ [b]) => C a b - -Remember from Note [The equality types story] in TysPrim, that - * (a ~~ b) is a superclass of (a ~ b) - * (a ~# b) is a superclass of (a ~~ b) - -So when oclose expands superclasses we'll get a (a ~# [b]) superclass. -But that's an EqPred not a ClassPred, and we jolly well do want to -account for the mutual functional dependencies implied by (t1 ~# t2). -Hence the EqPred handling in oclose. See #10778. - -Note [Care with type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12803) - class C x y | x -> y - type family F a b - type family G c d = r | r -> d - -Now consider - oclose (C (F a b) (G c d)) {a,b} - -Knowing {a,b} fixes (F a b) regardless of the injectivity of F. -But knowing (G c d) fixes only {d}, because G is only injective -in its second parameter. - -Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds. --} - -oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet --- See Note [The liberal coverage condition] -oclose preds fixed_tvs - | null tv_fds = fixed_tvs -- Fast escape hatch for common case. - | otherwise = fixVarSet extend fixed_tvs - where - extend fixed_tvs = foldl' add fixed_tvs tv_fds - where - add fixed_tvs (ls,rs) - | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs - | otherwise = fixed_tvs - -- closeOverKinds: see Note [Closing over kinds in coverage] - - tv_fds :: [(TyCoVarSet,TyCoVarSet)] - tv_fds = [ (tyCoVarsOfTypes ls, fvVarSet $ injectiveVarsOfTypes True rs) - -- See Note [Care with type functions] - | pred <- preds - , pred' <- pred : transSuperClasses pred - -- Look for fundeps in superclasses too - , (ls, rs) <- determined pred' ] - - determined :: PredType -> [([Type],[Type])] - determined pred - = case classifyPredType pred of - EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])] - -- See Note [Equality superclasses] - ClassPred cls tys -> [ instFD fd cls_tvs tys - | let (cls_tvs, cls_fds) = classTvsFds cls - , fd <- cls_fds ] - _ -> [] - - -{- ********************************************************************* -* * - Check that a new instance decl is OK wrt fundeps -* * -************************************************************************ - -Here is the bad case: - class C a b | a->b where ... - instance C Int Bool where ... - instance C Int Char where ... - -The point is that a->b, so Int in the first parameter must uniquely -determine the second. In general, given the same class decl, and given - - instance C s1 s2 where ... - instance C t1 t2 where ... - -Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2). - -Matters are a little more complicated if there are free variables in -the s2/t2. - - class D a b c | a -> b - instance D a b => D [(a,a)] [b] Int - instance D a b => D [a] [b] Bool - -The instance decls don't overlap, because the third parameter keeps -them separate. But we want to make sure that given any constraint - D s1 s2 s3 -if s1 matches - -Note [Bogus consistency check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In checkFunDeps we check that a new ClsInst is consistent with all the -ClsInsts in the environment. - -The bogus aspect is discussed in #10675. Currently it if the two -types are *contradicatory*, using (isNothing . tcUnifyTys). But all -the papers say we should check if the two types are *equal* thus - not (substTys subst rtys1 `eqTypes` substTys subst rtys2) -For now I'm leaving the bogus form because that's the way it has -been for years. --} - -checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst] --- The Consistency Check. --- Check whether adding DFunId would break functional-dependency constraints --- Used only for instance decls defined in the module being compiled --- Returns a list of the ClsInst in InstEnvs that are inconsistent --- with the proposed new ClsInst -checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls - , is_tys = tys1, is_tcs = rough_tcs1 }) - | null fds - = [] - | otherwise - = nubBy eq_inst $ - [ ispec | ispec <- cls_insts - , fd <- fds - , is_inconsistent fd ispec ] - where - cls_insts = classInstances inst_envs cls - (cls_tvs, fds) = classTvsFds cls - qtv_set1 = mkVarSet qtvs1 - - is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 }) - | instanceCantMatch trimmed_tcs rough_tcs2 - = False - | otherwise - = case tcUnifyTyKis bind_fn ltys1 ltys2 of - Nothing -> False - Just subst - -> isNothing $ -- Bogus legacy test (#10675) - -- See Note [Bogus consistency check] - tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2) - - where - trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs1 - (ltys1, rtys1) = instFD fd cls_tvs tys1 - (ltys2, rtys2) = instFD fd cls_tvs tys2 - qtv_set2 = mkVarSet qtvs2 - bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe - | tv `elemVarSet` qtv_set2 = BindMe - | otherwise = Skolem - - eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2 - -- A single instance may appear twice in the un-nubbed conflict list - -- because it may conflict with more than one fundep. E.g. - -- class C a b c | a -> b, a -> c - -- instance C Int Bool Bool - -- instance C Int Char Char - -- The second instance conflicts with the first by *both* fundeps - -trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name] --- Computing rough_tcs for a particular fundep --- class C a b c | a -> b where ... --- For each instance .... => C ta tb tc --- we want to match only on the type ta; so our --- rough-match thing must similarly be filtered. --- Hence, we Nothing-ise the tb and tc types right here --- --- Result list is same length as input list, just with more Nothings -trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs - = zipWith select clas_tvs mb_tcs - where - select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc - | otherwise = Nothing diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs deleted file mode 100644 index 61e408e33e..0000000000 --- a/compiler/typecheck/Inst.hs +++ /dev/null @@ -1,853 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -The @Inst@ type: dictionaries or method instances --} - -{-# LANGUAGE CPP, MultiWayIf, TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module Inst ( - deeplySkolemise, - topInstantiate, topInstantiateInferred, deeplyInstantiate, - instCall, instDFunType, instStupidTheta, instTyVarsWith, - newWanted, newWanteds, - - tcInstInvisibleTyBinders, tcInstInvisibleTyBinder, - - newOverloadedLit, mkOverLit, - - newClsInst, - tcGetInsts, tcGetInstEnvs, getOverlapFlag, - tcExtendLocalInstEnv, - instCallConstraints, newMethodFromName, - tcSyntaxName, - - -- Simple functions over evidence variables - tyCoVarsOfWC, - tyCoVarsOfCt, tyCoVarsOfCts, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp ) -import {-# SOURCE #-} TcUnify( unifyType, unifyKind ) - -import GHC.Types.Basic ( IntegralLit(..), SourceText(..) ) -import FastString -import GHC.Hs -import TcHsSyn -import TcRnMonad -import Constraint -import GHC.Core.Predicate -import TcOrigin -import TcEnv -import TcEvidence -import GHC.Core.InstEnv -import TysWiredIn ( heqDataCon, eqDataCon ) -import GHC.Core ( isOrphan ) -import FunDeps -import TcMType -import GHC.Core.Type -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( debugPprType ) -import TcType -import GHC.Driver.Types -import GHC.Core.Class( Class ) -import GHC.Types.Id.Make( mkDictFunId ) -import GHC.Core( Expr(..) ) -- For the Coercion constructor -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Var ( EvVar, tyVarName, VarBndr(..) ) -import GHC.Core.DataCon -import GHC.Types.Var.Env -import PrelNames -import GHC.Types.SrcLoc as SrcLoc -import GHC.Driver.Session -import Util -import Outputable -import GHC.Types.Basic ( TypeOrKind(..) ) -import qualified GHC.LanguageExtensions as LangExt - -import Data.List ( sortBy ) -import Control.Monad( unless ) -import Data.Function ( on ) - -{- -************************************************************************ -* * - Creating and emittind constraints -* * -************************************************************************ --} - -newMethodFromName - :: CtOrigin -- ^ why do we need this? - -> Name -- ^ name of the method - -> [TcRhoType] -- ^ types with which to instantiate the class - -> TcM (HsExpr GhcTcId) --- ^ Used when 'Name' is the wired-in name for a wired-in class method, --- so the caller knows its type for sure, which should be of form --- --- > forall a. C a => <blah> --- --- 'newMethodFromName' is supposed to instantiate just the outer --- type variable and constraint - -newMethodFromName origin name ty_args - = do { id <- tcLookupId name - -- Use tcLookupId not tcLookupGlobalId; the method is almost - -- always a class op, but with -XRebindableSyntax GHC is - -- meant to find whatever thing is in scope, and that may - -- be an ordinary function. - - ; let ty = piResultTys (idType id) ty_args - (theta, _caller_knows_this) = tcSplitPhiTy ty - ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) - instCall origin ty_args theta - - ; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) } - -{- -************************************************************************ -* * - Deep instantiation and skolemisation -* * -************************************************************************ - -Note [Deep skolemisation] -~~~~~~~~~~~~~~~~~~~~~~~~~ -deeplySkolemise decomposes and skolemises a type, returning a type -with all its arrows visible (ie not buried under foralls) - -Examples: - - deeplySkolemise (Int -> forall a. Ord a => blah) - = ( wp, [a], [d:Ord a], Int -> blah ) - where wp = \x:Int. /\a. \(d:Ord a). <hole> x - - deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah) - = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah ) - where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x - -In general, - if deeplySkolemise ty = (wrap, tvs, evs, rho) - and e :: rho - then wrap e :: ty - and 'wrap' binds tvs, evs - -ToDo: this eta-abstraction plays fast and loose with termination, - because it can introduce extra lambdas. Maybe add a `seq` to - fix this --} - -deeplySkolemise :: TcSigmaType - -> TcM ( HsWrapper - , [(Name,TyVar)] -- All skolemised variables - , [EvVar] -- All "given"s - , TcRhoType ) - -deeplySkolemise ty - = go init_subst ty - where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) - - go subst ty - | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty - = do { let arg_tys' = substTys subst arg_tys - ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys' - ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs - ; ev_vars1 <- newEvVars (substTheta subst' theta) - ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty' - ; let tv_prs1 = map tyVarName tvs `zip` tvs1 - ; return ( mkWpLams ids1 - <.> mkWpTyLams tvs1 - <.> mkWpLams ev_vars1 - <.> wrap - <.> mkWpEvVarApps ids1 - , tv_prs1 ++ tvs_prs2 - , ev_vars1 ++ ev_vars2 - , mkVisFunTys arg_tys' rho ) } - - | otherwise - = return (idHsWrapper, [], [], substTy subst ty) - -- substTy is a quick no-op on an empty substitution - --- | Instantiate all outer type variables --- and any context. Never looks through arrows. -topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- if topInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho (that is, wrap :: ty "->" rho) -topInstantiate = top_instantiate True - --- | Instantiate all outer 'Inferred' binders --- and any context. Never looks through arrows or specified type variables. --- Used for visible type application. -topInstantiateInferred :: CtOrigin -> TcSigmaType - -> TcM (HsWrapper, TcSigmaType) --- if topInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho -topInstantiateInferred = top_instantiate False - -top_instantiate :: Bool -- True <=> instantiate *all* variables - -- False <=> instantiate only the inferred ones - -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) -top_instantiate inst_all orig ty - | not (null binders && null theta) - = do { let (inst_bndrs, leave_bndrs) = span should_inst binders - (inst_theta, leave_theta) - | null leave_bndrs = (theta, []) - | otherwise = ([], theta) - in_scope = mkInScopeSet (tyCoVarsOfType ty) - empty_subst = mkEmptyTCvSubst in_scope - inst_tvs = binderVars inst_bndrs - ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs - ; let inst_theta' = substTheta subst inst_theta - sigma' = substTy subst (mkForAllTys leave_bndrs $ - mkPhiTy leave_theta rho) - inst_tv_tys' = mkTyVarTys inst_tvs' - - ; wrap1 <- instCall orig inst_tv_tys' inst_theta' - ; traceTc "Instantiating" - (vcat [ text "all tyvars?" <+> ppr inst_all - , text "origin" <+> pprCtOrigin orig - , text "type" <+> debugPprType ty - , text "theta" <+> ppr theta - , text "leave_bndrs" <+> ppr leave_bndrs - , text "with" <+> vcat (map debugPprType inst_tv_tys') - , text "theta:" <+> ppr inst_theta' ]) - - ; (wrap2, rho2) <- - if null leave_bndrs - - -- account for types like forall a. Num a => forall b. Ord b => ... - then top_instantiate inst_all orig sigma' - - -- but don't loop if there were any un-inst'able tyvars - else return (idHsWrapper, sigma') - - ; return (wrap2 <.> wrap1, rho2) } - - | otherwise = return (idHsWrapper, ty) - where - (binders, phi) = tcSplitForAllVarBndrs ty - (theta, rho) = tcSplitPhiTy phi - - should_inst bndr - | inst_all = True - | otherwise = binderArgFlag bndr == Inferred - -deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- Int -> forall a. a -> a ==> (\x:Int. [] x alpha) :: Int -> alpha --- In general if --- if deeplyInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho --- That is, wrap :: ty ~> rho --- --- If you don't need the HsWrapper returned from this function, consider --- using tcSplitNestedSigmaTys in TcType, which is a pure alternative that --- only computes the returned TcRhoType. - -deeplyInstantiate orig ty = - deeply_instantiate orig - (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))) - ty - -deeply_instantiate :: CtOrigin - -> TCvSubst - -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- Internal function to deeply instantiate that builds on an existing subst. --- It extends the input substitution and applies the final substitution to --- the types on return. See #12549. - -deeply_instantiate orig subst ty - | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty - = do { (subst', tvs') <- newMetaTyVarsX subst tvs - ; let arg_tys' = substTys subst' arg_tys - theta' = substTheta subst' theta - ; ids1 <- newSysLocalIds (fsLit "di") arg_tys' - ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' - ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig - , text "type" <+> ppr ty - , text "with" <+> ppr tvs' - , text "args:" <+> ppr ids1 - , text "theta:" <+> ppr theta' - , text "subst:" <+> ppr subst']) - ; (wrap2, rho2) <- deeply_instantiate orig subst' rho - ; return (mkWpLams ids1 - <.> wrap2 - <.> wrap1 - <.> mkWpEvVarApps ids1, - mkVisFunTys arg_tys' rho2) } - - | otherwise - = do { let ty' = substTy subst ty - ; traceTc "deeply_instantiate final subst" - (vcat [ text "origin:" <+> pprCtOrigin orig - , text "type:" <+> ppr ty - , text "new type:" <+> ppr ty' - , text "subst:" <+> ppr subst ]) - ; return (idHsWrapper, ty') } - - -instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst --- Use this when you want to instantiate (forall a b c. ty) with --- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might --- not yet match (perhaps because there are unsolved constraints; #14154) --- If they don't match, emit a kind-equality to promise that they will --- eventually do so, and thus make a kind-homongeneous substitution. -instTyVarsWith orig tvs tys - = go emptyTCvSubst tvs tys - where - go subst [] [] - = return subst - go subst (tv:tvs) (ty:tys) - | tv_kind `tcEqType` ty_kind - = go (extendTvSubstAndInScope subst tv ty) tvs tys - | otherwise - = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind - ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys } - where - tv_kind = substTy subst (tyVarKind tv) - ty_kind = tcTypeKind ty - - go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys) - - -{- -************************************************************************ -* * - Instantiating a call -* * -************************************************************************ - -Note [Handling boxed equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The solver deals entirely in terms of unboxed (primitive) equality. -There should never be a boxed Wanted equality. Ever. But, what if -we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality -is boxed, so naive treatment here would emit a boxed Wanted equality. - -So we simply check for this case and make the right boxing of evidence. - --} - ----------------- -instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper --- Instantiate the constraints of a call --- (instCall o tys theta) --- (a) Makes fresh dictionaries as necessary for the constraints (theta) --- (b) Throws these dictionaries into the LIE --- (c) Returns an HsWrapper ([.] tys dicts) - -instCall orig tys theta - = do { dict_app <- instCallConstraints orig theta - ; return (dict_app <.> mkWpTyApps tys) } - ----------------- -instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper --- Instantiates the TcTheta, puts all constraints thereby generated --- into the LIE, and returns a HsWrapper to enclose the call site. - -instCallConstraints orig preds - | null preds - = return idHsWrapper - | otherwise - = do { evs <- mapM go preds - ; traceTc "instCallConstraints" (ppr evs) - ; return (mkWpEvApps evs) } - where - go :: TcPredType -> TcM EvTerm - go pred - | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1 - = do { co <- unifyType Nothing ty1 ty2 - ; return (evCoercion co) } - - -- Try short-cut #2 - | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred - , tc `hasKey` heqTyConKey - = do { co <- unifyType Nothing ty1 ty2 - ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) } - - | otherwise - = emitWanted orig pred - -instDFunType :: DFunId -> [DFunInstType] - -> TcM ( [TcType] -- instantiated argument types - , TcThetaType ) -- instantiated constraint --- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv -instDFunType dfun_id dfun_inst_tys - = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys - ; return (inst_tys, substTheta subst dfun_theta) } - where - dfun_ty = idType dfun_id - (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty)) - -- With quantified constraints, the - -- type of a dfun may not be closed - - go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType]) - go subst [] [] = return (subst, []) - go subst (tv:tvs) (Just ty : mb_tys) - = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty) - tvs - mb_tys - ; return (subst', ty : tys) } - go subst (tv:tvs) (Nothing : mb_tys) - = do { (subst', tv') <- newMetaTyVarX subst tv - ; (subst'', tys) <- go subst' tvs mb_tys - ; return (subst'', mkTyVarTy tv' : tys) } - go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys) - ----------------- -instStupidTheta :: CtOrigin -> TcThetaType -> TcM () --- Similar to instCall, but only emit the constraints in the LIE --- Used exclusively for the 'stupid theta' of a data constructor -instStupidTheta orig theta - = do { _co <- instCallConstraints orig theta -- Discard the coercion - ; return () } - - -{- ********************************************************************* -* * - Instantiating Kinds -* * -********************************************************************* -} - --- | Instantiates up to n invisible binders --- Returns the instantiating types, and body kind -tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind) - -tcInstInvisibleTyBinders 0 kind - = return ([], kind) -tcInstInvisibleTyBinders n ty - = go n empty_subst ty - where - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) - - go n subst kind - | n > 0 - , Just (bndr, body) <- tcSplitPiTy_maybe kind - , isInvisibleBinder bndr - = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr - ; (args, inner_ty) <- go (n-1) subst' body - ; return (arg:args, inner_ty) } - | otherwise - = return ([], substTy subst kind) - --- | Used only in *types* -tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) -tcInstInvisibleTyBinder subst (Named (Bndr tv _)) - = do { (subst', tv') <- newMetaTyVarX subst tv - ; return (subst', mkTyVarTy tv') } - -tcInstInvisibleTyBinder subst (Anon af ty) - | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty) - -- Equality is the *only* constraint currently handled in types. - -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep - = ASSERT( af == InvisArg ) - do { co <- unifyKind Nothing k1 k2 - ; arg' <- mk co - ; return (subst, arg') } - - | otherwise -- This should never happen - -- See GHC.Core.TyCo.Rep Note [Constraints in kinds] - = pprPanic "tcInvisibleTyBinder" (ppr ty) - -------------------------------- -get_eq_tys_maybe :: Type - -> Maybe ( Coercion -> TcM Type - -- given a coercion proving t1 ~# t2, produce the - -- right instantiation for the TyBinder at hand - , Type -- t1 - , Type -- t2 - ) --- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep -get_eq_tys_maybe ty - -- Lifted heterogeneous equality (~~) - | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty - , tc `hasKey` heqTyConKey - = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2) - - -- Lifted homogeneous equality (~) - | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty - , tc `hasKey` eqTyConKey - = Just (\co -> mkEqBoxTy co k1 k2, k1, k2) - - | otherwise - = Nothing - --- | This takes @a ~# b@ and returns @a ~~ b@. -mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type --- monadic just for convenience with mkEqBoxTy -mkHEqBoxTy co ty1 ty2 - = return $ - mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] - where k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 - --- | This takes @a ~# b@ and returns @a ~ b@. -mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type -mkEqBoxTy co ty1 ty2 - = return $ - mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co] - where k = tcTypeKind ty1 - -{- -************************************************************************ -* * - Literals -* * -************************************************************************ - --} - -{- -In newOverloadedLit we convert directly to an Int or Integer if we -know that's what we want. This may save some time, by not -temporarily generating overloaded literals, but it won't catch all -cases (the rest are caught in lookupInst). - --} - -newOverloadedLit :: HsOverLit GhcRn - -> ExpRhoType - -> TcM (HsOverLit GhcTcId) -newOverloadedLit - lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty - | not rebindable - -- all built-in overloaded lits are tau-types, so we can just - -- tauify the ExpType - = do { res_ty <- expTypeToType res_ty - ; dflags <- getDynFlags - ; let platform = targetPlatform dflags - ; case shortCutLit platform val res_ty of - -- Do not generate a LitInst for rebindable syntax. - -- Reason: If we do, tcSimplify will call lookupInst, which - -- will call tcSyntaxName, which does unification, - -- which tcSimplify doesn't like - Just expr -> return (lit { ol_witness = expr - , ol_ext = OverLitTc False res_ty }) - Nothing -> newNonTrivialOverloadedLit orig lit - (mkCheckExpType res_ty) } - - | otherwise - = newNonTrivialOverloadedLit orig lit res_ty - where - orig = LiteralOrigin lit -newOverloadedLit (XOverLit nec) _ = noExtCon nec - --- Does not handle things that 'shortCutLit' can handle. See also --- newOverloadedLit in TcUnify -newNonTrivialOverloadedLit :: CtOrigin - -> HsOverLit GhcRn - -> ExpRhoType - -> TcM (HsOverLit GhcTcId) -newNonTrivialOverloadedLit orig - lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name) - , ol_ext = rebindable }) res_ty - = do { hs_lit <- mkOverLit val - ; let lit_ty = hsLitType hs_lit - ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) - [synKnownType lit_ty] res_ty $ - \_ -> return () - ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] - ; res_ty <- readExpType res_ty - ; return (lit { ol_witness = witness - , ol_ext = OverLitTc rebindable res_ty }) } -newNonTrivialOverloadedLit _ lit _ - = pprPanic "newNonTrivialOverloadedLit" (ppr lit) - ------------- -mkOverLit ::OverLitVal -> TcM (HsLit GhcTc) -mkOverLit (HsIntegral i) - = do { integer_ty <- tcMetaTy integerTyConName - ; return (HsInteger (il_text i) - (il_value i) integer_ty) } - -mkOverLit (HsFractional r) - = do { rat_ty <- tcMetaTy rationalTyConName - ; return (HsRat noExtField r rat_ty) } - -mkOverLit (HsIsString src s) = return (HsString src s) - -{- -************************************************************************ -* * - Re-mappable syntax - - Used only for arrow syntax -- find a way to nuke this -* * -************************************************************************ - -Suppose we are doing the -XRebindableSyntax thing, and we encounter -a do-expression. We have to find (>>) in the current environment, which is -done by the rename. Then we have to check that it has the same type as -Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had -this: - - (>>) :: HB m n mn => m a -> n b -> mn b - -So the idea is to generate a local binding for (>>), thus: - - let then72 :: forall a b. m a -> m b -> m b - then72 = ...something involving the user's (>>)... - in - ...the do-expression... - -Now the do-expression can proceed using then72, which has exactly -the expected type. - -In fact tcSyntaxName just generates the RHS for then72, because we only -want an actual binding in the do-expression case. For literals, we can -just use the expression inline. --} - -tcSyntaxName :: CtOrigin - -> TcType -- ^ Type to instantiate it at - -> (Name, HsExpr GhcRn) -- ^ (Standard name, user name) - -> TcM (Name, HsExpr GhcTcId) - -- ^ (Standard name, suitable expression) --- USED ONLY FOR CmdTop (sigh) *** --- See Note [CmdSyntaxTable] in GHC.Hs.Expr - -tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm)) - | std_nm == user_nm - = do rhs <- newMethodFromName orig std_nm [ty] - return (std_nm, rhs) - -tcSyntaxName orig ty (std_nm, user_nm_expr) = do - std_id <- tcLookupId std_nm - let - -- C.f. newMethodAtLoc - ([tv], _, tau) = tcSplitSigmaTy (idType std_id) - sigma1 = substTyWith [tv] [ty] tau - -- Actually, the "tau-type" might be a sigma-type in the - -- case of locally-polymorphic methods. - - addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do - - -- Check that the user-supplied thing has the - -- same type as the standard one. - -- Tiresome jiggling because tcCheckSigma takes a located expression - span <- getSrcSpanM - expr <- tcPolyExpr (L span user_nm_expr) sigma1 - return (std_nm, unLoc expr) - -syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv - -> TcRn (TidyEnv, SDoc) -syntaxNameCtxt name orig ty tidy_env - = do { inst_loc <- getCtLocM orig (Just TypeLevel) - ; let msg = vcat [ text "When checking that" <+> quotes (ppr name) - <+> text "(needed by a syntactic construct)" - , nest 2 (text "has the required type:" - <+> ppr (tidyType tidy_env ty)) - , nest 2 (pprCtLoc inst_loc) ] - ; return (tidy_env, msg) } - -{- -************************************************************************ -* * - Instances -* * -************************************************************************ --} - -getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag --- Construct the OverlapFlag from the global module flags, --- but if the overlap_mode argument is (Just m), --- set the OverlapMode to 'm' -getOverlapFlag overlap_mode - = do { dflags <- getDynFlags - ; let overlap_ok = xopt LangExt.OverlappingInstances dflags - incoherent_ok = xopt LangExt.IncoherentInstances dflags - use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags - , overlapMode = x } - default_oflag | incoherent_ok = use (Incoherent NoSourceText) - | overlap_ok = use (Overlaps NoSourceText) - | otherwise = use (NoOverlap NoSourceText) - - final_oflag = setOverlapModeMaybe default_oflag overlap_mode - ; return final_oflag } - -tcGetInsts :: TcM [ClsInst] --- Gets the local class instances. -tcGetInsts = fmap tcg_insts getGblEnv - -newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType - -> Class -> [Type] -> TcM ClsInst -newClsInst overlap_mode dfun_name tvs theta clas tys - = do { (subst, tvs') <- freshenTyVarBndrs tvs - -- Be sure to freshen those type variables, - -- so they are sure not to appear in any lookup - ; let tys' = substTys subst tys - - dfun = mkDictFunId dfun_name tvs theta clas tys - -- The dfun uses the original 'tvs' because - -- (a) they don't need to be fresh - -- (b) they may be mentioned in the ib_binds field of - -- an InstInfo, and in TcEnv.pprInstInfoDetails it's - -- helpful to use the same names - - ; oflag <- getOverlapFlag overlap_mode - ; let inst = mkLocalInstance dfun oflag tvs' clas tys' - ; warnIfFlag Opt_WarnOrphans - (isOrphan (is_orphan inst)) - (instOrphWarn inst) - ; return inst } - -instOrphWarn :: ClsInst -> SDoc -instOrphWarn inst - = hang (text "Orphan instance:") 2 (pprInstanceHdr inst) - $$ text "To avoid this" - $$ nest 4 (vcat possibilities) - where - possibilities = - text "move the instance declaration to the module of the class or of the type, or" : - text "wrap the type with a newtype and declare the instance on the new type." : - [] - -tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a - -- Add new locally-defined instances -tcExtendLocalInstEnv dfuns thing_inside - = do { traceDFuns dfuns - ; env <- getGblEnv - ; (inst_env', cls_insts') <- foldlM addLocalInst - (tcg_inst_env env, tcg_insts env) - dfuns - ; let env' = env { tcg_insts = cls_insts' - , tcg_inst_env = inst_env' } - ; setGblEnv env' thing_inside } - -addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) --- Check that the proposed new instance is OK, --- and then add it to the home inst env --- If overwrite_inst, then we can overwrite a direct match -addLocalInst (home_ie, my_insts) ispec - = do { - -- Load imported instances, so that we report - -- duplicates correctly - - -- 'matches' are existing instance declarations that are less - -- specific than the new one - -- 'dups' are those 'matches' that are equal to the new one - ; isGHCi <- getIsGHCi - ; eps <- getEps - ; tcg_env <- getGblEnv - - -- In GHCi, we *override* any identical instances - -- that are also defined in the interactive context - -- See Note [Override identical instances in GHCi] - ; let home_ie' - | isGHCi = deleteFromInstEnv home_ie ispec - | otherwise = home_ie - - global_ie = eps_inst_env eps - inst_envs = InstEnvs { ie_global = global_ie - , ie_local = home_ie' - , ie_visible = tcVisibleOrphanMods tcg_env } - - -- Check for inconsistent functional dependencies - ; let inconsistent_ispecs = checkFunDeps inst_envs ispec - ; unless (null inconsistent_ispecs) $ - funDepErr ispec inconsistent_ispecs - - -- Check for duplicate instance decls. - ; let (_tvs, cls, tys) = instanceHead ispec - (matches, _, _) = lookupInstEnv False inst_envs cls tys - dups = filter (identicalClsInstHead ispec) (map fst matches) - ; unless (null dups) $ - dupInstErr ispec (head dups) - - ; return (extendInstEnv home_ie' ispec, ispec : my_insts) } - -{- -Note [Signature files and type class instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instances in signature files do not have an effect when compiling: -when you compile a signature against an implementation, you will -see the instances WHETHER OR NOT the instance is declared in -the file (this is because the signatures go in the EPS and we -can't filter them out easily.) This is also why we cannot -place the instance in the hi file: it would show up as a duplicate, -and we don't have instance reexports anyway. - -However, you might find them useful when typechecking against -a signature: the instance is a way of indicating to GHC that -some instance exists, in case downstream code uses it. - -Implementing this is a little tricky. Consider the following -situation (sigof03): - - module A where - instance C T where ... - - module ASig where - instance C T - -When compiling ASig, A.hi is loaded, which brings its instances -into the EPS. When we process the instance declaration in ASig, -we should ignore it for the purpose of doing a duplicate check, -since it's not actually a duplicate. But don't skip the check -entirely, we still want this to fail (tcfail221): - - module ASig where - instance C T - instance C T - -Note that in some situations, the interface containing the type -class instances may not have been loaded yet at all. The usual -situation when A imports another module which provides the -instances (sigof02m): - - module A(module B) where - import B - -See also Note [Signature lazy interface loading]. We can't -rely on this, however, since sometimes we'll have spurious -type class instances in the EPS, see #9422 (sigof02dm) - -************************************************************************ -* * - Errors and tracing -* * -************************************************************************ --} - -traceDFuns :: [ClsInst] -> TcRn () -traceDFuns ispecs - = traceTc "Adding instances:" (vcat (map pp ispecs)) - where - pp ispec = hang (ppr (instanceDFunId ispec) <+> colon) - 2 (ppr ispec) - -- Print the dfun name itself too - -funDepErr :: ClsInst -> [ClsInst] -> TcRn () -funDepErr ispec ispecs - = addClsInstsErr (text "Functional dependencies conflict between instance declarations:") - (ispec : ispecs) - -dupInstErr :: ClsInst -> ClsInst -> TcRn () -dupInstErr ispec dup_ispec - = addClsInstsErr (text "Duplicate instance declarations:") - [ispec, dup_ispec] - -addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () -addClsInstsErr herald ispecs - = setSrcSpan (getSrcSpan (head sorted)) $ - addErr (hang herald 2 (pprInstances sorted)) - where - sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs - -- The sortBy just arranges that instances are displayed in order - -- of source location, which reduced wobbling in error messages, - -- and is better for users diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs deleted file mode 100644 index dcd78b5d71..0000000000 --- a/compiler/typecheck/TcAnnotations.hs +++ /dev/null @@ -1,71 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[TcAnnotations]{Typechecking annotations} --} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -module TcAnnotations ( tcAnnotations, annCtxt ) where - -import GhcPrelude - -import {-# SOURCE #-} TcSplice ( runAnnotation ) -import GHC.Types.Module -import GHC.Driver.Session -import Control.Monad ( when ) - -import GHC.Hs -import GHC.Types.Name -import GHC.Types.Annotations -import TcRnMonad -import GHC.Types.SrcLoc -import Outputable -import GHC.Driver.Types - --- Some platforms don't support the interpreter, and compilation on those --- platforms shouldn't fail just due to annotations -tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation] -tcAnnotations anns = do - hsc_env <- getTopEnv - case hsc_interp hsc_env of - Just _ -> mapM tcAnnotation anns - Nothing -> warnAnns anns - -warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] ---- No GHCI; emit a warning (not an error) and ignore. cf #4268 -warnAnns [] = return [] -warnAnns anns@(L loc _ : _) - = do { setSrcSpan loc $ addWarnTc NoReason $ - (text "Ignoring ANN annotation" <> plural anns <> comma - <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") - ; return [] } - -tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation -tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do - -- Work out what the full target of this annotation was - mod <- getModule - let target = annProvenanceToTarget mod provenance - - -- Run that annotation and construct the full Annotation data structure - setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do - -- See #10826 -- Annotations allow one to bypass Safe Haskell. - dflags <- getDynFlags - when (safeLanguageOn dflags) $ failWithTc safeHsErr - runAnnotation target expr - where - safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." - , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] -tcAnnotation (L _ (XAnnDecl nec)) = noExtCon nec - -annProvenanceToTarget :: Module -> AnnProvenance Name - -> AnnTarget Name -annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name -annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name -annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod - -annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc -annCtxt ann - = hang (text "In the annotation:") 2 (ppr ann) diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs deleted file mode 100644 index 1b54417c85..0000000000 --- a/compiler/typecheck/TcArrows.hs +++ /dev/null @@ -1,442 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -Typecheck arrow notation --} - -{-# LANGUAGE RankNTypes, TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcArrows ( tcProc ) where - -import GhcPrelude - -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) - -import GHC.Hs -import TcMatches -import TcHsSyn( hsLPatType ) -import TcType -import TcMType -import TcBinds -import TcPat -import TcUnify -import TcRnMonad -import TcEnv -import TcOrigin -import TcEvidence -import GHC.Types.Id( mkLocalId ) -import Inst -import TysWiredIn -import GHC.Types.Var.Set -import TysPrim -import GHC.Types.Basic( Arity ) -import GHC.Types.SrcLoc -import Outputable -import Util - -import Control.Monad - -{- -Note [Arrow overview] -~~~~~~~~~~~~~~~~~~~~~ -Here's a summary of arrows and how they typecheck. First, here's -a cut-down syntax: - - expr ::= .... - | proc pat cmd - - cmd ::= cmd exp -- Arrow application - | \pat -> cmd -- Arrow abstraction - | (| exp cmd1 ... cmdn |) -- Arrow form, n>=0 - | ... -- If, case in the usual way - - cmd_type ::= carg_type --> type - - carg_type ::= () - | (type, carg_type) - -Note that - * The 'exp' in an arrow form can mention only - "arrow-local" variables - - * An "arrow-local" variable is bound by an enclosing - cmd binding form (eg arrow abstraction) - - * A cmd_type is here written with a funny arrow "-->", - The bit on the left is a carg_type (command argument type) - which itself is a nested tuple, finishing with () - - * The arrow-tail operator (e1 -< e2) means - (| e1 <<< arr snd |) e2 - - -************************************************************************ -* * - Proc -* * -************************************************************************ --} - -tcProc :: InPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr - -> ExpRhoType -- Expected type of whole proc expression - -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion) - -tcProc pat cmd exp_ty - = newArrowScope $ - do { exp_ty <- expTypeToType exp_ty -- no higher-rank stuff with arrows - ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty - ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 - ; let cmd_env = CmdEnv { cmd_arr = arr_ty } - ; (pat', cmd') <- tcPat ProcExpr pat (mkCheckExpType arg_ty) $ - tcCmdTop cmd_env cmd (unitTy, res_ty) - ; let res_co = mkTcTransCo co - (mkTcAppCo co1 (mkTcNomReflCo res_ty)) - ; return (pat', cmd', res_co) } - -{- -************************************************************************ -* * - Commands -* * -************************************************************************ --} - --- See Note [Arrow overview] -type CmdType = (CmdArgType, TcTauType) -- cmd_type -type CmdArgType = TcTauType -- carg_type, a nested tuple - -data CmdEnv - = CmdEnv { - cmd_arr :: TcType -- arrow type constructor, of kind *->*->* - } - -mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType -mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] - ---------------------------------------- -tcCmdTop :: CmdEnv - -> LHsCmdTop GhcRn - -> CmdType - -> TcM (LHsCmdTop GhcTcId) - -tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty) - = setSrcSpan loc $ - do { cmd' <- tcCmd env cmd cmd_ty - ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names - ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') } -tcCmdTop _ (L _ (XCmdTop nec)) _ = noExtCon nec - ----------------------------------------- -tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId) - -- The main recursive function -tcCmd env (L loc cmd) res_ty - = setSrcSpan loc $ do - { cmd' <- tc_cmd env cmd res_ty - ; return (L loc cmd') } - -tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTcId) -tc_cmd env (HsCmdPar x cmd) res_ty - = do { cmd' <- tcCmd env cmd res_ty - ; return (HsCmdPar x cmd') } - -tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty - = do { (binds', body') <- tcLocalBinds binds $ - setSrcSpan body_loc $ - tc_cmd env body res_ty - ; return (HsCmdLet x (L l binds') (L body_loc body')) } - -tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) - = addErrCtxt (cmdCtxt in_cmd) $ do - (scrut', scrut_ty) <- tcInferRho scrut - matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty) - return (HsCmdCase x scrut' matches') - where - match_ctxt = MC { mc_what = CaseAlt, - mc_body = mc_body } - mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' - ; tcCmd env body (stk, res_ty') } - -tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' - = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) - ; b1' <- tcCmd env b1 res_ty - ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2') - } - -tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syntax for if - = do { pred_ty <- newOpenFlexiTyVarTy - -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r - -- because we're going to apply it to the environment, not - -- the return value. - ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] - ; let r_ty = mkTyVarTy r_tv - ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) - (text "Predicate type of `ifThenElse' depends on result type") - ; (pred', fun') - <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty]) - (mkCheckExpType r_ty) $ \ _ -> - tcMonoExpr pred (mkCheckExpType pred_ty) - - ; b1' <- tcCmd env b1 res_ty - ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf x fun' pred' b1' b2') - } - -------------------------------------------- --- Arrow application --- (f -< a) or (f -<< a) --- --- D |- fun :: a t1 t2 --- D,G |- arg :: t1 --- ------------------------ --- D;G |-a fun -< arg :: stk --> t2 --- --- D,G |- fun :: a t1 t2 --- D,G |- arg :: t1 --- ------------------------ --- D;G |-a fun -<< arg :: stk --> t2 --- --- (plus -<< requires ArrowApply) - -tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { arg_ty <- newOpenFlexiTyVarTy - ; let fun_ty = mkCmdArrTy env arg_ty res_ty - ; fun' <- select_arrow_scope (tcMonoExpr fun (mkCheckExpType fun_ty)) - - ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - - ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) } - where - -- Before type-checking f, use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope - -- inside f. In the higher-order case (-<<), they are. - -- See Note [Escaping the arrow scope] in TcRnTypes - select_arrow_scope tc = case ho_app of - HsHigherOrderApp -> tc - HsFirstOrderApp -> escapeArrowScope tc - -------------------------------------------- --- Command application --- --- D,G |- exp : t --- D;G |-a cmd : (t,stk) --> res --- ----------------------------- --- D;G |-a cmd exp : stk --> res - -tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { arg_ty <- newOpenFlexiTyVarTy - ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) - ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - ; return (HsCmdApp x fun' arg') } - -------------------------------------------- --- Lambda --- --- D;G,x:t |-a cmd : stk --> res --- ------------------------------ --- D;G |-a (\x.cmd) : (t,stk) --> res - -tc_cmd env - (HsCmdLam x (MG { mg_alts = L l [L mtch_loc - (match@(Match { m_pats = pats, m_grhss = grhss }))], - mg_origin = origin })) - (cmd_stk, res_ty) - = addErrCtxt (pprMatchInCtxt match) $ - do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk - - -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpan mtch_loc $ - tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $ - tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) - - ; let match' = L mtch_loc (Match { m_ext = noExtField - , m_ctxt = LambdaExpr, m_pats = pats' - , m_grhss = grhss' }) - arg_tys = map hsLPatType pats' - cmd' = HsCmdLam x (MG { mg_alts = L l [match'] - , mg_ext = MatchGroupTc arg_tys res_ty - , mg_origin = origin }) - ; return (mkHsCmdWrap (mkWpCastN co) cmd') } - where - n_pats = length pats - match_ctxt = (LambdaExpr :: HsMatchContext GhcRn) -- Maybe KappaExpr? - pg_ctxt = PatGuard match_ctxt - - tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty - = do { (binds', grhss') <- tcLocalBinds binds $ - mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss - ; return (GRHSs x grhss' (L l binds')) } - tc_grhss (XGRHSs nec) _ _ = noExtCon nec - - tc_grhs stk_ty res_ty (GRHS x guards body) - = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ - \ res_ty -> tcCmd env body - (stk_ty, checkingExpType "tc_grhs" res_ty) - ; return (GRHS x guards' rhs') } - tc_grhs _ _ (XGRHS nec) = noExtCon nec - -------------------------------------------- --- Do notation - -tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty) - = do { co <- unifyType Nothing unitTy cmd_stk -- Expecting empty argument stack - ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty - ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) } - - ------------------------------------------------------------------ --- Arrow ``forms'' (| e c1 .. cn |) --- --- D; G |-a1 c1 : stk1 --> r1 --- ... --- D; G |-an cn : stkn --> rn --- D |- e :: forall e. a1 (e, stk1) t1 --- ... --- -> an (e, stkn) tn --- -> a (e, stk) t --- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) --- ---------------------------------------------- --- D; G |-a (| e c1 ... cn |) : stk --> t - -tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args - -- We use alphaTyVar for 'w' - ; let e_ty = mkInvForAllTy alphaTyVar $ - mkVisFunTys cmd_tys $ - mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty - ; expr' <- tcPolyExpr expr e_ty - ; return (HsCmdArrForm x expr' f fixity cmd_args') } - - where - tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType) - tc_cmd_arg cmd - = do { arr_ty <- newFlexiTyVarTy arrowTyConKind - ; stk_ty <- newFlexiTyVarTy liftedTypeKind - ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; let env' = env { cmd_arr = arr_ty } - ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) - ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } - -tc_cmd _ (XCmd nec) _ = noExtCon nec - ------------------------------------------------------------------ --- Base case for illegal commands --- This is where expressions that aren't commands get rejected - -tc_cmd _ cmd _ - = failWithTc (vcat [text "The expression", nest 2 (ppr cmd), - text "was found where an arrow command was expected"]) - - -matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType) -matchExpectedCmdArgs 0 ty - = return (mkTcNomReflCo ty, [], ty) -matchExpectedCmdArgs n ty - = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty - ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2 - ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } - -{- -************************************************************************ -* * - Stmts -* * -************************************************************************ --} - --------------------------------- --- Mdo-notation --- The distinctive features here are --- (a) RecStmts, and --- (b) no rebindable syntax - -tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker -tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside - = do { rhs' <- tcCmd env rhs (unitTy, res_ty) - ; thing <- thing_inside (panic "tcArrDoStmt") - ; return (LastStmt x rhs' noret noSyntaxExpr, thing) } - -tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside - = do { (rhs', elt_ty) <- tc_arr_rhs env rhs - ; thing <- thing_inside res_ty - ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) } - -tcArrDoStmt env ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside - = do { (rhs', pat_ty) <- tc_arr_rhs env rhs - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - thing_inside res_ty - ; return (mkTcBindStmt pat' rhs', thing) } - -tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names - , recS_rec_ids = rec_names }) res_ty thing_inside - = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names - ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys - ; tcExtendIdEnv tup_ids $ do - { (stmts', tup_rets) - <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> - -- ToDo: res_ty not really right - zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys) - - ; thing <- thing_inside res_ty - -- NB: The rec_ids for the recursive things - -- already scope over this part. This binding may shadow - -- some of them with polymorphic things with the same Name - -- (see note [RecStmt] in GHC.Hs.Expr) - - ; let rec_ids = takeList rec_names tup_ids - ; later_ids <- tcLookupLocalIds later_names - - ; let rec_rets = takeList rec_names tup_rets - ; let ret_table = zip tup_ids tup_rets - ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] - - ; return (emptyRecStmtId { recS_stmts = stmts' - , recS_later_ids = later_ids - , recS_rec_ids = rec_ids - , recS_ext = unitRecStmtTc - { recS_later_rets = later_rets - , recS_rec_rets = rec_rets - , recS_ret_ty = res_ty} }, thing) - }} - -tcArrDoStmt _ _ stmt _ _ - = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) - -tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType) -tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCmd env rhs (unitTy, ty) - ; return (rhs', ty) } - -{- -************************************************************************ -* * - Helpers -* * -************************************************************************ --} - -mkPairTy :: Type -> Type -> Type -mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] - -arrowTyConKind :: Kind -- *->*->* -arrowTyConKind = mkVisFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind - -{- -************************************************************************ -* * - Errors -* * -************************************************************************ --} - -cmdCtxt :: HsCmd GhcRn -> SDoc -cmdCtxt cmd = text "In the command:" <+> ppr cmd diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs deleted file mode 100644 index be35f02a6e..0000000000 --- a/compiler/typecheck/TcBackpack.hs +++ /dev/null @@ -1,1010 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module TcBackpack ( - findExtraSigImports', - findExtraSigImports, - implicitRequirements', - implicitRequirements, - checkUnitId, - tcRnCheckUnitId, - tcRnMergeSignatures, - mergeSignatures, - tcRnInstantiateSignature, - instantiateSignature, -) where - -import GhcPrelude - -import GHC.Types.Basic (defaultFixity, TypeOrKind(..)) -import GHC.Driver.Packages -import TcRnExports -import GHC.Driver.Session -import GHC.Hs -import GHC.Types.Name.Reader -import TcRnMonad -import TcTyDecls -import GHC.Core.InstEnv -import GHC.Core.FamInstEnv -import Inst -import GHC.IfaceToCore -import TcMType -import TcType -import TcSimplify -import Constraint -import TcOrigin -import GHC.Iface.Load -import GHC.Rename.Names -import ErrUtils -import GHC.Types.Id -import GHC.Types.Module -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Avail -import GHC.Types.SrcLoc -import GHC.Driver.Types -import Outputable -import GHC.Core.Type -import FastString -import GHC.Rename.Fixity ( lookupFixityRn ) -import Maybes -import TcEnv -import GHC.Types.Var -import GHC.Iface.Syntax -import PrelNames -import qualified Data.Map as Map - -import GHC.Driver.Finder -import GHC.Types.Unique.DSet -import GHC.Types.Name.Shape -import TcErrors -import TcUnify -import GHC.Iface.Rename -import Util - -import Control.Monad -import Data.List (find) - -import {-# SOURCE #-} TcRnDriver - -#include "HsVersions.h" - -fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc -fixityMisMatch real_thing real_fixity sig_fixity = - vcat [ppr real_thing <+> text "has conflicting fixities in the module", - text "and its hsig file", - text "Main module:" <+> ppr_fix real_fixity, - text "Hsig file:" <+> ppr_fix sig_fixity] - where - ppr_fix f = - ppr f <+> - (if f == defaultFixity - then parens (text "default") - else empty) - -checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn () -checkHsigDeclM sig_iface sig_thing real_thing = do - let name = getName real_thing - -- TODO: Distinguish between signature merging and signature - -- implementation cases. - checkBootDeclM False sig_thing real_thing - real_fixity <- lookupFixityRn name - let sig_fixity = case mi_fix_fn (mi_final_exts sig_iface) (occName name) of - Nothing -> defaultFixity - Just f -> f - when (real_fixity /= sig_fixity) $ - addErrAt (nameSrcSpan name) - (fixityMisMatch real_thing real_fixity sig_fixity) - --- | Given a 'ModDetails' of an instantiated signature (note that the --- 'ModDetails' must be knot-tied consistently with the actual implementation) --- and a 'GlobalRdrEnv' constructed from the implementor of this interface, --- verify that the actual implementation actually matches the original --- interface. --- --- Note that it is already assumed that the implementation *exports* --- a sufficient set of entities, since otherwise the renaming and then --- typechecking of the signature 'ModIface' would have failed. -checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn () -checkHsigIface tcg_env gr sig_iface - ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, - md_types = sig_type_env, md_exports = sig_exports } = do - traceTc "checkHsigIface" $ vcat - [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] - mapM_ check_export (map availName sig_exports) - unless (null sig_fam_insts) $ - panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++ - "instances in hsig files yet...") - -- Delete instances so we don't look them up when - -- checking instance satisfiability - -- TODO: this should not be necessary - tcg_env <- getGblEnv - setGblEnv tcg_env { tcg_inst_env = emptyInstEnv, - tcg_fam_inst_env = emptyFamInstEnv, - tcg_insts = [], - tcg_fam_insts = [] } $ do - mapM_ check_inst sig_insts - failIfErrsM - where - -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig - -- in package p that defines T; and we implement with himpl:H. Then the - -- Name is p[himpl:H]:H.T, NOT himplH:H.T. That's OK but we just - -- have to look up the right name. - sig_type_occ_env = mkOccEnv - . map (\t -> (nameOccName (getName t), t)) - $ nameEnvElts sig_type_env - dfun_names = map getName sig_insts - check_export name - -- Skip instances, we'll check them later - -- TODO: Actually this should never happen, because DFuns are - -- never exported... - | name `elem` dfun_names = return () - -- See if we can find the type directly in the hsig ModDetails - -- TODO: need to special case wired in names - | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do - -- NB: We use tcLookupImported_maybe because we want to EXCLUDE - -- tcg_env (TODO: but maybe this isn't relevant anymore). - r <- tcLookupImported_maybe name - case r of - Failed err -> addErr err - Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing - - -- The hsig did NOT define this function; that means it must - -- be a reexport. In this case, make sure the 'Name' of the - -- reexport matches the 'Name exported here. - | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) = - when (name /= name') $ do - -- See Note [Error reporting bad reexport] - -- TODO: Actually this error swizzle doesn't work - let p (L _ ie) = name `elem` ieNames ie - loc = case tcg_rn_exports tcg_env of - Just es | Just e <- find p (map fst es) - -- TODO: maybe we can be a little more - -- precise here and use the Located - -- info for the *specific* name we matched. - -> getLoc e - _ -> nameSrcSpan name - addErrAt loc - (badReexportedBootThing False name name') - -- This should actually never happen, but whatever... - | otherwise = - addErrAt (nameSrcSpan name) - (missingBootThing False name "exported by") - --- Note [Error reporting bad reexport] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- NB: You want to be a bit careful about what location you report on reexports. --- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the --- correct source location. However, if it was *reexported*, obviously the name --- is not going to have the right location. In this case, we need to grovel in --- tcg_rn_exports to figure out where the reexport came from. - - - --- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't --- assume that the implementing file actually implemented the instances (they --- may be reexported from elsewhere). Where should we look for the instances? --- We do the same as we would otherwise: consult the EPS. This isn't perfect --- (we might conclude the module exports an instance when it doesn't, see --- #9422), but we will never refuse to compile something. -check_inst :: ClsInst -> TcM () -check_inst sig_inst = do - -- TODO: This could be very well generalized to support instance - -- declarations in boot files. - tcg_env <- getGblEnv - -- NB: Have to tug on the interface, not necessarily - -- tugged... but it didn't work? - mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst)) - -- Based off of 'simplifyDeriv' - let ty = idType (instanceDFunId sig_inst) - skol_info = InstSkol - -- Based off of tcSplitDFunTy - (tvs, theta, pred) = - case tcSplitForAllTys ty of { (tvs, rho) -> - case splitFunTys rho of { (theta, pred) -> - (tvs, theta, pred) }} - origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst - (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize - (tclvl,cts) <- pushTcLevelM $ do - wanted <- newWanted origin - (Just TypeLevel) - (substTy skol_subst pred) - givens <- forM theta $ \given -> do - loc <- getCtLocM origin (Just TypeLevel) - let given_pred = substTy skol_subst given - new_ev <- newEvVar given_pred - return CtGiven { ctev_pred = given_pred - -- Doesn't matter, make something up - , ctev_evar = new_ev - , ctev_loc = loc - } - return $ wanted : givens - unsolved <- simplifyWantedsTcM cts - - (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved - reportAllUnsolved (mkImplicWC implic) - --- | Return this list of requirement interfaces that need to be merged --- to form @mod_name@, or @[]@ if this is not a requirement. -requirementMerges :: PackageState -> ModuleName -> [IndefModule] -requirementMerges pkgstate mod_name = - fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate)) - where - -- update ComponentId cached details as they may have changed since the - -- time the ComponentId was created - fixupModule (IndefModule iud name) = IndefModule iud' name - where - iud' = iud { indefUnitIdComponentId = cid' } - cid = indefUnitIdComponentId iud - cid' = updateComponentId pkgstate cid - --- | For a module @modname@ of type 'HscSource', determine the list --- of extra "imports" of other requirements which should be considered part of --- the import of the requirement, because it transitively depends on those --- requirements by imports of modules from other packages. The situation --- is something like this: --- --- unit p where --- signature A --- signature B --- import A --- --- unit q where --- dependency p[A=<A>,B=<B>] --- signature A --- signature B --- --- Although q's B does not directly import A, we still have to make sure we --- process A first, because the merging process will cause B to indirectly --- import A. This function finds the TRANSITIVE closure of all such imports --- we need to make. -findExtraSigImports' :: HscEnv - -> HscSource - -> ModuleName - -> IO (UniqDSet ModuleName) -findExtraSigImports' hsc_env HsigFile modname = - fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) -> - (initIfaceLoad hsc_env - . withException - $ moduleFreeHolesPrecise (text "findExtraSigImports") - (mkModule (IndefiniteUnitId iuid) mod_name))) - where - pkgstate = pkgState (hsc_dflags hsc_env) - reqs = requirementMerges pkgstate modname - -findExtraSigImports' _ _ _ = return emptyUniqDSet - --- | 'findExtraSigImports', but in a convenient form for "GHC.Driver.Make" and --- "TcRnDriver". -findExtraSigImports :: HscEnv -> HscSource -> ModuleName - -> IO [(Maybe FastString, Located ModuleName)] -findExtraSigImports hsc_env hsc_src modname = do - extra_requirements <- findExtraSigImports' hsc_env hsc_src modname - return [ (Nothing, noLoc mod_name) - | mod_name <- uniqDSetToList extra_requirements ] - --- A version of 'implicitRequirements'' which is more friendly --- for "GHC.Driver.Make" and "TcRnDriver". -implicitRequirements :: HscEnv - -> [(Maybe FastString, Located ModuleName)] - -> IO [(Maybe FastString, Located ModuleName)] -implicitRequirements hsc_env normal_imports - = do mns <- implicitRequirements' hsc_env normal_imports - return [ (Nothing, noLoc mn) | mn <- mns ] - --- Given a list of 'import M' statements in a module, figure out --- any extra implicit requirement imports they may have. For --- example, if they 'import M' and M resolves to p[A=<B>], then --- they actually also import the local requirement B. -implicitRequirements' :: HscEnv - -> [(Maybe FastString, Located ModuleName)] - -> IO [ModuleName] -implicitRequirements' hsc_env normal_imports - = fmap concat $ - forM normal_imports $ \(mb_pkg, L _ imp) -> do - found <- findImportedModule hsc_env imp mb_pkg - case found of - Found _ mod | thisPackage dflags /= moduleUnitId mod -> - return (uniqDSetToList (moduleFreeHoles mod)) - _ -> return [] - where dflags = hsc_dflags hsc_env - --- | Given a 'UnitId', make sure it is well typed. This is because --- unit IDs come from Cabal, which does not know if things are well-typed or --- not; a component may have been filled with implementations for the holes --- that don't actually fulfill the requirements. --- --- INVARIANT: the UnitId is NOT a InstalledUnitId -checkUnitId :: UnitId -> TcM () -checkUnitId uid = do - case splitUnitIdInsts uid of - (_, Just indef) -> - let insts = indefUnitIdInsts indef in - forM_ insts $ \(mod_name, mod) -> - -- NB: direct hole instantiations are well-typed by construction - -- (because we FORCE things to be merged in), so don't check them - when (not (isHoleModule mod)) $ do - checkUnitId (moduleUnitId mod) - _ <- mod `checkImplements` IndefModule indef mod_name - return () - _ -> return () -- if it's hashed, must be well-typed - --- | Top-level driver for signature instantiation (run when compiling --- an @hsig@ file.) -tcRnCheckUnitId :: - HscEnv -> UnitId -> - IO (Messages, Maybe ()) -tcRnCheckUnitId hsc_env uid = - withTiming dflags - (text "Check unit id" <+> ppr uid) - (const ()) $ - initTc hsc_env - HsigFile -- bogus - False - mAIN -- bogus - (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus - $ checkUnitId uid - where - dflags = hsc_dflags hsc_env - loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid) - --- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear... - --- | Top-level driver for signature merging (run after typechecking --- an @hsig@ file). -tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface - -> IO (Messages, Maybe TcGblEnv) -tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = - withTiming dflags - (text "Signature merging" <+> brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env HsigFile False this_mod real_loc $ - mergeSignatures hpm orig_tcg_env iface - where - dflags = hsc_dflags hsc_env - this_mod = mi_module iface - real_loc = tcg_top_loc orig_tcg_env - -thinModIface :: [AvailInfo] -> ModIface -> ModIface -thinModIface avails iface = - iface { - mi_exports = avails, - -- mi_fixities = ..., - -- mi_warns = ..., - -- mi_anns = ..., - -- TODO: The use of nameOccName here is a bit dodgy, because - -- perhaps there might be two IfaceTopBndr that are the same - -- OccName but different Name. Requires better understanding - -- of invariants here. - mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls - -- mi_insts = ..., - -- mi_fam_insts = ..., - } - where - decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs - filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface) - - exported_occs = mkOccSet [ occName n - | a <- avails - , n <- availNames a ] - exported_decls = filter_decls exported_occs - - non_exported_occs = mkOccSet [ occName n - | (_, d) <- exported_decls - , n <- ifaceDeclNeverExportedRefs d ] - non_exported_decls = filter_decls non_exported_occs - - dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True - dfun_pred _ = False - dfun_decls = filter (dfun_pred . snd) (mi_decls iface) - --- | The list of 'Name's of *non-exported* 'IfaceDecl's which this --- 'IfaceDecl' may refer to. A non-exported 'IfaceDecl' should be kept --- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps) --- refers to it; we can't decide to keep it by looking at the exports --- of a module after thinning. Keep this synchronized with --- 'rnIfaceDecl'. -ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name] -ifaceDeclNeverExportedRefs d@IfaceFamily{} = - case ifFamFlav d of - IfaceClosedSynFamilyTyCon (Just (n, _)) - -> [n] - _ -> [] -ifaceDeclNeverExportedRefs _ = [] - - --- Note [Blank hsigs for all requirements] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- One invariant that a client of GHC must uphold is that there --- must be an hsig file for every requirement (according to --- @-this-unit-id@); this ensures that for every interface --- file (hi), there is a source file (hsig), which helps grease --- the wheels of recompilation avoidance which assumes that --- source files always exist. - -{- -inheritedSigPvpWarning :: WarningTxt -inheritedSigPvpWarning = - WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))] - where - msg = "Inherited requirements from non-signature libraries (libraries " ++ - "with modules) should not be used, as this mode of use is not " ++ - "compatible with PVP-style version bounds. Instead, copy the " ++ - "declaration to the local hsig file or move the signature to a " ++ - "library of its own and add that library as a dependency." --} - --- Note [Handling never-exported TyThings under Backpack] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will --- never be mentioned in the export list of a module (mi_avails). --- Unlike implicit TyThings (Note [Implicit TyThings]), non-exported --- TyThings DO have a standalone IfaceDecl declaration in their --- interface file. --- --- Originally, Backpack was designed under the assumption that anything --- you could declare in a module could also be exported; thus, merging --- the export lists of two signatures is just merging the declarations --- of two signatures writ small. Of course, in GHC Haskell, there are a --- few important things which are not explicitly exported but still can --- be used: in particular, dictionary functions for instances, Typeable --- TyCon bindings, and coercion axioms for type families also count. --- --- When handling these non-exported things, there two primary things --- we need to watch out for: --- --- * Signature matching/merging is done by comparing each --- of the exported entities of a signature and a module. These exported --- entities may refer to non-exported TyThings which must be tested for --- consistency. For example, an instance (ClsInst) will refer to a --- non-exported DFunId. In this case, 'checkBootDeclM' directly compares the --- embedded 'DFunId' in 'is_dfun'. --- --- For this to work at all, we must ensure that pointers in 'is_dfun' refer --- to DISTINCT 'DFunId's, even though the 'Name's (may) be the same. --- Unfortunately, this is the OPPOSITE of how we treat most other references --- to 'Name's, so this case needs to be handled specially. --- --- The details are in the documentation for 'typecheckIfacesForMerging'. --- and the Note [Resolving never-exported Names] in GHC.IfaceToCore. --- --- * When we rename modules and signatures, we use the export lists to --- decide how the declarations should be renamed. However, this --- means we don't get any guidance for how to rename non-exported --- entities. Fortunately, we only need to rename these entities --- *consistently*, so that 'typecheckIfacesForMerging' can wire them --- up as needed. --- --- The details are in Note [rnIfaceNeverExported] in 'GHC.Iface.Rename'. --- --- The root cause for all of these complications is the fact that these --- logically "implicit" entities are defined indirectly in an interface --- file. #13151 gives a proposal to make these *truly* implicit. - -merge_msg :: ModuleName -> [IndefModule] -> SDoc -merge_msg mod_name [] = - text "while checking the local signature" <+> ppr mod_name <+> - text "for consistency" -merge_msg mod_name reqs = - hang (text "while merging the signatures from" <> colon) - 2 (vcat [ bullet <+> ppr req | req <- reqs ] $$ - bullet <+> text "...and the local signature for" <+> ppr mod_name) - --- | Given a local 'ModIface', merge all inherited requirements --- from 'requirementMerges' into this signature, producing --- a final 'TcGblEnv' that matches the local signature and --- all required signatures. -mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv -mergeSignatures - (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }), - hpm_src_files = src_files }) - orig_tcg_env lcl_iface0 = setSrcSpan loc $ do - -- The lcl_iface0 is the ModIface for the local hsig - -- file, which is guaranteed to exist, see - -- Note [Blank hsigs for all requirements] - hsc_env <- getTopEnv - dflags <- getDynFlags - - -- Copy over some things from the original TcGblEnv that - -- we want to preserve - updGblEnv (\env -> env { - -- Renamed imports/declarations are often used - -- by programs that use the GHC API, e.g., Haddock. - -- These won't get filled by the merging process (since - -- we don't actually rename the parsed module again) so - -- we need to take them directly from the previous - -- typechecking. - -- - -- NB: the export declarations aren't in their final - -- form yet. We'll fill those in when we reprocess - -- the export declarations. - tcg_rn_imports = tcg_rn_imports orig_tcg_env, - tcg_rn_decls = tcg_rn_decls orig_tcg_env, - -- Annotations - tcg_ann_env = tcg_ann_env orig_tcg_env, - -- Documentation header - tcg_doc_hdr = tcg_doc_hdr orig_tcg_env - -- tcg_dus? - -- tcg_th_used = tcg_th_used orig_tcg_env, - -- tcg_th_splice_used = tcg_th_splice_used orig_tcg_env - }) $ do - tcg_env <- getGblEnv - - let outer_mod = tcg_mod tcg_env - inner_mod = tcg_semantic_mod tcg_env - mod_name = moduleName (tcg_mod tcg_env) - pkgstate = pkgState dflags - - -- STEP 1: Figure out all of the external signature interfaces - -- we are going to merge in. - let reqs = requirementMerges pkgstate mod_name - - addErrCtxt (merge_msg mod_name reqs) $ do - - -- STEP 2: Read in the RAW forms of all of these interfaces - ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) -> - let m = mkModule (IndefiniteUnitId iuid) mod_name - im = fst (splitModuleInsts m) - in fmap fst - . withException - $ findAndReadIface (text "mergeSignatures") im m False - - -- STEP 3: Get the unrenamed exports of all these interfaces, - -- thin it according to the export list, and do shaping on them. - let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as - -- This function gets run on every inherited interface, and - -- it's responsible for: - -- - -- 1. Merging the exports of the interface into @nsubst@, - -- 2. Adding these exports to the "OK to import" set (@oks@) - -- if they came from a package with no exposed modules - -- (this means we won't report a PVP error in this case), and - -- 3. Thinning the interface according to an explicit export - -- list. - -- - gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do - let insts = indefUnitIdInsts iuid - isFromSignaturePackage = - let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid)) - pkg = getInstalledPackageDetails pkgstate inst_uid - in null (exposedModules pkg) - -- 3(a). Rename the exports according to how the dependency - -- was instantiated. The resulting export list will be accurate - -- except for exports *from the signature itself* (which may - -- be subsequently updated by exports from other signatures in - -- the merge. - as1 <- tcRnModExports insts ireq_iface - -- 3(b). Thin the interface if it comes from a signature package. - (thinned_iface, as2) <- case mb_exports of - Just (L loc _) - -- Check if the package containing this signature is - -- a signature package (i.e., does not expose any - -- modules.) If so, we can thin it. - | isFromSignaturePackage - -> setSrcSpan loc $ do - -- Suppress missing errors; they might be used to refer - -- to entities from other signatures we are merging in. - -- If an identifier truly doesn't exist in any of the - -- signatures that are merged in, we will discover this - -- when we run exports_from_avail on the final merged - -- export list. - (mb_r, msgs) <- tryTc $ do - -- Suppose that we have written in a signature: - -- signature A ( module A ) where {- empty -} - -- If I am also inheriting a signature from a - -- signature package, does 'module A' scope over - -- all of its exports? - -- - -- There are two possible interpretations: - -- - -- 1. For non self-reexports, a module reexport - -- is interpreted only in terms of the local - -- signature module, and not any of the inherited - -- ones. The reason for this is because after - -- typechecking, module exports are completely - -- erased from the interface of a file, so we - -- have no way of "interpreting" a module reexport. - -- Thus, it's only useful for the local signature - -- module (where we have a useful GlobalRdrEnv.) - -- - -- 2. On the other hand, a common idiom when - -- you want to "export everything, plus a reexport" - -- in modules is to say module A ( module A, reex ). - -- This applies to signature modules too; and in - -- particular, you probably still want the entities - -- from the inherited signatures to be preserved - -- too. - -- - -- We think it's worth making a special case for - -- self reexports to make use case (2) work. To - -- do this, we take the exports of the inherited - -- signature @as1@, and bundle them into a - -- GlobalRdrEnv where we treat them as having come - -- from the import @import A@. Thus, we will - -- pick them up if they are referenced explicitly - -- (@foo@) or even if we do a module reexport - -- (@module A@). - let ispec = ImpSpec ImpDeclSpec{ - -- NB: This needs to be mod name - -- of the local signature, not - -- the (original) module name of - -- the inherited signature, - -- because we need module - -- LocalSig (from the local - -- export list) to match it! - is_mod = mod_name, - is_as = mod_name, - is_qual = False, - is_dloc = loc - } ImpAll - rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1) - setGblEnv tcg_env { - tcg_rdr_env = rdr_env - } $ exports_from_avail mb_exports rdr_env - -- NB: tcg_imports is also empty! - emptyImportAvails - (tcg_semantic_mod tcg_env) - case mb_r of - Just (_, as2) -> return (thinModIface as2 ireq_iface, as2) - Nothing -> addMessages msgs >> failM - -- We can't think signatures from non signature packages - _ -> return (ireq_iface, as1) - -- 3(c). Only identifiers from signature packages are "ok" to - -- import (that is, they are safe from a PVP perspective.) - -- (NB: This code is actually dead right now.) - let oks' | isFromSignaturePackage - = extendOccSetList oks (exportOccs as2) - | otherwise - = oks - -- 3(d). Extend the name substitution (performing shaping) - mb_r <- extend_ns nsubst as2 - case mb_r of - Left err -> failWithTc err - Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces) - nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0) - ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0)) - -- Process each interface, getting the thinned interfaces as well as - -- the final, full set of exports @nsubst@ and the exports which are - -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.) - (nsubst, ok_to_use, rev_thinned_ifaces) - <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0) - let thinned_ifaces = reverse rev_thinned_ifaces - exports = nameShapeExports nsubst - rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports) - _warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports) - warns = NoWarnings - {- - -- TODO: Warnings are transitive, but this is not what we want here: - -- if a module reexports an entity from a signature, that should be OK. - -- Not supported in current warning framework - warns | null warn_occs = NoWarnings - | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs - -} - setGblEnv tcg_env { - -- The top-level GlobalRdrEnv is quite interesting. It consists - -- of two components: - -- 1. First, we reuse the GlobalRdrEnv of the local signature. - -- This is very useful, because it means that if we have - -- to print a message involving some entity that the local - -- signature imported, we'll qualify it accordingly. - -- 2. Second, we need to add all of the declarations we are - -- going to merge in (as they need to be in scope for the - -- final test of the export list.) - tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env, - -- Inherit imports from the local signature, so that module - -- reexports are picked up correctly - tcg_imports = tcg_imports orig_tcg_env, - tcg_exports = exports, - tcg_dus = usesOnly (availsToNameSetWithSelectors exports), - tcg_warns = warns - } $ do - tcg_env <- getGblEnv - - -- Make sure we didn't refer to anything that doesn't actually exist - -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return () - (mb_lies, _) <- exports_from_avail mb_exports rdr_env - (tcg_imports tcg_env) (tcg_semantic_mod tcg_env) - - {- -- NB: This is commented out, because warns above is disabled. - -- If you tried to explicitly export an identifier that has a warning - -- attached to it, that's probably a mistake. Warn about it. - case mb_lies of - Nothing -> return () - Just lies -> - forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) -> - setSrcSpan loc $ - unless (nameOccName n `elemOccSet` ok_to_use) $ - addWarn NoReason $ vcat [ - text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.", - parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.") - ] - -} - - failIfErrsM - - -- Save the exports - setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do - tcg_env <- getGblEnv - - -- STEP 4: Rename the interfaces - ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) -> - tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface - lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0 - let ifaces = lcl_iface : ext_ifaces - - -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env - let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) - | (occ, f) <- concatMap mi_fixities ifaces - , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ] - - -- STEP 5: Typecheck the interfaces - let type_env_var = tcg_type_env_var tcg_env - - -- typecheckIfacesForMerging does two things: - -- 1. It merges the all of the ifaces together, and typechecks the - -- result to type_env. - -- 2. It typechecks each iface individually, but with their 'Name's - -- resolving to the merged type_env from (1). - -- See typecheckIfacesForMerging for more details. - (type_env, detailss) <- initIfaceTcRn $ - typecheckIfacesForMerging inner_mod ifaces type_env_var - let infos = zip ifaces detailss - - -- Test for cycles - checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) [] - - -- NB on type_env: it contains NO dfuns. DFuns are recorded inside - -- detailss, and given a Name that doesn't correspond to anything real. See - -- also Note [Signature merging DFuns] - - -- Add the merged type_env to TcGblEnv, so that it gets serialized - -- out when we finally write out the interface. - -- - -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly, - -- rather than use tcExtendGlobalEnv (the normal method to add newly - -- defined types to TcGblEnv?) tcExtendGlobalEnv adds these - -- TyThings to 'tcg_type_env_var', which is consulted when - -- we read in interfaces to tie the knot. But *these TyThings themselves - -- come from interface*, so that would result in deadlock. Don't - -- update it! - setGblEnv tcg_env { - tcg_tcs = typeEnvTyCons type_env, - tcg_patsyns = typeEnvPatSyns type_env, - tcg_type_env = type_env, - tcg_fix_env = fix_env - } $ do - tcg_env <- getGblEnv - - -- STEP 6: Check for compatibility/merge things - tcg_env <- (\x -> foldM x tcg_env infos) - $ \tcg_env (iface, details) -> do - - let check_export name - | Just sig_thing <- lookupTypeEnv (md_types details) name - = case lookupTypeEnv type_env (getName sig_thing) of - Just thing -> checkHsigDeclM iface sig_thing thing - Nothing -> panic "mergeSignatures: check_export" - -- Oops! We're looking for this export but it's - -- not actually in the type environment of the signature's - -- ModDetails. - -- - -- NB: This case happens because the we're iterating - -- over the union of all exports, so some interfaces - -- won't have everything. Note that md_exports is nonsense - -- (it's the same as exports); maybe we should fix this - -- eventually. - | otherwise - = return () - mapM_ check_export (map availName exports) - - -- Note [Signature merging instances] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Merge instances into the global environment. The algorithm here is - -- dumb and simple: if an instance has exactly the same DFun type - -- (tested by 'memberInstEnv') as an existing instance, we drop it; - -- otherwise, we add it even, even if this would cause overlap. - -- - -- Why don't we deduplicate instances with identical heads? There's no - -- good choice if they have premises: - -- - -- instance K1 a => K (T a) - -- instance K2 a => K (T a) - -- - -- Why not eagerly error in this case? The overlapping head does not - -- necessarily mean that the instances are unimplementable: in fact, - -- they may be implemented without overlap (if, for example, the - -- implementing module has 'instance K (T a)'; both are implemented in - -- this case.) The implements test just checks that the wanteds are - -- derivable assuming the givens. - -- - -- Still, overlapping instances with hypotheses like above are going - -- to be a bad deal, because instance resolution when we're typechecking - -- against the merged signature is going to have a bad time when - -- there are overlapping heads like this: we never backtrack, so it - -- may be difficult to see that a wanted is derivable. For now, - -- we hope that we get lucky / the overlapping instances never - -- get used, but it is not a very good situation to be in. - -- - let merge_inst (insts, inst_env) inst - | memberInstEnv inst_env inst -- test DFun Type equality - = (insts, inst_env) - | otherwise - -- NB: is_dfun_name inst is still nonsense here, - -- see Note [Signature merging DFuns] - = (inst:insts, extendInstEnv inst_env inst) - (insts, inst_env) = foldl' merge_inst - (tcg_insts tcg_env, tcg_inst_env tcg_env) - (md_insts details) - -- This is a HACK to prevent calculateAvails from including imp_mod - -- in the listing. We don't want it because a module is NOT - -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 - iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } } - avails = plusImportAvails (tcg_imports tcg_env) $ - calculateAvails dflags iface' False False ImportedBySystem - return tcg_env { - tcg_inst_env = inst_env, - tcg_insts = insts, - tcg_imports = avails, - tcg_merged = - if outer_mod == mi_module iface - -- Don't add ourselves! - then tcg_merged tcg_env - else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env - } - - -- Note [Signature merging DFuns] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Once we know all of instances which will be defined by this merged - -- signature, we go through each of the DFuns and rename them with a fresh, - -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing - -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'. - -- - -- We can't do this fixup earlier, because we need a way to identify each - -- source DFun (from each of the signatures we are merging in) so that - -- when we have a ClsInst, we can pull up the correct DFun to check if - -- the types match. - -- - -- See also Note [rnIfaceNeverExported] in GHC.Iface.Rename - dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do - n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst)) - let dfun = setVarName (is_dfun inst) n - return (dfun, inst { is_dfun_name = n, is_dfun = dfun }) - tcg_env <- return tcg_env { - tcg_insts = map snd dfun_insts, - tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) - } - - addDependentFiles src_files - - return tcg_env - --- | Top-level driver for signature instantiation (run when compiling --- an @hsig@ file.) -tcRnInstantiateSignature :: - HscEnv -> Module -> RealSrcSpan -> - IO (Messages, Maybe TcGblEnv) -tcRnInstantiateSignature hsc_env this_mod real_loc = - withTiming dflags - (text "Signature instantiation"<+>brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature - where - dflags = hsc_dflags hsc_env - -exportOccs :: [AvailInfo] -> [OccName] -exportOccs = concatMap (map occName . availNames) - -impl_msg :: Module -> IndefModule -> SDoc -impl_msg impl_mod (IndefModule req_uid req_mod_name) = - text "while checking that" <+> ppr impl_mod <+> - text "implements signature" <+> ppr req_mod_name <+> - text "in" <+> ppr req_uid - --- | Check if module implements a signature. (The signature is --- always un-hashed, which is why its components are specified --- explicitly.) -checkImplements :: Module -> IndefModule -> TcRn TcGblEnv -checkImplements impl_mod req_mod@(IndefModule uid mod_name) = - addErrCtxt (impl_msg impl_mod req_mod) $ do - let insts = indefUnitIdInsts uid - - -- STEP 1: Load the implementing interface, and make a RdrEnv - -- for its exports. Also, add its 'ImportAvails' to 'tcg_imports', - -- so that we treat all orphan instances it provides as visible - -- when we verify that all instances are checked (see #12945), and so that - -- when we eventually write out the interface we record appropriate - -- dependency information. - impl_iface <- initIfaceTcRn $ - loadSysInterface (text "checkImplements 1") impl_mod - let impl_gr = mkGlobalRdrEnv - (gresFromAvails Nothing (mi_exports impl_iface)) - nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface) - - -- Load all the orphans, so the subsequent 'checkHsigIface' sees - -- all the instances it needs to - loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)") - (dep_orphs (mi_deps impl_iface)) - - dflags <- getDynFlags - let avails = calculateAvails dflags - impl_iface False{- safe -} False{- boot -} ImportedBySystem - fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f) - | (occ, f) <- mi_fixities impl_iface - , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ] - updGblEnv (\tcg_env -> tcg_env { - -- Setting tcg_rdr_env to treat all exported entities from - -- the implementing module as in scope improves error messages, - -- as it reduces the amount of qualification we need. Unfortunately, - -- we still end up qualifying references to external modules - -- (see bkpfail07 for an example); we'd need to record more - -- information in ModIface to solve this. - tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr, - tcg_imports = tcg_imports tcg_env `plusImportAvails` avails, - -- This is here so that when we call 'lookupFixityRn' for something - -- directly implemented by the module, we grab the right thing - tcg_fix_env = fix_env - }) $ do - - -- STEP 2: Load the *unrenamed, uninstantiated* interface for - -- the ORIGINAL signature. We are going to eventually rename it, - -- but we must proceed slowly, because it is NOT known if the - -- instantiation is correct. - let sig_mod = mkModule (IndefiniteUnitId uid) mod_name - isig_mod = fst (splitModuleInsts sig_mod) - mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False - isig_iface <- case mb_isig_iface of - Succeeded (iface, _) -> return iface - Failed err -> failWithTc $ - hang (text "Could not find hi interface for signature" <+> - quotes (ppr isig_mod) <> colon) 4 err - - -- STEP 3: Check that the implementing interface exports everything - -- we need. (Notice we IGNORE the Modules in the AvailInfos.) - forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> - case lookupGlobalRdrEnv impl_gr occ of - [] -> addErr $ quotes (ppr occ) - <+> text "is exported by the hsig file, but not" - <+> text "exported by the implementing module" - <+> quotes (ppr impl_mod) - _ -> return () - failIfErrsM - - -- STEP 4: Now that the export is complete, rename the interface... - sig_iface <- tcRnModIface insts (Just nsubst) isig_iface - - -- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst - -- lets us determine how top-level identifiers should be handled.) - sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface - - -- STEP 6: Check that it's sufficient - tcg_env <- getGblEnv - checkHsigIface tcg_env impl_gr sig_iface sig_details - - -- STEP 7: Return the updated 'TcGblEnv' with the signature exports, - -- so we write them out. - return tcg_env { - tcg_exports = mi_exports sig_iface - } - --- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite --- library to use the actual implementations of the relevant entities, --- checking that the implementation matches the signature. -instantiateSignature :: TcRn TcGblEnv -instantiateSignature = do - tcg_env <- getGblEnv - dflags <- getDynFlags - let outer_mod = tcg_mod tcg_env - inner_mod = tcg_semantic_mod tcg_env - -- TODO: setup the local RdrEnv so the error messages look a little better. - -- But this information isn't stored anywhere. Should we RETYPECHECK - -- the local one just to get the information? Hmm... - MASSERT( moduleUnitId outer_mod == thisPackage dflags ) - inner_mod `checkImplements` - IndefModule - (newIndefUnitId (thisComponentId dflags) - (thisUnitIdInsts dflags)) - (moduleName outer_mod) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs deleted file mode 100644 index 26e4ade66d..0000000000 --- a/compiler/typecheck/TcBinds.hs +++ /dev/null @@ -1,1732 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcBinds]{TcBinds} --} - -{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds, - tcHsBootSigs, tcPolyCheck, - chooseInferredQuantifiers, - badBootDeclErr ) where - -import GhcPrelude - -import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) -import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) -import GHC.Core (Tickish (..)) -import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) -import GHC.Driver.Session -import FastString -import GHC.Hs -import TcSigs -import TcRnMonad -import TcOrigin -import TcEnv -import TcUnify -import TcSimplify -import TcEvidence -import TcHsType -import TcPat -import TcMType -import GHC.Core.FamInstEnv( normaliseType ) -import FamInst( tcGetFamInstEnvs ) -import GHC.Core.TyCon -import TcType -import GHC.Core.Type (mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy) -import TysPrim -import TysWiredIn( mkBoxedTupleTy ) -import GHC.Types.Id -import GHC.Types.Var as Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env( TidyEnv ) -import GHC.Types.Module -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import GHC.Types.SrcLoc -import Bag -import ErrUtils -import Digraph -import Maybes -import Util -import GHC.Types.Basic -import Outputable -import PrelNames( ipClassName ) -import TcValidity (checkValidType) -import GHC.Types.Unique.FM -import GHC.Types.Unique.Set -import qualified GHC.LanguageExtensions as LangExt -import GHC.Core.ConLike - -import Control.Monad -import Data.Foldable (find) - -#include "HsVersions.h" - -{- -************************************************************************ -* * -\subsection{Type-checking bindings} -* * -************************************************************************ - -@tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because -it needs to know something about the {\em usage} of the things bound, -so that it can create specialisations of them. So @tcBindsAndThen@ -takes a function which, given an extended environment, E, typechecks -the scope of the bindings returning a typechecked thing and (most -important) an LIE. It is this LIE which is then used as the basis for -specialising the things bound. - -@tcBindsAndThen@ also takes a "combiner" which glues together the -bindings and the "thing" to make a new "thing". - -The real work is done by @tcBindWithSigsAndThen@. - -Recursive and non-recursive binds are handled in essentially the same -way: because of uniques there are no scoping issues left. The only -difference is that non-recursive bindings can bind primitive values. - -Even for non-recursive binding groups we add typings for each binder -to the LVE for the following reason. When each individual binding is -checked the type of its LHS is unified with that of its RHS; and -type-checking the LHS of course requires that the binder is in scope. - -At the top-level the LIE is sure to contain nothing but constant -dictionaries, which we resolve at the module level. - -Note [Polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The game plan for polymorphic recursion in the code above is - - * Bind any variable for which we have a type signature - to an Id with a polymorphic type. Then when type-checking - the RHSs we'll make a full polymorphic call. - -This fine, but if you aren't a bit careful you end up with a horrendous -amount of partial application and (worse) a huge space leak. For example: - - f :: Eq a => [a] -> [a] - f xs = ...f... - -If we don't take care, after typechecking we get - - f = /\a -> \d::Eq a -> let f' = f a d - in - \ys:[a] -> ...f'... - -Notice the stupid construction of (f a d), which is of course -identical to the function we're executing. In this case, the -polymorphic recursion isn't being used (but that's a very common case). -This can lead to a massive space leak, from the following top-level defn -(post-typechecking) - - ff :: [Int] -> [Int] - ff = f Int dEqInt - -Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but -f' is another thunk which evaluates to the same thing... and you end -up with a chain of identical values all hung onto by the CAF ff. - - ff = f Int dEqInt - - = let f' = f Int dEqInt in \ys. ...f'... - - = let f' = let f' = f Int dEqInt in \ys. ...f'... - in \ys. ...f'... - -Etc. - -NOTE: a bit of arity analysis would push the (f a d) inside the (\ys...), -which would make the space leak go away in this case - -Solution: when typechecking the RHSs we always have in hand the -*monomorphic* Ids for each binding. So we just need to make sure that -if (Method f a d) shows up in the constraints emerging from (...f...) -we just use the monomorphic Id. We achieve this by adding monomorphic Ids -to the "givens" when simplifying constraints. That's what the "lies_avail" -is doing. - -Then we get - - f = /\a -> \d::Eq a -> letrec - fm = \ys:[a] -> ...fm... - in - fm --} - -tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] - -> TcM (TcGblEnv, TcLclEnv) --- The TcGblEnv contains the new tcg_binds and tcg_spects --- The TcLclEnv has an extended type envt for the new bindings -tcTopBinds binds sigs - = do { -- Pattern synonym bindings populate the global environment - (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $ - do { gbl <- getGblEnv - ; lcl <- getLclEnv - ; return (gbl, lcl) } - ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids - - ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs - ; traceTc "complete_matches" (ppr binds $$ ppr sigs) - ; traceTc "complete_matches" (ppr complete_matches) - - ; let { tcg_env' = tcg_env { tcg_imp_specs - = specs ++ tcg_imp_specs tcg_env - , tcg_complete_matches - = complete_matches - ++ tcg_complete_matches tcg_env } - `addTypecheckedBinds` map snd binds' } - - ; return (tcg_env', tcl_env) } - -- The top level bindings are flattened into a giant - -- implicitly-mutually-recursive LHsBinds - - --- Note [Typechecking Complete Matches] --- Much like when a user bundled a pattern synonym, the result types of --- all the constructors in the match pragma must be consistent. --- --- If we allowed pragmas with inconsistent types then it would be --- impossible to ever match every constructor in the list and so --- the pragma would be useless. - - - - - --- This is only used in `tcCompleteSig`. We fold over all the conlikes, --- this accumulator keeps track of the first `ConLike` with a concrete --- return type. After fixing the return type, all other constructors with --- a fixed return type must agree with this. --- --- The fields of `Fixed` cache the first conlike and its return type so --- that that we can compare all the other conlikes to it. The conlike is --- stored for error messages. --- --- `Nothing` in the case that the type is fixed by a type signature -data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon - -tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch] -tcCompleteSigs sigs = - let - doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch) - doOne c@(CompleteMatchSig _ _ lns mtc) - = fmap Just $ do - addErrCtxt (text "In" <+> ppr c) $ - case mtc of - Nothing -> infer_complete_match - Just tc -> check_complete_match tc - where - - checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns) - - infer_complete_match = do - (res, cls) <- checkCLTypes AcceptAny - case res of - AcceptAny -> failWithTc ambiguousError - Fixed _ tc -> return $ mkMatch cls tc - - check_complete_match tc_name = do - ty_con <- tcLookupLocatedTyCon tc_name - (_, cls) <- checkCLTypes (Fixed Nothing ty_con) - return $ mkMatch cls ty_con - - mkMatch :: [ConLike] -> TyCon -> CompleteMatch - mkMatch cls ty_con = CompleteMatch { - -- foldM is a left-fold and will have accumulated the ConLikes in - -- the reverse order. foldrM would accumulate in the correct order, - -- but would type-check the last ConLike first, which might also be - -- confusing from the user's perspective. Hence reverse here. - completeMatchConLikes = reverse (map conLikeName cls), - completeMatchTyCon = tyConName ty_con - } - doOne _ = return Nothing - - ambiguousError :: SDoc - ambiguousError = - text "A type signature must be provided for a set of polymorphic" - <+> text "pattern synonyms." - - - -- See note [Typechecking Complete Matches] - checkCLType :: (CompleteSigType, [ConLike]) -> Located Name - -> TcM (CompleteSigType, [ConLike]) - checkCLType (cst, cs) n = do - cl <- addLocM tcLookupConLike n - let (_,_,_,_,_,_, res_ty) = conLikeFullSig cl - res_ty_con = fst <$> splitTyConApp_maybe res_ty - case (cst, res_ty_con) of - (AcceptAny, Nothing) -> return (AcceptAny, cl:cs) - (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs) - (Fixed mfcl tc, Nothing) -> return (Fixed mfcl tc, cl:cs) - (Fixed mfcl tc, Just tc') -> - if tc == tc' - then return (Fixed mfcl tc, cl:cs) - else case mfcl of - Nothing -> - addErrCtxt (text "In" <+> ppr cl) $ - failWithTc typeSigErrMsg - Just cl -> failWithTc (errMsg cl) - where - typeSigErrMsg :: SDoc - typeSigErrMsg = - text "Couldn't match expected type" - <+> quotes (ppr tc) - <+> text "with" - <+> quotes (ppr tc') - - errMsg :: ConLike -> SDoc - errMsg fcl = - text "Cannot form a group of complete patterns from patterns" - <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl) - <+> text "as they match different type constructors" - <+> parens (quotes (ppr tc) - <+> text "resp." - <+> quotes (ppr tc')) - -- For some reason I haven't investigated further, the signatures come in - -- backwards wrt. declaration order. So we reverse them here, because it makes - -- a difference for incomplete match suggestions. - in mapMaybeM (addLocM doOne) (reverse sigs) -- process in declaration order - -tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] --- A hs-boot file has only one BindGroup, and it only has type --- signatures in it. The renamer checked all this -tcHsBootSigs binds sigs - = do { checkTc (null binds) badBootDeclErr - ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } - where - tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames - where - f (L _ name) - = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty - ; return (mkVanillaGlobal name sigma_ty) } - -- Notice that we make GlobalIds, not LocalIds - tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) - -badBootDeclErr :: MsgDoc -badBootDeclErr = text "Illegal declarations in an hs-boot file" - ------------------------- -tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing - -> TcM (HsLocalBinds GhcTcId, thing) - -tcLocalBinds (EmptyLocalBinds x) thing_inside - = do { thing <- thing_inside - ; return (EmptyLocalBinds x, thing) } - -tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside - = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside - ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) } -tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds" - -tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside - = do { ipClass <- tcLookupClass ipClassName - ; (given_ips, ip_binds') <- - mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds - - -- If the binding binds ?x = E, we must now - -- discharge any ?x constraints in expr_lie - -- See Note [Implicit parameter untouchables] - ; (ev_binds, result) <- checkConstraints (IPSkol ips) - [] given_ips thing_inside - - ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } - where - ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds] - - -- I wonder if we should do these one at a time - -- Consider ?x = 4 - -- ?y = ?x + 1 - tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr) - = do { ty <- newOpenFlexiTyVarTy - ; let p = mkStrLitTy $ hsIPNameFS ip - ; ip_id <- newDict ipClass [ p, ty ] - ; expr' <- tcMonoExpr expr (mkCheckExpType ty) - ; let d = toDict ipClass p ty `fmap` expr' - ; return (ip_id, (IPBind noExtField (Right ip_id) d)) } - tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind" - tc_ip_bind _ (XIPBind nec) = noExtCon nec - - -- Coerces a `t` into a dictionary for `IP "x" t`. - -- co : t -> IP "x" t - toDict ipClass x ty = mkHsWrap $ mkWpCastR $ - wrapIP $ mkClassPred ipClass [x,ty] - -tcLocalBinds (HsIPBinds _ (XHsIPBinds nec)) _ = noExtCon nec -tcLocalBinds (XHsLocalBindsLR nec) _ = noExtCon nec - -{- Note [Implicit parameter untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We add the type variables in the types of the implicit parameters -as untouchables, not so much because we really must not unify them, -but rather because we otherwise end up with constraints like this - Num alpha, Implic { wanted = alpha ~ Int } -The constraint solver solves alpha~Int by unification, but then -doesn't float that solved constraint out (it's not an unsolved -wanted). Result disaster: the (Num alpha) is again solved, this -time by defaulting. No no no. - -However [Oct 10] this is all handled automatically by the -untouchable-range idea. --} - -tcValBinds :: TopLevelFlag - -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] - -> TcM thing - -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) - -tcValBinds top_lvl binds sigs thing_inside - = do { -- Typecheck the signatures - -- It's easier to do so now, once for all the SCCs together - -- because a single signature f,g :: <type> - -- might relate to more than one SCC - ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $ - tcTySigs sigs - - -- Extend the envt right away with all the Ids - -- declared with complete type signatures - -- Do not extend the TcBinderStack; instead - -- we extend it on a per-rhs basis in tcExtendForRhs - ; tcExtendSigIds top_lvl poly_ids $ do - { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do - { thing <- thing_inside - -- See Note [Pattern synonym builders don't yield dependencies] - -- in GHC.Rename.Binds - ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns - ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ] - ; return (extra_binds, thing) } - ; return (binds' ++ extra_binds', thing) }} - where - patsyns = getPatSynBinds binds - prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds) - ------------------------- -tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv - -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing - -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) --- Typecheck a whole lot of value bindings, --- one strongly-connected component at a time --- Here a "strongly connected component" has the straightforward --- meaning of a group of bindings that mention each other, --- ignoring type signatures (that part comes later) - -tcBindGroups _ _ _ [] thing_inside - = do { thing <- thing_inside - ; return ([], thing) } - -tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside - = do { -- See Note [Closed binder groups] - type_env <- getLclTypeEnv - ; let closed = isClosedBndrGroup type_env (snd group) - ; (group', (groups', thing)) - <- tc_group top_lvl sig_fn prag_fn group closed $ - tcBindGroups top_lvl sig_fn prag_fn groups thing_inside - ; return (group' ++ groups', thing) } - --- Note [Closed binder groups] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- A mutually recursive group is "closed" if all of the free variables of --- the bindings are closed. For example --- --- > h = \x -> let f = ...g... --- > g = ....f...x... --- > in ... --- --- Here @g@ is not closed because it mentions @x@; and hence neither is @f@ --- closed. --- --- So we need to compute closed-ness on each strongly connected components, --- before we sub-divide it based on what type signatures it has. --- - ------------------------- -tc_group :: forall thing. - TopLevelFlag -> TcSigFun -> TcPragEnv - -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing - -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) - --- Typecheck one strongly-connected component of the original program. --- We get a list of groups back, because there may --- be specialisations etc as well - -tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside - -- A single non-recursive binding - -- We want to keep non-recursive things non-recursive - -- so that we desugar unlifted bindings correctly - = do { let bind = case bagToList binds of - [bind] -> bind - [] -> panic "tc_group: empty list of binds" - _ -> panic "tc_group: NonRecursive binds is not a singleton bag" - ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed - thing_inside - ; return ( [(NonRecursive, bind')], thing) } - -tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside - = -- To maximise polymorphism, we do a new - -- strongly-connected-component analysis, this time omitting - -- any references to variables with type signatures. - -- (This used to be optional, but isn't now.) - -- See Note [Polymorphic recursion] in HsBinds. - do { traceTc "tc_group rec" (pprLHsBinds binds) - ; whenIsJust mbFirstPatSyn $ \lpat_syn -> - recursivePatSynErr (getLoc lpat_syn) binds - ; (binds1, thing) <- go sccs - ; return ([(Recursive, binds1)], thing) } - -- Rec them all together - where - mbFirstPatSyn = find (isPatSyn . unLoc) binds - isPatSyn PatSynBind{} = True - isPatSyn _ = False - - sccs :: [SCC (LHsBind GhcRn)] - sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds) - - go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing) - go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc - ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn - closed ids1 $ - go sccs - ; return (binds1 `unionBags` binds2, thing) } - go [] = do { thing <- thing_inside; return (emptyBag, thing) } - - tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind] - tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds - - tc_sub_group rec_tc binds = - tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds - -recursivePatSynErr :: - OutputableBndrId p => - SrcSpan -- ^ The location of the first pattern synonym binding - -- (for error reporting) - -> LHsBinds (GhcPass p) - -> TcM a -recursivePatSynErr loc binds - = failAt loc $ - hang (text "Recursive pattern synonym definition with following bindings:") - 2 (vcat $ map pprLBind . bagToList $ binds) - where - pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) - <+> pprLoc loc - -tc_single :: forall thing. - TopLevelFlag -> TcSigFun -> TcPragEnv - -> LHsBind GhcRn -> IsGroupClosed -> TcM thing - -> TcM (LHsBinds GhcTcId, thing) -tc_single _top_lvl sig_fn _prag_fn - (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) - _ thing_inside - = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) - ; thing <- setGblEnv tcg_env thing_inside - ; return (aux_binds, thing) - } - -tc_single top_lvl sig_fn prag_fn lbind closed thing_inside - = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn - NonRecursive NonRecursive - closed - [lbind] - ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside - ; return (binds1, thing) } - ------------------------- -type BKey = Int -- Just number off the bindings - -mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)] --- See Note [Polymorphic recursion] in HsBinds. -mkEdges sig_fn binds - = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)), - Just key <- [lookupNameEnv key_map n], no_sig n ] - | (bind, key) <- keyd_binds - ] - -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices - -- is still deterministic even if the edges are in nondeterministic order - -- as explained in Note [Deterministic SCC] in Digraph. - where - bind_fvs (FunBind { fun_ext = fvs }) = fvs - bind_fvs (PatBind { pat_ext = fvs }) = fvs - bind_fvs _ = emptyNameSet - - no_sig :: Name -> Bool - no_sig n = not (hasCompleteSig sig_fn n) - - keyd_binds = bagToList binds `zip` [0::BKey ..] - - key_map :: NameEnv BKey -- Which binding it comes from - key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds - , bndr <- collectHsBindBinders bind ] - ------------------------- -tcPolyBinds :: TcSigFun -> TcPragEnv - -> RecFlag -- Whether the group is really recursive - -> RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> IsGroupClosed -- Whether the group is closed - -> [LHsBind GhcRn] -- None are PatSynBind - -> TcM (LHsBinds GhcTcId, [TcId]) - --- Typechecks a single bunch of values bindings all together, --- and generalises them. The bunch may be only part of a recursive --- group, because we use type signatures to maximise polymorphism --- --- Returns a list because the input may be a single non-recursive binding, --- in which case the dependency order of the resulting bindings is --- important. --- --- Knows nothing about the scope of the bindings --- None of the bindings are pattern synonyms - -tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list - = setSrcSpan loc $ - recoverM (recoveryCode binder_names sig_fn) $ do - -- Set up main recover; take advantage of any type sigs - - { traceTc "------------------------------------------------" Outputable.empty - ; traceTc "Bindings for {" (ppr binder_names) - ; dflags <- getDynFlags - ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn - ; traceTc "Generalisation plan" (ppr plan) - ; result@(_, poly_ids) <- case plan of - NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list - InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list - CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind - - ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group - , vcat [ppr id <+> ppr (idType id) | id <- poly_ids] - ]) - - ; return result } - where - binder_names = collectHsBindListBinders bind_list - loc = foldr1 combineSrcSpans (map getLoc bind_list) - -- The mbinds have been dependency analysed and - -- may no longer be adjacent; so find the narrowest - -- span that includes them all - --------------- --- If typechecking the binds fails, then return with each --- signature-less binder given type (forall a.a), to minimise --- subsequent error messages -recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTcId, [Id]) -recoveryCode binder_names sig_fn - = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) - ; let poly_ids = map mk_dummy binder_names - ; return (emptyBag, poly_ids) } - where - mk_dummy name - | Just sig <- sig_fn name - , Just poly_id <- completeSigPolyId_maybe sig - = poly_id - | otherwise - = mkLocalId name forall_a_a - -forall_a_a :: TcType --- At one point I had (forall r (a :: TYPE r). a), but of course --- that type is ill-formed: its mentions 'r' which escapes r's scope. --- Another alternative would be (forall (a :: TYPE kappa). a), where --- kappa is a unification variable. But I don't think we need that --- complication here. I'm going to just use (forall (a::*). a). --- See #15276 -forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy - -{- ********************************************************************* -* * - tcPolyNoGen -* * -********************************************************************* -} - -tcPolyNoGen -- No generalisation whatsoever - :: RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> TcPragEnv -> TcSigFun - -> [LHsBind GhcRn] - -> TcM (LHsBinds GhcTcId, [TcId]) - -tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list - = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn - (LetGblBndr prag_fn) - bind_list - ; mono_ids' <- mapM tc_mono_info mono_infos - ; return (binds', mono_ids') } - where - tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id }) - = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name) - ; return mono_id } - -- NB: tcPrags generates error messages for - -- specialisation pragmas for non-overloaded sigs - -- Indeed that is why we call it here! - -- So we can safely ignore _specs - - -{- ********************************************************************* -* * - tcPolyCheck -* * -********************************************************************* -} - -tcPolyCheck :: TcPragEnv - -> TcIdSigInfo -- Must be a complete signature - -> LHsBind GhcRn -- Must be a FunBind - -> TcM (LHsBinds GhcTcId, [TcId]) --- There is just one binding, --- it is a FunBind --- it has a complete type signature, -tcPolyCheck prag_fn - (CompleteSig { sig_bndr = poly_id - , sig_ctxt = ctxt - , sig_loc = sig_loc }) - (L loc (FunBind { fun_id = (L nm_loc name) - , fun_matches = matches })) - = setSrcSpan sig_loc $ - do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) - ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id - -- See Note [Instantiate sig with fresh variables] - - ; mono_name <- newNameAt (nameOccName name) nm_loc - ; ev_vars <- newEvVars theta - ; let mono_id = mkLocalId mono_name tau - skol_info = SigSkol ctxt (idType poly_id) tv_prs - skol_tvs = map snd tv_prs - - ; (ev_binds, (co_fn, matches')) - <- checkConstraints skol_info skol_tvs ev_vars $ - tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ - tcExtendNameTyVarEnv tv_prs $ - setSrcSpan loc $ - tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau) - - ; let prag_sigs = lookupPragEnv prag_fn name - ; spec_prags <- tcSpecPrags poly_id prag_sigs - ; poly_id <- addInlinePrags poly_id prag_sigs - - ; mod <- getModule - ; tick <- funBindTicks nm_loc mono_id mod prag_sigs - ; let bind' = FunBind { fun_id = L nm_loc mono_id - , fun_matches = matches' - , fun_ext = co_fn - , fun_tick = tick } - - export = ABE { abe_ext = noExtField - , abe_wrap = idHsWrapper - , abe_poly = poly_id - , abe_mono = mono_id - , abe_prags = SpecPrags spec_prags } - - abs_bind = L loc $ - AbsBinds { abs_ext = noExtField - , abs_tvs = skol_tvs - , abs_ev_vars = ev_vars - , abs_ev_binds = [ev_binds] - , abs_exports = [export] - , abs_binds = unitBag (L loc bind') - , abs_sig = True } - - ; return (unitBag abs_bind, [poly_id]) } - -tcPolyCheck _prag_fn sig bind - = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) - -funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] - -> TcM [Tickish TcId] -funBindTicks loc fun_id mod sigs - | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] - -- this can only be a singleton list, as duplicate pragmas are rejected - -- by the renamer - , let cc_str - | Just cc_str <- mb_cc_str - = sl_fs $ unLoc cc_str - | otherwise - = getOccFS (Var.varName fun_id) - cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str - = do - flavour <- DeclCC <$> getCCIndexM cc_name - let cc = mkUserCC cc_name mod loc flavour - return [ProfNote cc True True] - | otherwise - = return [] - -{- Note [Instantiate sig with fresh variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's vital to instantiate a type signature with fresh variables. -For example: - type T = forall a. [a] -> [a] - f :: T; - f = g where { g :: T; g = <rhs> } - - We must not use the same 'a' from the defn of T at both places!! -(Instantiation is only necessary because of type synonyms. Otherwise, -it's all cool; each signature has distinct type variables from the renamer.) --} - - -{- ********************************************************************* -* * - tcPolyInfer -* * -********************************************************************* -} - -tcPolyInfer - :: RecFlag -- Whether it's recursive after breaking - -- dependencies based on type signatures - -> TcPragEnv -> TcSigFun - -> Bool -- True <=> apply the monomorphism restriction - -> [LHsBind GhcRn] - -> TcM (LHsBinds GhcTcId, [TcId]) -tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list - = do { (tclvl, wanted, (binds', mono_infos)) - <- pushLevelAndCaptureConstraints $ - tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list - - ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info)) - | info <- mono_infos ] - sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ] - infer_mode = if mono then ApplyMR else NoRestrictions - - ; mapM_ (checkOverloadedSig mono) sigs - - ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) - ; (qtvs, givens, ev_binds, residual, insoluble) - <- simplifyInfer tclvl infer_mode sigs name_taus wanted - ; emitConstraints residual - - ; let inferred_theta = map evVarPred givens - ; exports <- checkNoErrs $ - mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos - - ; loc <- getSrcSpanM - ; let poly_ids = map abe_poly exports - abs_bind = L loc $ - AbsBinds { abs_ext = noExtField - , abs_tvs = qtvs - , abs_ev_vars = givens, abs_ev_binds = [ev_binds] - , abs_exports = exports, abs_binds = binds' - , abs_sig = False } - - ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids)) - ; return (unitBag abs_bind, poly_ids) } - -- poly_ids are guaranteed zonked by mkExport - --------------- -mkExport :: TcPragEnv - -> Bool -- True <=> there was an insoluble type error - -- when typechecking the bindings - -> [TyVar] -> TcThetaType -- Both already zonked - -> MonoBindInfo - -> TcM (ABExport GhcTc) --- Only called for generalisation plan InferGen, not by CheckGen or NoGen --- --- mkExport generates exports with --- zonked type variables, --- zonked poly_ids --- The former is just because no further unifications will change --- the quantified type variables, so we can fix their final form --- right now. --- The latter is needed because the poly_ids are used to extend the --- type environment; see the invariant on TcEnv.tcExtendIdEnv - --- Pre-condition: the qtvs and theta are already zonked - -mkExport prag_fn insoluble qtvs theta - mono_info@(MBI { mbi_poly_name = poly_name - , mbi_sig = mb_sig - , mbi_mono_id = mono_id }) - = do { mono_ty <- zonkTcType (idType mono_id) - ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty - - -- NB: poly_id has a zonked type - ; poly_id <- addInlinePrags poly_id prag_sigs - ; spec_prags <- tcSpecPrags poly_id prag_sigs - -- tcPrags requires a zonked poly_id - - -- See Note [Impedance matching] - -- NB: we have already done checkValidType, including an ambiguity check, - -- on the type; either when we checked the sig or in mkInferredPolyId - ; let poly_ty = idType poly_id - sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty - -- This type is just going into tcSubType, - -- so Inferred vs. Specified doesn't matter - - ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility - then return idHsWrapper -- Fast path; also avoids complaint when we infer - -- an ambiguous type and have AllowAmbiguousType - -- e..g infer x :: forall a. F a -> Int - else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $ - tcSubType_NC sig_ctxt sel_poly_ty poly_ty - - ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures - ; when warn_missing_sigs $ - localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig - - ; return (ABE { abe_ext = noExtField - , abe_wrap = wrap - -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty) - , abe_poly = poly_id - , abe_mono = mono_id - , abe_prags = SpecPrags spec_prags }) } - where - prag_sigs = lookupPragEnv prag_fn poly_name - sig_ctxt = InfSigCtxt poly_name - -mkInferredPolyId :: Bool -- True <=> there was an insoluble error when - -- checking the binding group for this Id - -> [TyVar] -> TcThetaType - -> Name -> Maybe TcIdSigInst -> TcType - -> TcM TcId -mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty - | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst - , CompleteSig { sig_bndr = poly_id } <- sig - = return poly_id - - | otherwise -- Either no type sig or partial type sig - = checkNoErrs $ -- The checkNoErrs ensures that if the type is ambiguous - -- we don't carry on to the impedance matching, and generate - -- a duplicate ambiguity error. There is a similar - -- checkNoErrs for complete type signatures too. - do { fam_envs <- tcGetFamInstEnvs - ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty - -- Unification may not have normalised the type, - -- (see Note [Lazy flattening] in TcFlatten) so do it - -- here to make it as uncomplicated as possible. - -- Example: f :: [F Int] -> Bool - -- should be rewritten to f :: [Char] -> Bool, if possible - -- - -- We can discard the coercion _co, because we'll reconstruct - -- it in the call to tcSubType below - - ; (binders, theta') <- chooseInferredQuantifiers inferred_theta - (tyCoVarsOfType mono_ty') qtvs mb_sig_inst - - ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty') - - ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta' - , ppr inferred_poly_ty]) - ; unless insoluble $ - addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ - checkValidType (InfSigCtxt poly_name) inferred_poly_ty - -- See Note [Validity of inferred types] - -- If we found an insoluble error in the function definition, don't - -- do this check; otherwise (#14000) we may report an ambiguity - -- error for a rather bogus type. - - ; return (mkLocalId poly_name inferred_poly_ty) } - - -chooseInferredQuantifiers :: TcThetaType -- inferred - -> TcTyVarSet -- tvs free in tau type - -> [TcTyVar] -- inferred quantified tvs - -> Maybe TcIdSigInst - -> TcM ([TyVarBinder], TcThetaType) -chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing - = -- No type signature (partial or complete) for this binder, - do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) - -- Include kind variables! #7916 - my_theta = pickCapturedPreds free_tvs inferred_theta - binders = [ mkTyVarBinder Inferred tv - | tv <- qtvs - , tv `elemVarSet` free_tvs ] - ; return (binders, my_theta) } - -chooseInferredQuantifiers inferred_theta tau_tvs qtvs - (Just (TISI { sig_inst_sig = sig -- Always PartialSig - , sig_inst_wcx = wcx - , sig_inst_theta = annotated_theta - , sig_inst_skols = annotated_tvs })) - = -- Choose quantifiers for a partial type signature - do { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs - - -- Check whether the quantified variables of the - -- partial signature have been unified together - -- See Note [Quantified variables in partial type signatures] - ; mapM_ report_dup_tyvar_tv_err (findDupTyVarTvs psig_qtv_prs) - - -- Check whether a quantified variable of the partial type - -- signature is not actually quantified. How can that happen? - -- See Note [Quantification and partial signatures] Wrinkle 4 - -- in TcSimplify - ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs - , not (tv `elem` qtvs) ] - - ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs) - - ; annotated_theta <- zonkTcTypes annotated_theta - ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx - - ; let keep_me = free_tvs `unionVarSet` psig_qtvs - final_qtvs = [ mkTyVarBinder vis tv - | tv <- qtvs -- Pulling from qtvs maintains original order - , tv `elemVarSet` keep_me - , let vis | tv `elemVarSet` psig_qtvs = Specified - | otherwise = Inferred ] - - ; return (final_qtvs, my_theta) } - where - report_dup_tyvar_tv_err (n1,n2) - | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1) - <+> text "with" <+> quotes (ppr n2)) - 2 (hang (text "both bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) - - | otherwise -- Can't happen; by now we know it's a partial sig - = pprPanic "report_tyvar_tv_err" (ppr sig) - - report_mono_sig_tv_err n - | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig - = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n)) - 2 (hang (text "bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))) - | otherwise -- Can't happen; by now we know it's a partial sig - = pprPanic "report_mono_sig_tv_err" (ppr sig) - - choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType - -> TcM (VarSet, TcThetaType) - choose_psig_context _ annotated_theta Nothing - = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta - `unionVarSet` tau_tvs) - ; return (free_tvs, annotated_theta) } - - choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty) - = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs) - -- growThetaVars just like the no-type-sig case - -- Omitting this caused #12844 - seed_tvs = tyCoVarsOfTypes annotated_theta -- These are put there - `unionVarSet` tau_tvs -- by the user - - ; let keep_me = psig_qtvs `unionVarSet` free_tvs - my_theta = pickCapturedPreds keep_me inferred_theta - - -- Fill in the extra-constraints wildcard hole with inferred_theta, - -- so that the Hole constraint we have already emitted - -- (in tcHsPartialSigType) can report what filled it in. - -- NB: my_theta already includes all the annotated constraints - ; let inferred_diff = [ pred - | pred <- my_theta - , all (not . (`eqType` pred)) annotated_theta ] - ; ctuple <- mk_ctuple inferred_diff - - ; case tcGetCastedTyVar_maybe wc_var_ty of - -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it - -- comes from the checkExpectedKind in TcHsType.tcAnonWildCardOcc. So, to - -- make the kinds work out, we reverse the cast here. - Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co) - Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) - - ; traceTc "completeTheta" $ - vcat [ ppr sig - , ppr annotated_theta, ppr inferred_theta - , ppr inferred_diff ] - ; return (free_tvs, my_theta) } - - mk_ctuple preds = return (mkBoxedTupleTy preds) - -- Hack alert! See TcHsType: - -- Note [Extra-constraint holes in partial type signatures] - - -mk_impedance_match_msg :: MonoBindInfo - -> TcType -> TcType - -> TidyEnv -> TcM (TidyEnv, SDoc) --- This is a rare but rather awkward error messages -mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig }) - inf_ty sig_ty tidy_env - = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty - ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty - ; let msg = vcat [ text "When checking that the inferred type" - , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty - , text "is as general as its" <+> what <+> text "signature" - , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ] - ; return (tidy_env2, msg) } - where - what = case mb_sig of - Nothing -> text "inferred" - Just sig | isPartialSig sig -> text "(partial)" - | otherwise -> empty - - -mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) -mk_inf_msg poly_name poly_ty tidy_env - = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty - ; let msg = vcat [ text "When checking the inferred type" - , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] - ; return (tidy_env1, msg) } - - --- | Warn the user about polymorphic local binders that lack type signatures. -localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM () -localSigWarn flag id mb_sig - | Just _ <- mb_sig = return () - | not (isSigmaTy (idType id)) = return () - | otherwise = warnMissingSignatures flag msg id - where - msg = text "Polymorphic local binding with no type signature:" - -warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM () -warnMissingSignatures flag msg id - = do { env0 <- tcInitTidyEnv - ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) - ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) } - where - mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] - -checkOverloadedSig :: Bool -> TcIdSigInst -> TcM () --- Example: --- f :: Eq a => a -> a --- K f = e --- The MR applies, but the signature is overloaded, and it's --- best to complain about this directly --- c.f #11339 -checkOverloadedSig monomorphism_restriction_applies sig - | not (null (sig_inst_theta sig)) - , monomorphism_restriction_applies - , let orig_sig = sig_inst_sig sig - = setSrcSpan (sig_loc orig_sig) $ - failWith $ - hang (text "Overloaded signature conflicts with monomorphism restriction") - 2 (ppr orig_sig) - | otherwise - = return () - -{- Note [Partial type signatures and generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If /any/ of the signatures in the group is a partial type signature - f :: _ -> Int -then we *always* use the InferGen plan, and hence tcPolyInfer. -We do this even for a local binding with -XMonoLocalBinds, when -we normally use NoGen. - -Reasons: - * The TcSigInfo for 'f' has a unification variable for the '_', - whose TcLevel is one level deeper than the current level. - (See pushTcLevelM in tcTySig.) But NoGen doesn't increase - the TcLevel like InferGen, so we lose the level invariant. - - * The signature might be f :: forall a. _ -> a - so it really is polymorphic. It's not clear what it would - mean to use NoGen on this, and indeed the ASSERT in tcLhs, - in the (Just sig) case, checks that if there is a signature - then we are using LetLclBndr, and hence a nested AbsBinds with - increased TcLevel - -It might be possible to fix these difficulties somehow, but there -doesn't seem much point. Indeed, adding a partial type signature is a -way to get per-binding inferred generalisation. - -We apply the MR if /all/ of the partial signatures lack a context. -In particular (#11016): - f2 :: (?loc :: Int) => _ - f2 = ?loc -It's stupid to apply the MR here. This test includes an extra-constraints -wildcard; that is, we don't apply the MR if you write - f3 :: _ => blah - -Note [Quantified variables in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall a. a -> a -> _ - f x y = g x y - g :: forall b. b -> b -> _ - g x y = [x, y] - -Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b' -together, which is fine. So we bind 'a' and 'b' to TyVarTvs, which can then -unify with each other. - -But now consider: - f :: forall a b. a -> b -> _ - f x y = [x, y] - -We want to get an error from this, because 'a' and 'b' get unified. -So we make a test, one per partial signature, to check that the -explicitly-quantified type variables have not been unified together. -#14449 showed this up. - - -Note [Validity of inferred types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to check inferred type for validity, in case it uses language -extensions that are not turned on. The principle is that if the user -simply adds the inferred type to the program source, it'll compile fine. -See #8883. - -Examples that might fail: - - the type might be ambiguous - - - an inferred theta that requires type equalities e.g. (F a ~ G b) - or multi-parameter type classes - - an inferred type that includes unboxed tuples - - -Note [Impedance matching] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f 0 x = x - f n x = g [] (not x) - - g [] y = f 10 y - g _ y = f 9 y - -After typechecking we'll get - f_mono_ty :: a -> Bool -> Bool - g_mono_ty :: [b] -> Bool -> Bool -with constraints - (Eq a, Num a) - -Note that f is polymorphic in 'a' and g in 'b'; and these are not linked. -The types we really want for f and g are - f :: forall a. (Eq a, Num a) => a -> Bool -> Bool - g :: forall b. [b] -> Bool -> Bool - -We can get these by "impedance matching": - tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool) - tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono) - - f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f - g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g - -Suppose the shared quantified tyvars are qtvs and constraints theta. -Then we want to check that - forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype -and the proof is the impedance matcher. - -Notice that the impedance matcher may do defaulting. See #7173. - -It also cleverly does an ambiguity check; for example, rejecting - f :: F a -> F a -where F is a non-injective type function. --} - - -{- -Note [SPECIALISE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~ -There is no point in a SPECIALISE pragma for a non-overloaded function: - reverse :: [a] -> [a] - {-# SPECIALISE reverse :: [Int] -> [Int] #-} - -But SPECIALISE INLINE *can* make sense for GADTS: - data Arr e where - ArrInt :: !Int -> ByteArray# -> Arr Int - ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) - - (!:) :: Arr e -> Int -> e - {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} - {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} - (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) - (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) - -When (!:) is specialised it becomes non-recursive, and can usefully -be inlined. Scary! So we only warn for SPECIALISE *without* INLINE -for a non-overloaded function. - -************************************************************************ -* * - tcMonoBinds -* * -************************************************************************ - -@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. -The signatures have been dealt with already. --} - -data MonoBindInfo = MBI { mbi_poly_name :: Name - , mbi_sig :: Maybe TcIdSigInst - , mbi_mono_id :: TcId } - -tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes - -- i.e. the binders are mentioned in their RHSs, and - -- we are not rescued by a type signature - -> TcSigFun -> LetBndrSpec - -> [LHsBind GhcRn] - -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) -tcMonoBinds is_rec sig_fn no_gen - [ L b_loc (FunBind { fun_id = L nm_loc name - , fun_matches = matches })] - -- Single function binding, - | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS - , Nothing <- sig_fn name -- ...with no type signature - = -- Note [Single function non-recursive binding special-case] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- In this very special case we infer the type of the - -- right hand side first (it may have a higher-rank type) - -- and *then* make the monomorphic Id for the LHS - -- e.g. f = \(x::forall a. a->a) -> <body> - -- We want to infer a higher-rank type for f - setSrcSpan b_loc $ - do { ((co_fn, matches'), rhs_ty) - <- tcInferInst $ \ exp_ty -> - -- tcInferInst: see TcUnify, - -- Note [Deep instantiation of InferResult] in TcUnify - tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ - -- We extend the error context even for a non-recursive - -- function so that in type error messages we show the - -- type of the thing whose rhs we are type checking - tcMatchesFun (L nm_loc name) matches exp_ty - - ; mono_id <- newLetBndr no_gen name rhs_ty - ; return (unitBag $ L b_loc $ - FunBind { fun_id = L nm_loc mono_id, - fun_matches = matches', - fun_ext = co_fn, fun_tick = [] }, - [MBI { mbi_poly_name = name - , mbi_sig = Nothing - , mbi_mono_id = mono_id }]) } - -tcMonoBinds _ sig_fn no_gen binds - = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds - - -- Bring the monomorphic Ids, into scope for the RHSs - ; let mono_infos = getMonoBindInfo tc_binds - rhs_id_env = [ (name, mono_id) - | MBI { mbi_poly_name = name - , mbi_sig = mb_sig - , mbi_mono_id = mono_id } <- mono_infos - , case mb_sig of - Just sig -> isPartialSig sig - Nothing -> True ] - -- A monomorphic binding for each term variable that lacks - -- a complete type sig. (Ones with a sig are already in scope.) - - ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) - | (n,id) <- rhs_id_env] - ; binds' <- tcExtendRecIds rhs_id_env $ - mapM (wrapLocM tcRhs) tc_binds - - ; return (listToBag binds', mono_infos) } - - ------------------------- --- tcLhs typechecks the LHS of the bindings, to construct the environment in which --- we typecheck the RHSs. Basically what we are doing is this: for each binder: --- if there's a signature for it, use the instantiated signature type --- otherwise invent a type variable --- You see that quite directly in the FunBind case. --- --- But there's a complication for pattern bindings: --- data T = MkT (forall a. a->a) --- MkT f = e --- Here we can guess a type variable for the entire LHS (which will be refined to T) --- but we want to get (f::forall a. a->a) as the RHS environment. --- The simplest way to do this is to typecheck the pattern, and then look up the --- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing --- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't - -data TcMonoBind -- Half completed; LHS done, RHS not done - = TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn)) - | TcPatBind [MonoBindInfo] (LPat GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn)) - TcSigmaType - -tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind --- Only called with plan InferGen (LetBndrSpec = LetLclBndr) --- or NoGen (LetBndrSpec = LetGblBndr) --- CheckGen is used only for functions with a complete type signature, --- and tcPolyCheck doesn't use tcMonoBinds at all - -tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name - , fun_matches = matches }) - | Just (TcIdSig sig) <- sig_fn name - = -- There is a type signature. - -- It must be partial; if complete we'd be in tcPolyCheck! - -- e.g. f :: _ -> _ - -- f x = ...g... - -- Just g = ...f... - -- Hence always typechecked with InferGen - do { mono_info <- tcLhsSigId no_gen (name, sig) - ; return (TcFunBind mono_info nm_loc matches) } - - | otherwise -- No type signature - = do { mono_ty <- newOpenFlexiTyVarTy - ; mono_id <- newLetBndr no_gen name mono_ty - ; let mono_info = MBI { mbi_poly_name = name - , mbi_sig = Nothing - , mbi_mono_id = mono_id } - ; return (TcFunBind mono_info nm_loc matches) } - -tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) - = -- See Note [Typechecking pattern bindings] - do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names - - ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $ - [ (mbi_poly_name mbi, mbi_mono_id mbi) - | mbi <- sig_mbis ] - - -- See Note [Existentials in pattern bindings] - ; ((pat', nosig_mbis), pat_ty) - <- addErrCtxt (patMonoBindsCtxt pat grhss) $ - tcInferNoInst $ \ exp_ty -> - tcLetPat inst_sig_fun no_gen pat exp_ty $ - mapM lookup_info nosig_names - - ; let mbis = sig_mbis ++ nosig_mbis - - ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id) - | mbi <- mbis, let id = mbi_mono_id mbi ] - $$ ppr no_gen) - - ; return (TcPatBind mbis pat' grhss pat_ty) } - where - bndr_names = collectPatBinders pat - (nosig_names, sig_names) = partitionWith find_sig bndr_names - - find_sig :: Name -> Either Name (Name, TcIdSigInfo) - find_sig name = case sig_fn name of - Just (TcIdSig sig) -> Right (name, sig) - _ -> Left name - - -- After typechecking the pattern, look up the binder - -- names that lack a signature, which the pattern has brought - -- into scope. - lookup_info :: Name -> TcM MonoBindInfo - lookup_info name - = do { mono_id <- tcLookupId name - ; return (MBI { mbi_poly_name = name - , mbi_sig = Nothing - , mbi_mono_id = mono_id }) } - -tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) - -- AbsBind, VarBind impossible - -------------------- -tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo -tcLhsSigId no_gen (name, sig) - = do { inst_sig <- tcInstSig sig - ; mono_id <- newSigLetBndr no_gen name inst_sig - ; return (MBI { mbi_poly_name = name - , mbi_sig = Just inst_sig - , mbi_mono_id = mono_id }) } - ------------- -newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId -newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig }) - | CompleteSig { sig_bndr = poly_id } <- id_sig - = addInlinePrags poly_id (lookupPragEnv prags name) -newSigLetBndr no_gen name (TISI { sig_inst_tau = tau }) - = newLetBndr no_gen name tau - -------------------- -tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId) -tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) - loc matches) - = tcExtendIdBinderStackForRhs [info] $ - tcExtendTyVarEnvForRhs mb_sig $ - do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) - ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id)) - matches (mkCheckExpType $ idType mono_id) - ; return ( FunBind { fun_id = L loc mono_id - , fun_matches = matches' - , fun_ext = co_fn - , fun_tick = [] } ) } - -tcRhs (TcPatBind infos pat' grhss pat_ty) - = -- When we are doing pattern bindings we *don't* bring any scoped - -- type variables into scope unlike function bindings - -- Wny not? They are not completely rigid. - -- That's why we have the special case for a single FunBind in tcMonoBinds - tcExtendIdBinderStackForRhs infos $ - do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) - ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ - tcGRHSsPat grhss pat_ty - ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' - , pat_ext = NPatBindTc emptyNameSet pat_ty - , pat_ticks = ([],[]) } )} - -tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a -tcExtendTyVarEnvForRhs Nothing thing_inside - = thing_inside -tcExtendTyVarEnvForRhs (Just sig) thing_inside - = tcExtendTyVarEnvFromSig sig thing_inside - -tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a -tcExtendTyVarEnvFromSig sig_inst thing_inside - | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst - = tcExtendNameTyVarEnv wcs $ - tcExtendNameTyVarEnv skol_prs $ - thing_inside - -tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a --- Extend the TcBinderStack for the RHS of the binding, with --- the monomorphic Id. That way, if we have, say --- f = \x -> blah --- and something goes wrong in 'blah', we get a "relevant binding" --- looking like f :: alpha -> beta --- This applies if 'f' has a type signature too: --- f :: forall a. [a] -> [a] --- f x = True --- We can't unify True with [a], and a relevant binding is f :: [a] -> [a] --- If we had the *polymorphic* version of f in the TcBinderStack, it --- would not be reported as relevant, because its type is closed -tcExtendIdBinderStackForRhs infos thing_inside - = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel - | MBI { mbi_mono_id = mono_id } <- infos ] - thing_inside - -- NotTopLevel: it's a monomorphic binding - ---------------------- -getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] -getMonoBindInfo tc_binds - = foldr (get_info . unLoc) [] tc_binds - where - get_info (TcFunBind info _ _) rest = info : rest - get_info (TcPatBind infos _ _ _) rest = infos ++ rest - - -{- Note [Typechecking pattern bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at: - - typecheck/should_compile/ExPat - - #12427, typecheck/should_compile/T12427{a,b} - - data T where - MkT :: Integral a => a -> Int -> T - -and suppose t :: T. Which of these pattern bindings are ok? - - E1. let { MkT p _ = t } in <body> - - E2. let { MkT _ q = t } in <body> - - E3. let { MkT (toInteger -> r) _ = t } in <body> - -* (E1) is clearly wrong because the existential 'a' escapes. - What type could 'p' possibly have? - -* (E2) is fine, despite the existential pattern, because - q::Int, and nothing escapes. - -* Even (E3) is fine. The existential pattern binds a dictionary - for (Integral a) which the view pattern can use to convert the - a-valued field to an Integer, so r :: Integer. - -An easy way to see all three is to imagine the desugaring. -For (E2) it would look like - let q = case t of MkT _ q' -> q' - in <body> - - -We typecheck pattern bindings as follows. First tcLhs does this: - - 1. Take each type signature q :: ty, partial or complete, and - instantiate it (with tcLhsSigId) to get a MonoBindInfo. This - gives us a fresh "mono_id" qm :: instantiate(ty), where qm has - a fresh name. - - Any fresh unification variables in instantiate(ty) born here, not - deep under implications as would happen if we allocated them when - we encountered q during tcPat. - - 2. Build a little environment mapping "q" -> "qm" for those Ids - with signatures (inst_sig_fun) - - 3. Invoke tcLetPat to typecheck the pattern. - - - We pass in the current TcLevel. This is captured by - TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in - PatEnv. - - - When tcPat finds an existential constructor, it binds fresh - type variables and dictionaries as usual, increments the TcLevel, - and emits an implication constraint. - - - When we come to a binder (TcPat.tcPatBndr), it looks it up - in the little environment (the pc_sig_fn field of PatCtxt). - - Success => There was a type signature, so just use it, - checking compatibility with the expected type. - - Failure => No type signature. - Infer case: (happens only outside any constructor pattern) - use a unification variable - at the outer level pc_lvl - - Check case: use promoteTcType to promote the type - to the outer level pc_lvl. This is the - place where we emit a constraint that'll blow - up if existential capture takes place - - Result: the type of the binder is always at pc_lvl. This is - crucial. - - 4. Throughout, when we are making up an Id for the pattern-bound variables - (newLetBndr), we have two cases: - - - If we are generalising (generalisation plan is InferGen or - CheckGen), then the let_bndr_spec will be LetLclBndr. In that case - we want to bind a cloned, local version of the variable, with the - type given by the pattern context, *not* by the signature (even if - there is one; see #7268). The mkExport part of the - generalisation step will do the checking and impedance matching - against the signature. - - - If for some some reason we are not generalising (plan = NoGen), the - LetBndrSpec will be LetGblBndr. In that case we must bind the - global version of the Id, and do so with precisely the type given - in the signature. (Then we unify with the type from the pattern - context type.) - - -And that's it! The implication constraints check for the skolem -escape. It's quite simple and neat, and more expressive than before -e.g. GHC 8.0 rejects (E2) and (E3). - -Example for (E1), starting at level 1. We generate - p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta) -The (a~beta) can't float (because of the 'a'), nor be solved (because -beta is untouchable.) - -Example for (E2), we generate - q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta) -The beta is untouchable, but floats out of the constraint and can -be solved absolutely fine. - - -************************************************************************ -* * - Generalisation -* * -********************************************************************* -} - -data GeneralisationPlan - = NoGen -- No generalisation, no AbsBinds - - | InferGen -- Implicit generalisation; there is an AbsBinds - Bool -- True <=> apply the MR; generalise only unconstrained type vars - - | CheckGen (LHsBind GhcRn) TcIdSigInfo - -- One FunBind with a signature - -- Explicit generalisation - --- A consequence of the no-AbsBinds choice (NoGen) is that there is --- no "polymorphic Id" and "monmomorphic Id"; there is just the one - -instance Outputable GeneralisationPlan where - ppr NoGen = text "NoGen" - ppr (InferGen b) = text "InferGen" <+> ppr b - ppr (CheckGen _ s) = text "CheckGen" <+> ppr s - -decideGeneralisationPlan - :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun - -> GeneralisationPlan -decideGeneralisationPlan dflags lbinds closed sig_fn - | has_partial_sigs = InferGen (and partial_sig_mrs) - | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig - | do_not_generalise closed = NoGen - | otherwise = InferGen mono_restriction - where - binds = map unLoc lbinds - - partial_sig_mrs :: [Bool] - -- One for each partial signature (so empty => no partial sigs) - -- The Bool is True if the signature has no constraint context - -- so we should apply the MR - -- See Note [Partial type signatures and generalisation] - partial_sig_mrs - = [ null theta - | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) - <- mapMaybe sig_fn (collectHsBindListBinders lbinds) - , let (_, L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ] - - has_partial_sigs = not (null partial_sig_mrs) - - mono_restriction = xopt LangExt.MonomorphismRestriction dflags - && any restricted binds - - do_not_generalise (IsGroupClosed _ True) = False - -- The 'True' means that all of the group's - -- free vars have ClosedTypeId=True; so we can ignore - -- -XMonoLocalBinds, and generalise anyway - do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags - - -- With OutsideIn, all nested bindings are monomorphic - -- except a single function binding with a signature - one_funbind_with_sig - | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds - , Just (TcIdSig sig) <- sig_fn (unLoc v) - = Just (lbind, sig) - | otherwise - = Nothing - - -- The Haskell 98 monomorphism restriction - restricted (PatBind {}) = True - restricted (VarBind { var_id = v }) = no_sig v - restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m - && no_sig (unLoc v) - restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b) - - restricted_match mg = matchGroupArity mg == 0 - -- No args => like a pattern binding - -- Some args => a function binding - - no_sig n = not (hasCompleteSig sig_fn n) - -isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed -isClosedBndrGroup type_env binds - = IsGroupClosed fv_env type_closed - where - type_closed = allUFM (nameSetAll is_closed_type_id) fv_env - - fv_env :: NameEnv NameSet - fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds - - bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] - bindFvs (FunBind { fun_id = L _ f - , fun_ext = fvs }) - = let open_fvs = get_open_fvs fvs - in [(f, open_fvs)] - bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs }) - = let open_fvs = get_open_fvs fvs - in [(b, open_fvs) | b <- collectPatBinders pat] - bindFvs _ - = [] - - get_open_fvs fvs = filterNameSet (not . is_closed) fvs - - is_closed :: Name -> ClosedTypeId - is_closed name - | Just thing <- lookupNameEnv type_env name - = case thing of - AGlobal {} -> True - ATcId { tct_info = ClosedLet } -> True - _ -> False - - | otherwise - = True -- The free-var set for a top level binding mentions - - - is_closed_type_id :: Name -> Bool - -- We're already removed Global and ClosedLet Ids - is_closed_type_id name - | Just thing <- lookupNameEnv type_env name - = case thing of - ATcId { tct_info = NonClosedLet _ cl } -> cl - ATcId { tct_info = NotLetBound } -> False - ATyVar {} -> False - -- In-scope type variables are not closed! - _ -> pprPanic "is_closed_id" (ppr name) - - | otherwise - = True -- The free-var set for a top level binding mentions - -- imported things too, so that we can report unused imports - -- These won't be in the local type env. - -- Ditto class method etc from the current module - - -{- ********************************************************************* -* * - Error contexts and messages -* * -********************************************************************* -} - --- This one is called on LHS, when pat and grhss are both Name --- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (OutputableBndrId p, Outputable body) - => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc -patMonoBindsCtxt pat grhss - = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs deleted file mode 100644 index fa24829694..0000000000 --- a/compiler/typecheck/TcCanonical.hs +++ /dev/null @@ -1,2542 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -module TcCanonical( - canonicalize, - unifyDerived, - makeSuperClasses, maybeSym, - StopOrContinue(..), stopWith, continueWith, - solveCallStack -- For TcSimplify - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Constraint -import GHC.Core.Predicate -import TcOrigin -import TcUnify( swapOverTyVars, metaTyVarUpdateOK, MetaTyVarUpdateResult(..) ) -import TcType -import GHC.Core.Type -import TcFlatten -import TcSMonad -import TcEvidence -import TcEvTerm -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking -import GHC.Core.Coercion -import GHC.Core -import GHC.Types.Id( idType, mkTemplateLocals ) -import GHC.Core.FamInstEnv ( FamInstEnvs ) -import FamInst ( tcTopNormaliseNewTypeTF_maybe ) -import GHC.Types.Var -import GHC.Types.Var.Env( mkInScopeSet ) -import GHC.Types.Var.Set( delVarSetList ) -import GHC.Types.Name.Occurrence ( OccName ) -import Outputable -import GHC.Driver.Session( DynFlags ) -import GHC.Types.Name.Set -import GHC.Types.Name.Reader -import GHC.Hs.Types( HsIPName(..) ) - -import Pair -import Util -import Bag -import MonadUtils -import Control.Monad -import Data.Maybe ( isJust ) -import Data.List ( zip4 ) -import GHC.Types.Basic - -import Data.Bifunctor ( bimap ) -import Data.Foldable ( traverse_ ) - -{- -************************************************************************ -* * -* The Canonicaliser * -* * -************************************************************************ - -Note [Canonicalization] -~~~~~~~~~~~~~~~~~~~~~~~ - -Canonicalization converts a simple constraint to a canonical form. It is -unary (i.e. treats individual constraints one at a time). - -Constraints originating from user-written code come into being as -CNonCanonicals (except for CHoleCans, arising from holes). We know nothing -about these constraints. So, first: - - Classify CNonCanoncal constraints, depending on whether they - are equalities, class predicates, or other. - -Then proceed depending on the shape of the constraint. Generally speaking, -each constraint gets flattened and then decomposed into one of several forms -(see type Ct in TcRnTypes). - -When an already-canonicalized constraint gets kicked out of the inert set, -it must be recanonicalized. But we know a bit about its shape from the -last time through, so we can skip the classification step. - --} - --- Top-level canonicalization --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -canonicalize :: Ct -> TcS (StopOrContinue Ct) -canonicalize (CNonCanonical { cc_ev = ev }) - = {-# SCC "canNC" #-} - case classifyPredType pred of - ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys) - canClassNC ev cls tys - EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2) - canEqNC ev eq_rel ty1 ty2 - IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred) - canIrred OtherCIS ev - ForAllPred tvs theta p -> do traceTcS "canEvNC:forall" (ppr pred) - canForAllNC ev tvs theta p - where - pred = ctEvPred ev - -canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) - = canForAll ev pend_sc - -canonicalize (CIrredCan { cc_ev = ev, cc_status = status }) - | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev) - = -- For insolubles (all of which are equalities, do /not/ flatten the arguments - -- In #14350 doing so led entire-unnecessary and ridiculously large - -- type function expansion. Instead, canEqNC just applies - -- the substitution to the predicate, and may do decomposition; - -- e.g. a ~ [a], where [G] a ~ [Int], can decompose - canEqNC ev eq_rel ty1 ty2 - - | otherwise - = canIrred status ev - -canonicalize (CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = xis, cc_pend_sc = pend_sc }) - = {-# SCC "canClass" #-} - canClass ev cls xis pend_sc - -canonicalize (CTyEqCan { cc_ev = ev - , cc_tyvar = tv - , cc_rhs = xi - , cc_eq_rel = eq_rel }) - = {-# SCC "canEqLeafTyVarEq" #-} - canEqNC ev eq_rel (mkTyVarTy tv) xi - -- NB: Don't use canEqTyVar because that expects flattened types, - -- and tv and xi may not be flat w.r.t. an updated inert set - -canonicalize (CFunEqCan { cc_ev = ev - , cc_fun = fn - , cc_tyargs = xis1 - , cc_fsk = fsk }) - = {-# SCC "canEqLeafFunEq" #-} - canCFunEqCan ev fn xis1 fsk - -canonicalize (CHoleCan { cc_ev = ev, cc_occ = occ, cc_hole = hole }) - = canHole ev occ hole - -{- -************************************************************************ -* * -* Class Canonicalization -* * -************************************************************************ --} - -canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct) --- "NC" means "non-canonical"; that is, we have got here --- from a NonCanonical constraint, not from a CDictCan --- Precondition: EvVar is class evidence -canClassNC ev cls tys - | isGiven ev -- See Note [Eagerly expand given superclasses] - = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys - ; emitWork sc_cts - ; canClass ev cls tys False } - - | isWanted ev - , Just ip_name <- isCallStackPred cls tys - , OccurrenceOf func <- ctLocOrigin loc - -- If we're given a CallStack constraint that arose from a function - -- call, we need to push the current call-site onto the stack instead - -- of solving it directly from a given. - -- See Note [Overview of implicit CallStacks] in TcEvidence - -- and Note [Solving CallStack constraints] in TcSMonad - = do { -- First we emit a new constraint that will capture the - -- given CallStack. - ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name)) - -- We change the origin to IPOccOrigin so - -- this rule does not fire again. - -- See Note [Overview of implicit CallStacks] - - ; new_ev <- newWantedEvVarNC new_loc pred - - -- Then we solve the wanted by pushing the call-site - -- onto the newly emitted CallStack - ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev) - ; solveCallStack ev ev_cs - - ; canClass new_ev cls tys False } - - | otherwise - = canClass ev cls tys (has_scs cls) - - where - has_scs cls = not (null (classSCTheta cls)) - loc = ctEvLoc ev - pred = ctEvPred ev - -solveCallStack :: CtEvidence -> EvCallStack -> TcS () --- Also called from TcSimplify when defaulting call stacks -solveCallStack ev ev_cs = do - -- We're given ev_cs :: CallStack, but the evidence term should be a - -- dictionary, so we have to coerce ev_cs to a dictionary for - -- `IP ip CallStack`. See Note [Overview of implicit CallStacks] - cs_tm <- evCallStack ev_cs - let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev)) - setEvBindIfWanted ev ev_tm - -canClass :: CtEvidence - -> Class -> [Type] - -> Bool -- True <=> un-explored superclasses - -> TcS (StopOrContinue Ct) --- Precondition: EvVar is class evidence - -canClass ev cls tys pend_sc - = -- all classes do *nominal* matching - ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys ) - do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys - ; MASSERT( isTcReflCo _kind_co ) - ; let co = mkTcTyConAppCo Nominal cls_tc cos - xi = mkClassPred cls xis - mk_ct new_ev = CDictCan { cc_ev = new_ev - , cc_tyargs = xis - , cc_class = cls - , cc_pend_sc = pend_sc } - ; mb <- rewriteEvidence ev xi co - ; traceTcS "canClass" (vcat [ ppr ev - , ppr xi, ppr mb ]) - ; return (fmap mk_ct mb) } - where - cls_tc = classTyCon cls - -{- Note [The superclass story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to add superclass constraints for two reasons: - -* For givens [G], they give us a route to proof. E.g. - f :: Ord a => a -> Bool - f x = x == x - We get a Wanted (Eq a), which can only be solved from the superclass - of the Given (Ord a). - -* For wanteds [W], and deriveds [WD], [D], they may give useful - functional dependencies. E.g. - class C a b | a -> b where ... - class C a b => D a b where ... - Now a [W] constraint (D Int beta) has (C Int beta) as a superclass - and that might tell us about beta, via C's fundeps. We can get this - by generating a [D] (C Int beta) constraint. It's derived because - we don't actually have to cough up any evidence for it; it's only there - to generate fundep equalities. - -See Note [Why adding superclasses can help]. - -For these reasons we want to generate superclass constraints for both -Givens and Wanteds. But: - -* (Minor) they are often not needed, so generating them aggressively - is a waste of time. - -* (Major) if we want recursive superclasses, there would be an infinite - number of them. Here is a real-life example (#10318); - - class (Frac (Frac a) ~ Frac a, - Fractional (Frac a), - IntegralDomain (Frac a)) - => IntegralDomain a where - type Frac a :: * - - Notice that IntegralDomain has an associated type Frac, and one - of IntegralDomain's superclasses is another IntegralDomain constraint. - -So here's the plan: - -1. Eagerly generate superclasses for given (but not wanted) - constraints; see Note [Eagerly expand given superclasses]. - This is done using mkStrictSuperClasses in canClassNC, when - we take a non-canonical Given constraint and cannonicalise it. - - However stop if you encounter the same class twice. That is, - mkStrictSuperClasses expands eagerly, but has a conservative - termination condition: see Note [Expanding superclasses] in TcType. - -2. Solve the wanteds as usual, but do no further expansion of - superclasses for canonical CDictCans in solveSimpleGivens or - solveSimpleWanteds; Note [Danger of adding superclasses during solving] - - However, /do/ continue to eagerly expand superclasses for new /given/ - /non-canonical/ constraints (canClassNC does this). As #12175 - showed, a type-family application can expand to a class constraint, - and we want to see its superclasses for just the same reason as - Note [Eagerly expand given superclasses]. - -3. If we have any remaining unsolved wanteds - (see Note [When superclasses help] in Constraint) - try harder: take both the Givens and Wanteds, and expand - superclasses again. See the calls to expandSuperClasses in - TcSimplify.simpl_loop and solveWanteds. - - This may succeed in generating (a finite number of) extra Givens, - and extra Deriveds. Both may help the proof. - -3a An important wrinkle: only expand Givens from the current level. - Two reasons: - - We only want to expand it once, and that is best done at - the level it is bound, rather than repeatedly at the leaves - of the implication tree - - We may be inside a type where we can't create term-level - evidence anyway, so we can't superclass-expand, say, - (a ~ b) to get (a ~# b). This happened in #15290. - -4. Go round to (2) again. This loop (2,3,4) is implemented - in TcSimplify.simpl_loop. - -The cc_pend_sc flag in a CDictCan records whether the superclasses of -this constraint have been expanded. Specifically, in Step 3 we only -expand superclasses for constraints with cc_pend_sc set to true (i.e. -isPendingScDict holds). - -Why do we do this? Two reasons: - -* To avoid repeated work, by repeatedly expanding the superclasses of - same constraint, - -* To terminate the above loop, at least in the -XNoRecursiveSuperClasses - case. If there are recursive superclasses we could, in principle, - expand forever, always encountering new constraints. - -When we take a CNonCanonical or CIrredCan, but end up classifying it -as a CDictCan, we set the cc_pend_sc flag to False. - -Note [Superclass loops] -~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class C a => D a - class D a => C a - -Then, when we expand superclasses, we'll get back to the self-same -predicate, so we have reached a fixpoint in expansion and there is no -point in fruitlessly expanding further. This case just falls out from -our strategy. Consider - f :: C a => a -> Bool - f x = x==x -Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses -G] d2: D a, [G] d3: C a (psc). (The "psc" means it has its sc_pend flag set.) -When processing d3 we find a match with d1 in the inert set, and we always -keep the inert item (d1) if possible: see Note [Replacement vs keeping] in -TcInteract. So d3 dies a quick, happy death. - -Note [Eagerly expand given superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In step (1) of Note [The superclass story], why do we eagerly expand -Given superclasses by one layer? (By "one layer" we mean expand transitively -until you meet the same class again -- the conservative criterion embodied -in expandSuperClasses. So a "layer" might be a whole stack of superclasses.) -We do this eagerly for Givens mainly because of some very obscure -cases like this: - - instance Bad a => Eq (T a) - - f :: (Ord (T a)) => blah - f x = ....needs Eq (T a), Ord (T a).... - -Here if we can't satisfy (Eq (T a)) from the givens we'll use the -instance declaration; but then we are stuck with (Bad a). Sigh. -This is really a case of non-confluent proofs, but to stop our users -complaining we expand one layer in advance. - -Note [Instance and Given overlap] in TcInteract. - -We also want to do this if we have - - f :: F (T a) => blah - -where - type instance F (T a) = Ord (T a) - -So we may need to do a little work on the givens to expose the -class that has the superclasses. That's why the superclass -expansion for Givens happens in canClassNC. - -This same scenario happens with quantified constraints, whose superclasses -are also eagerly expanded. Test case: typecheck/should_compile/T16502b -These are handled in canForAllNC, analogously to canClassNC. - -Note [Why adding superclasses can help] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Examples of how adding superclasses can help: - - --- Example 1 - class C a b | a -> b - Suppose we want to solve - [G] C a b - [W] C a beta - Then adding [D] beta~b will let us solve it. - - -- Example 2 (similar but using a type-equality superclass) - class (F a ~ b) => C a b - And try to sllve: - [G] C a b - [W] C a beta - Follow the superclass rules to add - [G] F a ~ b - [D] F a ~ beta - Now we get [D] beta ~ b, and can solve that. - - -- Example (tcfail138) - class L a b | a -> b - class (G a, L a b) => C a b - - instance C a b' => G (Maybe a) - instance C a b => C (Maybe a) a - instance L (Maybe a) a - - When solving the superclasses of the (C (Maybe a) a) instance, we get - [G] C a b, and hance by superclasses, [G] G a, [G] L a b - [W] G (Maybe a) - Use the instance decl to get - [W] C a beta - Generate its derived superclass - [D] L a beta. Now using fundeps, combine with [G] L a b to get - [D] beta ~ b - which is what we want. - -Note [Danger of adding superclasses during solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here's a serious, but now out-dated example, from #4497: - - class Num (RealOf t) => Normed t - type family RealOf x - -Assume the generated wanted constraint is: - [W] RealOf e ~ e - [W] Normed e - -If we were to be adding the superclasses during simplification we'd get: - [W] RealOf e ~ e - [W] Normed e - [D] RealOf e ~ fuv - [D] Num fuv -==> - e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv - -While looks exactly like our original constraint. If we add the -superclass of (Normed fuv) again we'd loop. By adding superclasses -definitely only once, during canonicalisation, this situation can't -happen. - -Mind you, now that Wanteds cannot rewrite Derived, I think this particular -situation can't happen. - -Note [Nested quantified constraint superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (typecheck/should_compile/T17202) - - class C1 a - class (forall c. C1 c) => C2 a - class (forall b. (b ~ F a) => C2 a) => C3 a - -Elsewhere in the code, we get a [G] g1 :: C3 a. We expand its superclass -to get [G] g2 :: (forall b. (b ~ F a) => C2 a). This constraint has a -superclass, as well. But we now must be careful: we cannot just add -(forall c. C1 c) as a Given, because we need to remember g2's context. -That new constraint is Given only when forall b. (b ~ F a) is true. - -It's tempting to make the new Given be (forall b. (b ~ F a) => forall c. C1 c), -but that's problematic, because it's nested, and ForAllPred is not capable -of representing a nested quantified constraint. (We could change ForAllPred -to allow this, but the solution in this Note is much more local and simpler.) - -So, we swizzle it around to get (forall b c. (b ~ F a) => C1 c). - -More generally, if we are expanding the superclasses of - g0 :: forall tvs. theta => cls tys -and find a superclass constraint - forall sc_tvs. sc_theta => sc_inner_pred -we must have a selector - sel_id :: forall cls_tvs. cls cls_tvs -> forall sc_tvs. sc_theta => sc_inner_pred -and thus build - g_sc :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred - g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. \ sc_theta_ids. - sel_id tys (g0 tvs theta_ids) sc_tvs sc_theta_ids - -Actually, we cheat a bit by eta-reducing: note that sc_theta_ids are both the -last bound variables and the last arguments. This avoids the need to produce -the sc_theta_ids at all. So our final construction is - - g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. - sel_id tys (g0 tvs theta_ids) sc_tvs - - -} - -makeSuperClasses :: [Ct] -> TcS [Ct] --- Returns strict superclasses, transitively, see Note [The superclasses story] --- See Note [The superclass story] --- The loop-breaking here follows Note [Expanding superclasses] in TcType --- Specifically, for an incoming (C t) constraint, we return all of (C t)'s --- superclasses, up to /and including/ the first repetition of C --- --- Example: class D a => C a --- class C [a] => D a --- makeSuperClasses (C x) will return (D x, C [x]) --- --- NB: the incoming constraints have had their cc_pend_sc flag already --- flipped to False, by isPendingScDict, so we are /obliged/ to at --- least produce the immediate superclasses -makeSuperClasses cts = concatMapM go cts - where - go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) - = mkStrictSuperClasses ev [] [] cls tys - go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev })) - = ASSERT2( isClassPred pred, ppr pred ) -- The cts should all have - -- class pred heads - mkStrictSuperClasses ev tvs theta cls tys - where - (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev) - go ct = pprPanic "makeSuperClasses" (ppr ct) - -mkStrictSuperClasses - :: CtEvidence - -> [TyVar] -> ThetaType -- These two args are non-empty only when taking - -- superclasses of a /quantified/ constraint - -> Class -> [Type] -> TcS [Ct] --- Return constraints for the strict superclasses of --- ev :: forall as. theta => cls tys -mkStrictSuperClasses ev tvs theta cls tys - = mk_strict_superclasses (unitNameSet (className cls)) - ev tvs theta cls tys - -mk_strict_superclasses :: NameSet -> CtEvidence - -> [TyVar] -> ThetaType - -> Class -> [Type] -> TcS [Ct] --- Always return the immediate superclasses of (cls tys); --- and expand their superclasses, provided none of them are in rec_clss --- nor are repeated -mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc }) - tvs theta cls tys - = concatMapM (do_one_given (mk_given_loc loc)) $ - classSCSelIds cls - where - dict_ids = mkTemplateLocals theta - size = sizeTypes tys - - do_one_given given_loc sel_id - | isUnliftedType sc_pred - , not (null tvs && null theta) - = -- See Note [Equality superclasses in quantified constraints] - return [] - | otherwise - = do { given_ev <- newGivenEvVar given_loc $ - mk_given_desc sel_id sc_pred - ; mk_superclasses rec_clss given_ev tvs theta sc_pred } - where - sc_pred = funResultTy (piResultTys (idType sel_id) tys) - - -- See Note [Nested quantified constraint superclasses] - mk_given_desc :: Id -> PredType -> (PredType, EvTerm) - mk_given_desc sel_id sc_pred - = (swizzled_pred, swizzled_evterm) - where - (sc_tvs, sc_rho) = splitForAllTys sc_pred - (sc_theta, sc_inner_pred) = splitFunTys sc_rho - - all_tvs = tvs `chkAppend` sc_tvs - all_theta = theta `chkAppend` sc_theta - swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred - - -- evar :: forall tvs. theta => cls tys - -- sel_id :: forall cls_tvs. cls cls_tvs - -- -> forall sc_tvs. sc_theta => sc_inner_pred - -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred - swizzled_evterm = EvExpr $ - mkLams all_tvs $ - mkLams dict_ids $ - Var sel_id - `mkTyApps` tys - `App` (evId evar `mkVarApps` (tvs ++ dict_ids)) - `mkVarApps` sc_tvs - - mk_given_loc loc - | isCTupleClass cls - = loc -- For tuple predicates, just take them apart, without - -- adding their (large) size into the chain. When we - -- get down to a base predicate, we'll include its size. - -- #10335 - - | GivenOrigin skol_info <- ctLocOrigin loc - -- See Note [Solving superclass constraints] in TcInstDcls - -- for explantation of this transformation for givens - = case skol_info of - InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) } - InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) } - _ -> loc - - | otherwise -- Probably doesn't happen, since this function - = loc -- is only used for Givens, but does no harm - -mk_strict_superclasses rec_clss ev tvs theta cls tys - | all noFreeVarsOfType tys - = return [] -- Wanteds with no variables yield no deriveds. - -- See Note [Improvement from Ground Wanteds] - - | otherwise -- Wanted/Derived case, just add Derived superclasses - -- that can lead to improvement. - = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta ) - concatMapM do_one_derived (immSuperClasses cls tys) - where - loc = ctEvLoc ev - - do_one_derived sc_pred - = do { sc_ev <- newDerivedNC loc sc_pred - ; mk_superclasses rec_clss sc_ev [] [] sc_pred } - -{- Note [Improvement from Ground Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose class C b a => D a b -and consider - [W] D Int Bool -Is there any point in emitting [D] C Bool Int? No! The only point of -emitting superclass constraints for W/D constraints is to get -improvement, extra unifications that result from functional -dependencies. See Note [Why adding superclasses can help] above. - -But no variables means no improvement; case closed. --} - -mk_superclasses :: NameSet -> CtEvidence - -> [TyVar] -> ThetaType -> PredType -> TcS [Ct] --- Return this constraint, plus its superclasses, if any -mk_superclasses rec_clss ev tvs theta pred - | ClassPred cls tys <- classifyPredType pred - = mk_superclasses_of rec_clss ev tvs theta cls tys - - | otherwise -- Superclass is not a class predicate - = return [mkNonCanonical ev] - -mk_superclasses_of :: NameSet -> CtEvidence - -> [TyVar] -> ThetaType -> Class -> [Type] - -> TcS [Ct] --- Always return this class constraint, --- and expand its superclasses -mk_superclasses_of rec_clss ev tvs theta cls tys - | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys) - ; return [this_ct] } -- cc_pend_sc of this_ct = True - | otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys - , ppr (isCTupleClass cls) - , ppr rec_clss - ]) - ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys - ; return (this_ct : sc_cts) } - -- cc_pend_sc of this_ct = False - where - cls_nm = className cls - loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss - -- Tuples never contribute to recursion, and can be nested - rec_clss' = rec_clss `extendNameSet` cls_nm - - this_ct | null tvs, null theta - = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys - , cc_pend_sc = loop_found } - -- NB: If there is a loop, we cut off, so we have not - -- added the superclasses, hence cc_pend_sc = True - | otherwise - = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys - , qci_ev = ev - , qci_pend_sc = loop_found }) - - -{- Note [Equality superclasses in quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#15359, #15593, #15625) - f :: (forall a. theta => a ~ b) => stuff - -It's a bit odd to have a local, quantified constraint for `(a~b)`, -but some people want such a thing (see the tickets). And for -Coercible it is definitely useful - f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q))) - => stuff - -Moreover it's not hard to arrange; we just need to look up /equality/ -constraints in the quantified-constraint environment, which we do in -TcInteract.doTopReactOther. - -There is a wrinkle though, in the case where 'theta' is empty, so -we have - f :: (forall a. a~b) => stuff - -Now, potentially, the superclass machinery kicks in, in -makeSuperClasses, giving us a a second quantified constraint - (forall a. a ~# b) -BUT this is an unboxed value! And nothing has prepared us for -dictionary "functions" that are unboxed. Actually it does just -about work, but the simplifier ends up with stuff like - case (/\a. eq_sel d) of df -> ...(df @Int)... -and fails to simplify that any further. And it doesn't satisfy -isPredTy any more. - -So for now we simply decline to take superclasses in the quantified -case. Instead we have a special case in TcInteract.doTopReactOther, -which looks for primitive equalities specially in the quantified -constraints. - -See also Note [Evidence for quantified constraints] in GHC.Core.Predicate. - - -************************************************************************ -* * -* Irreducibles canonicalization -* * -************************************************************************ --} - -canIrred :: CtIrredStatus -> CtEvidence -> TcS (StopOrContinue Ct) --- Precondition: ty not a tuple and no other evidence form -canIrred status ev - = do { let pred = ctEvPred ev - ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred) - ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred - ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> - do { -- Re-classify, in case flattening has improved its shape - ; case classifyPredType (ctEvPred new_ev) of - ClassPred cls tys -> canClassNC new_ev cls tys - EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2 - _ -> continueWith $ - mkIrredCt status new_ev } } - -canHole :: CtEvidence -> OccName -> HoleSort -> TcS (StopOrContinue Ct) -canHole ev occ hole_sort - = do { let pred = ctEvPred ev - ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred - ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> - do { updInertIrreds (`snocCts` (CHoleCan { cc_ev = new_ev - , cc_occ = occ - , cc_hole = hole_sort })) - ; stopWith new_ev "Emit insoluble hole" } } - - -{- ********************************************************************* -* * -* Quantified predicates -* * -********************************************************************* -} - -{- Note [Quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The -XQuantifiedConstraints extension allows type-class contexts like this: - - data Rose f x = Rose x (f (Rose f x)) - - instance (Eq a, forall b. Eq b => Eq (f b)) - => Eq (Rose f a) where - (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2 - -Note the (forall b. Eq b => Eq (f b)) in the instance contexts. -This quantified constraint is needed to solve the - [W] (Eq (f (Rose f x))) -constraint which arises form the (==) definition. - -The wiki page is - https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints -which in turn contains a link to the GHC Proposal where the change -is specified, and a Haskell Symposium paper about it. - -We implement two main extensions to the design in the paper: - - 1. We allow a variable in the instance head, e.g. - f :: forall m a. (forall b. m b) => D (m a) - Notice the 'm' in the head of the quantified constraint, not - a class. - - 2. We support superclasses to quantified constraints. - For example (contrived): - f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool - f x y = x==y - Here we need (Eq (m a)); but the quantified constraint deals only - with Ord. But we can make it work by using its superclass. - -Here are the moving parts - * Language extension {-# LANGUAGE QuantifiedConstraints #-} - and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension - - * A new form of evidence, EvDFun, that is used to discharge - such wanted constraints - - * checkValidType gets some changes to accept forall-constraints - only in the right places. - - * Predicate.Pred gets a new constructor ForAllPred, and - and classifyPredType analyses a PredType to decompose - the new forall-constraints - - * TcSMonad.InertCans gets an extra field, inert_insts, - which holds all the Given forall-constraints. In effect, - such Given constraints are like local instance decls. - - * When trying to solve a class constraint, via - TcInteract.matchInstEnv, use the InstEnv from inert_insts - so that we include the local Given forall-constraints - in the lookup. (See TcSMonad.getInstEnvs.) - - * TcCanonical.canForAll deals with solving a - forall-constraint. See - Note [Solving a Wanted forall-constraint] - - * We augment the kick-out code to kick out an inert - forall constraint if it can be rewritten by a new - type equality; see TcSMonad.kick_out_rewritable - -Note that a quantified constraint is never /inferred/ -(by TcSimplify.simplifyInfer). A function can only have a -quantified constraint in its type if it is given an explicit -type signature. - --} - -canForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType - -> TcS (StopOrContinue Ct) -canForAllNC ev tvs theta pred - | isGiven ev -- See Note [Eagerly expand given superclasses] - , Just (cls, tys) <- cls_pred_tys_maybe - = do { sc_cts <- mkStrictSuperClasses ev tvs theta cls tys - ; emitWork sc_cts - ; canForAll ev False } - - | otherwise - = canForAll ev (isJust cls_pred_tys_maybe) - - where - cls_pred_tys_maybe = getClassPredTys_maybe pred - -canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct) --- We have a constraint (forall as. blah => C tys) -canForAll ev pend_sc - = do { -- First rewrite it to apply the current substitution - -- Do not bother with type-family reductions; we can't - -- do them under a forall anyway (c.f. Flatten.flatten_one - -- on a forall type) - let pred = ctEvPred ev - ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred - ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev -> - - do { -- Now decompose into its pieces and solve it - -- (It takes a lot less code to flatten before decomposing.) - ; case classifyPredType (ctEvPred new_ev) of - ForAllPred tvs theta pred - -> solveForAll new_ev tvs theta pred pend_sc - _ -> pprPanic "canForAll" (ppr new_ev) - } } - -solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool - -> TcS (StopOrContinue Ct) -solveForAll ev tvs theta pred pend_sc - | CtWanted { ctev_dest = dest } <- ev - = -- See Note [Solving a Wanted forall-constraint] - do { let skol_info = QuantCtxtSkol - empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs - ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs - ; given_ev_vars <- mapM newEvVar (substTheta subst theta) - - ; (lvl, (w_id, wanteds)) - <- pushLevelNoWorkList (ppr skol_info) $ - do { wanted_ev <- newWantedEvVarNC loc $ - substTy subst pred - ; return ( ctEvEvId wanted_ev - , unitBag (mkNonCanonical wanted_ev)) } - - ; ev_binds <- emitImplicationTcS lvl skol_info skol_tvs - given_ev_vars wanteds - - ; setWantedEvTerm dest $ - EvFun { et_tvs = skol_tvs, et_given = given_ev_vars - , et_binds = ev_binds, et_body = w_id } - - ; stopWith ev "Wanted forall-constraint" } - - | isGiven ev -- See Note [Solving a Given forall-constraint] - = do { addInertForAll qci - ; stopWith ev "Given forall-constraint" } - - | otherwise - = do { traceTcS "discarding derived forall-constraint" (ppr ev) - ; stopWith ev "Derived forall-constraint" } - where - loc = ctEvLoc ev - qci = QCI { qci_ev = ev, qci_tvs = tvs - , qci_pred = pred, qci_pend_sc = pend_sc } - -{- Note [Solving a Wanted forall-constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Solving a wanted forall (quantified) constraint - [W] df :: forall ab. (Eq a, Ord b) => C x a b -is delightfully easy. Just build an implication constraint - forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a -and discharge df thus: - df = /\ab. \g1 g2. let <binds> in d -where <binds> is filled in by solving the implication constraint. -All the machinery is to hand; there is little to do. - -Note [Solving a Given forall-constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a Given constraint - [G] df :: forall ab. (Eq a, Ord b) => C x a b -we just add it to TcS's local InstEnv of known instances, -via addInertForall. Then, if we look up (C x Int Bool), say, -we'll find a match in the InstEnv. - - -************************************************************************ -* * -* Equalities -* * -************************************************************************ - -Note [Canonicalising equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In order to canonicalise an equality, we look at the structure of the -two types at hand, looking for similarities. A difficulty is that the -types may look dissimilar before flattening but similar after flattening. -However, we don't just want to jump in and flatten right away, because -this might be wasted effort. So, after looking for similarities and failing, -we flatten and then try again. Of course, we don't want to loop, so we -track whether or not we've already flattened. - -It is conceivable to do a better job at tracking whether or not a type -is flattened, but this is left as future work. (Mar '15) - - -Note [FunTy and decomposing tycon applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When can_eq_nc' attempts to decompose a tycon application we haven't yet zonked. -This means that we may very well have a FunTy containing a type of some unknown -kind. For instance, we may have, - - FunTy (a :: k) Int - -Where k is a unification variable. tcRepSplitTyConApp_maybe panics in the event -that it sees such a type as it cannot determine the RuntimeReps which the (->) -is applied to. Consequently, it is vital that we instead use -tcRepSplitTyConApp_maybe', which simply returns Nothing in such a case. - -When this happens can_eq_nc' will fail to decompose, zonk, and try again. -Zonking should fill the variable k, meaning that decomposition will succeed the -second time around. --} - -canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct) -canEqNC ev eq_rel ty1 ty2 - = do { result <- zonk_eq_types ty1 ty2 - ; case result of - Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2 - Right ty -> canEqReflexive ev eq_rel ty } - -can_eq_nc - :: Bool -- True => both types are flat - -> CtEvidence - -> EqRel - -> Type -> Type -- LHS, after and before type-synonym expansion, resp - -> Type -> Type -- RHS, after and before type-synonym expansion, resp - -> TcS (StopOrContinue Ct) -can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - = do { traceTcS "can_eq_nc" $ - vcat [ ppr flat, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ] - ; rdr_env <- getGlobalRdrEnvTcS - ; fam_insts <- getFamInstEnvs - ; can_eq_nc' flat rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 } - -can_eq_nc' - :: Bool -- True => both input types are flattened - -> GlobalRdrEnv -- needed to see which newtypes are in scope - -> FamInstEnvs -- needed to unwrap data instances - -> CtEvidence - -> EqRel - -> Type -> Type -- LHS, after and before type-synonym expansion, resp - -> Type -> Type -- RHS, after and before type-synonym expansion, resp - -> TcS (StopOrContinue Ct) - --- Expand synonyms first; see Note [Type synonyms and canonicalization] -can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | Just ty1' <- tcView ty1 = can_eq_nc' flat rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 - | Just ty2' <- tcView ty2 = can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2 - --- need to check for reflexivity in the ReprEq case. --- See Note [Eager reflexivity check] --- Check only when flat because the zonk_eq_types check in canEqNC takes --- care of the non-flat case. -can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _ - | ty1 `tcEqType` ty2 - = canEqReflexive ev ReprEq ty1 - --- When working with ReprEq, unwrap newtypes. --- See Note [Unwrap newtypes first] --- This must be above the TyVarTy case, in order to guarantee (TyEq:N) -can_eq_nc' _flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | ReprEq <- eq_rel - , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1 - = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2 - - | ReprEq <- eq_rel - , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 - = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1 - --- Then, get rid of casts -can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 - | not (isTyVarTy ty2) -- See (3) in Note [Equalities with incompatible kinds] - = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 -can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ - | not (isTyVarTy ty1) -- See (3) in Note [Equalities with incompatible kinds] - = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 - --- NB: pattern match on True: we want only flat types sent to canEqTyVar. --- See also Note [No top-level newtypes on RHS of representational equalities] -can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2 - = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2 -can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2 - = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1 - ----------------------- --- Otherwise try to decompose ----------------------- - --- Literals -can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ - | l1 == l2 - = do { setEvBindIfWanted ev (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1) - ; stopWith ev "Equal LitTy" } - --- Try to decompose type constructor applications --- Including FunTy (s -> t) -can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _ - --- See Note [FunTy and decomposing type constructor applications]. - | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1 - , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2 - , not (isTypeFamilyTyCon tc1) - , not (isTypeFamilyTyCon tc2) - = canTyConApp ev eq_rel tc1 tys1 tc2 tys2 - -can_eq_nc' _flat _rdr_env _envs ev eq_rel - s1@(ForAllTy {}) _ s2@(ForAllTy {}) _ - = can_eq_nc_forall ev eq_rel s1 s2 - --- See Note [Canonicalising type applications] about why we require flat types -can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _ - | NomEq <- eq_rel - , Just (t2, s2) <- tcSplitAppTy_maybe ty2 - = can_eq_app ev t1 s1 t2 s2 -can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _ - | NomEq <- eq_rel - , Just (t1, s1) <- tcSplitAppTy_maybe ty1 - = can_eq_app ev t1 s1 t2 s2 - --- No similarity in type structure detected. Flatten and try again. -can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 - = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1 - ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2 - ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 - ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } - --- We've flattened and the types don't match. Give up. -can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2 - = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2) - ; case eq_rel of -- See Note [Unsolved equalities] - ReprEq -> continueWith (mkIrredCt OtherCIS ev) - NomEq -> continueWith (mkIrredCt InsolubleCIS ev) } - -- No need to call canEqFailure/canEqHardFailure because they - -- flatten, and the types involved here are already flat - -{- Note [Unsolved equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an unsolved equality like - (a b ~R# Int) -that is not necessarily insoluble! Maybe 'a' will turn out to be a newtype. -So we want to make it a potentially-soluble Irred not an insoluble one. -Missing this point is what caused #15431 --} - ---------------------------------- -can_eq_nc_forall :: CtEvidence -> EqRel - -> Type -> Type -- LHS and RHS - -> TcS (StopOrContinue Ct) --- (forall as. phi1) ~ (forall bs. phi2) --- Check for length match of as, bs --- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs] --- But remember also to unify the kinds of as and bs --- (this is the 'go' loop), and actually substitute phi2[as |> cos / bs] --- Remember also that we might have forall z (a:z). blah --- so we must proceed one binder at a time (#13879) - -can_eq_nc_forall ev eq_rel s1 s2 - | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev - = do { let free_tvs = tyCoVarsOfTypes [s1,s2] - (bndrs1, phi1) = tcSplitForAllVarBndrs s1 - (bndrs2, phi2) = tcSplitForAllVarBndrs s2 - ; if not (equalLength bndrs1 bndrs2) - then do { traceTcS "Forall failure" $ - vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 - , ppr (map binderArgFlag bndrs1) - , ppr (map binderArgFlag bndrs2) ] - ; canEqHardFailure ev s1 s2 } - else - do { traceTcS "Creating implication for polytype equality" $ ppr ev - ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs - ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $ - binderVars bndrs1 - - ; let skol_info = UnifyForAllSkol phi1 - phi1' = substTy subst1 phi1 - - -- Unify the kinds, extend the substitution - go :: [TcTyVar] -> TCvSubst -> [TyVarBinder] - -> TcS (TcCoercion, Cts) - go (skol_tv:skol_tvs) subst (bndr2:bndrs2) - = do { let tv2 = binderVar bndr2 - ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv) - (substTy subst (tyVarKind tv2)) - ; let subst' = extendTvSubstAndInScope subst tv2 - (mkCastTy (mkTyVarTy skol_tv) kind_co) - -- skol_tv is already in the in-scope set, but the - -- free vars of kind_co are not; hence "...AndInScope" - ; (co, wanteds2) <- go skol_tvs subst' bndrs2 - ; return ( mkTcForAllCo skol_tv kind_co co - , wanteds1 `unionBags` wanteds2 ) } - - -- Done: unify phi1 ~ phi2 - go [] subst bndrs2 - = ASSERT( null bndrs2 ) - unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2) - - go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) [] - - empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1) - - ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ - go skol_tvs empty_subst2 bndrs2 - ; emitTvImplicationTcS lvl skol_info skol_tvs wanteds - - ; setWantedEq orig_dest all_co - ; stopWith ev "Deferred polytype equality" } } - - | otherwise - = do { traceTcS "Omitting decomposition of given polytype equality" $ - pprEq s1 s2 -- See Note [Do not decompose given polytype equalities] - ; stopWith ev "Discard given polytype equality" } - - where - unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts) - -- This version returns the wanted constraint rather - -- than putting it in the work list - unify loc role ty1 ty2 - | ty1 `tcEqType` ty2 - = return (mkTcReflCo role ty1, emptyBag) - | otherwise - = do { (wanted, co) <- newWantedEq loc role ty1 ty2 - ; return (co, unitBag (mkNonCanonical wanted)) } - ---------------------------------- --- | Compare types for equality, while zonking as necessary. Gives up --- as soon as it finds that two types are not equal. --- This is quite handy when some unification has made two --- types in an inert Wanted to be equal. We can discover the equality without --- flattening, which is sometimes very expensive (in the case of type functions). --- In particular, this function makes a ~20% improvement in test case --- perf/compiler/T5030. --- --- Returns either the (partially zonked) types in the case of --- inequality, or the one type in the case of equality. canEqReflexive is --- a good next step in the 'Right' case. Returning 'Left' is always safe. --- --- NB: This does *not* look through type synonyms. In fact, it treats type --- synonyms as rigid constructors. In the future, it might be convenient --- to look at only those arguments of type synonyms that actually appear --- in the synonym RHS. But we're not there yet. -zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType) -zonk_eq_types = go - where - go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2 - go (TyVarTy tv1) ty2 = tyvar NotSwapped tv1 ty2 - go ty1 (TyVarTy tv2) = tyvar IsSwapped tv2 ty1 - - -- We handle FunTys explicitly here despite the fact that they could also be - -- treated as an application. Why? Well, for one it's cheaper to just look - -- at two types (the argument and result types) than four (the argument, - -- result, and their RuntimeReps). Also, we haven't completely zonked yet, - -- so we may run into an unzonked type variable while trying to compute the - -- RuntimeReps of the argument and result types. This can be observed in - -- testcase tc269. - go ty1 ty2 - | Just (arg1, res1) <- split1 - , Just (arg2, res2) <- split2 - = do { res_a <- go arg1 arg2 - ; res_b <- go res1 res2 - ; return $ combine_rev mkVisFunTy res_b res_a - } - | isJust split1 || isJust split2 - = bale_out ty1 ty2 - where - split1 = tcSplitFunTy_maybe ty1 - split2 = tcSplitFunTy_maybe ty2 - - go ty1 ty2 - | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1 - , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2 - = if tc1 == tc2 && tys1 `equalLength` tys2 - -- Crucial to check for equal-length args, because - -- we cannot assume that the two args to 'go' have - -- the same kind. E.g go (Proxy * (Maybe Int)) - -- (Proxy (*->*) Maybe) - -- We'll call (go (Maybe Int) Maybe) - -- See #13083 - then tycon tc1 tys1 tys2 - else bale_out ty1 ty2 - - go ty1 ty2 - | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 - , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 - = do { res_a <- go ty1a ty2a - ; res_b <- go ty1b ty2b - ; return $ combine_rev mkAppTy res_b res_a } - - go ty1@(LitTy lit1) (LitTy lit2) - | lit1 == lit2 - = return (Right ty1) - - go ty1 ty2 = bale_out ty1 ty2 - -- We don't handle more complex forms here - - bale_out ty1 ty2 = return $ Left (Pair ty1 ty2) - - tyvar :: SwapFlag -> TcTyVar -> TcType - -> TcS (Either (Pair TcType) TcType) - -- Try to do as little as possible, as anything we do here is redundant - -- with flattening. In particular, no need to zonk kinds. That's why - -- we don't use the already-defined zonking functions - tyvar swapped tv ty - = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } - -> do { cts <- readTcRef ref - ; case cts of - Flexi -> give_up - Indirect ty' -> do { trace_indirect tv ty' - ; unSwap swapped go ty' ty } } - _ -> give_up - where - give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty - - tyvar_tyvar tv1 tv2 - | tv1 == tv2 = return (Right (mkTyVarTy tv1)) - | otherwise = do { (ty1', progress1) <- quick_zonk tv1 - ; (ty2', progress2) <- quick_zonk tv2 - ; if progress1 || progress2 - then go ty1' ty2' - else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) } - - trace_indirect tv ty - = traceTcS "Following filled tyvar (zonk_eq_types)" - (ppr tv <+> equals <+> ppr ty) - - quick_zonk tv = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } - -> do { cts <- readTcRef ref - ; case cts of - Flexi -> return (TyVarTy tv, False) - Indirect ty' -> do { trace_indirect tv ty' - ; return (ty', True) } } - _ -> return (TyVarTy tv, False) - - -- This happens for type families, too. But recall that failure - -- here just means to try harder, so it's OK if the type function - -- isn't injective. - tycon :: TyCon -> [TcType] -> [TcType] - -> TcS (Either (Pair TcType) TcType) - tycon tc tys1 tys2 - = do { results <- zipWithM go tys1 tys2 - ; return $ case combine_results results of - Left tys -> Left (mkTyConApp tc <$> tys) - Right tys -> Right (mkTyConApp tc tys) } - - combine_results :: [Either (Pair TcType) TcType] - -> Either (Pair [TcType]) [TcType] - combine_results = bimap (fmap reverse) reverse . - foldl' (combine_rev (:)) (Right []) - - -- combine (in reverse) a new result onto an already-combined result - combine_rev :: (a -> b -> c) - -> Either (Pair b) b - -> Either (Pair a) a - -> Either (Pair c) c - combine_rev f (Left list) (Left elt) = Left (f <$> elt <*> list) - combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list) - combine_rev f (Right tys) (Left elt) = Left (f <$> elt <*> pure tys) - combine_rev f (Right tys) (Right ty) = Right (f ty tys) - -{- See Note [Unwrap newtypes first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - newtype N m a = MkN (m a) -Then N will get a conservative, Nominal role for its second parameter 'a', -because it appears as an argument to the unknown 'm'. Now consider - [W] N Maybe a ~R# N Maybe b - -If we decompose, we'll get - [W] a ~N# b - -But if instead we unwrap we'll get - [W] Maybe a ~R# Maybe b -which in turn gives us - [W] a ~R# b -which is easier to satisfy. - -Bottom line: unwrap newtypes before decomposing them! -c.f. #9123 comment:52,53 for a compelling example. - -Note [Newtypes can blow the stack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype X = MkX (Int -> X) - newtype Y = MkY (Int -> Y) - -and now wish to prove - - [W] X ~R Y - -This Wanted will loop, expanding out the newtypes ever deeper looking -for a solid match or a solid discrepancy. Indeed, there is something -appropriate to this looping, because X and Y *do* have the same representation, -in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized -coercion will ever witness it. This loop won't actually cause GHC to hang, -though, because we check our depth when unwrapping newtypes. - -Note [Eager reflexivity check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype X = MkX (Int -> X) - -and - - [W] X ~R X - -Naively, we would start unwrapping X and end up in a loop. Instead, -we do this eager reflexivity check. This is necessary only for representational -equality because the flattener technology deals with the similar case -(recursive type families) for nominal equality. - -Note that this check does not catch all cases, but it will catch the cases -we're most worried about, types like X above that are actually inhabited. - -Here's another place where this reflexivity check is key: -Consider trying to prove (f a) ~R (f a). The AppTys in there can't -be decomposed, because representational equality isn't congruent with respect -to AppTy. So, when canonicalising the equality above, we get stuck and -would normally produce a CIrredCan. However, we really do want to -be able to solve (f a) ~R (f a). So, in the representational case only, -we do a reflexivity check. - -(This would be sound in the nominal case, but unnecessary, and I [Richard -E.] am worried that it would slow down the common case.) --} - ------------------------- --- | We're able to unwrap a newtype. Update the bits accordingly. -can_eq_newtype_nc :: CtEvidence -- ^ :: ty1 ~ ty2 - -> SwapFlag - -> TcType -- ^ ty1 - -> ((Bag GlobalRdrElt, TcCoercion), TcType) -- ^ :: ty1 ~ ty1' - -> TcType -- ^ ty2 - -> TcType -- ^ ty2, with type synonyms - -> TcS (StopOrContinue Ct) -can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2 - = do { traceTcS "can_eq_newtype_nc" $ - vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ] - - -- check for blowing our stack: - -- See Note [Newtypes can blow the stack] - ; checkReductionDepth (ctEvLoc ev) ty1 - - -- Next, we record uses of newtype constructors, since coercing - -- through newtypes is tantamount to using their constructors. - ; addUsedGREs gre_list - -- If a newtype constructor was imported, don't warn about not - -- importing it... - ; traverse_ keepAlive $ map gre_name gre_list - -- ...and similarly, if a newtype constructor was defined in the same - -- module, don't warn about it being unused. - -- See Note [Tracking unused binding and imports] in TcRnTypes. - - ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2 - (mkTcSymCo co) (mkTcReflCo Representational ps_ty2) - ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 } - where - gre_list = bagToList gres - ---------- --- ^ Decompose a type application. --- All input types must be flat. See Note [Canonicalising type applications] --- Nominal equality only! -can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2 - -> Xi -> Xi -- s1 t1 - -> Xi -> Xi -- s2 t2 - -> TcS (StopOrContinue Ct) - --- AppTys only decompose for nominal equality, so this case just leads --- to an irreducible constraint; see typecheck/should_compile/T10494 --- See Note [Decomposing equality], note {4} -can_eq_app ev s1 t1 s2 t2 - | CtDerived {} <- ev - = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2] - ; stopWith ev "Decomposed [D] AppTy" } - | CtWanted { ctev_dest = dest } <- ev - = do { co_s <- unifyWanted loc Nominal s1 s2 - ; let arg_loc - | isNextArgVisible s1 = loc - | otherwise = updateCtLocOrigin loc toInvisibleOrigin - ; co_t <- unifyWanted arg_loc Nominal t1 t2 - ; let co = mkAppCo co_s co_t - ; setWantedEq dest co - ; stopWith ev "Decomposed [W] AppTy" } - - -- If there is a ForAll/(->) mismatch, the use of the Left coercion - -- below is ill-typed, potentially leading to a panic in splitTyConApp - -- Test case: typecheck/should_run/Typeable1 - -- We could also include this mismatch check above (for W and D), but it's slow - -- and we'll get a better error message not doing it - | s1k `mismatches` s2k - = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2) - - | CtGiven { ctev_evar = evar } <- ev - = do { let co = mkTcCoVarCo evar - co_s = mkTcLRCo CLeft co - co_t = mkTcLRCo CRight co - ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2 - , evCoercion co_s ) - ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2 - , evCoercion co_t ) - ; emitWorkNC [evar_t] - ; canEqNC evar_s NomEq s1 s2 } - - where - loc = ctEvLoc ev - - s1k = tcTypeKind s1 - s2k = tcTypeKind s2 - - k1 `mismatches` k2 - = isForAllTy k1 && not (isForAllTy k2) - || not (isForAllTy k1) && isForAllTy k2 - ------------------------ --- | Break apart an equality over a casted type --- looking like (ty1 |> co1) ~ ty2 (modulo a swap-flag) -canEqCast :: Bool -- are both types flat? - -> CtEvidence - -> EqRel - -> SwapFlag - -> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1 - -> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty - -> TcS (StopOrContinue Ct) -canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2 - = do { traceTcS "Decomposing cast" (vcat [ ppr ev - , ppr ty1 <+> text "|>" <+> ppr co1 - , ppr ps_ty2 ]) - ; new_ev <- rewriteEqEvidence ev swapped ty1 ps_ty2 - (mkTcGReflRightCo role ty1 co1) - (mkTcReflCo role ps_ty2) - ; can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 } - where - role = eqRelRole eq_rel - ------------------------- -canTyConApp :: CtEvidence -> EqRel - -> TyCon -> [TcType] - -> TyCon -> [TcType] - -> TcS (StopOrContinue Ct) --- See Note [Decomposing TyConApps] -canTyConApp ev eq_rel tc1 tys1 tc2 tys2 - | tc1 == tc2 - , tys1 `equalLength` tys2 - = do { inerts <- getTcSInerts - ; if can_decompose inerts - then do { traceTcS "canTyConApp" - (ppr ev $$ ppr eq_rel $$ ppr tc1 $$ ppr tys1 $$ ppr tys2) - ; canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 - ; stopWith ev "Decomposed TyConApp" } - else canEqFailure ev eq_rel ty1 ty2 } - - -- See Note [Skolem abstract data] (at tyConSkolem) - | tyConSkolem tc1 || tyConSkolem tc2 - = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) - ; continueWith (mkIrredCt OtherCIS ev) } - - -- Fail straight away for better error messages - -- See Note [Use canEqFailure in canDecomposableTyConApp] - | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational && - isGenerativeTyCon tc2 Representational) - = canEqFailure ev eq_rel ty1 ty2 - | otherwise - = canEqHardFailure ev ty1 ty2 - where - ty1 = mkTyConApp tc1 tys1 - ty2 = mkTyConApp tc2 tys2 - - loc = ctEvLoc ev - pred = ctEvPred ev - - -- See Note [Decomposing equality] - can_decompose inerts - = isInjectiveTyCon tc1 (eqRelRole eq_rel) - || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts)) - -{- -Note [Use canEqFailure in canDecomposableTyConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must use canEqFailure, not canEqHardFailure here, because there is -the possibility of success if working with a representational equality. -Here is one case: - - type family TF a where TF Char = Bool - data family DF a - newtype instance DF Bool = MkDF Int - -Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet -know `a`. This is *not* a hard failure, because we might soon learn -that `a` is, in fact, Char, and then the equality succeeds. - -Here is another case: - - [G] Age ~R Int - -where Age's constructor is not in scope. We don't want to report -an "inaccessible code" error in the context of this Given! - -For example, see typecheck/should_compile/T10493, repeated here: - - import Data.Ord (Down) -- no constructor - - foo :: Coercible (Down Int) Int => Down Int -> Int - foo = coerce - -That should compile, but only because we use canEqFailure and not -canEqHardFailure. - -Note [Decomposing equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a constraint (of any flavour and role) that looks like -T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer, -of course, is "it depends". This Note spells it all out. - -In this Note, "decomposition" refers to taking the constraint - [fl] (T tys1 ~X T tys2) -(for some flavour fl and some role X) and replacing it with - [fls'] (tys1 ~Xs' tys2) -where that notation indicates a list of new constraints, where the -new constraints may have different flavours and different roles. - -The key property to consider is injectivity. When decomposing a Given the -decomposition is sound if and only if T is injective in all of its type -arguments. When decomposing a Wanted, the decomposition is sound (assuming the -correct roles in the produced equality constraints), but it may be a guess -- -that is, an unforced decision by the constraint solver. Decomposing Wanteds -over injective TyCons does not entail guessing. But sometimes we want to -decompose a Wanted even when the TyCon involved is not injective! (See below.) - -So, in broad strokes, we want this rule: - -(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective -at role X. - -Pursuing the details requires exploring three axes: -* Flavour: Given vs. Derived vs. Wanted -* Role: Nominal vs. Representational -* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable - -(So a type variable isn't a TyCon, but it's convenient to put the AppTy case -in the same table.) - -Right away, we can say that Derived behaves just as Wanted for the purposes -of decomposition. The difference between Derived and Wanted is the handling of -evidence. Since decomposition in these cases isn't a matter of soundness but of -guessing, we want the same behavior regardless of evidence. - -Here is a table (discussion following) detailing where decomposition of - (T s1 ... sn) ~r (T t1 .. tn) -is allowed. The first four lines (Data types ... type family) refer -to TyConApps with various TyCons T; the last line is for AppTy, where -there is presumably a type variable at the head, so it's actually - (s s1 ... sn) ~r (t t1 .. tn) - -NOMINAL GIVEN WANTED - -Datatype YES YES -Newtype YES YES -Data family YES YES -Type family YES, in injective args{1} YES, in injective args{1} -Type variable YES YES - -REPRESENTATIONAL GIVEN WANTED - -Datatype YES YES -Newtype NO{2} MAYBE{2} -Data family NO{3} MAYBE{3} -Type family NO NO -Type variable NO{4} NO{4} - -{1}: Type families can be injective in some, but not all, of their arguments, -so we want to do partial decomposition. This is quite different than the way -other decomposition is done, where the decomposed equalities replace the original -one. We thus proceed much like we do with superclasses: emitting new Givens -when "decomposing" a partially-injective type family Given and new Deriveds -when "decomposing" a partially-injective type family Wanted. (As of the time of -writing, 13 June 2015, the implementation of injective type families has not -been merged, but it should be soon. Please delete this parenthetical if the -implementation is indeed merged.) - -{2}: See Note [Decomposing newtypes at representational role] - -{3}: Because of the possibility of newtype instances, we must treat -data families like newtypes. See also Note [Decomposing newtypes at -representational role]. See #10534 and test case -typecheck/should_fail/T10534. - -{4}: Because type variables can stand in for newtypes, we conservatively do not -decompose AppTys over representational equality. - -In the implementation of can_eq_nc and friends, we don't directly pattern -match using lines like in the tables above, as those tables don't cover -all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity, -boiling the tables above down to rule (*). The exceptions to rule (*) are for -injective type families, which are handled separately from other decompositions, -and the MAYBE entries above. - -Note [Decomposing newtypes at representational role] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This note discusses the 'newtype' line in the REPRESENTATIONAL table -in Note [Decomposing equality]. (At nominal role, newtypes are fully -decomposable.) - -Here is a representative example of why representational equality over -newtypes is tricky: - - newtype Nt a = Mk Bool -- NB: a is not used in the RHS, - type role Nt representational -- but the user gives it an R role anyway - -If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to -[W] alpha ~R beta, because it's possible that alpha and beta aren't -representationally equal. Here's another example. - - newtype Nt a = MkNt (Id a) - type family Id a where Id a = a - - [W] Nt Int ~R Nt Age - -Because of its use of a type family, Nt's parameter will get inferred to have -a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, which -is unsatisfiable. Unwrapping, though, leads to a solution. - -Conclusion: - * Unwrap newtypes before attempting to decompose them. - This is done in can_eq_nc'. - -It all comes from the fact that newtypes aren't necessarily injective -w.r.t. representational equality. - -Furthermore, as explained in Note [NthCo and newtypes] in GHC.Core.TyCo.Rep, we can't use -NthCo on representational coercions over newtypes. NthCo comes into play -only when decomposing givens. - -Conclusion: - * Do not decompose [G] N s ~R N t - -Is it sensible to decompose *Wanted* constraints over newtypes? Yes! -It's the only way we could ever prove (IO Int ~R IO Age), recalling -that IO is a newtype. - -However we must be careful. Consider - - type role Nt representational - - [G] Nt a ~R Nt b (1) - [W] NT alpha ~R Nt b (2) - [W] alpha ~ a (3) - -If we focus on (3) first, we'll substitute in (2), and now it's -identical to the given (1), so we succeed. But if we focus on (2) -first, and decompose it, we'll get (alpha ~R b), which is not soluble. -This is exactly like the question of overlapping Givens for class -constraints: see Note [Instance and Given overlap] in TcInteract. - -Conclusion: - * Decompose [W] N s ~R N t iff there no given constraint that could - later solve it. - --} - -canDecomposableTyConAppOK :: CtEvidence -> EqRel - -> TyCon -> [TcType] -> [TcType] - -> TcS () --- Precondition: tys1 and tys2 are the same length, hence "OK" -canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 - = ASSERT( tys1 `equalLength` tys2 ) - case ev of - CtDerived {} - -> unifyDeriveds loc tc_roles tys1 tys2 - - CtWanted { ctev_dest = dest } - -- new_locs and tc_roles are both infinite, so - -- we are guaranteed that cos has the same length - -- as tys1 and tys2 - -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2 - ; setWantedEq dest (mkTyConAppCo role tc cos) } - - CtGiven { ctev_evar = evar } - -> do { let ev_co = mkCoVarCo evar - ; given_evs <- newGivenEvVars loc $ - [ ( mkPrimEqPredRole r ty1 ty2 - , evCoercion $ mkNthCo r i ev_co ) - | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] - , r /= Phantom - , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] - ; emitWorkNC given_evs } - where - loc = ctEvLoc ev - role = eqRelRole eq_rel - - -- infinite, as tyConRolesX returns an infinite tail of Nominal - tc_roles = tyConRolesX role tc - - -- Add nuances to the location during decomposition: - -- * if the argument is a kind argument, remember this, so that error - -- messages say "kind", not "type". This is determined based on whether - -- the corresponding tyConBinder is named (that is, dependent) - -- * if the argument is invisible, note this as well, again by - -- looking at the corresponding binder - -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't - -- do either of these changes. (Forgetting to do so led to #16188) - -- - -- NB: infinite in length - new_locs = [ new_loc - | bndr <- tyConBinders tc - , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc - | otherwise = loc - new_loc | isVisibleTyConBinder bndr - = updateCtLocOrigin new_loc0 toInvisibleOrigin - | otherwise - = new_loc0 ] - ++ repeat loc - --- | Call when canonicalizing an equality fails, but if the equality is --- representational, there is some hope for the future. --- Examples in Note [Use canEqFailure in canDecomposableTyConApp] -canEqFailure :: CtEvidence -> EqRel - -> TcType -> TcType -> TcS (StopOrContinue Ct) -canEqFailure ev NomEq ty1 ty2 - = canEqHardFailure ev ty1 ty2 -canEqFailure ev ReprEq ty1 ty2 - = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1 - ; (xi2, co2) <- flatten FM_FlattenAll ev ty2 - -- We must flatten the types before putting them in the - -- inert set, so that we are sure to kick them out when - -- new equalities become available - ; traceTcS "canEqFailure with ReprEq" $ - vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ] - ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 - ; continueWith (mkIrredCt OtherCIS new_ev) } - --- | Call when canonicalizing an equality fails with utterly no hope. -canEqHardFailure :: CtEvidence - -> TcType -> TcType -> TcS (StopOrContinue Ct) --- See Note [Make sure that insolubles are fully rewritten] -canEqHardFailure ev ty1 ty2 - = do { (s1, co1) <- flatten FM_SubstOnly ev ty1 - ; (s2, co2) <- flatten FM_SubstOnly ev ty2 - ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2 - ; continueWith (mkIrredCt InsolubleCIS new_ev) } - -{- -Note [Decomposing TyConApps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see (T s1 t1 ~ T s2 t2), then we can just decompose to - (s1 ~ s2, t1 ~ t2) -and push those back into the work list. But if - s1 = K k1 s2 = K k2 -then we will just decomopose s1~s2, and it might be better to -do so on the spot. An important special case is where s1=s2, -and we get just Refl. - -So canDecomposableTyCon is a fast-path decomposition that uses -unifyWanted etc to short-cut that work. - -Note [Canonicalising type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (s1 t1) ~ ty2, how should we proceed? -The simple things is to see if ty2 is of form (s2 t2), and -decompose. By this time s1 and s2 can't be saturated type -function applications, because those have been dealt with -by an earlier equation in can_eq_nc, so it is always sound to -decompose. - -However, over-eager decomposition gives bad error messages -for things like - a b ~ Maybe c - e f ~ p -> q -Suppose (in the first example) we already know a~Array. Then if we -decompose the application eagerly, yielding - a ~ Maybe - b ~ c -we get an error "Can't match Array ~ Maybe", -but we'd prefer to get "Can't match Array b ~ Maybe c". - -So instead can_eq_wanted_app flattens the LHS and RHS, in the hope of -replacing (a b) by (Array b), before using try_decompose_app to -decompose it. - -Note [Make sure that insolubles are fully rewritten] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When an equality fails, we still want to rewrite the equality -all the way down, so that it accurately reflects - (a) the mutable reference substitution in force at start of solving - (b) any ty-binds in force at this point in solving -See Note [Rewrite insolubles] in TcSMonad. -And if we don't do this there is a bad danger that -TcSimplify.applyTyVarDefaulting will find a variable -that has in fact been substituted. - -Note [Do not decompose Given polytype equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? -No -- what would the evidence look like? So instead we simply discard -this given evidence. - - -Note [Combining insoluble constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As this point we have an insoluble constraint, like Int~Bool. - - * If it is Wanted, delete it from the cache, so that subsequent - Int~Bool constraints give rise to separate error messages - - * But if it is Derived, DO NOT delete from cache. A class constraint - may get kicked out of the inert set, and then have its functional - dependency Derived constraints generated a second time. In that - case we don't want to get two (or more) error messages by - generating two (or more) insoluble fundep constraints from the same - class constraint. - -Note [No top-level newtypes on RHS of representational equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we're in this situation: - - work item: [W] c1 : a ~R b - inert: [G] c2 : b ~R Id a - -where - newtype Id a = Id a - -We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened -and the Id newtype is unwrapped. This is assured by requiring only flat -types in canEqTyVar *and* having the newtype-unwrapping check above -the tyvar check in can_eq_nc. - -Note [Occurs check error] -~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an occurs check error, are we necessarily hosed? Say our -tyvar is tv1 and the type it appears in is xi2. Because xi2 is function -free, then if we're computing w.r.t. nominal equality, then, yes, we're -hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t. -representational equality, this is a little subtler. Once again, (a ~R [a]) -is a bad thing, but (a ~R N a) for a newtype N might be just fine. This -means also that (a ~ b a) might be fine, because `b` might become a newtype. - -So, we must check: does tv1 appear in xi2 under any type constructor -that is generative w.r.t. representational equality? That's what -isInsolubleOccursCheck does. - -See also #10715, which induced this addition. - -Note [canCFunEqCan] -~~~~~~~~~~~~~~~~~~~ -Flattening the arguments to a type family can change the kind of the type -family application. As an easy example, consider (Any k) where (k ~ Type) -is in the inert set. The original (Any k :: k) becomes (Any Type :: Type). -The problem here is that the fsk in the CFunEqCan will have the old kind. - -The solution is to come up with a new fsk/fmv of the right kind. For -givens, this is easy: just introduce a new fsk and update the flat-cache -with the new one. For wanteds, we want to solve the old one if favor of -the new one, so we use dischargeFmv. This also kicks out constraints -from the inert set; this behavior is correct, as the kind-change may -allow more constraints to be solved. - -We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case -if we really need to. Of course `flattenArgsNom` should return `Refl` -whenever possible, but #15577 was an infinite loop because even -though the coercion was homo-kinded, `kind_co` was not `Refl`, so we -made a new (identical) CFunEqCan, and then the entire process repeated. --} - -canCFunEqCan :: CtEvidence - -> TyCon -> [TcType] -- LHS - -> TcTyVar -- RHS - -> TcS (StopOrContinue Ct) --- ^ Canonicalise a CFunEqCan. We know that --- the arg types are already flat, --- and the RHS is a fsk, which we must *not* substitute. --- So just substitute in the LHS -canCFunEqCan ev fn tys fsk - = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys - -- cos :: tys' ~ tys - - ; let lhs_co = mkTcTyConAppCo Nominal fn cos - -- :: F tys' ~ F tys - new_lhs = mkTyConApp fn tys' - - flav = ctEvFlavour ev - ; (ev', fsk') - <- if isTcReflexiveCo kind_co -- See Note [canCFunEqCan] - then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs) - ; let fsk_ty = mkTyVarTy fsk - ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty - lhs_co (mkTcNomReflCo fsk_ty) - ; return (ev', fsk) } - else do { traceTcS "canCFunEqCan: non-refl" $ - vcat [ text "Kind co:" <+> ppr kind_co - , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk) - , text "LHS:" <+> hang (ppr (mkTyConApp fn tys)) - 2 (dcolon <+> ppr (tcTypeKind (mkTyConApp fn tys))) - , text "New LHS" <+> hang (ppr new_lhs) - 2 (dcolon <+> ppr (tcTypeKind new_lhs)) ] - ; (ev', new_co, new_fsk) - <- newFlattenSkolem flav (ctEvLoc ev) fn tys' - ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co - -- sym lhs_co :: F tys ~ F tys' - -- new_co :: F tys' ~ new_fsk - -- co :: F tys ~ (new_fsk |> kind_co) - co = mkTcSymCo lhs_co `mkTcTransCo` - mkTcCoherenceRightCo Nominal - (mkTyVarTy new_fsk) - kind_co - new_co - - ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev) - ; dischargeFunEq ev fsk co xi - ; return (ev', new_fsk) } - - ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev') - ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn - , cc_tyargs = tys', cc_fsk = fsk' }) } - ---------------------- -canEqTyVar :: CtEvidence -- ev :: lhs ~ rhs - -> EqRel -> SwapFlag - -> TcTyVar -- tv1 - -> TcType -- lhs: pretty lhs, already flat - -> TcType -> TcType -- rhs: already flat - -> TcS (StopOrContinue Ct) -canEqTyVar ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 - | k1 `tcEqType` k2 - = canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 - - | otherwise - = canEqTyVarHetero ev eq_rel swapped tv1 ps_xi1 k1 xi2 ps_xi2 k2 - - where - k1 = tyVarKind tv1 - k2 = tcTypeKind xi2 - -canEqTyVarHetero :: CtEvidence -- :: (tv1 :: ki1) ~ (xi2 :: ki2) - -> EqRel -> SwapFlag - -> TcTyVar -> TcType -- tv1, pretty tv1 - -> TcKind -- ki1 - -> TcType -> TcType -- xi2, pretty xi2 :: ki2 - -> TcKind -- ki2 - -> TcS (StopOrContinue Ct) -canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2 - -- See Note [Equalities with incompatible kinds] - = do { kind_co <- emit_kind_co -- :: ki2 ~N ki1 - - ; let -- kind_co :: (ki2 :: *) ~N (ki1 :: *) (whether swapped or not) - -- co1 :: kind(tv1) ~N ki1 - rhs' = xi2 `mkCastTy` kind_co -- :: ki1 - ps_rhs' = ps_xi2 `mkCastTy` kind_co -- :: ki1 - rhs_co = mkTcGReflLeftCo role xi2 kind_co - -- rhs_co :: (xi2 |> kind_co) ~ xi2 - - lhs' = mkTyVarTy tv1 -- same as old lhs - lhs_co = mkTcReflCo role lhs' - - ; traceTcS "Hetero equality gives rise to kind equality" - (ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ]) - ; type_ev <- rewriteEqEvidence ev swapped lhs' rhs' lhs_co rhs_co - - -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more - ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' } - where - emit_kind_co :: TcS CoercionN - emit_kind_co - | CtGiven { ctev_evar = evar } <- ev - = do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar) -- :: k2 ~ k1 - ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co) - ; emitWorkNC [kind_ev] - ; return (ctEvCoercion kind_ev) } - - | otherwise - = unifyWanted kind_loc Nominal ki2 ki1 - - loc = ctev_loc ev - role = eqRelRole eq_rel - kind_loc = mkKindLoc (mkTyVarTy tv1) xi2 loc - kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki2 ki1 - - maybe_sym = case swapped of - IsSwapped -> id -- if the input is swapped, then we already - -- will have k2 ~ k1 - NotSwapped -> mkTcSymCo - --- guaranteed that tcTypeKind lhs == tcTypeKind rhs -canEqTyVarHomo :: CtEvidence - -> EqRel -> SwapFlag - -> TcTyVar -- lhs: tv1 - -> TcType -- pretty lhs, flat - -> TcType -> TcType -- rhs, flat - -> TcS (StopOrContinue Ct) -canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 _ - | Just (tv2, _) <- tcGetCastedTyVar_maybe xi2 - , tv1 == tv2 - = canEqReflexive ev eq_rel (mkTyVarTy tv1) - -- we don't need to check co because it must be reflexive - - -- this guarantees (TyEq:TV) - | Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2 - , swapOverTyVars tv1 tv2 - = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) - ; let role = eqRelRole eq_rel - sym_co2 = mkTcSymCo co2 - ty1 = mkTyVarTy tv1 - new_lhs = ty1 `mkCastTy` sym_co2 - lhs_co = mkTcGReflLeftCo role ty1 sym_co2 - - new_rhs = mkTyVarTy tv2 - rhs_co = mkTcGReflRightCo role new_rhs co2 - - ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co - - ; dflags <- getDynFlags - ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_xi1 `mkCastTy` sym_co2) } - -canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_xi2 - = do { dflags <- getDynFlags - ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_xi2 } - --- The RHS here is either not a casted tyvar, or it's a tyvar but we want --- to rewrite the LHS to the RHS (as per swapOverTyVars) -canEqTyVar2 :: DynFlags - -> CtEvidence -- lhs ~ rhs (or, if swapped, orhs ~ olhs) - -> EqRel - -> SwapFlag - -> TcTyVar -- lhs = tv, flat - -> TcType -- rhs, flat - -> TcS (StopOrContinue Ct) --- LHS is an inert type variable, --- and RHS is fully rewritten, but with type synonyms --- preserved as much as possible --- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K) --- the "flat" requirement guarantees (TyEq:AFF) --- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqTyVarHomo -canEqTyVar2 dflags ev eq_rel swapped tv1 rhs - -- this next line checks also for coercion holes; see - -- Note [Equalities with incompatible kinds] - | MTVU_OK rhs' <- mtvu -- No occurs check - -- Must do the occurs check even on tyvar/tyvar - -- equalities, in case have x ~ (y :: ..x...) - -- #12593 - -- guarantees (TyEq:OC), (TyEq:F), and (TyEq:H) - = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2 - ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1 - , cc_rhs = rhs', cc_eq_rel = eq_rel }) } - - | otherwise -- For some reason (occurs check, or forall) we can't unify - -- We must not use it for further rewriting! - = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs) - ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2 - ; let status | isInsolubleOccursCheck eq_rel tv1 rhs - = InsolubleCIS - -- If we have a ~ [a], it is not canonical, and in particular - -- we don't want to rewrite existing inerts with it, otherwise - -- we'd risk divergence in the constraint solver - - | MTVU_HoleBlocker <- mtvu - = BlockedCIS - -- This is the case detailed in - -- Note [Equalities with incompatible kinds] - - | otherwise - = OtherCIS - -- A representational equality with an occurs-check problem isn't - -- insoluble! For example: - -- a ~R b a - -- We might learn that b is the newtype Id. - -- But, the occurs-check certainly prevents the equality from being - -- canonical, and we might loop if we were to use it in rewriting. - - ; continueWith (mkIrredCt status new_ev) } - where - mtvu = metaTyVarUpdateOK dflags tv1 rhs - - role = eqRelRole eq_rel - - lhs = mkTyVarTy tv1 - - rewrite_co1 = mkTcReflCo role lhs - rewrite_co2 = mkTcReflCo role rhs - --- | Solve a reflexive equality constraint -canEqReflexive :: CtEvidence -- ty ~ ty - -> EqRel - -> TcType -- ty - -> TcS (StopOrContinue Ct) -- always Stop -canEqReflexive ev eq_rel ty - = do { setEvBindIfWanted ev (evCoercion $ - mkTcReflCo (eqRelRole eq_rel) ty) - ; stopWith ev "Solved by reflexivity" } - -{- Note [Equalities with incompatible kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What do we do when we have an equality - - (tv :: k1) ~ (rhs :: k2) - -where k1 and k2 differ? Easy: we create a coercion that relates k1 and -k2 and use this to cast. To wit, from - - [X] (tv :: k1) ~ (rhs :: k2) - -we go to - - [noDerived X] co :: k2 ~ k1 - [X] (tv :: k1) ~ ((rhs |> co) :: k1) - -where - - noDerived G = G - noDerived _ = W - -Wrinkles: - - (1) The noDerived step is because Derived equalities have no evidence. - And yet we absolutely need evidence to be able to proceed here. - Given evidence will use the KindCo coercion; Wanted evidence will - be a coercion hole. Even a Derived hetero equality begets a Wanted - kind equality. - - (2) Though it would be sound to do so, we must not mark the rewritten Wanted - [W] (tv :: k1) ~ ((rhs |> co) :: k1) - as canonical in the inert set. In particular, we must not unify tv. - If we did, the Wanted becomes a Given (effectively), and then can - rewrite other Wanteds. But that's bad: See Note [Wanteds to not rewrite Wanteds] - in Constraint. The problem is about poor error messages. See #11198 for - tales of destruction. - - So, we have an invariant on CTyEqCan (TyEq:H) that the RHS does not have - any coercion holes. This is checked in metaTyVarUpdateOK. We also - must be sure to kick out any constraints that mention coercion holes - when those holes get filled in. - - (2a) We don't want to do this for CoercionHoles that witness - CFunEqCans (that are produced by the flattener), as these will disappear - once we unflatten. So we remember in the CoercionHole structure - whether the presence of the hole should block substitution or not. - A bit gross, this. - - (2b) We must now absolutely make sure to kick out any constraints that - mention a newly-filled-in coercion hole. This is done in - kickOutAfterFillingCoercionHole. - - (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the - algorithm detailed here, producing [W] co :: k2 ~ k1, and adding - [W] (a :: k1) ~ ((rhs |> co) :: k1) to the irreducibles. Some time - later, we solve co, and fill in co's coercion hole. This kicks out - the irreducible as described in (2b). - But now, during canonicalization, we see the cast - and remove it, in canEqCast. By the time we get into canEqTyVar, the equality - is heterogeneous again, and the process repeats. - - To avoid this, we don't strip casts off a type if the other type - in the equality is a tyvar. And this is an improvement regardless: - because tyvars can, generally, unify with casted types, there's no - reason to go through the work of stripping off the cast when the - cast appears opposite a tyvar. This is implemented in the cast case - of can_eq_nc'. - - (4) Reporting an error for a constraint that is blocked only because - of wrinkle (2) is hard: what would we say to users? And we don't - really need to report, because if a constraint is blocked, then - there is unsolved wanted blocking it; that unsolved wanted will - be reported. We thus push such errors to the bottom of the queue - in the error-reporting code; they should never be printed. - - (4a) It would seem possible to do this filtering just based on the - presence of a blocking coercion hole. However, this is no good, - as it suppresses e.g. no-instance-found errors. We thus record - a CtIrredStatus in CIrredCan and filter based on this status. - This happened in T14584. An alternative approach is to expressly - look for *equalities* with blocking coercion holes, but actually - recording the blockage in a status field seems nicer. - - (4b) The error message might be printed with -fdefer-type-errors, - so it still must exist. This is the only reason why there is - a message at all. Otherwise, we could simply do nothing. - -Historical note: - -We used to do this via emitting a Derived kind equality and then parking -the heterogeneous equality as irreducible. But this new approach is much -more direct. And it doesn't produce duplicate Deriveds (as the old one did). - -Note [Type synonyms and canonicalization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat type synonym applications as xi types, that is, they do not -count as type function applications. However, we do need to be a bit -careful with type synonyms: like type functions they may not be -generative or injective. However, unlike type functions, they are -parametric, so there is no problem in expanding them whenever we see -them, since we do not need to know anything about their arguments in -order to expand them; this is what justifies not having to treat them -as specially as type function applications. The thing that causes -some subtleties is that we prefer to leave type synonym applications -*unexpanded* whenever possible, in order to generate better error -messages. - -If we encounter an equality constraint with type synonym applications -on both sides, or a type synonym application on one side and some sort -of type application on the other, we simply must expand out the type -synonyms in order to continue decomposing the equality constraint into -primitive equality constraints. For example, suppose we have - - type F a = [Int] - -and we encounter the equality - - F a ~ [b] - -In order to continue we must expand F a into [Int], giving us the -equality - - [Int] ~ [b] - -which we can then decompose into the more primitive equality -constraint - - Int ~ b. - -However, if we encounter an equality constraint with a type synonym -application on one side and a variable on the other side, we should -NOT (necessarily) expand the type synonym, since for the purpose of -good error messages we want to leave type synonyms unexpanded as much -as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqTyVar. - --} - -{- -************************************************************************ -* * - Evidence transformation -* * -************************************************************************ --} - -data StopOrContinue a - = ContinueWith a -- The constraint was not solved, although it may have - -- been rewritten - - | Stop CtEvidence -- The (rewritten) constraint was solved - SDoc -- Tells how it was solved - -- Any new sub-goals have been put on the work list - deriving (Functor) - -instance Outputable a => Outputable (StopOrContinue a) where - ppr (Stop ev s) = text "Stop" <> parens s <+> ppr ev - ppr (ContinueWith w) = text "ContinueWith" <+> ppr w - -continueWith :: a -> TcS (StopOrContinue a) -continueWith = return . ContinueWith - -stopWith :: CtEvidence -> String -> TcS (StopOrContinue a) -stopWith ev s = return (Stop ev (text s)) - -andWhenContinue :: TcS (StopOrContinue a) - -> (a -> TcS (StopOrContinue b)) - -> TcS (StopOrContinue b) -andWhenContinue tcs1 tcs2 - = do { r <- tcs1 - ; case r of - Stop ev s -> return (Stop ev s) - ContinueWith ct -> tcs2 ct } -infixr 0 `andWhenContinue` -- allow chaining with ($) - -rewriteEvidence :: CtEvidence -- old evidence - -> TcPredType -- new predicate - -> TcCoercion -- Of type :: new predicate ~ <type of old evidence> - -> TcS (StopOrContinue CtEvidence) --- Returns Just new_ev iff either (i) 'co' is reflexivity --- or (ii) 'co' is not reflexivity, and 'new_pred' not cached --- In either case, there is nothing new to do with new_ev -{- - rewriteEvidence old_ev new_pred co -Main purpose: create new evidence for new_pred; - unless new_pred is cached already -* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev -* If old_ev was wanted, create a binding for old_ev, in terms of new_ev -* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev -* Returns Nothing if new_ev is already cached - - Old evidence New predicate is Return new evidence - flavour of same flavor - ------------------------------------------------------------------- - Wanted Already solved or in inert Nothing - or Derived Not Just new_evidence - - Given Already in inert Nothing - Not Just new_evidence - -Note [Rewriting with Refl] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the coercion is just reflexivity then you may re-use the same -variable. But be careful! Although the coercion is Refl, new_pred -may reflect the result of unification alpha := ty, so new_pred might -not _look_ the same as old_pred, and it's vital to proceed from now on -using new_pred. - -qThe flattener preserves type synonyms, so they should appear in new_pred -as well as in old_pred; that is important for good error messages. - -} - - -rewriteEvidence old_ev@(CtDerived {}) new_pred _co - = -- If derived, don't even look at the coercion. - -- This is very important, DO NOT re-order the equations for - -- rewriteEvidence to put the isTcReflCo test first! - -- Why? Because for *Derived* constraints, c, the coercion, which - -- was produced by flattening, may contain suspended calls to - -- (ctEvExpr c), which fails for Derived constraints. - -- (Getting this wrong caused #7384.) - continueWith (old_ev { ctev_pred = new_pred }) - -rewriteEvidence old_ev new_pred co - | isTcReflCo co -- See Note [Rewriting with Refl] - = continueWith (old_ev { ctev_pred = new_pred }) - -rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co - = do { new_ev <- newGivenEvVar loc (new_pred, new_tm) - ; continueWith new_ev } - where - -- mkEvCast optimises ReflCo - new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational - (ctEvRole ev) - (mkTcSymCo co)) - -rewriteEvidence ev@(CtWanted { ctev_dest = dest - , ctev_nosh = si - , ctev_loc = loc }) new_pred co - = do { mb_new_ev <- newWanted_SI si loc new_pred - -- The "_SI" variant ensures that we make a new Wanted - -- with the same shadow-info as the existing one - -- with the same shadow-info as the existing one (#16735) - ; MASSERT( tcCoercionRole co == ctEvRole ev ) - ; setWantedEvTerm dest - (mkEvCast (getEvExpr mb_new_ev) - (tcDowngradeRole Representational (ctEvRole ev) co)) - ; case mb_new_ev of - Fresh new_ev -> continueWith new_ev - Cached _ -> stopWith ev "Cached wanted" } - - -rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) - -- or orhs ~ olhs (swapped) - -> SwapFlag - -> TcType -> TcType -- New predicate nlhs ~ nrhs - -> TcCoercion -- lhs_co, of type :: nlhs ~ olhs - -> TcCoercion -- rhs_co, of type :: nrhs ~ orhs - -> TcS CtEvidence -- Of type nlhs ~ nrhs --- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co) --- we generate --- If not swapped --- g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co --- If 'swapped' --- g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co --- --- For (Wanted w) we do the dual thing. --- New w1 : nlhs ~ nrhs --- If not swapped --- w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co --- If swapped --- w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co --- --- It's all a form of rewwriteEvidence, specialised for equalities -rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co - | CtDerived {} <- old_ev -- Don't force the evidence for a Derived - = return (old_ev { ctev_pred = new_pred }) - - | NotSwapped <- swapped - , isTcReflCo lhs_co -- See Note [Rewriting with Refl] - , isTcReflCo rhs_co - = return (old_ev { ctev_pred = new_pred }) - - | CtGiven { ctev_evar = old_evar } <- old_ev - = do { let new_tm = evCoercion (lhs_co - `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar) - `mkTcTransCo` mkTcSymCo rhs_co) - ; newGivenEvVar loc' (new_pred, new_tm) } - - | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev - = case dest of - HoleDest hole -> - do { (new_ev, hole_co) <- newWantedEq_SI (ch_blocker hole) si loc' - (ctEvRole old_ev) nlhs nrhs - -- The "_SI" variant ensures that we make a new Wanted - -- with the same shadow-info as the existing one (#16735) - ; let co = maybeSym swapped $ - mkSymCo lhs_co - `mkTransCo` hole_co - `mkTransCo` rhs_co - ; setWantedEq dest co - ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co]) - ; return new_ev } - - _ -> panic "rewriteEqEvidence" - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise - = panic "rewriteEvidence" -#endif - where - new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs - - -- equality is like a type class. Bumping the depth is necessary because - -- of recursive newtypes, where "reducing" a newtype can actually make - -- it bigger. See Note [Newtypes can blow the stack]. - loc = ctEvLoc old_ev - loc' = bumpCtLocDepth loc - -{- Note [unifyWanted and unifyDerived] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When decomposing equalities we often create new wanted constraints for -(s ~ t). But what if s=t? Then it'd be faster to return Refl right away. -Similar remarks apply for Derived. - -Rather than making an equality test (which traverses the structure of the -type, perhaps fruitlessly), unifyWanted traverses the common structure, and -bales out when it finds a difference by creating a new Wanted constraint. -But where it succeeds in finding common structure, it just builds a coercion -to reflect it. --} - -unifyWanted :: CtLoc -> Role - -> TcType -> TcType -> TcS Coercion --- Return coercion witnessing the equality of the two types, --- emitting new work equalities where necessary to achieve that --- Very good short-cut when the two types are equal, or nearly so --- See Note [unifyWanted and unifyDerived] --- The returned coercion's role matches the input parameter -unifyWanted loc Phantom ty1 ty2 - = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2) - ; return (mkPhantomCo kind_co ty1 ty2) } - -unifyWanted loc role orig_ty1 orig_ty2 - = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - - go (FunTy _ s1 t1) (FunTy _ s2 t2) - = do { co_s <- unifyWanted loc role s1 s2 - ; co_t <- unifyWanted loc role t1 t2 - ; return (mkFunCo role co_s co_t) } - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, tys1 `equalLength` tys2 - , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality - = do { cos <- zipWith3M (unifyWanted loc) - (tyConRolesX role tc1) tys1 tys2 - ; return (mkTyConAppCo role tc1 cos) } - - go ty1@(TyVarTy tv) ty2 - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty1' -> go ty1' ty2 - Nothing -> bale_out ty1 ty2} - go ty1 ty2@(TyVarTy tv) - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty2' -> go ty1 ty2' - Nothing -> bale_out ty1 ty2 } - - go ty1@(CoercionTy {}) (CoercionTy {}) - = return (mkReflCo role ty1) -- we just don't care about coercions! - - go ty1 ty2 = bale_out ty1 ty2 - - bale_out ty1 ty2 - | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1) - -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2 - -unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS () --- See Note [unifyWanted and unifyDerived] -unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2 - -unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS () --- See Note [unifyWanted and unifyDerived] -unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2 - -unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS () --- Create new Derived and put it in the work list --- Should do nothing if the two types are equal --- See Note [unifyWanted and unifyDerived] -unify_derived _ Phantom _ _ = return () -unify_derived loc role orig_ty1 orig_ty2 - = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - - go (FunTy _ s1 t1) (FunTy _ s2 t2) - = do { unify_derived loc role s1 s2 - ; unify_derived loc role t1 t2 } - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, tys1 `equalLength` tys2 - , isInjectiveTyCon tc1 role - = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2 - go ty1@(TyVarTy tv) ty2 - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty1' -> go ty1' ty2 - Nothing -> bale_out ty1 ty2 } - go ty1 ty2@(TyVarTy tv) - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty2' -> go ty1 ty2' - Nothing -> bale_out ty1 ty2 } - go ty1 ty2 = bale_out ty1 ty2 - - bale_out ty1 ty2 - | ty1 `tcEqType` ty2 = return () - -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2 - -maybeSym :: SwapFlag -> TcCoercion -> TcCoercion -maybeSym IsSwapped co = mkTcSymCo co -maybeSym NotSwapped co = co diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs deleted file mode 100644 index c705902a10..0000000000 --- a/compiler/typecheck/TcClassDcl.hs +++ /dev/null @@ -1,548 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Typechecking class declarations --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcClassDcl ( tcClassSigs, tcClassDecl2, - findMethodBind, instantiateMethod, - tcClassMinimalDef, - HsSigFun, mkHsSigFun, - badMethodErr, - instDeclCtxt1, instDeclCtxt2, instDeclCtxt3, - tcATDefault - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TcEnv -import TcSigs -import TcEvidence ( idHsWrapper ) -import TcBinds -import TcUnify -import TcHsType -import TcMType -import GHC.Core.Type ( piResultTys ) -import GHC.Core.Predicate -import TcOrigin -import TcType -import TcRnMonad -import GHC.Driver.Phases (HscSource(..)) -import BuildTyCl( TcMethInfo ) -import GHC.Core.Class -import GHC.Core.Coercion ( pprCoAxiom ) -import GHC.Driver.Session -import FamInst -import GHC.Core.FamInstEnv -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Var -import GHC.Types.Var.Env -import Outputable -import GHC.Types.SrcLoc -import GHC.Core.TyCon -import Maybes -import GHC.Types.Basic -import Bag -import FastString -import BooleanFormula -import Util - -import Control.Monad -import Data.List ( mapAccumL, partition ) - -{- -Dictionary handling -~~~~~~~~~~~~~~~~~~~ -Every class implicitly declares a new data type, corresponding to dictionaries -of that class. So, for example: - - class (D a) => C a where - op1 :: a -> a - op2 :: forall b. Ord b => a -> b -> b - -would implicitly declare - - data CDict a = CDict (D a) - (a -> a) - (forall b. Ord b => a -> b -> b) - -(We could use a record decl, but that means changing more of the existing apparatus. -One step at a time!) - -For classes with just one superclass+method, we use a newtype decl instead: - - class C a where - op :: forallb. a -> b -> b - -generates - - newtype CDict a = CDict (forall b. a -> b -> b) - -Now DictTy in Type is just a form of type synomym: - DictTy c t = TyConTy CDict `AppTy` t - -Death to "ExpandingDicts". - - -************************************************************************ -* * - Type-checking the class op signatures -* * -************************************************************************ --} - -illegalHsigDefaultMethod :: Name -> SDoc -illegalHsigDefaultMethod n = - text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file" - -tcClassSigs :: Name -- Name of the class - -> [LSig GhcRn] - -> LHsBinds GhcRn - -> TcM [TcMethInfo] -- Exactly one for each method -tcClassSigs clas sigs def_methods - = do { traceTc "tcClassSigs 1" (ppr clas) - - ; gen_dm_prs <- concatMapM (addLocM tc_gen_sig) gen_sigs - ; let gen_dm_env :: NameEnv (SrcSpan, Type) - gen_dm_env = mkNameEnv gen_dm_prs - - ; op_info <- concatMapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs - - ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ] - ; sequence_ [ failWithTc (badMethodErr clas n) - | n <- dm_bind_names, not (n `elemNameSet` op_names) ] - -- Value binding for non class-method (ie no TypeSig) - - ; tcg_env <- getGblEnv - ; if tcg_src tcg_env == HsigFile - then - -- Error if we have value bindings - -- (Generic signatures without value bindings indicate - -- that a default of this form is expected to be - -- provided.) - when (not (null def_methods)) $ - failWithTc (illegalHsigDefaultMethod clas) - else - -- Error for each generic signature without value binding - sequence_ [ failWithTc (badGenericMethod clas n) - | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] - - ; traceTc "tcClassSigs 2" (ppr clas) - ; return op_info } - where - vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs] - gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs] - dm_bind_names :: [Name] -- These ones have a value binding in the class decl - dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] - - skol_info = TyConSkol ClassFlavour clas - - tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn) - -> TcM [TcMethInfo] - tc_sig gen_dm_env (op_names, op_hs_ty) - = do { traceTc "ClsSig 1" (ppr op_names) - ; op_ty <- tcClassSigType skol_info op_names op_hs_ty - -- Class tyvars already in scope - - ; traceTc "ClsSig 2" (ppr op_names) - ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] } - where - f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty) - | nm `elem` dm_bind_names = Just VanillaDM - | otherwise = Nothing - - tc_gen_sig (op_names, gen_hs_ty) - = do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty - ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] } - -{- -************************************************************************ -* * - Class Declarations -* * -************************************************************************ --} - -tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration - -> TcM (LHsBinds GhcTcId) - -tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, - tcdMeths = default_binds})) - = recoverM (return emptyLHsBinds) $ - setSrcSpan (getLoc class_name) $ - do { clas <- tcLookupLocatedClass class_name - - -- We make a separate binding for each default method. - -- At one time I used a single AbsBinds for all of them, thus - -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... } - -- But that desugars into - -- ds = \d -> (..., ..., ...) - -- dm1 = \d -> case ds d of (a,b,c) -> a - -- And since ds is big, it doesn't get inlined, so we don't get good - -- default methods. Better to make separate AbsBinds for each - ; let (tyvars, _, _, op_items) = classBigSig clas - prag_fn = mkPragEnv sigs default_binds - sig_fn = mkHsSigFun sigs - clas_tyvars = snd (tcSuperSkolTyVars tyvars) - pred = mkClassPred clas (mkTyVarTys clas_tyvars) - ; this_dict <- newEvVar pred - - ; let tc_item = tcDefMeth clas clas_tyvars this_dict - default_binds sig_fn prag_fn - ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ - mapM tc_item op_items - - ; return (unionManyBags dm_binds) } - -tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) - -tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn - -> HsSigFun -> TcPragEnv -> ClassOpItem - -> TcM (LHsBinds GhcTcId) --- Generate code for default methods --- This is incompatible with Hugs, which expects a polymorphic --- default method for every class op, regardless of whether or not --- the programmer supplied an explicit default decl for the class. --- (If necessary we can fix that, but we don't have a convenient Id to hand.) - -tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) - = do { -- No default method - mapM_ (addLocM (badDmPrag sel_id)) - (lookupPragEnv prag_fn (idName sel_id)) - ; return emptyBag } - -tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn - (sel_id, Just (dm_name, dm_spec)) - | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn - = do { -- First look up the default method; it should be there! - -- It can be the ordinary default method - -- or the generic-default method. E.g of the latter - -- class C a where - -- op :: a -> a -> Bool - -- default op :: Eq a => a -> a -> Bool - -- op x y = x==y - -- The default method we generate is - -- $gm :: (C a, Eq a) => a -> a -> Bool - -- $gm x y = x==y - - global_dm_id <- tcLookupId dm_name - ; global_dm_id <- addInlinePrags global_dm_id prags - ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc - -- Base the local_dm_name on the selector name, because - -- type errors from tcInstanceMethodBody come from here - - ; spec_prags <- discardConstraints $ - tcSpecPrags global_dm_id prags - ; warnTc NoReason - (not (null spec_prags)) - (text "Ignoring SPECIALISE pragmas on default method" - <+> quotes (ppr sel_name)) - - ; let hs_ty = hs_sig_fn sel_name - `orElse` pprPanic "tc_dm" (ppr sel_name) - -- We need the HsType so that we can bring the right - -- type variables into scope - -- - -- Eg. class C a where - -- op :: forall b. Eq b => a -> [b] -> a - -- gen_op :: a -> a - -- generic gen_op :: D a => a -> a - -- The "local_dm_ty" is precisely the type in the above - -- type signatures, ie with no "forall a. C a =>" prefix - - local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars) - - lm_bind = dm_bind { fun_id = L bind_loc local_dm_name } - -- Substitute the local_meth_name for the binder - -- NB: the binding is always a FunBind - - warn_redundant = case dm_spec of - GenericDM {} -> True - VanillaDM -> False - -- For GenericDM, warn if the user specifies a signature - -- with redundant constraints; but not for VanillaDM, where - -- the default method may well be 'error' or something - - ctxt = FunSigCtxt sel_name warn_redundant - - ; let local_dm_id = mkLocalId local_dm_name local_dm_ty - local_dm_sig = CompleteSig { sig_bndr = local_dm_id - , sig_ctxt = ctxt - , sig_loc = getLoc (hsSigType hs_ty) } - - ; (ev_binds, (tc_bind, _)) - <- checkConstraints skol_info tyvars [this_dict] $ - tcPolyCheck no_prag_fn local_dm_sig - (L bind_loc lm_bind) - - ; let export = ABE { abe_ext = noExtField - , abe_poly = global_dm_id - , abe_mono = local_dm_id - , abe_wrap = idHsWrapper - , abe_prags = IsDefaultMethod } - full_bind = AbsBinds { abs_ext = noExtField - , abs_tvs = tyvars - , abs_ev_vars = [this_dict] - , abs_exports = [export] - , abs_ev_binds = [ev_binds] - , abs_binds = tc_bind - , abs_sig = True } - - ; return (unitBag (L bind_loc full_bind)) } - - | otherwise = pprPanic "tcDefMeth" (ppr sel_id) - where - skol_info = TyConSkol ClassFlavour (getName clas) - sel_name = idName sel_id - no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; - -- they are all for meth_id - ---------------- -tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef -tcClassMinimalDef _clas sigs op_info - = case findMinimalDef sigs of - Nothing -> return defMindef - Just mindef -> do - -- Warn if the given mindef does not imply the default one - -- That is, the given mindef should at least ensure that the - -- class ops without default methods are required, since we - -- have no way to fill them in otherwise - tcg_env <- getGblEnv - -- However, only do this test when it's not an hsig file, - -- since you can't write a default implementation. - when (tcg_src tcg_env /= HsigFile) $ - whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ - (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf)) - return mindef - where - -- By default require all methods without a default implementation - defMindef :: ClassMinimalDef - defMindef = mkAnd [ noLoc (mkVar name) - | (name, _, Nothing) <- op_info ] - -instantiateMethod :: Class -> TcId -> [TcType] -> TcType --- Take a class operation, say --- op :: forall ab. C a => forall c. Ix c => (b,c) -> a --- Instantiate it at [ty1,ty2] --- Return the "local method type": --- forall c. Ix x => (ty2,c) -> ty1 -instantiateMethod clas sel_id inst_tys - = ASSERT( ok_first_pred ) local_meth_ty - where - rho_ty = piResultTys (idType sel_id) inst_tys - (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty - `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) - - ok_first_pred = case getClassPredTys_maybe first_pred of - Just (clas1, _tys) -> clas == clas1 - Nothing -> False - -- The first predicate should be of form (C a b) - -- where C is the class in question - - ---------------------------- -type HsSigFun = Name -> Maybe (LHsSigType GhcRn) - -mkHsSigFun :: [LSig GhcRn] -> HsSigFun -mkHsSigFun sigs = lookupNameEnv env - where - env = mkHsSigEnv get_classop_sig sigs - - get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn) - get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty) - get_classop_sig _ = Nothing - ---------------------------- -findMethodBind :: Name -- Selector - -> LHsBinds GhcRn -- A group of bindings - -> TcPragEnv - -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn]) - -- Returns the binding, the binding - -- site of the method binder, and any inline or - -- specialisation pragmas -findMethodBind sel_name binds prag_fn - = foldl' mplus Nothing (mapBag f binds) - where - prags = lookupPragEnv prag_fn sel_name - - f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) - | op_name == sel_name - = Just (bind, bndr_loc, prags) - f _other = Nothing - ---------------------------- -findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef -findMinimalDef = firstJusts . map toMinimalDef - where - toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef - toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf) - toMinimalDef _ = Nothing - -{- -Note [Polymorphic methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - class Foo a where - op :: forall b. Ord b => a -> b -> b -> b - instance Foo c => Foo [c] where - op = e - -When typechecking the binding 'op = e', we'll have a meth_id for op -whose type is - op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b - -So tcPolyBinds must be capable of dealing with nested polytypes; -and so it is. See TcBinds.tcMonoBinds (with type-sig case). - -Note [Silly default-method bind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we pass the default method binding to the type checker, it must -look like op2 = e -not $dmop2 = e -otherwise the "$dm" stuff comes out error messages. But we want the -"$dm" to come out in the interface file. So we typecheck the former, -and wrap it in a let, thus - $dmop2 = let op2 = e in op2 -This makes the error messages right. - - -************************************************************************ -* * - Error messages -* * -************************************************************************ --} - -badMethodErr :: Outputable a => a -> Name -> SDoc -badMethodErr clas op - = hsep [text "Class", quotes (ppr clas), - text "does not have a method", quotes (ppr op)] - -badGenericMethod :: Outputable a => a -> Name -> SDoc -badGenericMethod clas op - = hsep [text "Class", quotes (ppr clas), - text "has a generic-default signature without a binding", quotes (ppr op)] - -{- -badGenericInstanceType :: LHsBinds Name -> SDoc -badGenericInstanceType binds - = vcat [text "Illegal type pattern in the generic bindings", - nest 2 (ppr binds)] - -missingGenericInstances :: [Name] -> SDoc -missingGenericInstances missing - = text "Missing type patterns for" <+> pprQuotedList missing - -dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc -dupGenericInsts tc_inst_infos - = vcat [text "More than one type pattern for a single generic type constructor:", - nest 2 (vcat (map ppr_inst_ty tc_inst_infos)), - text "All the type patterns for a generic type constructor must be identical" - ] - where - ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) --} -badDmPrag :: TcId -> Sig GhcRn -> TcM () -badDmPrag sel_id prag - = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method") - <+> quotes (ppr sel_id) - <+> text "lacks an accompanying binding") - -warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc -warningMinimalDefIncomplete mindef - = vcat [ text "The MINIMAL pragma does not require:" - , nest 2 (pprBooleanFormulaNice mindef) - , text "but there is no default implementation." ] - -instDeclCtxt1 :: LHsSigType GhcRn -> SDoc -instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - -instDeclCtxt2 :: Type -> SDoc -instDeclCtxt2 dfun_ty - = instDeclCtxt3 cls tys - where - (_,_,cls,tys) = tcSplitDFunTy dfun_ty - -instDeclCtxt3 :: Class -> [Type] -> SDoc -instDeclCtxt3 cls cls_tys - = inst_decl_ctxt (ppr (mkClassPred cls cls_tys)) - -inst_decl_ctxt :: SDoc -> SDoc -inst_decl_ctxt doc = hang (text "In the instance declaration for") - 2 (quotes doc) - -tcATDefault :: SrcSpan - -> TCvSubst - -> NameSet - -> ClassATItem - -> TcM [FamInst] --- ^ Construct default instances for any associated types that --- aren't given a user definition --- Returns [] or singleton -tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) - -- User supplied instances ==> everything is OK - | tyConName fam_tc `elemNameSet` defined_ats - = return [] - - -- No user instance, have defaults ==> instantiate them - -- Example: class C a where { type F a b :: *; type F a b = () } - -- instance C [x] - -- Then we want to generate the decl: type F [x] b = () - | Just (rhs_ty, _loc) <- defs - = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst - (tyConTyVars fam_tc) - rhs' = substTyUnchecked subst' rhs_ty - tcv' = tyCoVarsOfTypesList pat_tys' - (tv', cv') = partition isTyVar tcv' - tvs' = scopedSort tv' - cvs' = scopedSort cv' - ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' - ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs' - fam_tc pat_tys' rhs' - -- NB: no validity check. We check validity of default instances - -- in the class definition. Because type instance arguments cannot - -- be type family applications and cannot be polytypes, the - -- validity check is redundant. - - ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty - , pprCoAxiom axiom ]) - ; fam_inst <- newFamInst SynFamilyInst axiom - ; return [fam_inst] } - - -- No defaults ==> generate a warning - | otherwise -- defs = Nothing - = do { warnMissingAT (tyConName fam_tc) - ; return [] } - where - subst_tv subst tc_tv - | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv - = (subst, ty) - | otherwise - = (extendTvSubst subst tc_tv ty', ty') - where - ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) - -warnMissingAT :: Name -> TcM () -warnMissingAT name - = do { warn <- woptM Opt_WarnMissingMethods - ; traceTc "warn" (ppr name <+> ppr warn) - ; hsc_src <- fmap tcg_src getGblEnv - -- Warn only if -Wmissing-methods AND not a signature - ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile) - (text "No explicit" <+> text "associated type" - <+> text "or default declaration for" - <+> quotes (ppr name)) } diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs deleted file mode 100644 index e69ac2170d..0000000000 --- a/compiler/typecheck/TcDefaults.hs +++ /dev/null @@ -1,110 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[TcDefaults]{Typechecking \tr{default} declarations} --} -{-# LANGUAGE TypeFamilies #-} - -module TcDefaults ( tcDefaults ) where - -import GhcPrelude - -import GHC.Hs -import GHC.Core.Class -import TcRnMonad -import TcEnv -import TcHsType -import TcHsSyn -import TcSimplify -import TcValidity -import TcType -import PrelNames -import GHC.Types.SrcLoc -import Outputable -import FastString -import qualified GHC.LanguageExtensions as LangExt - -tcDefaults :: [LDefaultDecl GhcRn] - -> TcM (Maybe [Type]) -- Defaulting types to heave - -- into Tc monad for later use - -- in Disambig. - -tcDefaults [] - = getDeclaredDefaultTys -- No default declaration, so get the - -- default types from the envt; - -- i.e. use the current ones - -- (the caller will put them back there) - -- It's important not to return defaultDefaultTys here (which - -- we used to do) because in a TH program, tcDefaults [] is called - -- repeatedly, once for each group of declarations between top-level - -- splices. We don't want to carefully set the default types in - -- one group, only for the next group to ignore them and install - -- defaultDefaultTys - -tcDefaults [L _ (DefaultDecl _ [])] - = return (Just []) -- Default declaration specifying no types - -tcDefaults [L locn (DefaultDecl _ mono_tys)] - = setSrcSpan locn $ - addErrCtxt defaultDeclCtxt $ - do { ovl_str <- xoptM LangExt.OverloadedStrings - ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules - ; num_class <- tcLookupClass numClassName - ; deflt_str <- if ovl_str - then mapM tcLookupClass [isStringClassName] - else return [] - ; deflt_interactive <- if ext_deflt - then mapM tcLookupClass interactiveClassNames - else return [] - ; let deflt_clss = num_class : deflt_str ++ deflt_interactive - - ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys - - ; return (Just tau_tys) } - -tcDefaults decls@(L locn (DefaultDecl _ _) : _) - = setSrcSpan locn $ - failWithTc (dupDefaultDeclErr decls) -tcDefaults (L _ (XDefaultDecl nec):_) = noExtCon nec - - -tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type -tc_default_ty deflt_clss hs_ty - = do { (ty, _kind) <- solveEqualities $ - tcLHsType hs_ty - ; ty <- zonkTcTypeToType ty -- establish Type invariants - ; checkValidType DefaultDeclCtxt ty - - -- Check that the type is an instance of at least one of the deflt_clss - ; oks <- mapM (check_instance ty) deflt_clss - ; checkTc (or oks) (badDefaultTy ty deflt_clss) - ; return ty } - -check_instance :: Type -> Class -> TcM Bool - -- Check that ty is an instance of cls - -- We only care about whether it worked or not; return a boolean -check_instance ty cls - = do { (_, success) <- discardErrs $ - askNoErrs $ - simplifyDefault [mkClassPred cls [ty]] - ; return success } - -defaultDeclCtxt :: SDoc -defaultDeclCtxt = text "When checking the types in a default declaration" - -dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc -dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) - = hang (text "Multiple default declarations") - 2 (vcat (map pp dup_things)) - where - pp (L locn (DefaultDecl _ _)) - = text "here was another default declaration" <+> ppr locn - pp (L _ (XDefaultDecl nec)) = noExtCon nec -dupDefaultDeclErr (L _ (XDefaultDecl nec) : _) = noExtCon nec -dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" - -badDefaultTy :: Type -> [Class] -> SDoc -badDefaultTy ty deflt_clss - = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) - 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs deleted file mode 100644 index 506ae1a1fc..0000000000 --- a/compiler/typecheck/TcDeriv.hs +++ /dev/null @@ -1,2305 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Handles @deriving@ clauses on @data@ declarations. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcDeriv ( tcDeriving, DerivInfo(..) ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Driver.Session - -import TcRnMonad -import FamInst -import TcOrigin -import GHC.Core.Predicate -import TcDerivInfer -import TcDerivUtils -import TcValidity( allDistinctTyVars ) -import TcClassDcl( instDeclCtxt3, tcATDefault ) -import TcEnv -import TcGenDeriv -- Deriv stuff -import TcValidity( checkValidInstHead ) -import GHC.Core.InstEnv -import Inst -import GHC.Core.FamInstEnv -import TcHsType -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( pprTyVars ) - -import GHC.Rename.Names ( extendGlobalRdrEnvRn ) -import GHC.Rename.Binds -import GHC.Rename.Env -import GHC.Rename.Source ( addTcgDUs ) -import GHC.Types.Avail - -import GHC.Core.Unify( tcUnifyTy ) -import GHC.Core.Class -import GHC.Core.Type -import ErrUtils -import GHC.Core.DataCon -import Maybes -import GHC.Types.Name.Reader -import GHC.Types.Name -import GHC.Types.Name.Set as NameSet -import GHC.Core.TyCon -import TcType -import GHC.Types.Var as Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import PrelNames -import GHC.Types.SrcLoc -import Util -import Outputable -import FastString -import Bag -import FV (fvVarList, unionFV, mkFVs) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Data.List (partition, find) - -{- -************************************************************************ -* * - Overview -* * -************************************************************************ - -Overall plan -~~~~~~~~~~~~ -1. Convert the decls (i.e. data/newtype deriving clauses, - plus standalone deriving) to [EarlyDerivSpec] - -2. Infer the missing contexts for the InferTheta's - -3. Add the derived bindings, generating InstInfos --} - -data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin]) - | GivenTheta (DerivSpec ThetaType) - -- InferTheta ds => the context for the instance should be inferred - -- In this case ds_theta is the list of all the sets of - -- constraints needed, such as (Eq [a], Eq a), together with a - -- suitable CtLoc to get good error messages. - -- The inference process is to reduce this to a - -- simpler form (e.g. Eq a) - -- - -- GivenTheta ds => the exact context for the instance is supplied - -- by the programmer; it is ds_theta - -- See Note [Inferring the instance context] in TcDerivInfer - -splitEarlyDerivSpec :: [EarlyDerivSpec] - -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType]) -splitEarlyDerivSpec [] = ([],[]) -splitEarlyDerivSpec (InferTheta spec : specs) = - case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs) -splitEarlyDerivSpec (GivenTheta spec : specs) = - case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs) - -instance Outputable EarlyDerivSpec where - ppr (InferTheta spec) = ppr spec <+> text "(Infer)" - ppr (GivenTheta spec) = ppr spec <+> text "(Given)" - -{- -Note [Data decl contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data (RealFloat a) => Complex a = !a :+ !a deriving( Read ) - -We will need an instance decl like: - - instance (Read a, RealFloat a) => Read (Complex a) where - ... - -The RealFloat in the context is because the read method for Complex is bound -to construct a Complex, and doing that requires that the argument type is -in RealFloat. - -But this ain't true for Show, Eq, Ord, etc, since they don't construct -a Complex; they only take them apart. - -Our approach: identify the offending classes, and add the data type -context to the instance decl. The "offending classes" are - - Read, Enum? - -FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that -pattern matching against a constructor from a data type with a context -gives rise to the constraints for that context -- or at least the thinned -version. So now all classes are "offending". - -Note [Newtype deriving] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - class C a b - instance C [a] Char - newtype T = T Char deriving( C [a] ) - -Notice the free 'a' in the deriving. We have to fill this out to - newtype T = T Char deriving( forall a. C [a] ) - -And then translate it to: - instance C [a] Char => C [a] T where ... - -Note [Unused constructors and deriving clauses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #3221. Consider - data T = T1 | T2 deriving( Show ) -Are T1 and T2 unused? Well, no: the deriving clause expands to mention -both of them. So we gather defs/uses from deriving just like anything else. - --} - --- | Stuff needed to process a datatype's `deriving` clauses -data DerivInfo = DerivInfo { di_rep_tc :: TyCon - -- ^ The data tycon for normal datatypes, - -- or the *representation* tycon for data families - , di_scoped_tvs :: ![(Name,TyVar)] - -- ^ Variables that scope over the deriving clause. - , di_clauses :: [LHsDerivingClause GhcRn] - , di_ctxt :: SDoc -- ^ error context - } - -{- - -************************************************************************ -* * -\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}} -* * -************************************************************************ --} - -tcDeriving :: [DerivInfo] -- All `deriving` clauses - -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations - -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn) -tcDeriving deriv_infos deriv_decls - = recoverM (do { g <- getGblEnv - ; return (g, emptyBag, emptyValBindsOut)}) $ - do { -- Fish the "deriving"-related information out of the TcEnv - -- And make the necessary "equations". - early_specs <- makeDerivSpecs deriv_infos deriv_decls - ; traceTc "tcDeriving" (ppr early_specs) - - ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs - ; insts1 <- mapM genInst given_specs - ; insts2 <- mapM genInst infer_specs - - ; dflags <- getDynFlags - - ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2) - ; loc <- getSrcSpanM - ; let (binds, famInsts) = genAuxBinds dflags loc - (unionManyBags deriv_stuff) - - ; let mk_inst_infos1 = map fstOf3 insts1 - ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs - - -- We must put all the derived type family instances (from both - -- infer_specs and given_specs) in the local instance environment - -- before proceeding, or else simplifyInstanceContexts might - -- get stuck if it has to reason about any of those family instances. - -- See Note [Staging of tcDeriving] - ; tcExtendLocalFamInstEnv (bagToList famInsts) $ - -- NB: only call tcExtendLocalFamInstEnv once, as it performs - -- validity checking for all of the family instances you give it. - -- If the family instances have errors, calling it twice will result - -- in duplicate error messages! - - do { - -- the stand-alone derived instances (@inst_infos1@) are used when - -- inferring the contexts for "deriving" clauses' instances - -- (@infer_specs@) - ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $ - simplifyInstanceContexts infer_specs - - ; let mk_inst_infos2 = map fstOf3 insts2 - ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs - ; let inst_infos = inst_infos1 ++ inst_infos2 - - ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds - - ; unless (isEmptyBag inst_info) $ - liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - FormatHaskell - (ddump_deriving inst_info rn_binds famInsts)) - - ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) - getGblEnv - ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs) - ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } } - where - ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn - -> Bag FamInst -- ^ Rep type family instances - -> SDoc - ddump_deriving inst_infos extra_binds repFamInsts - = hang (text "Derived class instances:") - 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) - $$ ppr extra_binds) - $$ hangP "Derived type family instances:" - (vcat (map pprRepTy (bagToList repFamInsts))) - - hangP s x = text "" $$ hang (ptext (sLit s)) 2 x - - -- Apply the suspended computations given by genInst calls. - -- See Note [Staging of tcDeriving] - apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)] - -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs] - apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds)) - --- Prints the representable type family instance -pprRepTy :: FamInst -> SDoc -pprRepTy fi@(FamInst { fi_tys = lhs }) - = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> - equals <+> ppr rhs - where rhs = famInstRHS fi - -renameDeriv :: [InstInfo GhcPs] - -> Bag (LHsBind GhcPs, LSig GhcPs) - -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses) -renameDeriv inst_infos bagBinds - = discardWarnings $ - -- Discard warnings about unused bindings etc - setXOptM LangExt.EmptyCase $ - -- Derived decls (for empty types) can have - -- case x of {} - setXOptM LangExt.ScopedTypeVariables $ - setXOptM LangExt.KindSignatures $ - -- Derived decls (for newtype-deriving) can use ScopedTypeVariables & - -- KindSignatures - setXOptM LangExt.TypeApplications $ - -- GND/DerivingVia uses TypeApplications in generated code - -- (See Note [Newtype-deriving instances] in TcGenDeriv) - unsetXOptM LangExt.RebindableSyntax $ - -- See Note [Avoid RebindableSyntax when deriving] - setXOptM LangExt.TemplateHaskellQuotes $ - -- DeriveLift makes uses of quotes - do { - -- Bring the extra deriving stuff into scope - -- before renaming the instances themselves - ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) - ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds - ; let aux_val_binds = ValBinds noExtField aux_binds (bagToList aux_sigs) - ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds - ; let bndrs = collectHsValBinders rn_aux_lhs - ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ; - ; setEnvs envs $ - do { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs - ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos - ; return (listToBag rn_inst_infos, rn_aux, - dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } } - - where - rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars) - rn_inst_info - inst_info@(InstInfo { iSpec = inst - , iBinds = InstBindings - { ib_binds = binds - , ib_tyvars = tyvars - , ib_pragmas = sigs - , ib_extensions = exts -- Only for type-checking - , ib_derived = sa } }) - = do { (rn_binds, rn_sigs, fvs) <- rnMethodBinds False (is_cls_nm inst) - tyvars binds sigs - ; let binds' = InstBindings { ib_binds = rn_binds - , ib_tyvars = tyvars - , ib_pragmas = rn_sigs - , ib_extensions = exts - , ib_derived = sa } - ; return (inst_info { iBinds = binds' }, fvs) } - -{- -Note [Staging of tcDeriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here's a tricky corner case for deriving (adapted from #2721): - - class C a where - type T a - foo :: a -> T a - - instance C Int where - type T Int = Int - foo = id - - newtype N = N Int deriving C - -This will produce an instance something like this: - - instance C N where - type T N = T Int - foo = coerce (foo :: Int -> T Int) :: N -> T N - -We must be careful in order to typecheck this code. When determining the -context for the instance (in simplifyInstanceContexts), we need to determine -that T N and T Int have the same representation, but to do that, the T N -instance must be in the local family instance environment. Otherwise, GHC -would be unable to conclude that T Int is representationally equivalent to -T Int, and simplifyInstanceContexts would get stuck. - -Previously, tcDeriving would defer adding any derived type family instances to -the instance environment until the very end, which meant that -simplifyInstanceContexts would get called without all the type family instances -it needed in the environment in order to properly simplify instance like -the C N instance above. - -To avoid this scenario, we carefully structure the order of events in -tcDeriving. We first call genInst on the standalone derived instance specs and -the instance specs obtained from deriving clauses. Note that the return type of -genInst is a triple: - - TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name) - -The type family instances are in the BagDerivStuff. The first field of the -triple is a suspended computation which, given an instance context, produces -the rest of the instance. The fact that it is suspended is important, because -right now, we don't have ThetaTypes for the instances that use deriving clauses -(only the standalone-derived ones). - -Now we can collect the type family instances and extend the local instance -environment. At this point, it is safe to run simplifyInstanceContexts on the -deriving-clause instance specs, which gives us the ThetaTypes for the -deriving-clause instances. Now we can feed all the ThetaTypes to the -suspended computations and obtain our InstInfos, at which point -tcDeriving is done. - -An alternative design would be to split up genInst so that the -family instances are generated separately from the InstInfos. But this would -require carving up a lot of the GHC deriving internals to accommodate the -change. On the other hand, we can keep all of the InstInfo and type family -instance logic together in genInst simply by converting genInst to -continuation-returning style, so we opt for that route. - -Note [Why we don't pass rep_tc into deriveTyData] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Down in the bowels of mk_deriv_inst_tys_maybe, we need to convert the fam_tc -back into the rep_tc by means of a lookup. And yet we have the rep_tc right -here! Why look it up again? Answer: it's just easier this way. -We drop some number of arguments from the end of the datatype definition -in deriveTyData. The arguments are dropped from the fam_tc. -This action may drop a *different* number of arguments -passed to the rep_tc, depending on how many free variables, etc., the -dropped patterns have. - -Also, this technique carries over the kind substitution from deriveTyData -nicely. - -Note [Avoid RebindableSyntax when deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The RebindableSyntax extension interacts awkwardly with the derivation of -any stock class whose methods require the use of string literals. The Show -class is a simple example (see #12688): - - {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} - newtype Text = Text String - fromString :: String -> Text - fromString = Text - - data Foo = Foo deriving Show - -This will generate code to the effect of: - - instance Show Foo where - showsPrec _ Foo = showString "Foo" - -But because RebindableSyntax and OverloadedStrings are enabled, the "Foo" -string literal is now of type Text, not String, which showString doesn't -accept! This causes the generated Show instance to fail to typecheck. - -To avoid this kind of scenario, we simply turn off RebindableSyntax entirely -in derived code. - -************************************************************************ -* * - From HsSyn to DerivSpec -* * -************************************************************************ - -@makeDerivSpecs@ fishes around to find the info about needed derived instances. --} - -makeDerivSpecs :: [DerivInfo] - -> [LDerivDecl GhcRn] - -> TcM [EarlyDerivSpec] -makeDerivSpecs deriv_infos deriv_decls - = do { eqns1 <- sequenceA - [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt - | DerivInfo { di_rep_tc = rep_tc - , di_scoped_tvs = scoped_tvs - , di_clauses = clauses - , di_ctxt = err_ctxt } <- deriv_infos - , L _ (HsDerivingClause { deriv_clause_strategy = dcs - , deriv_clause_tys = L _ preds }) - <- clauses - ] - ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls - ; return $ concat eqns1 ++ catMaybes eqns2 } - ------------------------------------------------------------------- --- | Process the derived classes in a single @deriving@ clause. -deriveClause :: TyCon - -> [(Name, TcTyVar)] -- Scoped type variables taken from tcTyConScopedTyVars - -- See Note [Scoped tyvars in a TcTyCon] in types/TyCon - -> Maybe (LDerivStrategy GhcRn) - -> [LHsSigType GhcRn] -> SDoc - -> TcM [EarlyDerivSpec] -deriveClause rep_tc scoped_tvs mb_lderiv_strat deriv_preds err_ctxt - = addErrCtxt err_ctxt $ do - traceTc "deriveClause" $ vcat - [ text "tvs" <+> ppr tvs - , text "scoped_tvs" <+> ppr scoped_tvs - , text "tc" <+> ppr tc - , text "tys" <+> ppr tys - , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat ] - tcExtendNameTyVarEnv scoped_tvs $ do - (mb_lderiv_strat', via_tvs) <- tcDerivStrategy mb_lderiv_strat - tcExtendTyVarEnv via_tvs $ - -- Moreover, when using DerivingVia one can bind type variables in - -- the `via` type as well, so these type variables must also be - -- brought into scope. - mapMaybeM (derivePred tc tys mb_lderiv_strat' via_tvs) deriv_preds - -- After typechecking the `via` type once, we then typecheck all - -- of the classes associated with that `via` type in the - -- `deriving` clause. - -- See also Note [Don't typecheck too much in DerivingVia]. - where - tvs = tyConTyVars rep_tc - (tc, tys) = case tyConFamInstSig_maybe rep_tc of - -- data family: - Just (fam_tc, pats, _) -> (fam_tc, pats) - -- NB: deriveTyData wants the *user-specified* - -- name. See Note [Why we don't pass rep_tc into deriveTyData] - - _ -> (rep_tc, mkTyVarTys tvs) -- datatype - --- | Process a single predicate in a @deriving@ clause. --- --- This returns a 'Maybe' because the user might try to derive 'Typeable', --- which is a no-op nowadays. -derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar] - -> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec) -derivePred tc tys mb_lderiv_strat via_tvs deriv_pred = - -- We carefully set up uses of recoverM to minimize error message - -- cascades. See Note [Recovering from failures in deriving clauses]. - recoverM (pure Nothing) $ - setSrcSpan (getLoc (hsSigType deriv_pred)) $ do - traceTc "derivePred" $ vcat - [ text "tc" <+> ppr tc - , text "tys" <+> ppr tys - , text "deriv_pred" <+> ppr deriv_pred - , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat - , text "via_tvs" <+> ppr via_tvs ] - (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred - when (cls_arg_kinds `lengthIsNot` 1) $ - failWithTc (nonUnaryErr deriv_pred) - let [cls_arg_kind] = cls_arg_kinds - mb_deriv_strat = fmap unLoc mb_lderiv_strat - if (className cls == typeableClassName) - then do warnUselessTypeable - return Nothing - else let deriv_tvs = via_tvs ++ cls_tvs in - Just <$> deriveTyData tc tys mb_deriv_strat - deriv_tvs cls cls_tys cls_arg_kind - -{- -Note [Don't typecheck too much in DerivingVia] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example: - - data D = ... - deriving (A1 t, ..., A20 t) via T t - -GHC used to be engineered such that it would typecheck the `deriving` -clause like so: - -1. Take the first class in the clause (`A1`). -2. Typecheck the `via` type (`T t`) and bring its bound type variables - into scope (`t`). -3. Typecheck the class (`A1`). -4. Move on to the next class (`A2`) and repeat the process until all - classes have been typechecked. - -This algorithm gets the job done most of the time, but it has two notable -flaws. One flaw is that it is wasteful: it requires that `T t` be typechecked -20 different times, once for each class in the `deriving` clause. This is -unnecessary because we only need to typecheck `T t` once in order to get -access to its bound type variable. - -The other issue with this algorithm arises when there are no classes in the -`deriving` clause, like in the following example: - - data D2 = ... - deriving () via Maybe Maybe - -Because there are no classes, the algorithm above will simply do nothing. -As a consequence, GHC will completely miss the fact that `Maybe Maybe` -is ill-kinded nonsense (#16923). - -To address both of these problems, GHC now uses this algorithm instead: - -1. Typecheck the `via` type and bring its bound type variables into scope. -2. Take the first class in the `deriving` clause. -3. Typecheck the class. -4. Move on to the next class and repeat the process until all classes have been - typechecked. - -This algorithm ensures that the `via` type is always typechecked, even if there -are no classes in the `deriving` clause. Moreover, it typecheck the `via` type -/exactly/ once and no more, even if there are multiple classes in the clause. - -Note [Recovering from failures in deriving clauses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider what happens if you run this program (from #10684) without -DeriveGeneric enabled: - - data A = A deriving (Show, Generic) - data B = B A deriving (Show) - -Naturally, you'd expect GHC to give an error to the effect of: - - Can't make a derived instance of `Generic A': - You need -XDeriveGeneric to derive an instance for this class - -And *only* that error, since the other two derived Show instances appear to be -independent of this derived Generic instance. Yet GHC also used to give this -additional error on the program above: - - No instance for (Show A) - arising from the 'deriving' clause of a data type declaration - When deriving the instance for (Show B) - -This was happening because when GHC encountered any error within a single -data type's set of deriving clauses, it would call recoverM and move on -to the next data type's deriving clauses. One unfortunate consequence of -this design is that if A's derived Generic instance failed, its derived -Show instance would be skipped entirely, leading to the "No instance for -(Show A)" error cascade. - -The solution to this problem is to push through uses of recoverM to the -level of the individual derived classes in a particular data type's set of -deriving clauses. That is, if you have: - - newtype C = C D - deriving (E, F, G) - -Then instead of processing instances E through M under the scope of a single -recoverM, as in the following pseudocode: - - recoverM (pure Nothing) $ mapM derivePred [E, F, G] - -We instead use recoverM in each iteration of the loop: - - mapM (recoverM (pure Nothing) . derivePred) [E, F, G] - -And then process each class individually, under its own recoverM scope. That -way, failure to derive one class doesn't cancel out other classes in the -same set of clause-derived classes. --} - ------------------------------------------------------------------- -deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec) --- Process a single standalone deriving declaration --- e.g. deriving instance Show a => Show (T a) --- Rather like tcLocalInstDecl --- --- This returns a Maybe because the user might try to derive Typeable, which is --- a no-op nowadays. -deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) - = setSrcSpan loc $ - addErrCtxt (standaloneCtxt deriv_ty) $ - do { traceTc "Standalone deriving decl for" (ppr deriv_ty) - ; let ctxt = TcOrigin.InstDeclCtxt True - ; traceTc "Deriving strategy (standalone deriving)" $ - vcat [ppr mb_lderiv_strat, ppr deriv_ty] - ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat - ; (cls_tvs, deriv_ctxt, cls, inst_tys) - <- tcExtendTyVarEnv via_tvs $ - tcStandaloneDerivInstType ctxt deriv_ty - ; let mb_deriv_strat = fmap unLoc mb_lderiv_strat - tvs = via_tvs ++ cls_tvs - -- See Note [Unify kinds in deriving] - ; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <- - case mb_deriv_strat of - -- Perform an additional unification with the kind of the `via` - -- type and the result of the previous kind unification. - Just (ViaStrategy via_ty) - -- This unification must be performed on the last element of - -- inst_tys, but we have not yet checked for this property. - -- (This is done later in expectNonNullaryClsArgs). For now, - -- simply do nothing if inst_tys is empty, since - -- expectNonNullaryClsArgs will error later if this - -- is the case. - | Just inst_ty <- lastMaybe inst_tys - -> do - let via_kind = tcTypeKind via_ty - inst_ty_kind = tcTypeKind inst_ty - mb_match = tcUnifyTy inst_ty_kind via_kind - - checkTc (isJust mb_match) - (derivingViaKindErr cls inst_ty_kind - via_ty via_kind) - - let Just kind_subst = mb_match - ki_subst_range = getTCvSubstRangeFVs kind_subst - -- See Note [Unification of two kind variables in deriving] - unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst - && not (v `elemVarSet` ki_subst_range)) - tvs - (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs - (final_deriv_ctxt, final_deriv_ctxt_tys) - = case deriv_ctxt of - InferContext wc -> (InferContext wc, []) - SupplyContext theta -> - let final_theta = substTheta subst theta - in (SupplyContext final_theta, final_theta) - final_inst_tys = substTys subst inst_tys - final_via_ty = substTy subst via_ty - -- See Note [Floating `via` type variables] - final_tvs = tyCoVarsOfTypesWellScoped $ - final_deriv_ctxt_tys ++ final_inst_tys - ++ [final_via_ty] - pure ( final_tvs, final_deriv_ctxt, final_inst_tys - , Just (ViaStrategy final_via_ty) ) - - _ -> pure (tvs, deriv_ctxt, inst_tys, mb_deriv_strat) - ; traceTc "Standalone deriving;" $ vcat - [ text "tvs':" <+> ppr tvs' - , text "mb_deriv_strat':" <+> ppr mb_deriv_strat' - , text "deriv_ctxt':" <+> ppr deriv_ctxt' - , text "cls:" <+> ppr cls - , text "inst_tys':" <+> ppr inst_tys' ] - -- C.f. TcInstDcls.tcLocalInstDecl1 - - ; if className cls == typeableClassName - then do warnUselessTypeable - return Nothing - else Just <$> mkEqnHelp (fmap unLoc overlap_mode) - tvs' cls inst_tys' - deriv_ctxt' mb_deriv_strat' } -deriveStandalone (L _ (XDerivDecl nec)) = noExtCon nec - --- Typecheck the type in a standalone deriving declaration. --- --- This may appear dense, but it's mostly huffing and puffing to recognize --- the special case of a type with an extra-constraints wildcard context, e.g., --- --- deriving instance _ => Eq (Foo a) --- --- If there is such a wildcard, we typecheck this as if we had written --- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@, --- as the 'DerivContext', where loc is the location of the wildcard used for --- error reporting. This indicates that we should infer the context as if we --- were deriving Eq via a deriving clause --- (see Note [Inferring the instance context] in TcDerivInfer). --- --- If there is no wildcard, then proceed as normal, and instead return --- @'SupplyContext' theta@, where theta is the typechecked context. --- --- Note that this will never return @'InferContext' 'Nothing'@, as that can --- only happen with @deriving@ clauses. -tcStandaloneDerivInstType - :: UserTypeCtxt -> LHsSigWcType GhcRn - -> TcM ([TyVar], DerivContext, Class, [Type]) -tcStandaloneDerivInstType ctxt - (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars - , hsib_body = deriv_ty_body })}) - | (tvs, theta, rho) <- splitLHsSigmaTyInvis deriv_ty_body - , L _ [wc_pred] <- theta - , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred - = do dfun_ty <- tcHsClsInstType ctxt $ - HsIB { hsib_ext = vars - , hsib_body - = L (getLoc deriv_ty_body) $ - HsForAllTy { hst_fvf = ForallInvis - , hst_bndrs = tvs - , hst_xforall = noExtField - , hst_body = rho }} - let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty - pure (tvs, InferContext (Just wc_span), cls, inst_tys) - | otherwise - = do dfun_ty <- tcHsClsInstType ctxt deriv_ty - let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty - pure (tvs, SupplyContext theta, cls, inst_tys) - -tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs nec)) - = noExtCon nec -tcStandaloneDerivInstType _ (XHsWildCardBndrs nec) - = noExtCon nec - -warnUselessTypeable :: TcM () -warnUselessTypeable - = do { warn <- woptM Opt_WarnDerivingTypeable - ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable) - $ text "Deriving" <+> quotes (ppr typeableClassName) <+> - text "has no effect: all types now auto-derive Typeable" } - ------------------------------------------------------------------- -deriveTyData :: TyCon -> [Type] -- LHS of data or data instance - -- Can be a data instance, hence [Type] args - -- and in that case the TyCon is the /family/ tycon - -> Maybe (DerivStrategy GhcTc) -- The optional deriving strategy - -> [TyVar] -- The type variables bound by the derived class - -> Class -- The derived class - -> [Type] -- The derived class's arguments - -> Kind -- The function argument in the derived class's kind. - -- (e.g., if `deriving Functor`, this would be - -- `Type -> Type` since - -- `Functor :: (Type -> Type) -> Constraint`) - -> TcM EarlyDerivSpec --- The deriving clause of a data or newtype declaration --- I.e. not standalone deriving -deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind - = do { -- Given data T a b c = ... deriving( C d ), - -- we want to drop type variables from T so that (C d (T a)) is well-kinded - let (arg_kinds, _) = splitFunTys cls_arg_kind - n_args_to_drop = length arg_kinds - n_args_to_keep = length tc_args - n_args_to_drop - -- See Note [tc_args and tycon arity] - (tc_args_to_keep, args_to_drop) - = splitAt n_args_to_keep tc_args - inst_ty_kind = tcTypeKind (mkTyConApp tc tc_args_to_keep) - - -- Match up the kinds, and apply the resulting kind substitution - -- to the types. See Note [Unify kinds in deriving] - -- We are assuming the tycon tyvars and the class tyvars are distinct - mb_match = tcUnifyTy inst_ty_kind cls_arg_kind - enough_args = n_args_to_keep >= 0 - - -- Check that the result really is well-kinded - ; checkTc (enough_args && isJust mb_match) - (derivingKindErr tc cls cls_tys cls_arg_kind enough_args) - - ; let -- Returns a singleton-element list if using ViaStrategy and an - -- empty list otherwise. Useful for free-variable calculations. - deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type] - deriv_strat_tys = foldMap (foldDerivStrategy [] (:[])) - - propagate_subst kind_subst tkvs' cls_tys' tc_args' mb_deriv_strat' - = (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) - where - ki_subst_range = getTCvSubstRangeFVs kind_subst - -- See Note [Unification of two kind variables in deriving] - unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst - && not (v `elemVarSet` ki_subst_range)) - tkvs' - (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs - final_tc_args = substTys subst tc_args' - final_cls_tys = substTys subst cls_tys' - final_mb_deriv_strat = fmap (mapDerivStrategy (substTy subst)) - mb_deriv_strat' - -- See Note [Floating `via` type variables] - final_tkvs = tyCoVarsOfTypesWellScoped $ - final_cls_tys ++ final_tc_args - ++ deriv_strat_tys final_mb_deriv_strat - - ; let tkvs = scopedSort $ fvVarList $ - unionFV (tyCoFVsOfTypes tc_args_to_keep) - (FV.mkFVs deriv_tvs) - Just kind_subst = mb_match - (tkvs', cls_tys', tc_args', mb_deriv_strat') - = propagate_subst kind_subst tkvs cls_tys - tc_args_to_keep mb_deriv_strat - - -- See Note [Unify kinds in deriving] - ; (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <- - case mb_deriv_strat' of - -- Perform an additional unification with the kind of the `via` - -- type and the result of the previous kind unification. - Just (ViaStrategy via_ty) -> do - let via_kind = tcTypeKind via_ty - inst_ty_kind - = tcTypeKind (mkTyConApp tc tc_args') - via_match = tcUnifyTy inst_ty_kind via_kind - - checkTc (isJust via_match) - (derivingViaKindErr cls inst_ty_kind via_ty via_kind) - - let Just via_subst = via_match - pure $ propagate_subst via_subst tkvs' cls_tys' - tc_args' mb_deriv_strat' - - _ -> pure (tkvs', cls_tys', tc_args', mb_deriv_strat') - - ; traceTc "deriveTyData 1" $ vcat - [ ppr final_mb_deriv_strat, pprTyVars deriv_tvs, ppr tc, ppr tc_args - , pprTyVars (tyCoVarsOfTypesList tc_args) - , ppr n_args_to_keep, ppr n_args_to_drop - , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match - , ppr final_tc_args, ppr final_cls_tys ] - - ; traceTc "deriveTyData 2" $ vcat - [ ppr final_tkvs ] - - ; let final_tc_app = mkTyConApp tc final_tc_args - final_cls_args = final_cls_tys ++ [final_tc_app] - ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c) - (derivingEtaErr cls final_cls_tys final_tc_app) - -- Check that - -- (a) The args to drop are all type variables; eg reject: - -- data instance T a Int = .... deriving( Monad ) - -- (b) The args to drop are all *distinct* type variables; eg reject: - -- class C (a :: * -> * -> *) where ... - -- data instance T a a = ... deriving( C ) - -- (c) The type class args, or remaining tycon args, - -- do not mention any of the dropped type variables - -- newtype T a s = ... deriving( ST s ) - -- newtype instance K a a = ... deriving( Monad ) - -- - -- It is vital that the implementation of allDistinctTyVars - -- expand any type synonyms. - -- See Note [Eta-reducing type synonyms] - - ; checkValidInstHead DerivClauseCtxt cls final_cls_args - -- Check that we aren't deriving an instance of a magical - -- type like (~) or Coercible (#14916). - - ; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args - (InferContext Nothing) final_mb_deriv_strat - ; traceTc "deriveTyData 3" (ppr spec) - ; return spec } - - -{- Note [tc_args and tycon arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might wonder if we could use (tyConArity tc) at this point, rather -than (length tc_args). But for data families the two can differ! The -tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which -in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them -from DataFamInstTyCon: - -| DataFamInstTyCon -- See Note [Data type families] - (CoAxiom Unbranched) - TyCon -- The family TyCon - [Type] -- Argument types (mentions the tyConTyVars of this TyCon) - -- No shorter in length than the tyConTyVars of the family TyCon - -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv - -Notice that the arg tys might not be the same as the family tycon arity -(= length tyConTyVars). - -Note [Unify kinds in deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#8534) - data T a b = MkT a deriving( Functor ) - -- where Functor :: (*->*) -> Constraint - -So T :: forall k. * -> k -> *. We want to get - instance Functor (T * (a:*)) where ... -Notice the '*' argument to T. - -Moreover, as well as instantiating T's kind arguments, we may need to instantiate -C's kind args. Consider (#8865): - newtype T a b = MkT (Either a b) deriving( Category ) -where - Category :: forall k. (k -> k -> *) -> Constraint -We need to generate the instance - instance Category * (Either a) where ... -Notice the '*' argument to Category. - -So we need to - * drop arguments from (T a b) to match the number of - arrows in the (last argument of the) class; - * and then *unify* kind of the remaining type against the - expected kind, to figure out how to instantiate C's and T's - kind arguments. - -In the two examples, - * we unify kind-of( T k (a:k) ) ~ kind-of( Functor ) - i.e. (k -> *) ~ (* -> *) to find k:=*. - yielding k:=* - - * we unify kind-of( Either ) ~ kind-of( Category ) - i.e. (* -> * -> *) ~ (k -> k -> k) - yielding k:=* - -Now we get a kind substitution. We then need to: - - 1. Remove the substituted-out kind variables from the quantified kind vars - - 2. Apply the substitution to the kinds of quantified *type* vars - (and extend the substitution to reflect this change) - - 3. Apply that extended substitution to the non-dropped args (types and - kinds) of the type and class - -Forgetting step (2) caused #8893: - data V a = V [a] deriving Functor - data P (x::k->*) (a:k) = P (x a) deriving Functor - data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor - -When deriving Functor for P, we unify k to *, but we then want -an instance $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*)) -and similarly for C. Notice the modified kind of x, both at binding -and occurrence sites. - -This can lead to some surprising results when *visible* kind binder is -unified (in contrast to the above examples, in which only non-visible kind -binders were considered). Consider this example from #11732: - - data T k (a :: k) = MkT deriving Functor - -Since unification yields k:=*, this results in a generated instance of: - - instance Functor (T *) where ... - -which looks odd at first glance, since one might expect the instance head -to be of the form Functor (T k). Indeed, one could envision an alternative -generated instance of: - - instance (k ~ *) => Functor (T k) where - -But this does not typecheck by design: kind equalities are not allowed to be -bound in types, only terms. But in essence, the two instance declarations are -entirely equivalent, since even though (T k) matches any kind k, the only -possibly value for k is *, since anything else is ill-typed. As a result, we can -just as comfortably use (T *). - -Another way of thinking about is: deriving clauses often infer constraints. -For example: - - data S a = S a deriving Eq - -infers an (Eq a) constraint in the derived instance. By analogy, when we -are deriving Functor, we might infer an equality constraint (e.g., k ~ *). -The only distinction is that GHC instantiates equality constraints directly -during the deriving process. - -Another quirk of this design choice manifests when typeclasses have visible -kind parameters. Consider this code (also from #11732): - - class Cat k (cat :: k -> k -> *) where - catId :: cat a a - catComp :: cat b c -> cat a b -> cat a c - - instance Cat * (->) where - catId = id - catComp = (.) - - newtype Fun a b = Fun (a -> b) deriving (Cat k) - -Even though we requested a derived instance of the form (Cat k Fun), the -kind unification will actually generate (Cat * Fun) (i.e., the same thing as if -the user wrote deriving (Cat *)). - -What happens with DerivingVia, when you have yet another type? Consider: - - newtype Foo (a :: Type) = MkFoo (Proxy a) - deriving Functor via Proxy - -As before, we unify the kind of Foo (* -> *) with the kind of the argument to -Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind -(k -> *), which is more general than what we want. So we must additionally -unify (k -> *) with (* -> *). - -Currently, all of this unification is implemented kludgily with the pure -unifier, which is rather tiresome. #14331 lays out a plan for how this -might be made cleaner. - -Note [Unification of two kind variables in deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As a special case of the Note above, it is possible to derive an instance of -a poly-kinded typeclass for a poly-kinded datatype. For example: - - class Category (cat :: k -> k -> *) where - newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category - -This case is surprisingly tricky. To see why, let's write out what instance GHC -will attempt to derive (using -fprint-explicit-kinds syntax): - - instance Category k1 (T k2 c) where ... - -GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst) -that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to -the type variable binder for c, since its kind is (k2 -> k2 -> *). - -We used to accomplish this by doing the following: - - unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs - (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs - -Where all_tkvs contains all kind variables in the class and instance types (in -this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping, -this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped -to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new]. -This is bad, because applying that substitution yields the following instance: - - instance Category k_new (T k1 c) where ... - -In other words, keeping k1 in unmapped_tvks taints the substitution, resulting -in an ill-kinded instance (this caused #11837). - -To prevent this, we need to filter out any variable from all_tkvs which either - -1. Appears in the domain of kind_subst. notElemTCvSubst checks this. -2. Appears in the range of kind_subst. To do this, we compute the free - variable set of the range of kind_subst with getTCvSubstRangeFVs, and check - if a kind variable appears in that set. - -Note [Eta-reducing type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One can instantiate a type in a data family instance with a type synonym that -mentions other type variables: - - type Const a b = a - data family Fam (f :: * -> *) (a :: *) - newtype instance Fam f (Const a f) = Fam (f a) deriving Functor - -It is also possible to define kind synonyms, and they can mention other types in -a datatype declaration. For example, - - type Const a b = a - newtype T f (a :: Const * f) = T (f a) deriving Functor - -When deriving, we need to perform eta-reduction analysis to ensure that none of -the eta-reduced type variables are mentioned elsewhere in the declaration. But -we need to be careful, because if we don't expand through the Const type -synonym, we will mistakenly believe that f is an eta-reduced type variable and -fail to derive Functor, even though the code above is correct (see #11416, -where this was first noticed). For this reason, we expand the type synonyms in -the eta-reduced types before doing any analysis. - -Note [Floating `via` type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When generating a derived instance, it will be of the form: - - instance forall ???. C c_args (D d_args) where ... - -To fill in ???, GHC computes the free variables of `c_args` and `d_args`. -`DerivingVia` adds an extra wrinkle to this formula, since we must also -include the variables bound by the `via` type when computing the binders -used to fill in ???. This might seem strange, since if a `via` type binds -any type variables, then in almost all scenarios it will appear free in -`c_args` or `d_args`. There are certain corner cases where this does not hold, -however, such as in the following example (adapted from #15831): - - newtype Age = MkAge Int - deriving Eq via Const Int a - -In this example, the `via` type binds the type variable `a`, but `a` appears -nowhere in `Eq Age`. Nevertheless, we include it in the generated instance: - - instance forall a. Eq Age where - (==) = coerce @(Const Int a -> Const Int a -> Bool) - @(Age -> Age -> Bool) - (==) - -The use of `forall a` is certainly required here, since the `a` in -`Const Int a` would not be in scope otherwise. This instance is somewhat -strange in that nothing in the instance head `Eq Age` ever determines what `a` -will be, so any code that uses this instance will invariably instantiate `a` -to be `Any`. We refer to this property of `a` as being a "floating" `via` -type variable. Programs with floating `via` type variables are the only known -class of program in which the `via` type quantifies type variables that aren't -mentioned in the instance head in the generated instance. - -Fortunately, the choice to instantiate floating `via` type variables to `Any` -is one that is completely transparent to the user (since the instance will -work as expected regardless of what `a` is instantiated to), so we decide to -permit them. An alternative design would make programs with floating `via` -variables illegal, by requiring that every variable mentioned in the `via` type -is also mentioned in the data header or the derived class. That restriction -would require the user to pick a particular type (the choice does not matter); -for example: - - newtype Age = MkAge Int - -- deriving Eq via Const Int a -- Floating 'a' - deriving Eq via Const Int () -- Choose a=() - deriving Eq via Const Int Any -- Choose a=Any - -No expressiveness would be lost thereby, but stylistically it seems preferable -to allow a type variable to indicate "it doesn't matter". - -Note that by quantifying the `a` in `forall a. Eq Age`, we are deferring the -work of instantiating `a` to `Any` at every use site of the instance. An -alternative approach would be to generate an instance that directly defaulted -to `Any`: - - instance Eq Age where - (==) = coerce @(Const Int Any -> Const Int Any -> Bool) - @(Age -> Age -> Bool) - (==) - -We do not implement this approach since it would require a nontrivial amount -of implementation effort to substitute `Any` for the floating `via` type -variables, and since the end result isn't distinguishable from the former -instance (at least from the user's perspective), the amount of engineering -required to obtain the latter instance just isn't worth it. --} - -mkEqnHelp :: Maybe OverlapMode - -> [TyVar] - -> Class -> [Type] - -> DerivContext - -- SupplyContext => context supplied (standalone deriving) - -- InferContext => context inferred (deriving on data decl, or - -- standalone deriving decl with a wildcard) - -> Maybe (DerivStrategy GhcTc) - -> TcRn EarlyDerivSpec --- Make the EarlyDerivSpec for an instance --- forall tvs. theta => cls (tys ++ [ty]) --- where the 'theta' is optional (that's the Maybe part) --- Assumes that this declaration is well-kinded - -mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do - is_boot <- tcIsHsBootOrSig - when is_boot $ - bale_out (text "Cannot derive instances in hs-boot files" - $+$ text "Write an instance declaration instead") - runReaderT mk_eqn deriv_env - where - deriv_env = DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = cls_args - , denv_ctxt = deriv_ctxt - , denv_strat = deriv_strat } - - bale_out msg = failWithTc $ derivingThingErr False cls cls_args deriv_strat msg - - mk_eqn :: DerivM EarlyDerivSpec - mk_eqn = do - DerivEnv { denv_inst_tys = cls_args - , denv_strat = mb_strat } <- ask - case mb_strat of - Just StockStrategy -> do - (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args - dit <- expectAlgTyConApp cls_tys inst_ty - mk_eqn_stock dit - - Just AnyclassStrategy -> mk_eqn_anyclass - - Just (ViaStrategy via_ty) -> do - (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args - mk_eqn_via cls_tys inst_ty via_ty - - Just NewtypeStrategy -> do - (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args - dit <- expectAlgTyConApp cls_tys inst_ty - unless (isNewTyCon (dit_rep_tc dit)) $ - derivingThingFailWith False gndNonNewtypeErr - mkNewTypeEqn True dit - - Nothing -> mk_eqn_no_strategy - --- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty. --- If so, return @(init inst_tys, last inst_tys)@. --- Otherwise, throw an error message. --- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this --- property is important. -expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type) -expectNonNullaryClsArgs inst_tys = - maybe (derivingThingFailWith False derivingNullaryErr) pure $ - snocView inst_tys - --- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application --- of an algebraic type constructor. If so, return a 'DerivInstTys' consisting --- of @cls_tys@ and the constituent pars of @inst_ty@. --- Otherwise, throw an error message. --- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this --- property is important. -expectAlgTyConApp :: [Type] -- All but the last argument to the class in a - -- derived instance - -> Type -- The last argument to the class in a - -- derived instance - -> DerivM DerivInstTys -expectAlgTyConApp cls_tys inst_ty = do - fam_envs <- lift tcGetFamInstEnvs - case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of - Nothing -> derivingThingFailWith False $ - text "The last argument of the instance must be a" - <+> text "data or newtype application" - Just dit -> do expectNonDataFamTyCon dit - pure dit - --- @expectNonDataFamTyCon dit@ checks if @dit_rep_tc dit@ is a representation --- type constructor for a data family instance, and if not, --- throws an error message. --- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this --- property is important. -expectNonDataFamTyCon :: DerivInstTys -> DerivM () -expectNonDataFamTyCon (DerivInstTys { dit_tc = tc - , dit_tc_args = tc_args - , dit_rep_tc = rep_tc }) = - -- If it's still a data family, the lookup failed; i.e no instance exists - when (isDataFamilyTyCon rep_tc) $ - derivingThingFailWith False $ - text "No family instance for" <+> quotes (pprTypeApp tc tc_args) - -mk_deriv_inst_tys_maybe :: FamInstEnvs - -> [Type] -> Type -> Maybe DerivInstTys -mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty = - fmap lookup $ tcSplitTyConApp_maybe inst_ty - where - lookup :: (TyCon, [Type]) -> DerivInstTys - lookup (tc, tc_args) = - -- Find the instance of a data family - -- Note [Looking up family instances for deriving] - let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args - in DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tc - , dit_tc_args = tc_args - , dit_rep_tc = rep_tc - , dit_rep_tc_args = rep_tc_args } - -{- -Note [Looking up family instances for deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcLookupFamInstExact is an auxiliary lookup wrapper which requires -that looked-up family instances exist. If called with a vanilla -tycon, the old type application is simply returned. - -If we have - data instance F () = ... deriving Eq - data instance F () = ... deriving Eq -then tcLookupFamInstExact will be confused by the two matches; -but that can't happen because tcInstDecls1 doesn't call tcDeriving -if there are any overlaps. - -There are two other things that might go wrong with the lookup. -First, we might see a standalone deriving clause - deriving Eq (F ()) -when there is no data instance F () in scope. - -Note that it's OK to have - data instance F [a] = ... - deriving Eq (F [(a,b)]) -where the match is not exact; the same holds for ordinary data types -with standalone deriving declarations. - -Note [Deriving, type families, and partial applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When there are no type families, it's quite easy: - - newtype S a = MkS [a] - -- :CoS :: S ~ [] -- Eta-reduced - - instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) - instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S - -When type families are involved it's trickier: - - data family T a b - newtype instance T Int a = MkT [a] deriving( Eq, Monad ) - -- :RT is the representation type for (T Int a) - -- :Co:RT :: :RT ~ [] -- Eta-reduced! - -- :CoF:RT a :: T Int a ~ :RT a -- Also eta-reduced! - - instance Eq [a] => Eq (T Int a) -- easy by coercion - -- d1 :: Eq [a] - -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a)) - - instance Monad [] => Monad (T Int) -- only if we can eta reduce??? - -- d1 :: Monad [] - -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT)) - -Note the need for the eta-reduced rule axioms. After all, we can -write it out - instance Monad [] => Monad (T Int) -- only if we can eta reduce??? - return x = MkT [x] - ... etc ... - -See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom - -%************************************************************************ -%* * - Deriving data types -* * -************************************************************************ --} - --- Once the DerivSpecMechanism is known, we can finally produce an --- EarlyDerivSpec from it. -mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec -mk_eqn_from_mechanism mechanism - = do DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys - , denv_ctxt = deriv_ctxt } <- ask - doDerivInstErrorChecks1 mechanism - loc <- lift getSrcSpanM - dfun_name <- lift $ newDFunName cls inst_tys loc - case deriv_ctxt of - InferContext wildcard -> - do { (inferred_constraints, tvs', inst_tys') - <- inferConstraints mechanism - ; return $ InferTheta $ DS - { ds_loc = loc - , ds_name = dfun_name, ds_tvs = tvs' - , ds_cls = cls, ds_tys = inst_tys' - , ds_theta = inferred_constraints - , ds_overlap = overlap_mode - , ds_standalone_wildcard = wildcard - , ds_mechanism = mechanism } } - - SupplyContext theta -> - return $ GivenTheta $ DS - { ds_loc = loc - , ds_name = dfun_name, ds_tvs = tvs - , ds_cls = cls, ds_tys = inst_tys - , ds_theta = theta - , ds_overlap = overlap_mode - , ds_standalone_wildcard = Nothing - , ds_mechanism = mechanism } - -mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class - -> DerivM EarlyDerivSpec -mk_eqn_stock dit@(DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tc - , dit_rep_tc = rep_tc }) - = do DerivEnv { denv_cls = cls - , denv_ctxt = deriv_ctxt } <- ask - dflags <- getDynFlags - case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys - tc rep_tc of - CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ - DerivSpecStock { dsm_stock_dit = dit - , dsm_stock_gen_fn = gen_fn } - StockClassError msg -> derivingThingFailWith False msg - _ -> derivingThingFailWith False (nonStdErr cls) - -mk_eqn_anyclass :: DerivM EarlyDerivSpec -mk_eqn_anyclass - = do dflags <- getDynFlags - case canDeriveAnyClass dflags of - IsValid -> mk_eqn_from_mechanism DerivSpecAnyClass - NotValid msg -> derivingThingFailWith False msg - -mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class - -> Type -- The newtype's representation type - -> DerivM EarlyDerivSpec -mk_eqn_newtype dit rep_ty = - mk_eqn_from_mechanism $ DerivSpecNewtype { dsm_newtype_dit = dit - , dsm_newtype_rep_ty = rep_ty } - -mk_eqn_via :: [Type] -- All arguments to the class besides the last - -> Type -- The last argument to the class - -> Type -- The @via@ type - -> DerivM EarlyDerivSpec -mk_eqn_via cls_tys inst_ty via_ty = - mk_eqn_from_mechanism $ DerivSpecVia { dsm_via_cls_tys = cls_tys - , dsm_via_inst_ty = inst_ty - , dsm_via_ty = via_ty } - --- Derive an instance without a user-requested deriving strategy. This uses --- heuristics to determine which deriving strategy to use. --- See Note [Deriving strategies]. -mk_eqn_no_strategy :: DerivM EarlyDerivSpec -mk_eqn_no_strategy = do - DerivEnv { denv_cls = cls - , denv_inst_tys = cls_args } <- ask - fam_envs <- lift tcGetFamInstEnvs - - -- First, check if the last argument is an application of a type constructor. - -- If not, fall back to DeriveAnyClass. - if | Just (cls_tys, inst_ty) <- snocView cls_args - , Just dit <- mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty - -> if | isNewTyCon (dit_rep_tc dit) - -- We have a dedicated code path for newtypes (see the - -- documentation for mkNewTypeEqn as to why this is the case) - -> mkNewTypeEqn False dit - - | otherwise - -> do -- Otherwise, our only other options are stock or anyclass. - -- If it is stock, we must confirm that the last argument's - -- type constructor is algebraic. - -- See Note [DerivEnv and DerivSpecMechanism] in TcDerivUtils - whenIsJust (hasStockDeriving cls) $ \_ -> - expectNonDataFamTyCon dit - mk_eqn_originative dit - - | otherwise - -> mk_eqn_anyclass - where - -- Use heuristics (checkOriginativeSideConditions) to determine whether - -- stock or anyclass deriving should be used. - mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec - mk_eqn_originative dit@(DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tc - , dit_rep_tc = rep_tc }) = do - DerivEnv { denv_cls = cls - , denv_ctxt = deriv_ctxt } <- ask - dflags <- getDynFlags - - -- See Note [Deriving instances for classes themselves] - let dac_error msg - | isClassTyCon rep_tc - = quotes (ppr tc) <+> text "is a type class," - <+> text "and can only have a derived instance" - $+$ text "if DeriveAnyClass is enabled" - | otherwise - = nonStdErr cls $$ msg - - case checkOriginativeSideConditions dflags deriv_ctxt cls - cls_tys tc rep_tc of - NonDerivableClass msg -> derivingThingFailWith False (dac_error msg) - StockClassError msg -> derivingThingFailWith False msg - CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ - DerivSpecStock { dsm_stock_dit = dit - , dsm_stock_gen_fn = gen_fn } - CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass - -{- -************************************************************************ -* * - Deriving instances for newtypes -* * -************************************************************************ --} - --- Derive an instance for a newtype. We put this logic into its own function --- because --- --- (a) When no explicit deriving strategy is requested, we have special --- heuristics for newtypes to determine which deriving strategy should --- actually be used. See Note [Deriving strategies]. --- (b) We make an effort to give error messages specifically tailored to --- newtypes. -mkNewTypeEqn :: Bool -- Was this instance derived using an explicit @newtype@ - -- deriving strategy? - -> DerivInstTys -> DerivM EarlyDerivSpec -mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tycon - , dit_rep_tc = rep_tycon - , dit_rep_tc_args = rep_tc_args }) --- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... - = do DerivEnv { denv_cls = cls - , denv_ctxt = deriv_ctxt } <- ask - dflags <- getDynFlags - - let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags - deriveAnyClass = xopt LangExt.DeriveAnyClass dflags - - bale_out = derivingThingFailWith newtype_deriving - - non_std = nonStdErr cls - suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's" - <+> text "newtype-deriving extension" - - -- Here is the plan for newtype derivings. We see - -- newtype T a1...an = MkT (t ak+1...an) - -- deriving (.., C s1 .. sm, ...) - -- where t is a type, - -- ak+1...an is a suffix of a1..an, and are all tyvars - -- ak+1...an do not occur free in t, nor in the s1..sm - -- (C s1 ... sm) is a *partial applications* of class C - -- with the last parameter missing - -- (T a1 .. ak) matches the kind of C's last argument - -- (and hence so does t) - -- The latter kind-check has been done by deriveTyData already, - -- and tc_args are already trimmed - -- - -- We generate the instance - -- instance forall ({a1..ak} u fvs(s1..sm)). - -- C s1 .. sm t => C s1 .. sm (T a1...ak) - -- where T a1...ap is the partial application of - -- the LHS of the correct kind and p >= k - -- - -- NB: the variables below are: - -- tc_tvs = [a1, ..., an] - -- tyvars_to_keep = [a1, ..., ak] - -- rep_ty = t ak .. an - -- deriv_tvs = fvs(s1..sm) \ tc_tvs - -- tys = [s1, ..., sm] - -- rep_fn' = t - -- - -- Running example: newtype T s a = MkT (ST s a) deriving( Monad ) - -- We generate the instance - -- instance Monad (ST s) => Monad (T s) where - - nt_eta_arity = newTyConEtadArity rep_tycon - -- For newtype T a b = MkT (S a a b), the TyCon - -- machinery already eta-reduces the representation type, so - -- we know that - -- T a ~ S a a - -- That's convenient here, because we may have to apply - -- it to fewer than its original complement of arguments - - -- Note [Newtype representation] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Need newTyConRhs (*not* a recursive representation finder) - -- to get the representation type. For example - -- newtype B = MkB Int - -- newtype A = MkA B deriving( Num ) - -- We want the Num instance of B, *not* the Num instance of Int, - -- when making the Num instance of A! - rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args - - ------------------------------------------------------------------- - -- Figuring out whether we can only do this newtype-deriving thing - - -- See Note [Determining whether newtype-deriving is appropriate] - might_be_newtype_derivable - = not (non_coercible_class cls) - && eta_ok --- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] - - -- Check that eta reduction is OK - eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity - -- The newtype can be eta-reduced to match the number - -- of type argument actually supplied - -- newtype T a b = MkT (S [a] b) deriving( Monad ) - -- Here the 'b' must be the same in the rep type (S [a] b) - -- And the [a] must not mention 'b'. That's all handled - -- by nt_eta_rity. - - cant_derive_err = ppUnless eta_ok eta_msg - eta_msg = text "cannot eta-reduce the representation type enough" - - MASSERT( cls_tys `lengthIs` (classArity cls - 1) ) - if newtype_strat - then - -- Since the user explicitly asked for GeneralizedNewtypeDeriving, - -- we don't need to perform all of the checks we normally would, - -- such as if the class being derived is known to produce ill-roled - -- coercions (e.g., Traversable), since we can just derive the - -- instance and let it error if need be. - -- See Note [Determining whether newtype-deriving is appropriate] - if eta_ok && newtype_deriving - then mk_eqn_newtype dit rep_inst_ty - else bale_out (cant_derive_err $$ - if newtype_deriving then empty else suggest_gnd) - else - if might_be_newtype_derivable - && ((newtype_deriving && not deriveAnyClass) - || std_class_via_coercible cls) - then mk_eqn_newtype dit rep_inst_ty - else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys - tycon rep_tycon of - StockClassError msg - -- There's a particular corner case where - -- - -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are - -- both enabled at the same time - -- 2. We're deriving a particular stock derivable class - -- (such as Functor) - -- - -- and the previous cases won't catch it. This fixes the bug - -- reported in #10598. - | might_be_newtype_derivable && newtype_deriving - -> mk_eqn_newtype dit rep_inst_ty - -- Otherwise, throw an error for a stock class - | might_be_newtype_derivable && not newtype_deriving - -> bale_out (msg $$ suggest_gnd) - | otherwise - -> bale_out msg - - -- Must use newtype deriving or DeriveAnyClass - NonDerivableClass _msg - -- Too hard, even with newtype deriving - | newtype_deriving -> bale_out cant_derive_err - -- Try newtype deriving! - -- Here we suggest GeneralizedNewtypeDeriving even in cases - -- where it may not be applicable. See #9600. - | otherwise -> bale_out (non_std $$ suggest_gnd) - - -- DeriveAnyClass - CanDeriveAnyClass -> do - -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are - -- enabled, we take the diplomatic approach of defaulting to - -- DeriveAnyClass, but emitting a warning about the choice. - -- See Note [Deriving strategies] - when (newtype_deriving && deriveAnyClass) $ - lift $ whenWOptM Opt_WarnDerivingDefaults $ - addWarnTc (Reason Opt_WarnDerivingDefaults) $ sep - [ text "Both DeriveAnyClass and" - <+> text "GeneralizedNewtypeDeriving are enabled" - , text "Defaulting to the DeriveAnyClass strategy" - <+> text "for instantiating" <+> ppr cls - , text "Use DerivingStrategies to pick" - <+> text "a different strategy" - ] - mk_eqn_from_mechanism DerivSpecAnyClass - -- CanDeriveStock - CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ - DerivSpecStock { dsm_stock_dit = dit - , dsm_stock_gen_fn = gen_fn } - -{- -Note [Recursive newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Newtype deriving works fine, even if the newtype is recursive. -e.g. newtype S1 = S1 [T1 ()] - newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad ) -Remember, too, that type families are currently (conservatively) given -a recursive flag, so this also allows newtype deriving to work -for type famillies. - -We used to exclude recursive types, because we had a rather simple -minded way of generating the instance decl: - newtype A = MkA [A] - instance Eq [A] => Eq A -- Makes typechecker loop! -But now we require a simple context, so it's ok. - -Note [Determining whether newtype-deriving is appropriate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we see - newtype NT = MkNT Foo - deriving C -we have to decide how to perform the deriving. Do we do newtype deriving, -or do we do normal deriving? In general, we prefer to do newtype deriving -wherever possible. So, we try newtype deriving unless there's a glaring -reason not to. - -"Glaring reasons not to" include trying to derive a class for which a -coercion-based instance doesn't make sense. These classes are listed in -the definition of non_coercible_class. They include Show (since it must -show the name of the datatype) and Traversable (since a coercion-based -Traversable instance is ill-roled). - -However, non_coercible_class is ignored if the user explicitly requests -to derive an instance with GeneralizedNewtypeDeriving using the newtype -deriving strategy. In such a scenario, GHC will unquestioningly try to -derive the instance via coercions (even if the final generated code is -ill-roled!). See Note [Deriving strategies]. - -Note that newtype deriving might fail, even after we commit to it. This -is because the derived instance uses `coerce`, which must satisfy its -`Coercible` constraint. This is different than other deriving scenarios, -where we're sure that the resulting instance will type-check. - -Note [GND and associated type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for -classes with associated type families. A general recipe is: - - class C x y z where - type T y z x - op :: x -> [y] -> z - - newtype N a = MkN <rep-type> deriving( C ) - - =====> - - instance C x y <rep-type> => C x y (N a) where - type T y (N a) x = T y <rep-type> x - op = coerce (op :: x -> [y] -> <rep-type>) - -However, we must watch out for three things: - -(a) The class must not contain any data families. If it did, we'd have to - generate a fresh data constructor name for the derived data family - instance, and it's not clear how to do this. - -(b) Each associated type family's type variables must mention the last type - variable of the class. As an example, you wouldn't be able to use GND to - derive an instance of this class: - - class C a b where - type T a - - But you would be able to derive an instance of this class: - - class C a b where - type T b - - The difference is that in the latter T mentions the last parameter of C - (i.e., it mentions b), but the former T does not. If you tried, e.g., - - newtype Foo x = Foo x deriving (C a) - - with the former definition of C, you'd end up with something like this: - - instance C a (Foo x) where - type T a = T ??? - - This T family instance doesn't mention the newtype (or its representation - type) at all, so we disallow such constructions with GND. - -(c) UndecidableInstances might need to be enabled. Here's a case where it is - most definitely necessary: - - class C a where - type T a - newtype Loop = Loop MkLoop deriving C - - =====> - - instance C Loop where - type T Loop = T Loop - - Obviously, T Loop would send the typechecker into a loop. Unfortunately, - you might even need UndecidableInstances even in cases where the - typechecker would be guaranteed to terminate. For example: - - instance C Int where - type C Int = Int - newtype MyInt = MyInt Int deriving C - - =====> - - instance C MyInt where - type T MyInt = T Int - - GHC's termination checker isn't sophisticated enough to conclude that the - definition of T MyInt terminates, so UndecidableInstances is required. - -(d) For the time being, we do not allow the last type variable of the class to - appear in a /kind/ of an associated type family definition. For instance: - - class C a where - type T1 a -- OK - type T2 (x :: a) -- Illegal: a appears in the kind of x - type T3 y :: a -- Illegal: a appears in the kind of (T3 y) - - The reason we disallow this is because our current approach to deriving - associated type family instances—i.e., by unwrapping the newtype's type - constructor as shown above—is ill-equipped to handle the scenario when - the last type variable appears as an implicit argument. In the worst case, - allowing the last variable to appear in a kind can result in improper Core - being generated (see #14728). - - There is hope for this feature being added some day, as one could - conceivably take a newtype axiom (which witnesses a coercion between a - newtype and its representation type) at lift that through each associated - type at the Core level. See #14728, comment:3 for a sketch of how this - might work. Until then, we disallow this featurette wholesale. - -The same criteria apply to DerivingVia. - -************************************************************************ -* * -\subsection[TcDeriv-normal-binds]{Bindings for the various classes} -* * -************************************************************************ - -After all the trouble to figure out the required context for the -derived instance declarations, all that's left is to chug along to -produce them. They will then be shoved into @tcInstDecls2@, which -will do all its usual business. - -There are lots of possibilities for code to generate. Here are -various general remarks. - -PRINCIPLES: -\begin{itemize} -\item -We want derived instances of @Eq@ and @Ord@ (both v common) to be -``you-couldn't-do-better-by-hand'' efficient. - -\item -Deriving @Show@---also pretty common--- should also be reasonable good code. - -\item -Deriving for the other classes isn't that common or that big a deal. -\end{itemize} - -PRAGMATICS: - -\begin{itemize} -\item -Deriving @Ord@ is done mostly with the 1.3 @compare@ method. - -\item -Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too. - -\item -We {\em normally} generate code only for the non-defaulted methods; -there are some exceptions for @Eq@ and (especially) @Ord@... - -\item -Sometimes we use a @_con2tag_<tycon>@ function, which returns a data -constructor's numeric (@Int#@) tag. These are generated by -@gen_tag_n_con_binds@, and the heuristic for deciding if one of -these is around is given by @hasCon2TagFun@. - -The examples under the different sections below will make this -clearer. - -\item -Much less often (really just for deriving @Ix@), we use a -@_tag2con_<tycon>@ function. See the examples. - -\item -We use the renamer!!! Reason: we're supposed to be -producing @LHsBinds Name@ for the methods, but that means -producing correctly-uniquified code on the fly. This is entirely -possible (the @TcM@ monad has a @UniqueSupply@), but it is painful. -So, instead, we produce @MonoBinds RdrName@ then heave 'em through -the renamer. What a great hack! -\end{itemize} --} - --- Generate the InstInfo for the required instance --- plus any auxiliary bindings required -genInst :: DerivSpec theta - -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name]) --- We must use continuation-returning style here to get the order in which we --- typecheck family instances and derived instances right. --- See Note [Staging of tcDeriving] -genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism - , ds_tys = tys, ds_cls = clas, ds_loc = loc - , ds_standalone_wildcard = wildcard }) - = do (meth_binds, meth_sigs, deriv_stuff, unusedNames) - <- set_span_and_ctxt $ - genDerivStuff mechanism loc clas tys tvs - let mk_inst_info theta = set_span_and_ctxt $ do - inst_spec <- newDerivClsInst theta spec - doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism - traceTc "newder" (ppr inst_spec) - return $ InstInfo - { iSpec = inst_spec - , iBinds = InstBindings - { ib_binds = meth_binds - , ib_tyvars = map Var.varName tvs - , ib_pragmas = meth_sigs - , ib_extensions = extensions - , ib_derived = True } } - return (mk_inst_info, deriv_stuff, unusedNames) - where - extensions :: [LangExt.Extension] - extensions - | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism - = [ - -- Both these flags are needed for higher-rank uses of coerce... - LangExt.ImpredicativeTypes, LangExt.RankNTypes - -- ...and this flag is needed to support the instance signatures - -- that bring type variables into scope. - -- See Note [Newtype-deriving instances] in TcGenDeriv - , LangExt.InstanceSigs - ] - | otherwise - = [] - - set_span_and_ctxt :: TcM a -> TcM a - set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys) - --- Checks: --- --- * All of the data constructors for a data type are in scope for a --- standalone-derived instance (for `stock` and `newtype` deriving). --- --- * All of the associated type families of a class are suitable for --- GeneralizedNewtypeDeriving or DerivingVia (for `newtype` and `via` --- deriving). -doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM () -doDerivInstErrorChecks1 mechanism = - case mechanism of - DerivSpecStock{dsm_stock_dit = dit} - -> data_cons_in_scope_check dit - DerivSpecNewtype{dsm_newtype_dit = dit} - -> do atf_coerce_based_error_checks - data_cons_in_scope_check dit - DerivSpecAnyClass{} - -> pure () - DerivSpecVia{} - -> atf_coerce_based_error_checks - where - -- When processing a standalone deriving declaration, check that all of the - -- constructors for the data type are in scope. For instance: - -- - -- import M (T) - -- deriving stock instance Eq T - -- - -- This should be rejected, as the derived Eq instance would need to refer - -- to the constructors for T, which are not in scope. - -- - -- Note that the only strategies that require this check are `stock` and - -- `newtype`. Neither `anyclass` nor `via` require it as the code that they - -- generate does not require using data constructors. - data_cons_in_scope_check :: DerivInstTys -> DerivM () - data_cons_in_scope_check (DerivInstTys { dit_tc = tc - , dit_rep_tc = rep_tc }) = do - standalone <- isStandaloneDeriv - when standalone $ do - let bale_out msg = do err <- derivingThingErrMechanism mechanism msg - lift $ failWithTc err - - rdr_env <- lift getGlobalRdrEnv - let data_con_names = map dataConName (tyConDataCons rep_tc) - hidden_data_cons = not (isWiredIn rep_tc) && - (isAbstractTyCon rep_tc || - any not_in_scope data_con_names) - not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc) - - -- Make sure to also mark the data constructors as used so that GHC won't - -- mistakenly emit -Wunused-imports warnings about them. - lift $ addUsedDataCons rdr_env rep_tc - - unless (not hidden_data_cons) $ - bale_out $ derivingHiddenErr tc - - -- Ensure that a class's associated type variables are suitable for - -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is - -- only required for the `newtype` and `via` strategies. - -- - -- See Note [GND and associated type families] - atf_coerce_based_error_checks :: DerivM () - atf_coerce_based_error_checks = do - cls <- asks denv_cls - let bale_out msg = do err <- derivingThingErrMechanism mechanism msg - lift $ failWithTc err - - cls_tyvars = classTyVars cls - - ats_look_sensible - = -- Check (a) from Note [GND and associated type families] - no_adfs - -- Check (b) from Note [GND and associated type families] - && isNothing at_without_last_cls_tv - -- Check (d) from Note [GND and associated type families] - && isNothing at_last_cls_tv_in_kinds - - (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs - no_adfs = null adf_tcs - -- We cannot newtype-derive data family instances - - at_without_last_cls_tv - = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs - at_last_cls_tv_in_kinds - = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind) - (tyConTyVars tc) - || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs - at_last_cls_tv_in_kind kind - = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind - at_tcs = classATs cls - last_cls_tv = ASSERT( notNull cls_tyvars ) - last cls_tyvars - - cant_derive_err - = vcat [ ppUnless no_adfs adfs_msg - , maybe empty at_without_last_cls_tv_msg - at_without_last_cls_tv - , maybe empty at_last_cls_tv_in_kinds_msg - at_last_cls_tv_in_kinds - ] - adfs_msg = text "the class has associated data types" - at_without_last_cls_tv_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "is not parameterized over the last type variable") - 2 (text "of the class" <+> quotes (ppr cls)) - at_last_cls_tv_in_kinds_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "contains the last type variable") - 2 (text "of the class" <+> quotes (ppr cls) - <+> text "in a kind, which is not (yet) allowed") - unless ats_look_sensible $ bale_out cant_derive_err - -doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan - -> DerivSpecMechanism -> TcM () -doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism - = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst) - ; dflags <- getDynFlags - ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures - ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures - - -- Error if PartialTypeSignatures isn't enabled when a user tries - -- to write @deriving instance _ => Eq (Foo a)@. Or, if that - -- extension is enabled, give a warning if -Wpartial-type-signatures - -- is enabled. - ; case wildcard of - Nothing -> pure () - Just span -> setSrcSpan span $ do - checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion) - warnTc (Reason Opt_WarnPartialTypeSignatures) - wpartial_sigs partial_sig_msg - - -- Check for Generic instances that are derived with an exotic - -- deriving strategy like DAC - -- See Note [Deriving strategies] - ; when (exotic_mechanism && className clas `elem` genericClassNames) $ - do { failIfTc (safeLanguageOn dflags) gen_inst_err - ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } } - where - exotic_mechanism = not $ isDerivSpecStock mechanism - - partial_sig_msg = text "Found type wildcard" <+> quotes (char '_') - <+> text "standing for" <+> quotes (pprTheta theta) - - pts_suggestion - = text "To use the inferred type, enable PartialTypeSignatures" - - gen_inst_err = text "Generic instances can only be derived in" - <+> text "Safe Haskell using the stock strategy." - -derivingThingFailWith :: Bool -- If True, add a snippet about how not even - -- GeneralizedNewtypeDeriving would make this - -- declaration work. This only kicks in when - -- an explicit deriving strategy is not given. - -> SDoc -- The error message - -> DerivM a -derivingThingFailWith newtype_deriving msg = do - err <- derivingThingErrM newtype_deriving msg - lift $ failWithTc err - -genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class - -> [Type] -> [TyVar] - -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]) -genDerivStuff mechanism loc clas inst_tys tyvars - = case mechanism of - -- See Note [Bindings for Generalised Newtype Deriving] - DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty} - -> gen_newtype_or_via rhs_ty - - -- Try a stock deriver - DerivSpecStock { dsm_stock_dit = DerivInstTys{dit_rep_tc = rep_tc} - , dsm_stock_gen_fn = gen_fn } - -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys - pure (binds, [], faminsts, field_names) - - -- Try DeriveAnyClass - DerivSpecAnyClass -> do - let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) - mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env - dflags <- getDynFlags - tyfam_insts <- - -- canDeriveAnyClass should ensure that this code can't be reached - -- unless -XDeriveAnyClass is enabled. - ASSERT2( isValid (canDeriveAnyClass dflags) - , ppr "genDerivStuff: bad derived class" <+> ppr clas ) - mapM (tcATDefault loc mini_subst emptyNameSet) - (classATItems clas) - return ( emptyBag, [] -- No method bindings are needed... - , listToBag (map DerivFamInst (concat tyfam_insts)) - -- ...but we may need to generate binding for associated type - -- family default instances. - -- See Note [DeriveAnyClass and default family instances] - , [] ) - - -- Try DerivingVia - DerivSpecVia{dsm_via_ty = via_ty} - -> gen_newtype_or_via via_ty - where - gen_newtype_or_via ty = do - (binds, sigs, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty - return (binds, sigs, faminsts, []) - -{- -Note [Bindings for Generalised Newtype Deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - class Eq a => C a where - f :: a -> a - newtype N a = MkN [a] deriving( C ) - instance Eq (N a) where ... - -The 'deriving C' clause generates, in effect - instance (C [a], Eq a) => C (N a) where - f = coerce (f :: [a] -> [a]) - -This generates a cast for each method, but allows the superclasse to -be worked out in the usual way. In this case the superclass (Eq (N -a)) will be solved by the explicit Eq (N a) instance. We do *not* -create the superclasses by casting the superclass dictionaries for the -representation type. - -See the paper "Safe zero-cost coercions for Haskell". - -Note [DeriveAnyClass and default family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When a class has a associated type family with a default instance, e.g.: - - class C a where - type T a - type T a = Char - -then there are a couple of scenarios in which a user would expect T a to -default to Char. One is when an instance declaration for C is given without -an implementation for T: - - instance C Int - -Another scenario in which this can occur is when the -XDeriveAnyClass extension -is used: - - data Example = Example deriving (C, Generic) - -In the latter case, we must take care to check if C has any associated type -families with default instances, because -XDeriveAnyClass will never provide -an implementation for them. We "fill in" the default instances using the -tcATDefault function from TcClassDcl (which is also used in TcInstDcls to -handle the empty instance declaration case). - -Note [Deriving strategies] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC has a notion of deriving strategies, which allow the user to explicitly -request which approach to use when deriving an instance (enabled with the --XDerivingStrategies language extension). For more information, refer to the -original issue (#10598) or the associated wiki page: -https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies - -A deriving strategy can be specified in a deriving clause: - - newtype Foo = MkFoo Bar - deriving newtype C - -Or in a standalone deriving declaration: - - deriving anyclass instance C Foo - --XDerivingStrategies also allows the use of multiple deriving clauses per data -declaration so that a user can derive some instance with one deriving strategy -and other instances with another deriving strategy. For example: - - newtype Baz = Baz Quux - deriving (Eq, Ord) - deriving stock (Read, Show) - deriving newtype (Num, Floating) - deriving anyclass C - -Currently, the deriving strategies are: - -* stock: Have GHC implement a "standard" instance for a data type, if possible - (e.g., Eq, Ord, Generic, Data, Functor, etc.) - -* anyclass: Use -XDeriveAnyClass - -* newtype: Use -XGeneralizedNewtypeDeriving - -* via: Use -XDerivingVia - -The latter two strategies (newtype and via) are referred to as the -"coerce-based" strategies, since they generate code that relies on the `coerce` -function. See, for instance, TcDerivInfer.inferConstraintsCoerceBased. - -The former two strategies (stock and anyclass), in contrast, are -referred to as the "originative" strategies, since they create "original" -instances instead of "reusing" old instances (by way of `coerce`). -See, for instance, TcDerivUtils.checkOriginativeSideConditions. - -If an explicit deriving strategy is not given, GHC has an algorithm it uses to -determine which strategy it will actually use. The algorithm is quite long, -so it lives in the Haskell wiki at -https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies -("The deriving strategy resolution algorithm" section). - -Internally, GHC uses the DerivStrategy datatype to denote a user-requested -deriving strategy, and it uses the DerivSpecMechanism datatype to denote what -GHC will use to derive the instance after taking the above steps. In other -words, GHC will always settle on a DerivSpecMechnism, even if the user did not -ask for a particular DerivStrategy (using the algorithm linked to above). - -Note [Deriving instances for classes themselves] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Much of the code in TcDeriv assumes that deriving only works on data types. -But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly -reasonable to do something like this: - - {-# LANGUAGE DeriveAnyClass #-} - class C1 (a :: Constraint) where - class C2 where - deriving instance C1 C2 - -- This is equivalent to `instance C1 C2` - -If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock -deriving), we throw a special error message indicating that DeriveAnyClass is -the only way to go. We don't bother throwing this error if an explicit 'stock' -or 'newtype' keyword is used, since both options have their own perfectly -sensible error messages in the case of the above code (as C1 isn't a stock -derivable class, and C2 isn't a newtype). - -************************************************************************ -* * -\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} -* * -************************************************************************ --} - -nonUnaryErr :: LHsSigType GhcRn -> SDoc -nonUnaryErr ct = quotes (ppr ct) - <+> text "is not a unary constraint, as expected by a deriving clause" - -nonStdErr :: Class -> SDoc -nonStdErr cls = - quotes (ppr cls) - <+> text "is not a stock derivable class (Eq, Show, etc.)" - -gndNonNewtypeErr :: SDoc -gndNonNewtypeErr = - text "GeneralizedNewtypeDeriving cannot be used on non-newtypes" - -derivingNullaryErr :: MsgDoc -derivingNullaryErr = text "Cannot derive instances for nullary classes" - -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc -derivingKindErr tc cls cls_tys cls_kind enough_args - = sep [ hang (text "Cannot derive well-kinded instance of form" - <+> quotes (pprClassPred cls cls_tys - <+> parens (ppr tc <+> text "..."))) - 2 gen1_suggestion - , nest 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind)) - ] - where - gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args - = text "(Perhaps you intended to use PolyKinds)" - | otherwise = Outputable.empty - -derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc -derivingViaKindErr cls cls_kind via_ty via_kind - = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) - 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind) <> char ',' - $+$ text "but" <+> quotes (pprType via_ty) - <+> text "has kind" <+> quotes (pprKind via_kind)) - -derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc -derivingEtaErr cls cls_tys inst_ty - = sep [text "Cannot eta-reduce to an instance of form", - nest 2 (text "instance (...) =>" - <+> pprClassPred cls (cls_tys ++ [inst_ty]))] - -derivingThingErr :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -derivingThingErr newtype_deriving cls cls_args mb_strat why - = derivingThingErr' newtype_deriving cls cls_args mb_strat - (maybe empty derivStrategyName mb_strat) why - -derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc -derivingThingErrM newtype_deriving why - = do DerivEnv { denv_cls = cls - , denv_inst_tys = cls_args - , denv_strat = mb_strat } <- ask - pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why - -derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc -derivingThingErrMechanism mechanism why - = do DerivEnv { denv_cls = cls - , denv_inst_tys = cls_args - , denv_strat = mb_strat } <- ask - pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_args mb_strat - (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why - -derivingThingErr' :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc -derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why - = sep [(hang (text "Can't make a derived instance of") - 2 (quotes (ppr pred) <+> via_mechanism) - $$ nest 2 extra) <> colon, - nest 2 why] - where - strat_used = isJust mb_strat - extra | not strat_used, newtype_deriving - = text "(even with cunning GeneralizedNewtypeDeriving)" - | otherwise = empty - pred = mkClassPred cls cls_args - via_mechanism | strat_used - = text "with the" <+> strat_msg <+> text "strategy" - | otherwise - = empty - -derivingHiddenErr :: TyCon -> SDoc -derivingHiddenErr tc - = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) - 2 (text "so you cannot derive an instance for it") - -standaloneCtxt :: LHsSigWcType GhcRn -> SDoc -standaloneCtxt ty = hang (text "In the stand-alone deriving instance for") - 2 (quotes (ppr ty)) diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs deleted file mode 100644 index 079414d604..0000000000 --- a/compiler/typecheck/TcDerivInfer.hs +++ /dev/null @@ -1,1071 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Functions for inferring (and simplifying) the context for derived instances. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} - -module TcDerivInfer (inferConstraints, simplifyInstanceContexts) where - -#include "HsVersions.h" - -import GhcPrelude - -import Bag -import GHC.Types.Basic -import GHC.Core.Class -import GHC.Core.DataCon -import ErrUtils -import Inst -import Outputable -import Pair -import PrelNames -import TcDerivUtils -import TcEnv -import TcGenDeriv -import TcGenFunctor -import TcGenGenerics -import TcMType -import TcRnMonad -import TcOrigin -import Constraint -import GHC.Core.Predicate -import TcType -import GHC.Core.TyCon -import GHC.Core.TyCo.Ppr (pprTyVars) -import GHC.Core.Type -import TcSimplify -import TcValidity (validDerivPred) -import TcUnify (buildImplicationFor, checkConstraints) -import TysWiredIn (typeToTypeKind) -import GHC.Core.Unify (tcUnifyTy) -import Util -import GHC.Types.Var -import GHC.Types.Var.Set - -import Control.Monad -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ask) -import Data.List (sortBy) -import Data.Maybe - ----------------------- - -inferConstraints :: DerivSpecMechanism - -> DerivM ([ThetaOrigin], [TyVar], [TcType]) --- inferConstraints figures out the constraints needed for the --- instance declaration generated by a 'deriving' clause on a --- data type declaration. It also returns the new in-scope type --- variables and instance types, in case they were changed due to --- the presence of functor-like constraints. --- See Note [Inferring the instance context] - --- e.g. inferConstraints --- C Int (T [a]) -- Class and inst_tys --- :RTList a -- Rep tycon and its arg tys --- where T [a] ~R :RTList a --- --- Generate a sufficiently large set of constraints that typechecking the --- generated method definitions should succeed. This set will be simplified --- before being used in the instance declaration -inferConstraints mechanism - = do { DerivEnv { denv_tvs = tvs - , denv_cls = main_cls - , denv_inst_tys = inst_tys } <- ask - ; wildcard <- isStandaloneWildcardDeriv - ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType]) - infer_constraints = - case mechanism of - DerivSpecStock{dsm_stock_dit = dit} - -> inferConstraintsStock dit - DerivSpecAnyClass - -> infer_constraints_simple inferConstraintsAnyclass - DerivSpecNewtype { dsm_newtype_dit = - DerivInstTys{dit_cls_tys = cls_tys} - , dsm_newtype_rep_ty = rep_ty } - -> infer_constraints_simple $ - inferConstraintsCoerceBased cls_tys rep_ty - DerivSpecVia { dsm_via_cls_tys = cls_tys - , dsm_via_ty = via_ty } - -> infer_constraints_simple $ - inferConstraintsCoerceBased cls_tys via_ty - - -- Most deriving strategies do not need to do anything special to - -- the type variables and arguments to the class in the derived - -- instance, so they can pass through unchanged. The exception to - -- this rule is stock deriving. See - -- Note [Inferring the instance context]. - infer_constraints_simple - :: DerivM [ThetaOrigin] - -> DerivM ([ThetaOrigin], [TyVar], [TcType]) - infer_constraints_simple infer_thetas = do - thetas <- infer_thetas - pure (thetas, tvs, inst_tys) - - -- Constraints arising from superclasses - -- See Note [Superclasses of derived instance] - cls_tvs = classTyVars main_cls - sc_constraints = ASSERT2( equalLength cls_tvs inst_tys - , ppr main_cls <+> ppr inst_tys ) - [ mkThetaOrigin (mkDerivOrigin wildcard) - TypeLevel [] [] [] $ - substTheta cls_subst (classSCTheta main_cls) ] - cls_subst = ASSERT( equalLength cls_tvs inst_tys ) - zipTvSubst cls_tvs inst_tys - - ; (inferred_constraints, tvs', inst_tys') <- infer_constraints - ; lift $ traceTc "inferConstraints" $ vcat - [ ppr main_cls <+> ppr inst_tys' - , ppr inferred_constraints - ] - ; return ( sc_constraints ++ inferred_constraints - , tvs', inst_tys' ) } - --- | Like 'inferConstraints', but used only in the case of the @stock@ deriving --- strategy. The constraints are inferred by inspecting the fields of each data --- constructor. In this example: --- --- > data Foo = MkFoo Int Char deriving Show --- --- We would infer the following constraints ('ThetaOrigin's): --- --- > (Show Int, Show Char) --- --- Note that this function also returns the type variables ('TyVar's) and --- class arguments ('TcType's) for the resulting instance. This is because --- when deriving 'Functor'-like classes, we must sometimes perform kind --- substitutions to ensure the resulting instance is well kinded, which may --- affect the type variables and class arguments. In this example: --- --- > newtype Compose (f :: k -> Type) (g :: Type -> k) (a :: Type) = --- > Compose (f (g a)) deriving stock Functor --- --- We must unify @k@ with @Type@ in order for the resulting 'Functor' instance --- to be well kinded, so we return @[]@/@[Type, f, g]@ for the --- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@. --- See Note [Inferring the instance context]. -inferConstraintsStock :: DerivInstTys - -> DerivM ([ThetaOrigin], [TyVar], [TcType]) -inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys - , dit_tc = tc - , dit_tc_args = tc_args - , dit_rep_tc = rep_tc - , dit_rep_tc_args = rep_tc_args }) - = do DerivEnv { denv_tvs = tvs - , denv_cls = main_cls - , denv_inst_tys = inst_tys } <- ask - wildcard <- isStandaloneWildcardDeriv - - let inst_ty = mkTyConApp tc tc_args - tc_binders = tyConBinders rep_tc - choose_level bndr - | isNamedTyConBinder bndr = KindLevel - | otherwise = TypeLevel - t_or_ks = map choose_level tc_binders ++ repeat TypeLevel - -- want to report *kind* errors when possible - - -- Constraints arising from the arguments of each constructor - con_arg_constraints - :: (CtOrigin -> TypeOrKind - -> Type - -> [([PredOrigin], Maybe TCvSubst)]) - -> ([ThetaOrigin], [TyVar], [TcType]) - con_arg_constraints get_arg_constraints - = let (predss, mbSubsts) = unzip - [ preds_and_mbSubst - | data_con <- tyConDataCons rep_tc - , (arg_n, arg_t_or_k, arg_ty) - <- zip3 [1..] t_or_ks $ - dataConInstOrigArgTys data_con all_rep_tc_args - -- No constraints for unlifted types - -- See Note [Deriving and unboxed types] - , not (isUnliftedType arg_ty) - , let orig = DerivOriginDC data_con arg_n wildcard - , preds_and_mbSubst - <- get_arg_constraints orig arg_t_or_k arg_ty - ] - preds = concat predss - -- If the constraints require a subtype to be of kind - -- (* -> *) (which is the case for functor-like - -- constraints), then we explicitly unify the subtype's - -- kinds with (* -> *). - -- See Note [Inferring the instance context] - subst = foldl' composeTCvSubst - emptyTCvSubst (catMaybes mbSubsts) - unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst - && not (v `isInScope` subst)) tvs - (subst', _) = substTyVarBndrs subst unmapped_tvs - preds' = map (substPredOrigin subst') preds - inst_tys' = substTys subst' inst_tys - tvs' = tyCoVarsOfTypesWellScoped inst_tys' - in ([mkThetaOriginFromPreds preds'], tvs', inst_tys') - - is_generic = main_cls `hasKey` genClassKey - is_generic1 = main_cls `hasKey` gen1ClassKey - -- is_functor_like: see Note [Inferring the instance context] - is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind - || is_generic1 - - get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type - -> [([PredOrigin], Maybe TCvSubst)] - get_gen1_constraints functor_cls orig t_or_k ty - = mk_functor_like_constraints orig t_or_k functor_cls $ - get_gen1_constrained_tys last_tv ty - - get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type - -> [([PredOrigin], Maybe TCvSubst)] - get_std_constrained_tys orig t_or_k ty - | is_functor_like - = mk_functor_like_constraints orig t_or_k main_cls $ - deepSubtypesContaining last_tv ty - | otherwise - = [( [mk_cls_pred orig t_or_k main_cls ty] - , Nothing )] - - mk_functor_like_constraints :: CtOrigin -> TypeOrKind - -> Class -> [Type] - -> [([PredOrigin], Maybe TCvSubst)] - -- 'cls' is usually main_cls (Functor or Traversable etc), but if - -- main_cls = Generic1, then 'cls' can be Functor; see - -- get_gen1_constraints - -- - -- For each type, generate two constraints, - -- [cls ty, kind(ty) ~ (*->*)], and a kind substitution that results - -- from unifying kind(ty) with * -> *. If the unification is - -- successful, it will ensure that the resulting instance is well - -- kinded. If not, the second constraint will result in an error - -- message which points out the kind mismatch. - -- See Note [Inferring the instance context] - mk_functor_like_constraints orig t_or_k cls - = map $ \ty -> let ki = tcTypeKind ty in - ( [ mk_cls_pred orig t_or_k cls ty - , mkPredOrigin orig KindLevel - (mkPrimEqPred ki typeToTypeKind) ] - , tcUnifyTy ki typeToTypeKind - ) - - rep_tc_tvs = tyConTyVars rep_tc - last_tv = last rep_tc_tvs - -- When we first gather up the constraints to solve, most of them - -- contain rep_tc_tvs, i.e., the type variables from the derived - -- datatype's type constructor. We don't want these type variables - -- to appear in the final instance declaration, so we must - -- substitute each type variable with its counterpart in the derived - -- instance. rep_tc_args lists each of these counterpart types in - -- the same order as the type variables. - all_rep_tc_args - = rep_tc_args ++ map mkTyVarTy - (drop (length rep_tc_args) rep_tc_tvs) - - -- Stupid constraints - stupid_constraints - = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $ - substTheta tc_subst (tyConStupidTheta rep_tc) ] - tc_subst = -- See the comment with all_rep_tc_args for an - -- explanation of this assertion - ASSERT( equalLength rep_tc_tvs all_rep_tc_args ) - zipTvSubst rep_tc_tvs all_rep_tc_args - - -- Extra Data constraints - -- The Data class (only) requires that for - -- instance (...) => Data (T t1 t2) - -- IF t1:*, t2:* - -- THEN (Data t1, Data t2) are among the (...) constraints - -- Reason: when the IF holds, we generate a method - -- dataCast2 f = gcast2 f - -- and we need the Data constraints to typecheck the method - extra_constraints = [mkThetaOriginFromPreds constrs] - where - constrs - | main_cls `hasKey` dataClassKey - , all (isLiftedTypeKind . tcTypeKind) rep_tc_args - = [ mk_cls_pred deriv_origin t_or_k main_cls ty - | (t_or_k, ty) <- zip t_or_ks rep_tc_args] - | otherwise - = [] - - mk_cls_pred orig t_or_k cls ty - -- Don't forget to apply to cls_tys' too - = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty])) - cls_tys' | is_generic1 = [] - -- In the awkward Generic1 case, cls_tys' should be - -- empty, since we are applying the class Functor. - - | otherwise = cls_tys - - deriv_origin = mkDerivOrigin wildcard - - if -- Generic constraints are easy - | is_generic - -> return ([], tvs, inst_tys) - - -- Generic1 needs Functor - -- See Note [Getting base classes] - | is_generic1 - -> ASSERT( rep_tc_tvs `lengthExceeds` 0 ) - -- Generic1 has a single kind variable - ASSERT( cls_tys `lengthIs` 1 ) - do { functorClass <- lift $ tcLookupClass functorClassName - ; pure $ con_arg_constraints - $ get_gen1_constraints functorClass } - - -- The others are a bit more complicated - | otherwise - -> -- See the comment with all_rep_tc_args for an explanation of - -- this assertion - ASSERT2( equalLength rep_tc_tvs all_rep_tc_args - , ppr main_cls <+> ppr rep_tc - $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args ) - do { let (arg_constraints, tvs', inst_tys') - = con_arg_constraints get_std_constrained_tys - ; lift $ traceTc "inferConstraintsStock" $ vcat - [ ppr main_cls <+> ppr inst_tys' - , ppr arg_constraints - ] - ; return ( stupid_constraints ++ extra_constraints - ++ arg_constraints - , tvs', inst_tys') } - --- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@, --- which gathers its constraints based on the type signatures of the class's --- methods instead of the types of the data constructor's field. --- --- See Note [Gathering and simplifying constraints for DeriveAnyClass] --- for an explanation of how these constraints are used to determine the --- derived instance context. -inferConstraintsAnyclass :: DerivM [ThetaOrigin] -inferConstraintsAnyclass - = do { DerivEnv { denv_cls = cls - , denv_inst_tys = inst_tys } <- ask - ; wildcard <- isStandaloneWildcardDeriv - - ; let gen_dms = [ (sel_id, dm_ty) - | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ] - - cls_tvs = classTyVars cls - - do_one_meth :: (Id, Type) -> TcM ThetaOrigin - -- (Id,Type) are the selector Id and the generic default method type - -- NB: the latter is /not/ quantified over the class variables - -- See Note [Gathering and simplifying constraints for DeriveAnyClass] - do_one_meth (sel_id, gen_dm_ty) - = do { let (sel_tvs, _cls_pred, meth_ty) - = tcSplitMethodTy (varType sel_id) - meth_ty' = substTyWith sel_tvs inst_tys meth_ty - (meth_tvs, meth_theta, meth_tau) - = tcSplitNestedSigmaTys meth_ty' - - gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty - (dm_tvs, dm_theta, dm_tau) - = tcSplitNestedSigmaTys gen_dm_ty' - tau_eq = mkPrimEqPred meth_tau dm_tau - ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel - meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) } - - ; theta_origins <- lift $ mapM do_one_meth gen_dms - ; return theta_origins } - --- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and --- @DerivingVia@. Since both strategies generate code involving 'coerce', the --- inferred constraints set up the scaffolding needed to typecheck those uses --- of 'coerce'. In this example: --- --- > newtype Age = MkAge Int deriving newtype Num --- --- We would infer the following constraints ('ThetaOrigin's): --- --- > (Num Int, Coercible Age Int) -inferConstraintsCoerceBased :: [Type] -> Type - -> DerivM [ThetaOrigin] -inferConstraintsCoerceBased cls_tys rep_ty = do - DerivEnv { denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys } <- ask - sa_wildcard <- isStandaloneWildcardDeriv - let -- The following functions are polymorphic over the representation - -- type, since we might either give it the underlying type of a - -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type - -- (for DerivingVia). - rep_tys ty = cls_tys ++ [ty] - rep_pred ty = mkClassPred cls (rep_tys ty) - rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty) - -- rep_pred is the representation dictionary, from where - -- we are going to get all the methods for the final - -- dictionary - deriv_origin = mkDerivOrigin sa_wildcard - - -- Next we collect constraints for the class methods - -- If there are no methods, we don't need any constraints - -- Otherwise we need (C rep_ty), for the representation methods, - -- and constraints to coerce each individual method - meth_preds :: Type -> [PredOrigin] - meth_preds ty - | null meths = [] -- No methods => no constraints - -- (#12814) - | otherwise = rep_pred_o ty : coercible_constraints ty - meths = classMethods cls - coercible_constraints ty - = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard) - TypeLevel (mkReprPrimEqPred t1 t2) - | meth <- meths - , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs - inst_tys ty meth ] - - all_thetas :: Type -> [ThetaOrigin] - all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty] - - pure (all_thetas rep_ty) - -{- Note [Inferring the instance context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are two sorts of 'deriving', as represented by the two constructors -for DerivContext: - - * InferContext mb_wildcard: This can either be: - - The deriving clause for a data type. - (e.g, data T a = T1 a deriving( Eq )) - In this case, mb_wildcard = Nothing. - - A standalone declaration with an extra-constraints wildcard - (e.g., deriving instance _ => Eq (Foo a)) - In this case, mb_wildcard = Just loc, where loc is the location - of the extra-constraints wildcard. - - Here we must infer an instance context, - and generate instance declaration - instance Eq a => Eq (T a) where ... - - * SupplyContext theta: standalone deriving - deriving instance Eq a => Eq (T a) - Here we only need to fill in the bindings; - the instance context (theta) is user-supplied - -For the InferContext case, we must figure out the -instance context (inferConstraintsStock). Suppose we are inferring -the instance context for - C t1 .. tn (T s1 .. sm) -There are two cases - - * (T s1 .. sm) :: * (the normal case) - Then we behave like Eq and guess (C t1 .. tn t) - for each data constructor arg of type t. More - details below. - - * (T s1 .. sm) :: * -> * (the functor-like case) - Then we behave like Functor. - -In both cases we produce a bunch of un-simplified constraints -and them simplify them in simplifyInstanceContexts; see -Note [Simplifying the instance context]. - -In the functor-like case, we may need to unify some kind variables with * in -order for the generated instance to be well-kinded. An example from -#10524: - - newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) - = Compose (f (g a)) deriving Functor - -Earlier in the deriving pipeline, GHC unifies the kind of Compose f g -(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this -alone isn't enough, since k2 wasn't unified with *: - - instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) => - Functor (Compose f g) where ... - -The two Functor constraints are ill-kinded. To ensure this doesn't happen, we: - - 1. Collect all of a datatype's subtypes which require functor-like - constraints. - 2. For each subtype, create a substitution by unifying the subtype's kind - with (* -> *). - 3. Compose all the substitutions into one, then apply that substitution to - all of the in-scope type variables and the instance types. - -Note [Getting base classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Functor and Typeable are defined in package 'base', and that is not available -when compiling 'ghc-prim'. So we must be careful that 'deriving' for stuff in -ghc-prim does not use Functor or Typeable implicitly via these lookups. - -Note [Deriving and unboxed types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have some special hacks to support things like - data T = MkT Int# deriving ( Show ) - -Specifically, we use TcGenDeriv.box to box the Int# into an Int -(which we know how to show), and append a '#'. Parentheses are not required -for unboxed values (`MkT -3#` is a valid expression). - -Note [Superclasses of derived instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, a derived instance decl needs the superclasses of the derived -class too. So if we have - data T a = ...deriving( Ord ) -then the initial context for Ord (T a) should include Eq (T a). Often this is -redundant; we'll also generate an Ord constraint for each constructor argument, -and that will probably generate enough constraints to make the Eq (T a) constraint -be satisfied too. But not always; consider: - - data S a = S - instance Eq (S a) - instance Ord (S a) - - data T a = MkT (S a) deriving( Ord ) - instance Num a => Eq (T a) - -The derived instance for (Ord (T a)) must have a (Num a) constraint! -Similarly consider: - data T a = MkT deriving( Data ) -Here there *is* no argument field, but we must nevertheless generate -a context for the Data instances: - instance Typeable a => Data (T a) where ... - - -************************************************************************ -* * - Finding the fixed point of deriving equations -* * -************************************************************************ - -Note [Simplifying the instance context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T a b = C1 (Foo a) (Bar b) - | C2 Int (T b a) - | C3 (T a a) - deriving (Eq) - -We want to come up with an instance declaration of the form - - instance (Ping a, Pong b, ...) => Eq (T a b) where - x == y = ... - -It is pretty easy, albeit tedious, to fill in the code "...". The -trick is to figure out what the context for the instance decl is, -namely Ping, Pong and friends. - -Let's call the context reqd for the T instance of class C at types -(a,b, ...) C (T a b). Thus: - - Eq (T a b) = (Ping a, Pong b, ...) - -Now we can get a (recursive) equation from the data decl. This part -is done by inferConstraintsStock. - - Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 - u Eq (T b a) u Eq Int -- From C2 - u Eq (T a a) -- From C3 - - -Foo and Bar may have explicit instances for Eq, in which case we can -just substitute for them. Alternatively, either or both may have -their Eq instances given by deriving clauses, in which case they -form part of the system of equations. - -Now all we need do is simplify and solve the equations, iterating to -find the least fixpoint. This is done by simplifyInstanceConstraints. -Notice that the order of the arguments can -switch around, as here in the recursive calls to T. - -Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b. - -We start with: - - Eq (T a b) = {} -- The empty set - -Next iteration: - Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 - u Eq (T b a) u Eq Int -- From C2 - u Eq (T a a) -- From C3 - - After simplification: - = Eq a u Ping b u {} u {} u {} - = Eq a u Ping b - -Next iteration: - - Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 - u Eq (T b a) u Eq Int -- From C2 - u Eq (T a a) -- From C3 - - After simplification: - = Eq a u Ping b - u (Eq b u Ping a) - u (Eq a u Ping a) - - = Eq a u Ping b u Eq b u Ping a - -The next iteration gives the same result, so this is the fixpoint. We -need to make a canonical form of the RHS to ensure convergence. We do -this by simplifying the RHS to a form in which - - - the classes constrain only tyvars - - the list is sorted by tyvar (major key) and then class (minor key) - - no duplicates, of course - -Note [Deterministic simplifyInstanceContexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting -with nonDetCmpType puts the returned lists in a nondeterministic order. -If we were to return them, we'd get class constraints in -nondeterministic order. - -Consider: - - data ADT a b = Z a b deriving Eq - -The generated code could be either: - - instance (Eq a, Eq b) => Eq (Z a b) where - -Or: - - instance (Eq b, Eq a) => Eq (Z a b) where - -To prevent the order from being nondeterministic we only -canonicalize when comparing and return them in the same order as -simplifyDeriv returned them. -See also Note [nonDetCmpType nondeterminism] --} - - -simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]] - -> TcM [DerivSpec ThetaType] --- Used only for deriving clauses or standalone deriving with an --- extra-constraints wildcard (InferContext) --- See Note [Simplifying the instance context] - -simplifyInstanceContexts [] = return [] - -simplifyInstanceContexts infer_specs - = do { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs) - ; iterate_deriv 1 initial_solutions } - where - ------------------------------------------------------------------ - -- The initial solutions for the equations claim that each - -- instance has an empty context; this solution is certainly - -- in canonical form. - initial_solutions :: [ThetaType] - initial_solutions = [ [] | _ <- infer_specs ] - - ------------------------------------------------------------------ - -- iterate_deriv calculates the next batch of solutions, - -- compares it with the current one; finishes if they are the - -- same, otherwise recurses with the new solutions. - -- It fails if any iteration fails - iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType] - iterate_deriv n current_solns - | n > 20 -- Looks as if we are in an infinite loop - -- This can happen if we have -XUndecidableInstances - -- (See TcSimplify.tcSimplifyDeriv.) - = pprPanic "solveDerivEqns: probable loop" - (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns) - | otherwise - = do { -- Extend the inst info from the explicit instance decls - -- with the current set of solutions, and simplify each RHS - inst_specs <- zipWithM newDerivClsInst current_solns infer_specs - ; new_solns <- checkNoErrs $ - extendLocalInstEnv inst_specs $ - mapM gen_soln infer_specs - - ; if (current_solns `eqSolution` new_solns) then - return [ spec { ds_theta = soln } - | (spec, soln) <- zip infer_specs current_solns ] - else - iterate_deriv (n+1) new_solns } - - eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b) - -- Canonicalise for comparison - -- See Note [Deterministic simplifyInstanceContexts] - canSolution = map (sortBy nonDetCmpType) - ------------------------------------------------------------------ - gen_soln :: DerivSpec [ThetaOrigin] -> TcM ThetaType - gen_soln (DS { ds_loc = loc, ds_tvs = tyvars - , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) - = setSrcSpan loc $ - addErrCtxt (derivInstCtxt the_pred) $ - do { theta <- simplifyDeriv the_pred tyvars deriv_rhs - -- checkValidInstance tyvars theta clas inst_tys - -- Not necessary; see Note [Exotic derived instance contexts] - - ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta) - -- Claim: the result instance declaration is guaranteed valid - -- Hence no need to call: - -- checkValidInstance tyvars theta clas inst_tys - ; return theta } - where - the_pred = mkClassPred clas inst_tys - -derivInstCtxt :: PredType -> MsgDoc -derivInstCtxt pred - = text "When deriving the instance for" <+> parens (ppr pred) - -{- -*********************************************************************************** -* * -* Simplify derived constraints -* * -*********************************************************************************** --} - --- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much --- as possible. Fail if not possible. -simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are - -- deriving. Only used for SkolemInfo. - -> [TyVar] -- ^ The tyvars bound by @inst_ty@. - -> [ThetaOrigin] -- ^ Given and wanted constraints - -> TcM ThetaType -- ^ Needed constraints (after simplification), - -- i.e. @['PredType']@. -simplifyDeriv pred tvs thetas - = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize - -- The constraint solving machinery - -- expects *TcTyVars* not TyVars. - -- We use *non-overlappable* (vanilla) skolems - -- See Note [Overlap and deriving] - - ; let skol_set = mkVarSet tvs_skols - skol_info = DerivSkol pred - doc = text "deriving" <+> parens (ppr pred) - - mk_given_ev :: PredType -> TcM EvVar - mk_given_ev given = - let given_pred = substTy skol_subst given - in newEvVar given_pred - - emit_wanted_constraints :: [TyVar] -> [PredOrigin] -> TcM () - emit_wanted_constraints metas_to_be preds - = do { -- We instantiate metas_to_be with fresh meta type - -- variables. Currently, these can only be type variables - -- quantified in generic default type signatures. - -- See Note [Gathering and simplifying constraints for - -- DeriveAnyClass] - (meta_subst, _meta_tvs) <- newMetaTyVars metas_to_be - - -- Now make a constraint for each of the instantiated predicates - ; let wanted_subst = skol_subst `unionTCvSubst` meta_subst - mk_wanted_ct (PredOrigin wanted orig t_or_k) - = do { ev <- newWanted orig (Just t_or_k) $ - substTyUnchecked wanted_subst wanted - ; return (mkNonCanonical ev) } - ; cts <- mapM mk_wanted_ct preds - - -- And emit them into the monad - ; emitSimples (listToCts cts) } - - -- Create the implications we need to solve. For stock and newtype - -- deriving, these implication constraints will be simple class - -- constraints like (C a, Ord b). - -- But with DeriveAnyClass, we make an implication constraint. - -- See Note [Gathering and simplifying constraints for DeriveAnyClass] - mk_wanteds :: ThetaOrigin -> TcM WantedConstraints - mk_wanteds (ThetaOrigin { to_anyclass_skols = ac_skols - , to_anyclass_metas = ac_metas - , to_anyclass_givens = ac_givens - , to_wanted_origins = preds }) - = do { ac_given_evs <- mapM mk_given_ev ac_givens - ; (_, wanteds) - <- captureConstraints $ - checkConstraints skol_info ac_skols ac_given_evs $ - -- The checkConstraints bumps the TcLevel, and - -- wraps the wanted constraints in an implication, - -- when (but only when) necessary - emit_wanted_constraints ac_metas preds - ; pure wanteds } - - -- See [STEP DAC BUILD] - -- Generate the implication constraints, one for each method, to solve - -- with the skolemized variables. Start "one level down" because - -- we are going to wrap the result in an implication with tvs_skols, - -- in step [DAC RESIDUAL] - ; (tc_lvl, wanteds) <- pushTcLevelM $ - mapM mk_wanteds thetas - - ; traceTc "simplifyDeriv inputs" $ - vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ] - - -- See [STEP DAC SOLVE] - -- Simplify the constraints, starting at the same level at which - -- they are generated (c.f. the call to runTcSWithEvBinds in - -- simplifyInfer) - ; solved_wanteds <- setTcLevel tc_lvl $ - runTcSDeriveds $ - solveWantedsAndDrop $ - unionsWC wanteds - - -- It's not yet zonked! Obviously zonk it before peering at it - ; solved_wanteds <- zonkWC solved_wanteds - - -- See [STEP DAC HOIST] - -- Split the resulting constraints into bad and good constraints, - -- building an @unsolved :: WantedConstraints@ representing all - -- the constraints we can't just shunt to the predicates. - -- See Note [Exotic derived instance contexts] - ; let residual_simple = approximateWC True solved_wanteds - (bad, good) = partitionBagWith get_good residual_simple - - get_good :: Ct -> Either Ct PredType - get_good ct | validDerivPred skol_set p - , isWantedCt ct - = Right p - -- TODO: This is wrong - -- NB re 'isWantedCt': residual_wanted may contain - -- unsolved CtDerived and we stick them into the - -- bad set so that reportUnsolved may decide what - -- to do with them - | otherwise - = Left ct - where p = ctPred ct - - ; traceTc "simplifyDeriv outputs" $ - vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ] - - -- Return the good unsolved constraints (unskolemizing on the way out.) - ; let min_theta = mkMinimalBySCs id (bagToList good) - -- An important property of mkMinimalBySCs (used above) is that in - -- addition to removing constraints that are made redundant by - -- superclass relationships, it also removes _duplicate_ - -- constraints. - -- See Note [Gathering and simplifying constraints for - -- DeriveAnyClass] - subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs - -- The reverse substitution (sigh) - - -- See [STEP DAC RESIDUAL] - ; min_theta_vars <- mapM newEvVar min_theta - ; (leftover_implic, _) - <- buildImplicationFor tc_lvl skol_info tvs_skols - min_theta_vars solved_wanteds - -- This call to simplifyTop is purely for error reporting - -- See Note [Error reporting for deriving clauses] - -- See also Note [Exotic derived instance contexts], which are caught - -- in this line of code. - ; simplifyTopImplic leftover_implic - - ; return (substTheta subst_skol min_theta) } - -{- -Note [Overlap and deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider some overlapping instances: - instance Show a => Show [a] where .. - instance Show [Char] where ... - -Now a data type with deriving: - data T a = MkT [a] deriving( Show ) - -We want to get the derived instance - instance Show [a] => Show (T a) where... -and NOT - instance Show a => Show (T a) where... -so that the (Show (T Char)) instance does the Right Thing - -It's very like the situation when we're inferring the type -of a function - f x = show [x] -and we want to infer - f :: Show [a] => a -> String - -BOTTOM LINE: use vanilla, non-overlappable skolems when inferring - the context for the derived instance. - Hence tcInstSkolTyVars not tcInstSuperSkolTyVars - -Note [Gathering and simplifying constraints for DeriveAnyClass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -DeriveAnyClass works quite differently from stock and newtype deriving in -the way it gathers and simplifies constraints to be used in a derived -instance's context. Stock and newtype deriving gather constraints by looking -at the data constructors of the data type for which we are deriving an -instance. But DeriveAnyClass doesn't need to know about a data type's -definition at all! - -To see why, consider this example of DeriveAnyClass: - - class Foo a where - bar :: forall b. Ix b => a -> b -> String - default bar :: (Show a, Ix c) => a -> c -> String - bar x y = show x ++ show (range (y,y)) - - baz :: Eq a => a -> a -> Bool - default baz :: (Ord a, Show a) => a -> a -> Bool - baz x y = compare x y == EQ - -Because 'bar' and 'baz' have default signatures, this generates a top-level -definition for these generic default methods - - $gdm_bar :: forall a. Foo a - => forall c. (Show a, Ix c) - => a -> c -> String - $gdm_bar x y = show x ++ show (range (y,y)) - -(and similarly for baz). Now consider a 'deriving' clause - data Maybe s = ... deriving Foo - -This derives an instance of the form: - instance (CX) => Foo (Maybe s) where - bar = $gdm_bar - baz = $gdm_baz - -Now it is GHC's job to fill in a suitable instance context (CX). If -GHC were typechecking the binding - bar = $gdm bar -it would - * skolemise the expected type of bar - * instantiate the type of $gdm_bar with meta-type variables - * build an implication constraint - -[STEP DAC BUILD] -So that's what we do. We build the constraint (call it C1) - - forall[2] b. Ix b => (Show (Maybe s), Ix cc, - Maybe s -> b -> String - ~ Maybe s -> cc -> String) - -Here: -* The level of this forall constraint is forall[2], because we are later - going to wrap it in a forall[1] in [STEP DAC RESIDUAL] - -* The 'b' comes from the quantified type variable in the expected type - of bar (i.e., 'to_anyclass_skols' in 'ThetaOrigin'). The 'cc' is a unification - variable that comes from instantiating the quantified type variable 'c' in - $gdm_bar's type (i.e., 'to_anyclass_metas' in 'ThetaOrigin). - -* The (Ix b) constraint comes from the context of bar's type - (i.e., 'to_wanted_givens' in 'ThetaOrigin'). The (Show (Maybe s)) and (Ix cc) - constraints come from the context of $gdm_bar's type - (i.e., 'to_anyclass_givens' in 'ThetaOrigin'). - -* The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String) - comes from marrying up the instantiated type of $gdm_bar with the specified - type of bar. Notice that the type variables from the instance, 's' in this - case, are global to this constraint. - -Note that it is vital that we instantiate the `c` in $gdm_bar's type with a new -unification variable for each iteration of simplifyDeriv. If we re-use the same -unification variable across multiple iterations, then bad things can happen, -such as #14933. - -Similarly for 'baz', giving the constraint C2 - - forall[2]. Eq (Maybe s) => (Ord a, Show a, - Maybe s -> Maybe s -> Bool - ~ Maybe s -> Maybe s -> Bool) - -In this case baz has no local quantification, so the implication -constraint has no local skolems and there are no unification -variables. - -[STEP DAC SOLVE] -We can combine these two implication constraints into a single -constraint (C1, C2), and simplify, unifying cc:=b, to get: - - forall[2] b. Ix b => Show a - /\ - forall[2]. Eq (Maybe s) => (Ord a, Show a) - -[STEP DAC HOIST] -Let's call that (C1', C2'). Now we need to hoist the unsolved -constraints out of the implications to become our candidate for -(CX). That is done by approximateWC, which will return: - - (Show a, Ord a, Show a) - -Now we can use mkMinimalBySCs to remove superclasses and duplicates, giving - - (Show a, Ord a) - -And that's what GHC uses for CX. - -[STEP DAC RESIDUAL] -In this case we have solved all the leftover constraints, but what if -we don't? Simple! We just form the final residual constraint - - forall[1] s. CX => (C1',C2') - -and simplify that. In simple cases it'll succeed easily, because CX -literally contains the constraints in C1', C2', but if there is anything -more complicated it will be reported in a civilised way. - -Note [Error reporting for deriving clauses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A surprisingly tricky aspect of deriving to get right is reporting sensible -error messages. In particular, if simplifyDeriv reaches a constraint that it -cannot solve, which might include: - -1. Insoluble constraints -2. "Exotic" constraints (See Note [Exotic derived instance contexts]) - -Then we report an error immediately in simplifyDeriv. - -Another possible choice is to punt and let another part of the typechecker -(e.g., simplifyInstanceContexts) catch the errors. But this tends to lead -to worse error messages, so we do it directly in simplifyDeriv. - -simplifyDeriv checks for errors in a clever way. If the deriving machinery -infers the context (Foo a)--that is, if this instance is to be generated: - - instance Foo a => ... - -Then we form an implication of the form: - - forall a. Foo a => <residual_wanted_constraints> - -And pass it to the simplifier. If the context (Foo a) is enough to discharge -all the constraints in <residual_wanted_constraints>, then everything is -hunky-dory. But if <residual_wanted_constraints> contains, say, an insoluble -constraint, then (Foo a) won't be able to solve it, causing GHC to error. - -Note [Exotic derived instance contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a 'derived' instance declaration, we *infer* the context. It's a -bit unclear what rules we should apply for this; the Haskell report is -silent. Obviously, constraints like (Eq a) are fine, but what about - data T f a = MkT (f a) deriving( Eq ) -where we'd get an Eq (f a) constraint. That's probably fine too. - -One could go further: consider - data T a b c = MkT (Foo a b c) deriving( Eq ) - instance (C Int a, Eq b, Eq c) => Eq (Foo a b c) - -Notice that this instance (just) satisfies the Paterson termination -conditions. Then we *could* derive an instance decl like this: - - instance (C Int a, Eq b, Eq c) => Eq (T a b c) -even though there is no instance for (C Int a), because there just -*might* be an instance for, say, (C Int Bool) at a site where we -need the equality instance for T's. - -However, this seems pretty exotic, and it's quite tricky to allow -this, and yet give sensible error messages in the (much more common) -case where we really want that instance decl for C. - -So for now we simply require that the derived instance context -should have only type-variable constraints. - -Here is another example: - data Fix f = In (f (Fix f)) deriving( Eq ) -Here, if we are prepared to allow -XUndecidableInstances we -could derive the instance - instance Eq (f (Fix f)) => Eq (Fix f) -but this is so delicate that I don't think it should happen inside -'deriving'. If you want this, write it yourself! - -NB: if you want to lift this condition, make sure you still meet the -termination conditions! If not, the deriving mechanism generates -larger and larger constraints. Example: - data Succ a = S a - data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show - -Note the lack of a Show instance for Succ. First we'll generate - instance (Show (Succ a), Show a) => Show (Seq a) -and then - instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) -and so on. Instead we want to complain of no instance for (Show (Succ a)). - -The bottom line -~~~~~~~~~~~~~~~ -Allow constraints which consist only of type variables, with no repeats. --} diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs deleted file mode 100644 index 0f72eea2e2..0000000000 --- a/compiler/typecheck/TcDerivUtils.hs +++ /dev/null @@ -1,1112 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Error-checking and other utilities for @deriving@ clauses or declarations. --} - -{-# LANGUAGE TypeFamilies #-} - -module TcDerivUtils ( - DerivM, DerivEnv(..), - DerivSpec(..), pprDerivSpec, DerivInstTys(..), - DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock, - isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia, - DerivContext(..), OriginativeDerivStatus(..), - isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin, - PredOrigin(..), ThetaOrigin(..), mkPredOrigin, - mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin, - checkOriginativeSideConditions, hasStockDeriving, - canDeriveAnyClass, - std_class_via_coercible, non_coercible_class, - newDerivClsInst, extendLocalInstEnv - ) where - -import GhcPrelude - -import Bag -import GHC.Types.Basic -import GHC.Core.Class -import GHC.Core.DataCon -import GHC.Driver.Session -import ErrUtils -import GHC.Driver.Types (lookupFixity, mi_fix) -import GHC.Hs -import Inst -import GHC.Core.InstEnv -import GHC.Iface.Load (loadInterfaceForName) -import GHC.Types.Module (getModule) -import GHC.Types.Name -import Outputable -import PrelNames -import GHC.Types.SrcLoc -import TcGenDeriv -import TcGenFunctor -import TcGenGenerics -import TcOrigin -import TcRnMonad -import TcType -import THNames (liftClassKey) -import GHC.Core.TyCon -import GHC.Core.TyCo.Ppr (pprSourceTyCon) -import GHC.Core.Type -import Util -import GHC.Types.Var.Set - -import Control.Monad.Trans.Reader -import Data.Maybe -import qualified GHC.LanguageExtensions as LangExt -import ListSetOps (assocMaybe) - --- | To avoid having to manually plumb everything in 'DerivEnv' throughout --- various functions in @TcDeriv@ and @TcDerivInfer@, we use 'DerivM', which --- is a simple reader around 'TcRn'. -type DerivM = ReaderT DerivEnv TcRn - --- | Is GHC processing a standalone deriving declaration? -isStandaloneDeriv :: DerivM Bool -isStandaloneDeriv = asks (go . denv_ctxt) - where - go :: DerivContext -> Bool - go (InferContext wildcard) = isJust wildcard - go (SupplyContext {}) = True - --- | Is GHC processing a standalone deriving declaration with an --- extra-constraints wildcard as the context? --- (e.g., @deriving instance _ => Eq (Foo a)@) -isStandaloneWildcardDeriv :: DerivM Bool -isStandaloneWildcardDeriv = asks (go . denv_ctxt) - where - go :: DerivContext -> Bool - go (InferContext wildcard) = isJust wildcard - go (SupplyContext {}) = False - --- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True', --- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting. -mkDerivOrigin :: Bool -> CtOrigin -mkDerivOrigin standalone_wildcard - | standalone_wildcard = StandAloneDerivOrigin - | otherwise = DerivClauseOrigin - --- | Contains all of the information known about a derived instance when --- determining what its @EarlyDerivSpec@ should be. --- See @Note [DerivEnv and DerivSpecMechanism]@. -data DerivEnv = DerivEnv - { denv_overlap_mode :: Maybe OverlapMode - -- ^ Is this an overlapping instance? - , denv_tvs :: [TyVar] - -- ^ Universally quantified type variables in the instance - , denv_cls :: Class - -- ^ Class for which we need to derive an instance - , denv_inst_tys :: [Type] - -- ^ All arguments to to 'denv_cls' in the derived instance. - , denv_ctxt :: DerivContext - -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the - -- context of the instance). - -- 'InferContext' for @deriving@ clauses, or for standalone deriving that - -- uses a wildcard constraint. - -- See @Note [Inferring the instance context]@. - , denv_strat :: Maybe (DerivStrategy GhcTc) - -- ^ 'Just' if user requests a particular deriving strategy. - -- Otherwise, 'Nothing'. - } - -instance Outputable DerivEnv where - ppr (DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys - , denv_ctxt = ctxt - , denv_strat = mb_strat }) - = hang (text "DerivEnv") - 2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode - , text "denv_tvs" <+> ppr tvs - , text "denv_cls" <+> ppr cls - , text "denv_inst_tys" <+> ppr inst_tys - , text "denv_ctxt" <+> ppr ctxt - , text "denv_strat" <+> ppr mb_strat ]) - -data DerivSpec theta = DS { ds_loc :: SrcSpan - , ds_name :: Name -- DFun name - , ds_tvs :: [TyVar] - , ds_theta :: theta - , ds_cls :: Class - , ds_tys :: [Type] - , ds_overlap :: Maybe OverlapMode - , ds_standalone_wildcard :: Maybe SrcSpan - -- See Note [Inferring the instance context] - -- in TcDerivInfer - , ds_mechanism :: DerivSpecMechanism } - -- This spec implies a dfun declaration of the form - -- df :: forall tvs. theta => C tys - -- The Name is the name for the DFun we'll build - -- The tyvars bind all the variables in the theta - - -- the theta is either the given and final theta, in standalone deriving, - -- or the not-yet-simplified list of constraints together with their origin - - -- ds_mechanism specifies the means by which GHC derives the instance. - -- See Note [Deriving strategies] in TcDeriv - -{- -Example: - - newtype instance T [a] = MkT (Tree a) deriving( C s ) -==> - axiom T [a] = :RTList a - axiom :RTList a = Tree a - - DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]] - , ds_mechanism = DerivSpecNewtype (Tree a) } --} - -pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc -pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c, - ds_tys = tys, ds_theta = rhs, - ds_standalone_wildcard = wildcard, ds_mechanism = mech }) - = hang (text "DerivSpec") - 2 (vcat [ text "ds_loc =" <+> ppr l - , text "ds_name =" <+> ppr n - , text "ds_tvs =" <+> ppr tvs - , text "ds_cls =" <+> ppr c - , text "ds_tys =" <+> ppr tys - , text "ds_theta =" <+> ppr rhs - , text "ds_standalone_wildcard =" <+> ppr wildcard - , text "ds_mechanism =" <+> ppr mech ]) - -instance Outputable theta => Outputable (DerivSpec theta) where - ppr = pprDerivSpec - --- | Information about the arguments to the class in a stock- or --- newtype-derived instance. --- See @Note [DerivEnv and DerivSpecMechanism]@. -data DerivInstTys = DerivInstTys - { dit_cls_tys :: [Type] - -- ^ Other arguments to the class except the last - , dit_tc :: TyCon - -- ^ Type constructor for which the instance is requested - -- (last arguments to the type class) - , dit_tc_args :: [Type] - -- ^ Arguments to the type constructor - , dit_rep_tc :: TyCon - -- ^ The representation tycon for 'dit_tc' - -- (for data family instances). Otherwise the same as 'dit_tc'. - , dit_rep_tc_args :: [Type] - -- ^ The representation types for 'dit_tc_args' - -- (for data family instances). Otherwise the same as 'dit_tc_args'. - } - -instance Outputable DerivInstTys where - ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args - , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args }) - = hang (text "DITTyConHead") - 2 (vcat [ text "dit_cls_tys" <+> ppr cls_tys - , text "dit_tc" <+> ppr tc - , text "dit_tc_args" <+> ppr tc_args - , text "dit_rep_tc" <+> ppr rep_tc - , text "dit_rep_tc_args" <+> ppr rep_tc_args ]) - --- | What action to take in order to derive a class instance. --- See @Note [DerivEnv and DerivSpecMechanism]@, as well as --- @Note [Deriving strategies]@ in "TcDeriv". -data DerivSpecMechanism - -- | \"Standard\" classes - = DerivSpecStock - { dsm_stock_dit :: DerivInstTys - -- ^ Information about the arguments to the class in the derived - -- instance, including what type constructor the last argument is - -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. - , dsm_stock_gen_fn :: - SrcSpan -> TyCon - -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]) - -- ^ This function returns three things: - -- - -- 1. @LHsBinds GhcPs@: The derived instance's function bindings - -- (e.g., @compare (T x) (T y) = compare x y@) - -- - -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived - -- instance. As examples, derived 'Generic' instances require - -- associated type family instances, and derived 'Eq' and 'Ord' - -- instances require top-level @con2tag@ functions. - -- See @Note [Auxiliary binders]@ in "TcGenDeriv". - -- - -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be - -- suppressed. This is used to suppress unused warnings for record - -- selectors when deriving 'Read', 'Show', or 'Generic'. - -- See @Note [Deriving and unused record selectors]@. - } - - -- | @GeneralizedNewtypeDeriving@ - | DerivSpecNewtype - { dsm_newtype_dit :: DerivInstTys - -- ^ Information about the arguments to the class in the derived - -- instance, including what type constructor the last argument is - -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@. - , dsm_newtype_rep_ty :: Type - -- ^ The newtype rep type. - } - - -- | @DeriveAnyClass@ - | DerivSpecAnyClass - - -- | @DerivingVia@ - | DerivSpecVia - { dsm_via_cls_tys :: [Type] - -- ^ All arguments to the class besides the last one. - , dsm_via_inst_ty :: Type - -- ^ The last argument to the class. - , dsm_via_ty :: Type - -- ^ The @via@ type - } - --- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'. -derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc -derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy -derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy -derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy -derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t - -isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia - :: DerivSpecMechanism -> Bool -isDerivSpecStock (DerivSpecStock{}) = True -isDerivSpecStock _ = False - -isDerivSpecNewtype (DerivSpecNewtype{}) = True -isDerivSpecNewtype _ = False - -isDerivSpecAnyClass DerivSpecAnyClass = True -isDerivSpecAnyClass _ = False - -isDerivSpecVia (DerivSpecVia{}) = True -isDerivSpecVia _ = False - -instance Outputable DerivSpecMechanism where - ppr (DerivSpecStock{dsm_stock_dit = dit}) - = hang (text "DerivSpecStock") - 2 (vcat [ text "dsm_stock_dit" <+> ppr dit ]) - ppr (DerivSpecNewtype { dsm_newtype_dit = dit, dsm_newtype_rep_ty = rep_ty }) - = hang (text "DerivSpecNewtype") - 2 (vcat [ text "dsm_newtype_dit" <+> ppr dit - , text "dsm_newtype_rep_ty" <+> ppr rep_ty ]) - ppr DerivSpecAnyClass = text "DerivSpecAnyClass" - ppr (DerivSpecVia { dsm_via_cls_tys = cls_tys, dsm_via_inst_ty = inst_ty - , dsm_via_ty = via_ty }) - = hang (text "DerivSpecVia") - 2 (vcat [ text "dsm_via_cls_tys" <+> ppr cls_tys - , text "dsm_via_inst_ty" <+> ppr inst_ty - , text "dsm_via_ty" <+> ppr via_ty ]) - -{- -Note [DerivEnv and DerivSpecMechanism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -DerivEnv contains all of the bits and pieces that are common to every -deriving strategy. (See Note [Deriving strategies] in TcDeriv.) Some deriving -strategies impose stricter requirements on the types involved in the derived -instance than others, and these differences are factored out into the -DerivSpecMechanism type. Suppose that the derived instance looks like this: - - instance ... => C arg_1 ... arg_n - -Each deriving strategy imposes restrictions on arg_1 through arg_n as follows: - -* stock (DerivSpecStock): - - Stock deriving requires that: - - - n must be a positive number. This is checked by - TcDeriv.expectNonNullaryClsArgs - - arg_n must be an application of an algebraic type constructor. Here, - "algebraic type constructor" means: - - + An ordinary data type constructor, or - + A data family type constructor such that the arguments it is applied to - give rise to a data family instance. - - This is checked by TcDeriv.expectAlgTyConApp. - - This extra structure is witnessed by the DerivInstTys data type, which stores - arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor - (dit_tc), and its arguments (dit_tc_args). If dit_tc is an ordinary data type - constructor, then dit_rep_tc/dit_rep_tc_args are the same as - dit_tc/dit_tc_args. If dit_tc is a data family type constructor, then - dit_rep_tc is the representation type constructor for the data family - instance, and dit_rep_tc_args are the arguments to the representation type - constructor in the corresponding instance. - -* newtype (DerivSpecNewtype): - - Newtype deriving imposes the same DerivInstTys requirements as stock - deriving. This is necessary because we need to know what the underlying type - that the newtype wraps is, and this information can only be learned by - knowing dit_rep_tc. - -* anyclass (DerivSpecAnyclass): - - DeriveAnyClass is the most permissive deriving strategy of all, as it - essentially imposes no requirements on the derived instance. This is because - DeriveAnyClass simply derives an empty instance, so it does not need any - particular knowledge about the types involved. It can do several things - that stock/newtype deriving cannot do (#13154): - - - n can be 0. That is, one is allowed to anyclass-derive an instance with - no arguments to the class, such as in this example: - - class C - deriving anyclass instance C - - - One can derive an instance for a type that is not headed by a type - constructor, such as in the following example: - - class C (n :: Nat) - deriving instance C 0 - deriving instance C 1 - ... - - - One can derive an instance for a data family with no data family instances, - such as in the following example: - - data family Foo a - class C a - deriving anyclass instance C (Foo a) - -* via (DerivSpecVia): - - Like newtype deriving, DerivingVia requires that n must be a positive number. - This is because when one derives something like this: - - deriving via Foo instance C Bar - - Then the generated code must specifically mention Bar. However, in - contrast with newtype deriving, DerivingVia does *not* require Bar to be - an application of an algebraic type constructor. This is because the - generated code simply defers to invoking `coerce`, which does not need to - know anything in particular about Bar (besides that it is representationally - equal to Foo). This allows DerivingVia to do some things that are not - possible with newtype deriving, such as deriving instances for data families - without data instances (#13154): - - data family Foo a - newtype ByBar a = ByBar a - class Baz a where ... - instance Baz (ByBar a) where ... - deriving via ByBar (Foo a) instance Baz (Foo a) --} - --- | Whether GHC is processing a @deriving@ clause or a standalone deriving --- declaration. -data DerivContext - = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either: - -- - -- * A @deriving@ clause (in which case - -- @mb_wildcard@ is 'Nothing'). - -- - -- * A standalone deriving declaration with - -- an extra-constraints wildcard as the - -- context (in which case @mb_wildcard@ is - -- @'Just' loc@, where @loc@ is the location - -- of the wildcard. - -- - -- GHC should infer the context. - - | SupplyContext ThetaType -- ^ @'SupplyContext' theta@ is a standalone - -- deriving declaration, where @theta@ is the - -- context supplied by the user. - -instance Outputable DerivContext where - ppr (InferContext standalone) = text "InferContext" <+> ppr standalone - ppr (SupplyContext theta) = text "SupplyContext" <+> ppr theta - --- | Records whether a particular class can be derived by way of an --- /originative/ deriving strategy (i.e., @stock@ or @anyclass@). --- --- See @Note [Deriving strategies]@ in "TcDeriv". -data OriginativeDerivStatus - = CanDeriveStock -- Stock class, can derive - (SrcSpan -> TyCon -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) - | StockClassError SDoc -- Stock class, but can't do it - | CanDeriveAnyClass -- See Note [Deriving any class] - | NonDerivableClass SDoc -- Cannot derive with either stock or anyclass - --- A stock class is one either defined in the Haskell report or for which GHC --- otherwise knows how to generate code for (possibly requiring the use of a --- language extension), such as Eq, Ord, Ix, Data, Generic, etc.) - --- | A 'PredType' annotated with the origin of the constraint 'CtOrigin', --- and whether or the constraint deals in types or kinds. -data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind - --- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to --- simplify when inferring a derived instance's context. These are used in all --- deriving strategies, but in the particular case of @DeriveAnyClass@, we --- need extra information. In particular, we need: --- --- * 'to_anyclass_skols', the list of type variables bound by a class method's --- regular type signature, which should be rigid. --- --- * 'to_anyclass_metas', the list of type variables bound by a class method's --- default type signature. These can be unified as necessary. --- --- * 'to_anyclass_givens', the list of constraints from a class method's --- regular type signature, which can be used to help solve constraints --- in the 'to_wanted_origins'. --- --- (Note that 'to_wanted_origins' will likely contain type variables from the --- derived type class or data type, neither of which will appear in --- 'to_anyclass_skols' or 'to_anyclass_metas'.) --- --- For all other deriving strategies, it is always the case that --- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are --- empty. --- --- Here is an example to illustrate this: --- --- @ --- class Foo a where --- bar :: forall b. Ix b => a -> b -> String --- default bar :: forall y. (Show a, Ix y) => a -> y -> String --- bar x y = show x ++ show (range (y, y)) --- --- baz :: Eq a => a -> a -> Bool --- default baz :: Ord a => a -> a -> Bool --- baz x y = compare x y == EQ --- --- data Quux q = Quux deriving anyclass Foo --- @ --- --- Then it would generate two 'ThetaOrigin's, one for each method: --- --- @ --- [ ThetaOrigin { to_anyclass_skols = [b] --- , to_anyclass_metas = [y] --- , to_anyclass_givens = [Ix b] --- , to_wanted_origins = [ Show (Quux q), Ix y --- , (Quux q -> b -> String) ~ --- (Quux q -> y -> String) --- ] } --- , ThetaOrigin { to_anyclass_skols = [] --- , to_anyclass_metas = [] --- , to_anyclass_givens = [Eq (Quux q)] --- , to_wanted_origins = [ Ord (Quux q) --- , (Quux q -> Quux q -> Bool) ~ --- (Quux q -> Quux q -> Bool) --- ] } --- ] --- @ --- --- (Note that the type variable @q@ is bound by the data type @Quux@, and thus --- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.) --- --- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@ --- in "TcDerivInfer" for an explanation of how 'to_wanted_origins' are --- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols', --- 'to_anyclass_metas', and 'to_anyclass_givens' are used. -data ThetaOrigin - = ThetaOrigin { to_anyclass_skols :: [TyVar] - , to_anyclass_metas :: [TyVar] - , to_anyclass_givens :: ThetaType - , to_wanted_origins :: [PredOrigin] } - -instance Outputable PredOrigin where - ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging - -instance Outputable ThetaOrigin where - ppr (ThetaOrigin { to_anyclass_skols = ac_skols - , to_anyclass_metas = ac_metas - , to_anyclass_givens = ac_givens - , to_wanted_origins = wanted_origins }) - = hang (text "ThetaOrigin") - 2 (vcat [ text "to_anyclass_skols =" <+> ppr ac_skols - , text "to_anyclass_metas =" <+> ppr ac_metas - , text "to_anyclass_givens =" <+> ppr ac_givens - , text "to_wanted_origins =" <+> ppr wanted_origins ]) - -mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin -mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k - -mkThetaOrigin :: CtOrigin -> TypeOrKind - -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType - -> ThetaOrigin -mkThetaOrigin origin t_or_k skols metas givens - = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k) - --- A common case where the ThetaOrigin only contains wanted constraints, with --- no givens or locally scoped type variables. -mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin -mkThetaOriginFromPreds = ThetaOrigin [] [] [] - -substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin -substPredOrigin subst (PredOrigin pred origin t_or_k) - = PredOrigin (substTy subst pred) origin t_or_k - -{- -************************************************************************ -* * - Class deriving diagnostics -* * -************************************************************************ - -Only certain blessed classes can be used in a deriving clause (without the -assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes -are listed below in the definition of hasStockDeriving. The stockSideConditions -function determines the criteria that needs to be met in order for a particular -stock class to be able to be derived successfully. - -A class might be able to be used in a deriving clause if -XDeriveAnyClass -is willing to support it. The canDeriveAnyClass function checks if this is the -case. --} - -hasStockDeriving - :: Class -> Maybe (SrcSpan - -> TyCon - -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) -hasStockDeriving clas - = assocMaybe gen_list (getUnique clas) - where - gen_list - :: [(Unique, SrcSpan - -> TyCon - -> [Type] - -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))] - gen_list = [ (eqClassKey, simpleM gen_Eq_binds) - , (ordClassKey, simpleM gen_Ord_binds) - , (enumClassKey, simpleM gen_Enum_binds) - , (boundedClassKey, simple gen_Bounded_binds) - , (ixClassKey, simpleM gen_Ix_binds) - , (showClassKey, read_or_show gen_Show_binds) - , (readClassKey, read_or_show gen_Read_binds) - , (dataClassKey, simpleM gen_Data_binds) - , (functorClassKey, simple gen_Functor_binds) - , (foldableClassKey, simple gen_Foldable_binds) - , (traversableClassKey, simple gen_Traversable_binds) - , (liftClassKey, simple gen_Lift_binds) - , (genClassKey, generic (gen_Generic_binds Gen0)) - , (gen1ClassKey, generic (gen_Generic_binds Gen1)) ] - - simple gen_fn loc tc _ - = let (binds, deriv_stuff) = gen_fn loc tc - in return (binds, deriv_stuff, []) - - simpleM gen_fn loc tc _ - = do { (binds, deriv_stuff) <- gen_fn loc tc - ; return (binds, deriv_stuff, []) } - - read_or_show gen_fn loc tc _ - = do { fix_env <- getDataConFixityFun tc - ; let (binds, deriv_stuff) = gen_fn fix_env loc tc - field_names = all_field_names tc - ; return (binds, deriv_stuff, field_names) } - - generic gen_fn _ tc inst_tys - = do { (binds, faminst) <- gen_fn tc inst_tys - ; let field_names = all_field_names tc - ; return (binds, unitBag (DerivFamInst faminst), field_names) } - - -- See Note [Deriving and unused record selectors] - all_field_names = map flSelector . concatMap dataConFieldLabels - . tyConDataCons - -{- -Note [Deriving and unused record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (see #13919): - - module Main (main) where - - data Foo = MkFoo {bar :: String} deriving Show - - main :: IO () - main = print (Foo "hello") - -Strictly speaking, the record selector `bar` is unused in this module, since -neither `main` nor the derived `Show` instance for `Foo` mention `bar`. -However, the behavior of `main` is affected by the presence of `bar`, since -it will print different output depending on whether `MkFoo` is defined using -record selectors or not. Therefore, we do not to issue a -"Defined but not used: ‘bar’" warning for this module, since removing `bar` -changes the program's behavior. This is the reason behind the [Name] part of -the return type of `hasStockDeriving`—it tracks all of the record selector -`Name`s for which -Wunused-binds should be suppressed. - -Currently, the only three stock derived classes that require this are Read, -Show, and Generic, as their derived code all depend on the record selectors -of the derived data type's constructors. - -See also Note [Newtype deriving and unused constructors] in TcDeriv for -another example of a similar trick. --} - -getDataConFixityFun :: TyCon -> TcM (Name -> Fixity) --- If the TyCon is locally defined, we want the local fixity env; --- but if it is imported (which happens for standalone deriving) --- we need to get the fixity env from the interface file --- c.f. GHC.Rename.Env.lookupFixity, and #9830 -getDataConFixityFun tc - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod name - then do { fix_env <- getFixityEnv - ; return (lookupFixity fix_env) } - else do { iface <- loadInterfaceForName doc name - -- Should already be loaded! - ; return (mi_fix iface . nameOccName) } } - where - name = tyConName tc - doc = text "Data con fixities for" <+> ppr name - ------------------------------------------------------------------- --- Check side conditions that dis-allow derivability for the originative --- deriving strategies (stock and anyclass). --- See Note [Deriving strategies] in TcDeriv for an explanation of what --- "originative" means. --- --- This is *apart* from the coerce-based strategies, newtype and via. --- --- Here we get the representation tycon in case of family instances as it has --- the data constructors - but we need to be careful to fall back to the --- family tycon (with indexes) in error messages. - -checkOriginativeSideConditions - :: DynFlags -> DerivContext -> Class -> [TcType] - -> TyCon -> TyCon - -> OriginativeDerivStatus -checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc - -- First, check if stock deriving is possible... - | Just cond <- stockSideConditions deriv_ctxt cls - = case (cond dflags tc rep_tc) of - NotValid err -> StockClassError err -- Class-specific error - IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys) - -- All stock derivable classes are unary in the sense that - -- there should be not types in cls_tys (i.e., no type args - -- other than last). Note that cls_types can contain - -- invisible types as well (e.g., for Generic1, which is - -- poly-kinded), so make sure those are not counted. - , Just gen_fn <- hasStockDeriving cls - -> CanDeriveStock gen_fn - | otherwise -> StockClassError (classArgsErr cls cls_tys) - -- e.g. deriving( Eq s ) - - -- ...if not, try falling back on DeriveAnyClass. - | NotValid err <- canDeriveAnyClass dflags - = NonDerivableClass err -- Neither anyclass nor stock work - - | otherwise - = CanDeriveAnyClass -- DeriveAnyClass should work - -classArgsErr :: Class -> [Type] -> SDoc -classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class" - --- Side conditions (whether the datatype must have at least one constructor, --- required language extensions, etc.) for using GHC's stock deriving --- mechanism on certain classes (as opposed to classes that require --- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a --- class for which stock deriving isn't possible. -stockSideConditions :: DerivContext -> Class -> Maybe Condition -stockSideConditions deriv_ctxt cls - | cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == readClassKey = Just (cond_std `andCond` cond_args cls) - | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration) - | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) - | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls) - | cls_key == dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond` - cond_vanilla `andCond` - cond_args cls) - | cls_key == functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond` - cond_vanilla `andCond` - cond_functorOK True False) - | cls_key == foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond` - cond_vanilla `andCond` - cond_functorOK False True) - -- Functor/Fold/Trav works ok - -- for rank-n types - | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond` - cond_vanilla `andCond` - cond_functorOK False False) - | cls_key == genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` - cond_vanilla `andCond` - cond_RepresentableOk) - | cls_key == gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond` - cond_vanilla `andCond` - cond_Representable1Ok) - | cls_key == liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond` - cond_vanilla `andCond` - cond_args cls) - | otherwise = Nothing - where - cls_key = getUnique cls - cond_std = cond_stdOK deriv_ctxt False - -- Vanilla data constructors, at least one, and monotype arguments - cond_vanilla = cond_stdOK deriv_ctxt True - -- Vanilla data constructors but allow no data cons or polytype arguments - -canDeriveAnyClass :: DynFlags -> Validity --- IsValid: we can (try to) derive it via an empty instance declaration --- NotValid s: we can't, reason s -canDeriveAnyClass dflags - | not (xopt LangExt.DeriveAnyClass dflags) - = NotValid (text "Try enabling DeriveAnyClass") - | otherwise - = IsValid -- OK! - -type Condition - = DynFlags - - -> TyCon -- ^ The data type's 'TyCon'. For data families, this is the - -- family 'TyCon'. - - -> TyCon -- ^ For data families, this is the representation 'TyCon'. - -- Otherwise, this is the same as the other 'TyCon' argument. - - -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is - -- possible. Otherwise, it's @'NotValid' err@, where @err@ - -- explains what went wrong. - -orCond :: Condition -> Condition -> Condition -orCond c1 c2 dflags tc rep_tc - = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of - (IsValid, _) -> IsValid -- c1 succeeds - (_, IsValid) -> IsValid -- c21 succeeds - (NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y) - -- Both fail - -andCond :: Condition -> Condition -> Condition -andCond c1 c2 dflags tc rep_tc - = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc - --- | Some common validity checks shared among stock derivable classes. One --- check that absolutely must hold is that if an instance @C (T a)@ is being --- derived, then @T@ must be a tycon for a data type or a newtype. The --- remaining checks are only performed if using a @deriving@ clause (i.e., --- they're ignored if using @StandaloneDeriving@): --- --- 1. The data type must have at least one constructor (this check is ignored --- if using @EmptyDataDeriving@). --- --- 2. The data type cannot have any GADT constructors. --- --- 3. The data type cannot have any constructors with existentially quantified --- type variables. --- --- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@). --- --- 5. The data type cannot have fields with higher-rank types. -cond_stdOK - :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a - -- user-supplied context, 'InferContext' if not. - -- If it is the former, we relax some of the validity checks - -- we would otherwise perform (i.e., "just go for it"). - - -> Bool -- ^ 'True' <=> allow higher rank arguments and empty data - -- types (with no data constructors) even in the absence of - -- the -XEmptyDataDeriving extension. - - -> Condition -cond_stdOK deriv_ctxt permissive dflags tc rep_tc - = valid_ADT `andValid` valid_misc - where - valid_ADT, valid_misc :: Validity - valid_ADT - | isAlgTyCon tc || isDataFamilyTyCon tc - = IsValid - | otherwise - -- Complain about functions, primitive types, and other tycons that - -- stock deriving can't handle. - = NotValid $ text "The last argument of the instance must be a" - <+> text "data or newtype application" - - valid_misc - = case deriv_ctxt of - SupplyContext _ -> IsValid - -- Don't check these conservative conditions for - -- standalone deriving; just generate the code - -- and let the typechecker handle the result - InferContext wildcard - | null data_cons -- 1. - , not permissive - -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid` - NotValid (no_cons_why rep_tc $$ empty_data_suggestion) - | not (null con_whys) - -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard) - | otherwise - -> IsValid - - empty_data_suggestion = - text "Use EmptyDataDeriving to enable deriving for empty data types" - possible_fix_suggestion wildcard - = case wildcard of - Just _ -> - text "Possible fix: fill in the wildcard constraint yourself" - Nothing -> - text "Possible fix: use a standalone deriving declaration instead" - data_cons = tyConDataCons rep_tc - con_whys = getInvalids (map check_con data_cons) - - check_con :: DataCon -> Validity - check_con con - | not (null eq_spec) -- 2. - = bad "is a GADT" - | not (null ex_tvs) -- 3. - = bad "has existential type variables in its type" - | not (null theta) -- 4. - = bad "has constraints in its type" - | not (permissive || all isTauTy (dataConOrigArgTys con)) -- 5. - = bad "has a higher-rank type" - | otherwise - = IsValid - where - (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con - bad msg = NotValid (badCon con (text msg)) - -no_cons_why :: TyCon -> SDoc -no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> - text "must have at least one data constructor" - -cond_RepresentableOk :: Condition -cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc - -cond_Representable1Ok :: Condition -cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc - -cond_enumOrProduct :: Class -> Condition -cond_enumOrProduct cls = cond_isEnumeration `orCond` - (cond_isProduct `andCond` cond_args cls) - -cond_args :: Class -> Condition --- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types --- by generating specialised code. For others (eg 'Data') we don't. --- For even others (eg 'Lift'), unlifted types aren't even a special --- consideration! -cond_args cls _ _ rep_tc - = case bad_args of - [] -> IsValid - (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls)) - 2 (text "for type" <+> quotes (ppr ty))) - where - bad_args = [ arg_ty | con <- tyConDataCons rep_tc - , arg_ty <- dataConOrigArgTys con - , isLiftedType_maybe arg_ty /= Just True - , not (ok_ty arg_ty) ] - - cls_key = classKey cls - ok_ty arg_ty - | cls_key == eqClassKey = check_in arg_ty ordOpTbl - | cls_key == ordClassKey = check_in arg_ty ordOpTbl - | cls_key == showClassKey = check_in arg_ty boxConTbl - | cls_key == liftClassKey = True -- Lift is levity-polymorphic - | otherwise = False -- Read, Ix etc - - check_in :: Type -> [(Type,a)] -> Bool - check_in arg_ty tbl = any (eqType arg_ty . fst) tbl - - -cond_isEnumeration :: Condition -cond_isEnumeration _ _ rep_tc - | isEnumerationTyCon rep_tc = IsValid - | otherwise = NotValid why - where - why = sep [ quotes (pprSourceTyCon rep_tc) <+> - text "must be an enumeration type" - , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ] - -- See Note [Enumeration types] in GHC.Core.TyCon - -cond_isProduct :: Condition -cond_isProduct _ _ rep_tc - | isProductTyCon rep_tc = IsValid - | otherwise = NotValid why - where - why = quotes (pprSourceTyCon rep_tc) <+> - text "must have precisely one constructor" - -cond_functorOK :: Bool -> Bool -> Condition --- OK for Functor/Foldable/Traversable class --- Currently: (a) at least one argument --- (b) don't use argument contravariantly --- (c) don't use argument in the wrong place, e.g. data T a = T (X a a) --- (d) optionally: don't use function types --- (e) no "stupid context" on data type -cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc - | null tc_tvs - = NotValid (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters") - - | not (null bad_stupid_theta) - = NotValid (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) - - | otherwise - = allValid (map check_con data_cons) - where - tc_tvs = tyConTyVars rep_tc - last_tv = last tc_tvs - bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc) - is_bad pred = last_tv `elemVarSet` exactTyCoVarsOfType pred - -- See Note [Check that the type variable is truly universal] - - data_cons = tyConDataCons rep_tc - check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con) - - check_universal :: DataCon -> Validity - check_universal con - | allowExQuantifiedLastTyVar - = IsValid -- See Note [DeriveFoldable with ExistentialQuantification] - -- in TcGenFunctor - | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) - , tv `elem` dataConUnivTyVars con - , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con)) - = IsValid -- See Note [Check that the type variable is truly universal] - | otherwise - = NotValid (badCon con existential) - - ft_check :: DataCon -> FFoldType Validity - ft_check con = FT { ft_triv = IsValid, ft_var = IsValid - , ft_co_var = NotValid (badCon con covariant) - , ft_fun = \x y -> if allowFunctions then x `andValid` y - else NotValid (badCon con functions) - , ft_tup = \_ xs -> allValid xs - , ft_ty_app = \_ _ x -> x - , ft_bad_app = NotValid (badCon con wrong_arg) - , ft_forall = \_ x -> x } - - existential = text "must be truly polymorphic in the last argument of the data type" - covariant = text "must not use the type variable in a function argument" - functions = text "must not contain function types" - wrong_arg = text "must use the type variable only as the last argument of a data type" - -checkFlag :: LangExt.Extension -> Condition -checkFlag flag dflags _ _ - | xopt flag dflags = IsValid - | otherwise = NotValid why - where - why = text "You need " <> text flag_str - <+> text "to derive an instance for this class" - flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of - [s] -> s - other -> pprPanic "checkFlag" (ppr other) - -std_class_via_coercible :: Class -> Bool --- These standard classes can be derived for a newtype --- using the coercible trick *even if no -XGeneralizedNewtypeDeriving --- because giving so gives the same results as generating the boilerplate -std_class_via_coercible clas - = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] - -- Not Read/Show because they respect the type - -- Not Enum, because newtypes are never in Enum - - -non_coercible_class :: Class -> Bool --- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift --- by Coercible, even with -XGeneralizedNewtypeDeriving --- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived --- instance behave differently if there's a non-lawful Applicative out there. --- Besides, with roles, Coercible-deriving Traversable is ill-roled. -non_coercible_class cls - = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey - , genClassKey, gen1ClassKey, typeableClassKey - , traversableClassKey, liftClassKey ]) - -badCon :: DataCon -> SDoc -> SDoc -badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg - ------------------------------------------------------------------- - -newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst -newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode - , ds_tvs = tvs, ds_cls = clas, ds_tys = tys }) - = newClsInst overlap_mode dfun_name tvs theta clas tys - -extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a --- Add new locally-defined instances; don't bother to check --- for functional dependency errors -- that'll happen in TcInstDcls -extendLocalInstEnv dfuns thing_inside - = do { env <- getGblEnv - ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns - env' = env { tcg_inst_env = inst_env' } - ; setGblEnv env' thing_inside } - -{- -Note [Deriving any class] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Classic uses of a deriving clause, or a standalone-deriving declaration, are -for: - * a stock class like Eq or Show, for which GHC knows how to generate - the instance code - * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving - -The DeriveAnyClass extension adds a third way to derive instances, based on -empty instance declarations. - -The canonical use case is in combination with GHC.Generics and default method -signatures. These allow us to have instance declarations being empty, but still -useful, e.g. - - data T a = ...blah..blah... deriving( Generic ) - instance C a => C (T a) -- No 'where' clause - -where C is some "random" user-defined class. - -This boilerplate code can be replaced by the more compact - - data T a = ...blah..blah... deriving( Generic, C ) - -if DeriveAnyClass is enabled. - -This is not restricted to Generics; any class can be derived, simply giving -rise to an empty instance. - -See Note [Gathering and simplifying constraints for DeriveAnyClass] in -TcDerivInfer for an explanation hof how the instance context is inferred for -DeriveAnyClass. - -Note [Check that the type variable is truly universal] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For Functor and Traversable instances, we must check that the *last argument* -of the type constructor is used truly universally quantified. Example - - data T a b where - T1 :: a -> b -> T a b -- Fine! Vanilla H-98 - T2 :: b -> c -> T a b -- Fine! Existential c, but we can still map over 'b' - T3 :: b -> T Int b -- Fine! Constraint 'a', but 'b' is still polymorphic - T4 :: Ord b => b -> T a b -- No! 'b' is constrained - T5 :: b -> T b b -- No! 'b' is constrained - T6 :: T a (b,b) -- No! 'b' is constrained - -Notice that only the first of these constructors is vanilla H-98. We only -need to take care about the last argument (b in this case). See #8678. -Eg. for T1-T3 we can write - - fmap f (T1 a b) = T1 a (f b) - fmap f (T2 b c) = T2 (f b) c - fmap f (T3 x) = T3 (f x) - -We need not perform these checks for Foldable instances, however, since -functions in Foldable can only consume existentially quantified type variables, -rather than produce them (as is the case in Functor and Traversable functions.) -As a result, T can have a derived Foldable instance: - - foldr f z (T1 a b) = f b z - foldr f z (T2 b c) = f b z - foldr f z (T3 x) = f x z - foldr f z (T4 x) = f x z - foldr f z (T5 x) = f x z - foldr _ z T6 = z - -See Note [DeriveFoldable with ExistentialQuantification] in TcGenFunctor. - -For Functor and Traversable, we must take care not to let type synonyms -unfairly reject a type for not being truly universally quantified. An -example of this is: - - type C (a :: Constraint) b = a - data T a b = C (Show a) b => MkT b - -Here, the existential context (C (Show a) b) does technically mention the last -type variable b. But this is OK, because expanding the type synonym C would -give us the context (Show a), which doesn't mention b. Therefore, we must make -sure to expand type synonyms before performing this check. Not doing so led to -#13813. --} diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs deleted file mode 100644 index 01bff1db4c..0000000000 --- a/compiler/typecheck/TcEnv.hs +++ /dev/null @@ -1,1110 +0,0 @@ --- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP, FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an - -- orphan -{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] - -- in module GHC.Hs.Extension -{-# LANGUAGE TypeFamilies #-} - -module TcEnv( - TyThing(..), TcTyThing(..), TcId, - - -- Instance environment, and InstInfo type - InstInfo(..), iDFunId, pprInstInfoDetails, - simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, - InstBindings(..), - - -- Global environment - tcExtendGlobalEnv, tcExtendTyConEnv, - tcExtendGlobalEnvImplicit, setGlobalTypeEnv, - tcExtendGlobalValEnv, - tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly, - tcLookupTyCon, tcLookupClass, - tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, - tcLookupLocatedGlobalId, tcLookupLocatedTyCon, - tcLookupLocatedClass, tcLookupAxiom, - lookupGlobal, ioLookupDataCon, - addTypecheckedBinds, - - -- Local environment - tcExtendKindEnv, tcExtendKindEnvList, - tcExtendTyVarEnv, tcExtendNameTyVarEnv, - tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds, - tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, - tcExtendBinderStack, tcExtendLocalTypeEnv, - isTypeClosedLetBndr, - - tcLookup, tcLookupLocated, tcLookupLocalIds, - tcLookupId, tcLookupIdMaybe, tcLookupTyVar, - tcLookupTcTyCon, - tcLookupLcl_maybe, - getInLocalScope, - wrongThingErr, pprBinders, - - tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, - getTypeSigNames, - tcExtendRecEnv, -- For knot-tying - - -- Tidying - tcInitTidyEnv, tcInitOpenTidyEnv, - - -- Instances - tcLookupInstance, tcGetInstEnvs, - - -- Rules - tcExtendRules, - - -- Defaults - tcGetDefaultTys, - - -- Template Haskell stuff - checkWellStaged, tcMetaTy, thLevel, - topIdLvl, isBrackStage, - - -- New Ids - newDFunName, newFamInstTyConName, - newFamInstAxiomName, - mkStableIdFromString, mkStableIdFromName, - mkWrapperName - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Iface.Env -import TcRnMonad -import TcMType -import TcType -import GHC.Iface.Load -import PrelNames -import TysWiredIn -import GHC.Types.Id -import GHC.Types.Var -import GHC.Types.Name.Reader -import GHC.Core.InstEnv -import GHC.Core.DataCon ( DataCon ) -import GHC.Core.PatSyn ( PatSyn ) -import GHC.Core.ConLike -import GHC.Core.TyCon -import GHC.Core.Type -import GHC.Core.Coercion.Axiom -import GHC.Core.Class -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import GHC.Types.Var.Env -import GHC.Driver.Types -import GHC.Driver.Session -import GHC.Types.SrcLoc -import GHC.Types.Basic hiding( SuccessFlag(..) ) -import GHC.Types.Module -import Outputable -import Encoding -import FastString -import Bag -import ListSetOps -import ErrUtils -import Maybes( MaybeErr(..), orElse ) -import qualified GHC.LanguageExtensions as LangExt -import Util ( HasDebugCallStack ) - -import Data.IORef -import Data.List (intercalate) -import Control.Monad - -{- ********************************************************************* -* * - An IO interface to looking up globals -* * -********************************************************************* -} - -lookupGlobal :: HscEnv -> Name -> IO TyThing --- A variant of lookupGlobal_maybe for the clients which are not --- interested in recovering from lookup failure and accept panic. -lookupGlobal hsc_env name - = do { - mb_thing <- lookupGlobal_maybe hsc_env name - ; case mb_thing of - Succeeded thing -> return thing - Failed msg -> pprPanic "lookupGlobal" msg - } - -lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) --- This may look up an Id that one one has previously looked up. --- If so, we are going to read its interface file, and add its bindings --- to the ExternalPackageTable. -lookupGlobal_maybe hsc_env name - = do { -- Try local envt - let mod = icInteractiveModule (hsc_IC hsc_env) - dflags = hsc_dflags hsc_env - tcg_semantic_mod = canonicalizeModuleIfHome dflags mod - - ; if nameIsLocalOrFrom tcg_semantic_mod name - then (return - (Failed (text "Can't find local name: " <+> ppr name))) - -- Internal names can happen in GHCi - else - -- Try home package table and external package table - lookupImported_maybe hsc_env name - } - -lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) --- Returns (Failed err) if we can't find the interface file for the thing -lookupImported_maybe hsc_env name - = do { mb_thing <- lookupTypeHscEnv hsc_env name - ; case mb_thing of - Just thing -> return (Succeeded thing) - Nothing -> importDecl_maybe hsc_env name - } - -importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) -importDecl_maybe hsc_env name - | Just thing <- wiredInNameTyThing_maybe name - = do { when (needWiredInHomeIface thing) - (initIfaceLoad hsc_env (loadWiredInHomeIface name)) - -- See Note [Loading instances for wired-in things] - ; return (Succeeded thing) } - | otherwise - = initIfaceLoad hsc_env (importDecl name) - -ioLookupDataCon :: HscEnv -> Name -> IO DataCon -ioLookupDataCon hsc_env name = do - mb_thing <- ioLookupDataCon_maybe hsc_env name - case mb_thing of - Succeeded thing -> return thing - Failed msg -> pprPanic "lookupDataConIO" msg - -ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon) -ioLookupDataCon_maybe hsc_env name = do - thing <- lookupGlobal hsc_env name - return $ case thing of - AConLike (RealDataCon con) -> Succeeded con - _ -> Failed $ - pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+> - text "used as a data constructor" - -addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv -addTypecheckedBinds tcg_env binds - | isHsBootOrSig (tcg_src tcg_env) = tcg_env - -- Do not add the code for record-selector bindings - -- when compiling hs-boot files - | otherwise = tcg_env { tcg_binds = foldr unionBags - (tcg_binds tcg_env) - binds } - -{- -************************************************************************ -* * -* tcLookupGlobal * -* * -************************************************************************ - -Using the Located versions (eg. tcLookupLocatedGlobal) is preferred, -unless you know that the SrcSpan in the monad is already set to the -span of the Name. --} - - -tcLookupLocatedGlobal :: Located Name -> TcM TyThing --- c.f. GHC.IfaceToCore.tcIfaceGlobal -tcLookupLocatedGlobal name - = addLocM tcLookupGlobal name - -tcLookupGlobal :: Name -> TcM TyThing --- The Name is almost always an ExternalName, but not always --- In GHCi, we may make command-line bindings (ghci> let x = True) --- that bind a GlobalId, but with an InternalName -tcLookupGlobal name - = do { -- Try local envt - env <- getGblEnv - ; case lookupNameEnv (tcg_type_env env) name of { - Just thing -> return thing ; - Nothing -> - - -- Should it have been in the local envt? - -- (NB: use semantic mod here, since names never use - -- identity module, see Note [Identity versus semantic module].) - if nameIsLocalOrFrom (tcg_semantic_mod env) name - then notFound name -- Internal names can happen in GHCi - else - - -- Try home package table and external package table - do { mb_thing <- tcLookupImported_maybe name - ; case mb_thing of - Succeeded thing -> return thing - Failed msg -> failWithTc msg - }}} - --- Look up only in this module's global env't. Don't look in imports, etc. --- Panic if it's not there. -tcLookupGlobalOnly :: Name -> TcM TyThing -tcLookupGlobalOnly name - = do { env <- getGblEnv - ; return $ case lookupNameEnv (tcg_type_env env) name of - Just thing -> thing - Nothing -> pprPanic "tcLookupGlobalOnly" (ppr name) } - -tcLookupDataCon :: Name -> TcM DataCon -tcLookupDataCon name = do - thing <- tcLookupGlobal name - case thing of - AConLike (RealDataCon con) -> return con - _ -> wrongThingErr "data constructor" (AGlobal thing) name - -tcLookupPatSyn :: Name -> TcM PatSyn -tcLookupPatSyn name = do - thing <- tcLookupGlobal name - case thing of - AConLike (PatSynCon ps) -> return ps - _ -> wrongThingErr "pattern synonym" (AGlobal thing) name - -tcLookupConLike :: Name -> TcM ConLike -tcLookupConLike name = do - thing <- tcLookupGlobal name - case thing of - AConLike cl -> return cl - _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name - -tcLookupClass :: Name -> TcM Class -tcLookupClass name = do - thing <- tcLookupGlobal name - case thing of - ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls - _ -> wrongThingErr "class" (AGlobal thing) name - -tcLookupTyCon :: Name -> TcM TyCon -tcLookupTyCon name = do - thing <- tcLookupGlobal name - case thing of - ATyCon tc -> return tc - _ -> wrongThingErr "type constructor" (AGlobal thing) name - -tcLookupAxiom :: Name -> TcM (CoAxiom Branched) -tcLookupAxiom name = do - thing <- tcLookupGlobal name - case thing of - ACoAxiom ax -> return ax - _ -> wrongThingErr "axiom" (AGlobal thing) name - -tcLookupLocatedGlobalId :: Located Name -> TcM Id -tcLookupLocatedGlobalId = addLocM tcLookupId - -tcLookupLocatedClass :: Located Name -> TcM Class -tcLookupLocatedClass = addLocM tcLookupClass - -tcLookupLocatedTyCon :: Located Name -> TcM TyCon -tcLookupLocatedTyCon = addLocM tcLookupTyCon - --- Find the instance that exactly matches a type class application. The class arguments must be precisely --- the same as in the instance declaration (modulo renaming & casts). --- -tcLookupInstance :: Class -> [Type] -> TcM ClsInst -tcLookupInstance cls tys - = do { instEnv <- tcGetInstEnvs - ; case lookupUniqueInstEnv instEnv cls tys of - Left err -> failWithTc $ text "Couldn't match instance:" <+> err - Right (inst, tys) - | uniqueTyVars tys -> return inst - | otherwise -> failWithTc errNotExact - } - where - errNotExact = text "Not an exact match (i.e., some variables get instantiated)" - - uniqueTyVars tys = all isTyVarTy tys - && hasNoDups (map (getTyVar "tcLookupInstance") tys) - -tcGetInstEnvs :: TcM InstEnvs --- Gets both the external-package inst-env --- and the home-pkg inst env (includes module being compiled) -tcGetInstEnvs = do { eps <- getEps - ; env <- getGblEnv - ; return (InstEnvs { ie_global = eps_inst_env eps - , ie_local = tcg_inst_env env - , ie_visible = tcVisibleOrphanMods env }) } - -instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where - lookupThing = tcLookupGlobal - -{- -************************************************************************ -* * - Extending the global environment -* * -************************************************************************ --} - -setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv --- Use this to update the global type env --- It updates both * the normal tcg_type_env field --- * the tcg_type_env_var field seen by interface files -setGlobalTypeEnv tcg_env new_type_env - = do { -- Sync the type-envt variable seen by interface files - writeMutVar (tcg_type_env_var tcg_env) new_type_env - ; return (tcg_env { tcg_type_env = new_type_env }) } - - -tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r - -- Just extend the global environment with some TyThings - -- Do not extend tcg_tcs, tcg_patsyns etc -tcExtendGlobalEnvImplicit things thing_inside - = do { tcg_env <- getGblEnv - ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things - ; tcg_env' <- setGlobalTypeEnv tcg_env ge' - ; setGblEnv tcg_env' thing_inside } - -tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r - -- Given a mixture of Ids, TyCons, Classes, all defined in the - -- module being compiled, extend the global environment -tcExtendGlobalEnv things thing_inside - = do { env <- getGblEnv - ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env, - tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env } - ; setGblEnv env' $ - tcExtendGlobalEnvImplicit things thing_inside - } - -tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r - -- Given a mixture of Ids, TyCons, Classes, all defined in the - -- module being compiled, extend the global environment -tcExtendTyConEnv tycons thing_inside - = do { env <- getGblEnv - ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env } - ; setGblEnv env' $ - tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside - } - -tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a - -- Same deal as tcExtendGlobalEnv, but for Ids -tcExtendGlobalValEnv ids thing_inside - = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside - -tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r --- Extend the global environments for the type/class knot tying game --- Just like tcExtendGlobalEnv, except the argument is a list of pairs -tcExtendRecEnv gbl_stuff thing_inside - = do { tcg_env <- getGblEnv - ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff - tcg_env' = tcg_env { tcg_type_env = ge' } - -- No need for setGlobalTypeEnv (which side-effects the - -- tcg_type_env_var); tcExtendRecEnv is used just - -- when kind-check a group of type/class decls. It would - -- in any case be wrong for an interface-file decl to end up - -- with a TcTyCon in it! - ; setGblEnv tcg_env' thing_inside } - -{- -************************************************************************ -* * -\subsection{The local environment} -* * -************************************************************************ --} - -tcLookupLocated :: Located Name -> TcM TcTyThing -tcLookupLocated = addLocM tcLookup - -tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) -tcLookupLcl_maybe name - = do { local_env <- getLclTypeEnv - ; return (lookupNameEnv local_env name) } - -tcLookup :: Name -> TcM TcTyThing -tcLookup name = do - local_env <- getLclTypeEnv - case lookupNameEnv local_env name of - Just thing -> return thing - Nothing -> AGlobal <$> tcLookupGlobal name - -tcLookupTyVar :: Name -> TcM TcTyVar -tcLookupTyVar name - = do { thing <- tcLookup name - ; case thing of - ATyVar _ tv -> return tv - _ -> pprPanic "tcLookupTyVar" (ppr name) } - -tcLookupId :: Name -> TcM Id --- Used when we aren't interested in the binding level, nor refinement. --- The "no refinement" part means that we return the un-refined Id regardless --- --- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId) -tcLookupId name = do - thing <- tcLookupIdMaybe name - case thing of - Just id -> return id - _ -> pprPanic "tcLookupId" (ppr name) - -tcLookupIdMaybe :: Name -> TcM (Maybe Id) -tcLookupIdMaybe name - = do { thing <- tcLookup name - ; case thing of - ATcId { tct_id = id} -> return $ Just id - AGlobal (AnId id) -> return $ Just id - _ -> return Nothing } - -tcLookupLocalIds :: [Name] -> TcM [TcId] --- We expect the variables to all be bound, and all at --- the same level as the lookup. Only used in one place... -tcLookupLocalIds ns - = do { env <- getLclEnv - ; return (map (lookup (tcl_env env)) ns) } - where - lookup lenv name - = case lookupNameEnv lenv name of - Just (ATcId { tct_id = id }) -> id - _ -> pprPanic "tcLookupLocalIds" (ppr name) - --- inferInitialKind has made a suitably-shaped kind for the type or class --- Look it up in the local environment. This is used only for tycons --- that we're currently type-checking, so we're sure to find a TcTyCon. -tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon -tcLookupTcTyCon name = do - thing <- tcLookup name - case thing of - ATcTyCon tc -> return tc - _ -> pprPanic "tcLookupTcTyCon" (ppr name) - -getInLocalScope :: TcM (Name -> Bool) -getInLocalScope = do { lcl_env <- getLclTypeEnv - ; return (`elemNameEnv` lcl_env) } - -tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r --- Used only during kind checking, for TcThings that are --- ATcTyCon or APromotionErr --- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr -tcExtendKindEnvList things thing_inside - = do { traceTc "tcExtendKindEnvList" (ppr things) - ; updLclEnv upd_env thing_inside } - where - upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things } - -tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r --- A variant of tcExtendKindEvnList -tcExtendKindEnv extra_env thing_inside - = do { traceTc "tcExtendKindEnv" (ppr extra_env) - ; updLclEnv upd_env thing_inside } - where - upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env } - ------------------------ --- Scoped type and kind variables -tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r -tcExtendTyVarEnv tvs thing_inside - = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside - -tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r -tcExtendNameTyVarEnv binds thing_inside - -- this should be used only for explicitly mentioned scoped variables. - -- thus, no coercion variables - = do { tc_extend_local_env NotTopLevel - [(name, ATyVar name tv) | (name, tv) <- binds] $ - tcExtendBinderStack tv_binds $ - thing_inside } - where - tv_binds :: [TcBinder] - tv_binds = [TcTvBndr name tv | (name,tv) <- binds] - -isTypeClosedLetBndr :: Id -> Bool --- See Note [Bindings with closed types] in TcRnTypes -isTypeClosedLetBndr = noFreeVarsOfType . idType - -tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a --- Used for binding the recursive uses of Ids in a binding --- both top-level value bindings and nested let/where-bindings --- Does not extend the TcBinderStack -tcExtendRecIds pairs thing_inside - = tc_extend_local_env NotTopLevel - [ (name, ATcId { tct_id = let_id - , tct_info = NonClosedLet emptyNameSet False }) - | (name, let_id) <- pairs ] $ - thing_inside - -tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a --- Used for binding the Ids that have a complete user type signature --- Does not extend the TcBinderStack -tcExtendSigIds top_lvl sig_ids thing_inside - = tc_extend_local_env top_lvl - [ (idName id, ATcId { tct_id = id - , tct_info = info }) - | id <- sig_ids - , let closed = isTypeClosedLetBndr id - info = NonClosedLet emptyNameSet closed ] - thing_inside - - -tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed - -> [TcId] -> TcM a -> TcM a --- Used for both top-level value bindings and nested let/where-bindings --- Adds to the TcBinderStack too -tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) - ids thing_inside - = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $ - tc_extend_local_env top_lvl - [ (idName id, ATcId { tct_id = id - , tct_info = mk_tct_info id }) - | id <- ids ] - thing_inside - where - mk_tct_info id - | type_closed && isEmptyNameSet rhs_fvs = ClosedLet - | otherwise = NonClosedLet rhs_fvs type_closed - where - name = idName id - rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet - type_closed = isTypeClosedLetBndr id && - (fv_type_closed || hasCompleteSig sig_fn name) - -tcExtendIdEnv :: [TcId] -> TcM a -> TcM a --- For lambda-bound and case-bound Ids --- Extends the TcBinderStack as well -tcExtendIdEnv ids thing_inside - = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside - -tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a --- Exactly like tcExtendIdEnv2, but for a single (name,id) pair -tcExtendIdEnv1 name id thing_inside - = tcExtendIdEnv2 [(name,id)] thing_inside - -tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a -tcExtendIdEnv2 names_w_ids thing_inside - = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel - | (_,mono_id) <- names_w_ids ] $ - tc_extend_local_env NotTopLevel - [ (name, ATcId { tct_id = id - , tct_info = NotLetBound }) - | (name,id) <- names_w_ids] - thing_inside - -tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a -tc_extend_local_env top_lvl extra_env thing_inside --- Precondition: the argument list extra_env has TcTyThings --- that ATcId or ATyVar, but nothing else --- --- Invariant: the ATcIds are fully zonked. Reasons: --- (a) The kinds of the forall'd type variables are defaulted --- (see Kind.defaultKind, done in skolemiseQuantifiedTyVar) --- (b) There are no via-Indirect occurrences of the bound variables --- in the types, because instantiation does not look through such things --- (c) The call to tyCoVarsOfTypes is ok without looking through refs - --- The second argument of type TyVarSet is a set of type variables --- that are bound together with extra_env and should not be regarded --- as free in the types of extra_env. - = do { traceTc "tc_extend_local_env" (ppr extra_env) - ; env0 <- getLclEnv - ; let env1 = tcExtendLocalTypeEnv env0 extra_env - ; stage <- getStage - ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1 - ; setLclEnv env2 thing_inside } - where - extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv - -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously - -- Reason for extending LocalRdrEnv: after running a TH splice we need - -- to do renaming. - extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env - , tcl_th_bndrs = th_bndrs }) - = env { tcl_rdr = extendLocalRdrEnvList rdr_env - [ n | (n, _) <- pairs, isInternalName n ] - -- The LocalRdrEnv contains only non-top-level names - -- (GlobalRdrEnv handles the top level) - , tcl_th_bndrs = extendNameEnvList th_bndrs -- We only track Ids in tcl_th_bndrs - [(n, thlvl) | (n, ATcId {}) <- pairs] } - -tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv -tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things - = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things } - -{- ********************************************************************* -* * - The TcBinderStack -* * -********************************************************************* -} - -tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a -tcExtendBinderStack bndrs thing_inside - = do { traceTc "tcExtendBinderStack" (ppr bndrs) - ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) - thing_inside } - -tcInitTidyEnv :: TcM TidyEnv --- We initialise the "tidy-env", used for tidying types before printing, --- by building a reverse map from the in-scope type variables to the --- OccName that the programmer originally used for them -tcInitTidyEnv - = do { lcl_env <- getLclEnv - ; go emptyTidyEnv (tcl_bndrs lcl_env) } - where - go (env, subst) [] - = return (env, subst) - go (env, subst) (b : bs) - | TcTvBndr name tyvar <- b - = do { let (env', occ') = tidyOccName env (nameOccName name) - name' = tidyNameOcc name occ' - tyvar1 = setTyVarName tyvar name' - ; tyvar2 <- zonkTcTyVarToTyVar tyvar1 - -- Be sure to zonk here! Tidying applies to zonked - -- types, so if we don't zonk we may create an - -- ill-kinded type (#14175) - ; go (env', extendVarEnv subst tyvar tyvar2) bs } - | otherwise - = go (env, subst) bs - --- | Get a 'TidyEnv' that includes mappings for all vars free in the given --- type. Useful when tidying open types. -tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv -tcInitOpenTidyEnv tvs - = do { env1 <- tcInitTidyEnv - ; let env2 = tidyFreeTyCoVars env1 tvs - ; return env2 } - - - -{- ********************************************************************* -* * - Adding placeholders -* * -********************************************************************* -} - -tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a --- See Note [AFamDataCon: not promoting data family constructors] -tcAddDataFamConPlaceholders inst_decls thing_inside - = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE) - | lid <- inst_decls, con <- get_cons lid ] - thing_inside - -- Note [AFamDataCon: not promoting data family constructors] - where - -- get_cons extracts the *constructor* bindings of the declaration - get_cons :: LInstDecl GhcRn -> [Name] - get_cons (L _ (TyFamInstD {})) = [] - get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid - get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } })) - = concatMap (get_fi_cons . unLoc) fids - get_cons (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec - get_cons (L _ (XInstDecl nec)) = noExtCon nec - - get_fi_cons :: DataFamInstDecl GhcRn -> [Name] - get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}}) - = map unLoc $ concatMap (getConNames . unLoc) cons - get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_rhs = XHsDataDefn nec }}}) - = noExtCon nec - get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn nec))) = noExtCon nec - get_fi_cons (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec - - -tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a --- See Note [Don't promote pattern synonyms] -tcAddPatSynPlaceholders pat_syns thing_inside - = tcExtendKindEnvList [ (name, APromotionErr PatSynPE) - | PSB{ psb_id = L _ name } <- pat_syns ] - thing_inside - -getTypeSigNames :: [LSig GhcRn] -> NameSet --- Get the names that have a user type sig -getTypeSigNames sigs - = foldr get_type_sig emptyNameSet sigs - where - get_type_sig :: LSig GhcRn -> NameSet -> NameSet - get_type_sig sig ns = - case sig of - L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names) - L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names) - _ -> ns - - -{- Note [AFamDataCon: not promoting data family constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family T a - data instance T Int = MkT - data Proxy (a :: k) - data S = MkS (Proxy 'MkT) - -Is it ok to use the promoted data family instance constructor 'MkT' in -the data declaration for S (where both declarations live in the same module)? -No, we don't allow this. It *might* make sense, but at least it would mean that -we'd have to interleave typechecking instances and data types, whereas at -present we do data types *then* instances. - -So to check for this we put in the TcLclEnv a binding for all the family -constructors, bound to AFamDataCon, so that if we trip over 'MkT' when -type checking 'S' we'll produce a decent error message. - -#12088 describes this limitation. Of course, when MkT and S live in -different modules then all is well. - -Note [Don't promote pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We never promote pattern synonyms. - -Consider this (#11265): - pattern A = True - instance Eq A -We want a civilised error message from the occurrence of 'A' -in the instance, yet 'A' really has not yet been type checked. - -Similarly (#9161) - {-# LANGUAGE PatternSynonyms, DataKinds #-} - pattern A = () - b :: A - b = undefined -Here, the type signature for b mentions A. But A is a pattern -synonym, which is typechecked as part of a group of bindings (for very -good reasons; a view pattern in the RHS may mention a value binding). -It is entirely reasonable to reject this, but to do so we need A to be -in the kind environment when kind-checking the signature for B. - -Hence tcAddPatSynPlaceholers adds a binding - A -> APromotionErr PatSynPE -to the environment. Then TcHsType.tcTyVar will find A in the kind -environment, and will give a 'wrongThingErr' as a result. But the -lookup of A won't fail. - - -************************************************************************ -* * -\subsection{Rules} -* * -************************************************************************ --} - -tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a - -- Just pop the new rules into the EPS and envt resp - -- All the rules come from an interface file, not source - -- Nevertheless, some may be for this module, if we read - -- its interface instead of its source code -tcExtendRules lcl_rules thing_inside - = do { env <- getGblEnv - ; let - env' = env { tcg_rules = lcl_rules ++ tcg_rules env } - ; setGblEnv env' thing_inside } - -{- -************************************************************************ -* * - Meta level -* * -************************************************************************ --} - -checkWellStaged :: SDoc -- What the stage check is for - -> ThLevel -- Binding level (increases inside brackets) - -> ThLevel -- Use stage - -> TcM () -- Fail if badly staged, adding an error -checkWellStaged pp_thing bind_lvl use_lvl - | use_lvl >= bind_lvl -- OK! Used later than bound - = return () -- E.g. \x -> [| $(f x) |] - - | bind_lvl == outerLevel -- GHC restriction on top level splices - = stageRestrictionError pp_thing - - | otherwise -- Badly staged - = failWithTc $ -- E.g. \x -> $(f x) - text "Stage error:" <+> pp_thing <+> - hsep [text "is bound at stage" <+> ppr bind_lvl, - text "but used at stage" <+> ppr use_lvl] - -stageRestrictionError :: SDoc -> TcM a -stageRestrictionError pp_thing - = failWithTc $ - sep [ text "GHC stage restriction:" - , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation," - , text "and must be imported, not defined locally"])] - -topIdLvl :: Id -> ThLevel --- Globals may either be imported, or may be from an earlier "chunk" --- (separated by declaration splices) of this module. The former --- *can* be used inside a top-level splice, but the latter cannot. --- Hence we give the former impLevel, but the latter topLevel --- E.g. this is bad: --- x = [| foo |] --- $( f x ) --- By the time we are processing the $(f x), the binding for "x" --- will be in the global env, not the local one. -topIdLvl id | isLocalId id = outerLevel - | otherwise = impLevel - -tcMetaTy :: Name -> TcM Type --- Given the name of a Template Haskell data type, --- return the type --- E.g. given the name "Expr" return the type "Expr" -tcMetaTy tc_name = do - t <- tcLookupTyCon tc_name - return (mkTyConTy t) - -isBrackStage :: ThStage -> Bool -isBrackStage (Brack {}) = True -isBrackStage _other = False - -{- -************************************************************************ -* * - getDefaultTys -* * -************************************************************************ --} - -tcGetDefaultTys :: TcM ([Type], -- Default types - (Bool, -- True <=> Use overloaded strings - Bool)) -- True <=> Use extended defaulting rules -tcGetDefaultTys - = do { dflags <- getDynFlags - ; let ovl_strings = xopt LangExt.OverloadedStrings dflags - extended_defaults = xopt LangExt.ExtendedDefaultRules dflags - -- See also #1974 - flags = (ovl_strings, extended_defaults) - - ; mb_defaults <- getDeclaredDefaultTys - ; case mb_defaults of { - Just tys -> return (tys, flags) ; - -- User-supplied defaults - Nothing -> do - - -- No use-supplied default - -- Use [Integer, Double], plus modifications - { integer_ty <- tcMetaTy integerTyConName - ; list_ty <- tcMetaTy listTyConName - ; checkWiredInTyCon doubleTyCon - ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty] - -- Note [Extended defaults] - ++ [integer_ty, doubleTy] - ++ opt_deflt ovl_strings [stringTy] - ; return (deflt_tys, flags) } } } - where - opt_deflt True xs = xs - opt_deflt False _ = [] - -{- -Note [Extended defaults] -~~~~~~~~~~~~~~~~~~~~~ -In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we -try when defaulting. This has very little real impact, except in the following case. -Consider: - Text.Printf.printf "hello" -This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't -want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to -default the 'a' to (), rather than to Integer (which is what would otherwise happen; -and then GHCi doesn't attempt to print the (). So in interactive mode, we add -() to the list of defaulting types. See #1200. - -Additionally, the list type [] is added as a default specialization for -Traversable and Foldable. As such the default default list now has types of -varying kinds, e.g. ([] :: * -> *) and (Integer :: *). - -************************************************************************ -* * -\subsection{The InstInfo type} -* * -************************************************************************ - -The InstInfo type summarises the information in an instance declaration - - instance c => k (t tvs) where b - -It is used just for *local* instance decls (not ones from interface files). -But local instance decls includes - - derived ones - - generic ones -as well as explicit user written ones. --} - -data InstInfo a - = InstInfo - { iSpec :: ClsInst -- Includes the dfun id - , iBinds :: InstBindings a - } - -iDFunId :: InstInfo a -> DFunId -iDFunId info = instanceDFunId (iSpec info) - -data InstBindings a - = InstBindings - { ib_tyvars :: [Name] -- Names of the tyvars from the instance head - -- that are lexically in scope in the bindings - -- Must correspond 1-1 with the forall'd tyvars - -- of the dfun Id. When typechecking, we are - -- going to extend the typechecker's envt with - -- ib_tyvars -> dfun_forall_tyvars - - , ib_binds :: LHsBinds a -- Bindings for the instance methods - - , ib_pragmas :: [LSig a] -- User pragmas recorded for generating - -- specialised instances - - , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should - -- be enabled when type-checking - -- this instance; needed for - -- GeneralizedNewtypeDeriving - - , ib_derived :: Bool - -- True <=> This code was generated by GHC from a deriving clause - -- or standalone deriving declaration - -- Used only to improve error messages - } - -instance (OutputableBndrId a) - => Outputable (InstInfo (GhcPass a)) where - ppr = pprInstInfoDetails - -pprInstInfoDetails :: (OutputableBndrId a) - => InstInfo (GhcPass a) -> SDoc -pprInstInfoDetails info - = hang (pprInstanceHdr (iSpec info) <+> text "where") - 2 (details (iBinds info)) - where - details (InstBindings { ib_pragmas = p, ib_binds = b }) = - pprDeclList (pprLHsBindsForUser b p) - -simpleInstInfoClsTy :: InstInfo a -> (Class, Type) -simpleInstInfoClsTy info = case instanceHead (iSpec info) of - (_, cls, [ty]) -> (cls, ty) - _ -> panic "simpleInstInfoClsTy" - -simpleInstInfoTy :: InstInfo a -> Type -simpleInstInfoTy info = snd (simpleInstInfoClsTy info) - -simpleInstInfoTyCon :: InstInfo a -> TyCon - -- Gets the type constructor for a simple instance declaration, - -- i.e. one of the form instance (...) => C (T a b c) where ... -simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) - --- | Make a name for the dict fun for an instance decl. It's an *external* --- name, like other top-level names, and hence must be made with --- newGlobalBinder. -newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name -newDFunName clas tys loc - = do { is_boot <- tcIsHsBootOrSig - ; mod <- getModule - ; let info_string = occNameString (getOccName clas) ++ - concatMap (occNameString.getDFunTyKey) tys - ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) - ; newGlobalBinder mod dfun_occ loc } - -newFamInstTyConName :: Located Name -> [Type] -> TcM Name -newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] - -newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name -newFamInstAxiomName (L loc name) branches - = mk_fam_inst_name mkInstTyCoOcc loc name branches - -mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name -mk_fam_inst_name adaptOcc loc tc_name tyss - = do { mod <- getModule - ; let info_string = occNameString (getOccName tc_name) ++ - intercalate "|" ty_strings - ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) - ; newGlobalBinder mod (adaptOcc occ) loc } - where - ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss - -{- -Stable names used for foreign exports and annotations. -For stable names, the name must be unique (see #1533). If the -same thing has several stable Ids based on it, the -top-level bindings generated must not have the same name. -Hence we create an External name (doesn't change), and we -append a Unique to the string right here. --} - -mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId -mkStableIdFromString str sig_ty loc occ_wrapper = do - uniq <- newUnique - mod <- getModule - name <- mkWrapperName "stable" str - let occ = mkVarOccFS name :: OccName - gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name - id = mkExportedVanillaId gnm sig_ty :: Id - return id - -mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId -mkStableIdFromName nm = mkStableIdFromString (getOccString nm) - -mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m) - => String -> String -> m FastString -mkWrapperName what nameBase - = do dflags <- getDynFlags - thisMod <- getModule - let -- Note [Generating fresh names for ccall wrapper] - wrapperRef = nextWrapperNum dflags - pkg = unitIdString (moduleUnitId thisMod) - mod = moduleNameString (moduleName thisMod) - wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env -> - let num = lookupWithDefaultModuleEnv mod_env 0 thisMod - mod_env' = extendModuleEnv mod_env thisMod (num+1) - in (mod_env', num) - let components = [what, show wrapperNum, pkg, mod, nameBase] - return $ mkFastString $ zEncodeString $ intercalate ":" components - -{- -Note [Generating fresh names for FFI wrappers] - -We used to use a unique, rather than nextWrapperNum, to distinguish -between FFI wrapper functions. However, the wrapper names that we -generate are external names. This means that if a call to them ends up -in an unfolding, then we can't alpha-rename them, and thus if the -unique randomly changes from one compile to another then we get a -spurious ABI change (#4012). - -The wrapper counter has to be per-module, not global, so that the number we end -up using is not dependent on the modules compiled before the current one. --} - -{- -************************************************************************ -* * -\subsection{Errors} -* * -************************************************************************ --} - -pprBinders :: [Name] -> SDoc --- Used in error messages --- Use quotes for a single one; they look a bit "busy" for several -pprBinders [bndr] = quotes (ppr bndr) -pprBinders bndrs = pprWithCommas ppr bndrs - -notFound :: Name -> TcM TyThing -notFound name - = do { lcl_env <- getLclEnv - ; let stage = tcl_th_ctxt lcl_env - ; case stage of -- See Note [Out of scope might be a staging error] - Splice {} - | isUnboundName name -> failM -- If the name really isn't in scope - -- don't report it again (#11941) - | otherwise -> stageRestrictionError (quotes (ppr name)) - _ -> failWithTc $ - vcat[text "GHC internal error:" <+> quotes (ppr name) <+> - text "is not in scope during type checking, but it passed the renamer", - text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)] - -- Take care: printing the whole gbl env can - -- cause an infinite loop, in the case where we - -- are in the middle of a recursive TyCon/Class group; - -- so let's just not print it! Getting a loop here is - -- very unhelpful, because it hides one compiler bug with another - } - -wrongThingErr :: String -> TcTyThing -> Name -> TcM a --- It's important that this only calls pprTcTyThingCategory, which in --- turn does not look at the details of the TcTyThing. --- See Note [Placeholder PatSyn kinds] in TcBinds -wrongThingErr expected thing name - = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - text "used as a" <+> text expected) - -{- Note [Out of scope might be a staging error] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - x = 3 - data T = MkT $(foo x) - -where 'foo' is imported from somewhere. - -This is really a staging error, because we can't run code involving 'x'. -But in fact the type checker processes types first, so 'x' won't even be -in the type envt when we look for it in $(foo x). So inside splices we -report something missing from the type env as a staging error. -See #5752 and #5795. --} diff --git a/compiler/typecheck/TcEnv.hs-boot b/compiler/typecheck/TcEnv.hs-boot deleted file mode 100644 index 23278b8d34..0000000000 --- a/compiler/typecheck/TcEnv.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module TcEnv where - -import TcRnTypes( TcM ) -import GHC.Types.Var.Env( TidyEnv ) - --- Annoyingly, there's a recursion between tcInitTidyEnv --- (which does zonking and hence needs TcMType) and --- addErrTc etc which live in TcRnMonad. Rats. -tcInitTidyEnv :: TcM TidyEnv - diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs deleted file mode 100644 index 0fbef80ec0..0000000000 --- a/compiler/typecheck/TcErrors.hs +++ /dev/null @@ -1,2981 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE LambdaCase #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcErrors( - reportUnsolved, reportAllUnsolved, warnAllUnsolved, - warnDefaulting, - - solverDepthErrorTcS - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnTypes -import TcRnMonad -import Constraint -import GHC.Core.Predicate -import TcMType -import TcUnify( occCheckForErrors, MetaTyVarUpdateResult(..) ) -import TcEnv( tcInitTidyEnv ) -import TcType -import TcOrigin -import GHC.Rename.Unbound ( unknownNameSuggestions ) -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) -import GHC.Core.Unify ( tcMatchTys ) -import GHC.Types.Module -import FamInst -import GHC.Core.FamInstEnv ( flattenTys ) -import Inst -import GHC.Core.InstEnv -import GHC.Core.TyCon -import GHC.Core.Class -import GHC.Core.DataCon -import TcEvidence -import TcEvTerm -import GHC.Hs.Binds ( PatSynBind(..) ) -import GHC.Types.Name -import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual ) -import PrelNames ( typeableClassName ) -import GHC.Types.Id -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Name.Set -import Bag -import ErrUtils ( ErrMsg, errDoc, pprLocErrMsg ) -import GHC.Types.Basic -import GHC.Core.ConLike ( ConLike(..)) -import Util -import FastString -import Outputable -import GHC.Types.SrcLoc -import GHC.Driver.Session -import ListSetOps ( equivClasses ) -import Maybes -import qualified GHC.LanguageExtensions as LangExt -import FV ( fvVarList, unionFV ) - -import Control.Monad ( when ) -import Data.Foldable ( toList ) -import Data.List ( partition, mapAccumL, nub, sortBy, unfoldr ) - -import {-# SOURCE #-} TcHoleErrors ( findValidHoleFits ) - --- import Data.Semigroup ( Semigroup ) -import qualified Data.Semigroup as Semigroup - - -{- -************************************************************************ -* * -\section{Errors and contexts} -* * -************************************************************************ - -ToDo: for these error messages, should we note the location as coming -from the insts, or just whatever seems to be around in the monad just -now? - -Note [Deferring coercion errors to runtime] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -While developing, sometimes it is desirable to allow compilation to succeed even -if there are type errors in the code. Consider the following case: - - module Main where - - a :: Int - a = 'a' - - main = print "b" - -Even though `a` is ill-typed, it is not used in the end, so if all that we're -interested in is `main` it is handy to be able to ignore the problems in `a`. - -Since we treat type equalities as evidence, this is relatively simple. Whenever -we run into a type mismatch in TcUnify, we normally just emit an error. But it -is always safe to defer the mismatch to the main constraint solver. If we do -that, `a` will get transformed into - - co :: Int ~ Char - co = ... - - a :: Int - a = 'a' `cast` co - -The constraint solver would realize that `co` is an insoluble constraint, and -emit an error with `reportUnsolved`. But we can also replace the right-hand side -of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program -to compile, and it will run fine unless we evaluate `a`. This is what -`deferErrorsToRuntime` does. - -It does this by keeping track of which errors correspond to which coercion -in TcErrors. TcErrors.reportTidyWanteds does not print the errors -and does not fail if -fdefer-type-errors is on, so that we can continue -compilation. The errors are turned into warnings in `reportUnsolved`. --} - --- | Report unsolved goals as errors or warnings. We may also turn some into --- deferred run-time errors if `-fdefer-type-errors` is on. -reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) -reportUnsolved wanted - = do { binds_var <- newTcEvBinds - ; defer_errors <- goptM Opt_DeferTypeErrors - ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283 - ; let type_errors | not defer_errors = TypeError - | warn_errors = TypeWarn (Reason Opt_WarnDeferredTypeErrors) - | otherwise = TypeDefer - - ; defer_holes <- goptM Opt_DeferTypedHoles - ; warn_holes <- woptM Opt_WarnTypedHoles - ; let expr_holes | not defer_holes = HoleError - | warn_holes = HoleWarn - | otherwise = HoleDefer - - ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures - ; let type_holes | not partial_sigs = HoleError - | warn_partial_sigs = HoleWarn - | otherwise = HoleDefer - - ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables - ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables - ; let out_of_scope_holes | not defer_out_of_scope = HoleError - | warn_out_of_scope = HoleWarn - | otherwise = HoleDefer - - ; report_unsolved type_errors expr_holes - type_holes out_of_scope_holes - binds_var wanted - - ; ev_binds <- getTcEvBindsMap binds_var - ; return (evBindMapBinds ev_binds)} - --- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on --- However, do not make any evidence bindings, because we don't --- have any convenient place to put them. --- NB: Type-level holes are OK, because there are no bindings. --- See Note [Deferring coercion errors to runtime] --- Used by solveEqualities for kind equalities --- (see Note [Fail fast on kind errors] in TcSimplify) --- and for simplifyDefault. -reportAllUnsolved :: WantedConstraints -> TcM () -reportAllUnsolved wanted - = do { ev_binds <- newNoTcEvBinds - - ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures - ; let type_holes | not partial_sigs = HoleError - | warn_partial_sigs = HoleWarn - | otherwise = HoleDefer - - ; report_unsolved TypeError HoleError type_holes HoleError - ev_binds wanted } - --- | Report all unsolved goals as warnings (but without deferring any errors to --- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in --- TcSimplify -warnAllUnsolved :: WantedConstraints -> TcM () -warnAllUnsolved wanted - = do { ev_binds <- newTcEvBinds - ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn - ev_binds wanted } - --- | Report unsolved goals as errors or warnings. -report_unsolved :: TypeErrorChoice -- Deferred type errors - -> HoleChoice -- Expression holes - -> HoleChoice -- Type holes - -> HoleChoice -- Out of scope holes - -> EvBindsVar -- cec_binds - -> WantedConstraints -> TcM () -report_unsolved type_errors expr_holes - type_holes out_of_scope_holes binds_var wanted - | isEmptyWC wanted - = return () - | otherwise - = do { traceTc "reportUnsolved {" $ - vcat [ text "type errors:" <+> ppr type_errors - , text "expr holes:" <+> ppr expr_holes - , text "type holes:" <+> ppr type_holes - , text "scope holes:" <+> ppr out_of_scope_holes ] - ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) - - ; wanted <- zonkWC wanted -- Zonk to reveal all information - -- If we are deferring we are going to need /all/ evidence around, - -- including the evidence produced by unflattening (zonkWC) - ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs - free_tvs = tyCoVarsOfWCList wanted - - ; traceTc "reportUnsolved (after zonking):" $ - vcat [ text "Free tyvars:" <+> pprTyVars free_tvs - , text "Tidy env:" <+> ppr tidy_env - , text "Wanted:" <+> ppr wanted ] - - ; warn_redundant <- woptM Opt_WarnRedundantConstraints - ; let err_ctxt = CEC { cec_encl = [] - , cec_tidy = tidy_env - , cec_defer_type_errors = type_errors - , cec_expr_holes = expr_holes - , cec_type_holes = type_holes - , cec_out_of_scope_holes = out_of_scope_holes - , cec_suppress = insolubleWC wanted - -- See Note [Suppressing error messages] - -- Suppress low-priority errors if there - -- are insoluble errors anywhere; - -- See #15539 and c.f. setting ic_status - -- in TcSimplify.setImplicationStatus - , cec_warn_redundant = warn_redundant - , cec_binds = binds_var } - - ; tc_lvl <- getTcLevel - ; reportWanteds err_ctxt tc_lvl wanted - ; traceTc "reportUnsolved }" empty } - --------------------------------------------- --- Internal functions --------------------------------------------- - --- | An error Report collects messages categorised by their importance. --- See Note [Error report] for details. -data Report - = Report { report_important :: [SDoc] - , report_relevant_bindings :: [SDoc] - , report_valid_hole_fits :: [SDoc] - } - -instance Outputable Report where -- Debugging only - ppr (Report { report_important = imp - , report_relevant_bindings = rel - , report_valid_hole_fits = val }) - = vcat [ text "important:" <+> vcat imp - , text "relevant:" <+> vcat rel - , text "valid:" <+> vcat val ] - -{- Note [Error report] -The idea is that error msgs are divided into three parts: the main msg, the -context block (\"In the second argument of ...\"), and the relevant bindings -block, which are displayed in that order, with a mark to divide them. The -idea is that the main msg ('report_important') varies depending on the error -in question, but context and relevant bindings are always the same, which -should simplify visual parsing. - -The context is added when the Report is passed off to 'mkErrorReport'. -Unfortunately, unlike the context, the relevant bindings are added in -multiple places so they have to be in the Report. --} - -instance Semigroup Report where - Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2) - -instance Monoid Report where - mempty = Report [] [] [] - mappend = (Semigroup.<>) - --- | Put a doc into the important msgs block. -important :: SDoc -> Report -important doc = mempty { report_important = [doc] } - --- | Put a doc into the relevant bindings block. -relevant_bindings :: SDoc -> Report -relevant_bindings doc = mempty { report_relevant_bindings = [doc] } - --- | Put a doc into the valid hole fits block. -valid_hole_fits :: SDoc -> Report -valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] } - -data TypeErrorChoice -- What to do for type errors found by the type checker - = TypeError -- A type error aborts compilation with an error message - | TypeWarn WarnReason - -- A type error is deferred to runtime, plus a compile-time warning - -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors) - -- but it isn't for the Safe Haskell Overlapping Instances warnings - -- see warnAllUnsolved - | TypeDefer -- A type error is deferred to runtime; no error or warning at compile time - -data HoleChoice - = HoleError -- A hole is a compile-time error - | HoleWarn -- Defer to runtime, emit a compile-time warning - | HoleDefer -- Defer to runtime, no warning - -instance Outputable HoleChoice where - ppr HoleError = text "HoleError" - ppr HoleWarn = text "HoleWarn" - ppr HoleDefer = text "HoleDefer" - -instance Outputable TypeErrorChoice where - ppr TypeError = text "TypeError" - ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason - ppr TypeDefer = text "TypeDefer" - -data ReportErrCtxt - = CEC { cec_encl :: [Implication] -- Enclosing implications - -- (innermost first) - -- ic_skols and givens are tidied, rest are not - , cec_tidy :: TidyEnv - - , cec_binds :: EvBindsVar -- Make some errors (depending on cec_defer) - -- into warnings, and emit evidence bindings - -- into 'cec_binds' for unsolved constraints - - , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime - - -- cec_expr_holes is a union of: - -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' - -- cec_out_of_scope_holes - a set of variables which are - -- out of scope: 'x', 'y', 'bar' - , cec_expr_holes :: HoleChoice -- Holes in expressions - , cec_type_holes :: HoleChoice -- Holes in types - , cec_out_of_scope_holes :: HoleChoice -- Out of scope holes - - , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints - - , cec_suppress :: Bool -- True <=> More important errors have occurred, - -- so create bindings if need be, but - -- don't issue any more errors/warnings - -- See Note [Suppressing error messages] - } - -instance Outputable ReportErrCtxt where - ppr (CEC { cec_binds = bvar - , cec_defer_type_errors = dte - , cec_expr_holes = eh - , cec_type_holes = th - , cec_out_of_scope_holes = osh - , cec_warn_redundant = wr - , cec_suppress = sup }) - = text "CEC" <+> braces (vcat - [ text "cec_binds" <+> equals <+> ppr bvar - , text "cec_defer_type_errors" <+> equals <+> ppr dte - , text "cec_expr_holes" <+> equals <+> ppr eh - , text "cec_type_holes" <+> equals <+> ppr th - , text "cec_out_of_scope_holes" <+> equals <+> ppr osh - , text "cec_warn_redundant" <+> equals <+> ppr wr - , text "cec_suppress" <+> equals <+> ppr sup ]) - --- | Returns True <=> the ReportErrCtxt indicates that something is deferred -deferringAnyBindings :: ReportErrCtxt -> Bool - -- Don't check cec_type_holes, as these don't cause bindings to be deferred -deferringAnyBindings (CEC { cec_defer_type_errors = TypeError - , cec_expr_holes = HoleError - , cec_out_of_scope_holes = HoleError }) = False -deferringAnyBindings _ = True - --- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings --- at all. -noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt -noDeferredBindings ctxt = ctxt { cec_defer_type_errors = TypeError - , cec_expr_holes = HoleError - , cec_out_of_scope_holes = HoleError } - -{- Note [Suppressing error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The cec_suppress flag says "don't report any errors". Instead, just create -evidence bindings (as usual). It's used when more important errors have occurred. - -Specifically (see reportWanteds) - * If there are insoluble Givens, then we are in unreachable code and all bets - are off. So don't report any further errors. - * If there are any insolubles (eg Int~Bool), here or in a nested implication, - then suppress errors from the simple constraints here. Sometimes the - simple-constraint errors are a knock-on effect of the insolubles. - -This suppression behaviour is controlled by the Bool flag in -ReportErrorSpec, as used in reportWanteds. - -But we need to take care: flags can turn errors into warnings, and we -don't want those warnings to suppress subsequent errors (including -suppressing the essential addTcEvBind for them: #15152). So in -tryReporter we use askNoErrs to see if any error messages were -/actually/ produced; if not, we don't switch on suppression. - -A consequence is that warnings never suppress warnings, so turning an -error into a warning may allow subsequent warnings to appear that were -previously suppressed. (e.g. partial-sigs/should_fail/T14584) --} - -reportImplic :: ReportErrCtxt -> Implication -> TcM () -reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope - , ic_given = given - , ic_wanted = wanted, ic_binds = evb - , ic_status = status, ic_info = info - , ic_tclvl = tc_lvl }) - | BracketSkol <- info - , not insoluble - = return () -- For Template Haskell brackets report only - -- definite errors. The whole thing will be re-checked - -- later when we plug it in, and meanwhile there may - -- certainly be un-satisfied constraints - - | otherwise - = do { traceTc "reportImplic" (ppr implic') - ; reportWanteds ctxt' tc_lvl wanted - ; when (cec_warn_redundant ctxt) $ - warnRedundantConstraints ctxt' tcl_env info' dead_givens - ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs } - where - tcl_env = ic_env implic - insoluble = isInsolubleStatus status - (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs - info' = tidySkolemInfo env1 info - implic' = implic { ic_skols = tvs' - , ic_given = map (tidyEvVar env1) given - , ic_info = info' } - ctxt1 | CoEvBindsVar{} <- evb = noDeferredBindings ctxt - | otherwise = ctxt - -- If we go inside an implication that has no term - -- evidence (e.g. unifying under a forall), we can't defer - -- type errors. You could imagine using the /enclosing/ - -- bindings (in cec_binds), but that may not have enough stuff - -- in scope for the bindings to be well typed. So we just - -- switch off deferred type errors altogether. See #14605. - - ctxt' = ctxt1 { cec_tidy = env1 - , cec_encl = implic' : cec_encl ctxt - - , cec_suppress = insoluble || cec_suppress ctxt - -- Suppress inessential errors if there - -- are insolubles anywhere in the - -- tree rooted here, or we've come across - -- a suppress-worthy constraint higher up (#11541) - - , cec_binds = evb } - - dead_givens = case status of - IC_Solved { ics_dead = dead } -> dead - _ -> [] - - bad_telescope = case status of - IC_BadTelescope -> True - _ -> False - -warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM () --- See Note [Tracking redundant constraints] in TcSimplify -warnRedundantConstraints ctxt env info ev_vars - | null redundant_evs - = return () - - | SigSkol {} <- info - = setLclEnv env $ -- We want to add "In the type signature for f" - -- to the error context, which is a bit tiresome - addErrCtxt (text "In" <+> ppr info) $ - do { env <- getLclEnv - ; msg <- mkErrorReport ctxt env (important doc) - ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } - - | otherwise -- But for InstSkol there already *is* a surrounding - -- "In the instance declaration for Eq [a]" context - -- and we don't want to say it twice. Seems a bit ad-hoc - = do { msg <- mkErrorReport ctxt env (important doc) - ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } - where - doc = text "Redundant constraint" <> plural redundant_evs <> colon - <+> pprEvVarTheta redundant_evs - - redundant_evs = - filterOut is_type_error $ - case info of -- See Note [Redundant constraints in instance decls] - InstSkol -> filterOut (improving . idType) ev_vars - _ -> ev_vars - - -- See #15232 - is_type_error = isJust . userTypeError_maybe . idType - - improving pred -- (transSuperClasses p) does not include p - = any isImprovementPred (pred : transSuperClasses pred) - -reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TcTyVar] -> TcM () -reportBadTelescope ctxt env (Just telescope) skols - = do { msg <- mkErrorReport ctxt env (important doc) - ; reportError msg } - where - doc = hang (text "These kind and type variables:" <+> telescope $$ - text "are out of dependency order. Perhaps try this ordering:") - 2 (pprTyVars sorted_tvs) - - sorted_tvs = scopedSort skols - -reportBadTelescope _ _ Nothing skols - = pprPanic "reportBadTelescope" (ppr skols) - -{- Note [Redundant constraints in instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For instance declarations, we don't report unused givens if -they can give rise to improvement. Example (#10100): - class Add a b ab | a b -> ab, a ab -> b - instance Add Zero b b - instance Add a b ab => Add (Succ a) b (Succ ab) -The context (Add a b ab) for the instance is clearly unused in terms -of evidence, since the dictionary has no fields. But it is still -needed! With the context, a wanted constraint - Add (Succ Zero) beta (Succ Zero) -we will reduce to (Add Zero beta Zero), and thence we get beta := Zero. -But without the context we won't find beta := Zero. - -This only matters in instance declarations.. --} - -reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () -reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics }) - = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples - , text "Suppress =" <+> ppr (cec_suppress ctxt)]) - ; traceTc "rw2" (ppr tidy_cts) - - -- First deal with things that are utterly wrong - -- Like Int ~ Bool (incl nullary TyCons) - -- or Int ~ t a (AppTy on one side) - -- These /ones/ are not suppressed by the incoming context - ; let ctxt_for_insols = ctxt { cec_suppress = False } - ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts - - -- Now all the other constraints. We suppress errors here if - -- any of the first batch failed, or if the enclosing context - -- says to suppress - ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } - ; (_, leftovers) <- tryReporters ctxt2 report2 cts1 - ; MASSERT2( null leftovers, ppr leftovers ) - - -- All the Derived ones have been filtered out of simples - -- by the constraint solver. This is ok; we don't want - -- to report unsolved Derived goals as errors - -- See Note [Do not report derived but soluble errors] - - ; mapBagM_ (reportImplic ctxt2) implics } - -- NB ctxt2: don't suppress inner insolubles if there's only a - -- wanted insoluble here; but do suppress inner insolubles - -- if there's a *given* insoluble here (= inaccessible code) - where - env = cec_tidy ctxt - tidy_cts = bagToList (mapBag (tidyCt env) simples) - - -- report1: ones that should *not* be suppressed by - -- an insoluble somewhere else in the tree - -- It's crucial that anything that is considered insoluble - -- (see TcRnTypes.insolubleCt) is caught here, otherwise - -- we might suppress its error message, and proceed on past - -- type checking to get a Lint error later - report1 = [ ("Out of scope", unblocked is_out_of_scope, True, mkHoleReporter tidy_cts) - , ("Holes", unblocked is_hole, False, mkHoleReporter tidy_cts) - , ("custom_error", unblocked is_user_type_error, True, mkUserTypeErrorReporter) - - , given_eq_spec - , ("insoluble2", unblocked utterly_wrong, True, mkGroupReporter mkEqErr) - , ("skolem eq1", unblocked very_wrong, True, mkSkolReporter) - , ("skolem eq2", unblocked skolem_eq, True, mkSkolReporter) - , ("non-tv eq", unblocked non_tv_eq, True, mkSkolReporter) - - -- The only remaining equalities are alpha ~ ty, - -- where alpha is untouchable; and representational equalities - -- Prefer homogeneous equalities over hetero, because the - -- former might be holding up the latter. - -- See Note [Equalities with incompatible kinds] in TcCanonical - , ("Homo eqs", unblocked is_homo_equality, True, mkGroupReporter mkEqErr) - , ("Other eqs", unblocked is_equality, True, mkGroupReporter mkEqErr) - , ("Blocked eqs", is_equality, False, mkSuppressReporter mkBlockedEqErr)] - - -- report2: we suppress these if there are insolubles elsewhere in the tree - report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) - , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) - , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] - - -- also checks to make sure the constraint isn't BlockedCIS - -- See TcCanonical Note [Equalities with incompatible kinds], (4) - unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool - unblocked _ (CIrredCan { cc_status = BlockedCIS }) _ = False - unblocked checker ct pred = checker ct pred - - -- rigid_nom_eq, rigid_nom_tv_eq, - is_hole, is_dict, - is_equality, is_ip, is_irred :: Ct -> Pred -> Bool - - is_given_eq ct pred - | EqPred {} <- pred = arisesFromGivens ct - | otherwise = False - -- I think all given residuals are equalities - - -- Things like (Int ~N Bool) - utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 - utterly_wrong _ _ = False - - -- Things like (a ~N Int) - very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2 - very_wrong _ _ = False - - -- Things like (a ~N b) or (a ~N F Bool) - skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1 - skolem_eq _ _ = False - - -- Things like (F a ~N Int) - non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) - non_tv_eq _ _ = False - - is_out_of_scope ct _ = isOutOfScopeCt ct - is_hole ct _ = isHoleCt ct - - is_user_type_error ct _ = isUserTypeErrorCt ct - - is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2 - is_homo_equality _ _ = False - - is_equality _ (EqPred {}) = True - is_equality _ _ = False - - is_dict _ (ClassPred {}) = True - is_dict _ _ = False - - is_ip _ (ClassPred cls _) = isIPClass cls - is_ip _ _ = False - - is_irred _ (IrredPred {}) = True - is_irred _ _ = False - - given_eq_spec -- See Note [Given errors] - | has_gadt_match (cec_encl ctxt) - = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) - | otherwise - = ("insoluble1b", is_given_eq, False, ignoreErrorReporter) - -- False means don't suppress subsequent errors - -- Reason: we don't report all given errors - -- (see mkGivenErrorReporter), and we should only suppress - -- subsequent errors if we actually report this one! - -- #13446 is an example - - -- See Note [Given errors] - has_gadt_match [] = False - has_gadt_match (implic : implics) - | PatSkol {} <- ic_info implic - , not (ic_no_eqs implic) - , ic_warn_inaccessible implic - -- Don't bother doing this if -Winaccessible-code isn't enabled. - -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls. - = True - | otherwise - = has_gadt_match implics - ---------------- -isSkolemTy :: TcLevel -> Type -> Bool --- The type is a skolem tyvar -isSkolemTy tc_lvl ty - | Just tv <- getTyVar_maybe ty - = isSkolemTyVar tv - || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv) - -- The last case is for touchable TyVarTvs - -- we postpone untouchables to a latter test (too obscure) - - | otherwise - = False - -isTyFun_maybe :: Type -> Maybe TyCon -isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of - Just (tc,_) | isTypeFamilyTyCon tc -> Just tc - _ -> Nothing - --------------------------------------------- --- Reporters --------------------------------------------- - -type Reporter - = ReportErrCtxt -> [Ct] -> TcM () -type ReporterSpec - = ( String -- Name - , Ct -> Pred -> Bool -- Pick these ones - , Bool -- True <=> suppress subsequent reporters - , Reporter) -- The reporter itself - -mkSkolReporter :: Reporter --- Suppress duplicates with either the same LHS, or same location -mkSkolReporter ctxt cts - = mapM_ (reportGroup mkEqErr ctxt) (group cts) - where - group [] = [] - group (ct:cts) = (ct : yeses) : group noes - where - (yeses, noes) = partition (group_with ct) cts - - group_with ct1 ct2 - | EQ <- cmp_loc ct1 ct2 = True - | eq_lhs_type ct1 ct2 = True - | otherwise = False - -mkHoleReporter :: [Ct] -> Reporter --- Reports errors one at a time -mkHoleReporter tidy_simples ctxt - = mapM_ $ \ct -> do { err <- mkHoleError tidy_simples ctxt ct - ; maybeReportHoleError ctxt ct err - ; maybeAddDeferredHoleBinding ctxt err ct } - -mkUserTypeErrorReporter :: Reporter -mkUserTypeErrorReporter ctxt - = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct - ; maybeReportError ctxt err - ; addDeferredBinding ctxt err ct } - -mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg -mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct - $ important - $ pprUserTypeErrorTy - $ case getUserTypeErrorMsg ct of - Just msg -> msg - Nothing -> pprPanic "mkUserTypeError" (ppr ct) - - -mkGivenErrorReporter :: Reporter --- See Note [Given errors] -mkGivenErrorReporter ctxt cts - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; dflags <- getDynFlags - ; let (implic:_) = cec_encl ctxt - -- Always non-empty when mkGivenErrorReporter is called - ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) - -- For given constraints we overwrite the env (and hence src-loc) - -- with one from the immediately-enclosing implication. - -- See Note [Inaccessible code] - - inaccessible_msg = hang (text "Inaccessible code in") - 2 (ppr (ic_info implic)) - report = important inaccessible_msg `mappend` - relevant_bindings binds_msg - - ; err <- mkEqErr_help dflags ctxt report ct' - Nothing ty1 ty2 - - ; traceTc "mkGivenErrorReporter" (ppr ct) - ; reportWarning (Reason Opt_WarnInaccessibleCode) err } - where - (ct : _ ) = cts -- Never empty - (ty1, ty2) = getEqPredTys (ctPred ct) - -ignoreErrorReporter :: Reporter --- Discard Given errors that don't come from --- a pattern match; maybe we should warn instead? -ignoreErrorReporter ctxt cts - = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt)) - ; return () } - - -{- Note [Given errors] -~~~~~~~~~~~~~~~~~~~~~~ -Given constraints represent things for which we have (or will have) -evidence, so they aren't errors. But if a Given constraint is -insoluble, this code is inaccessible, and we might want to at least -warn about that. A classic case is - - data T a where - T1 :: T Int - T2 :: T a - T3 :: T Bool - - f :: T Int -> Bool - f T1 = ... - f T2 = ... - f T3 = ... -- We want to report this case as inaccessible - -We'd like to point out that the T3 match is inaccessible. It -will have a Given constraint [G] Int ~ Bool. - -But we don't want to report ALL insoluble Given constraints. See Trac -#12466 for a long discussion. For example, if we aren't careful -we'll complain about - f :: ((Int ~ Bool) => a -> a) -> Int -which arguably is OK. It's more debatable for - g :: (Int ~ Bool) => Int -> Int -but it's tricky to distinguish these cases so we don't report -either. - -The bottom line is this: has_gadt_match looks for an enclosing -pattern match which binds some equality constraints. If we -find one, we report the insoluble Given. --} - -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) - -- Make error message for a group - -> Reporter -- Deal with lots of constraints --- Group together errors from same location, --- and report only the first (to avoid a cascade) -mkGroupReporter mk_err ctxt cts - = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) - --- Like mkGroupReporter, but doesn't actually print error messages -mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter -mkSuppressReporter mk_err ctxt cts - = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) - -eq_lhs_type :: Ct -> Ct -> Bool -eq_lhs_type ct1 ct2 - = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of - (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> - (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2) - _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2) - -cmp_loc :: Ct -> Ct -> Ordering -cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2) - -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter -reportGroup mk_err ctxt cts = - ASSERT( not (null cts)) - do { err <- mk_err ctxt cts - ; traceTc "About to maybeReportErr" $ - vcat [ text "Constraint:" <+> ppr cts - , text "cec_suppress =" <+> ppr (cec_suppress ctxt) - , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] - ; maybeReportError ctxt err - -- But see Note [Always warn with -fdefer-type-errors] - ; traceTc "reportGroup" (ppr cts) - ; mapM_ (addDeferredBinding ctxt err) cts } - -- Add deferred bindings for all - -- Redundant if we are going to abort compilation, - -- but that's hard to know for sure, and if we don't - -- abort, we need bindings for all (e.g. #12156) - --- like reportGroup, but does not actually report messages. It still adds --- -fdefer-type-errors bindings, though. -suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter -suppressGroup mk_err ctxt cts - = do { err <- mk_err ctxt cts - ; traceTc "Suppressing errors for" (ppr cts) - ; mapM_ (addDeferredBinding ctxt err) cts } - -maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM () --- Unlike maybeReportError, these "hole" errors are --- /not/ suppressed by cec_suppress. We want to see them! -maybeReportHoleError ctxt ct err - -- When -XPartialTypeSignatures is on, warnings (instead of errors) are - -- generated for holes in partial type signatures. - -- Unless -fwarn-partial-type-signatures is not on, - -- in which case the messages are discarded. - | isTypeHoleCt ct - = -- For partial type signatures, generate warnings only, and do that - -- only if -fwarn-partial-type-signatures is on - case cec_type_holes ctxt of - HoleError -> reportError err - HoleWarn -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err - HoleDefer -> return () - - -- Always report an error for out-of-scope variables - -- Unless -fdefer-out-of-scope-variables is on, - -- in which case the messages are discarded. - -- See #12170, #12406 - | isOutOfScopeCt ct - = -- If deferring, report a warning only if -Wout-of-scope-variables is on - case cec_out_of_scope_holes ctxt of - HoleError -> reportError err - HoleWarn -> - reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err - HoleDefer -> return () - - -- Otherwise this is a typed hole in an expression, - -- but not for an out-of-scope variable - | otherwise - = -- If deferring, report a warning only if -Wtyped-holes is on - case cec_expr_holes ctxt of - HoleError -> reportError err - HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err - HoleDefer -> return () - -maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM () --- Report the error and/or make a deferred binding for it -maybeReportError ctxt err - | cec_suppress ctxt -- Some worse error has occurred; - = return () -- so suppress this error/warning - - | otherwise - = case cec_defer_type_errors ctxt of - TypeDefer -> return () - TypeWarn reason -> reportWarning reason err - TypeError -> reportError err - -addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () --- See Note [Deferring coercion errors to runtime] -addDeferredBinding ctxt err ct - | deferringAnyBindings ctxt - , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct - -- Only add deferred bindings for Wanted constraints - = do { dflags <- getDynFlags - ; let err_msg = pprLocErrMsg err - err_fs = mkFastString $ showSDoc dflags $ - err_msg $$ text "(deferred type error)" - err_tm = evDelayedError pred err_fs - ev_binds_var = cec_binds ctxt - - ; case dest of - EvVarDest evar - -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm - HoleDest hole - -> do { -- See Note [Deferred errors for coercion holes] - let co_var = coHoleCoVar hole - ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm - ; fillCoercionHole hole (mkTcCoVarCo co_var) }} - - | otherwise -- Do not set any evidence for Given/Derived - = return () - -maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () -maybeAddDeferredHoleBinding ctxt err ct - | isExprHoleCt ct - = addDeferredBinding ctxt err ct -- Only add bindings for holes in expressions - | otherwise -- not for holes in partial type signatures - = return () - -tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) --- Use the first reporter in the list whose predicate says True -tryReporters ctxt reporters cts - = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts - ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts) - ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts - ; traceTc "tryReporters }" (ppr cts') - ; return (ctxt', cts') } - where - go ctxt [] vis_cts invis_cts - = return (ctxt, vis_cts ++ invis_cts) - - go ctxt (r : rs) vis_cts invis_cts - -- always look at *visible* Origins before invisible ones - -- this is the whole point of isVisibleOrigin - = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts - ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts - ; go ctxt'' rs vis_cts' invis_cts' } - -- Carry on with the rest, because we must make - -- deferred bindings for them if we have -fdefer-type-errors - -- But suppress their error messages - -tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct]) -tryReporter ctxt (str, keep_me, suppress_after, reporter) cts - | null yeses - = return (ctxt, cts) - | otherwise - = do { traceTc "tryReporter{ " (text str <+> ppr yeses) - ; (_, no_errs) <- askNoErrs (reporter ctxt yeses) - ; let suppress_now = not no_errs && suppress_after - -- See Note [Suppressing error messages] - ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } - ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) - ; return (ctxt', nos) } - where - (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts - - -pprArising :: CtOrigin -> SDoc --- Used for the main, top-level error message --- We've done special processing for TypeEq, KindEq, Given -pprArising (TypeEqOrigin {}) = empty -pprArising (KindEqOrigin {}) = empty -pprArising (GivenOrigin {}) = empty -pprArising orig = pprCtOrigin orig - --- Add the "arising from..." part to a message about bunch of dicts -addArising :: CtOrigin -> SDoc -> SDoc -addArising orig msg = hang msg 2 (pprArising orig) - -pprWithArising :: [Ct] -> (CtLoc, SDoc) --- Print something like --- (Eq a) arising from a use of x at y --- (Show a) arising from a use of p at q --- Also return a location for the error message --- Works for Wanted/Derived only -pprWithArising [] - = panic "pprWithArising" -pprWithArising (ct:cts) - | null cts - = (loc, addArising (ctLocOrigin loc) - (pprTheta [ctPred ct])) - | otherwise - = (loc, vcat (map ppr_one (ct:cts))) - where - loc = ctLoc ct - ppr_one ct' = hang (parens (pprType (ctPred ct'))) - 2 (pprCtLoc (ctLoc ct')) - -mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg -mkErrorMsgFromCt ctxt ct report - = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report - -mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg -mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs) - = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing) - (errDoc important [context] (relevant_bindings ++ valid_subs)) - } - -type UserGiven = Implication - -getUserGivens :: ReportErrCtxt -> [UserGiven] --- One item for each enclosing implication -getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics - -getUserGivensFromImplics :: [Implication] -> [UserGiven] -getUserGivensFromImplics implics - = reverse (filterOut (null . ic_given) implics) - -{- Note [Always warn with -fdefer-type-errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When -fdefer-type-errors is on we warn about *all* type errors, even -if cec_suppress is on. This can lead to a lot more warnings than you -would get errors without -fdefer-type-errors, but if we suppress any of -them you might get a runtime error that wasn't warned about at compile -time. - -This is an easy design choice to change; just flip the order of the -first two equations for maybeReportError - -To be consistent, we should also report multiple warnings from a single -location in mkGroupReporter, when -fdefer-type-errors is on. But that -is perhaps a bit *over*-consistent! Again, an easy choice to change. - -With #10283, you can now opt out of deferred type error warnings. - -Note [Deferred errors for coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we need to defer a type error where the destination for the evidence -is a coercion hole. We can't just put the error in the hole, because we can't -make an erroneous coercion. (Remember that coercions are erased for runtime.) -Instead, we invent a new EvVar, bind it to an error and then make a coercion -from that EvVar, filling the hole with that coercion. Because coercions' -types are unlifted, the error is guaranteed to be hit before we get to the -coercion. - -Note [Do not report derived but soluble errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wc_simples include Derived constraints that have not been solved, -but are not insoluble (in that case they'd be reported by 'report1'). -We do not want to report these as errors: - -* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have - an unsolved [D] Eq a, and we do not want to report that; it's just noise. - -* Functional dependencies. For givens, consider - class C a b | a -> b - data T a where - MkT :: C a d => [d] -> T a - f :: C a b => T a -> F Int - f (MkT xs) = length xs - Then we get a [D] b~d. But there *is* a legitimate call to - f, namely f (MkT [True]) :: T Bool, in which b=d. So we should - not reject the program. - - For wanteds, something similar - data T a where - MkT :: C Int b => a -> b -> T a - g :: C Int c => c -> () - f :: T a -> () - f (MkT x y) = g x - Here we get [G] C Int b, [W] C Int a, hence [D] a~b. - But again f (MkT True True) is a legitimate call. - -(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose -derived superclasses between iterations of the solver.) - -For functional dependencies, here is a real example, -stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs - - class C a b | a -> b - g :: C a b => a -> b -> () - f :: C a b => a -> b -> () - f xa xb = - let loop = g xa - in loop xb - -We will first try to infer a type for loop, and we will succeed: - C a b' => b' -> () -Subsequently, we will type check (loop xb) and all is good. But, -recall that we have to solve a final implication constraint: - C a b => (C a b' => .... cts from body of loop .... )) -And now we have a problem as we will generate an equality b ~ b' and fail to -solve it. - - -************************************************************************ -* * - Irreducible predicate errors -* * -************************************************************************ --} - -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkIrredErr ctxt cts - = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) - ; mkErrorMsgFromCt ctxt ct1 $ - important msg `mappend` relevant_bindings binds_msg } - where - (ct1:_) = cts - ----------------- -mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg -mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) - | isOutOfScopeCt ct -- Out of scope variables, like 'a', where 'a' isn't bound - -- Suggest possible in-scope variables in the message - = do { dflags <- getDynFlags - ; rdr_env <- getGlobalRdrEnv - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing) $ - errDoc [out_of_scope_msg] [] - [unknownNameSuggestions dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)] } - - | otherwise -- Explicit holes, like "_" or "_f" - = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct - -- The 'False' means "don't filter the bindings"; see Trac #8191 - - ; show_hole_constraints <- goptM Opt_ShowHoleConstraints - ; let constraints_msg - | isExprHoleCt ct, show_hole_constraints - = givenConstraintsMsg ctxt - | otherwise - = empty - - ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits - ; (ctxt, sub_msg) <- if show_valid_hole_fits - then validHoleFits ctxt tidy_simples ct - else return (ctxt, empty) - - ; mkErrorMsgFromCt ctxt ct $ - important hole_msg `mappend` - relevant_bindings (binds_msg $$ constraints_msg) `mappend` - valid_hole_fits sub_msg } - - where - ct_loc = ctLoc ct - lcl_env = ctLocEnv ct_loc - hole_ty = ctEvPred (ctEvidence ct) - hole_kind = tcTypeKind hole_ty - tyvars = tyCoVarsOfTypeList hole_ty - boring_type = isTyVarTy hole_ty - - out_of_scope_msg -- Print v :: ty only if the type has structure - | boring_type = hang herald 2 (ppr occ) - | otherwise = hang herald 2 pp_with_type - - pp_with_type = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) - herald | isDataOcc occ = text "Data constructor not in scope:" - | otherwise = text "Variable not in scope:" - - hole_msg = case hole_sort of - ExprHole -> vcat [ hang (text "Found hole:") - 2 pp_with_type - , tyvars_msg, expr_hole_hint ] - TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ)) - 2 (text "standing for" <+> quotes pp_hole_type_with_kind) - , tyvars_msg, type_hole_hint ] - - pp_hole_type_with_kind - | isLiftedTypeKind hole_kind - || isCoVarType hole_ty -- Don't print the kind of unlifted - -- equalities (#15039) - = pprType hole_ty - | otherwise - = pprType hole_ty <+> dcolon <+> pprKind hole_kind - - tyvars_msg = ppUnless (null tyvars) $ - text "Where:" <+> (vcat (map loc_msg other_tvs) - $$ pprSkols ctxt skol_tvs) - where - (skol_tvs, other_tvs) = partition is_skol tyvars - is_skol tv = isTcTyVar tv && isSkolemTyVar tv - -- Coercion variables can be free in the - -- hole, via kind casts - - type_hole_hint - | HoleError <- cec_type_holes ctxt - = text "To use the inferred type, enable PartialTypeSignatures" - | otherwise - = empty - - expr_hole_hint -- Give hint for, say, f x = _x - | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_" - = text "Or perhaps" <+> quotes (ppr occ) - <+> text "is mis-spelled, or not in scope" - | otherwise - = empty - - loc_msg tv - | isTyVar tv - = case tcTyVarDetails tv of - MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" - _ -> empty -- Skolems dealt with already - | otherwise -- A coercion variable can be free in the hole type - = ppWhenOption sdocPrintExplicitCoercions $ - quotes (ppr tv) <+> text "is a coercion variable" - -mkHoleError _ _ ct = pprPanic "mkHoleError" (ppr ct) - --- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module --- imports -validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the - -- implications and the tidy environment - -> [Ct] -- Unsolved simple constraints - -> Ct -- The hole constraint. - -> TcM (ReportErrCtxt, SDoc) -- We return the new context - -- with a possibly updated - -- tidy environment, and - -- the message. -validHoleFits ctxt@(CEC {cec_encl = implics - , cec_tidy = lcl_env}) simps ct - = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps ct - ; return (ctxt {cec_tidy = tidy_env}, msg) } - --- See Note [Constraints include ...] -givenConstraintsMsg :: ReportErrCtxt -> SDoc -givenConstraintsMsg ctxt = - let constraints :: [(Type, RealSrcSpan)] - constraints = - do { implic@Implic{ ic_given = given } <- cec_encl ctxt - ; constraint <- given - ; return (varType constraint, tcl_loc (ic_env implic)) } - - pprConstraint (constraint, loc) = - ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) - - in ppUnless (null constraints) $ - hang (text "Constraints include") - 2 (vcat $ map pprConstraint constraints) - ----------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkIPErr ctxt cts - = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - preds = map ctPred cts - givens = getUserGivens ctxt - msg | null givens - = addArising orig $ - sep [ text "Unbound implicit parameter" <> plural cts - , nest 2 (pprParendTheta preds) ] - | otherwise - = couldNotDeduce givens (preds, orig) - - ; mkErrorMsgFromCt ctxt ct1 $ - important msg `mappend` relevant_bindings binds_msg } - where - (ct1:_) = cts - -{- -Note [Constraints include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'givenConstraintsMsg' returns the "Constraints include ..." message enabled by --fshow-hole-constraints. For example, the following hole: - - foo :: (Eq a, Show a) => a -> String - foo x = _ - -would generate the message: - - Constraints include - Eq a (from foo.hs:1:1-36) - Show a (from foo.hs:1:1-36) - -Constraints are displayed in order from innermost (closest to the hole) to -outermost. There's currently no filtering or elimination of duplicates. - -************************************************************************ -* * - Equality errors -* * -************************************************************************ - -Note [Inaccessible code] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a where - T1 :: T a - T2 :: T Bool - - f :: (a ~ Int) => T a -> Int - f T1 = 3 - f T2 = 4 -- Unreachable code - -Here the second equation is unreachable. The original constraint -(a~Int) from the signature gets rewritten by the pattern-match to -(Bool~Int), so the danger is that we report the error as coming from -the *signature* (#7293). So, for Given errors we replace the -env (and hence src-loc) on its CtLoc with that from the immediately -enclosing implication. - -Note [Error messages for untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#9109) - data G a where { GBool :: G Bool } - foo x = case x of GBool -> True - -Here we can't solve (t ~ Bool), where t is the untouchable result -meta-var 't', because of the (a ~ Bool) from the pattern match. -So we infer the type - f :: forall a t. G a -> t -making the meta-var 't' into a skolem. So when we come to report -the unsolved (t ~ Bool), t won't look like an untouchable meta-var -any more. So we don't assert that it is. --} - --- Don't have multiple equality errors from the same location --- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct -mkEqErr _ [] = panic "mkEqErr" - -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg -mkEqErr1 ctxt ct -- Wanted or derived; - -- givens handled in mkGivenErrorReporter - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; rdr_env <- getGlobalRdrEnv - ; fam_envs <- tcGetFamInstEnvs - ; exp_syns <- goptM Opt_PrintExpandedSynonyms - ; let (keep_going, is_oriented, wanted_msg) - = mk_wanted_extra (ctLoc ct) exp_syns - coercible_msg = case ctEqRel ct of - NomEq -> empty - ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - ; dflags <- getDynFlags - ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct) $$ ppr keep_going) - ; let report = mconcat [important wanted_msg, important coercible_msg, - relevant_bindings binds_msg] - ; if keep_going - then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2 - else mkErrorMsgFromCt ctxt ct report } - where - (ty1, ty2) = getEqPredTys (ctPred ct) - - -- If the types in the error message are the same as the types - -- we are unifying, don't add the extra expected/actual message - mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc) - mk_wanted_extra loc expandSyns - = case ctLocOrigin loc of - orig@TypeEqOrigin {} -> mkExpectedActualMsg ty1 ty2 orig - t_or_k expandSyns - where - t_or_k = ctLocTypeOrKind_maybe loc - - KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k - -> (True, Nothing, msg1 $$ msg2) - where - sub_what = case sub_t_or_k of Just KindLevel -> text "kinds" - _ -> text "types" - msg1 = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> - case mb_cty2 of - Just cty2 - | printExplicitCoercions - || not (cty1 `pickyEqType` cty2) - -> hang (text "When matching" <+> sub_what) - 2 (vcat [ ppr cty1 <+> dcolon <+> - ppr (tcTypeKind cty1) - , ppr cty2 <+> dcolon <+> - ppr (tcTypeKind cty2) ]) - _ -> text "When matching the kind of" <+> quotes (ppr cty1) - msg2 = case sub_o of - TypeEqOrigin {} - | Just cty2 <- mb_cty2 -> - thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k - expandSyns) - _ -> empty - _ -> (True, Nothing, empty) - --- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint --- is left over. -mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs - -> TcType -> TcType -> SDoc -mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 - , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys - , Just msg <- coercible_msg_for_tycon rep_tc - = msg - | Just (tc, tys) <- splitTyConApp_maybe ty2 - , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys - , Just msg <- coercible_msg_for_tycon rep_tc - = msg - | Just (s1, _) <- tcSplitAppTy_maybe ty1 - , Just (s2, _) <- tcSplitAppTy_maybe ty2 - , s1 `eqType` s2 - , has_unknown_roles s1 - = hang (text "NB: We cannot know what roles the parameters to" <+> - quotes (ppr s1) <+> text "have;") - 2 (text "we must assume that the role is nominal") - | otherwise - = empty - where - coercible_msg_for_tycon tc - | isAbstractTyCon tc - = Just $ hsep [ text "NB: The type constructor" - , quotes (pprSourceTyCon tc) - , text "is abstract" ] - | isNewTyCon tc - , [data_con] <- tyConDataCons tc - , let dc_name = dataConName data_con - , isNothing (lookupGRE_Name rdr_env dc_name) - = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name)) - 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) - , text "is not in scope" ]) - | otherwise = Nothing - - has_unknown_roles ty - | Just (tc, tys) <- tcSplitTyConApp_maybe ty - = tys `lengthAtLeast` tyConArity tc -- oversaturated tycon - | Just (s, _) <- tcSplitAppTy_maybe ty - = has_unknown_roles s - | isTyVarTy ty - = True - | otherwise - = False - -{- --- | Make a listing of role signatures for all the parameterised tycons --- used in the provided types - - --- SLPJ Jun 15: I could not convince myself that these hints were really --- useful. Maybe they are, but I think we need more work to make them --- actually helpful. -mkRoleSigs :: Type -> Type -> SDoc -mkRoleSigs ty1 ty2 - = ppUnless (null role_sigs) $ - hang (text "Relevant role signatures:") - 2 (vcat role_sigs) - where - tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2 - role_sigs = mapMaybe ppr_role_sig tcs - - ppr_role_sig tc - | null roles -- if there are no parameters, don't bother printing - = Nothing - | isBuiltInSyntax (tyConName tc) -- don't print roles for (->), etc. - = Nothing - | otherwise - = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles - where - roles = tyConRoles tc --} - -mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report - -> Ct - -> Maybe SwapFlag -- Nothing <=> not sure - -> TcType -> TcType -> TcM ErrMsg -mkEqErr_help dflags ctxt report ct oriented ty1 ty2 - | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 - = mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 - | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2 - = mkTyVarEqErr dflags ctxt report ct swapped tv2 ty1 - | otherwise - = reportEqErr ctxt report ct oriented ty1 ty2 - where - swapped = fmap flipSwap oriented - -reportEqErr :: ReportErrCtxt -> Report - -> Ct - -> Maybe SwapFlag -- Nothing <=> not sure - -> TcType -> TcType -> TcM ErrMsg -reportEqErr ctxt report ct oriented ty1 ty2 - = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo]) - where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2 - eqInfo = important $ mkEqInfoMsg ct ty1 ty2 - -mkTyVarEqErr, mkTyVarEqErr' - :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg --- tv1 and ty2 are already tidied -mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 - = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) - ; mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2 } - -mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2 - | not insoluble_occurs_check -- See Note [Occurs check wins] - , isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would - -- be oriented the other way round; - -- see TcCanonical.canEqTyVarTyVar - || isTyVarTyVar tv1 && not (isTyVarTy ty2) - || ctEqRel ct == ReprEq - -- the cases below don't really apply to ReprEq (except occurs check) - = mkErrorMsgFromCt ctxt ct $ mconcat - [ important $ misMatchOrCND ctxt ct oriented ty1 ty2 - , important $ extraTyVarEqInfo ctxt tv1 ty2 - , report - ] - - | MTVU_Occurs <- occ_check_expand - -- We report an "occurs check" even for a ~ F t a, where F is a type - -- function; it's not insoluble (because in principle F could reduce) - -- but we have certainly been unable to solve it - -- See Note [Occurs check error] in TcCanonical - = do { let main_msg = addArising (ctOrigin ct) $ - hang (text "Occurs check: cannot construct the infinite" <+> what <> colon) - 2 (sep [ppr ty1, char '~', ppr ty2]) - - extra2 = important $ mkEqInfoMsg ct ty1 ty2 - - interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ - filter isTyVar $ - fvVarList $ - tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 - extra3 = relevant_bindings $ - ppWhen (not (null interesting_tyvars)) $ - hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) - interesting_tyvars) - - tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - ; mkErrorMsgFromCt ctxt ct $ - mconcat [important main_msg, extra2, extra3, report] } - - | MTVU_Bad <- occ_check_expand - = do { let msg = vcat [ text "Cannot instantiate unification variable" - <+> quotes (ppr tv1) - , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) - , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ] - -- Unlike the other reports, this discards the old 'report_important' - -- instead of augmenting it. This is because the details are not likely - -- to be helpful since this is just an unimplemented feature. - ; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } } - - -- If the immediately-enclosing implication has 'tv' a skolem, and - -- we know by now its an InferSkol kind of skolem, then presumably - -- it started life as a TyVarTv, else it'd have been unified, given - -- that there's no occurs-check or forall problem - | (implic:_) <- cec_encl ctxt - , Implic { ic_skols = skols } <- implic - , tv1 `elem` skols - = mkErrorMsgFromCt ctxt ct $ mconcat - [ important $ misMatchMsg ct oriented ty1 ty2 - , important $ extraTyVarEqInfo ctxt tv1 ty2 - , report - ] - - -- Check for skolem escape - | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_skols = skols, ic_info = skol_info } <- implic - , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols - , not (null esc_skols) - = do { let msg = important $ misMatchMsg ct oriented ty1 ty2 - esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols - <+> pprQuotedList esc_skols - , text "would escape" <+> - if isSingleton esc_skols then text "its scope" - else text "their scope" ] - tv_extra = important $ - vcat [ nest 2 $ esc_doc - , sep [ (if isSingleton esc_skols - then text "This (rigid, skolem)" <+> - what <+> text "variable is" - else text "These (rigid, skolem)" <+> - what <+> text "variables are") - <+> text "bound by" - , nest 2 $ ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] ] - ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) } - - -- Nastiest case: attempt to unify an untouchable variable - -- So tv is a meta tyvar (or started that way before we - -- generalised it). So presumably it is an *untouchable* - -- meta tyvar or a TyVarTv, else it'd have been unified - -- See Note [Error messages for untouchables] - | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic - = ASSERT2( not (isTouchableMetaTyVar lvl tv1) - , ppr tv1 $$ ppr lvl ) -- See Note [Error messages for untouchables] - do { let msg = important $ misMatchMsg ct oriented ty1 ty2 - tclvl_extra = important $ - nest 2 $ - sep [ quotes (ppr tv1) <+> text "is untouchable" - , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given - , nest 2 $ text "bound by" <+> ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] - tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2 - add_sig = important $ suggestAddSig ctxt ty1 ty2 - ; mkErrorMsgFromCt ctxt ct $ mconcat - [msg, tclvl_extra, tv_extra, add_sig, report] } - - | otherwise - = reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2 - -- This *can* happen (#6123, and test T2627b) - -- Consider an ambiguous top-level constraint (a ~ F a) - -- Not an occurs check, because F is a type function. - where - ty1 = mkTyVarTy tv1 - occ_check_expand = occCheckForErrors dflags tv1 ty2 - insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2 - - what = case ctLocTypeOrKind_maybe (ctLoc ct) of - Just KindLevel -> text "kind" - _ -> text "type" - -mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc --- Report (a) ambiguity if either side is a type function application --- e.g. F a0 ~ Int --- (b) warning about injectivity if both sides are the same --- type function application F a ~ F b --- See Note [Non-injective type functions] -mkEqInfoMsg ct ty1 ty2 - = tyfun_msg $$ ambig_msg - where - mb_fun1 = isTyFun_maybe ty1 - mb_fun2 = isTyFun_maybe ty2 - - ambig_msg | isJust mb_fun1 || isJust mb_fun2 - = snd (mkAmbigMsg False ct) - | otherwise = empty - - tyfun_msg | Just tc1 <- mb_fun1 - , Just tc2 <- mb_fun2 - , tc1 == tc2 - , not (isInjectiveTyCon tc1 Nominal) - = text "NB:" <+> quotes (ppr tc1) - <+> text "is a non-injective type family" - | otherwise = empty - -isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool --- See Note [Reporting occurs-check errors] -isUserSkolem ctxt tv - = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt) - where - is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info }) - = tv `elem` sks && is_user_skol_info skol_info - - is_user_skol_info (InferSkol {}) = False - is_user_skol_info _ = True - -misMatchOrCND :: ReportErrCtxt -> Ct - -> Maybe SwapFlag -> TcType -> TcType -> SDoc --- If oriented then ty1 is actual, ty2 is expected -misMatchOrCND ctxt ct oriented ty1 ty2 - | null givens || - (isRigidTy ty1 && isRigidTy ty2) || - isGivenCt ct - -- If the equality is unconditionally insoluble - -- or there is no context, don't report the context - = misMatchMsg ct oriented ty1 ty2 - | otherwise - = couldNotDeduce givens ([eq_pred], orig) - where - ev = ctEvidence ct - eq_pred = ctEvPred ev - orig = ctEvOrigin ev - givens = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)] - -- Keep only UserGivens that have some equalities. - -- See Note [Suppress redundant givens during error reporting] - -couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc -couldNotDeduce givens (wanteds, orig) - = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds) - , vcat (pp_givens givens)] - -pp_givens :: [UserGiven] -> [SDoc] -pp_givens givens - = case givens of - [] -> [] - (g:gs) -> ppr_given (text "from the context:") g - : map (ppr_given (text "or from:")) gs - where - ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) - = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) - -- See Note [Suppress redundant givens during error reporting] - -- for why we use mkMinimalBySCs above. - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> ppr (tcl_loc (ic_env implic)) ]) - --- These are for the "blocked" equalities, as described in TcCanonical --- Note [Equalities with incompatible kinds], wrinkle (2). There should --- always be another unsolved wanted around, which will ordinarily suppress --- this message. But this can still be printed out with -fdefer-type-errors --- (sigh), so we must produce a message. -mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report - where - report = important msg - msg = vcat [ hang (text "Cannot use equality for substitution:") - 2 (ppr (ctPred ct)) - , text "Doing so would be ill-kinded." ] - -- This is a terrible message. Perhaps worse, if the user - -- has -fprint-explicit-kinds on, they will see that the two - -- sides have the same kind, as there is an invisible cast. - -- I really don't know how to do better. -mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints" - -{- -Note [Suppress redundant givens during error reporting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When GHC is unable to solve a constraint and prints out an error message, it -will print out what given constraints are in scope to provide some context to -the programmer. But we shouldn't print out /every/ given, since some of them -are not terribly helpful to diagnose type errors. Consider this example: - - foo :: Int :~: Int -> a :~: b -> a :~: c - foo Refl Refl = Refl - -When reporting that GHC can't solve (a ~ c), there are two givens in scope: -(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e., -redundant), so it's not terribly useful to report it in an error message. -To accomplish this, we discard any Implications that do not bind any -equalities by filtering the `givens` selected in `misMatchOrCND` (based on -the `ic_no_eqs` field of the Implication). - -But this is not enough to avoid all redundant givens! Consider this example, -from #15361: - - goo :: forall (a :: Type) (b :: Type) (c :: Type). - a :~~: b -> a :~~: c - goo HRefl = HRefl - -Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope. -The (* ~ *) part arises due the kinds of (:~~:) being unified. More -importantly, (* ~ *) is redundant, so we'd like not to report it. However, -the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its -ic_no_eqs field), so the test above will keep it wholesale. - -To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b) -part. This works because mkMinimalBySCs eliminates reflexive equalities in -addition to superclasses (see Note [Remove redundant provided dicts] -in TcPatSyn). --} - -extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc --- Add on extra info about skolem constants --- NB: The types themselves are already tidied -extraTyVarEqInfo ctxt tv1 ty2 - = extraTyVarInfo ctxt tv1 $$ ty_extra ty2 - where - ty_extra ty = case tcGetCastedTyVar_maybe ty of - Just (tv, _) -> extraTyVarInfo ctxt tv - Nothing -> empty - -extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc -extraTyVarInfo ctxt tv - = ASSERT2( isTyVar tv, ppr tv ) - case tcTyVarDetails tv of - SkolemTv {} -> pprSkols ctxt [tv] - RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" - MetaTv {} -> empty - -suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc --- See Note [Suggest adding a type signature] -suggestAddSig ctxt ty1 ty2 - | null inferred_bndrs - = empty - | [bndr] <- inferred_bndrs - = text "Possible fix: add a type signature for" <+> quotes (ppr bndr) - | otherwise - = text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs) - where - inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2) - get_inf ty | Just tv <- tcGetTyVar_maybe ty - , isSkolemTyVar tv - , ((InferSkol prs, _) : _) <- getSkolemInfo (cec_encl ctxt) [tv] - = map fst prs - | otherwise - = [] - --------------------- -misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc --- Types are already tidy --- If oriented then ty1 is actual, ty2 is expected -misMatchMsg ct oriented ty1 ty2 - | Just NotSwapped <- oriented - = misMatchMsg ct (Just IsSwapped) ty2 ty1 - - -- These next two cases are when we're about to report, e.g., that - -- 'LiftedRep doesn't match 'VoidRep. Much better just to say - -- lifted vs. unlifted - | isLiftedRuntimeRep ty1 - = lifted_vs_unlifted - - | isLiftedRuntimeRep ty2 - = lifted_vs_unlifted - - | otherwise -- So now we have Nothing or (Just IsSwapped) - -- For some reason we treat Nothing like IsSwapped - = addArising orig $ - pprWithExplicitKindsWhenMismatch ty1 ty2 (ctOrigin ct) $ - sep [ text herald1 <+> quotes (ppr ty1) - , nest padding $ - text herald2 <+> quotes (ppr ty2) - , sameOccExtra ty2 ty1 ] - where - herald1 = conc [ "Couldn't match" - , if is_repr then "representation of" else "" - , if is_oriented then "expected" else "" - , what ] - herald2 = conc [ "with" - , if is_repr then "that of" else "" - , if is_oriented then ("actual " ++ what) else "" ] - padding = length herald1 - length herald2 - - is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False } - is_oriented = isJust oriented - - orig = ctOrigin ct - what = case ctLocTypeOrKind_maybe (ctLoc ct) of - Just KindLevel -> "kind" - _ -> "type" - - conc :: [String] -> String - conc = foldr1 add_space - - add_space :: String -> String -> String - add_space s1 s2 | null s1 = s2 - | null s2 = s1 - | otherwise = s1 ++ (' ' : s2) - - lifted_vs_unlifted - = addArising orig $ - text "Couldn't match a lifted type with an unlifted type" - --- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a --- type mismatch occurs to due invisible kind arguments. --- --- This function first checks to see if the 'CtOrigin' argument is a --- 'TypeEqOrigin', and if so, uses the expected/actual types from that to --- check for a kind mismatch (as these types typically have more surrounding --- types and are likelier to be able to glean information about whether a --- mismatch occurred in an invisible argument position or not). If the --- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types --- themselves. -pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin - -> SDoc -> SDoc -pprWithExplicitKindsWhenMismatch ty1 ty2 ct - = pprWithExplicitKindsWhen show_kinds - where - (act_ty, exp_ty) = case ct of - TypeEqOrigin { uo_actual = act - , uo_expected = exp } -> (act, exp) - _ -> (ty1, ty2) - show_kinds = tcEqTypeVis act_ty exp_ty - -- True when the visible bit of the types look the same, - -- so we want to show the kinds in the displayed type - -mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool - -> (Bool, Maybe SwapFlag, SDoc) --- NotSwapped means (actual, expected), IsSwapped is the reverse --- First return val is whether or not to print a herald above this msg -mkExpectedActualMsg ty1 ty2 ct@(TypeEqOrigin { uo_actual = act - , uo_expected = exp - , uo_thing = maybe_thing }) - m_level printExpanded - | KindLevel <- level, occurs_check_error = (True, Nothing, empty) - | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2) - | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3) - | tcIsLiftedTypeKind exp = (False, Nothing, msg4) - | Just msg <- num_args_msg = (False, Nothing, msg $$ msg1) - | KindLevel <- level, Just th <- maybe_thing = (False, Nothing, msg5 th) - | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty) - | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (True, Just IsSwapped, empty) - | otherwise = (True, Nothing, msg1) - where - level = m_level `orElse` TypeLevel - - occurs_check_error - | Just tv <- tcGetTyVar_maybe ty1 - , tv `elemVarSet` tyCoVarsOfType ty2 - = True - | Just tv <- tcGetTyVar_maybe ty2 - , tv `elemVarSet` tyCoVarsOfType ty1 - = True - | otherwise - = False - - sort = case level of - TypeLevel -> text "type" - KindLevel -> text "kind" - - msg1 = case level of - KindLevel - | Just th <- maybe_thing - -> msg5 th - - _ | not (act `pickyEqType` exp) - -> pprWithExplicitKindsWhenMismatch ty1 ty2 ct $ - vcat [ text "Expected" <+> sort <> colon <+> ppr exp - , text " Actual" <+> sort <> colon <+> ppr act - , if printExpanded then expandedTys else empty ] - - | otherwise - -> empty - - thing_msg = case maybe_thing of - Just thing -> \_ levity -> - quotes thing <+> text "is" <+> levity - Nothing -> \vowel levity -> - text "got a" <> - (if vowel then char 'n' else empty) <+> - levity <+> - text "type" - msg2 = sep [ text "Expecting a lifted type, but" - , thing_msg True (text "unlifted") ] - msg3 = sep [ text "Expecting an unlifted type, but" - , thing_msg False (text "lifted") ] - msg4 = maybe_num_args_msg $$ - sep [ text "Expected a type, but" - , maybe (text "found something with kind") - (\thing -> quotes thing <+> text "has kind") - maybe_thing - , quotes (pprWithTYPE act) ] - - msg5 th = pprWithExplicitKindsWhenMismatch ty1 ty2 ct $ - hang (text "Expected" <+> kind_desc <> comma) - 2 (text "but" <+> quotes th <+> text "has kind" <+> - quotes (ppr act)) - where - kind_desc | tcIsConstraintKind exp = text "a constraint" - - -- TYPE t0 - | Just arg <- kindRep_maybe exp - , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case - True -> text "kind" <+> quotes (ppr exp) - False -> text "a type" - - | otherwise = text "kind" <+> quotes (ppr exp) - - num_args_msg = case level of - KindLevel - | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) - -- if one is a meta-tyvar, then it's possible that the user - -- has asked for something impredicative, and we couldn't unify. - -- Don't bother with counting arguments. - -> let n_act = count_args act - n_exp = count_args exp in - case n_act - n_exp of - n | n > 0 -- we don't know how many args there are, so don't - -- recommend removing args that aren't - , Just thing <- maybe_thing - -> Just $ text "Expecting" <+> speakN (abs n) <+> - more <+> quotes thing - where - more - | n == 1 = text "more argument to" - | otherwise = text "more arguments to" -- n > 1 - _ -> Nothing - - _ -> Nothing - - maybe_num_args_msg = case num_args_msg of - Nothing -> empty - Just m -> m - - count_args ty = count isVisibleBinder $ fst $ splitPiTys ty - - expandedTys = - ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat - [ text "Type synonyms expanded:" - , text "Expected type:" <+> ppr expTy1 - , text " Actual type:" <+> ppr expTy2 - ] - - (expTy1, expTy2) = expandSynonymsToMatch exp act - -mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg" - -{- Note [Insoluble occurs check wins] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble -so we don't use it for rewriting. The Wanted is also insoluble, and -we don't solve it from the Given. It's very confusing to say - Cannot solve a ~ [a] from given constraints a ~ [a] - -And indeed even thinking about the Givens is silly; [W] a ~ [a] is -just as insoluble as Int ~ Bool. - -Conclusion: if there's an insoluble occurs check (isInsolubleOccursCheck) -then report it first. - -(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't -want to be as draconian with them.) - -Note [Expanding type synonyms to make types similar] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In type error messages, if -fprint-expanded-types is used, we want to expand -type synonyms to make expected and found types as similar as possible, but we -shouldn't expand types too much to make type messages even more verbose and -harder to understand. The whole point here is to make the difference in expected -and found types clearer. - -`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms -only as much as necessary. Given two types t1 and t2: - - * If they're already same, it just returns the types. - - * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are - type constructors), it expands C1 and C2 if they're different type synonyms. - Then it recursively does the same thing on expanded types. If C1 and C2 are - same, then it applies the same procedure to arguments of C1 and arguments of - C2 to make them as similar as possible. - - Most important thing here is to keep number of synonym expansions at - minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, - Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and - `T (T3, T3, Bool)`. - - * Otherwise types don't have same shapes and so the difference is clearly - visible. It doesn't do any expansions and show these types. - -Note that we only expand top-layer type synonyms. Only when top-layer -constructors are the same we start expanding inner type synonyms. - -Suppose top-layer type synonyms of t1 and t2 can expand N and M times, -respectively. If their type-synonym-expanded forms will meet at some point (i.e. -will have same shapes according to `sameShapes` function), it's possible to find -where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) -comparisons. We first collect all the top-layer expansions of t1 and t2 in two -lists, then drop the prefix of the longer list so that they have same lengths. -Then we search through both lists in parallel, and return the first pair of -types that have same shapes. Inner types of these two types with same shapes -are then expanded using the same algorithm. - -In case they don't meet, we return the last pair of types in the lists, which -has top-layer type synonyms completely expanded. (in this case the inner types -are not expanded at all, as the current form already shows the type error) --} - --- | Expand type synonyms in given types only enough to make them as similar as --- possible. Returned types are the same in terms of used type synonyms. --- --- To expand all synonyms, see 'Type.expandTypeSynonyms'. --- --- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for --- some examples of how this should work. -expandSynonymsToMatch :: Type -> Type -> (Type, Type) -expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) - where - (ty1_ret, ty2_ret) = go ty1 ty2 - - -- | Returns (type synonym expanded version of first type, - -- type synonym expanded version of second type) - go :: Type -> Type -> (Type, Type) - go t1 t2 - | t1 `pickyEqType` t2 = - -- Types are same, nothing to do - (t1, t2) - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 = - -- Type constructors are same. They may be synonyms, but we don't - -- expand further. - let (tys1', tys2') = - unzip (zipWith (\ty1 ty2 -> go ty1 ty2) tys1 tys2) - in (TyConApp tc1 tys1', TyConApp tc2 tys2') - - go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') - - go ty1@(FunTy _ t1_1 t1_2) ty2@(FunTy _ t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } - , ty2 { ft_arg = t2_1', ft_res = t2_2' }) - - go (ForAllTy b1 t1) (ForAllTy b2 t2) = - -- NOTE: We may have a bug here, but we just can't reproduce it easily. - -- See D1016 comments for details and our attempts at producing a test - -- case. Short version: We probably need RnEnv2 to really get this right. - let (t1', t2') = go t1 t2 - in (ForAllTy b1 t1', ForAllTy b2 t2') - - go (CastTy ty1 _) ty2 = go ty1 ty2 - go ty1 (CastTy ty2 _) = go ty1 ty2 - - go t1 t2 = - -- See Note [Expanding type synonyms to make types similar] for how this - -- works - let - t1_exp_tys = t1 : tyExpansions t1 - t2_exp_tys = t2 : tyExpansions t2 - t1_exps = length t1_exp_tys - t2_exps = length t2_exp_tys - dif = abs (t1_exps - t2_exps) - in - followExpansions $ - zipEqual "expandSynonymsToMatch.go" - (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) - (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) - - -- | Expand the top layer type synonyms repeatedly, collect expansions in a - -- list. The list does not include the original type. - -- - -- Example, if you have: - -- - -- type T10 = T9 - -- type T9 = T8 - -- ... - -- type T0 = Int - -- - -- `tyExpansions T10` returns [T9, T8, T7, ... Int] - -- - -- This only expands the top layer, so if you have: - -- - -- type M a = Maybe a - -- - -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) - tyExpansions :: Type -> [Type] - tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t) - - -- | Drop the type pairs until types in a pair look alike (i.e. the outer - -- constructors are the same). - followExpansions :: [(Type, Type)] -> (Type, Type) - followExpansions [] = pprPanic "followExpansions" empty - followExpansions [(t1, t2)] - | sameShapes t1 t2 = go t1 t2 -- expand subtrees - | otherwise = (t1, t2) -- the difference is already visible - followExpansions ((t1, t2) : tss) - -- Traverse subtrees when the outer shapes are the same - | sameShapes t1 t2 = go t1 t2 - -- Otherwise follow the expansions until they look alike - | otherwise = followExpansions tss - - sameShapes :: Type -> Type -> Bool - sameShapes AppTy{} AppTy{} = True - sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 - sameShapes (FunTy {}) (FunTy {}) = True - sameShapes (ForAllTy {}) (ForAllTy {}) = True - sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 - sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 - sameShapes _ _ = False - -sameOccExtra :: TcType -> TcType -> SDoc --- See Note [Disambiguating (X ~ X) errors] -sameOccExtra ty1 ty2 - | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 - , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 - , let n1 = tyConName tc1 - n2 = tyConName tc2 - same_occ = nameOccName n1 == nameOccName n2 - same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2) - , n1 /= n2 -- Different Names - , same_occ -- but same OccName - = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) - | otherwise - = empty - where - ppr_from same_pkg nm - | isGoodSrcSpan loc - = hang (quotes (ppr nm) <+> text "is defined at") - 2 (ppr loc) - | otherwise -- Imported things have an UnhelpfulSrcSpan - = hang (quotes (ppr nm)) - 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) - , ppUnless (same_pkg || pkg == mainUnitId) $ - nest 4 $ text "in package" <+> quotes (ppr pkg) ]) - where - pkg = moduleUnitId mod - mod = nameModule nm - loc = nameSrcSpan nm - -{- -Note [Suggest adding a type signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The OutsideIn algorithm rejects GADT programs that don't have a principal -type, and indeed some that do. Example: - data T a where - MkT :: Int -> T Int - - f (MkT n) = n - -Does this have type f :: T a -> a, or f :: T a -> Int? -The error that shows up tends to be an attempt to unify an -untouchable type variable. So suggestAddSig sees if the offending -type variable is bound by an *inferred* signature, and suggests -adding a declared signature instead. - -This initially came up in #8968, concerning pattern synonyms. - -Note [Disambiguating (X ~ X) errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #8278 - -Note [Reporting occurs-check errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied -type signature, then the best thing is to report that we can't unify -a with [a], because a is a skolem variable. That avoids the confusing -"occur-check" error message. - -But nowadays when inferring the type of a function with no type signature, -even if there are errors inside, we still generalise its signature and -carry on. For example - f x = x:x -Here we will infer something like - f :: forall a. a -> [a] -with a deferred error of (a ~ [a]). So in the deferred unsolved constraint -'a' is now a skolem, but not one bound by the programmer in the context! -Here we really should report an occurs check. - -So isUserSkolem distinguishes the two. - -Note [Non-injective type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very confusing to get a message like - Couldn't match expected type `Depend s' - against inferred type `Depend s1' -so mkTyFunInfoMsg adds: - NB: `Depend' is type function, and hence may not be injective - -Warn of loopy local equalities that were dropped. - - -************************************************************************ -* * - Type-class errors -* * -************************************************************************ --} - -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -mkDictErr ctxt cts - = ASSERT( not (null cts) ) - do { inst_envs <- tcGetInstEnvs - ; let (ct1:_) = cts -- ct1 just for its location - min_cts = elim_superclasses cts - lookups = map (lookup_cls_inst inst_envs) min_cts - (no_inst_cts, overlap_cts) = partition is_no_inst lookups - - -- Report definite no-instance errors, - -- or (iff there are none) overlap errors - -- But we report only one of them (hence 'head') because they all - -- have the same source-location origin, to try avoid a cascade - -- of error from one location - ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) - ; mkErrorMsgFromCt ctxt ct1 (important err) } - where - no_givens = null (getUserGivens ctxt) - - is_no_inst (ct, (matches, unifiers, _)) - = no_givens - && null matches - && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) - - lookup_cls_inst inst_envs ct - -- Note [Flattening in error message generation] - = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys)) - where - (clas, tys) = getClassPredTys (ctPred ct) - - - -- When simplifying [W] Ord (Set a), we need - -- [W] Eq a, [W] Ord a - -- but we really only want to report the latter - elim_superclasses cts = mkMinimalBySCs ctPred cts - -mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) - -> TcM (ReportErrCtxt, SDoc) --- Report an overlap error if this class constraint results --- from an overlap (returning Left clas), otherwise return (Right pred) -mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped)) - | null matches -- No matches but perhaps several unifiers - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; candidate_insts <- get_candidate_instances - ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) } - - | null unsafe_overlapped -- Some matches => overlap errors - = return (ctxt, overlap_msg) - - | otherwise - = return (ctxt, safe_haskell_msg) - where - orig = ctOrigin ct - pred = ctPred ct - (clas, tys) = getClassPredTys pred - ispecs = [ispec | (ispec, _) <- matches] - unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] - useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) - -- useful_givens are the enclosing implications with non-empty givens, - -- modulo the horrid discardProvCtxtGivens - - get_candidate_instances :: TcM [ClsInst] - -- See Note [Report candidate instances] - get_candidate_instances - | [ty] <- tys -- Only try for single-parameter classes - = do { instEnvs <- tcGetInstEnvs - ; return (filter (is_candidate_inst ty) - (classInstances instEnvs clas)) } - | otherwise = return [] - - is_candidate_inst ty inst -- See Note [Report candidate instances] - | [other_ty] <- is_tys inst - , Just (tc1, _) <- tcSplitTyConApp_maybe ty - , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty - = let n1 = tyConName tc1 - n2 = tyConName tc2 - different_names = n1 /= n2 - same_occ_names = nameOccName n1 == nameOccName n2 - in different_names && same_occ_names - | otherwise = False - - cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc - cannot_resolve_msg ct candidate_insts binds_msg - = vcat [ no_inst_msg - , nest 2 extra_note - , vcat (pp_givens useful_givens) - , mb_patsyn_prov `orElse` empty - , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens)) - (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ]) - - , ppWhen (isNothing mb_patsyn_prov) $ - -- Don't suggest fixes for the provided context of a pattern - -- synonym; the right fix is to bind more in the pattern - show_fixes (ctxtFixes has_ambig_tvs pred implics - ++ drv_fixes) - , ppWhen (not (null candidate_insts)) - (hang (text "There are instances for similar types:") - 2 (vcat (map ppr candidate_insts))) ] - -- See Note [Report candidate instances] - where - orig = ctOrigin ct - -- See Note [Highlighting ambiguous type variables] - lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs) - && not (null unifiers) && null useful_givens - - (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct - ambig_tvs = uncurry (++) (getAmbigTkvs ct) - - no_inst_msg - | lead_with_ambig - = ambig_msg <+> pprArising orig - $$ text "prevents the constraint" <+> quotes (pprParendType pred) - <+> text "from being solved." - - | null useful_givens - = addArising orig $ text "No instance for" - <+> pprParendType pred - - | otherwise - = addArising orig $ text "Could not deduce" - <+> pprParendType pred - - potential_msg - = ppWhen (not (null unifiers) && want_potential orig) $ - sdocOption sdocPrintPotentialInstances $ \print_insts -> - getPprStyle $ \sty -> - pprPotentials (PrintPotentialInstances print_insts) sty potential_hdr unifiers - - potential_hdr - = vcat [ ppWhen lead_with_ambig $ - text "Probable fix: use a type annotation to specify what" - <+> pprQuotedList ambig_tvs <+> text "should be." - , text "These potential instance" <> plural unifiers - <+> text "exist:"] - - mb_patsyn_prov :: Maybe SDoc - mb_patsyn_prov - | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig - = Just (vcat [ text "In other words, a successful match on the pattern" - , nest 2 $ ppr pat - , text "does not provide the constraint" <+> pprParendType pred ]) - | otherwise = Nothing - - -- Report "potential instances" only when the constraint arises - -- directly from the user's use of an overloaded function - want_potential (TypeEqOrigin {}) = False - want_potential _ = True - - extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) - = text "(maybe you haven't applied a function to enough arguments?)" - | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) - , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) - , Just (tc,_) <- tcSplitTyConApp_maybe ty - , not (isTypeFamilyTyCon tc) - = hang (text "GHC can't yet do polykinded") - 2 (text "Typeable" <+> - parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty))) - | otherwise - = empty - - drv_fixes = case orig of - DerivClauseOrigin -> [drv_fix False] - StandAloneDerivOrigin -> [drv_fix True] - DerivOriginDC _ _ standalone -> [drv_fix standalone] - DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] - _ -> [] - - drv_fix standalone_wildcard - | standalone_wildcard - = text "fill in the wildcard constraint yourself" - | otherwise - = hang (text "use a standalone 'deriving instance' declaration,") - 2 (text "so you can specify the instance context yourself") - - -- Normal overlap error - overlap_msg - = ASSERT( not (null matches) ) - vcat [ addArising orig (text "Overlapping instances for" - <+> pprType (mkClassPred clas tys)) - - , ppUnless (null matching_givens) $ - sep [text "Matching givens (or their superclasses):" - , nest 2 (vcat matching_givens)] - - , sdocOption sdocPrintPotentialInstances $ \print_insts -> - getPprStyle $ \sty -> - pprPotentials (PrintPotentialInstances print_insts) sty (text "Matching instances:") $ - ispecs ++ unifiers - - , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ - -- Intuitively, some given matched the wanted in their - -- flattened or rewritten (from given equalities) form - -- but the matcher can't figure that out because the - -- constraints are non-flat and non-rewritten so we - -- simply report back the whole given - -- context. Accelerate Smart.hs showed this problem. - sep [ text "There exists a (perhaps superclass) match:" - , nest 2 (vcat (pp_givens useful_givens))] - - , ppWhen (isSingleton matches) $ - parens (vcat [ text "The choice depends on the instantiation of" <+> - quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys)) - , ppWhen (null (matching_givens)) $ - vcat [ text "To pick the first instance above, use IncoherentInstances" - , text "when compiling the other instance declarations"] - ])] - - matching_givens = mapMaybe matchable useful_givens - - matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) - = case ev_vars_matching of - [] -> Nothing - _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> - ppr (tcl_loc (ic_env implic)) ]) - where ev_vars_matching = [ pred - | ev_var <- evvars - , let pred = evVarPred ev_var - , any can_match (pred : transSuperClasses pred) ] - can_match pred - = case getClassPredTys_maybe pred of - Just (clas', tys') -> clas' == clas - && isJust (tcMatchTys tys tys') - Nothing -> False - - -- Overlap error because of Safe Haskell (first - -- match should be the most specific match) - safe_haskell_msg - = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) ) - vcat [ addArising orig (text "Unsafe overlapping instances for" - <+> pprType (mkClassPred clas tys)) - , sep [text "The matching instance is:", - nest 2 (pprInstance $ head ispecs)] - , vcat [ text "It is compiled in a Safe module and as such can only" - , text "overlap instances from the same module, however it" - , text "overlaps the following instances from different" <+> - text "modules:" - , nest 2 (vcat [pprInstances $ unsafe_ispecs]) - ] - ] - - -ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] -ctxtFixes has_ambig_tvs pred implics - | not has_ambig_tvs - , isTyVarClassPred pred - , (skol:skols) <- usefulContext implics pred - , let what | null skols - , SigSkol (PatSynCtxt {}) _ _ <- skol - = text "\"required\"" - | otherwise - = empty - = [sep [ text "add" <+> pprParendType pred - <+> text "to the" <+> what <+> text "context of" - , nest 2 $ ppr_skol skol $$ - vcat [ text "or" <+> ppr_skol skol - | skol <- skols ] ] ] - | otherwise = [] - where - ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) - ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) - ppr_skol skol_info = ppr skol_info - -discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] -discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] - | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig - = filterOut (discard name) givens - | otherwise - = givens - where - discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' - discard _ _ = False - -usefulContext :: [Implication] -> PredType -> [SkolemInfo] --- usefulContext picks out the implications whose context --- the programmer might plausibly augment to solve 'pred' -usefulContext implics pred - = go implics - where - pred_tvs = tyCoVarsOfType pred - go [] = [] - go (ic : ics) - | implausible ic = rest - | otherwise = ic_info ic : rest - where - -- Stop when the context binds a variable free in the predicate - rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] - | otherwise = go ics - - implausible ic - | null (ic_skols ic) = True - | implausible_info (ic_info ic) = True - | otherwise = False - - implausible_info (SigSkol (InfSigCtxt {}) _ _) = True - implausible_info _ = False - -- Do not suggest adding constraints to an *inferred* type signature - -{- Note [Report candidate instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an unsolved (Num Int), where `Int` is not the Prelude Int, -but comes from some other module, then it may be helpful to point out -that there are some similarly named instances elsewhere. So we get -something like - No instance for (Num Int) arising from the literal ‘3’ - There are instances for similar types: - instance Num GHC.Types.Int -- Defined in ‘GHC.Num’ -Discussion in #9611. - -Note [Highlighting ambiguous type variables] -~------------------------------------------- -When we encounter ambiguous type variables (i.e. type variables -that remain metavariables after type inference), we need a few more -conditions before we can reason that *ambiguity* prevents constraints -from being solved: - - We can't have any givens, as encountering a typeclass error - with given constraints just means we couldn't deduce - a solution satisfying those constraints and as such couldn't - bind the type variable to a known type. - - If we don't have any unifiers, we don't even have potential - instances from which an ambiguity could arise. - - Lastly, I don't want to mess with error reporting for - unknown runtime types so we just fall back to the old message there. -Once these conditions are satisfied, we can safely say that ambiguity prevents -the constraint from being solved. - -Note [discardProvCtxtGivens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In most situations we call all enclosing implications "useful". There is one -exception, and that is when the constraint that causes the error is from the -"provided" context of a pattern synonym declaration: - - pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a - -- required => provided => type - pattern Pat x <- (Just x, 4) - -When checking the pattern RHS we must check that it does actually bind all -the claimed "provided" constraints; in this case, does the pattern (Just x, 4) -bind the (Show a) constraint. Answer: no! - -But the implication we generate for this will look like - forall a. (Num a, Eq a) => [W] Show a -because when checking the pattern we must make the required -constraints available, since they are needed to match the pattern (in -this case the literal '4' needs (Num a, Eq a)). - -BUT we don't want to suggest adding (Show a) to the "required" constraints -of the pattern synonym, thus: - pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a -It would then typecheck but it's silly. We want the /pattern/ to bind -the alleged "provided" constraints, Show a. - -So we suppress that Implication in discardProvCtxtGivens. It's -painfully ad-hoc but the truth is that adding it to the "required" -constraints would work. Suppressing it solves two problems. First, -we never tell the user that we could not deduce a "provided" -constraint from the "required" context. Second, we never give a -possible fix that suggests to add a "provided" constraint to the -"required" context. - -For example, without this distinction the above code gives a bad error -message (showing both problems): - - error: Could not deduce (Show a) ... from the context: (Eq a) - ... Possible fix: add (Show a) to the context of - the signature for pattern synonym `Pat' ... - --} - -show_fixes :: [SDoc] -> SDoc -show_fixes [] = empty -show_fixes (f:fs) = sep [ text "Possible fix:" - , nest 2 (vcat (f : map (text "or" <+>) fs))] - - --- Avoid boolean blindness -newtype PrintPotentialInstances = PrintPotentialInstances Bool - -pprPotentials :: PrintPotentialInstances -> PprStyle -> SDoc -> [ClsInst] -> SDoc --- See Note [Displaying potential instances] -pprPotentials (PrintPotentialInstances show_potentials) sty herald insts - | null insts - = empty - - | null show_these - = hang herald - 2 (vcat [ not_in_scope_msg empty - , flag_hint ]) - - | otherwise - = hang herald - 2 (vcat [ pprInstances show_these - , ppWhen (n_in_scope_hidden > 0) $ - text "...plus" - <+> speakNOf n_in_scope_hidden (text "other") - , not_in_scope_msg (text "...plus") - , flag_hint ]) - where - n_show = 3 :: Int - - (in_scope, not_in_scope) = partition inst_in_scope insts - sorted = sortBy fuzzyClsInstCmp in_scope - show_these | show_potentials = sorted - | otherwise = take n_show sorted - n_in_scope_hidden = length sorted - length show_these - - -- "in scope" means that all the type constructors - -- are lexically in scope; these instances are likely - -- to be more useful - inst_in_scope :: ClsInst -> Bool - inst_in_scope cls_inst = nameSetAll name_in_scope $ - orphNamesOfTypes (is_tys cls_inst) - - name_in_scope name - | isBuiltInSyntax name - = True -- E.g. (->) - | Just mod <- nameModule_maybe name - = qual_in_scope (qualName sty mod (nameOccName name)) - | otherwise - = True - - qual_in_scope :: QualifyName -> Bool - qual_in_scope NameUnqual = True - qual_in_scope (NameQual {}) = True - qual_in_scope _ = False - - not_in_scope_msg herald - | null not_in_scope - = empty - | otherwise - = hang (herald <+> speakNOf (length not_in_scope) (text "instance") - <+> text "involving out-of-scope types") - 2 (ppWhen show_potentials (pprInstances not_in_scope)) - - flag_hint = ppUnless (show_potentials || equalLength show_these insts) $ - text "(use -fprint-potential-instances to see them all)" - -{- Note [Displaying potential instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When showing a list of instances for - - overlapping instances (show ones that match) - - no such instance (show ones that could match) -we want to give it a bit of structure. Here's the plan - -* Say that an instance is "in scope" if all of the - type constructors it mentions are lexically in scope. - These are the ones most likely to be useful to the programmer. - -* Show at most n_show in-scope instances, - and summarise the rest ("plus 3 others") - -* Summarise the not-in-scope instances ("plus 4 not in scope") - -* Add the flag -fshow-potential-instances which replaces the - summary with the full list --} - -{- -Note [Flattening in error message generation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (C (Maybe (F x))), where F is a type function, and we have -instances - C (Maybe Int) and C (Maybe a) -Since (F x) might turn into Int, this is an overlap situation, and -indeed (because of flattening) the main solver will have refrained -from solving. But by the time we get to error message generation, we've -un-flattened the constraint. So we must *re*-flatten it before looking -up in the instance environment, lest we only report one matching -instance when in fact there are two. - -Re-flattening is pretty easy, because we don't need to keep track of -evidence. We don't re-use the code in TcCanonical because that's in -the TcS monad, and we are in TcM here. - -Note [Kind arguments in error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It can be terribly confusing to get an error message like (#9171) - - Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ - with actual type ‘GetParam Base (GetParam Base Int)’ - -The reason may be that the kinds don't match up. Typically you'll get -more useful information, but not when it's as a result of ambiguity. - -To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag -whenever any error message arises due to a kind mismatch. This means that -the above error message would instead be displayed as: - - Couldn't match expected type - ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’ - with actual type - ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’ - -Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. --} - -mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence - -> Ct -> (Bool, SDoc) -mkAmbigMsg prepend_msg ct - | null ambig_kvs && null ambig_tvs = (False, empty) - | otherwise = (True, msg) - where - (ambig_kvs, ambig_tvs) = getAmbigTkvs ct - - msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] - || any isRuntimeUnkSkol ambig_tvs - = vcat [ text "Cannot resolve unknown runtime type" - <> plural ambig_tvs <+> pprQuotedList ambig_tvs - , text "Use :print or :force to determine these types"] - - | not (null ambig_tvs) - = pp_ambig (text "type") ambig_tvs - - | otherwise - = pp_ambig (text "kind") ambig_kvs - - pp_ambig what tkvs - | prepend_msg -- "Ambiguous type variable 't0'" - = text "Ambiguous" <+> what <+> text "variable" - <> plural tkvs <+> pprQuotedList tkvs - - | otherwise -- "The type variable 't0' is ambiguous" - = text "The" <+> what <+> text "variable" <> plural tkvs - <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" - -pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc -pprSkols ctxt tvs - = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs)) - where - pp_one (UnkSkol, tvs) - = hang (pprQuotedList tvs) - 2 (is_or_are tvs "an" "unknown") - pp_one (RuntimeUnkSkol, tvs) - = hang (pprQuotedList tvs) - 2 (is_or_are tvs "an" "unknown runtime") - pp_one (skol_info, tvs) - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "rigid" <+> text "bound by") - , nest 2 (pprSkolInfo skol_info) - , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ] - - is_or_are [_] article adjective = text "is" <+> text article <+> text adjective - <+> text "type variable" - is_or_are _ _ adjective = text "are" <+> text adjective - <+> text "type variables" - -getAmbigTkvs :: Ct -> ([Var],[Var]) -getAmbigTkvs ct - = partition (`elemVarSet` dep_tkv_set) ambig_tkvs - where - tkvs = tyCoVarsOfCtList ct - ambig_tkvs = filter isAmbiguousTyVar tkvs - dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) - -getSkolemInfo :: [Implication] -> [TcTyVar] - -> [(SkolemInfo, [TcTyVar])] -- #14628 --- Get the skolem info for some type variables --- from the implication constraints that bind them. --- --- In the returned (skolem, tvs) pairs, the 'tvs' part is non-empty -getSkolemInfo _ [] - = [] - -getSkolemInfo [] tvs - | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)] -- #14628 - | otherwise = pprPanic "No skolem info:" (ppr tvs) - -getSkolemInfo (implic:implics) tvs - | null tvs_here = getSkolemInfo implics tvs - | otherwise = (ic_info implic, tvs_here) : getSkolemInfo implics tvs_other - where - (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs - ------------------------ --- relevantBindings looks at the value environment and finds values whose --- types mention any of the offending type variables. It has to be --- careful to zonk the Id's type first, so it has to be in the monad. --- We must be careful to pass it a zonked type variable, too. --- --- We always remove closed top-level bindings, though, --- since they are never relevant (cf #8233) - -relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering - -- See #8191 - -> ReportErrCtxt -> Ct - -> TcM (ReportErrCtxt, SDoc, Ct) --- Also returns the zonked and tidied CtOrigin of the constraint -relevantBindings want_filtering ctxt ct - = do { dflags <- getDynFlags - ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) - ; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs - - -- For *kind* errors, report the relevant bindings of the - -- enclosing *type* equality, because that's more useful for the programmer - extra_tvs = case tidy_orig of - KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $ - t1 : maybeToList m_t2 - _ -> emptyVarSet - ; traceTc "relevantBindings" $ - vcat [ ppr ct - , pprCtOrigin (ctLocOrigin loc) - , ppr ct_tvs - , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) - | TcIdBndr id _ <- tcl_bndrs lcl_env ] - , pprWithCommas id - [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] - - ; (tidy_env', docs, discards) - <- go dflags env1 ct_tvs (maxRelevantBinds dflags) - emptyVarSet [] False - (removeBindingShadowing $ tcl_bndrs lcl_env) - -- tcl_bndrs has the innermost bindings first, - -- which are probably the most relevant ones - - ; let doc = ppUnless (null docs) $ - hang (text "Relevant bindings include") - 2 (vcat docs $$ ppWhen discards discardMsg) - - -- Put a zonked, tidied CtOrigin into the Ct - loc' = setCtLocOrigin loc tidy_orig - ct' = setCtLoc ct loc' - ctxt' = ctxt { cec_tidy = tidy_env' } - - ; return (ctxt', doc, ct') } - where - ev = ctEvidence ct - loc = ctEvLoc ev - lcl_env = ctLocEnv loc - - run_out :: Maybe Int -> Bool - run_out Nothing = False - run_out (Just n) = n <= 0 - - dec_max :: Maybe Int -> Maybe Int - dec_max = fmap (\n -> n - 1) - - - go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc] - -> Bool -- True <=> some filtered out due to lack of fuel - -> [TcBinder] - -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out - -- because of lack of fuel - go _ tidy_env _ _ _ docs discards [] - = return (tidy_env, reverse docs, discards) - go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs) - = case tc_bndr of - TcTvBndr {} -> discard_it - TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl - TcIdBndr_ExpType name et top_lvl -> - do { mb_ty <- readExpType_maybe et - -- et really should be filled in by now. But there's a chance - -- it hasn't, if, say, we're reporting a kind error en route to - -- checking a term. See test indexed-types/should_fail/T8129 - -- Or we are reporting errors from the ambiguity check on - -- a local type signature - ; case mb_ty of - Just ty -> go2 name ty top_lvl - Nothing -> discard_it -- No info; discard - } - where - discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs - discards tc_bndrs - go2 id_name id_type top_lvl - = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type - ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) - ; let id_tvs = tyCoVarsOfType tidy_ty - doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (text "bound at" - <+> ppr (getSrcLoc id_name)))] - new_seen = tvs_seen `unionVarSet` id_tvs - - ; if (want_filtering && not (hasPprDebug dflags) - && id_tvs `disjointVarSet` ct_tvs) - -- We want to filter out this binding anyway - -- so discard it silently - then discard_it - - else if isTopLevel top_lvl && not (isNothing n_left) - -- It's a top-level binding and we have not specified - -- -fno-max-relevant-bindings, so discard it silently - then discard_it - - else if run_out n_left && id_tvs `subVarSet` tvs_seen - -- We've run out of n_left fuel and this binding only - -- mentions already-seen type variables, so discard it - then go dflags tidy_env ct_tvs n_left tvs_seen docs - True -- Record that we have now discarded something - tc_bndrs - - -- Keep this binding, decrement fuel - else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen - (doc:docs) discards tc_bndrs } - - -discardMsg :: SDoc -discardMsg = text "(Some bindings suppressed;" <+> - text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" - ------------------------ -warnDefaulting :: [Ct] -> Type -> TcM () -warnDefaulting wanteds default_ty - = do { warn_default <- woptM Opt_WarnTypeDefaults - ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 $ - tyCoVarsOfCtsList (listToBag wanteds) - tidy_wanteds = map (tidyCt tidy_env) wanteds - (loc, ppr_wanteds) = pprWithArising tidy_wanteds - warn_msg = - hang (hsep [ text "Defaulting the following" - , text "constraint" <> plural tidy_wanteds - , text "to type" - , quotes (ppr default_ty) ]) - 2 - ppr_wanteds - ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg } - -{- -Note [Runtime skolems] -~~~~~~~~~~~~~~~~~~~~~~ -We want to give a reasonably helpful error message for ambiguity -arising from *runtime* skolems in the debugger. These -are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType. - -************************************************************************ -* * - Error from the canonicaliser - These ones are called *during* constraint simplification -* * -************************************************************************ --} - -solverDepthErrorTcS :: CtLoc -> TcType -> TcM a -solverDepthErrorTcS loc ty - = setCtLocM loc $ - do { ty <- zonkTcType ty - ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) - tidy_ty = tidyType tidy_env ty - msg - = vcat [ text "Reduction stack overflow; size =" <+> ppr depth - , hang (text "When simplifying the following type:") - 2 (ppr tidy_ty) - , note ] - ; failWithTcM (tidy_env, msg) } - where - depth = ctLocDepth loc - note = vcat - [ text "Use -freduction-depth=0 to disable this check" - , text "(any upper bound you could choose might fail unpredictably with" - , text " minor updates to GHC, so disabling the check is recommended if" - , text " you're sure that type checking should terminate)" ] diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs deleted file mode 100644 index 74ef0ae0b4..0000000000 --- a/compiler/typecheck/TcEvTerm.hs +++ /dev/null @@ -1,71 +0,0 @@ - --- (those who have too heavy dependencies for TcEvidence) -module TcEvTerm - ( evDelayedError, evCallStack ) -where - -import GhcPrelude - -import FastString -import GHC.Core.Type -import GHC.Core -import GHC.Core.Make -import GHC.Types.Literal ( Literal(..) ) -import TcEvidence -import GHC.Driver.Types -import GHC.Driver.Session -import GHC.Types.Name -import GHC.Types.Module -import GHC.Core.Utils -import PrelNames -import GHC.Types.SrcLoc - --- Used with Opt_DeferTypeErrors --- See Note [Deferring coercion errors to runtime] --- in TcSimplify -evDelayedError :: Type -> FastString -> EvTerm -evDelayedError ty msg - = EvExpr $ - Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg] - where - errorId = tYPE_ERROR_ID - litMsg = Lit (LitString (bytesFS msg)) - --- Dictionary for CallStack implicit parameters -evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) => - EvCallStack -> m EvExpr --- See Note [Overview of implicit CallStacks] in TcEvidence.hs -evCallStack cs = do - df <- getDynFlags - let platform = targetPlatform df - m <- getModule - srcLocDataCon <- lookupDataCon srcLocDataConName - let mkSrcLoc l = mkCoreConApps srcLocDataCon <$> - sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m) - , mkStringExprFS (moduleNameFS $ moduleName m) - , mkStringExprFS (srcSpanFile l) - , return $ mkIntExprInt platform (srcSpanStartLine l) - , return $ mkIntExprInt platform (srcSpanStartCol l) - , return $ mkIntExprInt platform (srcSpanEndLine l) - , return $ mkIntExprInt platform (srcSpanEndCol l) - ] - - emptyCS <- Var <$> lookupId emptyCallStackName - - pushCSVar <- lookupId pushCallStackName - let pushCS name loc rest = - mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest] - - let mkPush name loc tm = do - nameExpr <- mkStringExprFS name - locExpr <- mkSrcLoc loc - -- at this point tm :: IP sym CallStack - -- but we need the actual CallStack to pass to pushCS, - -- so we use unwrapIP to strip the dictionary wrapper - -- See Note [Overview of implicit CallStacks] - let ip_co = unwrapIP (exprType tm) - return (pushCS nameExpr locExpr (Cast tm ip_co)) - - case cs of - EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm - EvCsEmpty -> return emptyCS diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs deleted file mode 100644 index 4e89219271..0000000000 --- a/compiler/typecheck/TcEvidence.hs +++ /dev/null @@ -1,1026 +0,0 @@ --- (c) The University of Glasgow 2006 - -{-# LANGUAGE CPP, DeriveDataTypeable #-} -{-# LANGUAGE LambdaCase #-} - -module TcEvidence ( - - -- * HsWrapper - HsWrapper(..), - (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, - mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders, - mkWpFun, idHsWrapper, isIdHsWrapper, isErasableHsWrapper, - pprHsWrapper, - - -- * Evidence bindings - TcEvBinds(..), EvBindsVar(..), - EvBindMap(..), emptyEvBindMap, extendEvBinds, - lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap, - isEmptyEvBindMap, - EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, - evBindVar, isCoEvBindsVar, - - -- * EvTerm (already a CoreExpr) - EvTerm(..), EvExpr, - evId, evCoercion, evCast, evDFunApp, evDataConApp, evSelector, - mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars, - - evTermCoercion, evTermCoercion_maybe, - EvCallStack(..), - EvTypeable(..), - - -- * TcCoercion - TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole, - TcMCoercion, - Role(..), LeftOrRight(..), pickLR, - mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo, - mkTcTyConAppCo, mkTcAppCo, mkTcFunCo, - mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos, - mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo, - tcDowngradeRole, - mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflLeftCo, mkTcPhantomCo, - mkTcCoherenceLeftCo, - mkTcCoherenceRightCo, - mkTcKindCo, - tcCoercionKind, coVarsOfTcCo, - mkTcCoVarCo, - isTcReflCo, isTcReflexiveCo, isTcGReflMCo, tcCoToMCo, - tcCoercionRole, - unwrapIP, wrapIP, - - -- * QuoteWrapper - QuoteWrapper(..), applyQuoteWrapper, quoteWrapperTyVarTy - ) where -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Types.Var -import GHC.Core.Coercion.Axiom -import GHC.Core.Coercion -import GHC.Core.Ppr () -- Instance OutputableBndr TyVar -import TcType -import GHC.Core.Type -import GHC.Core.TyCon -import GHC.Core.DataCon( DataCon, dataConWrapId ) -import GHC.Core.Class( Class ) -import PrelNames -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Core.Predicate -import GHC.Types.Name -import Pair - -import GHC.Core -import GHC.Core.Class ( classSCSelId ) -import GHC.Core.FVs ( exprSomeFreeVars ) - -import Util -import Bag -import qualified Data.Data as Data -import Outputable -import GHC.Types.SrcLoc -import Data.IORef( IORef ) -import GHC.Types.Unique.Set - -{- -Note [TcCoercions] -~~~~~~~~~~~~~~~~~~ -| TcCoercions are a hack used by the typechecker. Normally, -Coercions have free variables of type (a ~# b): we call these -CoVars. However, the type checker passes around equality evidence -(boxed up) at type (a ~ b). - -An TcCoercion is simply a Coercion whose free variables have may be either -boxed or unboxed. After we are done with typechecking the desugarer finds the -boxed free variables, unboxes them, and creates a resulting real Coercion with -kosher free variables. - --} - -type TcCoercion = Coercion -type TcCoercionN = CoercionN -- A Nominal coercion ~N -type TcCoercionR = CoercionR -- A Representational coercion ~R -type TcCoercionP = CoercionP -- a phantom coercion -type TcMCoercion = MCoercion - -mkTcReflCo :: Role -> TcType -> TcCoercion -mkTcSymCo :: TcCoercion -> TcCoercion -mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion -mkTcNomReflCo :: TcType -> TcCoercionN -mkTcRepReflCo :: TcType -> TcCoercionR -mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion -mkTcAppCo :: TcCoercion -> TcCoercionN -> TcCoercion -mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion -mkTcAxInstCo :: Role -> CoAxiom br -> BranchIndex - -> [TcType] -> [TcCoercion] -> TcCoercion -mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] - -> [TcCoercion] -> TcCoercionR -mkTcForAllCo :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion -mkTcForAllCos :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion -mkTcNthCo :: Role -> Int -> TcCoercion -> TcCoercion -mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion -mkTcSubCo :: TcCoercionN -> TcCoercionR -tcDowngradeRole :: Role -> Role -> TcCoercion -> TcCoercion -mkTcAxiomRuleCo :: CoAxiomRule -> [TcCoercion] -> TcCoercionR -mkTcGReflRightCo :: Role -> TcType -> TcCoercionN -> TcCoercion -mkTcGReflLeftCo :: Role -> TcType -> TcCoercionN -> TcCoercion -mkTcCoherenceLeftCo :: Role -> TcType -> TcCoercionN - -> TcCoercion -> TcCoercion -mkTcCoherenceRightCo :: Role -> TcType -> TcCoercionN - -> TcCoercion -> TcCoercion -mkTcPhantomCo :: TcCoercionN -> TcType -> TcType -> TcCoercionP -mkTcKindCo :: TcCoercion -> TcCoercionN -mkTcCoVarCo :: CoVar -> TcCoercion - -tcCoercionKind :: TcCoercion -> Pair TcType -tcCoercionRole :: TcCoercion -> Role -coVarsOfTcCo :: TcCoercion -> TcTyCoVarSet -isTcReflCo :: TcCoercion -> Bool -isTcGReflMCo :: TcMCoercion -> Bool - --- | This version does a slow check, calculating the related types and seeing --- if they are equal. -isTcReflexiveCo :: TcCoercion -> Bool - -mkTcReflCo = mkReflCo -mkTcSymCo = mkSymCo -mkTcTransCo = mkTransCo -mkTcNomReflCo = mkNomReflCo -mkTcRepReflCo = mkRepReflCo -mkTcTyConAppCo = mkTyConAppCo -mkTcAppCo = mkAppCo -mkTcFunCo = mkFunCo -mkTcAxInstCo = mkAxInstCo -mkTcUnbranchedAxInstCo = mkUnbranchedAxInstCo Representational -mkTcForAllCo = mkForAllCo -mkTcForAllCos = mkForAllCos -mkTcNthCo = mkNthCo -mkTcLRCo = mkLRCo -mkTcSubCo = mkSubCo -tcDowngradeRole = downgradeRole -mkTcAxiomRuleCo = mkAxiomRuleCo -mkTcGReflRightCo = mkGReflRightCo -mkTcGReflLeftCo = mkGReflLeftCo -mkTcCoherenceLeftCo = mkCoherenceLeftCo -mkTcCoherenceRightCo = mkCoherenceRightCo -mkTcPhantomCo = mkPhantomCo -mkTcKindCo = mkKindCo -mkTcCoVarCo = mkCoVarCo - -tcCoercionKind = coercionKind -tcCoercionRole = coercionRole -coVarsOfTcCo = coVarsOfCo -isTcReflCo = isReflCo -isTcGReflMCo = isGReflMCo -isTcReflexiveCo = isReflexiveCo - -tcCoToMCo :: TcCoercion -> TcMCoercion -tcCoToMCo = coToMCo - --- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. --- Note that the input coercion should always be nominal. -maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion -maybeTcSubCo NomEq = id -maybeTcSubCo ReprEq = mkTcSubCo - - -{- -%************************************************************************ -%* * - HsWrapper -* * -************************************************************************ --} - -data HsWrapper - = WpHole -- The identity coercion - - | WpCompose HsWrapper HsWrapper - -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] - -- - -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) - -- But ([] a) `WpCompose` ([] b) = ([] b a) - - | WpFun HsWrapper HsWrapper TcType SDoc - -- (WpFun wrap1 wrap2 t1)[e] = \(x:t1). wrap2[ e wrap1[x] ] - -- So note that if wrap1 :: exp_arg <= act_arg - -- wrap2 :: act_res <= exp_res - -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res) - -- This isn't the same as for mkFunCo, but it has to be this way - -- because we can't use 'sym' to flip around these HsWrappers - -- The TcType is the "from" type of the first wrapper - -- The SDoc explains the circumstances under which we have created this - -- WpFun, in case we run afoul of levity polymorphism restrictions in - -- the desugarer. See Note [Levity polymorphism checking] in GHC.HsToCore.Monad - - | WpCast TcCoercionR -- A cast: [] `cast` co - -- Guaranteed not the identity coercion - -- At role Representational - - -- Evidence abstraction and application - -- (both dictionaries and coercions) - | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable - | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint - -- Kind and Type abstraction and application - | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) - | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) - - - | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, - -- so that the identity coercion is always exactly WpHole - --- Cannot derive Data instance because SDoc is not Data (it stores a function). --- So we do it manually: -instance Data.Data HsWrapper where - gfoldl _ z WpHole = z WpHole - gfoldl k z (WpCompose a1 a2) = z WpCompose `k` a1 `k` a2 - gfoldl k z (WpFun a1 a2 a3 _) = z wpFunEmpty `k` a1 `k` a2 `k` a3 - gfoldl k z (WpCast a1) = z WpCast `k` a1 - gfoldl k z (WpEvLam a1) = z WpEvLam `k` a1 - gfoldl k z (WpEvApp a1) = z WpEvApp `k` a1 - gfoldl k z (WpTyLam a1) = z WpTyLam `k` a1 - gfoldl k z (WpTyApp a1) = z WpTyApp `k` a1 - gfoldl k z (WpLet a1) = z WpLet `k` a1 - - gunfold k z c = case Data.constrIndex c of - 1 -> z WpHole - 2 -> k (k (z WpCompose)) - 3 -> k (k (k (z wpFunEmpty))) - 4 -> k (z WpCast) - 5 -> k (z WpEvLam) - 6 -> k (z WpEvApp) - 7 -> k (z WpTyLam) - 8 -> k (z WpTyApp) - _ -> k (z WpLet) - - toConstr WpHole = wpHole_constr - toConstr (WpCompose _ _) = wpCompose_constr - toConstr (WpFun _ _ _ _) = wpFun_constr - toConstr (WpCast _) = wpCast_constr - toConstr (WpEvLam _) = wpEvLam_constr - toConstr (WpEvApp _) = wpEvApp_constr - toConstr (WpTyLam _) = wpTyLam_constr - toConstr (WpTyApp _) = wpTyApp_constr - toConstr (WpLet _) = wpLet_constr - - dataTypeOf _ = hsWrapper_dataType - -hsWrapper_dataType :: Data.DataType -hsWrapper_dataType - = Data.mkDataType "HsWrapper" - [ wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr - , wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr - , wpLet_constr] - -wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr, wpEvLam_constr, - wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr :: Data.Constr -wpHole_constr = mkHsWrapperConstr "WpHole" -wpCompose_constr = mkHsWrapperConstr "WpCompose" -wpFun_constr = mkHsWrapperConstr "WpFun" -wpCast_constr = mkHsWrapperConstr "WpCast" -wpEvLam_constr = mkHsWrapperConstr "WpEvLam" -wpEvApp_constr = mkHsWrapperConstr "WpEvApp" -wpTyLam_constr = mkHsWrapperConstr "WpTyLam" -wpTyApp_constr = mkHsWrapperConstr "WpTyApp" -wpLet_constr = mkHsWrapperConstr "WpLet" - -mkHsWrapperConstr :: String -> Data.Constr -mkHsWrapperConstr name = Data.mkConstr hsWrapper_dataType name [] Data.Prefix - -wpFunEmpty :: HsWrapper -> HsWrapper -> TcType -> HsWrapper -wpFunEmpty c1 c2 t1 = WpFun c1 c2 t1 empty - -(<.>) :: HsWrapper -> HsWrapper -> HsWrapper -WpHole <.> c = c -c <.> WpHole = c -c1 <.> c2 = c1 `WpCompose` c2 - -mkWpFun :: HsWrapper -> HsWrapper - -> TcType -- the "from" type of the first wrapper - -> TcType -- either type of the second wrapper (used only when the - -- second wrapper is the identity) - -> SDoc -- what caused you to want a WpFun? Something like "When converting ..." - -> HsWrapper -mkWpFun WpHole WpHole _ _ _ = WpHole -mkWpFun WpHole (WpCast co2) t1 _ _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2) -mkWpFun (WpCast co1) WpHole _ t2 _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2)) -mkWpFun (WpCast co1) (WpCast co2) _ _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) -mkWpFun co1 co2 t1 _ d = WpFun co1 co2 t1 d - -mkWpCastR :: TcCoercionR -> HsWrapper -mkWpCastR co - | isTcReflCo co = WpHole - | otherwise = ASSERT2(tcCoercionRole co == Representational, ppr co) - WpCast co - -mkWpCastN :: TcCoercionN -> HsWrapper -mkWpCastN co - | isTcReflCo co = WpHole - | otherwise = ASSERT2(tcCoercionRole co == Nominal, ppr co) - WpCast (mkTcSubCo co) - -- The mkTcSubCo converts Nominal to Representational - -mkWpTyApps :: [Type] -> HsWrapper -mkWpTyApps tys = mk_co_app_fn WpTyApp tys - -mkWpEvApps :: [EvTerm] -> HsWrapper -mkWpEvApps args = mk_co_app_fn WpEvApp args - -mkWpEvVarApps :: [EvVar] -> HsWrapper -mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs) - -mkWpTyLams :: [TyVar] -> HsWrapper -mkWpTyLams ids = mk_co_lam_fn WpTyLam ids - -mkWpLams :: [Var] -> HsWrapper -mkWpLams ids = mk_co_lam_fn WpEvLam ids - -mkWpLet :: TcEvBinds -> HsWrapper --- This no-op is a quite a common case -mkWpLet (EvBinds b) | isEmptyBag b = WpHole -mkWpLet ev_binds = WpLet ev_binds - -mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper -mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as - -mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper --- For applications, the *first* argument must --- come *last* in the composition sequence -mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as - -idHsWrapper :: HsWrapper -idHsWrapper = WpHole - -isIdHsWrapper :: HsWrapper -> Bool -isIdHsWrapper WpHole = True -isIdHsWrapper _ = False - --- | Is the wrapper erasable, i.e., will not affect runtime semantics? -isErasableHsWrapper :: HsWrapper -> Bool -isErasableHsWrapper = go - where - go WpHole = True - go (WpCompose wrap1 wrap2) = go wrap1 && go wrap2 - go WpFun{} = False - go WpCast{} = True - go WpEvLam{} = False -- case in point - go WpEvApp{} = False - go WpTyLam{} = True - go WpTyApp{} = True - go WpLet{} = False - -collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper) --- Collect the outer lambda binders of a HsWrapper, --- stopping as soon as you get to a non-lambda binder -collectHsWrapBinders wrap = go wrap [] - where - -- go w ws = collectHsWrapBinders (w <.> w1 <.> ... <.> wn) - go :: HsWrapper -> [HsWrapper] -> ([Var], HsWrapper) - go (WpEvLam v) wraps = add_lam v (gos wraps) - go (WpTyLam v) wraps = add_lam v (gos wraps) - go (WpCompose w1 w2) wraps = go w1 (w2:wraps) - go wrap wraps = ([], foldl' (<.>) wrap wraps) - - gos [] = ([], WpHole) - gos (w:ws) = go w ws - - add_lam v (vs,w) = (v:vs, w) - -{- -************************************************************************ -* * - Evidence bindings -* * -************************************************************************ --} - -data TcEvBinds - = TcEvBinds -- Mutable evidence bindings - EvBindsVar -- Mutable because they are updated "later" - -- when an implication constraint is solved - - | EvBinds -- Immutable after zonking - (Bag EvBind) - -data EvBindsVar - = EvBindsVar { - ebv_uniq :: Unique, - -- The Unique is for debug printing only - - ebv_binds :: IORef EvBindMap, - -- The main payload: the value-level evidence bindings - -- (dictionaries etc) - -- Some Given, some Wanted - - ebv_tcvs :: IORef CoVarSet - -- The free Given coercion vars needed by Wanted coercions that - -- are solved by filling in their HoleDest in-place. Since they - -- don't appear in ebv_binds, we keep track of their free - -- variables so that we can report unused given constraints - -- See Note [Tracking redundant constraints] in TcSimplify - } - - | CoEvBindsVar { -- See Note [Coercion evidence only] - - -- See above for comments on ebv_uniq, ebv_tcvs - ebv_uniq :: Unique, - ebv_tcvs :: IORef CoVarSet - } - -instance Data.Data TcEvBinds where - -- Placeholder; we can't travers into TcEvBinds - toConstr _ = abstractConstr "TcEvBinds" - gunfold _ _ = error "gunfold" - dataTypeOf _ = Data.mkNoRepType "TcEvBinds" - -{- Note [Coercion evidence only] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Class constraints etc give rise to /term/ bindings for evidence, and -we have nowhere to put term bindings in /types/. So in some places we -use CoEvBindsVar (see newCoTcEvBinds) to signal that no term-level -evidence bindings are allowed. Notebly (): - - - Places in types where we are solving kind constraints (all of which - are equalities); see solveEqualities, solveLocalEqualities - - - When unifying forall-types --} - -isCoEvBindsVar :: EvBindsVar -> Bool -isCoEvBindsVar (CoEvBindsVar {}) = True -isCoEvBindsVar (EvBindsVar {}) = False - ------------------ -newtype EvBindMap - = EvBindMap { - ev_bind_varenv :: DVarEnv EvBind - } -- Map from evidence variables to evidence terms - -- We use @DVarEnv@ here to get deterministic ordering when we - -- turn it into a Bag. - -- If we don't do that, when we generate let bindings for - -- dictionaries in dsTcEvBinds they will be generated in random - -- order. - -- - -- For example: - -- - -- let $dEq = GHC.Classes.$fEqInt in - -- let $$dNum = GHC.Num.$fNumInt in ... - -- - -- vs - -- - -- let $dNum = GHC.Num.$fNumInt in - -- let $dEq = GHC.Classes.$fEqInt in ... - -- - -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why - -- @UniqFM@ can lead to nondeterministic order. - -emptyEvBindMap :: EvBindMap -emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyDVarEnv } - -extendEvBinds :: EvBindMap -> EvBind -> EvBindMap -extendEvBinds bs ev_bind - = EvBindMap { ev_bind_varenv = extendDVarEnv (ev_bind_varenv bs) - (eb_lhs ev_bind) - ev_bind } - -isEmptyEvBindMap :: EvBindMap -> Bool -isEmptyEvBindMap (EvBindMap m) = isEmptyDVarEnv m - -lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind -lookupEvBind bs = lookupDVarEnv (ev_bind_varenv bs) - -evBindMapBinds :: EvBindMap -> Bag EvBind -evBindMapBinds = foldEvBindMap consBag emptyBag - -foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a -foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs) - -filterEvBindMap :: (EvBind -> Bool) -> EvBindMap -> EvBindMap -filterEvBindMap k (EvBindMap { ev_bind_varenv = env }) - = EvBindMap { ev_bind_varenv = filterDVarEnv k env } - -instance Outputable EvBindMap where - ppr (EvBindMap m) = ppr m - ------------------ --- All evidence is bound by EvBinds; no side effects -data EvBind - = EvBind { eb_lhs :: EvVar - , eb_rhs :: EvTerm - , eb_is_given :: Bool -- True <=> given - -- See Note [Tracking redundant constraints] in TcSimplify - } - -evBindVar :: EvBind -> EvVar -evBindVar = eb_lhs - -mkWantedEvBind :: EvVar -> EvTerm -> EvBind -mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm } - --- EvTypeable are never given, so we can work with EvExpr here instead of EvTerm -mkGivenEvBind :: EvVar -> EvTerm -> EvBind -mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm } - - --- An EvTerm is, conceptually, a CoreExpr that implements the constraint. --- Unfortunately, we cannot just do --- type EvTerm = CoreExpr --- Because of staging problems issues around EvTypeable -data EvTerm - = EvExpr EvExpr - - | EvTypeable Type EvTypeable -- Dictionary for (Typeable ty) - - | EvFun -- /\as \ds. let binds in v - { et_tvs :: [TyVar] - , et_given :: [EvVar] - , et_binds :: TcEvBinds -- This field is why we need an EvFun - -- constructor, and can't just use EvExpr - , et_body :: EvVar } - - deriving Data.Data - -type EvExpr = CoreExpr - --- An EvTerm is (usually) constructed by any of the constructors here --- and those more complicates ones who were moved to module TcEvTerm - --- | Any sort of evidence Id, including coercions -evId :: EvId -> EvExpr -evId = Var - --- coercion bindings --- See Note [Coercion evidence terms] -evCoercion :: TcCoercion -> EvTerm -evCoercion co = EvExpr (Coercion co) - --- | d |> co -evCast :: EvExpr -> TcCoercion -> EvTerm -evCast et tc | isReflCo tc = EvExpr et - | otherwise = EvExpr (Cast et tc) - --- Dictionary instance application -evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm -evDFunApp df tys ets = EvExpr $ Var df `mkTyApps` tys `mkApps` ets - -evDataConApp :: DataCon -> [Type] -> [EvExpr] -> EvTerm -evDataConApp dc tys ets = evDFunApp (dataConWrapId dc) tys ets - --- Selector id plus the types at which it --- should be instantiated, used for HasField --- dictionaries; see Note [HasField instances] --- in TcInterface -evSelector :: Id -> [Type] -> [EvExpr] -> EvExpr -evSelector sel_id tys tms = Var sel_id `mkTyApps` tys `mkApps` tms - --- Dictionary for (Typeable ty) -evTypeable :: Type -> EvTypeable -> EvTerm -evTypeable = EvTypeable - --- | Instructions on how to make a 'Typeable' dictionary. --- See Note [Typeable evidence terms] -data EvTypeable - = EvTypeableTyCon TyCon [EvTerm] - -- ^ Dictionary for @Typeable T@ where @T@ is a type constructor with all of - -- its kind variables saturated. The @[EvTerm]@ is @Typeable@ evidence for - -- the applied kinds.. - - | EvTypeableTyApp EvTerm EvTerm - -- ^ Dictionary for @Typeable (s t)@, - -- given a dictionaries for @s@ and @t@. - - | EvTypeableTrFun EvTerm EvTerm - -- ^ Dictionary for @Typeable (s -> t)@, - -- given a dictionaries for @s@ and @t@. - - | EvTypeableTyLit EvTerm - -- ^ Dictionary for a type literal, - -- e.g. @Typeable "foo"@ or @Typeable 3@ - -- The 'EvTerm' is evidence of, e.g., @KnownNat 3@ - -- (see #10348) - deriving Data.Data - --- | Evidence for @CallStack@ implicit parameters. -data EvCallStack - -- See Note [Overview of implicit CallStacks] - = EvCsEmpty - | EvCsPushCall Name RealSrcSpan EvExpr - -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at - -- @loc@, in a calling context @stk@. - deriving Data.Data - -{- -Note [Typeable evidence terms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The EvTypeable data type looks isomorphic to Type, but the EvTerms -inside can be EvIds. Eg - f :: forall a. Typeable a => a -> TypeRep - f x = typeRep (undefined :: Proxy [a]) -Here for the (Typeable [a]) dictionary passed to typeRep we make -evidence - dl :: Typeable [a] = EvTypeable [a] - (EvTypeableTyApp (EvTypeableTyCon []) (EvId d)) -where - d :: Typable a -is the lambda-bound dictionary passed into f. - -Note [Coercion evidence terms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "coercion evidence term" takes one of these forms - co_tm ::= EvId v where v :: t1 ~# t2 - | EvCoercion co - | EvCast co_tm co - -We do quite often need to get a TcCoercion from an EvTerm; see -'evTermCoercion'. - -INVARIANT: The evidence for any constraint with type (t1 ~# t2) is -a coercion evidence term. Consider for example - [G] d :: F Int a -If we have - ax7 a :: F Int a ~ (a ~ Bool) -then we do NOT generate the constraint - [G] (d |> ax7 a) :: a ~ Bool -because that does not satisfy the invariant (d is not a coercion variable). -Instead we make a binding - g1 :: a~Bool = g |> ax7 a -and the constraint - [G] g1 :: a~Bool -See #7238 and Note [Bind new Givens immediately] in Constraint - -Note [EvBinds/EvTerm] -~~~~~~~~~~~~~~~~~~~~~ -How evidence is created and updated. Bindings for dictionaries, -and coercions and implicit parameters are carried around in TcEvBinds -which during constraint generation and simplification is always of the -form (TcEvBinds ref). After constraint simplification is finished it -will be transformed to t an (EvBinds ev_bag). - -Evidence for coercions *SHOULD* be filled in using the TcEvBinds -However, all EvVars that correspond to *wanted* coercion terms in -an EvBind must be mutable variables so that they can be readily -inlined (by zonking) after constraint simplification is finished. - -Conclusion: a new wanted coercion variable should be made mutable. -[Notice though that evidence variables that bind coercion terms - from super classes will be "given" and hence rigid] - - -Note [Overview of implicit CallStacks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(See https://gitlab.haskell.org/ghc/ghc/wikis/explicit-call-stack/implicit-locations) - -The goal of CallStack evidence terms is to reify locations -in the program source as runtime values, without any support -from the RTS. We accomplish this by assigning a special meaning -to constraints of type GHC.Stack.Types.HasCallStack, an alias - - type HasCallStack = (?callStack :: CallStack) - -Implicit parameters of type GHC.Stack.Types.CallStack (the name is not -important) are solved in three steps: - -1. Occurrences of CallStack IPs are solved directly from the given IP, - just like a regular IP. For example, the occurrence of `?stk` in - - error :: (?stk :: CallStack) => String -> a - error s = raise (ErrorCall (s ++ prettyCallStack ?stk)) - - will be solved for the `?stk` in `error`s context as before. - -2. In a function call, instead of simply passing the given IP, we first - append the current call-site to it. For example, consider a - call to the callstack-aware `error` above. - - undefined :: (?stk :: CallStack) => a - undefined = error "undefined!" - - Here we want to take the given `?stk` and append the current - call-site, before passing it to `error`. In essence, we want to - rewrite `error "undefined!"` to - - let ?stk = pushCallStack <error's location> ?stk - in error "undefined!" - - We achieve this effect by emitting a NEW wanted - - [W] d :: IP "stk" CallStack - - from which we build the evidence term - - EvCsPushCall "error" <error's location> (EvId d) - - that we use to solve the call to `error`. The new wanted `d` will - then be solved per rule (1), ie as a regular IP. - - (see TcInteract.interactDict) - -3. We default any insoluble CallStacks to the empty CallStack. Suppose - `undefined` did not request a CallStack, ie - - undefinedNoStk :: a - undefinedNoStk = error "undefined!" - - Under the usual IP rules, the new wanted from rule (2) would be - insoluble as there's no given IP from which to solve it, so we - would get an "unbound implicit parameter" error. - - We don't ever want to emit an insoluble CallStack IP, so we add a - defaulting pass to default any remaining wanted CallStacks to the - empty CallStack with the evidence term - - EvCsEmpty - - (see TcSimplify.simpl_top and TcSimplify.defaultCallStacks) - -This provides a lightweight mechanism for building up call-stacks -explicitly, but is notably limited by the fact that the stack will -stop at the first function whose type does not include a CallStack IP. -For example, using the above definition of `undefined`: - - head :: [a] -> a - head [] = undefined - head (x:_) = x - - g = head [] - -the resulting CallStack will include the call to `undefined` in `head` -and the call to `error` in `undefined`, but *not* the call to `head` -in `g`, because `head` did not explicitly request a CallStack. - - -Important Details: -- GHC should NEVER report an insoluble CallStack constraint. - -- GHC should NEVER infer a CallStack constraint unless one was requested - with a partial type signature (See TcType.pickQuantifiablePreds). - -- A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)], - where the String is the name of the binder that is used at the - SrcLoc. SrcLoc is also defined in GHC.Stack.Types and contains the - package/module/file name, as well as the full source-span. Both - CallStack and SrcLoc are kept abstract so only GHC can construct new - values. - -- We will automatically solve any wanted CallStack regardless of the - name of the IP, i.e. - - f = show (?stk :: CallStack) - g = show (?loc :: CallStack) - - are both valid. However, we will only push new SrcLocs onto existing - CallStacks when the IP names match, e.g. in - - head :: (?loc :: CallStack) => [a] -> a - head [] = error (show (?stk :: CallStack)) - - the printed CallStack will NOT include head's call-site. This reflects the - standard scoping rules of implicit-parameters. - -- An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`. - The desugarer will need to unwrap the IP newtype before pushing a new - call-site onto a given stack (See GHC.HsToCore.Binds.dsEvCallStack) - -- When we emit a new wanted CallStack from rule (2) we set its origin to - `IPOccOrigin ip_name` instead of the original `OccurrenceOf func` - (see TcInteract.interactDict). - - This is a bit shady, but is how we ensure that the new wanted is - solved like a regular IP. - --} - -mkEvCast :: EvExpr -> TcCoercion -> EvTerm -mkEvCast ev lco - | ASSERT2( tcCoercionRole lco == Representational - , (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco])) - isTcReflCo lco = EvExpr ev - | otherwise = evCast ev lco - - -mkEvScSelectors -- Assume class (..., D ty, ...) => C a b - :: Class -> [TcType] -- C ty1 ty2 - -> [(TcPredType, -- D ty[ty1/a,ty2/b] - EvExpr) -- :: C ty1 ty2 -> D ty[ty1/a,ty2/b] - ] -mkEvScSelectors cls tys - = zipWith mk_pr (immSuperClasses cls tys) [0..] - where - mk_pr pred i = (pred, Var sc_sel_id `mkTyApps` tys) - where - sc_sel_id = classSCSelId cls i -- Zero-indexed - -emptyTcEvBinds :: TcEvBinds -emptyTcEvBinds = EvBinds emptyBag - -isEmptyTcEvBinds :: TcEvBinds -> Bool -isEmptyTcEvBinds (EvBinds b) = isEmptyBag b -isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" - -evTermCoercion_maybe :: EvTerm -> Maybe TcCoercion --- Applied only to EvTerms of type (s~t) --- See Note [Coercion evidence terms] -evTermCoercion_maybe ev_term - | EvExpr e <- ev_term = go e - | otherwise = Nothing - where - go :: EvExpr -> Maybe TcCoercion - go (Var v) = return (mkCoVarCo v) - go (Coercion co) = return co - go (Cast tm co) = do { co' <- go tm - ; return (mkCoCast co' co) } - go _ = Nothing - -evTermCoercion :: EvTerm -> TcCoercion -evTermCoercion tm = case evTermCoercion_maybe tm of - Just co -> co - Nothing -> pprPanic "evTermCoercion" (ppr tm) - - -{- ********************************************************************* -* * - Free variables -* * -********************************************************************* -} - -findNeededEvVars :: EvBindMap -> VarSet -> VarSet --- Find all the Given evidence needed by seeds, --- looking transitively through binds -findNeededEvVars ev_binds seeds - = transCloVarSet also_needs seeds - where - also_needs :: VarSet -> VarSet - also_needs needs = nonDetFoldUniqSet add emptyVarSet needs - -- It's OK to use nonDetFoldUFM here because we immediately - -- forget about the ordering by creating a set - - add :: Var -> VarSet -> VarSet - add v needs - | Just ev_bind <- lookupEvBind ev_binds v - , EvBind { eb_is_given = is_given, eb_rhs = rhs } <- ev_bind - , is_given - = evVarsOfTerm rhs `unionVarSet` needs - | otherwise - = needs - -evVarsOfTerm :: EvTerm -> VarSet -evVarsOfTerm (EvExpr e) = exprSomeFreeVars isEvVar e -evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev -evVarsOfTerm (EvFun {}) = emptyVarSet -- See Note [Free vars of EvFun] - -evVarsOfTerms :: [EvTerm] -> VarSet -evVarsOfTerms = mapUnionVarSet evVarsOfTerm - -evVarsOfTypeable :: EvTypeable -> VarSet -evVarsOfTypeable ev = - case ev of - EvTypeableTyCon _ e -> mapUnionVarSet evVarsOfTerm e - EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] - EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2] - EvTypeableTyLit e -> evVarsOfTerm e - - -{- Note [Free vars of EvFun] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Finding the free vars of an EvFun is made tricky by the fact the -bindings et_binds may be a mutable variable. Fortunately, we -can just squeeze by. Here's how. - -* evVarsOfTerm is used only by TcSimplify.neededEvVars. -* Each EvBindsVar in an et_binds field of an EvFun is /also/ in the - ic_binds field of an Implication -* So we can track usage via the processing for that implication, - (see Note [Tracking redundant constraints] in TcSimplify). - We can ignore usage from the EvFun altogether. - -************************************************************************ -* * - Pretty printing -* * -************************************************************************ --} - -instance Outputable HsWrapper where - ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>")) - -pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc --- With -fprint-typechecker-elaboration, print the wrapper --- otherwise just print what's inside --- The pp_thing_inside function takes Bool to say whether --- it's in a position that needs parens for a non-atomic thing -pprHsWrapper wrap pp_thing_inside - = sdocOption sdocPrintTypecheckerElaboration $ \case - True -> help pp_thing_inside wrap False - False -> pp_thing_inside False - where - help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc - -- True <=> appears in function application position - -- False <=> appears as body of let or lambda - help it WpHole = it - help it (WpCompose f1 f2) = help (help it f2) f1 - help it (WpFun f1 f2 t1 _) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+> - help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False - help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" - <+> pprParendCo co)] - help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] - help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <> pprParendType ty] - help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False] - help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False] - help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] - -pprLamBndr :: Id -> SDoc -pprLamBndr v = pprBndr LambdaBind v - -add_parens, no_parens :: SDoc -> Bool -> SDoc -add_parens d True = parens d -add_parens d False = d -no_parens d _ = d - -instance Outputable TcEvBinds where - ppr (TcEvBinds v) = ppr v - ppr (EvBinds bs) = text "EvBinds" <> braces (vcat (map ppr (bagToList bs))) - -instance Outputable EvBindsVar where - ppr (EvBindsVar { ebv_uniq = u }) - = text "EvBindsVar" <> angleBrackets (ppr u) - ppr (CoEvBindsVar { ebv_uniq = u }) - = text "CoEvBindsVar" <> angleBrackets (ppr u) - -instance Uniquable EvBindsVar where - getUnique = ebv_uniq - -instance Outputable EvBind where - ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given }) - = sep [ pp_gw <+> ppr v - , nest 2 $ equals <+> ppr e ] - where - pp_gw = brackets (if is_given then char 'G' else char 'W') - -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing - -instance Outputable EvTerm where - ppr (EvExpr e) = ppr e - ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty - ppr (EvFun { et_tvs = tvs, et_given = gs, et_binds = bs, et_body = w }) - = hang (text "\\" <+> sep (map pprLamBndr (tvs ++ gs)) <+> arrow) - 2 (ppr bs $$ ppr w) -- Not very pretty - -instance Outputable EvCallStack where - ppr EvCsEmpty - = text "[]" - ppr (EvCsPushCall name loc tm) - = ppr (name,loc) <+> text ":" <+> ppr tm - -instance Outputable EvTypeable where - ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts - ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) - ppr (EvTypeableTrFun t1 t2) = parens (ppr t1 <+> arrow <+> ppr t2) - ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 - - ----------------------------------------------------------------------- --- Helper functions for dealing with IP newtype-dictionaries ----------------------------------------------------------------------- - --- | Create a 'Coercion' that unwraps an implicit-parameter or --- overloaded-label dictionary to expose the underlying value. We --- expect the 'Type' to have the form `IP sym ty` or `IsLabel sym ty`, --- and return a 'Coercion' `co :: IP sym ty ~ ty` or --- `co :: IsLabel sym ty ~ Proxy# sym -> ty`. See also --- Note [Type-checking overloaded labels] in TcExpr. -unwrapIP :: Type -> CoercionR -unwrapIP ty = - case unwrapNewTyCon_maybe tc of - Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys [] - Nothing -> pprPanic "unwrapIP" $ - text "The dictionary for" <+> quotes (ppr tc) - <+> text "is not a newtype!" - where - (tc, tys) = splitTyConApp ty - --- | Create a 'Coercion' that wraps a value in an implicit-parameter --- dictionary. See 'unwrapIP'. -wrapIP :: Type -> CoercionR -wrapIP ty = mkSymCo (unwrapIP ty) - ----------------------------------------------------------------------- --- A datatype used to pass information when desugaring quotations ----------------------------------------------------------------------- - --- We have to pass a `EvVar` and `Type` into `dsBracket` so that the --- correct evidence and types are applied to all the TH combinators. --- This data type bundles them up together with some convenience methods. --- --- The EvVar is evidence for `Quote m` --- The Type is a metavariable for `m` --- -data QuoteWrapper = QuoteWrapper EvVar Type deriving Data.Data - -quoteWrapperTyVarTy :: QuoteWrapper -> Type -quoteWrapperTyVarTy (QuoteWrapper _ t) = t - --- | Convert the QuoteWrapper into a normal HsWrapper which can be used to --- apply its contents. -applyQuoteWrapper :: QuoteWrapper -> HsWrapper -applyQuoteWrapper (QuoteWrapper ev_var m_var) - = mkWpEvVarApps [ev_var] <.> mkWpTyApps [m_var] diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs deleted file mode 100644 index 63824f5cbe..0000000000 --- a/compiler/typecheck/TcExpr.hs +++ /dev/null @@ -1,2897 +0,0 @@ -{- -% -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcExpr]{Typecheck an expression} --} - -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC, - tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC, - tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, - tcCheckId, - addExprErrCtxt, - addAmbiguousNameErr, - getFixedTyVars ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) -import THNames( liftStringName, liftName ) - -import GHC.Hs -import Constraint ( HoleSort(..) ) -import TcHsSyn -import TcRnMonad -import TcUnify -import GHC.Types.Basic -import Inst -import TcBinds ( chooseInferredQuantifiers, tcLocalBinds ) -import TcSigs ( tcUserTypeSig, tcInstSig ) -import TcSimplify ( simplifyInfer, InferMode(..) ) -import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst ) -import GHC.Core.FamInstEnv ( FamInstEnvs ) -import GHC.Rename.Env ( addUsedGRE ) -import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr ) -import TcEnv -import TcArrows -import TcMatches -import TcHsType -import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr ) -import TcPat -import TcMType -import TcOrigin -import TcType -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.PatSyn -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Name.Reader -import GHC.Core.TyCon -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import GHC.Core.TyCo.Subst (substTyWithInScope) -import GHC.Core.Type -import TcEvidence -import GHC.Types.Var.Set -import TysWiredIn -import TysPrim( intPrimTy ) -import PrimOp( tagToEnumKey ) -import PrelNames -import GHC.Driver.Session -import GHC.Types.SrcLoc -import Util -import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet ) -import ListSetOps -import Maybes -import Outputable -import FastString -import Control.Monad -import GHC.Core.Class(classTyCon) -import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) -import qualified GHC.LanguageExtensions as LangExt - -import Data.Function -import Data.List (partition, sortBy, groupBy, intersect) -import qualified Data.Set as Set - -{- -************************************************************************ -* * -\subsection{Main wrappers} -* * -************************************************************************ --} - -tcPolyExpr, tcPolyExprNC - :: LHsExpr GhcRn -- Expression to type check - -> TcSigmaType -- Expected type (could be a polytype) - -> TcM (LHsExpr GhcTcId) -- Generalised expr with expected type - --- tcPolyExpr is a convenient place (frequent but not too frequent) --- place to add context information. --- The NC version does not do so, usually because the caller wants --- to do so himself. - -tcPolyExpr expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty) -tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty) - --- these versions take an ExpType -tc_poly_expr, tc_poly_expr_nc :: LHsExpr GhcRn -> ExpSigmaType - -> TcM (LHsExpr GhcTcId) -tc_poly_expr expr res_ty - = addExprErrCtxt expr $ - do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty } - -tc_poly_expr_nc (L loc expr) res_ty - = setSrcSpan loc $ - do { traceTc "tcPolyExprNC" (ppr res_ty) - ; (wrap, expr') - <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> - tcExpr expr res_ty - ; return $ L loc (mkHsWrap wrap expr') } - ---------------- -tcMonoExpr, tcMonoExprNC - :: LHsExpr GhcRn -- Expression to type check - -> ExpRhoType -- Expected type - -- Definitely no foralls at the top - -> TcM (LHsExpr GhcTcId) - -tcMonoExpr expr res_ty - = addErrCtxt (exprCtxt expr) $ - tcMonoExprNC expr res_ty - -tcMonoExprNC (L loc expr) res_ty - = setSrcSpan loc $ - do { expr' <- tcExpr expr res_ty - ; return (L loc expr') } - ---------------- -tcInferSigma, tcInferSigmaNC :: LHsExpr GhcRn -> TcM ( LHsExpr GhcTcId - , TcSigmaType ) --- Infer a *sigma*-type. -tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr) - -tcInferSigmaNC (L loc expr) - = setSrcSpan loc $ - do { (expr', sigma) <- tcInferNoInst (tcExpr expr) - ; return (L loc expr', sigma) } - -tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcRhoType) --- Infer a *rho*-type. The return type is always (shallowly) instantiated. -tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr) - -tcInferRhoNC expr - = do { (expr', sigma) <- tcInferSigmaNC expr - ; (wrap, rho) <- topInstantiate (lexprCtOrigin expr) sigma - ; return (mkLHsWrap wrap expr', rho) } - - -{- -************************************************************************ -* * - tcExpr: the main expression typechecker -* * -************************************************************************ - -NB: The res_ty is always deeply skolemised. --} - -tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcExpr (HsVar _ (L _ name)) res_ty = tcCheckId name res_ty -tcExpr e@(HsUnboundVar _ uv) res_ty = tcUnboundId e uv res_ty - -tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty -tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty - -tcExpr e@(HsLit x lit) res_ty - = do { let lit_ty = hsLitType lit - ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } - -tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty - ; return (HsPar x expr') } - -tcExpr (HsPragE x prag expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsPragE x (tc_prag prag) expr') } - where - tc_prag :: HsPragE GhcRn -> HsPragE GhcTc - tc_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann - tc_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl - tc_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo - tc_prag (XHsPragE x) = noExtCon x - -tcExpr (HsOverLit x lit) res_ty - = do { lit' <- newOverloadedLit lit res_ty - ; return (HsOverLit x lit') } - -tcExpr (NegApp x expr neg_expr) res_ty - = do { (expr', neg_expr') - <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ - \[arg_ty] -> - tcMonoExpr expr (mkCheckExpType arg_ty) - ; return (NegApp x expr' neg_expr') } - -tcExpr e@(HsIPVar _ x) res_ty - = do { {- Implicit parameters must have a *tau-type* not a - type scheme. We enforce this by creating a fresh - type variable as its type. (Because res_ty may not - be a tau-type.) -} - ip_ty <- newOpenFlexiTyVarTy - ; let ip_name = mkStrLitTy (hsIPNameFS x) - ; ipClass <- tcLookupClass ipClassName - ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) - ; tcWrapResult e - (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLoc ip_var))) - ip_ty res_ty } - where - -- Coerces a dictionary for `IP "x" t` into `t`. - fromDict ipClass x ty = mkHsWrap $ mkWpCastR $ - unwrapIP $ mkClassPred ipClass [x,ty] - origin = IPOccOrigin x - -tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty - = do { -- See Note [Type-checking overloaded labels] - loc <- getSrcSpanM - ; case mb_fromLabel of - Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty - Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName - ; alpha <- newFlexiTyVarTy liftedTypeKind - ; let pred = mkClassPred isLabelClass [lbl, alpha] - ; loc <- getSrcSpanM - ; var <- emitWantedEvVar origin pred - ; tcWrapResult e - (fromDict pred (HsVar noExtField (L loc var))) - alpha res_ty } } - where - -- Coerces a dictionary for `IsLabel "x" t` into `t`, - -- or `HasField "x" r a into `r -> a`. - fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred - origin = OverLabelOrigin l - lbl = mkStrLitTy l - - applyFromLabel loc fromLabel = - HsAppType noExtField - (L loc (HsVar noExtField (L loc fromLabel))) - (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l)))) - -tcExpr (HsLam x match) res_ty - = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty - ; return (mkHsWrap wrap (HsLam x match')) } - where - match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } - herald = sep [ text "The lambda expression" <+> - quotes (pprSetDepth (PartWay 1) $ - pprMatches match), - -- The pprSetDepth makes the abstraction print briefly - text "has"] - -tcExpr e@(HsLamCase x matches) res_ty - = do { (matches', wrap) - <- tcMatchLambda msg match_ctxt matches res_ty - -- The laziness annotation is because we don't want to fail here - -- if there are multiple arguments - ; return (mkHsWrap wrap $ HsLamCase x matches') } - where - msg = sep [ text "The function" <+> quotes (ppr e) - , text "requires"] - match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } - -tcExpr e@(ExprWithTySig _ expr sig_ty) res_ty - = do { let loc = getLoc (hsSigWcType sig_ty) - ; sig_info <- checkNoErrs $ -- Avoid error cascade - tcUserTypeSig loc sig_ty Nothing - ; (expr', poly_ty) <- tcExprSig expr sig_info - ; let expr'' = ExprWithTySig noExtField expr' sig_ty - ; tcWrapResult e expr'' poly_ty res_ty } - -{- -Note [Type-checking overloaded labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recall that we have - - module GHC.OverloadedLabels where - class IsLabel (x :: Symbol) a where - fromLabel :: a - -We translate `#foo` to `fromLabel @"foo"`, where we use - - * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not - * `GHC.OverloadedLabels.fromLabel`. - -In the `RebindableSyntax` case, the renamer will have filled in the -first field of `HsOverLabel` with the `fromLabel` function to use, and -we simply apply it to the appropriate visible type argument. - -In the `OverloadedLabels` case, when we see an overloaded label like -`#foo`, we generate a fresh variable `alpha` for the type and emit an -`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a -single method, it is represented by a newtype, so we can coerce -`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters). - --} - - -{- -************************************************************************ -* * - Infix operators and sections -* * -************************************************************************ - -Note [Left sections] -~~~~~~~~~~~~~~~~~~~~ -Left sections, like (4 *), are equivalent to - \ x -> (*) 4 x, -or, if PostfixOperators is enabled, just - (*) 4 -With PostfixOperators we don't actually require the function to take -two arguments at all. For example, (x `not`) means (not x); you get -postfix operators! Not Haskell 98, but it's less work and kind of -useful. - -Note [Typing rule for ($)] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -People write - runST $ blah -so much, where - runST :: (forall s. ST s a) -> a -that I have finally given in and written a special type-checking -rule just for saturated applications of ($). - * Infer the type of the first argument - * Decompose it; should be of form (arg2_ty -> res_ty), - where arg2_ty might be a polytype - * Use arg2_ty to typecheck arg2 --} - -tcExpr expr@(OpApp fix arg1 op arg2) res_ty - | (L loc (HsVar _ (L lv op_name))) <- op - , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] - = do { traceTc "Application rule" (ppr op) - ; (arg1', arg1_ty) <- tcInferSigma arg1 - - ; let doc = text "The first argument of ($) takes" - orig1 = lexprCtOrigin arg1 - ; (wrap_arg1, [arg2_sigma], op_res_ty) <- - matchActualFunTys doc orig1 (Just (unLoc arg1)) 1 arg1_ty - - -- We have (arg1 $ arg2) - -- So: arg1_ty = arg2_ty -> op_res_ty - -- where arg2_sigma maybe polymorphic; that's the point - - ; arg2' <- tcArg op arg2 arg2_sigma 2 - - -- Make sure that the argument type has kind '*' - -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b - -- Eg we do not want to allow (D# $ 4.0#) #5570 - -- (which gives a seg fault) - ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma)) - (tcTypeKind arg2_sigma) liftedTypeKind - -- Ignore the evidence. arg2_sigma must have type * or #, - -- because we know (arg2_sigma -> op_res_ty) is well-kinded - -- (because otherwise matchActualFunTys would fail) - -- So this 'unifyKind' will either succeed with Refl, or will - -- produce an insoluble constraint * ~ #, which we'll report later. - - -- NB: unlike the argument type, the *result* type, op_res_ty can - -- have any kind (#8739), so we don't need to check anything for that - - ; op_id <- tcLookupId op_name - ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty - , arg2_sigma - , op_res_ty]) - (HsVar noExtField (L lv op_id))) - -- arg1' :: arg1_ty - -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) - -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty - - expr' = OpApp fix (mkLHsWrap wrap_arg1 arg1') op' arg2' - - ; tcWrapResult expr expr' op_res_ty res_ty } - - | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op - , Just sig_ty <- obviousSig (unLoc arg1) - -- See Note [Disambiguating record fields] - = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty - ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; let op' = L loc (HsRecFld noExtField (Unambiguous sel_name lbl)) - ; tcExpr (OpApp fix arg1 op' arg2) res_ty - } - - | otherwise - = do { traceTc "Non Application rule" (ppr op) - ; (wrap, op', [HsValArg arg1', HsValArg arg2']) - <- tcApp (Just $ mk_op_msg op) - op [HsValArg arg1, HsValArg arg2] res_ty - ; return (mkHsWrap wrap $ OpApp fix arg1' op' arg2') } - --- Right sections, equivalent to \ x -> x `op` expr, or --- \ x -> op x expr - -tcExpr expr@(SectionR x op arg2) res_ty - = do { (op', op_ty) <- tcInferFun op - ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) - <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty - ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) - (mkVisFunTy arg1_ty op_res_ty) res_ty - ; arg2' <- tcArg op arg2 arg2_ty 2 - ; return ( mkHsWrap wrap_res $ - SectionR x (mkLHsWrap wrap_fun op') arg2' ) } - where - fn_orig = lexprCtOrigin op - -- It's important to use the origin of 'op', so that call-stacks - -- come out right; they are driven by the OccurrenceOf CtOrigin - -- See #13285 - -tcExpr expr@(SectionL x arg1 op) res_ty - = do { (op', op_ty) <- tcInferFun op - ; dflags <- getDynFlags -- Note [Left sections] - ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1 - | otherwise = 2 - - ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) - <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) - n_reqd_args op_ty - ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) - (mkVisFunTys arg_tys op_res_ty) res_ty - ; arg1' <- tcArg op arg1 arg1_ty 1 - ; return ( mkHsWrap wrap_res $ - SectionL x arg1' (mkLHsWrap wrap_fn op') ) } - where - fn_orig = lexprCtOrigin op - -- It's important to use the origin of 'op', so that call-stacks - -- come out right; they are driven by the OccurrenceOf CtOrigin - -- See #13285 - -tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty - | all tupArgPresent tup_args - = do { let arity = length tup_args - tup_tc = tupleTyCon boxity arity - -- NB: tupleTyCon doesn't flatten 1-tuples - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make - ; res_ty <- expTypeToType res_ty - ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty - -- Unboxed tuples have RuntimeRep vars, which we - -- don't care about here - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys - Boxed -> arg_tys - ; tup_args1 <- tcTupArgs tup_args arg_tys' - ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) } - - | otherwise - = -- The tup_args are a mixture of Present and Missing (for tuple sections) - do { let arity = length tup_args - - ; arg_tys <- case boxity of - { Boxed -> newFlexiTyVarTys arity liftedTypeKind - ; Unboxed -> replicateM arity newOpenFlexiTyVarTy } - ; let actual_res_ty - = mkVisFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args] - (mkTupleTy1 boxity arg_tys) - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make - - ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple") - (Just expr) - actual_res_ty res_ty - - -- Handle tuple sections where - ; tup_args1 <- tcTupArgs tup_args arg_tys - - ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) } - -tcExpr (ExplicitSum _ alt arity expr) res_ty - = do { let sum_tc = sumTyCon arity - ; res_ty <- expTypeToType res_ty - ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty - ; -- Drop levity vars, we don't care about them here - let arg_tys' = drop arity arg_tys - ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1)) - ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } - --- This will see the empty list only when -XOverloadedLists. --- See Note [Empty lists] in GHC.Hs.Expr. -tcExpr (ExplicitList _ witness exprs) res_ty - = case witness of - Nothing -> do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ - mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' } - - Just fln -> do { ((exprs', elt_ty), fln') - <- tcSyntaxOp ListOrigin fln - [synKnownType intTy, SynList] res_ty $ - \ [elt_ty] -> - do { exprs' <- - mapM (tc_elt elt_ty) exprs - ; return (exprs', elt_ty) } - - ; return $ ExplicitList elt_ty (Just fln') exprs' } - where tc_elt elt_ty expr = tcPolyExpr expr elt_ty - -{- -************************************************************************ -* * - Let, case, if, do -* * -************************************************************************ --} - -tcExpr (HsLet x (L l binds) expr) res_ty - = do { (binds', expr') <- tcLocalBinds binds $ - tcMonoExpr expr res_ty - ; return (HsLet x (L l binds') expr') } - -tcExpr (HsCase x scrut matches) res_ty - = do { -- We used to typecheck the case alternatives first. - -- The case patterns tend to give good type info to use - -- when typechecking the scrutinee. For example - -- case (map f) of - -- (x:xs) -> ... - -- will report that map is applied to too few arguments - -- - -- But now, in the GADT world, we need to typecheck the scrutinee - -- first, to get type info that may be refined in the case alternatives - (scrut', scrut_ty) <- tcInferRho scrut - - ; traceTc "HsCase" (ppr scrut_ty) - ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty - ; return (HsCase x scrut' matches') } - where - match_ctxt = MC { mc_what = CaseAlt, - mc_body = tcBody } - -tcExpr (HsIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' - = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) - ; res_ty <- tauifyExpType res_ty - -- Just like Note [Case branches must never infer a non-tau type] - -- in TcMatches (See #10619) - - ; b1' <- tcMonoExpr b1 res_ty - ; b2' <- tcMonoExpr b2 res_ty - ; return (HsIf x NoSyntaxExprTc pred' b1' b2') } - -tcExpr (HsIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty - = do { ((pred', b1', b2'), fun') - <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $ - \ [pred_ty, b1_ty, b2_ty] -> - do { pred' <- tcPolyExpr pred pred_ty - ; b1' <- tcPolyExpr b1 b1_ty - ; b2' <- tcPolyExpr b2 b2_ty - ; return (pred', b1', b2') } - ; return (HsIf x fun' pred' b1' b2') } - -tcExpr (HsMultiIf _ alts) res_ty - = do { res_ty <- if isSingleton alts - then return res_ty - else tauifyExpType res_ty - -- Just like TcMatches - -- Note [Case branches must never infer a non-tau type] - - ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts - ; res_ty <- readExpType res_ty - ; return (HsMultiIf res_ty alts') } - where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } - -tcExpr (HsDo _ do_or_lc stmts) res_ty - = do { expr' <- tcDoStmts do_or_lc stmts res_ty - ; return expr' } - -tcExpr (HsProc x pat cmd) res_ty - = do { (pat', cmd', coi) <- tcProc pat cmd res_ty - ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } - --- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. --- See Note [Grand plan for static forms] in StaticPtrTable for an overview. --- To type check --- (static e) :: p a --- we want to check (e :: a), --- and wrap (static e) in a call to --- fromStaticPtr :: IsStatic p => StaticPtr a -> p a - -tcExpr (HsStatic fvs expr) res_ty - = do { res_ty <- expTypeToType res_ty - ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty - ; (expr', lie) <- captureConstraints $ - addErrCtxt (hang (text "In the body of a static form:") - 2 (ppr expr) - ) $ - tcPolyExprNC expr expr_ty - - -- Check that the free variables of the static form are closed. - -- It's OK to use nonDetEltsUniqSet here as the only side effects of - -- checkClosedInStaticForm are error messages. - ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs - - -- Require the type of the argument to be Typeable. - -- The evidence is not used, but asking the constraint ensures that - -- the current implementation is as restrictive as future versions - -- of the StaticPointers extension. - ; typeableClass <- tcLookupClass typeableClassName - ; _ <- emitWantedEvVar StaticOrigin $ - mkTyConApp (classTyCon typeableClass) - [liftedTypeKind, expr_ty] - - -- Insert the constraints of the static form in a global list for later - -- validation. - ; emitStaticConstraints lie - - -- Wrap the static form with the 'fromStaticPtr' call. - ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName - [p_ty] - ; let wrap = mkWpTyApps [expr_ty] - ; loc <- getSrcSpanM - ; return $ mkHsWrapCo co $ HsApp noExtField - (L loc $ mkHsWrap wrap fromStaticPtr) - (L loc (HsStatic fvs expr')) - } - -{- -************************************************************************ -* * - Record construction and update -* * -************************************************************************ --} - -tcExpr expr@(RecordCon { rcon_con_name = L loc con_name - , rcon_flds = rbinds }) res_ty - = do { con_like <- tcLookupConLike con_name - - -- Check for missing fields - ; checkMissingFields con_like rbinds - - ; (con_expr, con_sigma) <- tcInferId con_name - ; (con_wrap, con_tau) <- - topInstantiate (OccurrenceOf con_name) con_sigma - -- a shallow instantiation should really be enough for - -- a data constructor. - ; let arity = conLikeArity con_like - Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau - ; case conLikeWrapId_maybe con_like of - Nothing -> nonBidirectionalErr (conLikeName con_like) - Just con_id -> do { - res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon") - (Just expr) actual_res_ty res_ty - ; rbinds' <- tcRecordBinds con_like arg_tys rbinds - ; return $ - mkHsWrap res_wrap $ - RecordCon { rcon_ext = RecordConTc - { rcon_con_like = con_like - , rcon_con_expr = mkHsWrap con_wrap con_expr } - , rcon_con_name = L loc con_id - , rcon_flds = rbinds' } } } - -{- -Note [Type of a record update] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The main complication with RecordUpd is that we need to explicitly -handle the *non-updated* fields. Consider: - - data T a b c = MkT1 { fa :: a, fb :: (b,c) } - | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } - | MkT3 { fd :: a } - - upd :: T a b c -> (b',c) -> T a b' c - upd t x = t { fb = x} - -The result type should be (T a b' c) -not (T a b c), because 'b' *is not* mentioned in a non-updated field -not (T a b' c'), because 'c' *is* mentioned in a non-updated field -NB that it's not good enough to look at just one constructor; we must -look at them all; cf #3219 - -After all, upd should be equivalent to: - upd t x = case t of - MkT1 p q -> MkT1 p x - MkT2 a b -> MkT2 p b - MkT3 d -> error ... - -So we need to give a completely fresh type to the result record, -and then constrain it by the fields that are *not* updated ("p" above). -We call these the "fixed" type variables, and compute them in getFixedTyVars. - -Note that because MkT3 doesn't contain all the fields being updated, -its RHS is simply an error, so it doesn't impose any type constraints. -Hence the use of 'relevant_cont'. - -Note [Implicit type sharing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We also take into account any "implicit" non-update fields. For example - data T a b where { MkT { f::a } :: T a a; ... } -So the "real" type of MkT is: forall ab. (a~b) => a -> T a b - -Then consider - upd t x = t { f=x } -We infer the type - upd :: T a b -> a -> T a b - upd (t::T a b) (x::a) - = case t of { MkT (co:a~b) (_:a) -> MkT co x } -We can't give it the more general type - upd :: T a b -> c -> T c b - -Note [Criteria for update] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to allow update for existentials etc, provided the updated -field isn't part of the existential. For example, this should be ok. - data T a where { MkT { f1::a, f2::b->b } :: T a } - f :: T a -> b -> T b - f t b = t { f1=b } - -The criterion we use is this: - - The types of the updated fields - mention only the universally-quantified type variables - of the data constructor - -NB: this is not (quite) the same as being a "naughty" record selector -(See Note [Naughty record selectors]) in TcTyClsDecls), at least -in the case of GADTs. Consider - data T a where { MkT :: { f :: a } :: T [a] } -Then f is not "naughty" because it has a well-typed record selector. -But we don't allow updates for 'f'. (One could consider trying to -allow this, but it makes my head hurt. Badly. And no one has asked -for it.) - -In principle one could go further, and allow - g :: T a -> T a - g t = t { f2 = \x -> x } -because the expression is polymorphic...but that seems a bridge too far. - -Note [Data family example] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - data instance T (a,b) = MkT { x::a, y::b } - ---> - data :TP a b = MkT { a::a, y::b } - coTP a b :: T (a,b) ~ :TP a b - -Suppose r :: T (t1,t2), e :: t3 -Then r { x=e } :: T (t3,t1) - ---> - case r |> co1 of - MkT x y -> MkT e y |> co2 - where co1 :: T (t1,t2) ~ :TP t1 t2 - co2 :: :TP t3 t2 ~ T (t3,t2) -The wrapping with co2 is done by the constructor wrapper for MkT - -Outgoing invariants -~~~~~~~~~~~~~~~~~~~ -In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): - - * cons are the data constructors to be updated - - * in_inst_tys, out_inst_tys have same length, and instantiate the - *representation* tycon of the data cons. In Note [Data - family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] - -Note [Mixed Record Field Updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following pattern synonym. - - data MyRec = MyRec { foo :: Int, qux :: String } - - pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} - -This allows updates such as the following - - updater :: MyRec -> MyRec - updater a = a {f1 = 1 } - -It would also make sense to allow the following update (which we reject). - - updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two" - -This leads to confusing behaviour when the selectors in fact refer the same -field. - - updater a = a {f1 = 1, foo = 2} ==? ??? - -For this reason, we reject a mixture of pattern synonym and normal record -selectors in the same update block. Although of course we still allow the -following. - - updater a = (a {f1 = 1}) {foo = 2} - - > updater (MyRec 0 "str") - MyRec 2 "str" - --} - -tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty - = ASSERT( notNull rbnds ) - do { -- STEP -2: typecheck the record_expr, the record to be updated - (record_expr', record_rho) <- tcInferRho record_expr - - -- STEP -1 See Note [Disambiguating record fields] - -- After this we know that rbinds is unambiguous - ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty - ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds - upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds - sel_ids = map selectorAmbiguousFieldOcc upd_flds - -- STEP 0 - -- Check that the field names are really field names - -- and they are all field names for proper records or - -- all field names for pattern synonyms. - ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) - | fld <- rbinds, - -- Excludes class ops - let L loc sel_id = hsRecUpdFieldId (unLoc fld), - not (isRecordSelector sel_id), - let fld_name = idName sel_id ] - ; unless (null bad_guys) (sequence bad_guys >> failM) - -- See note [Mixed Record Selectors] - ; let (data_sels, pat_syn_sels) = - partition isDataConRecordSelector sel_ids - ; MASSERT( all isPatSynRecordSelector pat_syn_sels ) - ; checkTc ( null data_sels || null pat_syn_sels ) - ( mixedSelectors data_sels pat_syn_sels ) - - -- STEP 1 - -- Figure out the tycon and data cons from the first field name - ; let -- It's OK to use the non-tc splitters here (for a selector) - sel_id : _ = sel_ids - - mtycon :: Maybe TyCon - mtycon = case idDetails sel_id of - RecSelId (RecSelData tycon) _ -> Just tycon - _ -> Nothing - - con_likes :: [ConLike] - con_likes = case idDetails sel_id of - RecSelId (RecSelData tc) _ - -> map RealDataCon (tyConDataCons tc) - RecSelId (RecSelPatSyn ps) _ - -> [PatSynCon ps] - _ -> panic "tcRecordUpd" - -- NB: for a data type family, the tycon is the instance tycon - - relevant_cons = conLikesWithFields con_likes upd_fld_occs - -- A constructor is only relevant to this process if - -- it contains *all* the fields that are being updated - -- Other ones will cause a runtime error if they occur - - -- Step 2 - -- Check that at least one constructor has all the named fields - -- i.e. has an empty set of bad fields returned by badFields - ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes) - - -- Take apart a representative constructor - ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) - = conLikeFullSig con1 - con1_flds = map flLabel $ conLikeFieldLabels con1 - con1_tv_tys = mkTyVarTys con1_tvs - con1_res_ty = case mtycon of - Just tc -> mkFamilyTyConApp tc con1_tv_tys - Nothing -> conLikeResTy con1 con1_tv_tys - - -- Check that we're not dealing with a unidirectional pattern - -- synonym - ; unless (isJust $ conLikeWrapId_maybe con1) - (nonBidirectionalErr (conLikeName con1)) - - -- STEP 3 Note [Criteria for update] - -- Check that each updated field is polymorphic; that is, its type - -- mentions only the universally-quantified variables of the data con - ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys - bad_upd_flds = filter bad_fld flds1_w_tys - con1_tv_set = mkVarSet con1_tvs - bad_fld (fld, ty) = fld `elem` upd_fld_occs && - not (tyCoVarsOfType ty `subVarSet` con1_tv_set) - ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) - - -- STEP 4 Note [Type of a record update] - -- Figure out types for the scrutinee and result - -- Both are of form (T a b c), with fresh type variables, but with - -- common variables where the scrutinee and result must have the same type - -- These are variables that appear in *any* arg of *any* of the - -- relevant constructors *except* in the updated fields - -- - ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons - is_fixed_tv tv = tv `elemVarSet` fixed_tvs - - mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType) - -- Deals with instantiation of kind variables - -- c.f. TcMType.newMetaTyVars - mk_inst_ty subst (tv, result_inst_ty) - | is_fixed_tv tv -- Same as result type - = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) - | otherwise -- Fresh type, of correct kind - = do { (subst', new_tv) <- newMetaTyVarX subst tv - ; return (subst', mkTyVarTy new_tv) } - - ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs - ; let result_inst_tys = mkTyVarTys con1_tvs' - init_subst = mkEmptyTCvSubst (getTCvInScope result_subst) - - ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst - (con1_tvs `zip` result_inst_tys) - - ; let rec_res_ty = TcType.substTy result_subst con1_res_ty - scrut_ty = TcType.substTy scrut_subst con1_res_ty - con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys - - ; wrap_res <- tcSubTypeHR (exprCtOrigin expr) - (Just expr) rec_res_ty res_ty - ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty - -- NB: normal unification is OK here (as opposed to subsumption), - -- because for this to work out, both record_rho and scrut_ty have - -- to be normal datatypes -- no contravariant stuff can go on - - -- STEP 5 - -- Typecheck the bindings - ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds - - -- STEP 6: Deal with the stupid theta - ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1) - ; instStupidTheta RecordUpdOrigin theta' - - -- Step 7: make a cast for the scrutinee, in the - -- case that it's from a data family - ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty - fam_co | Just tycon <- mtycon - , Just co_con <- tyConFamilyCoercion_maybe tycon - = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys []) - | otherwise - = idHsWrapper - - -- Step 8: Check that the req constraints are satisfied - -- For normal data constructors req_theta is empty but we must do - -- this check for pattern synonyms. - ; let req_theta' = substThetaUnchecked scrut_subst req_theta - ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta' - - -- Phew! - ; return $ - mkHsWrap wrap_res $ - RecordUpd { rupd_expr - = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr') - , rupd_flds = rbinds' - , rupd_ext = RecordUpdTc - { rupd_cons = relevant_cons - , rupd_in_tys = scrut_inst_tys - , rupd_out_tys = result_inst_tys - , rupd_wrap = req_wrap }} } - -tcExpr e@(HsRecFld _ f) res_ty - = tcCheckRecSelId e f res_ty - -{- -************************************************************************ -* * - Arithmetic sequences e.g. [a,b..] - and their parallel-array counterparts e.g. [: a,b.. :] - -* * -************************************************************************ --} - -tcExpr (ArithSeq _ witness seq) res_ty - = tcArithSeq witness seq res_ty - -{- -************************************************************************ -* * - Template Haskell -* * -************************************************************************ --} - --- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceExpr'. --- Here we get rid of it and add the finalizers to the global environment. --- --- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. -tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr))) - res_ty - = do addModFinalizersWithLclEnv mod_finalizers - tcExpr expr res_ty -tcExpr (HsSpliceE _ splice) res_ty - = tcSpliceExpr splice res_ty -tcExpr e@(HsBracket _ brack) res_ty - = tcTypedBracket e brack res_ty -tcExpr e@(HsRnBracketOut _ brack ps) res_ty - = tcUntypedBracket e brack ps res_ty - -{- -************************************************************************ -* * - Catch-all -* * -************************************************************************ --} - -tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) - -- Include ArrForm, ArrApp, which shouldn't appear at all - -- Also HsTcBracketOut, HsQuasiQuoteE - -{- -************************************************************************ -* * - Arithmetic sequences [a..b] etc -* * -************************************************************************ --} - -tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType - -> TcM (HsExpr GhcTcId) - -tcArithSeq witness seq@(From expr) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr' <- tcPolyExpr expr elt_ty - ; enum_from <- newMethodFromName (ArithSeqOrigin seq) - enumFromName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq enum_from wit' (From expr') } - -tcArithSeq witness seq@(FromThen expr1 expr2) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq enum_from_then wit' (FromThen expr1' expr2') } - -tcArithSeq witness seq@(FromTo expr1 expr2) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) - enumFromToName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq enum_from_to wit' (FromTo expr1' expr2') } - -tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty - = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; expr3' <- tcPolyExpr expr3 elt_ty - ; eft <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenToName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } - ------------------ -arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType - -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr GhcTc)) -arithSeqEltType Nothing res_ty - = do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; return (mkWpCastN coi, elt_ty, Nothing) } -arithSeqEltType (Just fl) res_ty - = do { (elt_ty, fl') - <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ - \ [elt_ty] -> return elt_ty - ; return (idHsWrapper, elt_ty, Just fl') } - -{- -************************************************************************ -* * - Applications -* * -************************************************************************ --} - --- HsArg is defined in GHC.Hs.Types - -wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn) - => LHsExpr (GhcPass id) - -> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)] - -> LHsExpr (GhcPass id) -wrapHsArgs f [] = f -wrapHsArgs f (HsValArg a : args) = wrapHsArgs (mkHsApp f a) args -wrapHsArgs f (HsTypeArg _ t : args) = wrapHsArgs (mkHsAppType f t) args -wrapHsArgs f (HsArgPar sp : args) = wrapHsArgs (L sp $ HsPar noExtField f) args - -isHsValArg :: HsArg tm ty -> Bool -isHsValArg (HsValArg {}) = True -isHsValArg (HsTypeArg {}) = False -isHsValArg (HsArgPar {}) = False - -isArgPar :: HsArg tm ty -> Bool -isArgPar (HsArgPar {}) = True -isArgPar (HsValArg {}) = False -isArgPar (HsTypeArg {}) = False - -isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d) -isArgPar_maybe (HsArgPar sp) = Just $ HsArgPar sp -isArgPar_maybe _ = Nothing - -type LHsExprArgIn = HsArg (LHsExpr GhcRn) (LHsWcType GhcRn) -type LHsExprArgOut = HsArg (LHsExpr GhcTcId) (LHsWcType GhcRn) - -tcApp1 :: HsExpr GhcRn -- either HsApp or HsAppType - -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcApp1 e res_ty - = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty - ; return (mkHsWrap wrap $ unLoc $ wrapHsArgs fun args) } - -tcApp :: Maybe SDoc -- like "The function `f' is applied to" - -- or leave out to get exactly that message - -> LHsExpr GhcRn -> [LHsExprArgIn] -- Function and args - -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) - -- (wrap, fun, args). For an ordinary function application, - -- these should be assembled as (wrap (fun args)). - -- But OpApp is slightly different, so that's why the caller - -- must assemble - -tcApp m_herald (L sp (HsPar _ fun)) args res_ty - = tcApp m_herald fun (HsArgPar sp : args) res_ty - -tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty - = tcApp m_herald fun (HsValArg arg1 : args) res_ty - -tcApp m_herald (L _ (HsAppType _ fun ty1)) args res_ty - = tcApp m_herald fun (HsTypeArg noSrcSpan ty1 : args) res_ty - -tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty - | Ambiguous _ lbl <- fld_lbl -- Still ambiguous - , HsValArg (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first - , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates - = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty - ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl) - ; tcFunApp m_herald fun (L loc tc_fun) fun_ty args res_ty } - -tcApp _m_herald (L loc (HsVar _ (L _ fun_id))) args res_ty - -- Special typing rule for tagToEnum# - | fun_id `hasKey` tagToEnumKey - , n_val_args == 1 - = tcTagToEnum loc fun_id args res_ty - where - n_val_args = count isHsValArg args - -tcApp m_herald fun args res_ty - = do { (tc_fun, fun_ty) <- tcInferFun fun - ; tcFunApp m_herald fun tc_fun fun_ty args res_ty } - ---------------------- -tcFunApp :: Maybe SDoc -- like "The function `f' is applied to" - -- or leave out to get exactly that message - -> LHsExpr GhcRn -- Renamed function - -> LHsExpr GhcTcId -> TcSigmaType -- Function and its type - -> [LHsExprArgIn] -- Arguments - -> ExpRhoType -- Overall result type - -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) - -- (wrapper-for-result, fun, args) - -- For an ordinary function application, - -- these should be assembled as wrap_res[ fun args ] - -- But OpApp is slightly different, so that's why the caller - -- must assemble - --- tcFunApp deals with the general case; --- the special cases are handled by tcApp -tcFunApp m_herald rn_fun tc_fun fun_sigma rn_args res_ty - = do { let orig = lexprCtOrigin rn_fun - - ; traceTc "tcFunApp" (ppr rn_fun <+> dcolon <+> ppr fun_sigma $$ ppr rn_args $$ ppr res_ty) - ; (wrap_fun, tc_args, actual_res_ty) - <- tcArgs rn_fun fun_sigma orig rn_args - (m_herald `orElse` mk_app_msg rn_fun rn_args) - - -- this is just like tcWrapResult, but the types don't line - -- up to call that function - ; wrap_res <- addFunResCtxt True (unLoc rn_fun) actual_res_ty res_ty $ - tcSubTypeDS_NC_O orig GenSigCtxt - (Just $ unLoc $ wrapHsArgs rn_fun rn_args) - actual_res_ty res_ty - - ; return (wrap_res, mkLHsWrap wrap_fun tc_fun, tc_args) } - -mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc -mk_app_msg fun args = sep [ text "The" <+> text what <+> quotes (ppr expr) - , text "is applied to"] - where - what | null type_app_args = "function" - | otherwise = "expression" - -- Include visible type arguments (but not other arguments) in the herald. - -- See Note [Herald for matchExpectedFunTys] in TcUnify. - expr = mkHsAppTypes fun type_app_args - type_app_args = [hs_ty | HsTypeArg _ hs_ty <- args] - -mk_op_msg :: LHsExpr GhcRn -> SDoc -mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" - ----------------- -tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType) --- Infer type of a function -tcInferFun (L loc (HsVar _ (L _ name))) - = do { (fun, ty) <- setSrcSpan loc (tcInferId name) - -- Don't wrap a context around a plain Id - ; return (L loc fun, ty) } - -tcInferFun (L loc (HsRecFld _ f)) - = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f) - -- Don't wrap a context around a plain Id - ; return (L loc fun, ty) } - -tcInferFun fun - = tcInferSigma fun - -- NB: tcInferSigma; see TcUnify - -- Note [Deep instantiation of InferResult] in TcUnify - - ----------------- --- | Type-check the arguments to a function, possibly including visible type --- applications -tcArgs :: LHsExpr GhcRn -- ^ The function itself (for err msgs only) - -> TcSigmaType -- ^ the (uninstantiated) type of the function - -> CtOrigin -- ^ the origin for the function's type - -> [LHsExprArgIn] -- ^ the args - -> SDoc -- ^ the herald for matchActualFunTys - -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType) - -- ^ (a wrapper for the function, the tc'd args, result type) -tcArgs fun orig_fun_ty fun_orig orig_args herald - = go [] 1 orig_fun_ty orig_args - where - -- Don't count visible type arguments when determining how many arguments - -- an expression is given in an arity mismatch error, since visible type - -- arguments reported as a part of the expression herald itself. - -- See Note [Herald for matchExpectedFunTys] in TcUnify. - orig_expr_args_arity = count isHsValArg orig_args - - fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] - = case fun of - L _ (HsUnboundVar {}) -> True - _ -> False - - go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty) - - go acc_args n fun_ty (HsArgPar sp : args) - = do { (inner_wrap, args', res_ty) <- go acc_args n fun_ty args - ; return (inner_wrap, HsArgPar sp : args', res_ty) - } - - go acc_args n fun_ty (HsTypeArg l hs_ty_arg : args) - | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] - = go acc_args (n+1) fun_ty args - - | otherwise - = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty - -- wrap1 :: fun_ty "->" upsilon_ty - ; case tcSplitForAllTy_maybe upsilon_ty of - Just (tvb, inner_ty) - | binderArgFlag tvb == Specified -> - -- It really can't be Inferred, because we've justn - -- instantiated those. But, oddly, it might just be Required. - -- See Note [Required quantifiers in the type of a term] - do { let tv = binderVar tvb - kind = tyVarKind tv - ; ty_arg <- tcHsTypeApp hs_ty_arg kind - - ; inner_ty <- zonkTcType inner_ty - -- See Note [Visible type application zonk] - ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg]) - - insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty - -- NB: tv and ty_arg have the same kind, so this - -- substitution is kind-respecting - ; traceTc "VTA" (vcat [ppr tv, debugPprType kind - , debugPprType ty_arg - , debugPprType (tcTypeKind ty_arg) - , debugPprType inner_ty - , debugPprType insted_ty ]) - - ; (inner_wrap, args', res_ty) - <- go acc_args (n+1) insted_ty args - -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty - ; let inst_wrap = mkWpTyApps [ty_arg] - ; return ( inner_wrap <.> inst_wrap <.> wrap1 - , HsTypeArg l hs_ty_arg : args' - , res_ty ) } - _ -> ty_app_err upsilon_ty hs_ty_arg } - - go acc_args n fun_ty (HsValArg arg : args) - = do { (wrap, [arg_ty], res_ty) - <- matchActualFunTysPart herald fun_orig (Just (unLoc fun)) 1 fun_ty - acc_args orig_expr_args_arity - -- wrap :: fun_ty "->" arg_ty -> res_ty - ; arg' <- tcArg fun arg arg_ty n - ; (inner_wrap, args', inner_res_ty) - <- go (arg_ty : acc_args) (n+1) res_ty args - -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty - ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap - , HsValArg arg' : args' - , inner_res_ty ) } - where - doc = text "When checking the" <+> speakNth n <+> - text "argument to" <+> quotes (ppr fun) - - ty_app_err ty arg - = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty - ; failWith $ - text "Cannot apply expression of type" <+> quotes (ppr ty) $$ - text "to a visible type argument" <+> quotes (ppr arg) } - -{- Note [Required quantifiers in the type of a term] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#15859) - - data A k :: k -> Type -- A :: forall k -> k -> Type - type KindOf (a :: k) = k -- KindOf :: forall k. k -> Type - a = (undefind :: KindOf A) @Int - -With ImpredicativeTypes (thin ice, I know), we instantiate -KindOf at type (forall k -> k -> Type), so - KindOf A = forall k -> k -> Type -whose first argument is Required - -We want to reject this type application to Int, but in earlier -GHCs we had an ASSERT that Required could not occur here. - -The ice is thin; c.f. Note [No Required TyCoBinder in terms] -in GHC.Core.TyCo.Rep. - -Note [VTA for out-of-scope functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose 'wurble' is not in scope, and we have - (wurble @Int @Bool True 'x') - -Then the renamer will make (HsUnboundVar "wurble) for 'wurble', -and the typechecker will typecheck it with tcUnboundId, giving it -a type 'alpha', and emitting a deferred CHoleCan constraint, to -be reported later. - -But then comes the visible type application. If we do nothing, we'll -generate an immediate failure (in tc_app_err), saying that a function -of type 'alpha' can't be applied to Bool. That's insane! And indeed -users complain bitterly (#13834, #17150.) - -The right error is the CHoleCan, which has /already/ been emitted by -tcUnboundId. It later reports 'wurble' as out of scope, and tries to -give its type. - -Fortunately in tcArgs we still have access to the function, so we can -check if it is a HsUnboundVar. We use this info to simply skip over -any visible type arguments. We've already inferred the type of the -function, so we'll /already/ have emitted a CHoleCan constraint; -failing preserves that constraint. - -We do /not/ want to fail altogether in this case (via failM) becuase -that may abandon an entire instance decl, which (in the presence of --fdefer-type-errors) leads to leading to #17792. - -Downside; the typechecked term has lost its visible type arguments; we -don't even kind-check them. But let's jump that bridge if we come to -it. Meanwhile, let's not crash! - -Note [Visible type application zonk] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg). - -* tcHsTypeApp only guarantees that - - ty_arg is zonked - - kind(zonk(tv)) = kind(ty_arg) - (checkExpectedKind zonks as it goes). - -So we must zonk inner_ty as well, to guarantee consistency between zonk(tv) -and inner_ty. Otherwise we can build an ill-kinded type. An example was -#14158, where we had: - id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a -and we had the visible type application - id @(->) - -* We instantiated k := kappa, yielding - forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a -* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *). -* That instantiated (->) as ((->) q1 q1), and unified kappa := q1, - Here q1 :: RuntimeRep -* Now we substitute - cat :-> (->) q1 q1 :: TYPE q1 -> TYPE q1 -> * - but we must first zonk the inner_ty to get - forall (a :: TYPE q1). cat a a - so that the result of substitution is well-kinded - Failing to do so led to #14158. --} - ----------------- -tcArg :: LHsExpr GhcRn -- The function (for error messages) - -> LHsExpr GhcRn -- Actual arguments - -> TcRhoType -- expected arg type - -> Int -- # of argument - -> TcM (LHsExpr GhcTcId) -- Resulting argument -tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $ - tcPolyExprNC arg ty - ----------------- -tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId] -tcTupArgs args tys - = ASSERT( equalLength args tys ) mapM go (args `zip` tys) - where - go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty)) - go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty - ; return (L l (Present x expr')) } - go (L _ (XTupArg nec), _) = noExtCon nec - ---------------------------- --- See TcType.SyntaxOpType also for commentary -tcSyntaxOp :: CtOrigin - -> SyntaxExprRn - -> [SyntaxOpType] -- ^ shape of syntax operator arguments - -> ExpRhoType -- ^ overall result type - -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments - -> TcM (a, SyntaxExprTc) --- ^ Typecheck a syntax operator --- The operator is a variable or a lambda at this stage (i.e. renamer --- output) -tcSyntaxOp orig expr arg_tys res_ty - = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) - --- | Slightly more general version of 'tcSyntaxOp' that allows the caller --- to specify the shape of the result of the syntax operator -tcSyntaxOpGen :: CtOrigin - -> SyntaxExprRn - -> [SyntaxOpType] - -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) - -> TcM (a, SyntaxExprTc) -tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside - = do { (expr, sigma) <- tcInferSigma $ noLoc op - ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) - ; (result, expr_wrap, arg_wraps, res_wrap) - <- tcSynArgA orig sigma arg_tys res_ty $ - thing_inside - ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma ) - ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap $ unLoc expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) } -tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen" - -{- -Note [tcSynArg] -~~~~~~~~~~~~~~~ -Because of the rich structure of SyntaxOpType, we must do the -contra-/covariant thing when working down arrows, to get the -instantiation vs. skolemisation decisions correct (and, more -obviously, the orientation of the HsWrappers). We thus have -two tcSynArgs. --} - --- works on "expected" types, skolemising where necessary --- See Note [tcSynArg] -tcSynArgE :: CtOrigin - -> TcSigmaType - -> SyntaxOpType -- ^ shape it is expected to have - -> ([TcSigmaType] -> TcM a) -- ^ check the arguments - -> TcM (a, HsWrapper) - -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) -tcSynArgE orig sigma_ty syn_ty thing_inside - = do { (skol_wrap, (result, ty_wrapper)) - <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty -> - go rho_ty syn_ty - ; return (result, skol_wrap <.> ty_wrapper) } - where - go rho_ty SynAny - = do { result <- thing_inside [rho_ty] - ; return (result, idHsWrapper) } - - go rho_ty SynRho -- same as SynAny, because we skolemise eagerly - = do { result <- thing_inside [rho_ty] - ; return (result, idHsWrapper) } - - go rho_ty SynList - = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty - ; result <- thing_inside [elt_ty] - ; return (result, mkWpCastN list_co) } - - go rho_ty (SynFun arg_shape res_shape) - = do { ( ( ( (result, arg_ty, res_ty) - , res_wrapper ) -- :: res_ty_out "->" res_ty - , arg_wrapper1, [], arg_wrapper2 ) -- :: arg_ty "->" arg_ty_out - , match_wrapper ) -- :: (arg_ty -> res_ty) "->" rho_ty - <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $ - \ [arg_ty] res_ty -> - do { arg_tc_ty <- expTypeToType arg_ty - ; res_tc_ty <- expTypeToType res_ty - - -- another nested arrow is too much for now, - -- but I bet we'll never need this - ; MASSERT2( case arg_shape of - SynFun {} -> False; - _ -> True - , text "Too many nested arrows in SyntaxOpType" $$ - pprCtOrigin orig ) - - ; tcSynArgA orig arg_tc_ty [] arg_shape $ - \ arg_results -> - tcSynArgE orig res_tc_ty res_shape $ - \ res_results -> - do { result <- thing_inside (arg_results ++ res_results) - ; return (result, arg_tc_ty, res_tc_ty) }} - - ; return ( result - , match_wrapper <.> - mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper - arg_ty res_ty doc ) } - where - herald = text "This rebindable syntax expects a function with" - doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig - - go rho_ty (SynType the_ty) - = do { wrap <- tcSubTypeET orig GenSigCtxt the_ty rho_ty - ; result <- thing_inside [] - ; return (result, wrap) } - --- works on "actual" types, instantiating where necessary --- See Note [tcSynArg] -tcSynArgA :: CtOrigin - -> TcSigmaType - -> [SyntaxOpType] -- ^ argument shapes - -> SyntaxOpType -- ^ result shape - -> ([TcSigmaType] -> TcM a) -- ^ check the arguments - -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) - -- ^ returns a wrapper to be applied to the original function, - -- wrappers to be applied to arguments - -- and a wrapper to be applied to the overall expression -tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside - = do { (match_wrapper, arg_tys, res_ty) - <- matchActualFunTys herald orig Nothing (length arg_shapes) sigma_ty - -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) - ; ((result, res_wrapper), arg_wrappers) - <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results -> - tc_syn_arg res_ty res_shape $ \ res_results -> - thing_inside (arg_results ++ res_results) - ; return (result, match_wrapper, arg_wrappers, res_wrapper) } - where - herald = text "This rebindable syntax expects a function with" - - tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType] - -> ([TcSigmaType] -> TcM a) - -> TcM (a, [HsWrapper]) - -- the wrappers are for arguments - tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside - = do { ((result, arg_wraps), arg_wrap) - <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results -> - tc_syn_args_e arg_tys arg_shapes $ \ args_results -> - thing_inside (arg1_results ++ args_results) - ; return (result, arg_wrap : arg_wraps) } - tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] - - tc_syn_arg :: TcSigmaType -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) - -> TcM (a, HsWrapper) - -- the wrapper applies to the overall result - tc_syn_arg res_ty SynAny thing_inside - = do { result <- thing_inside [res_ty] - ; return (result, idHsWrapper) } - tc_syn_arg res_ty SynRho thing_inside - = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty - -- inst_wrap :: res_ty "->" rho_ty - ; result <- thing_inside [rho_ty] - ; return (result, inst_wrap) } - tc_syn_arg res_ty SynList thing_inside - = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty - -- inst_wrap :: res_ty "->" rho_ty - ; (list_co, elt_ty) <- matchExpectedListTy rho_ty - -- list_co :: [elt_ty] ~N rho_ty - ; result <- thing_inside [elt_ty] - ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) } - tc_syn_arg _ (SynFun {}) _ - = pprPanic "tcSynArgA hits a SynFun" (ppr orig) - tc_syn_arg res_ty (SynType the_ty) thing_inside - = do { wrap <- tcSubTypeO orig GenSigCtxt res_ty the_ty - ; result <- thing_inside [] - ; return (result, wrap) } - -{- -Note [Push result type in] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unify with expected result before type-checking the args so that the -info from res_ty percolates to args. This is when we might detect a -too-few args situation. (One can think of cases when the opposite -order would give a better error message.) -experimenting with putting this first. - -Here's an example where it actually makes a real difference - - class C t a b | t a -> b - instance C Char a Bool - - data P t a = forall b. (C t a b) => MkP b - data Q t = MkQ (forall a. P t a) - - f1, f2 :: Q Char; - f1 = MkQ (MkP True) - f2 = MkQ (MkP True :: forall a. P Char a) - -With the change, f1 will type-check, because the 'Char' info from -the signature is propagated into MkQ's argument. With the check -in the other order, the extra signature in f2 is reqd. - -************************************************************************ -* * - Expressions with a type signature - expr :: type -* * -********************************************************************* -} - -tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcType) -tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) - = setSrcSpan loc $ -- Sets the location for the implication constraint - do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id - ; given <- newEvVars theta - ; traceTc "tcExprSig: CompleteSig" $ - vcat [ text "poly_id:" <+> ppr poly_id <+> dcolon <+> ppr (idType poly_id) - , text "tv_prs:" <+> ppr tv_prs ] - - ; let skol_info = SigSkol ExprSigCtxt (idType poly_id) tv_prs - skol_tvs = map snd tv_prs - ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $ - tcExtendNameTyVarEnv tv_prs $ - tcPolyExprNC expr tau - - ; let poly_wrap = mkWpTyLams skol_tvs - <.> mkWpLams given - <.> mkWpLet ev_binds - ; return (mkLHsWrap poly_wrap expr', idType poly_id) } - -tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) - = setSrcSpan loc $ -- Sets the location for the implication constraint - do { (tclvl, wanted, (expr', sig_inst)) - <- pushLevelAndCaptureConstraints $ - do { sig_inst <- tcInstSig sig - ; expr' <- tcExtendNameTyVarEnv (sig_inst_skols sig_inst) $ - tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ - tcPolyExprNC expr (sig_inst_tau sig_inst) - ; return (expr', sig_inst) } - -- See Note [Partial expression signatures] - ; let tau = sig_inst_tau sig_inst - infer_mode | null (sig_inst_theta sig_inst) - , isNothing (sig_inst_wcx sig_inst) - = ApplyMR - | otherwise - = NoRestrictions - ; (qtvs, givens, ev_binds, residual, _) - <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted - ; emitConstraints residual - - ; tau <- zonkTcType tau - ; let inferred_theta = map evVarPred givens - tau_tvs = tyCoVarsOfType tau - ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta - tau_tvs qtvs (Just sig_inst) - ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau - my_sigma = mkForAllTys binders (mkPhiTy my_theta tau) - ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. - then return idHsWrapper -- Fast path; also avoids complaint when we infer - -- an ambiguous type and have AllowAmbiguousType - -- e..g infer x :: forall a. F a -> Int - else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma - - ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) - ; let poly_wrap = wrap - <.> mkWpTyLams qtvs - <.> mkWpLams givens - <.> mkWpLet ev_binds - ; return (mkLHsWrap poly_wrap expr', my_sigma) } - - -{- Note [Partial expression signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Partial type signatures on expressions are easy to get wrong. But -here is a guiding principile - e :: ty -should behave like - let x :: ty - x = e - in x - -So for partial signatures we apply the MR if no context is given. So - e :: IO _ apply the MR - e :: _ => IO _ do not apply the MR -just like in TcBinds.decideGeneralisationPlan - -This makes a difference (#11670): - peek :: Ptr a -> IO CLong - peek ptr = peekElemOff undefined 0 :: _ -from (peekElemOff undefined 0) we get - type: IO w - constraints: Storable w - -We must NOT try to generalise over 'w' because the signature specifies -no constraints so we'll complain about not being able to solve -Storable w. Instead, don't generalise; then _ gets instantiated to -CLong, as it should. --} - -{- ********************************************************************* -* * - tcInferId -* * -********************************************************************* -} - -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcCheckId name res_ty - = do { (expr, actual_res_ty) <- tcInferId name - ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) - ; addFunResCtxt False (HsVar noExtField (noLoc name)) actual_res_ty res_ty $ - tcWrapResultO (OccurrenceOf name) (HsVar noExtField (noLoc name)) expr - actual_res_ty res_ty } - -tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty - = do { (expr, actual_res_ty) <- tcInferRecSelId f - ; addFunResCtxt False (HsRecFld noExtField f) actual_res_ty res_ty $ - tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty } -tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty - = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of - Nothing -> ambiguousSelector lbl - Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg - ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) - res_ty } -tcCheckRecSelId _ (XAmbiguousFieldOcc nec) _ = noExtCon nec - ------------------------- -tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType) -tcInferRecSelId (Unambiguous sel (L _ lbl)) - = do { (expr', ty) <- tc_infer_id lbl sel - ; return (expr', ty) } -tcInferRecSelId (Ambiguous _ lbl) - = ambiguousSelector lbl -tcInferRecSelId (XAmbiguousFieldOcc nec) = noExtCon nec - ------------------------- -tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) --- Look up an occurrence of an Id --- Do not instantiate its type -tcInferId id_name - | id_name `hasKey` tagToEnumKey - = failWithTc (text "tagToEnum# must appear applied to one argument") - -- tcApp catches the case (tagToEnum# arg) - - | id_name `hasKey` assertIdKey - = do { dflags <- getDynFlags - ; if gopt Opt_IgnoreAsserts dflags - then tc_infer_id (nameRdrName id_name) id_name - else tc_infer_assert id_name } - - | otherwise - = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name - ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty) - ; return (expr, ty) } - -tc_infer_assert :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) --- Deal with an occurrence of 'assert' --- See Note [Adding the implicit parameter to 'assert'] -tc_infer_assert assert_name - = do { assert_error_id <- tcLookupId assertErrorName - ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) - (idType assert_error_id) - ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho) - } - -tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType) -tc_infer_id lbl id_name - = do { thing <- tcLookup id_name - ; case thing of - ATcId { tct_id = id } - -> do { check_naughty id -- Note [Local record selectors] - ; checkThLocalId id - ; return_id id } - - AGlobal (AnId id) - -> do { check_naughty id - ; return_id id } - -- A global cannot possibly be ill-staged - -- nor does it need the 'lifting' treatment - -- hence no checkTh stuff here - - AGlobal (AConLike cl) -> case cl of - RealDataCon con -> return_data_con con - PatSynCon ps -> tcPatSynBuilderOcc ps - - _ -> failWithTc $ - ppr thing <+> text "used where a value identifier was expected" } - where - return_id id = return (HsVar noExtField (noLoc id), idType id) - - return_data_con con - -- For data constructors, must perform the stupid-theta check - | null stupid_theta - = return (HsConLikeOut noExtField (RealDataCon con), con_ty) - - | otherwise - -- See Note [Instantiating stupid theta] - = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty - ; (subst, tvs') <- newMetaTyVars tvs - ; let tys' = mkTyVarTys tvs' - theta' = substTheta subst theta - rho' = substTy subst rho - ; wrap <- instCall (OccurrenceOf id_name) tys' theta' - ; addDataConStupidTheta con tys' - ; return ( mkHsWrap wrap (HsConLikeOut noExtField (RealDataCon con)) - , rho') } - - where - con_ty = dataConUserType con - stupid_theta = dataConStupidTheta con - - check_naughty id - | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) - | otherwise = return () - - -tcUnboundId :: HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTcId) --- Typecheck an occurrence of an unbound Id --- --- Some of these started life as a true expression hole "_". --- Others might simply be variables that accidentally have no binding site --- --- We turn all of them into HsVar, since HsUnboundVar can't contain an --- Id; and indeed the evidence for the CHoleCan does bind it, so it's --- not unbound any more! -tcUnboundId rn_expr occ res_ty - = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531) - ; name <- newSysName occ - ; let ev = mkLocalId name ty - ; can <- newHoleCt ExprHole ev ty - ; emitInsoluble can - ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr - (HsVar noExtField (noLoc ev)) ty res_ty } - - -{- -Note [Adding the implicit parameter to 'assert'] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker transforms (assert e1 e2) to (assertError e1 e2). -This isn't really the Right Thing because there's no way to "undo" -if you want to see the original source code in the typechecker -output. We'll have fix this in due course, when we care more about -being able to reconstruct the exact original program. - -Note [tagToEnum#] -~~~~~~~~~~~~~~~~~ -Nasty check to ensure that tagToEnum# is applied to a type that is an -enumeration TyCon. Unification may refine the type later, but this -check won't see that, alas. It's crude, because it relies on our -knowing *now* that the type is ok, which in turn relies on the -eager-unification part of the type checker pushing enough information -here. In theory the Right Thing to do is to have a new form of -constraint but I definitely cannot face that! And it works ok as-is. - -Here's are two cases that should fail - f :: forall a. a - f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable - - g :: Int - g = tagToEnum# 0 -- Int is not an enumeration - -When data type families are involved it's a bit more complicated. - data family F a - data instance F [Int] = A | B | C -Then we want to generate something like - tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int] -Usually that coercion is hidden inside the wrappers for -constructors of F [Int] but here we have to do it explicitly. - -It's all grotesquely complicated. - -Note [Instantiating stupid theta] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, when we infer the type of an Id, we don't instantiate, -because we wish to allow for visible type application later on. -But if a datacon has a stupid theta, we're a bit stuck. We need -to emit the stupid theta constraints with instantiated types. It's -difficult to defer this to the lazy instantiation, because a stupid -theta has no spot to put it in a type. So we just instantiate eagerly -in this case. Thus, users cannot use visible type application with -a data constructor sporting a stupid theta. I won't feel so bad for -the users that complain. - --} - -tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType - -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) --- tagToEnum# :: forall a. Int# -> a --- See Note [tagToEnum#] Urgh! -tcTagToEnum loc fun_name args res_ty - = do { fun <- tcLookupId fun_name - - ; let pars1 = mapMaybe isArgPar_maybe before - pars2 = mapMaybe isArgPar_maybe after - -- args contains exactly one HsValArg - (before, _:after) = break isHsValArg args - - ; arg <- case filterOut isArgPar args of - [HsTypeArg _ hs_ty_arg, HsValArg term_arg] - -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind - ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty - -- other than influencing res_ty, we just - -- don't care about a type arg passed in. - -- So drop the evidence. - ; return term_arg } - [HsValArg term_arg] -> do { _ <- expTypeToType res_ty - ; return term_arg } - _ -> too_many_args "tagToEnum#" args - - ; res_ty <- readExpType res_ty - ; ty' <- zonkTcType res_ty - - -- Check that the type is algebraic - ; let mb_tc_app = tcSplitTyConApp_maybe ty' - Just (tc, tc_args) = mb_tc_app - ; checkTc (isJust mb_tc_app) - (mk_error ty' doc1) - - -- Look through any type family - ; fam_envs <- tcGetFamInstEnvs - ; let (rep_tc, rep_args, coi) - = tcLookupDataFamInst fam_envs tc tc_args - -- coi :: tc tc_args ~R rep_tc rep_args - - ; checkTc (isEnumerationTyCon rep_tc) - (mk_error ty' doc2) - - ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy) - ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExtField (L loc fun))) - rep_ty = mkTyConApp rep_tc rep_args - out_args = concat - [ pars1 - , [HsValArg arg'] - , pars2 - ] - - ; return (mkWpCastR (mkTcSymCo coi), fun', out_args) } - -- coi is a Representational coercion - where - doc1 = vcat [ text "Specify the type by giving a type signature" - , text "e.g. (tagToEnum# x) :: Bool" ] - doc2 = text "Result type must be an enumeration type" - - mk_error :: TcType -> SDoc -> SDoc - mk_error ty what - = hang (text "Bad call to tagToEnum#" - <+> text "at type" <+> ppr ty) - 2 what - -too_many_args :: String -> [LHsExprArgIn] -> TcM a -too_many_args fun args - = failWith $ - hang (text "Too many type arguments to" <+> text fun <> colon) - 2 (sep (map pp args)) - where - pp (HsValArg e) = ppr e - pp (HsTypeArg _ (HsWC { hswc_body = L _ t })) = pprHsType t - pp (HsTypeArg _ (XHsWildCardBndrs nec)) = noExtCon nec - pp (HsArgPar _) = empty - - -{- -************************************************************************ -* * - Template Haskell checks -* * -************************************************************************ --} - -checkThLocalId :: Id -> TcM () --- The renamer has already done checkWellStaged, --- in RnSplice.checkThLocalName, so don't repeat that here. --- Here we just just add constraints fro cross-stage lifting -checkThLocalId id - = do { mb_local_use <- getStageAndBindLevel (idName id) - ; case mb_local_use of - Just (top_lvl, bind_lvl, use_stage) - | thLevel use_stage > bind_lvl - -> checkCrossStageLifting top_lvl id use_stage - _ -> return () -- Not a locally-bound thing, or - -- no cross-stage link - } - --------------------------------------- -checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM () --- If we are inside typed brackets, and (use_lvl > bind_lvl) --- we must check whether there's a cross-stage lift to do --- Examples \x -> [|| x ||] --- [|| map ||] --- --- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but --- this code is applied to *typed* brackets. - -checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) - | isTopLevel top_lvl - = when (isExternalName id_name) (keepAlive id_name) - -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice - - | otherwise - = -- Nested identifiers, such as 'x' in - -- E.g. \x -> [|| h x ||] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the splice proxy, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- bindings of the same splice proxy, but that doesn't - -- matter, although it's a mite untidy. - do { let id_ty = idType id - ; checkTc (isTauTy id_ty) (polySpliceErr id) - -- If x is polymorphic, its occurrence sites might - -- have different instantiations, so we can't use plain - -- 'x' as the splice proxy name. I don't know how to - -- solve this, and it's probably unimportant, so I'm - -- just going to flag an error for now - - ; lift <- if isStringTy id_ty then - do { sid <- tcLookupId THNames.liftStringName - -- See Note [Lifting strings] - ; return (HsVar noExtField (noLoc sid)) } - else - setConstraintVar lie_var $ - -- Put the 'lift' constraint into the right LIE - newMethodFromName (OccurrenceOf id_name) - THNames.liftName - [getRuntimeRep id_ty, id_ty] - - -- Update the pending splices - ; ps <- readMutVar ps_var - ; let pending_splice = PendingTcSplice id_name - (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLoc lift)) - (nlHsVar id)) - ; writeMutVar ps_var (pending_splice : ps) - - ; return () } - where - id_name = idName id - -checkCrossStageLifting _ _ _ = return () - -polySpliceErr :: Id -> SDoc -polySpliceErr id - = text "Can't splice the polymorphic local variable" <+> quotes (ppr id) - -{- -Note [Lifting strings] -~~~~~~~~~~~~~~~~~~~~~~ -If we see $(... [| s |] ...) where s::String, we don't want to -generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. -So this conditional short-circuits the lifting mechanism to generate -(liftString "xy") in that case. I didn't want to use overlapping instances -for the Lift class in TH.Syntax, because that can lead to overlapping-instance -errors in a polymorphic situation. - -If this check fails (which isn't impossible) we get another chance; see -Note [Converting strings] in Convert.hs - -Local record selectors -~~~~~~~~~~~~~~~~~~~~~~ -Record selectors for TyCons in this module are ordinary local bindings, -which show up as ATcIds rather than AGlobals. So we need to check for -naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. - - -************************************************************************ -* * -\subsection{Record bindings} -* * -************************************************************************ --} - -getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet --- These tyvars must not change across the updates -getFixedTyVars upd_fld_occs univ_tvs cons - = mkVarSet [tv1 | con <- cons - , let (u_tvs, _, eqspec, prov_theta - , req_theta, arg_tys, _) - = conLikeFullSig con - theta = eqSpecPreds eqspec - ++ prov_theta - ++ req_theta - flds = conLikeFieldLabels con - fixed_tvs = exactTyCoVarsOfTypes fixed_tys - -- fixed_tys: See Note [Type of a record update] - `unionVarSet` tyCoVarsOfTypes theta - -- Universally-quantified tyvars that - -- appear in any of the *implicit* - -- arguments to the constructor are fixed - -- See Note [Implicit type sharing] - - fixed_tys = [ty | (fl, ty) <- zip flds arg_tys - , not (flLabel fl `elem` upd_fld_occs)] - , (tv1,tv) <- univ_tvs `zip` u_tvs - , tv `elemVarSet` fixed_tvs ] - -{- -Note [Disambiguating record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the -XDuplicateRecordFields extension is used, and the renamer -encounters a record selector or update that it cannot immediately -disambiguate (because it involves fields that belong to multiple -datatypes), it will defer resolution of the ambiguity to the -typechecker. In this case, the `Ambiguous` constructor of -`AmbiguousFieldOcc` is used. - -Consider the following definitions: - - data S = MkS { foo :: Int } - data T = MkT { foo :: Int, bar :: Int } - data U = MkU { bar :: Int, baz :: Int } - -When the renamer sees `foo` as a selector or an update, it will not -know which parent datatype is in use. - -For selectors, there are two possible ways to disambiguate: - -1. Check if the pushed-in type is a function whose domain is a - datatype, for example: - - f s = (foo :: S -> Int) s - - g :: T -> Int - g = foo - - This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`. - -2. Check if the selector is applied to an argument that has a type - signature, for example: - - h = foo (s :: S) - - This is checked by `tcApp`. - - -Updates are slightly more complex. The `disambiguateRecordBinds` -function tries to determine the parent datatype in three ways: - -1. Check for types that have all the fields being updated. For example: - - f x = x { foo = 3, bar = 2 } - - Here `f` must be updating `T` because neither `S` nor `U` have - both fields. This may also discover that no possible type exists. - For example the following will be rejected: - - f' x = x { foo = 3, baz = 3 } - -2. Use the type being pushed in, if it is already a TyConApp. The - following are valid updates to `T`: - - g :: T -> T - g x = x { foo = 3 } - - g' x = x { foo = 3 } :: T - -3. Use the type signature of the record expression, if it exists and - is a TyConApp. Thus this is valid update to `T`: - - h x = (x :: T) { foo = 3 } - - -Note that we do not look up the types of variables being updated, and -no constraint-solving is performed, so for example the following will -be rejected as ambiguous: - - let bad (s :: S) = foo s - - let r :: T - r = blah - in r { foo = 3 } - - \r. (r { foo = 3 }, r :: T ) - -We could add further tests, of a more heuristic nature. For example, -rather than looking for an explicit signature, we could try to infer -the type of the argument to a selector or the record expression being -updated, in case we are lucky enough to get a TyConApp straight -away. However, it might be hard for programmers to predict whether a -particular update is sufficiently obvious for the signature to be -omitted. Moreover, this might change the behaviour of typechecker in -non-obvious ways. - -See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat. --} - --- Given a RdrName that refers to multiple record fields, and the type --- of its argument, try to determine the name of the selector that is --- meant. -disambiguateSelector :: Located RdrName -> Type -> TcM Name -disambiguateSelector lr@(L _ rdr) parent_type - = do { fam_inst_envs <- tcGetFamInstEnvs - ; case tyConOf fam_inst_envs parent_type of - Nothing -> ambiguousSelector lr - Just p -> - do { xs <- lookupParents rdr - ; let parent = RecSelData p - ; case lookup parent xs of - Just gre -> do { addUsedGRE True gre - ; return (gre_name gre) } - Nothing -> failWithTc (fieldNotInType parent rdr) } } - --- This field name really is ambiguous, so add a suitable "ambiguous --- occurrence" error, then give up. -ambiguousSelector :: Located RdrName -> TcM a -ambiguousSelector (L _ rdr) - = do { addAmbiguousNameErr rdr - ; failM } - --- | This name really is ambiguous, so add a suitable "ambiguous --- occurrence" error, then continue -addAmbiguousNameErr :: RdrName -> TcM () -addAmbiguousNameErr rdr - = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_RdrName rdr env - ; setErrCtxt [] $ addNameClashErrRn rdr gres} - --- Disambiguate the fields in a record update. --- See Note [Disambiguating record fields] -disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType - -> [LHsRecUpdField GhcRn] -> ExpRhoType - -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -disambiguateRecordBinds record_expr record_rho rbnds res_ty - -- Are all the fields unambiguous? - = case mapM isUnambiguous rbnds of - -- If so, just skip to looking up the Ids - -- Always the case if DuplicateRecordFields is off - Just rbnds' -> mapM lookupSelector rbnds' - Nothing -> -- If not, try to identify a single parent - do { fam_inst_envs <- tcGetFamInstEnvs - -- Look up the possible parents for each field - ; rbnds_with_parents <- getUpdFieldsParents - ; let possible_parents = map (map fst . snd) rbnds_with_parents - -- Identify a single parent - ; p <- identifyParent fam_inst_envs possible_parents - -- Pick the right selector with that parent for each field - ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents } - where - -- Extract the selector name of a field update if it is unambiguous - isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) - isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of - Unambiguous sel_name _ -> Just (x, sel_name) - Ambiguous{} -> Nothing - XAmbiguousFieldOcc nec -> noExtCon nec - - -- Look up the possible parents and selector GREs for each field - getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn - , [(RecSelParent, GlobalRdrElt)])] - getUpdFieldsParents - = fmap (zip rbnds) $ mapM - (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc) - rbnds - - -- Given a the lists of possible parents for each field, - -- identify a single parent - identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent - identifyParent fam_inst_envs possible_parents - = case foldr1 intersect possible_parents of - -- No parents for all fields: record update is ill-typed - [] -> failWithTc (noPossibleParents rbnds) - - -- Exactly one datatype with all the fields: use that - [p] -> return p - - -- Multiple possible parents: try harder to disambiguate - -- Can we get a parent TyCon from the pushed-in type? - _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p) - - -- Does the expression being updated have a type signature? - -- If so, try to extract a parent TyCon from it - | Just {} <- obviousSig (unLoc record_expr) - , Just tc <- tyConOf fam_inst_envs record_rho - -> return (RecSelData tc) - - -- Nothing else we can try... - _ -> failWithTc badOverloadedUpdate - - -- Make a field unambiguous by choosing the given parent. - -- Emits an error if the field cannot have that parent, - -- e.g. if the user writes - -- r { x = e } :: T - -- where T does not have field x. - pickParent :: RecSelParent - -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)]) - -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) - pickParent p (upd, xs) - = case lookup p xs of - -- Phew! The parent is valid for this field. - -- Previously ambiguous fields must be marked as - -- used now that we know which one is meant, but - -- unambiguous ones shouldn't be recorded again - -- (giving duplicate deprecation warnings). - Just gre -> do { unless (null (tail xs)) $ do - let L loc _ = hsRecFieldLbl (unLoc upd) - setSrcSpan loc $ addUsedGRE True gre - ; lookupSelector (upd, gre_name gre) } - -- The field doesn't belong to this parent, so report - -- an error but keep going through all the fields - Nothing -> do { addErrTc (fieldNotInType p - (unLoc (hsRecUpdFieldRdr (unLoc upd)))) - ; lookupSelector (upd, gre_name (snd (head xs))) } - - -- Given a (field update, selector name) pair, look up the - -- selector to give a field update with an unambiguous Id - lookupSelector :: (LHsRecUpdField GhcRn, Name) - -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) - lookupSelector (L l upd, n) - = do { i <- tcLookupId n - ; let L loc af = hsRecFieldLbl upd - lbl = rdrNameAmbiguousFieldOcc af - ; return $ L l upd { hsRecFieldLbl - = L loc (Unambiguous i (L loc lbl)) } } - - --- Extract the outermost TyCon of a type, if there is one; for --- data families this is the representation tycon (because that's --- where the fields live). -tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon -tyConOf fam_inst_envs ty0 - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) - Nothing -> Nothing - where - (_, _, ty) = tcSplitSigmaTy ty0 - --- Variant of tyConOf that works for ExpTypes -tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon -tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 - --- For an ambiguous record field, find all the candidate record --- selectors (as GlobalRdrElts) and their parents. -lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)] -lookupParents rdr - = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_RdrName rdr env - ; mapM lookupParent gres } - where - lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) - lookupParent gre = do { id <- tcLookupId (gre_name gre) - ; if isRecordSelector id - then return (recordSelectorTyCon id, gre) - else failWithTc (notSelector (gre_name gre)) } - --- A type signature on the argument of an ambiguous record selector or --- the record expression in an update must be "obvious", i.e. the --- outermost constructor ignoring parentheses. -obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) -obviousSig (ExprWithTySig _ _ ty) = Just ty -obviousSig (HsPar _ p) = obviousSig (unLoc p) -obviousSig _ = Nothing - - -{- -Game plan for record bindings -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -1. Find the TyCon for the bindings, from the first field label. - -2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. - -For each binding field = value - -3. Instantiate the field type (from the field label) using the type - envt from step 2. - -4 Type check the value using tcArg, passing the field type as - the expected argument type. - -This extends OK when the field types are universally quantified. --} - -tcRecordBinds - :: ConLike - -> [TcType] -- Expected type for each field - -> HsRecordBinds GhcRn - -> TcM (HsRecordBinds GhcTcId) - -tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) - = do { mb_binds <- mapM do_bind rbinds - ; return (HsRecFields (catMaybes mb_binds) dd) } - where - fields = map flSelector $ conLikeFieldLabels con_like - flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys - - do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) - -> TcM (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))) - do_bind (L l fld@(HsRecField { hsRecFieldLbl = f - , hsRecFieldArg = rhs })) - - = do { mb <- tcRecordField con_like flds_w_tys f rhs - ; case mb of - Nothing -> return Nothing - Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' - , hsRecFieldArg = rhs' }))) } - -tcRecordUpd - :: ConLike - -> [TcType] -- Expected type for each field - -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] - -> TcM [LHsRecUpdField GhcTcId] - -tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds - where - fields = map flSelector $ conLikeFieldLabels con_like - flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys - - do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) - -> TcM (Maybe (LHsRecUpdField GhcTcId)) - do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af - , hsRecFieldArg = rhs })) - = do { let lbl = rdrNameAmbiguousFieldOcc af - sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (idName sel_id) (L loc lbl)) - ; mb <- tcRecordField con_like flds_w_tys f rhs - ; case mb of - Nothing -> return Nothing - Just (f', rhs') -> - return (Just - (L l (fld { hsRecFieldLbl - = L loc (Unambiguous - (extFieldOcc (unLoc f')) - (L loc lbl)) - , hsRecFieldArg = rhs' }))) } - -tcRecordField :: ConLike -> Assoc Name Type - -> LFieldOcc GhcRn -> LHsExpr GhcRn - -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) -tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs - | Just field_ty <- assocMaybe flds_w_tys sel_name - = addErrCtxt (fieldCtxt field_lbl) $ - do { rhs' <- tcPolyExprNC rhs field_ty - ; let field_id = mkUserLocal (nameOccName sel_name) - (nameUnique sel_name) - field_ty loc - -- Yuk: the field_id has the *unique* of the selector Id - -- (so we can find it easily) - -- but is a LocalId with the appropriate type of the RHS - -- (so the desugarer knows the type of local binder to make) - ; return (Just (L loc (FieldOcc field_id lbl), rhs')) } - | otherwise - = do { addErrTc (badFieldCon con_like field_lbl) - ; return Nothing } - where - field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) -tcRecordField _ _ (L _ (XFieldOcc nec)) _ = noExtCon nec - - -checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () -checkMissingFields con_like rbinds - | null field_labels -- Not declared as a record; - -- But C{} is still valid if no strict fields - = if any isBanged field_strs then - -- Illegal if any arg is strict - addErrTc (missingStrictFields con_like []) - else do - warn <- woptM Opt_WarnMissingFields - when (warn && notNull field_strs && null field_labels) - (warnTc (Reason Opt_WarnMissingFields) True - (missingFields con_like [])) - - | otherwise = do -- A record - unless (null missing_s_fields) - (addErrTc (missingStrictFields con_like missing_s_fields)) - - warn <- woptM Opt_WarnMissingFields - when (warn && notNull missing_ns_fields) - (warnTc (Reason Opt_WarnMissingFields) True - (missingFields con_like missing_ns_fields)) - - where - missing_s_fields - = [ flLabel fl | (fl, str) <- field_info, - isBanged str, - not (fl `elemField` field_names_used) - ] - missing_ns_fields - = [ flLabel fl | (fl, str) <- field_info, - not (isBanged str), - not (fl `elemField` field_names_used) - ] - - field_names_used = hsRecFields rbinds - field_labels = conLikeFieldLabels con_like - - field_info = zipEqual "missingFields" - field_labels - field_strs - - field_strs = conLikeImplBangs con_like - - fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds - -{- -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -Boring and alphabetical: --} - -addExprErrCtxt :: LHsExpr GhcRn -> TcM a -> TcM a -addExprErrCtxt expr = addErrCtxt (exprCtxt expr) - -exprCtxt :: LHsExpr GhcRn -> SDoc -exprCtxt expr - = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr)) - -fieldCtxt :: FieldLabelString -> SDoc -fieldCtxt field_name - = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") - -addFunResCtxt :: Bool -- There is at least one argument - -> HsExpr GhcRn -> TcType -> ExpRhoType - -> TcM a -> TcM a --- When we have a mis-match in the return type of a function --- try to give a helpful message about too many/few arguments --- --- Used for naked variables too; but with has_args = False -addFunResCtxt has_args fun fun_res_ty env_ty - = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) - -- NB: use a landmark error context, so that an empty context - -- doesn't suppress some more useful context - where - mk_msg - = do { mb_env_ty <- readExpType_maybe env_ty - -- by the time the message is rendered, the ExpType - -- will be filled in (except if we're debugging) - ; fun_res' <- zonkTcType fun_res_ty - ; env' <- case mb_env_ty of - Just env_ty -> zonkTcType env_ty - Nothing -> - do { dumping <- doptM Opt_D_dump_tc_trace - ; MASSERT( dumping ) - ; newFlexiTyVarTy liftedTypeKind } - ; let -- See Note [Splitting nested sigma types in mismatched - -- function types] - (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res' - -- No need to call tcSplitNestedSigmaTys here, since env_ty is - -- an ExpRhoTy, i.e., it's already deeply instantiated. - (_, _, env_tau) = tcSplitSigmaTy env' - (args_fun, res_fun) = tcSplitFunTys fun_tau - (args_env, res_env) = tcSplitFunTys env_tau - n_fun = length args_fun - n_env = length args_env - info | n_fun == n_env = Outputable.empty - | n_fun > n_env - , not_fun res_env - = text "Probable cause:" <+> quotes (ppr fun) - <+> text "is applied to too few arguments" - - | has_args - , not_fun res_fun - = text "Possible cause:" <+> quotes (ppr fun) - <+> text "is applied to too many arguments" - - | otherwise - = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args! - ; return info } - where - not_fun ty -- ty is definitely not an arrow type, - -- and cannot conceivably become one - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isAlgTyCon tc - Nothing -> False - -{- -Note [Splitting nested sigma types in mismatched function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When one applies a function to too few arguments, GHC tries to determine this -fact if possible so that it may give a helpful error message. It accomplishes -this by checking if the type of the applied function has more argument types -than supplied arguments. - -Previously, GHC computed the number of argument types through tcSplitSigmaTy. -This is incorrect in the face of nested foralls, however! This caused Trac -#13311, for instance: - - f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b - -If one uses `f` like so: - - do { f; putChar 'a' } - -Then tcSplitSigmaTy will decompose the type of `f` into: - - Tyvars: [a] - Context: (Monoid a) - Argument types: [] - Return type: forall b. Monoid b => Maybe a -> Maybe b - -That is, it will conclude that there are *no* argument types, and since `f` -was given no arguments, it won't print a helpful error message. On the other -hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to: - - Tyvars: [a, b] - Context: (Monoid a, Monoid b) - Argument types: [Maybe a] - Return type: Maybe b - -So now GHC recognizes that `f` has one more argument type than it was actually -provided. --} - -badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc -badFieldTypes prs - = hang (text "Record update for insufficiently polymorphic field" - <> plural prs <> colon) - 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) - -badFieldsUpd - :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] - -- Field names that don't belong to a single datacon - -> [ConLike] -- Data cons of the type which the first field name belongs to - -> SDoc -badFieldsUpd rbinds data_cons - = hang (text "No constructor has all these fields:") - 2 (pprQuotedList conflictingFields) - -- See Note [Finding the conflicting fields] - where - -- A (preferably small) set of fields such that no constructor contains - -- all of them. See Note [Finding the conflicting fields] - conflictingFields = case nonMembers of - -- nonMember belongs to a different type. - (nonMember, _) : _ -> [aMember, nonMember] - [] -> let - -- All of rbinds belong to one type. In this case, repeatedly add - -- a field to the set until no constructor contains the set. - - -- Each field, together with a list indicating which constructors - -- have all the fields so far. - growingSets :: [(FieldLabelString, [Bool])] - growingSets = scanl1 combine membership - combine (_, setMem) (field, fldMem) - = (field, zipWith (&&) setMem fldMem) - in - -- Fields that don't change the membership status of the set - -- are redundant and can be dropped. - map (fst . head) $ groupBy ((==) `on` snd) growingSets - - aMember = ASSERT( not (null members) ) fst (head members) - (members, nonMembers) = partition (or . snd) membership - - -- For each field, which constructors contain the field? - membership :: [(FieldLabelString, [Bool])] - membership = sortMembership $ - map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $ - map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds - - fieldLabelSets :: [Set.Set FieldLabelString] - fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons - - -- Sort in order of increasing number of True, so that a smaller - -- conflicting set can be found. - sortMembership = - map snd . - sortBy (compare `on` fst) . - map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) - - countTrue = count id - -{- -Note [Finding the conflicting fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - data A = A {a0, a1 :: Int} - | B {b0, b1 :: Int} -and we see a record update - x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } -Then we'd like to find the smallest subset of fields that no -constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. -We don't really want to report that no constructor has all of -{a0,a1,b0,b1}, because when there are hundreds of fields it's -hard to see what was really wrong. - -We may need more than two fields, though; eg - data T = A { x,y :: Int, v::Int } - | B { y,z :: Int, v::Int } - | C { z,x :: Int, v::Int } -with update - r { x=e1, y=e2, z=e3 }, we - -Finding the smallest subset is hard, so the code here makes -a decent stab, no more. See #7989. --} - -naughtyRecordSel :: RdrName -> SDoc -naughtyRecordSel sel_id - = text "Cannot use record selector" <+> quotes (ppr sel_id) <+> - text "as a function due to escaped type variables" $$ - text "Probable fix: use pattern-matching syntax instead" - -notSelector :: Name -> SDoc -notSelector field - = hsep [quotes (ppr field), text "is not a record selector"] - -mixedSelectors :: [Id] -> [Id] -> SDoc -mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) - = ptext - (sLit "Cannot use a mixture of pattern synonym and record selectors") $$ - text "Record selectors defined by" - <+> quotes (ppr (tyConName rep_dc)) - <> text ":" - <+> pprWithCommas ppr data_sels $$ - text "Pattern synonym selectors defined by" - <+> quotes (ppr (patSynName rep_ps)) - <> text ":" - <+> pprWithCommas ppr pat_syn_sels - where - RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id - RecSelData rep_dc = recordSelectorTyCon dc_rep_id -mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists" - - -missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc -missingStrictFields con fields - = header <> rest - where - rest | null fields = Outputable.empty -- Happens for non-record constructors - -- with strict fields - | otherwise = colon <+> pprWithCommas ppr fields - - header = text "Constructor" <+> quotes (ppr con) <+> - text "does not have the required strict field(s)" - -missingFields :: ConLike -> [FieldLabelString] -> SDoc -missingFields con fields - = header <> rest - where - rest | null fields = Outputable.empty - | otherwise = colon <+> pprWithCommas ppr fields - header = text "Fields of" <+> quotes (ppr con) <+> - text "not initialised" - --- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args)) - -noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc -noPossibleParents rbinds - = hang (text "No type has all these fields:") - 2 (pprQuotedList fields) - where - fields = map (hsRecFieldLbl . unLoc) rbinds - -badOverloadedUpdate :: SDoc -badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" - -fieldNotInType :: RecSelParent -> RdrName -> SDoc -fieldNotInType p rdr - = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr - -{- -************************************************************************ -* * -\subsection{Static Pointers} -* * -************************************************************************ --} - --- | A data type to describe why a variable is not closed. -data NotClosedReason = NotLetBoundReason - | NotTypeClosed VarSet - | NotClosed Name NotClosedReason - --- | Checks if the given name is closed and emits an error if not. --- --- See Note [Not-closed error messages]. -checkClosedInStaticForm :: Name -> TcM () -checkClosedInStaticForm name = do - type_env <- getLclTypeEnv - case checkClosed type_env name of - Nothing -> return () - Just reason -> addErrTc $ explain name reason - where - -- See Note [Checking closedness]. - checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason - checkClosed type_env n = checkLoop type_env (unitNameSet n) n - - checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason - checkLoop type_env visited n = do - -- The @visited@ set is an accumulating parameter that contains the set of - -- visited nodes, so we avoid repeating cycles in the traversal. - case lookupNameEnv type_env n of - Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of - ClosedLet -> Nothing - NotLetBound -> Just NotLetBoundReason - NonClosedLet fvs type_closed -> listToMaybe $ - -- Look for a non-closed variable in fvs - [ NotClosed n' reason - | n' <- nameSetElemsStable fvs - , not (elemNameSet n' visited) - , Just reason <- [checkLoop type_env (extendNameSet visited n') n'] - ] ++ - if type_closed then - [] - else - -- We consider non-let-bound variables easier to figure out than - -- non-closed types, so we report non-closed types to the user - -- only if we cannot spot the former. - [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ] - -- The binding is closed. - _ -> Nothing - - -- Converts a reason into a human-readable sentence. - -- - -- @explain name reason@ starts with - -- - -- "<name> is used in a static form but it is not closed because it" - -- - -- and then follows a list of causes. For each id in the path, the text - -- - -- "uses <id> which" - -- - -- is appended, yielding something like - -- - -- "uses <id> which uses <id1> which uses <id2> which" - -- - -- until the end of the path is reached, which is reported as either - -- - -- "is not let-bound" - -- - -- when the final node is not let-bound, or - -- - -- "has a non-closed type because it contains the type variables: - -- v1, v2, v3" - -- - -- when the final node has a non-closed type. - -- - explain :: Name -> NotClosedReason -> SDoc - explain name reason = - quotes (ppr name) <+> text "is used in a static form but it is not closed" - <+> text "because it" - $$ - sep (causes reason) - - causes :: NotClosedReason -> [SDoc] - causes NotLetBoundReason = [text "is not let-bound."] - causes (NotTypeClosed vs) = - [ text "has a non-closed type because it contains the" - , text "type variables:" <+> - pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) - ] - causes (NotClosed n reason) = - let msg = text "uses" <+> quotes (ppr n) <+> text "which" - in case reason of - NotClosed _ _ -> msg : causes reason - _ -> let (xs0, xs1) = splitAt 1 $ causes reason - in fmap (msg <+>) xs0 ++ xs1 - --- Note [Not-closed error messages] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- When variables in a static form are not closed, we go through the trouble --- of explaining why they aren't. --- --- Thus, the following program --- --- > {-# LANGUAGE StaticPointers #-} --- > module M where --- > --- > f x = static g --- > where --- > g = h --- > h = x --- --- produces the error --- --- 'g' is used in a static form but it is not closed because it --- uses 'h' which uses 'x' which is not let-bound. --- --- And a program like --- --- > {-# LANGUAGE StaticPointers #-} --- > module M where --- > --- > import Data.Typeable --- > import GHC.StaticPtr --- > --- > f :: Typeable a => a -> StaticPtr TypeRep --- > f x = const (static (g undefined)) (h x) --- > where --- > g = h --- > h = typeOf --- --- produces the error --- --- 'g' is used in a static form but it is not closed because it --- uses 'h' which has a non-closed type because it contains the --- type variables: 'a' --- - --- Note [Checking closedness] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- @checkClosed@ checks if a binding is closed and returns a reason if it is --- not. --- --- The bindings define a graph where the nodes are ids, and there is an edge --- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free --- variables. --- --- When @n@ is not closed, it has to exist in the graph some node reachable --- from @n@ that it is not a let-bound variable or that it has a non-closed --- type. Thus, the "reason" is a path from @n@ to this offending node. --- --- When @n@ is not closed, we traverse the graph reachable from @n@ to build --- the reason. --- diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot deleted file mode 100644 index 6c2c3bb733..0000000000 --- a/compiler/typecheck/TcExpr.hs-boot +++ /dev/null @@ -1,42 +0,0 @@ -module TcExpr where -import GHC.Types.Name -import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc ) -import TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) -import TcRnTypes( TcM ) -import TcOrigin ( CtOrigin ) -import GHC.Hs.Extension ( GhcRn, GhcTcId ) - -tcPolyExpr :: - LHsExpr GhcRn - -> TcSigmaType - -> TcM (LHsExpr GhcTcId) - -tcMonoExpr, tcMonoExprNC :: - LHsExpr GhcRn - -> ExpRhoType - -> TcM (LHsExpr GhcTcId) - -tcInferSigma :: - LHsExpr GhcRn - -> TcM (LHsExpr GhcTcId, TcSigmaType) - -tcInferRho, tcInferRhoNC :: - LHsExpr GhcRn - -> TcM (LHsExpr GhcTcId, TcRhoType) - -tcSyntaxOp :: CtOrigin - -> SyntaxExprRn - -> [SyntaxOpType] -- ^ shape of syntax operator arguments - -> ExpType -- ^ overall result type - -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments - -> TcM (a, SyntaxExprTc) - -tcSyntaxOpGen :: CtOrigin - -> SyntaxExprRn - -> [SyntaxOpType] - -> SyntaxOpType - -> ([TcSigmaType] -> TcM a) - -> TcM (a, SyntaxExprTc) - - -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs deleted file mode 100644 index 762938c971..0000000000 --- a/compiler/typecheck/TcFlatten.hs +++ /dev/null @@ -1,1925 +0,0 @@ -{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns, BangPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcFlatten( - FlattenMode(..), - flatten, flattenKind, flattenArgsNom, - rewriteTyVar, - - unflattenWanteds - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnTypes -import GHC.Core.TyCo.Ppr ( pprTyVar ) -import Constraint -import GHC.Core.Predicate -import TcType -import GHC.Core.Type -import TcEvidence -import GHC.Core.TyCon -import GHC.Core.TyCo.Rep -- performs delicate algorithm on types -import GHC.Core.Coercion -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import Outputable -import TcSMonad as TcS -import GHC.Types.Basic( SwapFlag(..) ) - -import Util -import Bag -import Control.Monad -import MonadUtils ( zipWith3M ) -import Data.Foldable ( foldrM ) - -import Control.Arrow ( first ) - -{- -Note [The flattening story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* A CFunEqCan is either of form - [G] <F xis> : F xis ~ fsk -- fsk is a FlatSkolTv - [W] x : F xis ~ fmv -- fmv is a FlatMetaTv - where - x is the witness variable - xis are function-free - fsk/fmv is a flatten skolem; - it is always untouchable (level 0) - -* CFunEqCans can have any flavour: [G], [W], [WD] or [D] - -* KEY INSIGHTS: - - - A given flatten-skolem, fsk, is known a-priori to be equal to - F xis (the LHS), with <F xis> evidence. The fsk is still a - unification variable, but it is "owned" by its CFunEqCan, and - is filled in (unflattened) only by unflattenGivens. - - - A unification flatten-skolem, fmv, stands for the as-yet-unknown - type to which (F xis) will eventually reduce. It is filled in - - - - All fsk/fmv variables are "untouchable". To make it simple to test, - we simply give them TcLevel=0. This means that in a CTyVarEq, say, - fmv ~ Int - we NEVER unify fmv. - - - A unification flatten-skolem, fmv, ONLY gets unified when either - a) The CFunEqCan takes a step, using an axiom - b) By unflattenWanteds - They are never unified in any other form of equality. - For example [W] ffmv ~ Int is stuck; it does not unify with fmv. - -* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan. - That would destroy the invariant about the shape of a CFunEqCan, - and it would risk wanted/wanted interactions. The only way we - learn information about fsk is when the CFunEqCan takes a step. - - However we *do* substitute in the LHS of a CFunEqCan (else it - would never get to fire!) - -* Unflattening: - - We unflatten Givens when leaving their scope (see unflattenGivens) - - We unflatten Wanteds at the end of each attempt to simplify the - wanteds; see unflattenWanteds, called from solveSimpleWanteds. - -* Ownership of fsk/fmv. Each canonical [G], [W], or [WD] - CFunEqCan x : F xis ~ fsk/fmv - "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv. - Why? We make a fresh fsk/fmv when the constraint is born; - and we never rewrite the RHS of a CFunEqCan. - - In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W], - but does not "own" it. If we reduce a [D] F Int ~ fmv, where - say type instance F Int = ty, then we don't discharge fmv := ty. - Rather we simply generate [D] fmv ~ ty (in TcInteract.reduce_top_fun_eq, - and dischargeFmv) - -* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2 - then xis1 /= xis2 - i.e. at most one CFunEqCan with a particular LHS - -* Flattening a type (F xis): - - If we are flattening in a Wanted/Derived constraint - then create new [W] x : F xis ~ fmv - else create new [G] x : F xis ~ fsk - with fresh evidence variable x and flatten-skolem fsk/fmv - - - Add it to the work list - - - Replace (F xis) with fsk/fmv in the type you are flattening - - - You can also add the CFunEqCan to the "flat cache", which - simply keeps track of all the function applications you - have flattened. - - - If (F xis) is in the cache already, just - use its fsk/fmv and evidence x, and emit nothing. - - - No need to substitute in the flat-cache. It's not the end - of the world if we start with, say (F alpha ~ fmv1) and - (F Int ~ fmv2) and then find alpha := Int. Athat will - simply give rise to fmv1 := fmv2 via [Interacting rule] below - -* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv - - Flatten xis (to substitute any tyvars; there are already no functions) - cos :: xis ~ flat_xis - - New wanted x2 :: F flat_xis ~ fsk/fmv - - Add new wanted to flat cache - - Discharge x = F cos ; x2 - -* [Interacting rule] - (inert) [W] x1 : F tys ~ fmv1 - (work item) [W] x2 : F tys ~ fmv2 - Just solve one from the other: - x2 := x1 - fmv2 := fmv1 - This just unites the two fsks into one. - Always solve given from wanted if poss. - -* For top-level reductions, see Note [Top-level reductions for type functions] - in TcInteract - - -Why given-fsks, alone, doesn't work -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Could we get away with only flatten meta-tyvars, with no flatten-skolems? No. - - [W] w : alpha ~ [F alpha Int] - ----> flatten - w = ...w'... - [W] w' : alpha ~ [fsk] - [G] <F alpha Int> : F alpha Int ~ fsk - ---> unify (no occurs check) - alpha := [fsk] - -But since fsk = F alpha Int, this is really an occurs check error. If -that is all we know about alpha, we will succeed in constraint -solving, producing a program with an infinite type. - -Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk) -using axiom, zonking would not see it, so (x::alpha) sitting in the -tree will get zonked to an infinite type. (Zonking always only does -refl stuff.) - -Why flatten-meta-vars, alone doesn't work -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at Simple13, with unification-fmvs only - - [G] g : a ~ [F a] - ----> Flatten given - g' = g;[x] - [G] g' : a ~ [fmv] - [W] x : F a ~ fmv - ---> subst a in x - g' = g;[x] - x = F g' ; x2 - [W] x2 : F [fmv] ~ fmv - -And now we have an evidence cycle between g' and x! - -If we used a given instead (ie current story) - - [G] g : a ~ [F a] - ----> Flatten given - g' = g;[x] - [G] g' : a ~ [fsk] - [G] <F a> : F a ~ fsk - ----> Substitute for a - [G] g' : a ~ [fsk] - [G] F (sym g'); <F a> : F [fsk] ~ fsk - - -Why is it right to treat fmv's differently to ordinary unification vars? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - f :: forall a. a -> a -> Bool - g :: F Int -> F Int -> Bool - -Consider - f (x:Int) (y:Bool) -This gives alpha~Int, alpha~Bool. There is an inconsistency, -but really only one error. SherLoc may tell you which location -is most likely, based on other occurrences of alpha. - -Consider - g (x:Int) (y:Bool) -Here we get (F Int ~ Int, F Int ~ Bool), which flattens to - (fmv ~ Int, fmv ~ Bool) -But there are really TWO separate errors. - - ** We must not complain about Int~Bool. ** - -Moreover these two errors could arise in entirely unrelated parts of -the code. (In the alpha case, there must be *some* connection (eg -v:alpha in common envt).) - -Note [Unflattening can force the solver to iterate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Look at #10340: - type family Any :: * -- No instances - get :: MonadState s m => m s - instance MonadState s (State s) where ... - - foo :: State Any Any - foo = get - -For 'foo' we instantiate 'get' at types mm ss - [WD] MonadState ss mm, [WD] mm ss ~ State Any Any -Flatten, and decompose - [WD] MonadState ss mm, [WD] Any ~ fmv - [WD] mm ~ State fmv, [WD] fmv ~ ss -Unify mm := State fmv: - [WD] MonadState ss (State fmv) - [WD] Any ~ fmv, [WD] fmv ~ ss -Now we are stuck; the instance does not match!! So unflatten: - fmv := Any - ss := Any (*) - [WD] MonadState Any (State Any) - -The unification (*) represents progress, so we must do a second -round of solving; this time it succeeds. This is done by the 'go' -loop in solveSimpleWanteds. - -This story does not feel right but it's the best I can do; and the -iteration only happens in pretty obscure circumstances. - - -************************************************************************ -* * -* Examples - Here is a long series of examples I had to work through -* * -************************************************************************ - -Simple20 -~~~~~~~~ -axiom F [a] = [F a] - - [G] F [a] ~ a ---> - [G] fsk ~ a - [G] [F a] ~ fsk (nc) ---> - [G] F a ~ fsk2 - [G] fsk ~ [fsk2] - [G] fsk ~ a ---> - [G] F a ~ fsk2 - [G] a ~ [fsk2] - [G] fsk ~ a - ----------------------------------------- -indexed-types/should_compile/T44984 - - [W] H (F Bool) ~ H alpha - [W] alpha ~ F Bool ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 - - fmv1 ~ fmv2 - fmv0 ~ alpha - -flatten -~~~~~~~ - fmv0 := F Bool - fmv1 := H (F Bool) - fmv2 := H alpha - alpha := F Bool -plus - fmv1 ~ fmv2 - -But these two are equal under the above assumptions. -Solve by Refl. - - ---- under plan B, namely solve fmv1:=fmv2 eagerly --- - [W] H (F Bool) ~ H alpha - [W] alpha ~ F Bool ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 - - fmv1 ~ fmv2 - fmv0 ~ alpha ---> - F Bool ~ fmv0 - H fmv0 ~ fmv1 - H alpha ~ fmv2 fmv2 := fmv1 - - fmv0 ~ alpha - -flatten - fmv0 := F Bool - fmv1 := H fmv0 = H (F Bool) - retain H alpha ~ fmv2 - because fmv2 has been filled - alpha := F Bool - - ----------------------------- -indexed-types/should_failt/T4179 - -after solving - [W] fmv_1 ~ fmv_2 - [W] A3 (FCon x) ~ fmv_1 (CFunEqCan) - [W] A3 (x (aoa -> fmv_2)) ~ fmv_2 (CFunEqCan) - ----------------------------------------- -indexed-types/should_fail/T7729a - -a) [W] BasePrimMonad (Rand m) ~ m1 -b) [W] tt m1 ~ BasePrimMonad (Rand m) - ----> process (b) first - BasePrimMonad (Ramd m) ~ fmv_atH - fmv_atH ~ tt m1 - ----> now process (a) - m1 ~ s_atH ~ tt m1 -- An obscure occurs check - - ----------------------------------------- -typecheck/TcTypeNatSimple - -Original constraint - [W] x + y ~ x + alpha (non-canonical) -==> - [W] x + y ~ fmv1 (CFunEqCan) - [W] x + alpha ~ fmv2 (CFuneqCan) - [W] fmv1 ~ fmv2 (CTyEqCan) - -(sigh) - ----------------------------------------- -indexed-types/should_fail/GADTwrong1 - - [G] Const a ~ () -==> flatten - [G] fsk ~ () - work item: Const a ~ fsk -==> fire top rule - [G] fsk ~ () - work item fsk ~ () - -Surely the work item should rewrite to () ~ ()? Well, maybe not; -it'a very special case. More generally, our givens look like -F a ~ Int, where (F a) is not reducible. - - ----------------------------------------- -indexed_types/should_fail/T8227: - -Why using a different can-rewrite rule in CFunEqCan heads -does not work. - -Assuming NOT rewriting wanteds with wanteds - - Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk - [W] fmv_aBk ~ fsk_aBh - - [G] Scalar fsk_aBg ~ fsk_aBh - [G] V a ~ f_aBg - - Worklist includes [W] Scalar fmv_aBi ~ fmv_aBk - fmv_aBi, fmv_aBk are flatten unification variables - - Work item: [W] V fsk_aBh ~ fmv_aBi - -Note that the inert wanteds are cyclic, because we do not rewrite -wanteds with wanteds. - - -Then we go into a loop when normalise the work-item, because we -use rewriteOrSame on the argument of V. - -Conclusion: Don't make canRewrite context specific; instead use -[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable. - - ----------------------------------------- - -Here is a somewhat similar case: - - type family G a :: * - - blah :: (G a ~ Bool, Eq (G a)) => a -> a - blah = error "urk" - - foo x = blah x - -For foo we get - [W] Eq (G a), G a ~ Bool -Flattening - [W] G a ~ fmv, Eq fmv, fmv ~ Bool -We can't simplify away the Eq Bool unless we substitute for fmv. -Maybe that doesn't matter: we would still be left with unsolved -G a ~ Bool. - --------------------------- -#9318 has a very simple program leading to - - [W] F Int ~ Int - [W] F Int ~ Bool - -We don't want to get "Error Int~Bool". But if fmv's can rewrite -wanteds, we will - - [W] fmv ~ Int - [W] fmv ~ Bool ----> - [W] Int ~ Bool - - -************************************************************************ -* * -* FlattenEnv & FlatM -* The flattening environment & monad -* * -************************************************************************ - --} - -type FlatWorkListRef = TcRef [Ct] -- See Note [The flattening work list] - -data FlattenEnv - = FE { fe_mode :: !FlattenMode - , fe_loc :: CtLoc -- See Note [Flattener CtLoc] - -- unbanged because it's bogus in rewriteTyVar - , fe_flavour :: !CtFlavour - , fe_eq_rel :: !EqRel -- See Note [Flattener EqRels] - , fe_work :: !FlatWorkListRef } -- See Note [The flattening work list] - -data FlattenMode -- Postcondition for all three: inert wrt the type substitution - = FM_FlattenAll -- Postcondition: function-free - | FM_SubstOnly -- See Note [Flattening under a forall] - --- | FM_Avoid TcTyVar Bool -- See Note [Lazy flattening] --- -- Postcondition: --- -- * tyvar is only mentioned in result under a rigid path --- -- e.g. [a] is ok, but F a won't happen --- -- * If flat_top is True, top level is not a function application --- -- (but under type constructors is ok e.g. [F a]) - -instance Outputable FlattenMode where - ppr FM_FlattenAll = text "FM_FlattenAll" - ppr FM_SubstOnly = text "FM_SubstOnly" - -eqFlattenMode :: FlattenMode -> FlattenMode -> Bool -eqFlattenMode FM_FlattenAll FM_FlattenAll = True -eqFlattenMode FM_SubstOnly FM_SubstOnly = True --- FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2 -eqFlattenMode _ _ = False - --- | The 'FlatM' monad is a wrapper around 'TcS' with the following --- extra capabilities: (1) it offers access to a 'FlattenEnv'; --- and (2) it maintains the flattening worklist. --- See Note [The flattening work list]. -newtype FlatM a - = FlatM { runFlatM :: FlattenEnv -> TcS a } - deriving (Functor) - -instance Monad FlatM where - m >>= k = FlatM $ \env -> - do { a <- runFlatM m env - ; runFlatM (k a) env } - -instance Applicative FlatM where - pure x = FlatM $ const (pure x) - (<*>) = ap - -liftTcS :: TcS a -> FlatM a -liftTcS thing_inside - = FlatM $ const thing_inside - -emitFlatWork :: Ct -> FlatM () --- See Note [The flattening work list] -emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :) - --- convenient wrapper when you have a CtEvidence describing --- the flattening operation -runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a -runFlattenCtEv mode ev - = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev) - --- Run thing_inside (which does flattening), and put all --- the work it generates onto the main work list --- See Note [The flattening work list] -runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a -runFlatten mode loc flav eq_rel thing_inside - = do { flat_ref <- newTcRef [] - ; let fmode = FE { fe_mode = mode - , fe_loc = bumpCtLocDepth loc - -- See Note [Flatten when discharging CFunEqCan] - , fe_flavour = flav - , fe_eq_rel = eq_rel - , fe_work = flat_ref } - ; res <- runFlatM thing_inside fmode - ; new_flats <- readTcRef flat_ref - ; updWorkListTcS (add_flats new_flats) - ; return res } - where - add_flats new_flats wl - = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) } - - add_funeqs [] wl = wl - add_funeqs (f:fs) wl = add_funeqs fs (f:wl) - -- add_funeqs fs ws = reverse fs ++ ws - -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4] - -- = [f3,f2,f1,w1,w2,w3,w4] - -traceFlat :: String -> SDoc -> FlatM () -traceFlat herald doc = liftTcS $ traceTcS herald doc - -getFlatEnvField :: (FlattenEnv -> a) -> FlatM a -getFlatEnvField accessor - = FlatM $ \env -> return (accessor env) - -getEqRel :: FlatM EqRel -getEqRel = getFlatEnvField fe_eq_rel - -getRole :: FlatM Role -getRole = eqRelRole <$> getEqRel - -getFlavour :: FlatM CtFlavour -getFlavour = getFlatEnvField fe_flavour - -getFlavourRole :: FlatM CtFlavourRole -getFlavourRole - = do { flavour <- getFlavour - ; eq_rel <- getEqRel - ; return (flavour, eq_rel) } - -getMode :: FlatM FlattenMode -getMode = getFlatEnvField fe_mode - -getLoc :: FlatM CtLoc -getLoc = getFlatEnvField fe_loc - -checkStackDepth :: Type -> FlatM () -checkStackDepth ty - = do { loc <- getLoc - ; liftTcS $ checkReductionDepth loc ty } - --- | Change the 'EqRel' in a 'FlatM'. -setEqRel :: EqRel -> FlatM a -> FlatM a -setEqRel new_eq_rel thing_inside - = FlatM $ \env -> - if new_eq_rel == fe_eq_rel env - then runFlatM thing_inside env - else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel }) - --- | Change the 'FlattenMode' in a 'FlattenEnv'. -setMode :: FlattenMode -> FlatM a -> FlatM a -setMode new_mode thing_inside - = FlatM $ \env -> - if new_mode `eqFlattenMode` fe_mode env - then runFlatM thing_inside env - else runFlatM thing_inside (env { fe_mode = new_mode }) - --- | Make sure that flattening actually produces a coercion (in other --- words, make sure our flavour is not Derived) --- Note [No derived kind equalities] -noBogusCoercions :: FlatM a -> FlatM a -noBogusCoercions thing_inside - = FlatM $ \env -> - -- No new thunk is made if the flavour hasn't changed (note the bang). - let !env' = case fe_flavour env of - Derived -> env { fe_flavour = Wanted WDeriv } - _ -> env - in - runFlatM thing_inside env' - -bumpDepth :: FlatM a -> FlatM a -bumpDepth (FlatM thing_inside) - = FlatM $ \env -> do - -- bumpDepth can be called a lot during flattening so we force the - -- new env to avoid accumulating thunks. - { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) } - ; thing_inside env' } - -{- -Note [The flattening work list] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The "flattening work list", held in the fe_work field of FlattenEnv, -is a list of CFunEqCans generated during flattening. The key idea -is this. Consider flattening (Eq (F (G Int) (H Bool)): - * The flattener recursively calls itself on sub-terms before building - the main term, so it will encounter the terms in order - G Int - H Bool - F (G Int) (H Bool) - flattening to sub-goals - w1: G Int ~ fuv0 - w2: H Bool ~ fuv1 - w3: F fuv0 fuv1 ~ fuv2 - - * Processing w3 first is BAD, because we can't reduce i t,so it'll - get put into the inert set, and later kicked out when w1, w2 are - solved. In #9872 this led to inert sets containing hundreds - of suspended calls. - - * So we want to process w1, w2 first. - - * So you might think that we should just use a FIFO deque for the work-list, - so that putting adding goals in order w1,w2,w3 would mean we processed - w1 first. - - * BUT suppose we have 'type instance G Int = H Char'. Then processing - w1 leads to a new goal - w4: H Char ~ fuv0 - We do NOT want to put that on the far end of a deque! Instead we want - to put it at the *front* of the work-list so that we continue to work - on it. - -So the work-list structure is this: - - * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on - top (extendWorkListFunEq), and take new work from the top - (selectWorkItem). - - * When flattening, emitFlatWork pushes new flattening goals (like - w1,w2,w3) onto the flattening work list, fe_work, another - push-down stack. - - * When we finish flattening, we *reverse* the fe_work stack - onto the wl_funeqs stack (which brings w1 to the top). - -The function runFlatten initialises the fe_work stack, and reverses -it onto wl_fun_eqs at the end. - -Note [Flattener EqRels] -~~~~~~~~~~~~~~~~~~~~~~~ -When flattening, we need to know which equality relation -- nominal -or representation -- we should be respecting. The only difference is -that we rewrite variables by representational equalities when fe_eq_rel -is ReprEq, and that we unwrap newtypes when flattening w.r.t. -representational equality. - -Note [Flattener CtLoc] -~~~~~~~~~~~~~~~~~~~~~~ -The flattener does eager type-family reduction. -Type families might loop, and we -don't want GHC to do so. A natural solution is to have a bounded depth -to these processes. A central difficulty is that such a solution isn't -quite compositional. For example, say it takes F Int 10 steps to get to Bool. -How many steps does it take to get from F Int -> F Int to Bool -> Bool? -10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to -know and hard to track. So, we punt, essentially. We store a CtLoc in -the FlattenEnv and just update the environment when recurring. In the -TyConApp case, where there may be multiple type families to flatten, -we just copy the current CtLoc into each branch. If any branch hits the -stack limit, then the whole thing fails. - -A consequence of this is that setting the stack limits appropriately -will be essentially impossible. So, the official recommendation if a -stack limit is hit is to disable the check entirely. Otherwise, there -will be baffling, unpredictable errors. - -Note [Lazy flattening] -~~~~~~~~~~~~~~~~~~~~~~ -The idea of FM_Avoid mode is to flatten less aggressively. If we have - a ~ [F Int] -there seems to be no great merit in lifting out (F Int). But if it was - a ~ [G a Int] -then we *do* want to lift it out, in case (G a Int) reduces to Bool, say, -which gets rid of the occurs-check problem. (For the flat_top Bool, see -comments above and at call sites.) - -HOWEVER, the lazy flattening actually seems to make type inference go -*slower*, not faster. perf/compiler/T3064 is a case in point; it gets -*dramatically* worse with FM_Avoid. I think it may be because -floating the types out means we normalise them, and that often makes -them smaller and perhaps allows more re-use of previously solved -goals. But to be honest I'm not absolutely certain, so I am leaving -FM_Avoid in the code base. What I'm removing is the unique place -where it is *used*, namely in TcCanonical.canEqTyVar. - -See also Note [Conservative unification check] in TcUnify, which gives -other examples where lazy flattening caused problems. - -Bottom line: FM_Avoid is unused for now (Nov 14). -Note: T5321Fun got faster when I disabled FM_Avoid - T5837 did too, but it's pathological anyway - -Note [Phantoms in the flattener] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - -data Proxy p = Proxy - -and we're flattening (Proxy ty) w.r.t. ReprEq. Then, we know that `ty` -is really irrelevant -- it will be ignored when solving for representational -equality later on. So, we omit flattening `ty` entirely. This may -violate the expectation of "xi"s for a bit, but the canonicaliser will -soon throw out the phantoms when decomposing a TyConApp. (Or, the -canonicaliser will emit an insoluble, in which case the unflattened version -yields a better error message anyway.) - -Note [No derived kind equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A kind-level coercion can appear in types, via mkCastTy. So, whenever -we are generating a coercion in a dependent context (in other words, -in a kind) we need to make sure that our flavour is never Derived -(as Derived constraints have no evidence). The noBogusCoercions function -changes the flavour from Derived just for this purpose. - --} - -{- ********************************************************************* -* * -* Externally callable flattening functions * -* * -* They are all wrapped in runFlatten, so their * -* flattening work gets put into the work list * -* * -********************************************************************* - -Note [rewriteTyVar] -~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an injective function F and - inert_funeqs: F t1 ~ fsk1 - F t2 ~ fsk2 - inert_eqs: fsk1 ~ [a] - a ~ Int - fsk2 ~ [Int] - -We never rewrite the RHS (cc_fsk) of a CFunEqCan. But we /do/ want to get the -[D] t1 ~ t2 from the injectiveness of F. So we flatten cc_fsk of CFunEqCans -when trying to find derived equalities arising from injectivity. --} - --- | See Note [Flattening]. --- If (xi, co) <- flatten mode ev ty, then co :: xi ~r ty --- where r is the role in @ev@. If @mode@ is 'FM_FlattenAll', --- then 'xi' is almost function-free (Note [Almost function-free] --- in TcRnTypes). -flatten :: FlattenMode -> CtEvidence -> TcType - -> TcS (Xi, TcCoercion) -flatten mode ev ty - = do { traceTcS "flatten {" (ppr mode <+> ppr ty) - ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty) - ; traceTcS "flatten }" (ppr ty') - ; return (ty', co) } - --- Apply the inert set as an *inert generalised substitution* to --- a variable, zonking along the way. --- See Note [inert_eqs: the inert equalities] in TcSMonad. --- Equivalently, this flattens the variable with respect to NomEq --- in a Derived constraint. (Why Derived? Because Derived allows the --- most about of rewriting.) Returns no coercion, because we're --- using Derived constraints. --- See Note [rewriteTyVar] -rewriteTyVar :: TcTyVar -> TcS TcType -rewriteTyVar tv - = do { traceTcS "rewriteTyVar {" (ppr tv) - ; (ty, _) <- runFlatten FM_SubstOnly fake_loc Derived NomEq $ - flattenTyVar tv - ; traceTcS "rewriteTyVar }" (ppr ty) - ; return ty } - where - fake_loc = pprPanic "rewriteTyVar used a CtLoc" (ppr tv) - --- specialized to flattening kinds: never Derived, always Nominal --- See Note [No derived kind equalities] --- See Note [Flattening] -flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN) -flattenKind loc flav ty - = do { traceTcS "flattenKind {" (ppr flav <+> ppr ty) - ; let flav' = case flav of - Derived -> Wanted WDeriv -- the WDeriv/WOnly choice matters not - _ -> flav - ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty) - ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic - ; return (ty', co) } - --- See Note [Flattening] -flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN) --- Externally-callable, hence runFlatten --- Flatten a vector of types all at once; in fact they are --- always the arguments of type family or class, so --- ctEvFlavour ev = Nominal --- and we want to flatten all at nominal role --- The kind passed in is the kind of the type family or class, call it T --- The last coercion returned has type (tcTypeKind(T xis) ~N tcTypeKind(T tys)) --- --- For Derived constraints the returned coercion may be undefined --- because flattening may use a Derived equality ([D] a ~ ty) -flattenArgsNom ev tc tys - = do { traceTcS "flatten_args {" (vcat (map ppr tys)) - ; (tys', cos, kind_co) - <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys) - ; traceTcS "flatten }" (vcat (map ppr tys')) - ; return (tys', cos, kind_co) } - - -{- ********************************************************************* -* * -* The main flattening functions -* * -********************************************************************* -} - -{- Note [Flattening] -~~~~~~~~~~~~~~~~~~~~ - flatten ty ==> (xi, co) - where - xi has no type functions, unless they appear under ForAlls - has no skolems that are mapped in the inert set - has no filled-in metavariables - co :: xi ~ ty - -Key invariants: - (F0) co :: xi ~ zonk(ty) - (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind - (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) - -Note that it is flatten's job to flatten *every type function it sees*. -flatten is only called on *arguments* to type functions, by canEqGiven. - -Flattening also: - * zonks, removing any metavariables, and - * applies the substitution embodied in the inert set - -The result of flattening is *almost function-free*. See -Note [Almost function-free] in TcRnTypes. - -Because flattening zonks and the returned coercion ("co" above) is also -zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead, -we can rely on this fact: - - (F0) co :: xi ~ zonk(ty) - -Note that the left-hand type of co is *always* precisely xi. The right-hand -type may or may not be ty, however: if ty has unzonked filled-in metavariables, -then the right-hand type of co will be the zonked version of ty. -It is for this reason that we -occasionally have to explicitly zonk, when (co :: xi ~ ty) is important -even before we zonk the whole program. For example, see the FTRNotFollowed -case in flattenTyVar. - -Why have these invariants on flattening? Because we sometimes use tcTypeKind -during canonicalisation, and we want this kind to be zonked (e.g., see -TcCanonical.canEqTyVar). - -Flattening is always homogeneous. That is, the kind of the result of flattening is -always the same as the kind of the input, modulo zonking. More formally: - - (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) - -This invariant means that the kind of a flattened type might not itself be flat. - -Recall that in comments we use alpha[flat = ty] to represent a -flattening skolem variable alpha which has been generated to stand in -for ty. - ------ Example of flattening a constraint: ------ - flatten (List (F (G Int))) ==> (xi, cc) - where - xi = List alpha - cc = { G Int ~ beta[flat = G Int], - F beta ~ alpha[flat = F beta] } -Here - * alpha and beta are 'flattening skolem variables'. - * All the constraints in cc are 'given', and all their coercion terms - are the identity. - -NB: Flattening Skolems only occur in canonical constraints, which -are never zonked, so we don't need to worry about zonking doing -accidental unflattening. - -Note that we prefer to leave type synonyms unexpanded when possible, -so when the flattener encounters one, it first asks whether its -transitive expansion contains any type function applications. If so, -it expands the synonym and proceeds; if not, it simply returns the -unexpanded synonym. - -Note [flatten_args performance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In programs with lots of type-level evaluation, flatten_args becomes -part of a tight loop. For example, see test perf/compiler/T9872a, which -calls flatten_args a whopping 7,106,808 times. It is thus important -that flatten_args be efficient. - -Performance testing showed that the current implementation is indeed -efficient. It's critically important that zipWithAndUnzipM be -specialized to TcS, and it's also quite helpful to actually `inline` -it. On test T9872a, here are the allocation stats (Dec 16, 2014): - - * Unspecialized, uninlined: 8,472,613,440 bytes allocated in the heap - * Specialized, uninlined: 6,639,253,488 bytes allocated in the heap - * Specialized, inlined: 6,281,539,792 bytes allocated in the heap - -To improve performance even further, flatten_args_nom is split off -from flatten_args, as nominal equality is the common case. This would -be natural to write using mapAndUnzipM, but even inlined, that function -is not as performant as a hand-written loop. - - * mapAndUnzipM, inlined: 7,463,047,432 bytes allocated in the heap - * hand-written recursion: 5,848,602,848 bytes allocated in the heap - -If you make any change here, pay close attention to the T9872{a,b,c} tests -and T5321Fun. - -If we need to make this yet more performant, a possible way forward is to -duplicate the flattener code for the nominal case, and make that case -faster. This doesn't seem quite worth it, yet. - -Note [flatten_exact_fam_app_fully performance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the current state. - -The explicit pattern match in homogenise_result helps with T9872a, b, c. - -Still, it increases the expected allocation of T9872d by ~2%. - -TODO: a step-by-step replay of the refactor to analyze the performance. - --} - -{-# INLINE flatten_args_tc #-} -flatten_args_tc - :: TyCon -- T - -> [Role] -- Role r - -> [Type] -- Arg types [t1,..,tn] - -> FlatM ( [Xi] -- List of flattened args [x1,..,xn] - -- 1-1 corresp with [t1,..,tn] - , [Coercion] -- List of arg coercions [co1,..,con] - -- 1-1 corresp with [t1,..,tn] - -- coi :: xi ~r ti - , CoercionN) -- Result coercion, rco - -- rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con)) -flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet - -- NB: TyCon kinds are always closed - where - (bndrs, named) - = ty_con_binders_ty_binders' (tyConBinders tc) - -- it's possible that the result kind has arrows (for, e.g., a type family) - -- so we must split it - (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc) - !all_bndrs = bndrs `chkAppend` inner_bndrs - !any_named_bndrs = named || inner_named - -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%. - -{-# INLINE flatten_args #-} -flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are - -- named. - -> Kind -> TcTyCoVarSet -- function kind; kind's free vars - -> [Role] -> [Type] -- these are in 1-to-1 correspondence - -> FlatM ([Xi], [Coercion], CoercionN) --- Coercions :: Xi ~ Type, at roles given --- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys) --- That is, the third coercion relates the kind of some function (whose kind is --- passed as the first parameter) instantiated at xis to the kind of that --- function instantiated at the tys. This is useful in keeping flattening --- homoegeneous. The list of roles must be at least as long as the list of --- types. -flatten_args orig_binders - any_named_bndrs - orig_inner_ki - orig_fvs - orig_roles - orig_tys - = if any_named_bndrs - then flatten_args_slow orig_binders - orig_inner_ki - orig_fvs - orig_roles - orig_tys - else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys - -{-# INLINE flatten_args_fast #-} --- | fast path flatten_args, in which none of the binders are named and --- therefore we can avoid tracking a lifting context. --- There are many bang patterns in here. It's been observed that they --- greatly improve performance of an optimized build. --- The T9872 test cases are good witnesses of this fact. -flatten_args_fast :: [TyCoBinder] - -> Kind - -> [Role] - -> [Type] - -> FlatM ([Xi], [Coercion], CoercionN) -flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys - = fmap finish (iterate orig_tys orig_roles orig_binders) - where - - iterate :: [Type] - -> [Role] - -> [TyCoBinder] - -> FlatM ([Xi], [Coercion], [TyCoBinder]) - iterate (ty:tys) (role:roles) (_:binders) = do - (xi, co) <- go role ty - (xis, cos, binders) <- iterate tys roles binders - pure (xi : xis, co : cos, binders) - iterate [] _ binders = pure ([], [], binders) - iterate _ _ _ = pprPanic - "flatten_args wandered into deeper water than usual" (vcat []) - -- This debug information is commented out because leaving it in - -- causes a ~2% increase in allocations in T9872{a,c,d}. - {- - (vcat [ppr orig_binders, - ppr orig_inner_ki, - ppr (take 10 orig_roles), -- often infinite! - ppr orig_tys]) - -} - - {-# INLINE go #-} - go :: Role - -> Type - -> FlatM (Xi, Coercion) - go role ty - = case role of - -- In the slow path we bind the Xi and Coercion from the recursive - -- call and then use it such - -- - -- let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder) - -- casted_xi = xi `mkCastTy` kind_co - -- casted_co = xi |> kind_co ~r xi ; co - -- - -- but this isn't necessary: - -- mkTcSymCo (Refl a b) = Refl a b, - -- mkCastTy x (Refl _ _) = x - -- mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co - -- - -- Also, no need to check isAnonTyCoBinder or isNamedBinder, since - -- we've already established that they're all anonymous. - Nominal -> setEqRel NomEq $ flatten_one ty - Representational -> setEqRel ReprEq $ flatten_one ty - Phantom -> -- See Note [Phantoms in the flattener] - do { ty <- liftTcS $ zonkTcType ty - ; return (ty, mkReflCo Phantom ty) } - - - {-# INLINE finish #-} - finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN) - finish (xis, cos, binders) = (xis, cos, kind_co) - where - final_kind = mkPiTys binders orig_inner_ki - kind_co = mkNomReflCo final_kind - -{-# INLINE flatten_args_slow #-} --- | Slow path, compared to flatten_args_fast, because this one must track --- a lifting context. -flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet - -> [Role] -> [Type] - -> FlatM ([Xi], [Coercion], CoercionN) -flatten_args_slow binders inner_ki fvs roles tys --- Arguments used dependently must be flattened with proper coercions, but --- we're not guaranteed to get a proper coercion when flattening with the --- "Derived" flavour. So we must call noBogusCoercions when flattening arguments --- corresponding to binders that are dependent. However, we might legitimately --- have *more* arguments than binders, in the case that the inner_ki is a variable --- that gets instantiated with a Π-type. We conservatively choose not to produce --- bogus coercions for these, too. Note that this might miss an opportunity for --- a Derived rewriting a Derived. The solution would be to generate evidence for --- Deriveds, thus avoiding this whole noBogusCoercions idea. See also --- Note [No derived kind equalities] - = do { flattened_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True) - roles tys - ; return (simplifyArgsWorker binders inner_ki fvs roles flattened_args) } - where - {-# INLINE fl #-} - fl :: Bool -- must we ensure to produce a real coercion here? - -- see comment at top of function - -> Role -> Type -> FlatM (Xi, Coercion) - fl True r ty = noBogusCoercions $ fl1 r ty - fl False r ty = fl1 r ty - - {-# INLINE fl1 #-} - fl1 :: Role -> Type -> FlatM (Xi, Coercion) - fl1 Nominal ty - = setEqRel NomEq $ - flatten_one ty - - fl1 Representational ty - = setEqRel ReprEq $ - flatten_one ty - - fl1 Phantom ty - -- See Note [Phantoms in the flattener] - = do { ty <- liftTcS $ zonkTcType ty - ; return (ty, mkReflCo Phantom ty) } - ------------------- -flatten_one :: TcType -> FlatM (Xi, Coercion) --- Flatten a type to get rid of type function applications, returning --- the new type-function-free type, and a collection of new equality --- constraints. See Note [Flattening] for more detail. --- --- Postcondition: Coercion :: Xi ~ TcType --- The role on the result coercion matches the EqRel in the FlattenEnv - -flatten_one xi@(LitTy {}) - = do { role <- getRole - ; return (xi, mkReflCo role xi) } - -flatten_one (TyVarTy tv) - = flattenTyVar tv - -flatten_one (AppTy ty1 ty2) - = flatten_app_tys ty1 [ty2] - -flatten_one (TyConApp tc tys) - -- Expand type synonyms that mention type families - -- on the RHS; see Note [Flattening synonyms] - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' - = do { mode <- getMode - ; case mode of - FM_FlattenAll | not (isFamFreeTyCon tc) - -> flatten_one expanded_ty - _ -> flatten_ty_con_app tc tys } - - -- Otherwise, it's a type function application, and we have to - -- flatten it away as well, and generate a new given equality constraint - -- between the application and a newly generated flattening skolem variable. - | isTypeFamilyTyCon tc - = flatten_fam_app tc tys - - -- For * a normal data type application - -- * data family application - -- we just recursively flatten the arguments. - | otherwise --- FM_Avoid stuff commented out; see Note [Lazy flattening] --- , let fmode' = case fmode of -- Switch off the flat_top bit in FM_Avoid --- FE { fe_mode = FM_Avoid tv _ } --- -> fmode { fe_mode = FM_Avoid tv False } --- _ -> fmode - = flatten_ty_con_app tc tys - -flatten_one ty@(FunTy _ ty1 ty2) - = do { (xi1,co1) <- flatten_one ty1 - ; (xi2,co2) <- flatten_one ty2 - ; role <- getRole - ; return (ty { ft_arg = xi1, ft_res = xi2 } - , mkFunCo role co1 co2) } - -flatten_one ty@(ForAllTy {}) --- TODO (RAE): This is inadequate, as it doesn't flatten the kind of --- the bound tyvar. Doing so will require carrying around a substitution --- and the usual substTyVarBndr-like silliness. Argh. - --- We allow for-alls when, but only when, no type function --- applications inside the forall involve the bound type variables. - = do { let (bndrs, rho) = tcSplitForAllVarBndrs ty - tvs = binderVars bndrs - ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho - -- Substitute only under a forall - -- See Note [Flattening under a forall] - ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) } - -flatten_one (CastTy ty g) - = do { (xi, co) <- flatten_one ty - ; (g', _) <- flatten_co g - - ; role <- getRole - ; return (mkCastTy xi g', castCoercionKind co role xi ty g' g) } - -flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co - --- | "Flatten" a coercion. Really, just zonk it so we can uphold --- (F1) of Note [Flattening] -flatten_co :: Coercion -> FlatM (Coercion, Coercion) -flatten_co co - = do { co <- liftTcS $ zonkCo co - ; env_role <- getRole - ; let co' = mkTcReflCo env_role (mkCoercionTy co) - ; return (co, co') } - --- flatten (nested) AppTys -flatten_app_tys :: Type -> [Type] -> FlatM (Xi, Coercion) --- commoning up nested applications allows us to look up the function's kind --- only once. Without commoning up like this, we would spend a quadratic amount --- of time looking up functions' types -flatten_app_tys (AppTy ty1 ty2) tys = flatten_app_tys ty1 (ty2:tys) -flatten_app_tys fun_ty arg_tys - = do { (fun_xi, fun_co) <- flatten_one fun_ty - ; flatten_app_ty_args fun_xi fun_co arg_tys } - --- Given a flattened function (with the coercion produced by flattening) and --- a bunch of unflattened arguments, flatten the arguments and apply. --- The coercion argument's role matches the role stored in the FlatM monad. --- --- The bang patterns used here were observed to improve performance. If you --- wish to remove them, be sure to check for regeressions in allocations. -flatten_app_ty_args :: Xi -> Coercion -> [Type] -> FlatM (Xi, Coercion) -flatten_app_ty_args fun_xi fun_co [] - -- this will be a common case when called from flatten_fam_app, so shortcut - = return (fun_xi, fun_co) -flatten_app_ty_args fun_xi fun_co arg_tys - = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of - Just (tc, xis) -> - do { let tc_roles = tyConRolesRepresentational tc - arg_roles = dropList xis tc_roles - ; (arg_xis, arg_cos, kind_co) - <- flatten_vector (tcTypeKind fun_xi) arg_roles arg_tys - - -- Here, we have fun_co :: T xi1 xi2 ~ ty - -- and we need to apply fun_co to the arg_cos. The problem is - -- that using mkAppCo is wrong because that function expects - -- its second coercion to be Nominal, and the arg_cos might - -- not be. The solution is to use transitivity: - -- T <xi1> <xi2> arg_cos ;; fun_co <arg_tys> - ; eq_rel <- getEqRel - ; let app_xi = mkTyConApp tc (xis ++ arg_xis) - app_co = case eq_rel of - NomEq -> mkAppCos fun_co arg_cos - ReprEq -> mkTcTyConAppCo Representational tc - (zipWith mkReflCo tc_roles xis ++ arg_cos) - `mkTcTransCo` - mkAppCos fun_co (map mkNomReflCo arg_tys) - ; return (app_xi, app_co, kind_co) } - Nothing -> - do { (arg_xis, arg_cos, kind_co) - <- flatten_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys - ; let arg_xi = mkAppTys fun_xi arg_xis - arg_co = mkAppCos fun_co arg_cos - ; return (arg_xi, arg_co, kind_co) } - - ; role <- getRole - ; return (homogenise_result xi co role kind_co) } - -flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) -flatten_ty_con_app tc tys - = do { role <- getRole - ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys - ; let tyconapp_xi = mkTyConApp tc xis - tyconapp_co = mkTyConAppCo role tc cos - ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) } - --- Make the result of flattening homogeneous (Note [Flattening] (F2)) -homogenise_result :: Xi -- a flattened type - -> Coercion -- :: xi ~r original ty - -> Role -- r - -> CoercionN -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty) - -> (Xi, Coercion) -- (xi |> kind_co, (xi |> kind_co) - -- ~r original ty) -homogenise_result xi co r kind_co - -- the explicit pattern match here improves the performance of T9872a, b, c by - -- ~2% - | isGReflCo kind_co = (xi `mkCastTy` kind_co, co) - | otherwise = (xi `mkCastTy` kind_co - , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co) -{-# INLINE homogenise_result #-} - --- Flatten a vector (list of arguments). -flatten_vector :: Kind -- of the function being applied to these arguments - -> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the - -- args have? - -> [Type] -- the args to flatten - -> FlatM ([Xi], [Coercion], CoercionN) -flatten_vector ki roles tys - = do { eq_rel <- getEqRel - ; case eq_rel of - NomEq -> flatten_args bndrs - any_named_bndrs - inner_ki - fvs - (repeat Nominal) - tys - ReprEq -> flatten_args bndrs - any_named_bndrs - inner_ki - fvs - roles - tys - } - where - (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki - fvs = tyCoVarsOfType ki -{-# INLINE flatten_vector #-} - -{- -Note [Flattening synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Not expanding synonyms aggressively improves error messages, and -keeps types smaller. But we need to take care. - -Suppose - type T a = a -> a -and we want to flatten the type (T (F a)). Then we can safely flatten -the (F a) to a skolem, and return (T fsk). We don't need to expand the -synonym. This works because TcTyConAppCo can deal with synonyms -(unlike TyConAppCo), see Note [TcCoercions] in TcEvidence. - -But (#8979) for - type T a = (F a, a) where F is a type function -we must expand the synonym in (say) T Int, to expose the type function -to the flattener. - - -Note [Flattening under a forall] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Under a forall, we - (a) MUST apply the inert substitution - (b) MUST NOT flatten type family applications -Hence FMSubstOnly. - -For (a) consider c ~ a, a ~ T (forall b. (b, [c])) -If we don't apply the c~a substitution to the second constraint -we won't see the occurs-check error. - -For (b) consider (a ~ forall b. F a b), we don't want to flatten -to (a ~ forall b.fsk, F a b ~ fsk) -because now the 'b' has escaped its scope. We'd have to flatten to - (a ~ forall b. fsk b, forall b. F a b ~ fsk b) -and we have not begun to think about how to make that work! - -************************************************************************ -* * - Flattening a type-family application -* * -************************************************************************ --} - -flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) - -- flatten_fam_app can be over-saturated - -- flatten_exact_fam_app is exactly saturated - -- flatten_exact_fam_app_fully lifts out the application to top level - -- Postcondition: Coercion :: Xi ~ F tys -flatten_fam_app tc tys -- Can be over-saturated - = ASSERT2( tys `lengthAtLeast` tyConArity tc - , ppr tc $$ ppr (tyConArity tc) $$ ppr tys) - - do { mode <- getMode - ; case mode of - { FM_SubstOnly -> flatten_ty_con_app tc tys - ; FM_FlattenAll -> - - -- Type functions are saturated - -- The type function might be *over* saturated - -- in which case the remaining arguments should - -- be dealt with by AppTys - do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys - ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1 - -- co1 :: xi1 ~ F tys1 - - ; flatten_app_ty_args xi1 co1 tys_rest } } } - --- the [TcType] exactly saturate the TyCon --- See note [flatten_exact_fam_app_fully performance] -flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion) -flatten_exact_fam_app_fully tc tys - -- See Note [Reduce type family applications eagerly] - -- the following tcTypeKind should never be evaluated, as it's just used in - -- casting, and casts by refl are dropped - = do { mOut <- try_to_reduce_nocache tc tys - ; case mOut of - Just out -> pure out - Nothing -> do - { -- First, flatten the arguments - ; (xis, cos, kind_co) - <- setEqRel NomEq $ -- just do this once, instead of for - -- each arg - flatten_args_tc tc (repeat Nominal) tys - -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys) - ; eq_rel <- getEqRel - ; cur_flav <- getFlavour - ; let role = eqRelRole eq_rel - ret_co = mkTyConAppCo role tc cos - -- ret_co :: F xis ~ F tys; might be heterogeneous - - -- Now, look in the cache - ; mb_ct <- liftTcS $ lookupFlatCache tc xis - ; case mb_ct of - Just (co, rhs_ty, flav) -- co :: F xis ~ fsk - -- flav is [G] or [WD] - -- See Note [Type family equations] in TcSMonad - | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav - -> -- Usable hit in the flat-cache - do { traceFlat "flatten/flat-cache hit" $ - (ppr tc <+> ppr xis $$ ppr rhs_ty) - ; (fsk_xi, fsk_co) <- flatten_one rhs_ty - -- The fsk may already have been unified, so - -- flatten it - -- fsk_co :: fsk_xi ~ fsk - ; let xi = fsk_xi `mkCastTy` kind_co - co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co - `mkTransCo` - maybeTcSubCo eq_rel (mkSymCo co) - `mkTransCo` ret_co - ; return (xi, co') - } - -- :: fsk_xi ~ F xis - - -- Try to reduce the family application right now - -- See Note [Reduce type family applications eagerly] - _ -> do { mOut <- try_to_reduce tc - xis - kind_co - (`mkTransCo` ret_co) - ; case mOut of - Just out -> pure out - Nothing -> do - { loc <- getLoc - ; (ev, co, fsk) <- liftTcS $ - newFlattenSkolem cur_flav loc tc xis - - -- The new constraint (F xis ~ fsk) is not - -- necessarily inert (e.g. the LHS may be a - -- redex) so we must put it in the work list - ; let ct = CFunEqCan { cc_ev = ev - , cc_fun = tc - , cc_tyargs = xis - , cc_fsk = fsk } - ; emitFlatWork ct - - ; traceFlat "flatten/flat-cache miss" $ - (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev) - - -- NB: fsk's kind is already flattened because - -- the xis are flattened - ; let fsk_ty = mkTyVarTy fsk - xi = fsk_ty `mkCastTy` kind_co - co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeTcSubCo eq_rel (mkSymCo co)) - `mkTransCo` ret_co - ; return (xi, co') - } - } - } - } - - where - - -- try_to_reduce and try_to_reduce_nocache (below) could be unified into - -- a more general definition, but it was observed that separating them - -- gives better performance (lower allocation numbers in T9872x). - - try_to_reduce :: TyCon -- F, family tycon - -> [Type] -- args, not necessarily flattened - -> CoercionN -- kind_co :: tcTypeKind(F args) ~N - -- tcTypeKind(F orig_args) - -- where - -- orig_args is what was passed to the outer - -- function - -> ( Coercion -- :: (xi |> kind_co) ~ F args - -> Coercion ) -- what to return from outer function - -> FlatM (Maybe (Xi, Coercion)) - try_to_reduce tc tys kind_co update_co - = do { checkStackDepth (mkTyConApp tc tys) - ; mb_match <- liftTcS $ matchFam tc tys - ; case mb_match of - -- NB: norm_co will always be homogeneous. All type families - -- are homogeneous. - Just (norm_co, norm_ty) - -> do { traceFlat "Eager T.F. reduction success" $ - vcat [ ppr tc, ppr tys, ppr norm_ty - , ppr norm_co <+> dcolon - <+> ppr (coercionKind norm_co) - ] - ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty - ; eq_rel <- getEqRel - ; let co = maybeTcSubCo eq_rel norm_co - `mkTransCo` mkSymCo final_co - ; flavour <- getFlavour - -- NB: only extend cache with nominal equalities - ; when (eq_rel == NomEq) $ - liftTcS $ - extendFlatCache tc tys ( co, xi, flavour ) - ; let role = eqRelRole eq_rel - xi' = xi `mkCastTy` kind_co - co' = update_co $ - mkTcCoherenceLeftCo role xi kind_co (mkSymCo co) - ; return $ Just (xi', co') } - Nothing -> pure Nothing } - - try_to_reduce_nocache :: TyCon -- F, family tycon - -> [Type] -- args, not necessarily flattened - -> FlatM (Maybe (Xi, Coercion)) - try_to_reduce_nocache tc tys - = do { checkStackDepth (mkTyConApp tc tys) - ; mb_match <- liftTcS $ matchFam tc tys - ; case mb_match of - -- NB: norm_co will always be homogeneous. All type families - -- are homogeneous. - Just (norm_co, norm_ty) - -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty - ; eq_rel <- getEqRel - ; let co = mkSymCo (maybeTcSubCo eq_rel norm_co - `mkTransCo` mkSymCo final_co) - ; return $ Just (xi, co) } - Nothing -> pure Nothing } - -{- Note [Reduce type family applications eagerly] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we come across a type-family application like (Append (Cons x Nil) t), -then, rather than flattening to a skolem etc, we may as well just reduce -it on the spot to (Cons x t). This saves a lot of intermediate steps. -Examples that are helped are tests T9872, and T5321Fun. - -Performance testing indicates that it's best to try this *twice*, once -before flattening arguments and once after flattening arguments. -Adding the extra reduction attempt before flattening arguments cut -the allocation amounts for the T9872{a,b,c} tests by half. - -An example of where the early reduction appears helpful: - - type family Last x where - Last '[x] = x - Last (h ': t) = Last t - - workitem: (x ~ Last '[1,2,3,4,5,6]) - -Flattening the argument never gets us anywhere, but trying to flatten -it at every step is quadratic in the length of the list. Reducing more -eagerly makes simplifying the right-hand type linear in its length. - -Testing also indicated that the early reduction should *not* use the -flat-cache, but that the later reduction *should*. (Although the -effect was not large.) Hence the Bool argument to try_to_reduce. To -me (SLPJ) this seems odd; I get that eager reduction usually succeeds; -and if don't use the cache for eager reduction, we will miss most of -the opportunities for using it at all. More exploration would be good -here. - -At the end, once we've got a flat rhs, we extend the flatten-cache to record -the result. Doing so can save lots of work when the same redex shows up more -than once. Note that we record the link from the redex all the way to its -*final* value, not just the single step reduction. Interestingly, using the -flat-cache for the first reduction resulted in an increase in allocations -of about 3% for the four T9872x tests. However, using the flat-cache in -the later reduction is a similar gain. I (Richard E) don't currently (Dec '14) -have any knowledge as to *why* these facts are true. - -************************************************************************ -* * - Flattening a type variable -* * -********************************************************************* -} - --- | The result of flattening a tyvar "one step". -data FlattenTvResult - = FTRNotFollowed - -- ^ The inert set doesn't make the tyvar equal to anything else - - | FTRFollowed TcType Coercion - -- ^ The tyvar flattens to a not-necessarily flat other type. - -- co :: new type ~r old type, where the role is determined by - -- the FlattenEnv - -flattenTyVar :: TyVar -> FlatM (Xi, Coercion) -flattenTyVar tv - = do { mb_yes <- flatten_tyvar1 tv - ; case mb_yes of - FTRFollowed ty1 co1 -- Recur - -> do { (ty2, co2) <- flatten_one ty1 - -- ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2) - ; return (ty2, co2 `mkTransCo` co1) } - - FTRNotFollowed -- Done, but make sure the kind is zonked - -- Note [Flattening] invariant (F0) and (F1) - -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv - ; role <- getRole - ; let ty' = mkTyVarTy tv' - ; return (ty', mkTcReflCo role ty') } } - -flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult --- "Flattening" a type variable means to apply the substitution to it --- Specifically, look up the tyvar in --- * the internal MetaTyVar box --- * the inerts --- See also the documentation for FlattenTvResult - -flatten_tyvar1 tv - = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty -> do { traceFlat "Following filled tyvar" - (ppr tv <+> equals <+> ppr ty) - ; role <- getRole - ; return (FTRFollowed ty (mkReflCo role ty)) } ; - Nothing -> do { traceFlat "Unfilled tyvar" (pprTyVar tv) - ; fr <- getFlavourRole - ; flatten_tyvar2 tv fr } } - -flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult --- The tyvar is not a filled-in meta-tyvar --- Try in the inert equalities --- See Definition [Applying a generalised substitution] in TcSMonad --- See Note [Stability of flattening] in TcSMonad - -flatten_tyvar2 tv fr@(_, eq_rel) - = do { ieqs <- liftTcS $ getInertEqs - ; mode <- getMode - ; case lookupDVarEnv ieqs tv of - Just (ct:_) -- If the first doesn't work, - -- the subsequent ones won't either - | CTyEqCan { cc_ev = ctev, cc_tyvar = tv - , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct - , let ct_fr = (ctEvFlavour ctev, ct_eq_rel) - , ct_fr `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR - -> do { traceFlat "Following inert tyvar" - (ppr mode <+> - ppr tv <+> - equals <+> - ppr rhs_ty $$ ppr ctev) - ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev) - rewrite_co = case (ct_eq_rel, eq_rel) of - (ReprEq, _rel) -> ASSERT( _rel == ReprEq ) - -- if this ASSERT fails, then - -- eqCanRewriteFR answered incorrectly - rewrite_co1 - (NomEq, NomEq) -> rewrite_co1 - (NomEq, ReprEq) -> mkSubCo rewrite_co1 - - ; return (FTRFollowed rhs_ty rewrite_co) } - -- NB: ct is Derived then fmode must be also, hence - -- we are not going to touch the returned coercion - -- so ctEvCoercion is fine. - - _other -> return FTRNotFollowed } - -{- -Note [An alternative story for the inert substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(This entire note is just background, left here in case we ever want - to return the previous state of affairs) - -We used (GHC 7.8) to have this story for the inert substitution inert_eqs - - * 'a' is not in fvs(ty) - * They are *inert* in the weaker sense that there is no infinite chain of - (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc - -This means that flattening must be recursive, but it does allow - [G] a ~ [b] - [G] b ~ Maybe c - -This avoids "saturating" the Givens, which can save a modest amount of work. -It is easy to implement, in TcInteract.kick_out, by only kicking out an inert -only if (a) the work item can rewrite the inert AND - (b) the inert cannot rewrite the work item - -This is significantly harder to think about. It can save a LOT of work -in occurs-check cases, but we don't care about them much. #5837 -is an example; all the constraints here are Givens - - [G] a ~ TF (a,Int) - --> - work TF (a,Int) ~ fsk - inert fsk ~ a - - ---> - work fsk ~ (TF a, TF Int) - inert fsk ~ a - - ---> - work a ~ (TF a, TF Int) - inert fsk ~ a - - ---> (attempting to flatten (TF a) so that it does not mention a - work TF a ~ fsk2 - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (substitute for a) - work TF (fsk2, TF Int) ~ fsk2 - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (top-level reduction, re-orient) - work fsk2 ~ (TF fsk2, TF Int) - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> (attempt to flatten (TF fsk2) to get rid of fsk2 - work TF fsk2 ~ fsk3 - work fsk2 ~ (fsk3, TF Int) - inert a ~ (fsk2, TF Int) - inert fsk ~ (fsk2, TF Int) - - ---> - work TF fsk2 ~ fsk3 - inert fsk2 ~ (fsk3, TF Int) - inert a ~ ((fsk3, TF Int), TF Int) - inert fsk ~ ((fsk3, TF Int), TF Int) - -Because the incoming given rewrites all the inert givens, we get more and -more duplication in the inert set. But this really only happens in pathological -casee, so we don't care. - - -************************************************************************ -* * - Unflattening -* * -************************************************************************ - -An unflattening example: - [W] F a ~ alpha -flattens to - [W] F a ~ fmv (CFunEqCan) - [W] fmv ~ alpha (CTyEqCan) -We must solve both! --} - -unflattenWanteds :: Cts -> Cts -> TcS Cts -unflattenWanteds tv_eqs funeqs - = do { tclvl <- getTcLevel - - ; traceTcS "Unflattening" $ braces $ - vcat [ text "Funeqs =" <+> pprCts funeqs - , text "Tv eqs =" <+> pprCts tv_eqs ] - - -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check - -- Occurs check: consider [W] alpha ~ [F alpha] - -- ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv] - -- ==> (unify) [W] F [fmv] ~ fmv - -- See Note [Unflatten using funeqs first] - ; funeqs <- foldrM unflatten_funeq emptyCts funeqs - ; traceTcS "Unflattening 1" $ braces (pprCts funeqs) - - -- Step 2: unify the tv_eqs, if possible - ; tv_eqs <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs - ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs) - - -- Step 3: fill any remaining fmvs with fresh unification variables - ; funeqs <- mapBagM finalise_funeq funeqs - ; traceTcS "Unflattening 3" $ braces (pprCts funeqs) - - -- Step 4: remove any tv_eqs that look like ty ~ ty - ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs - - ; let all_flat = tv_eqs `andCts` funeqs - ; traceTcS "Unflattening done" $ braces (pprCts all_flat) - - ; return all_flat } - where - ---------------- - unflatten_funeq :: Ct -> Cts -> TcS Cts - unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis - , cc_fsk = fmv, cc_ev = ev }) rest - = do { -- fmv should be an un-filled flatten meta-tv; - -- we now fix its final value by filling it, being careful - -- to observe the occurs check. Zonking will eliminate it - -- altogether in due course - rhs' <- zonkTcType (mkTyConApp tc xis) - ; case occCheckExpand [fmv] rhs' of - Just rhs'' -- Normal case: fill the tyvar - -> do { setReflEvidence ev NomEq rhs'' - ; unflattenFmv fmv rhs'' - ; return rest } - - Nothing -> -- Occurs check - return (ct `consCts` rest) } - - unflatten_funeq other_ct _ - = pprPanic "unflatten_funeq" (ppr other_ct) - - ---------------- - finalise_funeq :: Ct -> TcS Ct - finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev }) - = do { demoteUnfilledFmv fmv - ; return (mkNonCanonical ev) } - finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct) - - ---------------- - unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts - unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv - , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest - - | NomEq <- eq_rel -- See Note [Do not unify representational equalities] - -- in TcInteract - , isFmvTyVar tv -- Previously these fmvs were untouchable, - -- but now they are touchable - -- NB: unlike unflattenFmv, filling a fmv here /does/ - -- bump the unification count; it is "improvement" - -- Note [Unflattening can force the solver to iterate] - = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct ) - -- CTyEqCan invariant (TyEq:K) should ensure this is true - do { is_filled <- isFilledMetaTyVar tv - ; elim <- case is_filled of - False -> do { traceTcS "unflatten_eq 2" (ppr ct) - ; tryFill ev tv rhs } - True -> do { traceTcS "unflatten_eq 3" (ppr ct) - ; try_fill_rhs ev tclvl tv rhs } - ; if elim - then do { setReflEvidence ev eq_rel (mkTyVarTy tv) - ; return rest } - else return (ct `consCts` rest) } - - | otherwise - = return (ct `consCts` rest) - - unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct) - - ---------------- - try_fill_rhs ev tclvl lhs_tv rhs - -- Constraint is lhs_tv ~ rhs_tv, - -- and lhs_tv is filled, so try RHS - | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs - -- co :: kind(rhs_tv) ~ kind(lhs_tv) - , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv - && not (isTyVarTyVar rhs_tv)) - -- LHS is a filled fmv, and so is a type - -- family application, which a TyVarTv should - -- not unify with - = do { is_filled <- isFilledMetaTyVar rhs_tv - ; if is_filled then return False - else tryFill ev rhs_tv - (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) } - - | otherwise - = return False - - ---------------- - finalise_eq :: Ct -> Cts -> TcS Cts - finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv - , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest - | isFmvTyVar tv - = do { ty1 <- zonkTcTyVar tv - ; rhs' <- zonkTcType rhs - ; if ty1 `tcEqType` rhs' - then do { setReflEvidence ev eq_rel rhs' - ; return rest } - else return (mkNonCanonical ev `consCts` rest) } - - | otherwise - = return (mkNonCanonical ev `consCts` rest) - - finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct) - -tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool --- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv --- If tv does not appear in 'rhs', it set tv := rhs, --- binds the evidence (which should be a CtWanted) to Refl<rhs> --- and return True. Otherwise returns False -tryFill ev tv rhs - = ASSERT2( not (isGiven ev), ppr ev ) - do { rhs' <- zonkTcType rhs - ; case () of - _ | Just tv' <- tcGetTyVar_maybe rhs' - , tv == tv' -- tv == rhs - -> return True - - _ | Just rhs'' <- occCheckExpand [tv] rhs' - -> do { -- Fill the tyvar - unifyTyVar tv rhs'' - ; return True } - - _ | otherwise -- Occurs check - -> return False - } - -setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS () -setReflEvidence ev eq_rel rhs - = setEvBindIfWanted ev (evCoercion refl_co) - where - refl_co = mkTcReflCo (eqRelRole eq_rel) rhs - -{- -Note [Unflatten using funeqs first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - [W] G a ~ Int - [W] F (G a) ~ G a - -do not want to end up with - [W] F Int ~ Int -because that might actually hold! Better to end up with the two above -unsolved constraints. The flat form will be - - G a ~ fmv1 (CFunEqCan) - F fmv1 ~ fmv2 (CFunEqCan) - fmv1 ~ Int (CTyEqCan) - fmv1 ~ fmv2 (CTyEqCan) - -Flatten using the fun-eqs first. --} - --- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at --- least one named binder. -split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool) -split_pi_tys' ty = split ty ty - where - split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' - split _ (ForAllTy b res) = let (bs, ty, _) = split res res - in (Named b : bs, ty, True) - split _ (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) - = let (bs, ty, named) = split res res - in (Anon af arg : bs, ty, named) - split orig_ty _ = ([], orig_ty, False) -{-# INLINE split_pi_tys' #-} - --- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff --- there is at least one named binder. -ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool) -ty_con_binders_ty_binders' = foldr go ([], False) - where - go (Bndr tv (NamedTCB vis)) (bndrs, _) - = (Named (Bndr tv vis) : bndrs, True) - go (Bndr tv (AnonTCB af)) (bndrs, n) - = (Anon af (tyVarKind tv) : bndrs, n) - {-# INLINE go #-} -{-# INLINE ty_con_binders_ty_binders' #-} diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs deleted file mode 100644 index f050d2a992..0000000000 --- a/compiler/typecheck/TcForeign.hs +++ /dev/null @@ -1,571 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1998 - -\section[TcForeign]{Typechecking \tr{foreign} declarations} - -A foreign declaration is used to either give an externally -implemented function a Haskell type (and calling interface) or -give a Haskell function an external calling interface. Either way, -the range of argument and result types these functions can accommodate -is restricted to what the outside world understands (read C), and this -module checks to see if a foreign declaration has got a legal type. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module TcForeign - ( tcForeignImports - , tcForeignExports - - -- Low-level exports for hooks - , isForeignImport, isForeignExport - , tcFImport, tcFExport - , tcForeignImports' - , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes - , normaliseFfiType - , nonIOok, mustBeIO - , checkSafe, noCheckSafe - , tcForeignExports' - , tcCheckFEType - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs - -import TcRnMonad -import TcHsType -import TcExpr -import TcEnv - -import FamInst -import GHC.Core.FamInstEnv -import GHC.Core.Coercion -import GHC.Core.Type -import GHC.Types.ForeignCall -import ErrUtils -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Name.Reader -import GHC.Core.DataCon -import GHC.Core.TyCon -import TcType -import PrelNames -import GHC.Driver.Session -import Outputable -import GHC.Platform -import GHC.Types.SrcLoc -import Bag -import GHC.Driver.Hooks -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad - --- Defines a binding -isForeignImport :: LForeignDecl name -> Bool -isForeignImport (L _ (ForeignImport {})) = True -isForeignImport _ = False - --- Exports a binding -isForeignExport :: LForeignDecl name -> Bool -isForeignExport (L _ (ForeignExport {})) = True -isForeignExport _ = False - -{- -Note [Don't recur in normaliseFfiType'] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -normaliseFfiType' is the workhorse for normalising a type used in a foreign -declaration. If we have - -newtype Age = MkAge Int - -we want to see that Age -> IO () is the same as Int -> IO (). But, we don't -need to recur on any type parameters, because no paramaterized types (with -interesting parameters) are marshalable! The full list of marshalable types -is in the body of boxedMarshalableTyCon in TcType. The only members of that -list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled -the same way regardless of type parameter. So, no need to recur into -parameters. - -Similarly, we don't need to look in AppTy's, because nothing headed by -an AppTy will be marshalable. - -Note [FFI type roles] -~~~~~~~~~~~~~~~~~~~~~ -The 'go' helper function within normaliseFfiType' always produces -representational coercions. But, in the "children_only" case, we need to -use these coercions in a TyConAppCo. Accordingly, the roles on the coercions -must be twiddled to match the expectation of the enclosing TyCon. However, -we cannot easily go from an R coercion to an N one, so we forbid N roles -on FFI type constructors. Currently, only two such type constructors exist: -IO and FunPtr. Thus, this is not an onerous burden. - -If we ever want to lift this restriction, we would need to make 'go' take -the target role as a parameter. This wouldn't be hard, but it's a complication -not yet necessary and so is not yet implemented. --} - --- normaliseFfiType takes the type from an FFI declaration, and --- evaluates any type synonyms, type functions, and newtypes. However, --- we are only allowed to look through newtypes if the constructor is --- in scope. We return a bag of all the newtype constructors thus found. --- Always returns a Representational coercion -normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt) -normaliseFfiType ty - = do fam_envs <- tcGetFamInstEnvs - normaliseFfiType' fam_envs ty - -normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) -normaliseFfiType' env ty0 = go initRecTc ty0 - where - go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) - go rec_nts ty - | Just ty' <- tcView ty -- Expand synonyms - = go rec_nts ty' - - | Just (tc, tys) <- splitTyConApp_maybe ty - = go_tc_app rec_nts tc tys - - | (bndrs, inner_ty) <- splitForAllVarBndrs ty - , not (null bndrs) - = do (coi, nty1, gres1) <- go rec_nts inner_ty - return ( mkHomoForAllCos (binderVars bndrs) coi - , mkForAllTys bndrs nty1, gres1 ) - - | otherwise -- see Note [Don't recur in normaliseFfiType'] - = return (mkRepReflCo ty, ty, emptyBag) - - go_tc_app :: RecTcChecker -> TyCon -> [Type] - -> TcM (Coercion, Type, Bag GlobalRdrElt) - go_tc_app rec_nts tc tys - -- We don't want to look through the IO newtype, even if it is - -- in scope, so we have a special case for it: - | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey] - -- These *must not* have nominal roles on their parameters! - -- See Note [FFI type roles] - = children_only - - | isNewTyCon tc -- Expand newtypes - , Just rec_nts' <- checkRecTc rec_nts tc - -- See Note [Expanding newtypes] in GHC.Core.TyCon - -- We can't just use isRecursiveTyCon; sometimes recursion is ok: - -- newtype T = T (Ptr T) - -- Here, we don't reject the type for being recursive. - -- If this is a recursive newtype then it will normally - -- be rejected later as not being a valid FFI type. - = do { rdr_env <- getGlobalRdrEnv - ; case checkNewtypeFFI rdr_env tc of - Nothing -> nothing - Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs - ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } } - - | isFamilyTyCon tc -- Expand open tycons - , (co, ty) <- normaliseTcApp env Representational tc tys - , not (isReflexiveCo co) - = do (co', ty', gres) <- go rec_nts ty - return (mkTransCo co co', ty', gres) - - | otherwise - = nothing -- see Note [Don't recur in normaliseFfiType'] - where - tc_key = getUnique tc - children_only - = do xs <- mapM (go rec_nts) tys - let (cos, tys', gres) = unzip3 xs - -- the (repeat Representational) is because 'go' always - -- returns R coercions - cos' = zipWith3 downgradeRole (tyConRoles tc) - (repeat Representational) cos - return ( mkTyConAppCo Representational tc cos' - , mkTyConApp tc tys', unionManyBags gres) - nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys [] - nt_rhs = newTyConInstRhs tc tys - - ty = mkTyConApp tc tys - nothing = return (mkRepReflCo ty, ty, emptyBag) - -checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt -checkNewtypeFFI rdr_env tc - | Just con <- tyConSingleDataCon_maybe tc - , Just gre <- lookupGRE_Name rdr_env (dataConName con) - = Just gre -- See Note [Newtype constructor usage in foreign declarations] - | otherwise - = Nothing - -{- -Note [Newtype constructor usage in foreign declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC automatically "unwraps" newtype constructors in foreign import/export -declarations. In effect that means that a newtype data constructor is -used even though it is not mentioned expclitly in the source, so we don't -want to report it as "defined but not used" or "imported but not used". -eg newtype D = MkD Int - foreign import foo :: D -> IO () -Here 'MkD' us used. See #7408. - -GHC also expands type functions during this process, so it's not enough -just to look at the free variables of the declaration. -eg type instance F Bool = D - foreign import bar :: F Bool -> IO () -Here again 'MkD' is used. - -So we really have wait until the type checker to decide what is used. -That's why tcForeignImports and tecForeignExports return a (Bag GRE) -for the newtype constructors they see. Then TcRnDriver can add them -to the module's usages. - - -************************************************************************ -* * -\subsection{Imports} -* * -************************************************************************ --} - -tcForeignImports :: [LForeignDecl GhcRn] - -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) -tcForeignImports decls - = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls) - -tcForeignImports' :: [LForeignDecl GhcRn] - -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) --- For the (Bag GlobalRdrElt) result, --- see Note [Newtype constructor usage in foreign declarations] -tcForeignImports' decls - = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $ - filter isForeignImport decls - ; return (ids, decls, unionManyBags gres) } - -tcFImport :: LForeignDecl GhcRn - -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt) -tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty - , fd_fi = imp_decl })) - = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $ - do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty - ; let - -- Drop the foralls before inspecting the - -- structure of the foreign type. - (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty) - id = mkLocalId nm sig_ty - -- Use a LocalId to obey the invariant that locally-defined - -- things are LocalIds. However, it does not need zonking, - -- (so TcHsSyn.zonkForeignExports ignores it). - - ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl - -- Can't use sig_ty here because sig_ty :: Type and - -- we need HsType Id hence the undefined - ; let fi_decl = ForeignImport { fd_name = L nloc id - , fd_sig_ty = undefined - , fd_i_ext = mkSymCo norm_co - , fd_fi = imp_decl' } - ; return (id, L dloc fi_decl, gres) } -tcFImport d = pprPanic "tcFImport" (ppr d) - --- ------------ Checking types for foreign import ---------------------- - -tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport - -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src) - -- Foreign import label - = do checkCg checkCOrAsmOrLlvmOrInterp - -- NB check res_ty not sig_ty! - -- In case sig_ty is (forall a. ForeignPtr a) - check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty) - cconv' <- checkCConv cconv - return (CImport (L lc cconv') safety mh l src) - -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do - -- Foreign wrapper (former f.e.d.) - -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid - -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. - -- The use of the latter form is DEPRECATED, though. - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - case arg_tys of - [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys - checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty - checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty - where - (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected")) - return (CImport (L lc cconv') safety mh CWrapper src) - -tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh - (CFunction target) src) - | isDynamicTarget target = do -- Foreign import dynamic - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - case arg_tys of -- The first arg must be Ptr or FunPtr - [] -> - addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected")) - (arg1_ty:arg_tys) -> do - dflags <- getDynFlags - let curried_res_ty = mkVisFunTys arg_tys res_ty - check (isFFIDynTy curried_res_ty arg1_ty) - (illegalForeignTyErr argument) - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src - | cconv == PrimCallConv = do - dflags <- getDynFlags - checkTc (xopt LangExt.GHCForeignImportPrim dflags) - (text "Use GHCForeignImportPrim to allow `foreign import prim'.") - checkCg checkCOrAsmOrLlvmOrInterp - checkCTarget target - checkTc (playSafe safety) - (text "The safe/unsafe annotation should not be used with `foreign import prim'.") - checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys - -- prim import result is more liberal, allows (#,,#) - checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty - return idecl - | otherwise = do -- Normal foreign import - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - checkCTarget target - dflags <- getDynFlags - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - checkMissingAmpersand dflags arg_tys res_ty - case target of - StaticTarget _ _ _ False - | not (null arg_tys) -> - addErrTc (text "`value' imports cannot have function types") - _ -> return () - return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src - - --- This makes a convenient place to check --- that the C identifier is valid for C -checkCTarget :: CCallTarget -> TcM () -checkCTarget (StaticTarget _ str _ _) = do - checkCg checkCOrAsmOrLlvmOrInterp - checkTc (isCLabelString str) (badCName str) - -checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" - - -checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () -checkMissingAmpersand dflags arg_tys res_ty - | null arg_tys && isFunPtrTy res_ty && - wopt Opt_WarnDodgyForeignImports dflags - = addWarn (Reason Opt_WarnDodgyForeignImports) - (text "possible missing & in foreign import of FunPtr") - | otherwise - = return () - -{- -************************************************************************ -* * -\subsection{Exports} -* * -************************************************************************ --} - -tcForeignExports :: [LForeignDecl GhcRn] - -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt) -tcForeignExports decls = - getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls) - -tcForeignExports' :: [LForeignDecl GhcRn] - -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt) --- For the (Bag GlobalRdrElt) result, --- see Note [Newtype constructor usage in foreign declarations] -tcForeignExports' decls - = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls) - where - combine (binds, fs, gres1) (L loc fe) = do - (b, f, gres2) <- setSrcSpan loc (tcFExport fe) - return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) - -tcFExport :: ForeignDecl GhcRn - -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt) -tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec }) - = addErrCtxt (foreignDeclCtxt fo) $ do - - sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - rhs <- tcPolyExpr (nlHsVar nm) sig_ty - - (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty - - spec' <- tcCheckFEType norm_sig_ty spec - - -- we're exporting a function, but at a type possibly more - -- constrained than its declared/inferred type. Hence the need - -- to create a local binding which will call the exported function - -- at a particular type (and, maybe, overloading). - - - -- We need to give a name to the new top-level binding that - -- is *stable* (i.e. the compiler won't change it later), - -- because this name will be referred to by the C code stub. - id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc - return ( mkVarBind id rhs - , ForeignExport { fd_name = L loc id - , fd_sig_ty = undefined - , fd_e_ext = norm_co, fd_fe = spec' } - , gres) -tcFExport d = pprPanic "tcFExport" (ppr d) - --- ------------ Checking argument types for foreign export ---------------------- - -tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport -tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do - checkCg checkCOrAsmOrLlvm - checkTc (isCLabelString str) (badCName str) - cconv' <- checkCConv cconv - checkForeignArgs isFFIExternalTy arg_tys - checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty - return (CExport (L l (CExportStatic esrc str cconv')) src) - where - -- Drop the foralls before inspecting - -- the structure of the foreign type. - (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty) - -{- -************************************************************************ -* * -\subsection{Miscellaneous} -* * -************************************************************************ --} - ------------- Checking argument types for foreign import ---------------------- -checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM () -checkForeignArgs pred tys = mapM_ go tys - where - go ty = check (pred ty) (illegalForeignTyErr argument) - ------------- Checking result types for foreign calls ---------------------- --- | Check that the type has the form --- (IO t) or (t) , and that t satisfies the given predicate. --- When calling this function, any newtype wrappers (should) have been --- already dealt with by normaliseFfiType. --- --- We also check that the Safe Haskell condition of FFI imports having --- results in the IO monad holds. --- -checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM () -checkForeignRes non_io_result_ok check_safe pred_res_ty ty - | Just (_, res_ty) <- tcSplitIOType_maybe ty - = -- Got an IO result type, that's always fine! - check (pred_res_ty res_ty) (illegalForeignTyErr result) - - -- We disallow nested foralls in foreign types - -- (at least, for the time being). See #16702. - | tcIsForAllTy ty - = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall") - - -- Case for non-IO result type with FFI Import - | not non_io_result_ok - = addErrTc $ illegalForeignTyErr result (text "IO result type expected") - - | otherwise - = do { dflags <- getDynFlags - ; case pred_res_ty ty of - -- Handle normal typecheck fail, we want to handle this first and - -- only report safe haskell errors if the normal type check is OK. - NotValid msg -> addErrTc $ illegalForeignTyErr result msg - - -- handle safe infer fail - _ | check_safe && safeInferOn dflags - -> recordUnsafeInfer emptyBag - - -- handle safe language typecheck fail - _ | check_safe && safeLanguageOn dflags - -> addErrTc (illegalForeignTyErr result safeHsErr) - - -- success! non-IO return is fine - _ -> return () } - where - safeHsErr = - text "Safe Haskell is on, all FFI imports must be in the IO monad" - -nonIOok, mustBeIO :: Bool -nonIOok = True -mustBeIO = False - -checkSafe, noCheckSafe :: Bool -checkSafe = True -noCheckSafe = False - --- Checking a supported backend is in use - -checkCOrAsmOrLlvm :: HscTarget -> Validity -checkCOrAsmOrLlvm HscC = IsValid -checkCOrAsmOrLlvm HscAsm = IsValid -checkCOrAsmOrLlvm HscLlvm = IsValid -checkCOrAsmOrLlvm _ - = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") - -checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity -checkCOrAsmOrLlvmOrInterp HscC = IsValid -checkCOrAsmOrLlvmOrInterp HscAsm = IsValid -checkCOrAsmOrLlvmOrInterp HscLlvm = IsValid -checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid -checkCOrAsmOrLlvmOrInterp _ - = NotValid (text "requires interpreted, unregisterised, llvm or native code generation") - -checkCg :: (HscTarget -> Validity) -> TcM () -checkCg check = do - dflags <- getDynFlags - let target = hscTarget dflags - case target of - HscNothing -> return () - _ -> - case check target of - IsValid -> return () - NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) - --- Calling conventions - -checkCConv :: CCallConv -> TcM CCallConv -checkCConv CCallConv = return CCallConv -checkCConv CApiConv = return CApiConv -checkCConv StdCallConv = do dflags <- getDynFlags - let platform = targetPlatform dflags - if platformArch platform == ArchX86 - then return StdCallConv - else do -- This is a warning, not an error. see #3336 - when (wopt Opt_WarnUnsupportedCallingConventions dflags) $ - addWarnTc (Reason Opt_WarnUnsupportedCallingConventions) - (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") - return CCallConv -checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") - return PrimCallConv -checkCConv JavaScriptCallConv = do dflags <- getDynFlags - if platformArch (targetPlatform dflags) == ArchJavaScript - then return JavaScriptCallConv - else do addErrTc (text "The `javascript' calling convention is unsupported on this platform") - return JavaScriptCallConv - --- Warnings - -check :: Validity -> (MsgDoc -> MsgDoc) -> TcM () -check IsValid _ = return () -check (NotValid doc) err_fn = addErrTc (err_fn doc) - -illegalForeignTyErr :: SDoc -> SDoc -> SDoc -illegalForeignTyErr arg_or_res extra - = hang msg 2 extra - where - msg = hsep [ text "Unacceptable", arg_or_res - , text "type in foreign declaration:"] - --- Used for 'arg_or_res' argument to illegalForeignTyErr -argument, result :: SDoc -argument = text "argument" -result = text "result" - -badCName :: CLabelString -> MsgDoc -badCName target - = sep [quotes (ppr target) <+> text "is not a valid C identifier"] - -foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc -foreignDeclCtxt fo - = hang (text "When checking declaration:") - 2 (ppr fo) diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs deleted file mode 100644 index 0a2ab47e9b..0000000000 --- a/compiler/typecheck/TcGenDeriv.hs +++ /dev/null @@ -1,2425 +0,0 @@ -{- - % -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcGenDeriv: Generating derived instance declarations - -This module is nominally ``subordinate'' to @TcDeriv@, which is the -``official'' interface to deriving-related things. - -This is where we do all the grimy bindings' generation. --} - -{-# LANGUAGE CPP, ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcGenDeriv ( - BagDerivStuff, DerivStuff(..), - - gen_Eq_binds, - gen_Ord_binds, - gen_Enum_binds, - gen_Bounded_binds, - gen_Ix_binds, - gen_Show_binds, - gen_Read_binds, - gen_Data_binds, - gen_Lift_binds, - gen_Newtype_binds, - mkCoerceClassMethEqn, - genAuxBinds, - ordOpTbl, boxConTbl, litConTbl, - mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnMonad -import GHC.Hs -import GHC.Types.Name.Reader -import GHC.Types.Basic -import GHC.Core.DataCon -import GHC.Types.Name -import Fingerprint -import Encoding - -import GHC.Driver.Session -import PrelInfo -import FamInst -import GHC.Core.FamInstEnv -import PrelNames -import THNames -import GHC.Types.Id.Make ( coerceId ) -import PrimOp -import GHC.Types.SrcLoc -import GHC.Core.TyCon -import TcEnv -import TcType -import TcValidity ( checkValidCoAxBranch ) -import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch ) -import TysPrim -import TysWiredIn -import GHC.Core.Type -import GHC.Core.Class -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import Util -import GHC.Types.Var -import Outputable -import GHC.Utils.Lexeme -import FastString -import Pair -import Bag - -import Data.List ( find, partition, intersperse ) - -type BagDerivStuff = Bag DerivStuff - -data AuxBindSpec - = DerivCon2Tag TyCon -- The con2Tag for given TyCon - | DerivTag2Con TyCon -- ...ditto tag2Con - | DerivMaxTag TyCon -- ...and maxTag - deriving( Eq ) - -- All these generate ZERO-BASED tag operations - -- I.e first constructor has tag 0 - -data DerivStuff -- Please add this auxiliary stuff - = DerivAuxBind AuxBindSpec - - -- Generics and DeriveAnyClass - | DerivFamInst FamInst -- New type family instances - - -- New top-level auxiliary bindings - | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB - - -{- -************************************************************************ -* * - Eq instances -* * -************************************************************************ - -Here are the heuristics for the code we generate for @Eq@. Let's -assume we have a data type with some (possibly zero) nullary data -constructors and some ordinary, non-nullary ones (the rest, also -possibly zero of them). Here's an example, with both \tr{N}ullary and -\tr{O}rdinary data cons. - - data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... - -* For the ordinary constructors (if any), we emit clauses to do The - Usual Thing, e.g.,: - - (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2 - (==) (O2 a1) (O2 a2) = a1 == a2 - (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 - - Note: if we're comparing unlifted things, e.g., if 'a1' and - 'a2' are Float#s, then we have to generate - case (a1 `eqFloat#` a2) of r -> r - for that particular test. - -* If there are a lot of (more than ten) nullary constructors, we emit a - catch-all clause of the form: - - (==) a b = case (con2tag_Foo a) of { a# -> - case (con2tag_Foo b) of { b# -> - case (a# ==# b#) of { - r -> r }}} - - If con2tag gets inlined this leads to join point stuff, so - it's better to use regular pattern matching if there aren't too - many nullary constructors. "Ten" is arbitrary, of course - -* If there aren't any nullary constructors, we emit a simpler - catch-all: - - (==) a b = False - -* For the @(/=)@ method, we normally just use the default method. - If the type is an enumeration type, we could/may/should? generate - special code that calls @con2tag_Foo@, much like for @(==)@ shown - above. - -We thought about doing this: If we're also deriving 'Ord' for this -tycon, we generate: - instance ... Eq (Foo ...) where - (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False} - (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True } -However, that requires that (Ord <whatever>) was put in the context -for the instance decl, which it probably wasn't, so the decls -produced don't get through the typechecker. --} - -gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) -gen_Eq_binds loc tycon = do - dflags <- getDynFlags - return (method_binds dflags, aux_binds) - where - all_cons = tyConDataCons tycon - (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons - - -- If there are ten or more (arbitrary number) nullary constructors, - -- use the con2tag stuff. For small types it's better to use - -- ordinary pattern matching. - (tag_match_cons, pat_match_cons) - | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons) - | otherwise = ([], all_cons) - - no_tag_match_cons = null tag_match_cons - - fall_through_eqn dflags - | no_tag_match_cons -- All constructors have arguments - = case pat_match_cons of - [] -> [] -- No constructors; no fall-though case - [_] -> [] -- One constructor; no fall-though case - _ -> -- Two or more constructors; add fall-through of - -- (==) _ _ = False - [([nlWildPat, nlWildPat], false_Expr)] - - | otherwise -- One or more tag_match cons; add fall-through of - -- extract tags compare for equality - = [([a_Pat, b_Pat], - untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] - (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] - - aux_binds | no_tag_match_cons = emptyBag - | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon - - method_binds dflags = unitBag (eq_bind dflags) - eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr) - (map pats_etc pat_match_cons - ++ fall_through_eqn dflags) - - ------------------------------------------------------------------ - pats_etc data_con - = let - con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed - con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed - - data_con_RDR = getRdrName data_con - con_arity = length tys_needed - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs - tys_needed = dataConOrigArgTys data_con - in - ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) - where - nested_eq_expr [] [] [] = true_Expr - nested_eq_expr tys as bs - = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) - -- Using 'foldr1' here ensures that the derived code is correctly - -- associated. See #10859. - where - nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) - -{- -************************************************************************ -* * - Ord instances -* * -************************************************************************ - -Note [Generating Ord instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose constructors are K1..Kn, and some are nullary. -The general form we generate is: - -* Do case on first argument - case a of - K1 ... -> rhs_1 - K2 ... -> rhs_2 - ... - Kn ... -> rhs_n - _ -> nullary_rhs - -* To make rhs_i - If i = 1, 2, n-1, n, generate a single case. - rhs_2 case b of - K1 {} -> LT - K2 ... -> ...eq_rhs(K2)... - _ -> GT - - Otherwise do a tag compare against the bigger range - (because this is the one most likely to succeed) - rhs_3 case tag b of tb -> - if 3 <# tg then GT - else case b of - K3 ... -> ...eq_rhs(K3).... - _ -> LT - -* To make eq_rhs(K), which knows that - a = K a1 .. av - b = K b1 .. bv - we just want to compare (a1,b1) then (a2,b2) etc. - Take care on the last field to tail-call into comparing av,bv - -* To make nullary_rhs generate this - case con2tag a of a# -> - case con2tag b of -> - a# `compare` b# - -Several special cases: - -* Two or fewer nullary constructors: don't generate nullary_rhs - -* Be careful about unlifted comparisons. When comparing unboxed - values we can't call the overloaded functions. - See function unliftedOrdOp - -Note [Game plan for deriving Ord] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's a bad idea to define only 'compare', and build the other binary -comparisons on top of it; see #2130, #4019. Reason: we don't -want to laboriously make a three-way comparison, only to extract a -binary result, something like this: - (>) (I# x) (I# y) = case <# x y of - True -> False - False -> case ==# x y of - True -> False - False -> True - -This being said, we can get away with generating full code only for -'compare' and '<' thus saving us generation of other three operators. -Other operators can be cheaply expressed through '<': -a <= b = not $ b < a -a > b = b < a -a >= b = not $ a < b - -So for sufficiently small types (few constructors, or all nullary) -we generate all methods; for large ones we just use 'compare'. - --} - -data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT - ------------- -ordMethRdr :: OrdOp -> RdrName -ordMethRdr op - = case op of - OrdCompare -> compare_RDR - OrdLT -> lt_RDR - OrdLE -> le_RDR - OrdGE -> ge_RDR - OrdGT -> gt_RDR - ------------- -ltResult :: OrdOp -> LHsExpr GhcPs --- Knowing a<b, what is the result for a `op` b? -ltResult OrdCompare = ltTag_Expr -ltResult OrdLT = true_Expr -ltResult OrdLE = true_Expr -ltResult OrdGE = false_Expr -ltResult OrdGT = false_Expr - ------------- -eqResult :: OrdOp -> LHsExpr GhcPs --- Knowing a=b, what is the result for a `op` b? -eqResult OrdCompare = eqTag_Expr -eqResult OrdLT = false_Expr -eqResult OrdLE = true_Expr -eqResult OrdGE = true_Expr -eqResult OrdGT = false_Expr - ------------- -gtResult :: OrdOp -> LHsExpr GhcPs --- Knowing a>b, what is the result for a `op` b? -gtResult OrdCompare = gtTag_Expr -gtResult OrdLT = false_Expr -gtResult OrdLE = false_Expr -gtResult OrdGE = true_Expr -gtResult OrdGT = true_Expr - ------------- -gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) -gen_Ord_binds loc tycon = do - dflags <- getDynFlags - return $ if null tycon_data_cons -- No data-cons => invoke bale-out case - then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) [] - , emptyBag) - else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags - , aux_binds) - where - aux_binds | single_con_type = emptyBag - | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon - - -- Note [Game plan for deriving Ord] - other_ops dflags - | (last_tag - first_tag) <= 2 -- 1-3 constructors - || null non_nullary_cons -- Or it's an enumeration - = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE] - | otherwise - = emptyBag - - negate_expr = nlHsApp (nlHsVar not_RDR) - lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $ - negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr) - gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $ - nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr - gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $ - negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr) - - get_tag con = dataConTag con - fIRST_TAG - -- We want *zero-based* tags, because that's what - -- con2Tag returns (generated by untag_Expr)! - - tycon_data_cons = tyConDataCons tycon - single_con_type = isSingleton tycon_data_cons - (first_con : _) = tycon_data_cons - (last_con : _) = reverse tycon_data_cons - first_tag = get_tag first_con - last_tag = get_tag last_con - - (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons - - - mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs - -- Returns a binding op a b = ... compares a and b according to op .... - mkOrdOp dflags op = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat] - (mkOrdOpRhs dflags op) - - mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs - mkOrdOpRhs dflags op -- RHS for comparing 'a' and 'b' according to op - | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases - = nlHsCase (nlHsVar a_RDR) $ - map (mkOrdOpAlt dflags op) tycon_data_cons - -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y... - -- C2 x -> case b of C2 x -> ....comopare x.... } - - | null non_nullary_cons -- All nullary, so go straight to comparing tags - = mkTagCmp dflags op - - | otherwise -- Mixed nullary and non-nullary - = nlHsCase (nlHsVar a_RDR) $ - (map (mkOrdOpAlt dflags op) non_nullary_cons - ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)]) - - - mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon - -> LMatch GhcPs (LHsExpr GhcPs) - -- Make the alternative (Ki a1 a2 .. av -> - mkOrdOpAlt dflags op data_con - = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed) - (mkInnerRhs dflags op data_con) - where - as_needed = take (dataConSourceArity data_con) as_RDRs - data_con_RDR = getRdrName data_con - - mkInnerRhs dflags op data_con - | single_con_type - = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] - - | tag == first_tag - = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (ltResult op) ] - | tag == last_tag - = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (gtResult op) ] - - | tag == first_tag + 1 - = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con) - (gtResult op) - , mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (ltResult op) ] - | tag == last_tag - 1 - = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con) - (ltResult op) - , mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (gtResult op) ] - - | tag > last_tag `div` 2 -- lower range is larger - = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ - nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit) - (gtResult op) $ -- Definitely GT - nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (ltResult op) ] - - | otherwise -- upper range is larger - = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ - nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit) - (ltResult op) $ -- Definitely LT - nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkHsCaseAlt nlWildPat (gtResult op) ] - where - tag = get_tag data_con - tag_lit = noLoc (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag))) - - mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) - -- First argument 'a' known to be built with K - -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) - mkInnerEqAlt op data_con - = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $ - mkCompareFields op (dataConOrigArgTys data_con) - where - data_con_RDR = getRdrName data_con - bs_needed = take (dataConSourceArity data_con) bs_RDRs - - mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs - -- Both constructors known to be nullary - -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# - mkTagCmp dflags op = - untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ - unliftedOrdOp intPrimTy op ah_RDR bh_RDR - -mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs --- Generates nested comparisons for (a1,a2...) against (b1,b2,...) --- where the ai,bi have the given types -mkCompareFields op tys - = go tys as_RDRs bs_RDRs - where - go [] _ _ = eqResult op - go [ty] (a:_) (b:_) - | isUnliftedType ty = unliftedOrdOp ty op a b - | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b) - go (ty:tys) (a:as) (b:bs) = mk_compare ty a b - (ltResult op) - (go tys as bs) - (gtResult op) - go _ _ _ = panic "mkCompareFields" - - -- (mk_compare ty a b) generates - -- (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> }) - -- but with suitable special cases for - mk_compare ty a b lt eq gt - | isUnliftedType ty - = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt - | otherwise - = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr)) - [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt, - mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq, - mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt] - where - a_expr = nlHsVar a - b_expr = nlHsVar b - (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty - -unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs -unliftedOrdOp ty op a b - = case op of - OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr - ltTag_Expr eqTag_Expr gtTag_Expr - OrdLT -> wrap lt_op - OrdLE -> wrap le_op - OrdGE -> wrap ge_op - OrdGT -> wrap gt_op - where - (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty - wrap prim_op = genPrimOpApp a_expr prim_op b_expr - a_expr = nlHsVar a - b_expr = nlHsVar b - -unliftedCompare :: RdrName -> RdrName - -> LHsExpr GhcPs -> LHsExpr GhcPs -- What to compare - -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs - -- Three results - -> LHsExpr GhcPs --- Return (if a < b then lt else if a == b then eq else gt) -unliftedCompare lt_op eq_op a_expr b_expr lt eq gt - = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $ - -- Test (<) first, not (==), because the latter - -- is true less often, so putting it first would - -- mean more tests (dynamically) - nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt - where - ascribeBool e = nlExprWithTySig e boolTy - -nlConWildPat :: DataCon -> LPat GhcPs --- The pattern (K {}) -nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con)) - (RecCon (HsRecFields { rec_flds = [] - , rec_dotdot = Nothing }))) - -{- -************************************************************************ -* * - Enum instances -* * -************************************************************************ - -@Enum@ can only be derived for enumeration types. For a type -\begin{verbatim} -data Foo ... = N1 | N2 | ... | Nn -\end{verbatim} - -we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a -@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@). - -\begin{verbatim} -instance ... Enum (Foo ...) where - succ x = toEnum (1 + fromEnum x) - pred x = toEnum (fromEnum x - 1) - - toEnum i = tag2con_Foo i - - enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo] - - -- or, really... - enumFrom a - = case con2tag_Foo a of - a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo) - - enumFromThen a b - = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo] - - -- or, really... - enumFromThen a b - = case con2tag_Foo a of { a# -> - case con2tag_Foo b of { b# -> - map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo) - }} -\end{verbatim} - -For @enumFromTo@ and @enumFromThenTo@, we use the default methods. --} - -gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) -gen_Enum_binds loc tycon = do - dflags <- getDynFlags - return (method_binds dflags, aux_binds) - where - method_binds dflags = listToBag - [ succ_enum dflags - , pred_enum dflags - , to_enum dflags - , enum_from dflags - , enum_from_then dflags - , from_enum dflags - ] - aux_binds = listToBag $ map DerivAuxBind - [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon] - - occ_nm = getOccString tycon - - succ_enum dflags - = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon), - nlHsVarApps intDataCon_RDR [ah_RDR]]) - (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") - (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) - (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], - nlHsIntLit 1])) - - pred_enum dflags - = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, - nlHsVarApps intDataCon_RDR [ah_RDR]]) - (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") - (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) - (nlHsApps plus_RDR - [ nlHsVarApps intDataCon_RDR [ah_RDR] - , nlHsLit (HsInt noExtField - (mkIntegralLit (-1 :: Int)))])) - - to_enum dflags - = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $ - nlHsIf (nlHsApps and_RDR - [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], - nlHsApps le_RDR [ nlHsVar a_RDR - , nlHsVar (maxtag_RDR dflags tycon)]]) - (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR]) - (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon)) - - enum_from dflags - = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - nlHsApps map_RDR - [nlHsVar (tag2con_RDR dflags tycon), - nlHsPar (enum_from_to_Expr - (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVar (maxtag_RDR dflags tycon)))] - - enum_from_then dflags - = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ - nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ - nlHsPar (enum_from_then_to_Expr - (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVarApps intDataCon_RDR [bh_RDR]) - (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], - nlHsVarApps intDataCon_RDR [bh_RDR]]) - (nlHsIntLit 0) - (nlHsVar (maxtag_RDR dflags tycon)) - )) - - from_enum dflags - = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - (nlHsVarApps intDataCon_RDR [ah_RDR]) - -{- -************************************************************************ -* * - Bounded instances -* * -************************************************************************ --} - -gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) -gen_Bounded_binds loc tycon - | isEnumerationTyCon tycon - = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag) - | otherwise - = ASSERT(isSingleton data_cons) - (listToBag [ min_bound_1con, max_bound_1con ], emptyBag) - where - data_cons = tyConDataCons tycon - - ----- enum-flavored: --------------------------- - min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) - max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) - - data_con_1 = head data_cons - data_con_N = last data_cons - data_con_1_RDR = getRdrName data_con_1 - data_con_N_RDR = getRdrName data_con_N - - ----- single-constructor-flavored: ------------- - arity = dataConSourceArity data_con_1 - - min_bound_1con = mkHsVarBind loc minBound_RDR $ - nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR) - max_bound_1con = mkHsVarBind loc maxBound_RDR $ - nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR) - -{- -************************************************************************ -* * - Ix instances -* * -************************************************************************ - -Deriving @Ix@ is only possible for enumeration types and -single-constructor types. We deal with them in turn. - -For an enumeration type, e.g., -\begin{verbatim} - data Foo ... = N1 | N2 | ... | Nn -\end{verbatim} -things go not too differently from @Enum@: -\begin{verbatim} -instance ... Ix (Foo ...) where - range (a, b) - = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b] - - -- or, really... - range (a, b) - = case (con2tag_Foo a) of { a# -> - case (con2tag_Foo b) of { b# -> - map tag2con_Foo (enumFromTo (I# a#) (I# b#)) - }} - - -- Generate code for unsafeIndex, because using index leads - -- to lots of redundant range tests - unsafeIndex c@(a, b) d - = case (con2tag_Foo d -# con2tag_Foo a) of - r# -> I# r# - - inRange (a, b) c - = let - p_tag = con2tag_Foo c - in - p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b - - -- or, really... - inRange (a, b) c - = case (con2tag_Foo a) of { a_tag -> - case (con2tag_Foo b) of { b_tag -> - case (con2tag_Foo c) of { c_tag -> - if (c_tag >=# a_tag) then - c_tag <=# b_tag - else - False - }}} -\end{verbatim} -(modulo suitable case-ification to handle the unlifted tags) - -For a single-constructor type (NB: this includes all tuples), e.g., -\begin{verbatim} - data Foo ... = MkFoo a b Int Double c c -\end{verbatim} -we follow the scheme given in Figure~19 of the Haskell~1.2 report -(p.~147). --} - -gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) - -gen_Ix_binds loc tycon = do - dflags <- getDynFlags - return $ if isEnumerationTyCon tycon - then (enum_ixes dflags, listToBag $ map DerivAuxBind - [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]) - else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon))) - where - -------------------------------------------------------------- - enum_ixes dflags = listToBag - [ enum_range dflags - , enum_index dflags - , enum_inRange dflags - ] - - enum_range dflags - = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ - untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ - nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ - nlHsPar (enum_from_to_Expr - (nlHsVarApps intDataCon_RDR [ah_RDR]) - (nlHsVarApps intDataCon_RDR [bh_RDR])) - - enum_index dflags - = mkSimpleGeneratedFunBind loc unsafeIndex_RDR - [noLoc (AsPat noExtField (noLoc c_RDR) - (nlTuplePat [a_Pat, nlWildPat] Boxed)), - d_Pat] ( - untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( - untag_Expr dflags tycon [(d_RDR, dh_RDR)] ( - let - rhs = nlHsVarApps intDataCon_RDR [c_RDR] - in - nlHsCase - (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR)) - [mkHsCaseAlt (nlVarPat c_RDR) rhs] - )) - ) - - -- This produces something like `(ch >= ah) && (ch <= bh)` - enum_inRange dflags - = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ - untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( - untag_Expr dflags tycon [(b_RDR, bh_RDR)] ( - untag_Expr dflags tycon [(c_RDR, ch_RDR)] ( - -- This used to use `if`, which interacts badly with RebindableSyntax. - -- See #11396. - nlHsApps and_RDR - [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR) - , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR) - ] - ))) - - -------------------------------------------------------------- - single_con_ixes - = listToBag [single_con_range, single_con_index, single_con_inRange] - - data_con - = case tyConSingleDataCon_maybe tycon of -- just checking... - Nothing -> panic "get_Ix_binds" - Just dc -> dc - - con_arity = dataConSourceArity data_con - data_con_RDR = getRdrName data_con - - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs - cs_needed = take con_arity cs_RDRs - - con_pat xs = nlConVarPat data_con_RDR xs - con_expr = nlHsVarApps data_con_RDR cs_needed - - -------------------------------------------------------------- - single_con_range - = mkSimpleGeneratedFunBind loc range_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ - noLoc (mkHsComp ListComp stmts con_expr) - where - stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed - - mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c) - (nlHsApp (nlHsVar range_RDR) - (mkLHsVarTuple [a,b])) - - ---------------- - single_con_index - = mkSimpleGeneratedFunBind loc unsafeIndex_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] - -- We need to reverse the order we consider the components in - -- so that - -- range (l,u) !! index (l,u) i == i -- when i is in range - -- (from http://haskell.org/onlinereport/ix.html) holds. - (mk_index (reverse $ zip3 as_needed bs_needed cs_needed)) - where - -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) - mk_index [] = nlHsIntLit 0 - mk_index [(l,u,i)] = mk_one l u i - mk_index ((l,u,i) : rest) - = genOpApp ( - mk_one l u i - ) plus_RDR ( - genOpApp ( - (nlHsApp (nlHsVar unsafeRangeSize_RDR) - (mkLHsVarTuple [l,u])) - ) times_RDR (mk_index rest) - ) - mk_one l u i - = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] - - ------------------ - single_con_inRange - = mkSimpleGeneratedFunBind loc inRange_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] $ - if con_arity == 0 - -- If the product type has no fields, inRange is trivially true - -- (see #12853). - then true_Expr - else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range - as_needed bs_needed cs_needed) - where - in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] - -{- -************************************************************************ -* * - Read instances -* * -************************************************************************ - -Example - - infix 4 %% - data T = Int %% Int - | T1 { f1 :: Int } - | T2 T - -instance Read T where - readPrec = - parens - ( prec 4 ( - do x <- ReadP.step Read.readPrec - expectP (Symbol "%%") - y <- ReadP.step Read.readPrec - return (x %% y)) - +++ - prec (appPrec+1) ( - -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok - -- Record construction binds even more tightly than application - do expectP (Ident "T1") - expectP (Punc '{') - x <- Read.readField "f1" (ReadP.reset readPrec) - expectP (Punc '}') - return (T1 { f1 = x })) - +++ - prec appPrec ( - do expectP (Ident "T2") - x <- ReadP.step Read.readPrec - return (T2 x)) - ) - - readListPrec = readListPrecDefault - readList = readListDefault - - -Note [Use expectP] -~~~~~~~~~~~~~~~~~~ -Note that we use - expectP (Ident "T1") -rather than - Ident "T1" <- lexP -The latter desugares to inline code for matching the Ident and the -string, and this can be very voluminous. The former is much more -compact. Cf #7258, although that also concerned non-linearity in -the occurrence analyser, a separate issue. - -Note [Read for empty data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should we get for this? (#7931) - data Emp deriving( Read ) -- No data constructors - -Here we want - read "[]" :: [Emp] to succeed, returning [] -So we do NOT want - instance Read Emp where - readPrec = error "urk" -Rather we want - instance Read Emp where - readPred = pfail -- Same as choose [] - -Because 'pfail' allows the parser to backtrack, but 'error' doesn't. -These instances are also useful for Read (Either Int Emp), where -we want to be able to parse (Left 3) just fine. --} - -gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon - -> (LHsBinds GhcPs, BagDerivStuff) - -gen_Read_binds get_fixity loc tycon - = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag) - where - ----------------------------------------------------------------------- - default_readlist - = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) - - default_readlistprec - = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) - ----------------------------------------------------------------------- - - data_cons = tyConDataCons tycon - (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons - - read_prec = mkHsVarBind loc readPrec_RDR rhs - where - rhs | null data_cons -- See Note [Read for empty data types] - = nlHsVar pfail_RDR - | otherwise - = nlHsApp (nlHsVar parens_RDR) - (foldr1 mk_alt (read_nullary_cons ++ - read_non_nullary_cons)) - - read_non_nullary_cons = map read_non_nullary_con non_nullary_cons - - read_nullary_cons - = case nullary_cons of - [] -> [] - [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] - _ -> [nlHsApp (nlHsVar choose_RDR) - (nlList (map mk_pair nullary_cons))] - -- NB For operators the parens around (:=:) are matched by the - -- enclosing "parens" call, so here we must match the naked - -- data_con_str con - - match_con con | isSym con_str = [symbol_pat con_str] - | otherwise = ident_h_pat con_str - where - con_str = data_con_str con - -- For nullary constructors we must match Ident s for normal constrs - -- and Symbol s for operators - - mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), - result_expr con []] - - read_non_nullary_con data_con - | is_infix = mk_parser infix_prec infix_stmts body - | is_record = mk_parser record_prec record_stmts body --- Using these two lines instead allows the derived --- read for infix and record bindings to read the prefix form --- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body) --- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body) - | otherwise = prefix_parser - where - body = result_expr data_con as_needed - con_str = data_con_str data_con - - prefix_parser = mk_parser prefix_prec prefix_stmts body - - read_prefix_con - | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] - | otherwise = ident_h_pat con_str - - read_infix_con - | isSym con_str = [symbol_pat con_str] - | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] - - prefix_stmts -- T a b c - = read_prefix_con ++ read_args - - infix_stmts -- a %% b, or a `T` b - = [read_a1] - ++ read_infix_con - ++ [read_a2] - - record_stmts -- T { f1 = a, f2 = b } - = read_prefix_con - ++ [read_punc "{"] - ++ concat (intersperse [read_punc ","] field_stmts) - ++ [read_punc "}"] - - field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed - - con_arity = dataConSourceArity data_con - labels = map flLabel $ dataConFieldLabels data_con - dc_nm = getName data_con - is_infix = dataConIsInfix data_con - is_record = labels `lengthExceeds` 0 - as_needed = take con_arity as_RDRs - read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con) - (read_a1:read_a2:_) = read_args - - prefix_prec = appPrecedence - infix_prec = getPrecedence get_fixity dc_nm - record_prec = appPrecedence + 1 -- Record construction binds even more tightly - -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) - - ------------------------------------------------------------------------ - -- Helpers - ------------------------------------------------------------------------ - mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 - mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) - , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])] - con_app con as = nlHsVarApps (getRdrName con) as -- con as - result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) - - -- For constructors and field labels ending in '#', we hackily - -- let the lexer generate two tokens, and look for both in sequence - -- Thus [Ident "I"; Symbol "#"]. See #5041 - ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] - | otherwise = [ ident_pat s ] - - bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p - -- See Note [Use expectP] - ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo") - symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>") - read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<") - - data_con_str con = occNameString (getOccName con) - - read_arg a ty = ASSERT( not (isUnliftedType ty) ) - noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) - - -- When reading field labels we might encounter - -- a = 3 - -- _a = 3 - -- or (#) = 4 - -- Note the parens! - read_field lbl a = - [noLoc - (mkBindStmt - (nlVarPat a) - (nlHsApp - read_field - (nlHsVarApps reset_RDR [readPrec_RDR]) - ) - ) - ] - where - lbl_str = unpackFS lbl - mk_read_field read_field_rdr lbl - = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)] - read_field - | isSym lbl_str - = mk_read_field readSymField_RDR lbl_str - | Just (ss, '#') <- snocView lbl_str -- #14918 - = mk_read_field readFieldHash_RDR ss - | otherwise - = mk_read_field readField_RDR lbl_str - -{- -************************************************************************ -* * - Show instances -* * -************************************************************************ - -Example - - infixr 5 :^: - - data Tree a = Leaf a | Tree a :^: Tree a - - instance (Show a) => Show (Tree a) where - - showsPrec d (Leaf m) = showParen (d > app_prec) showStr - where - showStr = showString "Leaf " . showsPrec (app_prec+1) m - - showsPrec d (u :^: v) = showParen (d > up_prec) showStr - where - showStr = showsPrec (up_prec+1) u . - showString " :^: " . - showsPrec (up_prec+1) v - -- Note: right-associativity of :^: ignored - - up_prec = 5 -- Precedence of :^: - app_prec = 10 -- Application has precedence one more than - -- the most tightly-binding operator --} - -gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon - -> (LHsBinds GhcPs, BagDerivStuff) - -gen_Show_binds get_fixity loc tycon - = (unitBag shows_prec, emptyBag) - where - data_cons = tyConDataCons tycon - shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons) - comma_space = nlHsVar showCommaSpace_RDR - - pats_etc data_con - | nullary_con = -- skip the showParen junk... - ASSERT(null bs_needed) - ([nlWildPat, con_pat], mk_showString_app op_con_str) - | otherwise = - ([a_Pat, con_pat], - showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit - (HsInt noExtField (mkIntegralLit con_prec_plus_one)))) - (nlHsPar (nested_compose_Expr show_thingies))) - where - data_con_RDR = getRdrName data_con - con_arity = dataConSourceArity data_con - bs_needed = take con_arity bs_RDRs - arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed - con_pat = nlConVarPat data_con_RDR bs_needed - nullary_con = con_arity == 0 - labels = map flLabel $ dataConFieldLabels data_con - lab_fields = length labels - record_syntax = lab_fields > 0 - - dc_nm = getName data_con - dc_occ_nm = getOccName data_con - con_str = occNameString dc_occ_nm - op_con_str = wrapOpParens con_str - backquote_str = wrapOpBackquotes con_str - - show_thingies - | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2] - | record_syntax = mk_showString_app (op_con_str ++ " {") : - show_record_args ++ [mk_showString_app "}"] - | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args - - show_label l = mk_showString_app (nm ++ " = ") - -- Note the spaces around the "=" sign. If we - -- don't have them then we get Foo { x=-1 } and - -- the "=-" parses as a single lexeme. Only the - -- space after the '=' is necessary, but it - -- seems tidier to have them both sides. - where - nm = wrapOpParens (unpackFS l) - - show_args = zipWith show_arg bs_needed arg_tys - (show_arg1:show_arg2:_) = show_args - show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args - - -- Assumption for record syntax: no of fields == no of - -- labelled fields (and in same order) - show_record_args = concat $ - intersperse [comma_space] $ - [ [show_label lbl, arg] - | (lbl,arg) <- zipEqual "gen_Show_binds" - labels show_args ] - - show_arg :: RdrName -> Type -> LHsExpr GhcPs - show_arg b arg_ty - | isUnliftedType arg_ty - -- See Note [Deriving and unboxed types] in TcDerivInfer - = with_conv $ - nlHsApps compose_RDR - [mk_shows_app boxed_arg, mk_showString_app postfixMod] - | otherwise - = mk_showsPrec_app arg_prec arg - where - arg = nlHsVar b - boxed_arg = box "Show" arg arg_ty - postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty - with_conv expr - | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty = - nested_compose_Expr - [ mk_showString_app ("(" ++ conv ++ " ") - , expr - , mk_showString_app ")" - ] - | otherwise = expr - - -- Fixity stuff - is_infix = dataConIsInfix data_con - con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm - arg_prec | record_syntax = 0 -- Record fields don't need parens - | otherwise = con_prec_plus_one - -wrapOpParens :: String -> String -wrapOpParens s | isSym s = '(' : s ++ ")" - | otherwise = s - -wrapOpBackquotes :: String -> String -wrapOpBackquotes s | isSym s = s - | otherwise = '`' : s ++ "`" - -isSym :: String -> Bool -isSym "" = False -isSym (c : _) = startsVarSym c || startsConSym c - --- | showString :: String -> ShowS -mk_showString_app :: String -> LHsExpr GhcPs -mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) - --- | showsPrec :: Show a => Int -> a -> ShowS -mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs -mk_showsPrec_app p x - = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExtField (mkIntegralLit p)), x] - --- | shows :: Show a => a -> ShowS -mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs -mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x - -getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer -getPrec is_infix get_fixity nm - | not is_infix = appPrecedence - | otherwise = getPrecedence get_fixity nm - -appPrecedence :: Integer -appPrecedence = fromIntegral maxPrecedence + 1 - -- One more than the precedence of the most - -- tightly-binding operator - -getPrecedence :: (Name -> Fixity) -> Name -> Integer -getPrecedence get_fixity nm - = case get_fixity nm of - Fixity _ x _assoc -> fromIntegral x - -- NB: the Report says that associativity is not taken - -- into account for either Read or Show; hence we - -- ignore associativity here - -{- -************************************************************************ -* * - Data instances -* * -************************************************************************ - -From the data type - - data T a b = T1 a b | T2 - -we generate - - $cT1 = mkDataCon $dT "T1" Prefix - $cT2 = mkDataCon $dT "T2" Prefix - $dT = mkDataType "Module.T" [] [$con_T1, $con_T2] - -- the [] is for field labels. - - instance (Data a, Data b) => Data (T a b) where - gfoldl k z (T1 a b) = z T `k` a `k` b - gfoldl k z T2 = z T2 - -- ToDo: add gmapT,Q,M, gfoldr - - gunfold k z c = case conIndex c of - I# 1# -> k (k (z T1)) - I# 2# -> z T2 - - toConstr (T1 _ _) = $cT1 - toConstr T2 = $cT2 - - dataTypeOf _ = $dT - - dataCast1 = gcast1 -- If T :: * -> * - dataCast2 = gcast2 -- if T :: * -> * -> * --} - -gen_Data_binds :: SrcSpan - -> TyCon -- For data families, this is the - -- *representation* TyCon - -> TcM (LHsBinds GhcPs, -- The method bindings - BagDerivStuff) -- Auxiliary bindings -gen_Data_binds loc rep_tc - = do { dflags <- getDynFlags - - -- Make unique names for the data type and constructor - -- auxiliary bindings. Start with the name of the TyCon/DataCon - -- but that might not be unique: see #12245. - ; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc)) - ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName) - (tyConDataCons rep_tc) - ; let dt_rdr = mkRdrUnqual dt_occ - dc_rdrs = map mkRdrUnqual dc_occs - - -- OK, now do the work - ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) } - -gen_data :: DynFlags -> RdrName -> [RdrName] - -> SrcSpan -> TyCon - -> (LHsBinds GhcPs, -- The method bindings - BagDerivStuff) -- Auxiliary bindings -gen_data dflags data_type_name constr_names loc rep_tc - = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] - `unionBags` gcast_binds, - -- Auxiliary definitions: the data type and constructors - listToBag ( genDataTyCon - : zipWith genDataDataCon data_cons constr_names ) ) - where - data_cons = tyConDataCons rep_tc - n_cons = length data_cons - one_constr = n_cons == 1 - genDataTyCon :: DerivStuff - genDataTyCon -- $dT - = DerivHsBind (mkHsVarBind loc data_type_name rhs, - L loc (TypeSig noExtField [L loc data_type_name] sig_ty)) - - sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR) - rhs = nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc))) - `nlHsApp` nlList (map nlHsVar constr_names) - - genDataDataCon :: DataCon -> RdrName -> DerivStuff - genDataDataCon dc constr_name -- $cT1 etc - = DerivHsBind (mkHsVarBind loc constr_name rhs, - L loc (TypeSig noExtField [L loc constr_name] sig_ty)) - where - sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR) - rhs = nlHsApps mkConstr_RDR constr_args - - constr_args - = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag - nlHsVar (data_type_name) -- DataType - , nlHsLit (mkHsString (occNameString dc_occ)) -- String name - , nlList labels -- Field labels - , nlHsVar fixity ] -- Fixity - - labels = map (nlHsLit . mkHsString . unpackFS . flLabel) - (dataConFieldLabels dc) - dc_occ = getOccName dc - is_infix = isDataSymOcc dc_occ - fixity | is_infix = infix_RDR - | otherwise = prefix_RDR - - ------------ gfoldl - gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons) - - gfoldl_eqn con - = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed], - foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed) - where - con_name :: RdrName - con_name = getRdrName con - as_needed = take (dataConSourceArity con) as_RDRs - mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) - - ------------ gunfold - gunfold_bind = mkSimpleGeneratedFunBind loc - gunfold_RDR - [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat] - gunfold_rhs - - gunfold_rhs - | one_constr = mk_unfold_rhs (head data_cons) -- No need for case - | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) - (map gunfold_alt data_cons) - - gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) - mk_unfold_rhs dc = foldr nlHsApp - (z_Expr `nlHsApp` nlHsVar (getRdrName dc)) - (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) - - mk_unfold_pat dc -- Last one is a wild-pat, to avoid - -- redundant test, and annoying warning - | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor - | otherwise = nlConPat intDataCon_RDR - [nlLitPat (HsIntPrim NoSourceText (toInteger tag))] - where - tag = dataConTag dc - - ------------ toConstr - toCon_bind = mkFunBindEC 1 loc toConstr_RDR id - (zipWith to_con_eqn data_cons constr_names) - to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) - - ------------ dataTypeOf - dataTypeOf_bind = mkSimpleGeneratedFunBind - loc - dataTypeOf_RDR - [nlWildPat] - (nlHsVar data_type_name) - - ------------ gcast1/2 - -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> * - -- or dataCast2 x = gcast2 s -- if T :: * -> * -> * - -- (or nothing if T has neither of these two types) - - -- But care is needed for data families: - -- If we have data family D a - -- data instance D (a,b,c) = A | B deriving( Data ) - -- and we want instance ... => Data (D [(a,b,c)]) where ... - -- then we need dataCast1 x = gcast1 x - -- because D :: * -> * - -- even though rep_tc has kind * -> * -> * -> * - -- Hence looking for the kind of fam_tc not rep_tc - -- See #4896 - tycon_kind = case tyConFamInst_maybe rep_tc of - Just (fam_tc, _) -> tyConKind fam_tc - Nothing -> tyConKind rep_tc - gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR - | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR - | otherwise = emptyBag - mk_gcast dataCast_RDR gcast_RDR - = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR] - (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) - - -kind1, kind2 :: Kind -kind1 = typeToTypeKind -kind2 = liftedTypeKind `mkVisFunTy` kind1 - -gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, - mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, - dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, - constr_RDR, dataType_RDR, - eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR , - eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , - eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR , - eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR , - eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , - eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR , - eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR, - eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , - eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , - eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR, - extendWord8_RDR, extendInt8_RDR, - extendWord16_RDR, extendInt16_RDR :: RdrName -gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") -gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") -toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") -dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") -dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1") -dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") -gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") -gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") -mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") -constr_RDR = tcQual_RDR gENERICS (fsLit "Constr") -mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") -dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType") -conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") -prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") -infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") - -eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#") -ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#") -leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#") -gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#") -geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#") - -eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#") -ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" ) -leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#") -gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" ) -geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#") - -eqInt8_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt8#") -ltInt8_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt8#" ) -leInt8_RDR = varQual_RDR gHC_PRIM (fsLit "leInt8#") -gtInt8_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt8#" ) -geInt8_RDR = varQual_RDR gHC_PRIM (fsLit "geInt8#") - -eqInt16_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt16#") -ltInt16_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt16#" ) -leInt16_RDR = varQual_RDR gHC_PRIM (fsLit "leInt16#") -gtInt16_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt16#" ) -geInt16_RDR = varQual_RDR gHC_PRIM (fsLit "geInt16#") - -eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") -ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") -leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") -gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#") -geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#") - -eqWord8_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord8#") -ltWord8_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord8#" ) -leWord8_RDR = varQual_RDR gHC_PRIM (fsLit "leWord8#") -gtWord8_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord8#" ) -geWord8_RDR = varQual_RDR gHC_PRIM (fsLit "geWord8#") - -eqWord16_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord16#") -ltWord16_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord16#" ) -leWord16_RDR = varQual_RDR gHC_PRIM (fsLit "leWord16#") -gtWord16_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord16#" ) -geWord16_RDR = varQual_RDR gHC_PRIM (fsLit "geWord16#") - -eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") -ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") -leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") -gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#") -geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#") - -eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#") -ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#") -leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#") -gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#") -geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#") - -eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##") -ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" ) -leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##") -gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) -geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") - -extendWord8_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord8#") -extendInt8_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt8#") - -extendWord16_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord16#") -extendInt16_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt16#") - - -{- -************************************************************************ -* * - Lift instances -* * -************************************************************************ - -Example: - - data Foo a = Foo a | a :^: a deriving Lift - - ==> - - instance (Lift a) => Lift (Foo a) where - lift (Foo a) = [| Foo a |] - lift ((:^:) u v) = [| (:^:) u v |] - - liftTyped (Foo a) = [|| Foo a ||] - liftTyped ((:^:) u v) = [|| (:^:) u v ||] --} - - -gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) -gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag) - where - lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) - (map (pats_etc mk_exp) data_cons) - liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr) - (map (pats_etc mk_texp) data_cons) - - mk_exp = ExpBr noExtField - mk_texp = TExpBr noExtField - data_cons = tyConDataCons tycon - - pats_etc mk_bracket data_con - = ([con_pat], lift_Expr) - where - con_pat = nlConVarPat data_con_RDR as_needed - data_con_RDR = getRdrName data_con - con_arity = dataConSourceArity data_con - as_needed = take con_arity as_RDRs - lift_Expr = noLoc (HsBracket noExtField (mk_bracket br_body)) - br_body = nlHsApps (Exact (dataConName data_con)) - (map nlHsVar as_needed) - -{- -************************************************************************ -* * - Newtype-deriving instances -* * -************************************************************************ - -Note [Newtype-deriving instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We take every method in the original instance and `coerce` it to fit -into the derived instance. We need type applications on the argument -to `coerce` to make it obvious what instantiation of the method we're -coercing from. So from, say, - - class C a b where - op :: forall c. a -> [b] -> c -> Int - - newtype T x = MkT <rep-ty> - - instance C a <rep-ty> => C a (T x) where - op :: forall c. a -> [T x] -> c -> Int - op = coerce @(a -> [<rep-ty>] -> c -> Int) - @(a -> [T x] -> c -> Int) - op - -In addition to the type applications, we also have an explicit -type signature on the entire RHS. This brings the method-bound variable -`c` into scope over the two type applications. -See Note [GND and QuantifiedConstraints] for more information on why this -is important. - -Giving 'coerce' two explicitly-visible type arguments grants us finer control -over how it should be instantiated. Recall - - coerce :: Coercible a b => a -> b - -By giving it explicit type arguments we deal with the case where -'op' has a higher rank type, and so we must instantiate 'coerce' with -a polytype. E.g. - - class C a where op :: a -> forall b. b -> b - newtype T x = MkT <rep-ty> - instance C <rep-ty> => C (T x) where - op :: T x -> forall b. b -> b - op = coerce @(<rep-ty> -> forall b. b -> b) - @(T x -> forall b. b -> b) - op - -The use of type applications is crucial here. If we had tried using only -explicit type signatures, like so: - - instance C <rep-ty> => C (T x) where - op :: T x -> forall b. b -> b - op = coerce (op :: <rep-ty> -> forall b. b -> b) - -Then GHC will attempt to deeply skolemize the two type signatures, which will -wreak havoc with the Coercible solver. Therefore, we instead use type -applications, which do not deeply skolemize and thus avoid this issue. -The downside is that we currently require -XImpredicativeTypes to permit this -polymorphic type instantiation, so we have to switch that flag on locally in -TcDeriv.genInst. See #8503 for more discussion. - -Note [Newtype-deriving trickiness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12768): - class C a where { op :: D a => a -> a } - - instance C a => C [a] where { op = opList } - - opList :: (C a, D [a]) => [a] -> [a] - opList = ... - -Now suppose we try GND on this: - newtype N a = MkN [a] deriving( C ) - -The GND is expecting to get an implementation of op for N by -coercing opList, thus: - - instance C a => C (N a) where { op = opN } - - opN :: (C a, D (N a)) => N a -> N a - opN = coerce @([a] -> [a]) - @([N a] -> [N a] - opList :: D (N a) => [N a] -> [N a] - -But there is no reason to suppose that (D [a]) and (D (N a)) -are inter-coercible; these instances might completely different. -So GHC rightly rejects this code. - -Note [GND and QuantifiedConstraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example from #15290: - - class C m where - join :: m (m a) -> m a - - newtype T m a = MkT (m a) - - deriving instance - (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => - C (T m) - -The code that GHC used to generate for this was: - - instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => - C (T m) where - join = coerce @(forall a. m (m a) -> m a) - @(forall a. T m (T m a) -> T m a) - join - -This instantiates `coerce` at a polymorphic type, a form of impredicative -polymorphism, so we're already on thin ice. And in fact the ice breaks, -as we'll explain: - -The call to `coerce` gives rise to: - - Coercible (forall a. m (m a) -> m a) - (forall a. T m (T m a) -> T m a) - -And that simplified to the following implication constraint: - - forall a <no-ev>. m (T m a) ~R# m (m a) - -But because this constraint is under a `forall`, inside a type, we have to -prove it *without computing any term evidence* (hence the <no-ev>). Alas, we -*must* generate a term-level evidence binding in order to instantiate the -quantified constraint! In response, GHC currently chooses not to use such -a quantified constraint. -See Note [Instances in no-evidence implications] in TcInteract. - -But this isn't the death knell for combining QuantifiedConstraints with GND. -On the contrary, if we generate GND bindings in a slightly different way, then -we can avoid this situation altogether. Instead of applying `coerce` to two -polymorphic types, we instead let an instance signature do the polymorphic -instantiation, and omit the `forall`s in the type applications. -More concretely, we generate the following code instead: - - instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => - C (T m) where - join :: forall a. T m (T m a) -> T m a - join = coerce @( m (m a) -> m a) - @(T m (T m a) -> T m a) - join - -Now the visible type arguments are both monotypes, so we don't need any of this -funny quantified constraint instantiation business. While this particular -example no longer uses impredicative instantiation, we still need to enable -ImpredicativeTypes to typecheck GND-generated code for class methods with -higher-rank types. See Note [Newtype-deriving instances]. - -You might think that that second @(T m (T m a) -> T m a) argument is redundant -in the presence of the instance signature, but in fact leaving it off will -break this example (from the T15290d test case): - - class C a where - c :: Int -> forall b. b -> a - - instance C Int - - instance C Age where - c :: Int -> forall b. b -> Age - c = coerce @(Int -> forall b. b -> Int) - c - -That is because the instance signature deeply skolemizes the forall-bound -`b`, which wreaks havoc with the `Coercible` solver. An additional visible type -argument of @(Int -> forall b. b -> Age) is enough to prevent this. - -Be aware that the use of an instance signature doesn't /solve/ this -problem; it just makes it less likely to occur. For example, if a class has -a truly higher-rank type like so: - - class CProblem m where - op :: (forall b. ... (m b) ...) -> Int - -Then the same situation will arise again. But at least it won't arise for the -common case of methods with ordinary, prenex-quantified types. - -Note [GND and ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~ -We make an effort to make the code generated through GND be robust w.r.t. -ambiguous type variables. As one example, consider the following example -(from #15637): - - class C a where f :: String - instance C () where f = "foo" - newtype T = T () deriving C - -A naïve attempt and generating a C T instance would be: - - instance C T where - f :: String - f = coerce @String @String f - -This isn't going to typecheck, however, since GHC doesn't know what to -instantiate the type variable `a` with in the call to `f` in the method body. -(Note that `f :: forall a. String`!) To compensate for the possibility of -ambiguity here, we explicitly instantiate `a` like so: - - instance C T where - f :: String - f = coerce @String @String (f @()) - -All better now. --} - -gen_Newtype_binds :: SrcSpan - -> Class -- the class being derived - -> [TyVar] -- the tvs in the instance head (this includes - -- the tvs from both the class types and the - -- newtype itself) - -> [Type] -- instance head parameters (incl. newtype) - -> Type -- the representation type - -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff) --- See Note [Newtype-deriving instances] -gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty - = do let ats = classATs cls - (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls) - atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats ) - mapM mk_atf_inst ats - return ( listToBag binds - , sigs - , listToBag $ map DerivFamInst atf_insts ) - where - -- For each class method, generate its derived binding and instance - -- signature. Using the first example from - -- Note [Newtype-deriving instances]: - -- - -- class C a b where - -- op :: forall c. a -> [b] -> c -> Int - -- - -- newtype T x = MkT <rep-ty> - -- - -- Then we would generate <derived-op-impl> below: - -- - -- instance C a <rep-ty> => C a (T x) where - -- <derived-op-impl> - mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs) - mk_bind_and_sig meth_id - = ( -- The derived binding, e.g., - -- - -- op = coerce @(a -> [<rep-ty>] -> c -> Int) - -- @(a -> [T x] -> c -> Int) - -- op - mkRdrFunBind loc_meth_RDR [mkSimpleMatch - (mkPrefixFunRhs loc_meth_RDR) - [] rhs_expr] - , -- The derived instance signature, e.g., - -- - -- op :: forall c. a -> [T x] -> c -> Int - L loc $ ClassOpSig noExtField False [loc_meth_RDR] - $ mkLHsSigType $ typeToLHsType to_ty - ) - where - Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id - (_, _, from_tau) = tcSplitSigmaTy from_ty - (_, _, to_tau) = tcSplitSigmaTy to_ty - - meth_RDR = getRdrName meth_id - loc_meth_RDR = L loc meth_RDR - - rhs_expr = nlHsVar (getRdrName coerceId) - `nlHsAppType` from_tau - `nlHsAppType` to_tau - `nlHsApp` meth_app - - -- The class method, applied to all of the class instance types - -- (including the representation type) to avoid potential ambiguity. - -- See Note [GND and ambiguity] - meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $ - filterOutInferredTypes (classTyCon cls) underlying_inst_tys - -- Filter out any inferred arguments, since they can't be - -- applied with visible type application. - - mk_atf_inst :: TyCon -> TcM FamInst - mk_atf_inst fam_tc = do - rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) - rep_lhs_tys - let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs' - fam_tc rep_lhs_tys rep_rhs_ty - -- Check (c) from Note [GND and associated type families] in TcDeriv - checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom) - newFamInst SynFamilyInst axiom - where - cls_tvs = classTyVars cls - in_scope = mkInScopeSet $ mkVarSet inst_tvs - lhs_env = zipTyEnv cls_tvs inst_tys - lhs_subst = mkTvSubst in_scope lhs_env - rhs_env = zipTyEnv cls_tvs underlying_inst_tys - rhs_subst = mkTvSubst in_scope rhs_env - fam_tvs = tyConTyVars fam_tc - rep_lhs_tys = substTyVars lhs_subst fam_tvs - rep_rhs_tys = substTyVars rhs_subst fam_tvs - rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys - rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys - (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs - rep_tvs' = scopedSort rep_tvs - rep_cvs' = scopedSort rep_cvs - - -- Same as inst_tys, but with the last argument type replaced by the - -- representation type. - underlying_inst_tys :: [Type] - underlying_inst_tys = changeLast inst_tys rhs_ty - -nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty) - where - hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s) - -nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty - where - hs_ty = mkLHsSigWcType (typeToLHsType s) - -mkCoerceClassMethEqn :: Class -- the class being derived - -> [TyVar] -- the tvs in the instance head (this includes - -- the tvs from both the class types and the - -- newtype itself) - -> [Type] -- instance head parameters (incl. newtype) - -> Type -- the representation type - -> Id -- the method to look at - -> Pair Type --- See Note [Newtype-deriving instances] --- See also Note [Newtype-deriving trickiness] --- The pair is the (from_type, to_type), where to_type is --- the type of the method we are trying to get -mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id - = Pair (substTy rhs_subst user_meth_ty) - (substTy lhs_subst user_meth_ty) - where - cls_tvs = classTyVars cls - in_scope = mkInScopeSet $ mkVarSet inst_tvs - lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys) - rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty)) - (_class_tvs, _class_constraint, user_meth_ty) - = tcSplitMethodTy (varType id) - -{- -************************************************************************ -* * -\subsection{Generating extra binds (@con2tag@ and @tag2con@)} -* * -************************************************************************ - -\begin{verbatim} -data Foo ... = ... - -con2tag_Foo :: Foo ... -> Int# -tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# -maxtag_Foo :: Int -- ditto (NB: not unlifted) -\end{verbatim} - -The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) -fiddling around. --} - -genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec - -> (LHsBind GhcPs, LSig GhcPs) -genAuxBindSpec dflags loc (DerivCon2Tag tycon) - = (mkFunBindSE 0 loc rdr_name eqns, - L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) - where - rdr_name = con2tag_RDR dflags tycon - - sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ - mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ - mkParentType tycon `mkVisFunTy` intPrimTy - - lots_of_constructors = tyConFamilySize tycon > 8 - -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS - -- but we don't do vectored returns any more. - - eqns | lots_of_constructors = [get_tag_eqn] - | otherwise = map mk_eqn (tyConDataCons tycon) - - get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr) - - mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs) - mk_eqn con = ([nlWildConPat con], - nlHsLit (HsIntPrim NoSourceText - (toInteger ((dataConTag con) - fIRST_TAG)))) - -genAuxBindSpec dflags loc (DerivTag2Con tycon) - = (mkFunBindSE 0 loc rdr_name - [([nlConVarPat intDataCon_RDR [a_RDR]], - nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) - where - sig_ty = mkLHsSigWcType $ L loc $ - XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ - intTy `mkVisFunTy` mkParentType tycon - - rdr_name = tag2con_RDR dflags tycon - -genAuxBindSpec dflags loc (DerivMaxTag tycon) - = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig noExtField [L loc rdr_name] sig_ty)) - where - rdr_name = maxtag_RDR dflags tycon - sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy))) - rhs = nlHsApp (nlHsVar intDataCon_RDR) - (nlHsLit (HsIntPrim NoSourceText max_tag)) - max_tag = case (tyConDataCons tycon) of - data_cons -> toInteger ((length data_cons) - fIRST_TAG) - -type SeparateBagsDerivStuff = - -- AuxBinds and SYB bindings - ( Bag (LHsBind GhcPs, LSig GhcPs) - -- Extra family instances (used by Generic and DeriveAnyClass) - , Bag (FamInst) ) - -genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff -genAuxBinds dflags loc b = genAuxBinds' b2 where - (b1,b2) = partitionBagWith splitDerivAuxBind b - splitDerivAuxBind (DerivAuxBind x) = Left x - splitDerivAuxBind x = Right x - - rm_dups = foldr dup_check emptyBag - dup_check a b = if anyBag (== a) b then b else consBag a b - - genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff - genAuxBinds' = foldr f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1) - , emptyBag ) - f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff - f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before - f (DerivHsBind b) = add1 b - f (DerivFamInst t) = add2 t - - add1 x (a,b) = (x `consBag` a,b) - add2 x (a,b) = (a,x `consBag` b) - -mkParentType :: TyCon -> Type --- Turn the representation tycon of a family into --- a use of its family constructor -mkParentType tc - = case tyConFamInst_maybe tc of - Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc)) - Just (fam_tc,tys) -> mkTyConApp fam_tc tys - -{- -************************************************************************ -* * -\subsection{Utility bits for generating bindings} -* * -************************************************************************ --} - --- | Make a function binding. If no equations are given, produce a function --- with the given arity that produces a stock error. -mkFunBindSE :: Arity -> SrcSpan -> RdrName - -> [([LPat GhcPs], LHsExpr GhcPs)] - -> LHsBind GhcPs -mkFunBindSE arity loc fun pats_and_exprs - = mkRdrFunBindSE arity (L loc fun) matches - where - matches = [mkMatch (mkPrefixFunRhs (L loc fun)) - (map (parenthesizePat appPrec) p) e - (noLoc emptyLocalBinds) - | (p,e) <-pats_and_exprs] - -mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] - -> LHsBind GhcPs -mkRdrFunBind fun@(L loc _fun_rdr) matches - = L loc (mkFunBind Generated fun matches) - --- | Make a function binding. If no equations are given, produce a function --- with the given arity that uses an empty case expression for the last --- argument that is passes to the given function to produce the right-hand --- side. -mkFunBindEC :: Arity -> SrcSpan -> RdrName - -> (LHsExpr GhcPs -> LHsExpr GhcPs) - -> [([LPat GhcPs], LHsExpr GhcPs)] - -> LHsBind GhcPs -mkFunBindEC arity loc fun catch_all pats_and_exprs - = mkRdrFunBindEC arity catch_all (L loc fun) matches - where - matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) - (map (parenthesizePat appPrec) p) e - (noLoc emptyLocalBinds) - | (p,e) <- pats_and_exprs ] - --- | Produces a function binding. When no equations are given, it generates --- a binding of the given arity and an empty case expression --- for the last argument that it passes to the given function to produce --- the right-hand side. -mkRdrFunBindEC :: Arity - -> (LHsExpr GhcPs -> LHsExpr GhcPs) - -> Located RdrName - -> [LMatch GhcPs (LHsExpr GhcPs)] - -> LHsBind GhcPs -mkRdrFunBindEC arity catch_all - fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches') - where - -- Catch-all eqn looks like - -- fmap _ z = case z of {} - -- or - -- traverse _ z = pure (case z of) - -- or - -- foldMap _ z = mempty - -- It's needed if there no data cons at all, - -- which can happen with -XEmptyDataDecls - -- See #4302 - matches' = if null matches - then [mkMatch (mkPrefixFunRhs fun) - (replicate (arity - 1) nlWildPat ++ [z_Pat]) - (catch_all $ nlHsCase z_Expr []) - (noLoc emptyLocalBinds)] - else matches - --- | Produces a function binding. When there are no equations, it generates --- a binding with the given arity that produces an error based on the name of --- the type of the last argument. -mkRdrFunBindSE :: Arity -> Located RdrName -> - [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs -mkRdrFunBindSE arity - fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches') - where - -- Catch-all eqn looks like - -- compare _ _ = error "Void compare" - -- It's needed if there no data cons at all, - -- which can happen with -XEmptyDataDecls - -- See #4302 - matches' = if null matches - then [mkMatch (mkPrefixFunRhs fun) - (replicate arity nlWildPat) - (error_Expr str) (noLoc emptyLocalBinds)] - else matches - str = "Void " ++ occNameString (rdrNameOcc fun_rdr) - - -box :: String -- The class involved - -> LHsExpr GhcPs -- The argument - -> Type -- The argument type - -> LHsExpr GhcPs -- Boxed version of the arg --- See Note [Deriving and unboxed types] in TcDerivInfer -box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg - ---------------------- -primOrdOps :: String -- The class involved - -> Type -- The type - -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt) --- See Note [Deriving and unboxed types] in TcDerivInfer -primOrdOps str ty = assoc_ty_id str ordOpTbl ty - -ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] -ordOpTbl - = [(charPrimTy , (ltChar_RDR , leChar_RDR - , eqChar_RDR , geChar_RDR , gtChar_RDR )) - ,(intPrimTy , (ltInt_RDR , leInt_RDR - , eqInt_RDR , geInt_RDR , gtInt_RDR )) - ,(int8PrimTy , (ltInt8_RDR , leInt8_RDR - , eqInt8_RDR , geInt8_RDR , gtInt8_RDR )) - ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR - , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) - ,(wordPrimTy , (ltWord_RDR , leWord_RDR - , eqWord_RDR , geWord_RDR , gtWord_RDR )) - ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR - , eqWord8_RDR , geWord8_RDR , gtWord8_RDR )) - ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR - , eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) - ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR - , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) - ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR - , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) - ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR - , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] - --- A mapping from a primitive type to a function that constructs its boxed --- version. --- NOTE: Int8#/Word8# will become Int/Word. -boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] -boxConTbl = - [ (charPrimTy , nlHsApp (nlHsVar $ getRdrName charDataCon)) - , (intPrimTy , nlHsApp (nlHsVar $ getRdrName intDataCon)) - , (wordPrimTy , nlHsApp (nlHsVar $ getRdrName wordDataCon )) - , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon )) - , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon)) - , (int8PrimTy, - nlHsApp (nlHsVar $ getRdrName intDataCon) - . nlHsApp (nlHsVar extendInt8_RDR)) - , (word8PrimTy, - nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar extendWord8_RDR)) - , (int16PrimTy, - nlHsApp (nlHsVar $ getRdrName intDataCon) - . nlHsApp (nlHsVar extendInt16_RDR)) - , (word16PrimTy, - nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar extendWord16_RDR)) - ] - - --- | A table of postfix modifiers for unboxed values. -postfixModTbl :: [(Type, String)] -postfixModTbl - = [(charPrimTy , "#" ) - ,(intPrimTy , "#" ) - ,(wordPrimTy , "##") - ,(floatPrimTy , "#" ) - ,(doublePrimTy, "##") - ,(int8PrimTy, "#") - ,(word8PrimTy, "##") - ,(int16PrimTy, "#") - ,(word16PrimTy, "##") - ] - -primConvTbl :: [(Type, String)] -primConvTbl = - [ (int8PrimTy, "narrowInt8#") - , (word8PrimTy, "narrowWord8#") - , (int16PrimTy, "narrowInt16#") - , (word16PrimTy, "narrowWord16#") - ] - -litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] -litConTbl - = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR)) - ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR) - . nlHsApp (nlHsVar toInteger_RDR)) - ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR) - . nlHsApp (nlHsVar toInteger_RDR)) - ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR) - . nlHsApp (nlHsApp - (nlHsVar map_RDR) - (compose_RDR `nlHsApps` - [ nlHsVar fromIntegral_RDR - , nlHsVar fromEnum_RDR - ]))) - ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR) - . nlHsApp (nlHsVar toRational_RDR)) - ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR) - . nlHsApp (nlHsVar toRational_RDR)) - ] - --- | Lookup `Type` in an association list. -assoc_ty_id :: HasCallStack => String -- The class involved - -> [(Type,a)] -- The table - -> Type -- The type - -> a -- The result of the lookup -assoc_ty_id cls_str tbl ty - | Just a <- assoc_ty_id_maybe tbl ty = a - | otherwise = - pprPanic "Error in deriving:" - (text "Can't derive" <+> text cls_str <+> - text "for primitive type" <+> ppr ty) - --- | Lookup `Type` in an association list. -assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a -assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl - ------------------------------------------------------------------------ - -and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -and_Expr a b = genOpApp a and_RDR b - ------------------------------------------------------------------------ - -eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -eq_Expr ty a b - | not (isUnliftedType ty) = genOpApp a eq_RDR b - | otherwise = genPrimOpApp a prim_eq b - where - (_, _, prim_eq, _, _) = primOrdOps "Eq" ty - -untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)] - -> LHsExpr GhcPs -> LHsExpr GhcPs -untag_Expr _ _ [] expr = expr -untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr - = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon) - [untag_this])) {-of-} - [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)] - -enum_from_to_Expr - :: LHsExpr GhcPs -> LHsExpr GhcPs - -> LHsExpr GhcPs -enum_from_then_to_Expr - :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs - -> LHsExpr GhcPs - -enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2 -enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2 - -showParen_Expr - :: LHsExpr GhcPs -> LHsExpr GhcPs - -> LHsExpr GhcPs - -showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 - -nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs - -nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty -nested_compose_Expr [e] = parenify e -nested_compose_Expr (e:es) - = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es) - --- impossible_Expr is used in case RHSs that should never happen. --- We generate these to keep the desugarer from complaining that they *might* happen! -error_Expr :: String -> LHsExpr GhcPs -error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string)) - --- illegal_Expr is used when signalling error conditions in the RHS of a derived --- method. It is currently only used by Enum.{succ,pred} -illegal_Expr :: String -> String -> String -> LHsExpr GhcPs -illegal_Expr meth tp msg = - nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) - --- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you --- to include the value of a_RDR in the error string. -illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs -illegal_toEnum_tag tp maxtag = - nlHsApp (nlHsVar error_RDR) - (nlHsApp (nlHsApp (nlHsVar append_RDR) - (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag (")))) - (nlHsApp (nlHsApp (nlHsApp - (nlHsVar showsPrec_RDR) - (nlHsIntLit 0)) - (nlHsVar a_RDR)) - (nlHsApp (nlHsApp - (nlHsVar append_RDR) - (nlHsLit (mkHsString ") is outside of enumeration's range (0,"))) - (nlHsApp (nlHsApp (nlHsApp - (nlHsVar showsPrec_RDR) - (nlHsIntLit 0)) - (nlHsVar maxtag)) - (nlHsLit (mkHsString ")")))))) - -parenify :: LHsExpr GhcPs -> LHsExpr GhcPs -parenify e@(L _ (HsVar _ _)) = e -parenify e = mkHsPar e - --- genOpApp wraps brackets round the operator application, so that the --- renamer won't subsequently try to re-associate it. -genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs -genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) - -genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs -genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2)) - -a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR - :: RdrName -a_RDR = mkVarUnqual (fsLit "a") -b_RDR = mkVarUnqual (fsLit "b") -c_RDR = mkVarUnqual (fsLit "c") -d_RDR = mkVarUnqual (fsLit "d") -f_RDR = mkVarUnqual (fsLit "f") -k_RDR = mkVarUnqual (fsLit "k") -z_RDR = mkVarUnqual (fsLit "z") -ah_RDR = mkVarUnqual (fsLit "a#") -bh_RDR = mkVarUnqual (fsLit "b#") -ch_RDR = mkVarUnqual (fsLit "c#") -dh_RDR = mkVarUnqual (fsLit "d#") - -as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] -as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] -cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] - -a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, - true_Expr, pure_Expr :: LHsExpr GhcPs -a_Expr = nlHsVar a_RDR -b_Expr = nlHsVar b_RDR -c_Expr = nlHsVar c_RDR -z_Expr = nlHsVar z_RDR -ltTag_Expr = nlHsVar ltTag_RDR -eqTag_Expr = nlHsVar eqTag_RDR -gtTag_Expr = nlHsVar gtTag_RDR -false_Expr = nlHsVar false_RDR -true_Expr = nlHsVar true_RDR -pure_Expr = nlHsVar pure_RDR - -a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs -a_Pat = nlVarPat a_RDR -b_Pat = nlVarPat b_RDR -c_Pat = nlVarPat c_RDR -d_Pat = nlVarPat d_RDR -k_Pat = nlVarPat k_RDR -z_Pat = nlVarPat z_RDR - -minusInt_RDR, tagToEnum_RDR :: RdrName -minusInt_RDR = getRdrName (primOpId IntSubOp ) -tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) - -con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName --- Generates Orig s RdrName, for the binding positions -con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc -tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc -maxtag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc - -mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName -mk_tc_deriv_name dflags tycon occ_fun = - mkAuxBinderName dflags (tyConName tycon) occ_fun - -mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName --- ^ Make a top-level binder name for an auxiliary binding for a parent name --- See Note [Auxiliary binders] -mkAuxBinderName dflags parent occ_fun - = mkRdrUnqual (occ_fun stable_parent_occ) - where - stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string - stable_string - | hasPprDebug dflags = parent_stable - | otherwise = parent_stable_hash - parent_stable = nameStableString parent - parent_stable_hash = - let Fingerprint high low = fingerprintString parent_stable - in toBase62 high ++ toBase62Padded low - -- See Note [Base 62 encoding 128-bit integers] in Encoding - parent_occ = nameOccName parent - - -{- -Note [Auxiliary binders] -~~~~~~~~~~~~~~~~~~~~~~~~ -We often want to make a top-level auxiliary binding. E.g. for comparison we have - - instance Ord T where - compare a b = $con2tag a `compare` $con2tag b - - $con2tag :: T -> Int - $con2tag = ...code.... - -Of course these top-level bindings should all have distinct name, and we are -generating RdrNames here. We can't just use the TyCon or DataCon to distinguish -because with standalone deriving two imported TyCons might both be called T! -(See #7947.) - -So we use package name, module name and the name of the parent -(T in this example) as part of the OccName we generate for the new binding. -To make the symbol names short we take a base62 hash of the full name. - -In the past we used the *unique* from the parent, but that's not stable across -recompilations as uniques are nondeterministic. --} diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs deleted file mode 100644 index c326754b20..0000000000 --- a/compiler/typecheck/TcGenFunctor.hs +++ /dev/null @@ -1,1440 +0,0 @@ -{- -(c) The University of Glasgow 2011 - - -The deriving code for the Functor, Foldable, and Traversable classes -(equivalent to the code in TcGenDeriv, for other classes) --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - -module TcGenFunctor ( - FFoldType(..), functorLikeTraverse, - deepSubtypesContaining, foldDataConArgs, - - gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Bag -import GHC.Core.DataCon -import FastString -import GHC.Hs -import Outputable -import PrelNames -import GHC.Types.Name.Reader -import GHC.Types.SrcLoc -import State -import TcGenDeriv -import TcType -import GHC.Core.TyCon -import GHC.Core.TyCo.Rep -import GHC.Core.Type -import Util -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Id.Make (coerceId) -import TysWiredIn (true_RDR, false_RDR) - -import Data.Maybe (catMaybes, isJust) - -{- -************************************************************************ -* * - Functor instances - - see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html - -* * -************************************************************************ - -For the data type: - - data T a = T1 Int a | T2 (T a) - -We generate the instance: - - instance Functor T where - fmap f (T1 b1 a) = T1 b1 (f a) - fmap f (T2 ta) = T2 (fmap f ta) - -Notice that we don't simply apply 'fmap' to the constructor arguments. -Rather - - Do nothing to an argument whose type doesn't mention 'a' - - Apply 'f' to an argument of type 'a' - - Apply 'fmap f' to other arguments -That's why we have to recurse deeply into the constructor argument types, -rather than just one level, as we typically do. - -What about types with more than one type parameter? In general, we only -derive Functor for the last position: - - data S a b = S1 [b] | S2 (a, T a b) - instance Functor (S a) where - fmap f (S1 bs) = S1 (fmap f bs) - fmap f (S2 (p,q)) = S2 (a, fmap f q) - -However, we have special cases for - - tuples - - functions - -More formally, we write the derivation of fmap code over type variable -'a for type 'b as ($fmap 'a 'b x). In this general notation the derived -instance for T is: - - instance Functor T where - fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2) - fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1) - - $(fmap 'a 'b x) = x -- when b does not contain a - $(fmap 'a 'a x) = f x - $(fmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(fmap 'a 'b1 x1), $(fmap 'a 'b2 x2)) - $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T - $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - $(fmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(fmap 'a' 'tc' (x $(cofmap 'a 'tb y))) - -For functions, the type parameter 'a can occur in a contravariant position, -which means we need to derive a function like: - - cofmap :: (a -> b) -> (f b -> f a) - -This is pretty much the same as $fmap, only without the $(cofmap 'a 'a x) and -$(cofmap 'a '(T b1 a) x) cases: - - $(cofmap 'a 'b x) = x -- when b does not contain a - $(cofmap 'a 'a x) = error "type variable in contravariant position" - $(cofmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2) - $(cofmap 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T - $(cofmap 'a '(T b1 b2) x) = fmap (\y. $(cofmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - $(cofmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(cofmap 'a' 'tc' (x $(fmap 'a 'tb y))) - -Note that the code produced by $(fmap _ _ _) is always a higher order function, -with type `(a -> b) -> (g a -> g b)` for some g. - -Note that there are two distinct cases in $fmap (and $cofmap) that match on an -application of some type constructor T (where T is not a tuple type -constructor): - - $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T - $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - -While the latter case technically subsumes the former case, it is important to -give special treatment to the former case to avoid unnecessary eta expansion. -See Note [Avoid unnecessary eta expansion in derived fmap implementations]. - -We also generate code for (<$) in addition to fmap—see Note [Deriving <$] for -an explanation of why this is important. Just like $fmap/$cofmap above, there -is a similar algorithm for generating `p <$ x` (for some constant `p`): - - $(replace 'a 'b x) = x -- when b does not contain a - $(replace 'a 'a x) = p - $(replace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(replace 'a 'b1 x1), $(replace 'a 'b2 x2)) - $(replace 'a '(T b1 a) x) = p <$ x -- when a only occurs directly as the last argument of T - $(replace 'a '(T b1 b2) x) = fmap (\y. $(replace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - $(replace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(replace 'a' 'tc' (x $(coreplace 'a 'tb y))) - - $(coreplace 'a 'b x) = x -- when b does not contain a - $(coreplace 'a 'a x) = error "type variable in contravariant position" - $(coreplace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(coreplace 'a 'b1 x1), $(coreplace 'a 'b2 x2)) - $(coreplace 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T - $(coreplace 'a '(T b1 b2) x) = fmap (\y. $(coreplace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) --} - -gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) --- When the argument is phantom, we can use fmap _ = coerce --- See Note [Phantom types with Functor, Foldable, and Traversable] -gen_Functor_binds loc tycon - | Phantom <- last (tyConRoles tycon) - = (unitBag fmap_bind, emptyBag) - where - fmap_name = L loc fmap_RDR - fmap_bind = mkRdrFunBind fmap_name fmap_eqns - fmap_eqns = [mkSimpleMatch fmap_match_ctxt - [nlWildPat] - coerce_Expr] - fmap_match_ctxt = mkPrefixFunRhs fmap_name - -gen_Functor_binds loc tycon - = (listToBag [fmap_bind, replace_bind], emptyBag) - where - data_cons = tyConDataCons tycon - fmap_name = L loc fmap_RDR - - -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] - fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns - fmap_match_ctxt = mkPrefixFunRhs fmap_name - - fmap_eqn con = flip evalState bs_RDRs $ - match_for_con fmap_match_ctxt [f_Pat] con parts - where - parts = foldDataConArgs ft_fmap con - - fmap_eqns = map fmap_eqn data_cons - - ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) - ft_fmap = FT { ft_triv = \x -> pure x - -- fmap f x = x - , ft_var = \x -> pure $ nlHsApp f_Expr x - -- fmap f x = f x - , ft_fun = \g h x -> mkSimpleLam $ \b -> do - gg <- g b - h $ nlHsApp x gg - -- fmap f x = \b -> h (x (g b)) - , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt) - -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) - , ft_ty_app = \_ arg_ty g x -> - -- If the argument type is a bare occurrence of the - -- data type's last type variable, then we can generate - -- more efficient code. - -- See Note [Avoid unnecessary eta expansion in derived fmap implementations] - if tcIsTyVarTy arg_ty - then pure $ nlHsApps fmap_RDR [f_Expr,x] - else do gg <- mkSimpleLam g - pure $ nlHsApps fmap_RDR [gg,x] - -- fmap f x = fmap g x - , ft_forall = \_ g x -> g x - , ft_bad_app = panic "in other argument in ft_fmap" - , ft_co_var = panic "contravariant in ft_fmap" } - - -- See Note [Deriving <$] - replace_name = L loc replace_RDR - - -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] - replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns - replace_match_ctxt = mkPrefixFunRhs replace_name - - replace_eqn con = flip evalState bs_RDRs $ - match_for_con replace_match_ctxt [z_Pat] con parts - where - parts = foldDataConArgs ft_replace con - - replace_eqns = map replace_eqn data_cons - - ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) - ft_replace = FT { ft_triv = \x -> pure x - -- p <$ x = x - , ft_var = \_ -> pure z_Expr - -- p <$ _ = p - , ft_fun = \g h x -> mkSimpleLam $ \b -> do - gg <- g b - h $ nlHsApp x gg - -- p <$ x = \b -> h (x (g b)) - , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt) - -- p <$ x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) - , ft_ty_app = \_ arg_ty g x -> - -- If the argument type is a bare occurrence of the - -- data type's last type variable, then we can generate - -- more efficient code. - -- See [Deriving <$] - if tcIsTyVarTy arg_ty - then pure $ nlHsApps replace_RDR [z_Expr,x] - else do gg <- mkSimpleLam g - pure $ nlHsApps fmap_RDR [gg,x] - -- p <$ x = fmap (p <$) x - , ft_forall = \_ g x -> g x - , ft_bad_app = panic "in other argument in ft_replace" - , ft_co_var = panic "contravariant in ft_replace" } - - -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... - match_for_con :: Monad m - => HsMatchContext GhcPs - -> [LPat GhcPs] -> DataCon - -> [LHsExpr GhcPs -> m (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_for_con ctxt = mkSimpleConMatch ctxt $ - \con_name xsM -> do xs <- sequence xsM - pure $ nlHsApps con_name xs -- Con x1 x2 .. - -{- -Note [Avoid unnecessary eta expansion in derived fmap implementations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the sake of simplicity, the algorithm that derived implementations of -fmap used to have a single case that dealt with applications of some type -constructor T (where T is not a tuple type constructor): - - $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - -This generated less than optimal code in certain situations, however. Consider -this example: - - data List a = Nil | Cons a (List a) deriving Functor - -This would generate the following Functor instance: - - instance Functor List where - fmap f Nil = Nil - fmap f (Cons x xs) = Cons (f x) (fmap (\y -> f y) xs) - -The code `fmap (\y -> f y) xs` is peculiar, since it eta expands an application -of `f`. What's worse, this eta expansion actually degrades performance! To see -why, we can trace an invocation of fmap on a small List: - - fmap id $ Cons 0 $ Cons 0 $ Cons 0 $ Cons 0 Nil - - Cons (id 0) $ fmap (\y -> id y) - $ Cons 0 $ Cons 0 $ Cons 0 Nil - - Cons (id 0) $ Cons ((\y -> id y) 0) - $ fmap (\y' -> (\y -> id y) y') - $ Cons 0 $ Cons 0 Nil - - Cons (id 0) $ Cons ((\y -> id y) 0) - $ Cons ((\y' -> (\y -> id y) y') 0) - $ fmap (\y'' -> (\y' -> (\y -> id y) y') y'') - $ Cons 0 Nil - - Cons (id 0) $ Cons ((\y -> id y) 0) - $ Cons ((\y' -> (\y -> id y) y') 0) - $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0) - $ fmap (\y''' -> (\y'' -> (\y' -> (\y -> id y) y') y'') y''') - $ Nil - - Cons (id 0) $ Cons ((\y -> id y) 0) - $ Cons ((\y' -> (\y -> id y) y') 0) - $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0) - $ Nil - -Notice how the number of lambdas—and hence, the number of closures—one -needs to evaluate grows very quickly. In general, a List with N cons cells will -require (1 + 2 + ... (N-1)) beta reductions, which takes O(N^2) time! This is -what caused the performance issues observed in #7436. - -But hold on a second: shouldn't GHC's optimizer be able to eta reduce -`\y -> f y` to `f` and avoid these beta reductions? Unfortunately, this is not -the case. In general, eta reduction can change the semantics of a program. For -instance, (\x -> ⊥) `seq` () converges, but ⊥ `seq` () diverges. It just so -happens that the fmap implementation above would have the same semantics -regardless of whether or not `\y -> f y` or `f` is used, but GHC's optimizer is -not yet smart enough to realize this (see #17881). - -To avoid this quadratic blowup, we add a special case to $fmap that applies -`fmap f` directly: - - $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T - $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 - -With this modified algorithm, the derived Functor List instance becomes: - - instance Functor List where - fmap f Nil = Nil - fmap f (Cons x xs) = Cons (f x) (fmap f xs) - -No lambdas in sight, just the way we like it. - -This special case does not prevent all sources quadratic closure buildup, -however. In this example: - - data PolyList a = PLNil | PLCons a (PolyList (PolyList a)) - deriving Functor - -We would derive the following code: - - instance Functor PolyList where - fmap f PLNil = PLNil - fmap f (PLCons x xs) = PLCons (f x) (fmap (\y -> fmap f y) xs) - -The use of `fmap (\y -> fmap f y) xs` builds up closures in much the same way -as `fmap (\y -> f y) xs`. The difference here is that even if we eta reduced -to `fmap (fmap f) xs`, GHC would /still/ build up a closure, since we are -recursively invoking fmap with a different argument (fmap f). Since we end up -paying the price of building a closure either way, we do not extend the special -case in $fmap any further, since it wouldn't buy us anything. - -The ft_ty_app field of FFoldType distinguishes between these two $fmap cases by -inspecting the argument type. If the argument type is a bare type variable, -then we can conclude the type variable /must/ be the same as the data type's -last type parameter. We know that this must be the case since there is an -invariant that the argument type in ft_ty_app will always contain the last -type parameter somewhere (see Note [FFoldType and functorLikeTraverse]), so -if the argument type is a bare variable, then that must be exactly the last -type parameter. - -Note that the ft_ty_app case of ft_replace (which derives implementations of -(<$)) also inspects the argument type to generate more efficient code. -See Note [Deriving <$]. - -Note [Deriving <$] -~~~~~~~~~~~~~~~~~~ - -We derive the definition of <$. Allowing this to take the default definition -can lead to memory leaks: mapping over a structure with a constant function can -fill the result structure with trivial thunks that retain the values from the -original structure. The simplifier seems to handle this all right for simple -types, but not for recursive ones. Consider - -data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor - --- fmap _ Tip = Tip --- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r) - -Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that -simplifies no further. Why is that? `fmap` is defined recursively, so GHC -cannot inline it. The static argument transformation would turn the definition -into a non-recursive one - --- fmap f = go where --- go Tip = Tip --- go (Bin l v r) = Bin (go l) (f v) (go r) - -which GHC could inline, producing an efficient definion of `<$`. But there are -several problems. First, GHC does not perform the static argument transformation -by default, even with -O2. Second, even when it does perform the static argument -transformation, it does so only when there are at least two static arguments, -which is not the case for fmap. Finally, when the type in question is -non-regular, such as - -data Nesty a = Z a | S (Nesty a) (Nest (a, a)) - -the function argument is no longer (entirely) static, so the static argument -transformation will do nothing for us. - -Applying the default definition of `<$` will produce a tree full of thunks that -look like ((\_ -> x) x0), which represents unnecessary thunk allocation and -also retention of the previous value, potentially leaking memory. Instead, we -derive <$ separately. Two aspects are different from fmap: the case of the -sought type variable (ft_var) and the case of a type application (ft_ty_app). -The interesting one is ft_ty_app. We have to distinguish two cases: the -"immediate" case where the type argument *is* the sought type variable, and -the "nested" case where the type argument *contains* the sought type variable. - -The immediate case: - -Suppose we have - -data Imm a = Imm (F ... a) - -Then we want to define - -x <$ Imm q = Imm (x <$ q) - -The nested case: - -Suppose we have - -data Nes a = Nes (F ... (G a)) - -Then we want to define - -x <$ Nes q = Nes (fmap (x <$) q) - -We inspect the argument type in ft_ty_app -(see Note [FFoldType and functorLikeTraverse]) to distinguish between these -two cases. If the argument type is a bare type variable, then we know that it -must be the same variable as the data type's last type parameter. -This is very similar to a trick that derived fmap implementations -use in their own ft_ty_app case. -See Note [Avoid unnecessary eta expansion in derived fmap implementations], -which explains why checking if the argument type is a bare variable is -the right thing to do. - -We could, but do not, give tuples special treatment to improve efficiency -in some cases. Suppose we have - -data Nest a = Z a | S (Nest (a,a)) - -The optimal definition would be - -x <$ Z _ = Z x -x <$ S t = S ((x, x) <$ t) - -which produces a result with maximal internal sharing. The reason we do not -attempt to treat this case specially is that we have no way to give -user-provided tuple-like types similar treatment. If the user changed the -definition to - -data Pair a = Pair a a -data Nest a = Z a | S (Nest (Pair a)) - -they would experience a surprising degradation in performance. -} - - -{- -Utility functions related to Functor deriving. - -Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse. -This function works like a fold: it makes a value of type 'a' in a bottom up way. --} - --- Generic traversal for Functor deriving --- See Note [FFoldType and functorLikeTraverse] -data FFoldType a -- Describes how to fold over a Type in a functor like way - = FT { ft_triv :: a - -- ^ Does not contain variable - , ft_var :: a - -- ^ The variable itself - , ft_co_var :: a - -- ^ The variable itself, contravariantly - , ft_fun :: a -> a -> a - -- ^ Function type - , ft_tup :: TyCon -> [a] -> a - -- ^ Tuple type. The @[a]@ is the result of folding over the - -- arguments of the tuple. - , ft_ty_app :: Type -> Type -> a -> a - -- ^ Type app, variable only in last argument. The two 'Type's are - -- the function and argument parts of @fun_ty arg_ty@, - -- respectively. - , ft_bad_app :: a - -- ^ Type app, variable other than in last argument - , ft_forall :: TcTyVar -> a -> a - -- ^ Forall type - } - -functorLikeTraverse :: forall a. - TyVar -- ^ Variable to look for - -> FFoldType a -- ^ How to fold - -> Type -- ^ Type to process - -> a -functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar - , ft_co_var = caseCoVar, ft_fun = caseFun - , ft_tup = caseTuple, ft_ty_app = caseTyApp - , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) - ty - = fst (go False ty) - where - go :: Bool -- Covariant or contravariant context - -> Type - -> (a, Bool) -- (result of type a, does type contain var) - - go co ty | Just ty' <- tcView ty = go co ty' - go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) - go co (FunTy { ft_arg = x, ft_res = y, ft_af = af }) - | InvisArg <- af = go co y - | xc || yc = (caseFun xr yr,True) - where (xr,xc) = go (not co) x - (yr,yc) = go co y - go co (AppTy x y) | xc = (caseWrongArg, True) - | yc = (caseTyApp x y yr, True) - where (_, xc) = go co x - (yr,yc) = go co y - go co ty@(TyConApp con args) - | not (or xcs) = (caseTrivial, False) -- Variable does not occur - -- At this point we know that xrs, xcs is not empty, - -- and at least one xr is True - | isTupleTyCon con = (caseTuple con xrs, True) - | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty - | Just (fun_ty, arg_ty) <- splitAppTy_maybe ty -- T (..no var..) ty - = (caseTyApp fun_ty arg_ty (last xrs), True) - | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function) - where - -- When folding over an unboxed tuple, we must explicitly drop the - -- runtime rep arguments, or else GHC will generate twice as many - -- variables in a unboxed tuple pattern match and expression as it - -- actually needs. See #12399 - (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args)) - go co (ForAllTy (Bndr v vis) x) - | isVisibleArgFlag vis = panic "unexpected visible binder" - | v /= var && xc = (caseForAll v xr,True) - where (xr,xc) = go co x - - go _ _ = (caseTrivial,False) - --- Return all syntactic subterms of ty that contain var somewhere --- These are the things that should appear in instance constraints -deepSubtypesContaining :: TyVar -> Type -> [TcType] -deepSubtypesContaining tv - = functorLikeTraverse tv - (FT { ft_triv = [] - , ft_var = [] - , ft_fun = (++) - , ft_tup = \_ xs -> concat xs - , ft_ty_app = \t _ ts -> t:ts - , ft_bad_app = panic "in other argument in deepSubtypesContaining" - , ft_co_var = panic "contravariant in deepSubtypesContaining" - , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs }) - - -foldDataConArgs :: FFoldType a -> DataCon -> [a] --- Fold over the arguments of the datacon -foldDataConArgs ft con - = map foldArg (dataConOrigArgTys con) - where - foldArg - = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of - Just tv -> functorLikeTraverse tv ft - Nothing -> const (ft_triv ft) - -- If we are deriving Foldable for a GADT, there is a chance that the last - -- type variable in the data type isn't actually a type variable at all. - -- (for example, this can happen if the last type variable is refined to - -- be a concrete type such as Int). If the last type variable is refined - -- to be a specific type, then getTyVar_maybe will return Nothing. - -- See Note [DeriveFoldable with ExistentialQuantification] - -- - -- The kind checks have ensured the last type parameter is of kind *. - --- Make a HsLam using a fresh variable from a State monad -mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) - -> State [RdrName] (LHsExpr GhcPs) --- (mkSimpleLam fn) returns (\x. fn(x)) -mkSimpleLam lam = - get >>= \case - n:names -> do - put names - body <- lam (nlHsVar n) - return (mkHsLam [nlVarPat n] body) - _ -> panic "mkSimpleLam" - -mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs - -> State [RdrName] (LHsExpr GhcPs)) - -> State [RdrName] (LHsExpr GhcPs) -mkSimpleLam2 lam = - get >>= \case - n1:n2:names -> do - put names - body <- lam (nlHsVar n1) (nlHsVar n2) - return (mkHsLam [nlVarPat n1,nlVarPat n2] body) - _ -> panic "mkSimpleLam2" - --- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --- --- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in --- which the LHS pattern-matches on @extra_pats@, followed by a match on the --- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ --- and its arguments, applying an expression (from @insides@) to each of the --- respective arguments of @con@. -mkSimpleConMatch :: Monad m => HsMatchContext GhcPs - -> (RdrName -> [a] -> m (LHsExpr GhcPs)) - -> [LPat GhcPs] - -> DataCon - -> [LHsExpr GhcPs -> a] - -> m (LMatch GhcPs (LHsExpr GhcPs)) -mkSimpleConMatch ctxt fold extra_pats con insides = do - let con_name = getRdrName con - let vars_needed = takeList insides as_RDRs - let bare_pat = nlConVarPat con_name vars_needed - let pat = if null vars_needed - then bare_pat - else nlParPat bare_pat - rhs <- fold con_name - (zipWith (\i v -> i $ nlHsVar v) insides vars_needed) - return $ mkMatch ctxt (extra_pats ++ [pat]) rhs - (noLoc emptyLocalBinds) - --- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" --- --- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to --- 'mkSimpleConMatch', with two key differences: --- --- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a --- @[LHsExpr RdrName]@. This is because it filters out the expressions --- corresponding to arguments whose types do not mention the last type --- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the --- 'Nothing' elements of @insides@). --- --- 2. @fold@ takes an expression as its first argument instead of a --- constructor name. This is because it uses a specialized --- constructor function expression that only takes as many parameters as --- there are argument types that mention the last type variable. --- --- See Note [Generated code for DeriveFoldable and DeriveTraversable] -mkSimpleConMatch2 :: Monad m - => HsMatchContext GhcPs - -> (LHsExpr GhcPs -> [LHsExpr GhcPs] - -> m (LHsExpr GhcPs)) - -> [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) -mkSimpleConMatch2 ctxt fold extra_pats con insides = do - let con_name = getRdrName con - vars_needed = takeList insides as_RDRs - pat = nlConVarPat con_name vars_needed - -- Make sure to zip BEFORE invoking catMaybes. We want the variable - -- indices in each expression to match up with the argument indices - -- in con_expr (defined below). - exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i) - insides vars_needed - -- An element of argTysTyVarInfo is True if the constructor argument - -- with the same index has a type which mentions the last type - -- variable. - argTysTyVarInfo = map isJust insides - (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars - - con_expr - | null asWithTyVar = nlHsApps con_name asWithoutTyVar - | otherwise = - let bs = filterByList argTysTyVarInfo bs_RDRs - vars = filterByLists argTysTyVarInfo bs_Vars as_Vars - in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars) - - rhs <- fold con_expr exps - return $ mkMatch ctxt (extra_pats ++ [pat]) rhs - (noLoc emptyLocalBinds) - --- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" -mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a] - -> m (LMatch GhcPs (LHsExpr GhcPs))) - -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs) -mkSimpleTupleCase match_for_con tc insides x - = do { let data_con = tyConSingleDataCon tc - ; match <- match_for_con [] data_con insides - ; return $ nlHsCase x [match] } - -{- -************************************************************************ -* * - Foldable instances - - see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html - -* * -************************************************************************ - -Deriving Foldable instances works the same way as Functor instances, -only Foldable instances are not possible for function types at all. -Given (data T a = T a a (T a) deriving Foldable), we get: - - instance Foldable T where - foldr f z (T x1 x2 x3) = - $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) ) - --XDeriveFoldable is different from -XDeriveFunctor in that it filters out -arguments to the constructor that would produce useless code in a Foldable -instance. For example, the following datatype: - - data Foo a = Foo Int a Int deriving Foldable - -would have the following generated Foldable instance: - - instance Foldable Foo where - foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2 - -since neither of the two Int arguments are folded over. - -The cases are: - - $(foldr 'a 'a) = f - $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z ) - $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2 - -Note that the arguments to the real foldr function are the wrong way around, -since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). - -One can envision a case for types that don't contain the last type variable: - - $(foldr 'a 'b) = \x z -> z -- when b does not contain a - -But this case will never materialize, since the aforementioned filtering -removes all such types from consideration. -See Note [Generated code for DeriveFoldable and DeriveTraversable]. - -Foldable instances differ from Functor and Traversable instances in that -Foldable instances can be derived for data types in which the last type -variable is existentially quantified. In particular, if the last type variable -is refined to a more specific type in a GADT: - - data GADT a where - G :: a ~ Int => a -> G Int - -then the deriving machinery does not attempt to check that the type a contains -Int, since it is not syntactically equal to a type variable. That is, the -derived Foldable instance for GADT is: - - instance Foldable GADT where - foldr _ z (GADT _) = z - -See Note [DeriveFoldable with ExistentialQuantification]. - -Note [Deriving null] -~~~~~~~~~~~~~~~~~~~~ - -In some cases, deriving the definition of 'null' can produce much better -results than the default definition. For example, with - - data SnocList a = Nil | Snoc (SnocList a) a - -the default definition of 'null' would walk the entire spine of a -nonempty snoc-list before concluding that it is not null. But looking at -the Snoc constructor, we can immediately see that it contains an 'a', and -so 'null' can return False immediately if it matches on Snoc. When we -derive 'null', we keep track of things that cannot be null. The interesting -case is type application. Given - - data Wrap a = Wrap (Foo (Bar a)) - -we use - - null (Wrap fba) = all null fba - -but if we see - - data Wrap a = Wrap (Foo a) - -we can just use - - null (Wrap fa) = null fa - -Indeed, we allow this to happen even for tuples: - - data Wrap a = Wrap (Foo (a, Int)) - -produces - - null (Wrap fa) = null fa - -As explained in Note [Deriving <$], giving tuples special performance treatment -could surprise users if they switch to other types, but Ryan Scott seems to -think it's okay to do it for now. --} - -gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) --- When the parameter is phantom, we can use foldMap _ _ = mempty --- See Note [Phantom types with Functor, Foldable, and Traversable] -gen_Foldable_binds loc tycon - | Phantom <- last (tyConRoles tycon) - = (unitBag foldMap_bind, emptyBag) - where - foldMap_name = L loc foldMap_RDR - foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns - foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt - [nlWildPat, nlWildPat] - mempty_Expr] - foldMap_match_ctxt = mkPrefixFunRhs foldMap_name - -gen_Foldable_binds loc tycon - | null data_cons -- There's no real point producing anything but - -- foldMap for a type with no constructors. - = (unitBag foldMap_bind, emptyBag) - - | otherwise - = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag) - where - data_cons = tyConDataCons tycon - - foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns - eqns = map foldr_eqn data_cons - foldr_eqn con - = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs - where - parts = sequence $ foldDataConArgs ft_foldr con - - foldMap_name = L loc foldMap_RDR - - -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] - foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr) - foldMap_name foldMap_eqns - - foldMap_eqns = map foldMap_eqn data_cons - - foldMap_eqn con - = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs - where - parts = sequence $ foldDataConArgs ft_foldMap con - - -- Given a list of NullM results, produce Nothing if any of - -- them is NotNull, and otherwise produce a list of Maybes - -- with Justs representing unknowns and Nothings representing - -- things that are definitely null. - convert :: [NullM a] -> Maybe [Maybe a] - convert = traverse go where - go IsNull = Just Nothing - go NotNull = Nothing - go (NullM a) = Just (Just a) - - null_name = L loc null_RDR - null_match_ctxt = mkPrefixFunRhs null_name - null_bind = mkRdrFunBind null_name null_eqns - null_eqns = map null_eqn data_cons - null_eqn con - = flip evalState bs_RDRs $ do - parts <- sequence $ foldDataConArgs ft_null con - case convert parts of - Nothing -> return $ - mkMatch null_match_ctxt [nlParPat (nlWildConPat con)] - false_Expr (noLoc emptyLocalBinds) - Just cp -> match_null [] con cp - - -- Yields 'Just' an expression if we're folding over a type that mentions - -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. - -- See Note [FFoldType and functorLikeTraverse] - ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) - ft_foldr - = FT { ft_triv = return Nothing - -- foldr f = \x z -> z - , ft_var = return $ Just f_Expr - -- foldr f = f - , ft_tup = \t g -> do - gg <- sequence g - lam <- mkSimpleLam2 $ \x z -> - mkSimpleTupleCase (match_foldr z) t gg x - return (Just lam) - -- foldr f = (\x z -> case x of ...) - , ft_ty_app = \_ _ g -> do - gg <- g - mapM (\gg' -> mkSimpleLam2 $ \x z -> return $ - nlHsApps foldable_foldr_RDR [gg',z,x]) gg - -- foldr f = (\x z -> foldr g z x) - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant in ft_foldr" - , ft_fun = panic "function in ft_foldr" - , ft_bad_app = panic "in other argument in ft_foldr" } - - match_foldr :: Monad m - => LHsExpr GhcPs - -> [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs) - where - -- g1 v1 (g2 v2 (.. z)) - mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs - mkFoldr = foldr nlHsApp z - - -- See Note [FFoldType and functorLikeTraverse] - ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) - ft_foldMap - = FT { ft_triv = return Nothing - -- foldMap f = \x -> mempty - , ft_var = return (Just f_Expr) - -- foldMap f = f - , ft_tup = \t g -> do - gg <- sequence g - lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg - return (Just lam) - -- foldMap f = \x -> case x of (..,) - , ft_ty_app = \_ _ g -> fmap (nlHsApp foldMap_Expr) <$> g - -- foldMap f = foldMap g - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant in ft_foldMap" - , ft_fun = panic "function in ft_foldMap" - , ft_bad_app = panic "in other argument in ft_foldMap" } - - match_foldMap :: Monad m - => [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs) - where - -- mappend v1 (mappend v2 ..) - mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs - mkFoldMap [] = mempty_Expr - mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs - - -- See Note [FFoldType and functorLikeTraverse] - -- Yields NullM an expression if we're folding over an expression - -- that may or may not be null. Yields IsNull if it's certainly - -- null, and yields NotNull if it's certainly not null. - -- See Note [Deriving null] - ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs))) - ft_null - = FT { ft_triv = return IsNull - -- null = \_ -> True - , ft_var = return NotNull - -- null = \_ -> False - , ft_tup = \t g -> do - gg <- sequence g - case convert gg of - Nothing -> pure NotNull - Just ggg -> - NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg) - -- null = \x -> case x of (..,) - , ft_ty_app = \_ _ g -> flip fmap g $ \nestedResult -> - case nestedResult of - -- If e definitely contains the parameter, - -- then we can test if (G e) contains it by - -- simply checking if (G e) is null - NotNull -> NullM null_Expr - -- This case is unreachable--it will actually be - -- caught by ft_triv - IsNull -> IsNull - -- The general case uses (all null), - -- (all (all null)), etc. - NullM nestedTest -> NullM $ - nlHsApp all_Expr nestedTest - -- null fa = null fa, or null fa = all null fa, or null fa = True - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant in ft_null" - , ft_fun = panic "function in ft_null" - , ft_bad_app = panic "in other argument in ft_null" } - - match_null :: Monad m - => [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs) - where - -- v1 && v2 && .. - mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs - mkNull [] = true_Expr - mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs - -data NullM a = - IsNull -- Definitely null - | NotNull -- Definitely not null - | NullM a -- Unknown - -{- -************************************************************************ -* * - Traversable instances - - see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html -* * -************************************************************************ - -Again, Traversable is much like Functor and Foldable. - -The cases are: - - $(traverse 'a 'a) = f - $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> - liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2) - $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2 - -Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types -do not mention the last type parameter. Therefore, the following datatype: - - data Foo a = Foo Int a Int - -would have the following derived Traversable instance: - - instance Traversable Foo where - traverse f (Foo x1 x2 x3) = - fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 ) - -since the two Int arguments do not produce any effects in a traversal. - -One can envision a case for types that do not mention the last type parameter: - - $(traverse 'a 'b) = pure -- when b does not contain a - -But this case will never materialize, since the aforementioned filtering -removes all such types from consideration. -See Note [Generated code for DeriveFoldable and DeriveTraversable]. --} - -gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) --- When the argument is phantom, we can use traverse = pure . coerce --- See Note [Phantom types with Functor, Foldable, and Traversable] -gen_Traversable_binds loc tycon - | Phantom <- last (tyConRoles tycon) - = (unitBag traverse_bind, emptyBag) - where - traverse_name = L loc traverse_RDR - traverse_bind = mkRdrFunBind traverse_name traverse_eqns - traverse_eqns = - [mkSimpleMatch traverse_match_ctxt - [nlWildPat, z_Pat] - (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])] - traverse_match_ctxt = mkPrefixFunRhs traverse_name - -gen_Traversable_binds loc tycon - = (unitBag traverse_bind, emptyBag) - where - data_cons = tyConDataCons tycon - - traverse_name = L loc traverse_RDR - - -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] - traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr) - traverse_name traverse_eqns - traverse_eqns = map traverse_eqn data_cons - traverse_eqn con - = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs - where - parts = sequence $ foldDataConArgs ft_trav con - - -- Yields 'Just' an expression if we're folding over a type that mentions - -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. - -- See Note [FFoldType and functorLikeTraverse] - ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) - ft_trav - = FT { ft_triv = return Nothing - -- traverse f = pure x - , ft_var = return (Just f_Expr) - -- traverse f = f x - , ft_tup = \t gs -> do - gg <- sequence gs - lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg - return (Just lam) - -- traverse f = \x -> case x of (a1,a2,..) -> - -- liftA2 (,,) (g1 a1) (g2 a2) <*> .. - , ft_ty_app = \_ _ g -> fmap (nlHsApp traverse_Expr) <$> g - -- traverse f = traverse g - , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant in ft_trav" - , ft_fun = panic "function in ft_trav" - , ft_bad_app = panic "in other argument in ft_trav" } - - -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) - -- (g2 a2) <*> ... - match_for_con :: Monad m - => [LPat GhcPs] - -> DataCon - -> [Maybe (LHsExpr GhcPs)] - -> m (LMatch GhcPs (LHsExpr GhcPs)) - match_for_con = mkSimpleConMatch2 CaseAlt $ - \con xs -> return (mkApCon con xs) - where - -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. - mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs - mkApCon con [] = nlHsApps pure_RDR [con] - mkApCon con [x] = nlHsApps fmap_RDR [con,x] - mkApCon con (x1:x2:xs) = - foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs - where appAp x y = nlHsApps ap_RDR [x,y] - ------------------------------------------------------------------------ - -f_Expr, z_Expr, mempty_Expr, foldMap_Expr, - traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr, - all_Expr, null_Expr :: LHsExpr GhcPs -f_Expr = nlHsVar f_RDR -z_Expr = nlHsVar z_RDR -mempty_Expr = nlHsVar mempty_RDR -foldMap_Expr = nlHsVar foldMap_RDR -traverse_Expr = nlHsVar traverse_RDR -coerce_Expr = nlHsVar (getRdrName coerceId) -pure_Expr = nlHsVar pure_RDR -true_Expr = nlHsVar true_RDR -false_Expr = nlHsVar false_RDR -all_Expr = nlHsVar all_RDR -null_Expr = nlHsVar null_RDR - -f_RDR, z_RDR :: RdrName -f_RDR = mkVarUnqual (fsLit "f") -z_RDR = mkVarUnqual (fsLit "z") - -as_RDRs, bs_RDRs :: [RdrName] -as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] - -as_Vars, bs_Vars :: [LHsExpr GhcPs] -as_Vars = map nlHsVar as_RDRs -bs_Vars = map nlHsVar bs_RDRs - -f_Pat, z_Pat :: LPat GhcPs -f_Pat = nlVarPat f_RDR -z_Pat = nlVarPat z_RDR - -{- -Note [DeriveFoldable with ExistentialQuantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Functor and Traversable instances can only be derived for data types whose -last type parameter is truly universally polymorphic. For example: - - data T a b where - T1 :: b -> T a b -- YES, b is unconstrained - T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b) - T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int) - T4 :: Int -> T a Int -- NO, this is just like T3 - T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even - -- though a is existential - T6 :: Int -> T Int b -- YES, b is unconstrained - -For Foldable instances, however, we can completely lift the constraint that -the last type parameter be truly universally polymorphic. This means that T -(as defined above) can have a derived Foldable instance: - - instance Foldable (T a) where - foldr f z (T1 b) = f b z - foldr f z (T2 b) = f b z - foldr f z (T3 b) = f b z - foldr f z (T4 b) = z - foldr f z (T5 a b) = f b z - foldr f z (T6 a) = z - - foldMap f (T1 b) = f b - foldMap f (T2 b) = f b - foldMap f (T3 b) = f b - foldMap f (T4 b) = mempty - foldMap f (T5 a b) = f b - foldMap f (T6 a) = mempty - -In a Foldable instance, it is safe to fold over an occurrence of the last type -parameter that is not truly universally polymorphic. However, there is a bit -of subtlety in determining what is actually an occurrence of a type parameter. -T3 and T4, as defined above, provide one example: - - data T a b where - ... - T3 :: b ~ Int => b -> T a b - T4 :: Int -> T a Int - ... - - instance Foldable (T a) where - ... - foldr f z (T3 b) = f b z - foldr f z (T4 b) = z - ... - foldMap f (T3 b) = f b - foldMap f (T4 b) = mempty - ... - -Notice that the argument of T3 is folded over, whereas the argument of T4 is -not. This is because we only fold over constructor arguments that -syntactically mention the universally quantified type parameter of that -particular data constructor. See foldDataConArgs for how this is implemented. - -As another example, consider the following data type. The argument of each -constructor has the same type as the last type parameter: - - data E a where - E1 :: (a ~ Int) => a -> E a - E2 :: Int -> E Int - E3 :: (a ~ Int) => a -> E Int - E4 :: (a ~ Int) => Int -> E a - -Only E1's argument is an occurrence of a universally quantified type variable -that is syntactically equivalent to the last type parameter, so only E1's -argument will be folded over in a derived Foldable instance. - -See #10447 for the original discussion on this feature. Also see -https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor -for a more in-depth explanation. - -Note [FFoldType and functorLikeTraverse] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deriving Functor, Foldable, and Traversable all require generating expressions -which perform an operation on each argument of a data constructor depending -on the argument's type. In particular, a generated operation can be different -depending on whether the type mentions the last type variable of the datatype -(e.g., if you have data T a = MkT a Int, then a generated foldr expression would -fold over the first argument of MkT, but not the second). - -This pattern is abstracted with the FFoldType datatype, which provides hooks -for the user to specify how a constructor argument should be folded when it -has a type with a particular "shape". The shapes are as follows (assume that -a is the last type variable in a given datatype): - -* ft_triv: The type does not mention the last type variable at all. - Examples: Int, b - -* ft_var: The type is syntactically equal to the last type variable. - Moreover, the type appears in a covariant position (see - the Deriving Functor instances section of the user's guide - for an in-depth explanation of covariance vs. contravariance). - Example: a (covariantly) - -* ft_co_var: The type is syntactically equal to the last type variable. - Moreover, the type appears in a contravariant position. - Example: a (contravariantly) - -* ft_fun: A function type which mentions the last type variable in - the argument position, result position or both. - Examples: a -> Int, Int -> a, Maybe a -> [a] - -* ft_tup: A tuple type which mentions the last type variable in at least - one of its fields. The TyCon argument of ft_tup represents the - particular tuple's type constructor. - Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #) - -* ft_ty_app: A type is being applied to the last type parameter, where the - applied type does not mention the last type parameter (if it - did, it would fall under ft_bad_app) and the argument type - mentions the last type parameter (if it did not, it would fall - under ft_triv). The first two Type arguments to - ft_ty_app represent the applied type and argument type, - respectively. - - Currently, only DeriveFunctor makes use of the argument type. - It inspects the argument type so that it can generate more - efficient implementations of fmap - (see Note [Avoid unnecessary eta expansion in derived fmap implementations]) - and (<$) (see Note [Deriving <$]) in certain cases. - - Note that functions, tuples, and foralls are distinct cases - and take precedence over ft_ty_app. (For example, (Int -> a) would - fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a). - Examples: Maybe a, Either b a - -* ft_bad_app: A type application uses the last type parameter in a position - other than the last argument. This case is singled out because - Functor, Foldable, and Traversable instances cannot be derived - for datatypes containing arguments with such types. - Examples: Either a Int, Const a b - -* ft_forall: A forall'd type mentions the last type parameter on its right- - hand side (and is not quantified on the left-hand side). This - case is present mostly for plumbing purposes. - Example: forall b. Either b a - -If FFoldType describes a strategy for folding subcomponents of a Type, then -functorLikeTraverse is the function that applies that strategy to the entirety -of a Type, returning the final folded-up result. - -foldDataConArgs applies functorLikeTraverse to every argument type of a -constructor, returning a list of the fold results. This makes foldDataConArgs -a natural way to generate the subexpressions in a generated fmap, foldr, -foldMap, or traverse definition (the subexpressions must then be combined in -a method-specific fashion to form the final generated expression). - -Deriving Generic1 also does validity checking by looking for the last type -variable in certain positions of a constructor's argument types, so it also -uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics. - -Note [Generated code for DeriveFoldable and DeriveTraversable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on -that of -XDeriveFunctor. However, there an important difference between deriving -the former two typeclasses and the latter one, which is best illustrated by the -following scenario: - - data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable) - -The generated code for the Functor instance is straightforward: - - instance Functor WithInt where - fmap f (WithInt a i) = WithInt (f a) i - -But if we use too similar of a strategy for deriving the Foldable and -Traversable instances, we end up with this code: - - instance Foldable WithInt where - foldMap f (WithInt a i) = f a <> mempty - - instance Traversable WithInt where - traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i - -This is unsatisfying for two reasons: - -1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure - expects an argument whose type is of kind *. This effectively prevents - Traversable from being derived for any datatype with an unlifted argument - type (#11174). - -2. The generated code contains superfluous expressions. By the Monoid laws, - we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can - reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)). - -We can fix both of these issues by incorporating a slight twist to the usual -algorithm that we use for -XDeriveFunctor. The differences can be summarized -as follows: - -1. In the generated expression, we only fold over arguments whose types - mention the last type parameter. Any other argument types will simply - produce useless 'mempty's or 'pure's, so they can be safely ignored. - -2. In the case of -XDeriveTraversable, instead of applying ConName, - we apply (\b_i ... b_k -> ConName a_1 ... a_n), where - - * ConName has n arguments - * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond - to the arguments whose types mention the last type parameter. As a - consequence, taking the difference of {a_1, ..., a_n} and - {b_i, ..., b_k} yields the all the argument values of ConName whose types - do not mention the last type parameter. Note that [i, ..., k] is a - strictly increasing—but not necessarily consecutive—integer sequence. - - For example, the datatype - - data Foo a = Foo Int a Int a - - would generate the following Traversable instance: - - instance Traversable Foo where - traverse f (Foo a1 a2 a3 a4) = - fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4 - -Technically, this approach would also work for -XDeriveFunctor as well, but we -decide not to do so because: - -1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a)) - instead of (WithInt (f a) i). - -2. There would be certain datatypes for which the above strategy would - generate Functor code that would fail to typecheck. For example: - - data Bar f a = Bar (forall f. Functor f => f a) deriving Functor - - With the conventional algorithm, it would generate something like: - - fmap f (Bar a) = Bar (fmap f a) - - which typechecks. But with the strategy mentioned above, it would generate: - - fmap f (Bar a) = (\b -> Bar b) (fmap f a) - - which does not typecheck, since GHC cannot unify the rank-2 type variables - in the types of b and (fmap f a). - -Note [Phantom types with Functor, Foldable, and Traversable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Given a type F :: * -> * whose type argument has a phantom role, we can always -produce lawful Functor and Traversable instances using - - fmap _ = coerce - traverse _ = pure . coerce - -Indeed, these are equivalent to any *strictly lawful* instances one could -write, except that this definition of 'traverse' may be lazier. That is, if -instances obey the laws under true equality (rather than up to some equivalence -relation), then they will be essentially equivalent to these. These definitions -are incredibly cheap, so we want to use them even if it means ignoring some -non-strictly-lawful instance in an embedded type. - -Foldable has far fewer laws to work with, which leaves us unwelcome -freedom in implementing it. At a minimum, we would like to ensure that -a derived foldMap is always at least as good as foldMapDefault with a -derived traverse. To accomplish that, we must define - - foldMap _ _ = mempty - -in these cases. - -This may have different strictness properties from a standard derivation. -Consider - - data NotAList a = Nil | Cons (NotAList a) deriving Foldable - -The usual deriving mechanism would produce - - foldMap _ Nil = mempty - foldMap f (Cons x) = foldMap f x - -which is strict in the entire spine of the NotAList. - -Final point: why do we even care about such types? Users will rarely if ever -map, fold, or traverse over such things themselves, but other derived -instances may: - - data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable - -Note [EmptyDataDecls with Functor, Foldable, and Traversable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are some slightly tricky decisions to make about how to handle -Functor, Foldable, and Traversable instances for types with no constructors. -For fmap, the two basic options are - - fmap _ _ = error "Sorry, no constructors" - -or - - fmap _ z = case z of - -In most cases, the latter is more helpful: if the thunk passed to fmap -throws an exception, we're generally going to be much more interested in -that exception than in the fact that there aren't any constructors. - -In order to match the semantics for phantoms (see note above), we need to -be a bit careful about 'traverse'. The obvious definition would be - - traverse _ z = case z of - -but this is stricter than the one for phantoms. We instead use - - traverse _ z = pure $ case z of - -For foldMap, the obvious choices are - - foldMap _ _ = mempty - -or - - foldMap _ z = case z of - -We choose the first one to be consistent with what foldMapDefault does for -a derived Traversable instance. --} diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs deleted file mode 100644 index a6193ed7c4..0000000000 --- a/compiler/typecheck/TcGenGenerics.hs +++ /dev/null @@ -1,1035 +0,0 @@ -{- -(c) The University of Glasgow 2011 - - -The deriving code for the Generic class -(equivalent to the code in TcGenDeriv, for other classes) --} - -{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcGenGenerics (canDoGenerics, canDoGenerics1, - GenericKind(..), - gen_Generic_binds, get_gen1_constrained_tys) where - -import GhcPrelude - -import GHC.Hs -import GHC.Core.Type -import TcType -import TcGenDeriv -import TcGenFunctor -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) -import FamInst -import GHC.Types.Module ( moduleName, moduleNameFS - , moduleUnitId, unitIdFS, getModule ) -import GHC.Iface.Env ( newGlobalBinder ) -import GHC.Types.Name hiding ( varName ) -import GHC.Types.Name.Reader -import GHC.Types.Basic -import TysPrim -import TysWiredIn -import PrelNames -import TcEnv -import TcRnMonad -import GHC.Driver.Types -import ErrUtils( Validity(..), andValid ) -import GHC.Types.SrcLoc -import Bag -import GHC.Types.Var.Env -import GHC.Types.Var.Set (elemVarSet) -import Outputable -import FastString -import Util - -import Control.Monad (mplus) -import Data.List (zip4, partition) -import Data.Maybe (isJust) - -#include "HsVersions.h" - -{- -************************************************************************ -* * -\subsection{Bindings for the new generic deriving mechanism} -* * -************************************************************************ - -For the generic representation we need to generate: -\begin{itemize} -\item A Generic instance -\item A Rep type instance -\item Many auxiliary datatypes and instances for them (for the meta-information) -\end{itemize} --} - -gen_Generic_binds :: GenericKind -> TyCon -> [Type] - -> TcM (LHsBinds GhcPs, FamInst) -gen_Generic_binds gk tc inst_tys = do - repTyInsts <- tc_mkRepFamInsts gk tc inst_tys - return (mkBindsRep gk tc, repTyInsts) - -{- -************************************************************************ -* * -\subsection{Generating representation types} -* * -************************************************************************ --} - -get_gen1_constrained_tys :: TyVar -> Type -> [Type] --- called by TcDeriv.inferConstraints; generates a list of types, each of which --- must be a Functor in order for the Generic1 instance to work. -get_gen1_constrained_tys argVar - = argTyFold argVar $ ArgTyAlg { ata_rec0 = const [] - , ata_par1 = [], ata_rec1 = const [] - , ata_comp = (:) } - -{- - -Note [Requirements for deriving Generic and Rep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In the following, T, Tfun, and Targ are "meta-variables" ranging over type -expressions. - -(Generic T) and (Rep T) are derivable for some type expression T if the -following constraints are satisfied. - - (a) D is a type constructor *value*. In other words, D is either a type - constructor or it is equivalent to the head of a data family instance (up to - alpha-renaming). - - (b) D cannot have a "stupid context". - - (c) The right-hand side of D cannot include existential types, universally - quantified types, or "exotic" unlifted types. An exotic unlifted type - is one which is not listed in the definition of allowedUnliftedTy - (i.e., one for which we have no representation type). - See Note [Generics and unlifted types] - - (d) T :: *. - -(Generic1 T) and (Rep1 T) are derivable for some type expression T if the -following constraints are satisfied. - - (a),(b),(c) As above. - - (d) T must expect arguments, and its last parameter must have kind *. - - We use `a' to denote the parameter of D that corresponds to the last - parameter of T. - - (e) For any type-level application (Tfun Targ) in the right-hand side of D - where the head of Tfun is not a tuple constructor: - - (b1) `a' must not occur in Tfun. - - (b2) If `a' occurs in Targ, then Tfun :: * -> *. - --} - -canDoGenerics :: TyCon -> Validity --- canDoGenerics determines if Generic/Rep can be derived. --- --- Check (a) from Note [Requirements for deriving Generic and Rep] is taken --- care of because canDoGenerics is applied to rep tycons. --- --- It returns IsValid if deriving is possible. It returns (NotValid reason) --- if not. -canDoGenerics tc - = mergeErrors ( - -- Check (b) from Note [Requirements for deriving Generic and Rep]. - (if (not (null (tyConStupidTheta tc))) - then (NotValid (tc_name <+> text "must not have a datatype context")) - else IsValid) - -- See comment below - : (map bad_con (tyConDataCons tc))) - where - -- The tc can be a representation tycon. When we want to display it to the - -- user (in an error message) we should print its parent - tc_name = ppr $ case tyConFamInst_maybe tc of - Just (ptc, _) -> ptc - _ -> tc - - -- Check (c) from Note [Requirements for deriving Generic and Rep]. - -- - -- If any of the constructors has an exotic unlifted type as argument, - -- then we can't build the embedding-projection pair, because - -- it relies on instantiating *polymorphic* sum and product types - -- at the argument types of the constructors - bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc)) - then (NotValid (ppr dc <+> text - "must not have exotic unlifted or polymorphic arguments")) - else (if (not (isVanillaDataCon dc)) - then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) - else IsValid) - - -- Nor can we do the job if it's an existential data constructor, - -- Nor if the args are polymorphic types (I don't think) - bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty)) - || not (isTauTy ty) - --- Returns True the Type argument is an unlifted type which has a --- corresponding generic representation type. For example, --- (allowedUnliftedTy Int#) would return True since there is the UInt --- representation type. -allowedUnliftedTy :: Type -> Bool -allowedUnliftedTy = isJust . unboxedRepRDRs - -mergeErrors :: [Validity] -> Validity -mergeErrors [] = IsValid -mergeErrors (NotValid s:t) = case mergeErrors t of - IsValid -> NotValid s - NotValid s' -> NotValid (s <> text ", and" $$ s') -mergeErrors (IsValid : t) = mergeErrors t - --- A datatype used only inside of canDoGenerics1. It's the result of analysing --- a type term. -data Check_for_CanDoGenerics1 = CCDG1 - { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in - -- this type? - , _ccdg1_errors :: Validity -- errors generated by this type - } - -{- - -Note [degenerate use of FFoldType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We use foldDataConArgs here only for its ability to treat tuples -specially. foldDataConArgs also tracks covariance (though it assumes all -higher-order type parameters are covariant) and has hooks for special handling -of functions and polytypes, but we do *not* use those. - -The key issue is that Generic1 deriving currently offers no sophisticated -support for functions. For example, we cannot handle - - data F a = F ((a -> Int) -> Int) - -even though a is occurring covariantly. - -In fact, our rule is harsh: a is simply not allowed to occur within the first -argument of (->). We treat (->) the same as any other non-tuple tycon. - -Unfortunately, this means we have to track "the parameter occurs in this type" -explicitly, even though foldDataConArgs is also doing this internally. - --} - --- canDoGenerics1 determines if a Generic1/Rep1 can be derived. --- --- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep] --- are taken care of by the call to canDoGenerics. --- --- It returns IsValid if deriving is possible. It returns (NotValid reason) --- if not. -canDoGenerics1 :: TyCon -> Validity -canDoGenerics1 rep_tc = - canDoGenerics rep_tc `andValid` additionalChecks - where - additionalChecks - -- check (d) from Note [Requirements for deriving Generic and Rep] - | null (tyConTyVars rep_tc) = NotValid $ - text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters" - - | otherwise = mergeErrors $ concatMap check_con data_cons - - data_cons = tyConDataCons rep_tc - check_con con = case check_vanilla con of - j@(NotValid {}) -> [j] - IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con - - bad :: DataCon -> SDoc -> SDoc - bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg - - check_vanilla :: DataCon -> Validity - check_vanilla con | isVanillaDataCon con = IsValid - | otherwise = NotValid (bad con existential) - - bmzero = CCDG1 False IsValid - bmbad con s = CCDG1 True $ NotValid $ bad con s - bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) - - -- check (e) from Note [Requirements for deriving Generic and Rep] - -- See also Note [degenerate use of FFoldType] - ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1 - ft_check con = FT - { ft_triv = bmzero - - , ft_var = caseVar, ft_co_var = caseVar - - -- (component_0,component_1,...,component_n) - , ft_tup = \_ components -> if any _ccdg1_hasParam (init components) - then bmbad con wrong_arg - else foldr bmplus bmzero components - - -- (dom -> rng), where the head of ty is not a tuple tycon - , ft_fun = \dom rng -> -- cf #8516 - if _ccdg1_hasParam dom - then bmbad con wrong_arg - else bmplus dom rng - - -- (ty arg), where head of ty is neither (->) nor a tuple constructor and - -- the parameter of interest does not occur in ty - , ft_ty_app = \_ _ arg -> arg - - , ft_bad_app = bmbad con wrong_arg - , ft_forall = \_ body -> body -- polytypes are handled elsewhere - } - where - caseVar = CCDG1 True IsValid - - - existential = text "must not have existential arguments" - wrong_arg = text "applies a type to an argument involving the last parameter" - $$ text "but the applied type is not of kind * -> *" - -{- -************************************************************************ -* * -\subsection{Generating the RHS of a generic default method} -* * -************************************************************************ --} - -type US = Int -- Local unique supply, just a plain Int -type Alt = (LPat GhcPs, LHsExpr GhcPs) - --- GenericKind serves to mark if a datatype derives Generic (Gen0) or --- Generic1 (Gen1). -data GenericKind = Gen0 | Gen1 - --- as above, but with a payload of the TyCon's name for "the" parameter -data GenericKind_ = Gen0_ | Gen1_ TyVar - --- as above, but using a single datacon's name for "the" parameter -data GenericKind_DC = Gen0_DC | Gen1_DC TyVar - -forgetArgVar :: GenericKind_DC -> GenericKind -forgetArgVar Gen0_DC = Gen0 -forgetArgVar Gen1_DC{} = Gen1 - --- When working only within a single datacon, "the" parameter's name should --- match that datacon's name for it. -gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC -gk2gkDC Gen0_ _ = Gen0_DC -gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d - - --- Bindings for the Generic instance -mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs -mkBindsRep gk tycon = - unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn]) - `unionBags` - unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn]) - where - -- The topmost M1 (the datatype metadata) has the exact same type - -- across all cases of a from/to definition, and can be factored out - -- to save some allocations during typechecking. - -- See Note [Generics compilation speed tricks] - from_eqn = mkHsCaseAlt x_Pat $ mkM1_E - $ nlHsPar $ nlHsCase x_Expr from_matches - to_eqn = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches - - from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts] - to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ] - loc = srcLocSpan (getSrcLoc tycon) - datacons = tyConDataCons tycon - - (from01_RDR, to01_RDR) = case gk of - Gen0 -> (from_RDR, to_RDR) - Gen1 -> (from1_RDR, to1_RDR) - - -- Recurse over the sum first - from_alts, to_alts :: [Alt] - (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons - where gk_ = case gk of - Gen0 -> Gen0_ - Gen1 -> ASSERT(tyvars `lengthAtLeast` 1) - Gen1_ (last tyvars) - where tyvars = tyConTyVars tycon - --------------------------------------------------------------------------------- --- The type synonym instance and synonym --- type instance Rep (D a b) = Rep_D a b --- type Rep_D a b = ...representation type for D ... --------------------------------------------------------------------------------- - -tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 - -> TyCon -- The type to generate representation for - -> [Type] -- The type(s) to which Generic(1) is applied - -- in the generated instance - -> TcM FamInst -- Generated representation0 coercion -tc_mkRepFamInsts gk tycon inst_tys = - -- Consider the example input tycon `D`, where data D a b = D_ a - -- Also consider `R:DInt`, where { data family D x y :: * -> * - -- ; data instance D Int a b = D_ a } - do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family) - fam_tc <- case gk of - Gen0 -> tcLookupTyCon repTyConName - Gen1 -> tcLookupTyCon rep1TyConName - - ; fam_envs <- tcGetFamInstEnvs - - ; let -- If the derived instance is - -- instance Generic (Foo x) - -- then: - -- `arg_ki` = *, `inst_ty` = Foo x :: * - -- - -- If the derived instance is - -- instance Generic1 (Bar x :: k -> *) - -- then: - -- `arg_k` = k, `inst_ty` = Bar x :: k -> * - (arg_ki, inst_ty) = case (gk, inst_tys) of - (Gen0, [inst_t]) -> (liftedTypeKind, inst_t) - (Gen1, [arg_k, inst_t]) -> (arg_k, inst_t) - _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys) - - ; let mbFamInst = tyConFamInst_maybe tycon - -- If we're examining a data family instance, we grab the parent - -- TyCon (ptc) and use it to determine the type arguments - -- (inst_args) for the data family *instance*'s type variables. - ptc = maybe tycon fst mbFamInst - (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd - $ tcSplitTyConApp inst_ty - - ; let -- `tyvars` = [a,b] - (tyvars, gk_) = case gk of - Gen0 -> (all_tyvars, Gen0_) - Gen1 -> ASSERT(not $ null all_tyvars) - (init all_tyvars, Gen1_ $ last all_tyvars) - where all_tyvars = tyConTyVars tycon - - -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - ; repTy <- tc_mkRepTy gk_ tycon arg_ki - - -- `rep_name` is a name we generate for the synonym - ; mod <- getModule - ; loc <- getSrcSpanM - ; let tc_occ = nameOccName (tyConName tycon) - rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ - ; rep_name <- newGlobalBinder mod rep_occ loc - - -- We make sure to substitute the tyvars with their user-supplied - -- type arguments before generating the Rep/Rep1 instance, since some - -- of the tyvars might have been instantiated when deriving. - -- See Note [Generating a correctly typed Rep instance]. - ; let (env_tyvars, env_inst_args) - = case gk_ of - Gen0_ -> (tyvars, inst_args) - Gen1_ last_tv - -- See the "wrinkle" in - -- Note [Generating a correctly typed Rep instance] - -> ( last_tv : tyvars - , anyTypeOfKind (tyVarKind last_tv) : inst_args ) - env = zipTyEnv env_tyvars env_inst_args - in_scope = mkInScopeSet (tyCoVarsOfTypes inst_tys) - subst = mkTvSubst in_scope env - repTy' = substTyUnchecked subst repTy - tcv' = tyCoVarsOfTypeList inst_ty - (tv', cv') = partition isTyVar tcv' - tvs' = scopedSort tv' - cvs' = scopedSort cv' - axiom = mkSingleCoAxiom Nominal rep_name tvs' [] cvs' - fam_tc inst_tys repTy' - - ; newFamInst SynFamilyInst axiom } - --------------------------------------------------------------------------------- --- Type representation --------------------------------------------------------------------------------- - --- | See documentation of 'argTyFold'; that function uses the fields of this --- type to interpret the structure of a type when that type is considered as an --- argument to a constructor that is being represented with 'Rep1'. -data ArgTyAlg a = ArgTyAlg - { ata_rec0 :: (Type -> a) - , ata_par1 :: a, ata_rec1 :: (Type -> a) - , ata_comp :: (Type -> a -> a) - } - --- | @argTyFold@ implements a generalised and safer variant of the @arg@ --- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@ --- is conceptually equivalent to: --- --- > arg t = case t of --- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t --- > App f [t'] | --- > representable1 f && --- > t' == argVar -> Rec1 f --- > App f [t'] | --- > representable1 f && --- > t' has tyvars -> f :.: (arg t') --- > _ -> Rec0 t --- --- where @argVar@ is the last type variable in the data type declaration we are --- finding the representation for. --- --- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to --- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and --- @:.:@. --- --- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for --- some data types. The problematic case is when @t@ is an application of a --- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the --- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in --- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some --- representable1 checks have been relaxed, and others were moved to --- @canDoGenerics1@. -argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a -argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0, - ata_par1 = mkPar1, ata_rec1 = mkRec1, - ata_comp = mkComp}) = - -- mkRec0 is the default; use it if there is no interesting structure - -- (e.g. occurrences of parameters or recursive occurrences) - \t -> maybe (mkRec0 t) id $ go t where - go :: Type -> -- type to fold through - Maybe a -- the result (e.g. representation type), unless it's trivial - go t = isParam `mplus` isApp where - - isParam = do -- handles parameters - t' <- getTyVar_maybe t - Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter - else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0 - - isApp = do -- handles applications - (phi, beta) <- tcSplitAppTy_maybe t - - let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta - - -- Does it have no interesting structure to represent? - if not interesting then Nothing - else -- Is the argument the parameter? Special case for mkRec1. - if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi - else mkComp phi `fmap` go beta -- It must be a composition. - - -tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 - GenericKind_ - -- The type to generate representation for - -> TyCon - -- The kind of the representation type's argument - -- See Note [Handling kinds in a Rep instance] - -> Kind - -- Generated representation0 type - -> TcM Type -tc_mkRepTy gk_ tycon k = - do - d1 <- tcLookupTyCon d1TyConName - c1 <- tcLookupTyCon c1TyConName - s1 <- tcLookupTyCon s1TyConName - rec0 <- tcLookupTyCon rec0TyConName - rec1 <- tcLookupTyCon rec1TyConName - par1 <- tcLookupTyCon par1TyConName - u1 <- tcLookupTyCon u1TyConName - v1 <- tcLookupTyCon v1TyConName - plus <- tcLookupTyCon sumTyConName - times <- tcLookupTyCon prodTyConName - comp <- tcLookupTyCon compTyConName - uAddr <- tcLookupTyCon uAddrTyConName - uChar <- tcLookupTyCon uCharTyConName - uDouble <- tcLookupTyCon uDoubleTyConName - uFloat <- tcLookupTyCon uFloatTyConName - uInt <- tcLookupTyCon uIntTyConName - uWord <- tcLookupTyCon uWordTyConName - - let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon - - md <- tcLookupPromDataCon metaDataDataConName - mc <- tcLookupPromDataCon metaConsDataConName - ms <- tcLookupPromDataCon metaSelDataConName - pPrefix <- tcLookupPromDataCon prefixIDataConName - pInfix <- tcLookupPromDataCon infixIDataConName - pLA <- tcLookupPromDataCon leftAssociativeDataConName - pRA <- tcLookupPromDataCon rightAssociativeDataConName - pNA <- tcLookupPromDataCon notAssociativeDataConName - pSUpk <- tcLookupPromDataCon sourceUnpackDataConName - pSNUpk <- tcLookupPromDataCon sourceNoUnpackDataConName - pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName - pSLzy <- tcLookupPromDataCon sourceLazyDataConName - pSStr <- tcLookupPromDataCon sourceStrictDataConName - pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName - pDLzy <- tcLookupPromDataCon decidedLazyDataConName - pDStr <- tcLookupPromDataCon decidedStrictDataConName - pDUpk <- tcLookupPromDataCon decidedUnpackDataConName - - fix_env <- getFixityEnv - - let mkSum' a b = mkTyConApp plus [k,a,b] - mkProd a b = mkTyConApp times [k,a,b] - mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a - mkRec1 a = mkTyConApp rec1 [k,a] - mkPar1 = mkTyConTy par1 - mkD a = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ] - mkC a = mkTyConApp c1 [ k - , metaConsTy a - , prod (dataConInstOrigArgTys a - . mkTyVarTys . tyConTyVars $ tycon) - (dataConSrcBangs a) - (dataConImplBangs a) - (dataConFieldLabels a)] - mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a] - - -- Sums and products are done in the same way for both Rep and Rep1 - sumP l = foldBal mkSum' (mkTyConApp v1 [k]) . map mkC $ l - -- The Bool is True if this constructor has labelled fields - prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type - prod l sb ib fl = foldBal mkProd (mkTyConApp u1 [k]) - [ ASSERT(null fl || lengthExceeds fl j) - arg t sb' ib' (if null fl - then Nothing - else Just (fl !! j)) - | (t,sb',ib',j) <- zip4 l sb ib [0..] ] - - arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type - arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of - -- Here we previously used Par0 if t was a type variable, but we - -- realized that we can't always guarantee that we are wrapping-up - -- all type variables in Par0. So we decided to stop using Par0 - -- altogether, and use Rec0 all the time. - Gen0_ -> mkRec0 t - Gen1_ argVar -> argPar argVar t - where - -- Builds argument representation for Rep1 (more complicated due to - -- the presence of composition). - argPar argVar = argTyFold argVar $ ArgTyAlg - {ata_rec0 = mkRec0, ata_par1 = mkPar1, - ata_rec1 = mkRec1, ata_comp = mkComp comp k} - - tyConName_user = case tyConFamInst_maybe tycon of - Just (ptycon, _) -> tyConName ptycon - Nothing -> tyConName tycon - - dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user - mdName = mkStrLitTy . moduleNameFS . moduleName - . nameModule . tyConName $ tycon - pkgName = mkStrLitTy . unitIdFS . moduleUnitId - . nameModule . tyConName $ tycon - isNT = mkTyConTy $ if isNewTyCon tycon - then promotedTrueDataCon - else promotedFalseDataCon - - ctName = mkStrLitTy . occNameFS . nameOccName . dataConName - ctFix c - | dataConIsInfix c - = case lookupFixity fix_env (dataConName c) of - Fixity _ n InfixL -> buildFix n pLA - Fixity _ n InfixR -> buildFix n pRA - Fixity _ n InfixN -> buildFix n pNA - | otherwise = mkTyConTy pPrefix - buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc - , mkNumLitTy (fromIntegral n)] - - isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0 - then promotedTrueDataCon - else promotedFalseDataCon - - selName = mkStrLitTy . flLabel - - mbSel Nothing = mkTyConApp promotedNothingDataCon [typeSymbolKind] - mbSel (Just s) = mkTyConApp promotedJustDataCon - [typeSymbolKind, selName s] - - metaDataTy = mkTyConApp md [dtName, mdName, pkgName, isNT] - metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c] - metaSelTy mlbl su ss ib = - mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness] - where - pSUpkness = mkTyConTy $ case su of - SrcUnpack -> pSUpk - SrcNoUnpack -> pSNUpk - NoSrcUnpack -> pNSUpkness - - pSStrness = mkTyConTy $ case ss of - SrcLazy -> pSLzy - SrcStrict -> pSStr - NoSrcStrict -> pNSStrness - - pDStrness = mkTyConTy $ case ib of - HsLazy -> pDLzy - HsStrict -> pDStr - HsUnpack{} -> pDUpk - - return (mkD tycon) - -mkComp :: TyCon -> Kind -> Type -> Type -> Type -mkComp comp k f g - | k1_first = mkTyConApp comp [k,liftedTypeKind,f,g] - | otherwise = mkTyConApp comp [liftedTypeKind,k,f,g] - where - -- Which of these is the case? - -- newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... - -- or newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... - -- We want to instantiate with k1=k, and k2=* - -- Reason for k2=*: see Note [Handling kinds in a Rep instance] - -- But we need to know which way round! - k1_first = k_first == p_kind_var - [k_first,_,_,_,p] = tyConTyVars comp - Just p_kind_var = getTyVar_maybe (tyVarKind p) - --- Given the TyCons for each URec-related type synonym, check to see if the --- given type is an unlifted type that generics understands. If so, return --- its representation type. Otherwise, return Rec0. --- See Note [Generics and unlifted types] -mkBoxTy :: TyCon -- UAddr - -> TyCon -- UChar - -> TyCon -- UDouble - -> TyCon -- UFloat - -> TyCon -- UInt - -> TyCon -- UWord - -> TyCon -- Rec0 - -> Kind -- What to instantiate Rec0's kind variable with - -> Type - -> Type -mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty - | ty `eqType` addrPrimTy = mkTyConApp uAddr [k] - | ty `eqType` charPrimTy = mkTyConApp uChar [k] - | ty `eqType` doublePrimTy = mkTyConApp uDouble [k] - | ty `eqType` floatPrimTy = mkTyConApp uFloat [k] - | ty `eqType` intPrimTy = mkTyConApp uInt [k] - | ty `eqType` wordPrimTy = mkTyConApp uWord [k] - | otherwise = mkTyConApp rec0 [k,ty] - --------------------------------------------------------------------------------- --- Dealing with sums --------------------------------------------------------------------------------- - -mkSum :: GenericKind_ -- Generic or Generic1? - -> US -- Base for generating unique names - -> [DataCon] -- The data constructors - -> ([Alt], -- Alternatives for the T->Trep "from" function - [Alt]) -- Alternatives for the Trep->T "to" function - --- Datatype without any constructors -mkSum _ _ [] = ([from_alt], [to_alt]) - where - from_alt = (x_Pat, nlHsCase x_Expr []) - to_alt = (x_Pat, nlHsCase x_Expr []) - -- These M1s are meta-information for the datatype - --- Datatype with at least one constructor -mkSum gk_ us datacons = - -- switch the payload of gk_ to be datacon-centric instead of tycon-centric - unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d - | (d,i) <- zip datacons [1..] ] - --- Build the sum for a particular constructor -mk1Sum :: GenericKind_DC -- Generic or Generic1? - -> US -- Base for generating unique names - -> Int -- The index of this constructor - -> Int -- Total number of constructors - -> DataCon -- The data constructor - -> (Alt, -- Alternative for the T->Trep "from" function - Alt) -- Alternative for the Trep->T "to" function -mk1Sum gk_ us i n datacon = (from_alt, to_alt) - where - gk = forgetArgVar gk_ - - -- Existentials already excluded - argTys = dataConOrigArgTys datacon - n_args = dataConSourceArity datacon - - datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys - datacon_vars = map fst datacon_varTys - - datacon_rdr = getRdrName datacon - - from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) - from_alt_rhs = genLR_E i n (mkProd_E gk_ datacon_varTys) - - to_alt = ( genLR_P i n (mkProd_P gk datacon_varTys) - , to_alt_rhs - ) -- These M1s are meta-information for the datatype - to_alt_rhs = case gk_ of - Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars - Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys - where - argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where - converter = argTyFold argVar $ ArgTyAlg - {ata_rec0 = nlHsVar . unboxRepRDR, - ata_par1 = nlHsVar unPar1_RDR, - ata_rec1 = const $ nlHsVar unRec1_RDR, - ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv) - `nlHsCompose` nlHsVar unComp1_RDR} - - --- Generates the L1/R1 sum pattern -genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs -genLR_P i n p - | n == 0 = error "impossible" - | n == 1 = p - | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] - | otherwise = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] - where m = div n 2 - --- Generates the L1/R1 sum expression -genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs -genLR_E i n e - | n == 0 = error "impossible" - | n == 1 = e - | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` - nlHsPar (genLR_E i (div n 2) e) - | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` - nlHsPar (genLR_E (i-m) (n-m) e) - where m = div n 2 - --------------------------------------------------------------------------------- --- Dealing with products --------------------------------------------------------------------------------- - --- Build a product expression -mkProd_E :: GenericKind_DC -- Generic or Generic1? - -> [(RdrName, Type)] - -- List of variables matched on the lhs and their types - -> LHsExpr GhcPs -- Resulting product expression -mkProd_E gk_ varTys = mkM1_E (foldBal prod (nlHsVar u1DataCon_RDR) appVars) - -- These M1s are meta-information for the constructor - where - appVars = map (wrapArg_E gk_) varTys - prod a b = prodDataCon_RDR `nlHsApps` [a,b] - -wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs -wrapArg_E Gen0_DC (var, ty) = mkM1_E $ - boxRepRDR ty `nlHsVarApps` [var] - -- This M1 is meta-information for the selector -wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ - converter ty `nlHsApp` nlHsVar var - -- This M1 is meta-information for the selector - where converter = argTyFold argVar $ ArgTyAlg - {ata_rec0 = nlHsVar . boxRepRDR, - ata_par1 = nlHsVar par1DataCon_RDR, - ata_rec1 = const $ nlHsVar rec1DataCon_RDR, - ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` - (nlHsVar fmap_RDR `nlHsApp` cnv)} - -boxRepRDR :: Type -> RdrName -boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs - -unboxRepRDR :: Type -> RdrName -unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs - --- Retrieve the RDRs associated with each URec data family instance --- constructor. See Note [Generics and unlifted types] -unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName) -unboxedRepRDRs ty - | ty `eqType` addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR) - | ty `eqType` charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR) - | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR) - | ty `eqType` floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR) - | ty `eqType` intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR) - | ty `eqType` wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR) - | otherwise = Nothing - --- Build a product pattern -mkProd_P :: GenericKind -- Gen0 or Gen1 - -> [(RdrName, Type)] -- List of variables to match, - -- along with their types - -> LPat GhcPs -- Resulting product pattern -mkProd_P gk varTys = mkM1_P (foldBal prod (nlNullaryConPat u1DataCon_RDR) appVars) - -- These M1s are meta-information for the constructor - where - appVars = unzipWith (wrapArg_P gk) varTys - prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b] - -wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs -wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v]) - -- This M1 is meta-information for the selector -wrapArg_P Gen1 v _ = nlParPat $ m1DataCon_RDR `nlConVarPat` [v] - -mkGenericLocal :: US -> RdrName -mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) - -x_RDR :: RdrName -x_RDR = mkVarUnqual (fsLit "x") - -x_Expr :: LHsExpr GhcPs -x_Expr = nlHsVar x_RDR - -x_Pat :: LPat GhcPs -x_Pat = nlVarPat x_RDR - -mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs -mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e - -mkM1_P :: LPat GhcPs -> LPat GhcPs -mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p] - -nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -nlHsCompose x y = compose_RDR `nlHsApps` [x, y] - --- | Variant of foldr for producing balanced lists -foldBal :: (a -> a -> a) -> a -> [a] -> a -foldBal _ x [] = x -foldBal _ _ [y] = y -foldBal op x l = let (a,b) = splitAt (length l `div` 2) l - in foldBal op x a `op` foldBal op x b - -{- -Note [Generics and unlifted types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, all constants are marked with K1/Rec0. The exception to this rule is -when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In -that case, we must use a data family instance of URec (from GHC.Generics) to -mark it. As a result, before we can generate K1 or unK1, we must first check -to see if the type is actually one of the unlifted types for which URec has a -data family instance; if so, we generate that instead. - -See wiki:commentary/compiler/generic-deriving#handling-unlifted-types for more -details on why URec is implemented the way it is. - -Note [Generating a correctly typed Rep instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving -Generic(1). That is, it derives the ellipsis in the following: - - instance Generic Foo where - type Rep Foo = ... - -However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which -a Generic(1) instance is being derived, not the fully instantiated type. As a -result, tc_mkRepTy builds the most generalized Rep(1) instance possible using -the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This -can cause problems when the instance has instantiated type variables -(see #11732). As an example: - - data T a = MkT a - deriving instance Generic (T Int) - ==> - instance Generic (T Int) where - type Rep (T Int) = (... (Rec0 a)) -- wrong! - --XStandaloneDeriving is one way for the type variables to become instantiated. -Another way is when Generic1 is being derived for a datatype with a visible -kind binder, e.g., - - data P k (a :: k) = MkP k deriving Generic1 - ==> - instance Generic1 (P *) where - type Rep1 (P *) = (... (Rec0 k)) -- wrong! - -See Note [Unify kinds in deriving] in TcDeriv. - -In any such scenario, we must prevent a discrepancy between the LHS and RHS of -a Rep(1) instance. To do so, we create a type variable substitution that maps -the tyConTyVars of the TyCon to their counterparts in the fully instantiated -type. (For example, using T above as example, you'd map a :-> Int.) We then -apply the substitution to the RHS before generating the instance. - -A wrinkle in all of this: when forming the type variable substitution for -Generic1 instances, we map the last type variable of the tycon to Any. Why? -It's because of wily data types like this one (#15012): - - data T a = MkT (FakeOut a) - type FakeOut a = Int - -If we ignore a, then we'll produce the following Rep1 instance: - - instance Generic1 T where - type Rep1 T = ... (Rec0 (FakeOut a)) - ... - -Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we -ensure that `a` is mapped to Any: - - instance Generic1 T where - type Rep1 T = ... (Rec0 (FakeOut Any)) - ... - -And now all is good. - -Alternatively, we could have avoided this problem by expanding all type -synonyms on the RHSes of Rep1 instances. But we might blow up the size of -these types even further by doing this, so we choose not to do so. - -Note [Handling kinds in a Rep instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because Generic1 is poly-kinded, the representation types were generalized to -be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply -the kind of the instance being derived to all the representation type -constructors. For instance, if you have - - data Empty (a :: k) = Empty deriving Generic1 - -Then the generated code is now approximately (with -fprint-explicit-kinds -syntax): - - instance Generic1 k (Empty k) where - type Rep1 k (Empty k) = U1 k - -Most representation types have only one kind variable, making them easy to deal -with. The only non-trivial case is (:.:), which is only used in Generic1 -instances: - - newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) = - Comp1 { unComp1 :: f (g p) } - -Here, we do something a bit counter-intuitive: we make k1 be the kind of the -instance being derived, and we always make k2 be *. Why *? It's because -the code that GHC generates using (:.:) is always of the form x :.: Rec1 y -for some types x and y. In other words, the second type to which (:.:) is -applied always has kind k -> *, for some kind k, so k2 cannot possibly be -anything other than * in a generated Generic1 instance. - -Note [Generics compilation speed tricks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deriving Generic(1) is known to have a large constant factor during -compilation, which contributes to noticeable compilation slowdowns when -deriving Generic(1) for large datatypes (see #5642). - -To ease the pain, there is a trick one can play when generating definitions for -to(1) and from(1). If you have a datatype like: - - data Letter = A | B | C | D - -then a naïve Generic instance for Letter would be: - - instance Generic Letter where - type Rep Letter = D1 ('MetaData ...) ... - - to (M1 (L1 (L1 (M1 U1)))) = A - to (M1 (L1 (R1 (M1 U1)))) = B - to (M1 (R1 (L1 (M1 U1)))) = C - to (M1 (R1 (R1 (M1 U1)))) = D - - from A = M1 (L1 (L1 (M1 U1))) - from B = M1 (L1 (R1 (M1 U1))) - from C = M1 (R1 (L1 (M1 U1))) - from D = M1 (R1 (R1 (M1 U1))) - -Notice that in every LHS pattern-match of the 'to' definition, and in every RHS -expression in the 'from' definition, the topmost constructor is M1. This -corresponds to the datatype-specific metadata (the D1 in the Rep Letter -instance). But this is wasteful from a typechecking perspective, since this -definition requires GHC to typecheck an application of M1 in every single case, -leading to an O(n) increase in the number of coercions the typechecker has to -solve, which in turn increases allocations and degrades compilation speed. - -Luckily, since the topmost M1 has the exact same type across every case, we can -factor it out reduce the typechecker's burden: - - instance Generic Letter where - type Rep Letter = D1 ('MetaData ...) ... - - to (M1 x) = case x of - L1 (L1 (M1 U1)) -> A - L1 (R1 (M1 U1)) -> B - R1 (L1 (M1 U1)) -> C - R1 (R1 (M1 U1)) -> D - - from x = M1 (case x of - A -> L1 (L1 (M1 U1)) - B -> L1 (R1 (M1 U1)) - C -> R1 (L1 (M1 U1)) - D -> R1 (R1 (M1 U1))) - -A simple change, but one that pays off, since it goes turns an O(n) amount of -coercions to an O(1) amount. --} diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs deleted file mode 100644 index 00a1a17226..0000000000 --- a/compiler/typecheck/TcHoleErrors.hs +++ /dev/null @@ -1,1002 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits - , tcCheckHoleFit, tcSubsumes - , withoutUnification - , fromPureHFPlugin - -- Re-exports for convenience - , hfIsLcl - , pprHoleFit, debugHoleFitDispConfig - - -- Re-exported from TcHoleFitTypes - , TypedHole (..), HoleFit (..), HoleFitCandidate (..) - , CandPlugin, FitPlugin - , HoleFitPlugin (..), HoleFitPluginR (..) - ) where - -import GhcPrelude - -import TcRnTypes -import TcRnMonad -import Constraint -import TcOrigin -import TcMType -import TcEvidence -import TcType -import GHC.Core.Type -import GHC.Core.DataCon -import GHC.Types.Name -import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts ) -import PrelNames ( gHC_ERR ) -import GHC.Types.Id -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import Bag -import GHC.Core.ConLike ( ConLike(..) ) -import Util -import TcEnv (tcLookup) -import Outputable -import GHC.Driver.Session -import Maybes -import FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV ) - -import Control.Arrow ( (&&&) ) - -import Control.Monad ( filterM, replicateM, foldM ) -import Data.List ( partition, sort, sortOn, nubBy ) -import Data.Graph ( graphFromEdges, topSort ) - - -import TcSimplify ( simpl_top, runTcSDeriveds ) -import TcUnify ( tcSubType_NC ) - -import GHC.HsToCore.Docs ( extractDocs ) -import qualified Data.Map as Map -import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) ) -import GHC.Driver.Types ( ModIface_(..) ) -import GHC.Iface.Load ( loadInterfaceForNameMaybe ) - -import PrelInfo (knownKeyNames) - -import TcHoleFitTypes - - -{- -Note [Valid hole fits include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -`findValidHoleFits` returns the "Valid hole fits include ..." message. -For example, look at the following definitions in a file called test.hs: - - import Data.List (inits) - - f :: [String] - f = _ "hello, world" - -The hole in `f` would generate the message: - - • Found hole: _ :: [Char] -> [String] - • In the expression: _ - In the expression: _ "hello, world" - In an equation for ‘f’: f = _ "hello, world" - • Relevant bindings include f :: [String] (bound at test.hs:6:1) - Valid hole fits include - lines :: String -> [String] - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘base-4.11.0.0:Data.OldList’)) - words :: String -> [String] - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘base-4.11.0.0:Data.OldList’)) - inits :: forall a. [a] -> [[a]] - with inits @Char - (imported from ‘Data.List’ at mpt.hs:4:19-23 - (and originally defined in ‘base-4.11.0.0:Data.OldList’)) - repeat :: forall a. a -> [a] - with repeat @String - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.List’)) - fail :: forall (m :: * -> *). Monad m => forall a. String -> m a - with fail @[] @String - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.Base’)) - return :: forall (m :: * -> *). Monad m => forall a. a -> m a - with return @[] @String - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.Base’)) - pure :: forall (f :: * -> *). Applicative f => forall a. a -> f a - with pure @[] @String - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.Base’)) - read :: forall a. Read a => String -> a - with read @[String] - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘Text.Read’)) - mempty :: forall a. Monoid a => a - with mempty @([Char] -> [String]) - (imported from ‘Prelude’ at mpt.hs:3:8-9 - (and originally defined in ‘GHC.Base’)) - -Valid hole fits are found by checking top level identifiers and local bindings -in scope for whether their type can be instantiated to the the type of the hole. -Additionally, we also need to check whether all relevant constraints are solved -by choosing an identifier of that type as well, see Note [Relevant Constraints] - -Since checking for subsumption results in the side-effect of type variables -being unified by the simplifier, we need to take care to restore them after -to being flexible type variables after we've checked for subsumption. -This is to avoid affecting the hole and later checks by prematurely having -unified one of the free unification variables. - -When outputting, we sort the hole fits by the size of the types we'd need to -apply by type application to the type of the fit to to make it fit. This is done -in order to display "more relevant" suggestions first. Another option is to -sort by building a subsumption graph of fits, i.e. a graph of which fits subsume -what other fits, and then outputting those fits which are are subsumed by other -fits (i.e. those more specific than other fits) first. This results in the ones -"closest" to the type of the hole to be displayed first. - -To help users understand how the suggested fit works, we also display the values -that the quantified type variables would take if that fit is used, like -`mempty @([Char] -> [String])` and `pure @[] @String` in the example above. -If -XTypeApplications is enabled, this can even be copied verbatim as a -replacement for the hole. - - -Note [Nested implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For the simplifier to be able to use any givens present in the enclosing -implications to solve relevant constraints, we nest the wanted subsumption -constraints and relevant constraints within the enclosing implications. - -As an example, let's look at the following code: - - f :: Show a => a -> String - f x = show _ - -The hole will result in the hole constraint: - - [WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)) - -Here the nested implications are just one level deep, namely: - - [Implic { - TcLevel = 2 - Skolems = a_a1pa[sk:2] - No-eqs = True - Status = Unsolved - Given = $dShow_a1pc :: Show a_a1pa[sk:2] - Wanted = - WC {wc_simple = - [WD] __a1ph {0}:: a_a1pd[tau:2] (CHoleCan: ExprHole(_)) - [WD] $dShow_a1pe {0}:: Show a_a1pd[tau:2] (CDictCan(psc))} - Binds = EvBindsVar<a1pi> - Needed inner = [] - Needed outer = [] - the type signature for: - f :: forall a. Show a => a -> String }] - -As we can see, the givens say that the information about the skolem -`a_a1pa[sk:2]` fulfills the Show constraint. - -The simples are: - - [[WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)), - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)] - -I.e. the hole `a0_a1pd[tau:2]` and the constraint that the type of the hole must -fulfill `Show a0_a1pd[tau:2])`. - -So when we run the check, we need to make sure that the - - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical) - -Constraint gets solved. When we now check for whether `x :: a0_a1pd[tau:2]` fits -the hole in `tcCheckHoleFit`, the call to `tcSubType` will end up writing the -meta type variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted -constraints needed by tcSubType_NC and the relevant constraints (see -Note [Relevant Constraints] for more details) in the nested implications, we -can pass the information in the givens along to the simplifier. For our example, -we end up needing to check whether the following constraints are soluble. - - WC {wc_impl = - Implic { - TcLevel = 2 - Skolems = a_a1pa[sk:2] - No-eqs = True - Status = Unsolved - Given = $dShow_a1pc :: Show a_a1pa[sk:2] - Wanted = - WC {wc_simple = - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)} - Binds = EvBindsVar<a1pl> - Needed inner = [] - Needed outer = [] - the type signature for: - f :: forall a. Show a => a -> String }} - -But since `a0_a1pd[tau:2] := a_a1pa[sk:2]` and we have from the nested -implications that Show a_a1pa[sk:2] is a given, this is trivial, and we end up -with a final WC of WC {}, confirming x :: a0_a1pd[tau:2] as a match. - -To avoid side-effects on the nested implications, we create a new EvBindsVar so -that any changes to the ev binds during a check remains localised to that check. - - -Note [Valid refinement hole fits include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the `-frefinement-level-hole-fits=N` flag is given, we additionally look -for "valid refinement hole fits"", i.e. valid hole fits with up to N -additional holes in them. - -With `-frefinement-level-hole-fits=0` (the default), GHC will find all -identifiers 'f' (top-level or nested) that will fit in the hole. - -With `-frefinement-level-hole-fits=1`, GHC will additionally find all -applications 'f _' that will fit in the hole, where 'f' is an in-scope -identifier, applied to single argument. It will also report the type of the -needed argument (a new hole). - -And similarly as the number of arguments increases - -As an example, let's look at the following code: - - f :: [Integer] -> Integer - f = _ - -with `-frefinement-level-hole-fits=1`, we'd get: - - Valid refinement hole fits include - - foldl1 (_ :: Integer -> Integer -> Integer) - with foldl1 @[] @Integer - where foldl1 :: forall (t :: * -> *). - Foldable t => - forall a. (a -> a -> a) -> t a -> a - foldr1 (_ :: Integer -> Integer -> Integer) - with foldr1 @[] @Integer - where foldr1 :: forall (t :: * -> *). - Foldable t => - forall a. (a -> a -> a) -> t a -> a - const (_ :: Integer) - with const @Integer @[Integer] - where const :: forall a b. a -> b -> a - ($) (_ :: [Integer] -> Integer) - with ($) @'GHC.Types.LiftedRep @[Integer] @Integer - where ($) :: forall a b. (a -> b) -> a -> b - fail (_ :: String) - with fail @((->) [Integer]) @Integer - where fail :: forall (m :: * -> *). - Monad m => - forall a. String -> m a - return (_ :: Integer) - with return @((->) [Integer]) @Integer - where return :: forall (m :: * -> *). Monad m => forall a. a -> m a - (Some refinement hole fits suppressed; - use -fmax-refinement-hole-fits=N or -fno-max-refinement-hole-fits) - -Which are hole fits with holes in them. This allows e.g. beginners to -discover the fold functions and similar, but also allows for advanced users -to figure out the valid functions in the Free monad, e.g. - - instance Functor f => Monad (Free f) where - Pure a >>= f = f a - Free f >>= g = Free (fmap _a f) - -Will output (with -frefinment-level-hole-fits=1): - Found hole: _a :: Free f a -> Free f b - Where: ‘a’, ‘b’ are rigid type variables bound by - the type signature for: - (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b - at fms.hs:25:12-14 - ‘f’ is a rigid type variable bound by - ... - Relevant bindings include - g :: a -> Free f b (bound at fms.hs:27:16) - f :: f (Free f a) (bound at fms.hs:27:10) - (>>=) :: Free f a -> (a -> Free f b) -> Free f b - (bound at fms.hs:25:12) - ... - Valid refinement hole fits include - ... - (=<<) (_ :: a -> Free f b) - with (=<<) @(Free f) @a @b - where (=<<) :: forall (m :: * -> *) a b. - Monad m => - (a -> m b) -> m a -> m b - (imported from ‘Prelude’ at fms.hs:5:18-22 - (and originally defined in ‘GHC.Base’)) - ... - -Where `(=<<) _` is precisely the function we want (we ultimately want `>>= g`). - -We find these refinement suggestions by considering hole fits that don't -fit the type of the hole, but ones that would fit if given an additional -argument. We do this by creating a new type variable with `newOpenFlexiTyVar` -(e.g. `t_a1/m[tau:1]`), and then considering hole fits of the type -`t_a1/m[tau:1] -> v` where `v` is the type of the hole. - -Since the simplifier is free to unify this new type variable with any type, we -can discover any identifiers that would fit if given another identifier of a -suitable type. This is then generalized so that we can consider any number of -additional arguments by setting the `-frefinement-level-hole-fits` flag to any -number, and then considering hole fits like e.g. `foldl _ _` with two additional -arguments. - -To make sure that the refinement hole fits are useful, we check that the types -of the additional holes have a concrete value and not just an invented type -variable. This eliminates suggestions such as `head (_ :: [t0 -> a]) (_ :: t0)`, -and limits the number of less than useful refinement hole fits. - -Additionally, to further aid the user in their implementation, we show the -types of the holes the binding would have to be applied to in order to work. -In the free monad example above, this is demonstrated with -`(=<<) (_ :: a -> Free f b)`, which tells the user that the `(=<<)` needs to -be applied to an expression of type `a -> Free f b` in order to match. -If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim. - - -Note [Relevant Constraints] -~~~~~~~~~~~~~~~~~~~ - -As highlighted by #14273, we need to check any relevant constraints as well -as checking for subsumption. Relevant constraints are the simple constraints -whose free unification variables are mentioned in the type of the hole. - -In the simplest case, these are all non-hole constraints in the simples, such -as is the case in - - f :: String - f = show _ - -Where the simples will be : - - [[WD] __a1kz {0}:: a0_a1kv[tau:1] (CHoleCan: ExprHole(_)), - [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)] - -However, when there are multiple holes, we need to be more careful. As an -example, Let's take a look at the following code: - - f :: Show a => a -> String - f x = show (_b (show _a)) - -Here there are two holes, `_a` and `_b`, and the simple constraints passed to -findValidHoleFits are: - - [[WD] _a_a1pi {0}:: String - -> a0_a1pd[tau:2] (CHoleCan: ExprHole(_b)), - [WD] _b_a1ps {0}:: a1_a1po[tau:2] (CHoleCan: ExprHole(_a)), - [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical), - [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)] - - -Here we have the two hole constraints for `_a` and `_b`, but also additional -constraints that these holes must fulfill. When we are looking for a match for -the hole `_a`, we filter the simple constraints to the "Relevant constraints", -by throwing out all hole constraints and any constraints which do not mention -a variable mentioned in the type of the hole. For hole `_a`, we will then -only require that the `$dShow_a1pp` constraint is solved, since that is -the only non-hole constraint that mentions any free type variables mentioned in -the hole constraint for `_a`, namely `a_a1pd[tau:2]` , and similarly for the -hole `_b` we only require that the `$dShow_a1pe` constraint is solved. - -Note [Leaking errors] -~~~~~~~~~~~~~~~~~~~ - -When considering candidates, GHC believes that we're checking for validity in -actual source. However, As evidenced by #15321, #15007 and #15202, this can -cause bewildering error messages. The solution here is simple: if a candidate -would cause the type checker to error, it is not a valid hole fit, and thus it -is discarded. - --} - - -data HoleFitDispConfig = HFDC { showWrap :: Bool - , showWrapVars :: Bool - , showType :: Bool - , showProv :: Bool - , showMatches :: Bool } - -debugHoleFitDispConfig :: HoleFitDispConfig -debugHoleFitDispConfig = HFDC True True True False False - - --- We read the various -no-show-*-of-hole-fits flags --- and set the display config accordingly. -getHoleFitDispConfig :: TcM HoleFitDispConfig -getHoleFitDispConfig - = do { sWrap <- goptM Opt_ShowTypeAppOfHoleFits - ; sWrapVars <- goptM Opt_ShowTypeAppVarsOfHoleFits - ; sType <- goptM Opt_ShowTypeOfHoleFits - ; sProv <- goptM Opt_ShowProvOfHoleFits - ; sMatc <- goptM Opt_ShowMatchesOfHoleFits - ; return HFDC{ showWrap = sWrap, showWrapVars = sWrapVars - , showProv = sProv, showType = sType - , showMatches = sMatc } } - --- Which sorting algorithm to use -data SortingAlg = NoSorting -- Do not sort the fits at all - | BySize -- Sort them by the size of the match - | BySubsumption -- Sort by full subsumption - deriving (Eq, Ord) - -getSortingAlg :: TcM SortingAlg -getSortingAlg = - do { shouldSort <- goptM Opt_SortValidHoleFits - ; subsumSort <- goptM Opt_SortBySubsumHoleFits - ; sizeSort <- goptM Opt_SortBySizeHoleFits - -- We default to sizeSort unless it has been explicitly turned off - -- or subsumption sorting has been turned on. - ; return $ if not shouldSort - then NoSorting - else if subsumSort - then BySubsumption - else if sizeSort - then BySize - else NoSorting } - --- If enabled, we go through the fits and add any associated documentation, --- by looking it up in the module or the environment (for local fits) -addDocs :: [HoleFit] -> TcM [HoleFit] -addDocs fits = - do { showDocs <- goptM Opt_ShowDocsOfHoleFits - ; if showDocs - then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv - ; mapM (upd lclDocs) fits } - else return fits } - where - msg = text "TcHoleErrors addDocs" - lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap }) - = Map.lookup name dmap - upd lclDocs fit@(HoleFit {hfCand = cand}) = - do { let name = getName cand - ; doc <- if hfIsLcl fit - then pure (Map.lookup name lclDocs) - else do { mbIface <- loadInterfaceForNameMaybe msg name - ; return $ mbIface >>= lookupInIface name } - ; return $ fit {hfDoc = doc} } - upd _ fit = return fit - --- For pretty printing hole fits, we display the name and type of the fit, --- with added '_' to represent any extra arguments in case of a non-zero --- refinement level. -pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc -pprHoleFit _ (RawHoleFit sd) = sd -pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = - hang display 2 provenance - where name = getName hfCand - tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap - where pprArg b arg = case binderArgFlag b of - Specified -> text "@" <> pprParendType arg - -- Do not print type application for inferred - -- variables (#16456) - Inferred -> empty - Required -> pprPanic "pprHoleFit: bad Required" - (ppr b <+> ppr arg) - tyAppVars = sep $ punctuate comma $ - zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+> - text "~" <+> pprParendType t) - vars hfWrap - - vars = unwrapTypeVars hfType - where - -- Attempts to get all the quantified type variables in a type, - -- e.g. - -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) - -- into [m, a] - unwrapTypeVars :: Type -> [TyCoVarBinder] - unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of - Just (_, unfunned) -> unwrapTypeVars unfunned - _ -> [] - where (vars, unforalled) = splitForAllVarBndrs t - holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches - holeDisp = if sMs then holeVs - else sep $ replicate (length hfMatches) $ text "_" - occDisp = pprPrefixOcc name - tyDisp = ppWhen sTy $ dcolon <+> ppr hfType - has = not . null - wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars)) - $ text "with" <+> if sWrp || not sTy - then occDisp <+> tyApp - else tyAppVars - docs = case hfDoc of - Just d -> text "{-^" <> - (vcat . map text . lines . unpackHDS) d - <> text "-}" - _ -> empty - funcInfo = ppWhen (has hfMatches && sTy) $ - text "where" <+> occDisp <+> tyDisp - subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp - display = subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp) - provenance = ppWhen sProv $ parens $ - case hfCand of - GreHFCand gre -> pprNameProvenance gre - _ -> text "bound at" <+> ppr (getSrcLoc name) - -getLocalBindings :: TidyEnv -> Ct -> TcM [Id] -getLocalBindings tidy_orig ct - = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin loc) - ; go env1 [] (removeBindingShadowing $ tcl_bndrs lcl_env) } - where - loc = ctEvLoc (ctEvidence ct) - lcl_env = ctLocEnv loc - - go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id] - go _ sofar [] = return (reverse sofar) - go env sofar (tc_bndr : tc_bndrs) = - case tc_bndr of - TcIdBndr id _ -> keep_it id - _ -> discard_it - where - discard_it = go env sofar tc_bndrs - keep_it id = go env (id:sofar) tc_bndrs - - - --- See Note [Valid hole fits include ...] -findValidHoleFits :: TidyEnv -- ^ The tidy_env for zonking - -> [Implication] -- ^ Enclosing implications for givens - -> [Ct] - -- ^ The unsolved simple constraints in the implication for - -- the hole. - -> Ct -- ^ The hole constraint itself - -> TcM (TidyEnv, SDoc) -findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct = - do { rdr_env <- getGlobalRdrEnv - ; lclBinds <- getLocalBindings tidy_env ct - ; maxVSubs <- maxValidHoleFits <$> getDynFlags - ; hfdc <- getHoleFitDispConfig - ; sortingAlg <- getSortingAlg - ; dflags <- getDynFlags - ; hfPlugs <- tcg_hf_plugins <$> getGblEnv - ; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs - refLevel = refLevelHoleFits dflags - hole = TyH (listToBag relevantCts) implics (Just ct) - (candidatePlugins, fitPlugins) = - unzip $ map (\p-> ((candPlugin p) hole, (fitPlugin p) hole)) hfPlugs - ; traceTc "findingValidHoleFitsFor { " $ ppr hole - ; traceTc "hole_lvl is:" $ ppr hole_lvl - ; traceTc "simples are: " $ ppr simples - ; traceTc "locals are: " $ ppr lclBinds - ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env) - -- We remove binding shadowings here, but only for the local level. - -- this is so we e.g. suggest the global fmap from the Functor class - -- even though there is a local definition as well, such as in the - -- Free monad example. - locals = removeBindingShadowing $ - map IdHFCand lclBinds ++ map GreHFCand lcl - globals = map GreHFCand gbl - syntax = map NameHFCand builtIns - to_check = locals ++ syntax ++ globals - ; cands <- foldM (flip ($)) to_check candidatePlugins - ; traceTc "numPlugins are:" $ ppr (length candidatePlugins) - ; (searchDiscards, subs) <- - tcFilterHoleFits findVLimit hole (hole_ty, []) cands - ; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs - ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs - ; plugin_handled_subs <- foldM (flip ($)) tidy_sorted_subs fitPlugins - ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs - vDiscards = pVDisc || searchDiscards - ; subs_with_docs <- addDocs limited_subs - ; let vMsg = ppUnless (null subs_with_docs) $ - hang (text "Valid hole fits include") 2 $ - vcat (map (pprHoleFit hfdc) subs_with_docs) - $$ ppWhen vDiscards subsDiscardMsg - -- Refinement hole fits. See Note [Valid refinement hole fits include ...] - ; (tidy_env, refMsg) <- if refLevel >= Just 0 then - do { maxRSubs <- maxRefHoleFits <$> getDynFlags - -- We can use from just, since we know that Nothing >= _ is False. - ; let refLvls = [1..(fromJust refLevel)] - -- We make a new refinement type for each level of refinement, where - -- the level of refinement indicates number of additional arguments - -- to allow. - ; ref_tys <- mapM mkRefTy refLvls - ; traceTc "ref_tys are" $ ppr ref_tys - ; let findRLimit = if sortingAlg > NoSorting then Nothing - else maxRSubs - ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole) - cands) ref_tys - ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs - ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs - -- For refinement substitutions we want matches - -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t), - -- and others in that vein to appear last, since these are - -- unlikely to be the most relevant fits. - ; (tidy_env, tidy_hole_ty) <- zonkTidyTcType tidy_env hole_ty - ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap - (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs - ; plugin_handled_rsubs <- foldM (flip ($)) - (not_exact ++ exact) fitPlugins - ; let (pRDisc, exact_last_rfits) = - possiblyDiscard maxRSubs $ plugin_handled_rsubs - rDiscards = pRDisc || any fst refDs - ; rsubs_with_docs <- addDocs exact_last_rfits - ; return (tidy_env, - ppUnless (null rsubs_with_docs) $ - hang (text "Valid refinement hole fits include") 2 $ - vcat (map (pprHoleFit hfdc) rsubs_with_docs) - $$ ppWhen rDiscards refSubsDiscardMsg) } - else return (tidy_env, empty) - ; traceTc "findingValidHoleFitsFor }" empty - ; return (tidy_env, vMsg $$ refMsg) } - where - -- We extract the type, the tcLevel and the types free variables - -- from from the constraint. - hole_ty :: TcPredType - hole_ty = ctPred ct - hole_fvs :: FV - hole_fvs = tyCoFVsOfType hole_ty - hole_lvl = ctLocLevel $ ctEvLoc $ ctEvidence ct - - -- BuiltInSyntax names like (:) and [] - builtIns :: [Name] - builtIns = filter isBuiltInSyntax knownKeyNames - - -- We make a refinement type by adding a new type variable in front - -- of the type of t h hole, going from e.g. [Integer] -> Integer - -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier - -- to unify the new type variable with any type, allowing us - -- to suggest a "refinement hole fit", like `(foldl1 _)` instead - -- of only concrete hole fits like `sum`. - mkRefTy :: Int -> TcM (TcType, [TcTyVar]) - mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars - where newTyVars = replicateM refLvl $ setLvl <$> - (newOpenTypeKind >>= newFlexiTyVar) - setLvl = flip setMetaTyVarTcLevel hole_lvl - wrapWithVars vars = mkVisFunTys (map mkTyVarTy vars) hole_ty - - sortFits :: SortingAlg -- How we should sort the hole fits - -> [HoleFit] -- The subs to sort - -> TcM [HoleFit] - sortFits NoSorting subs = return subs - sortFits BySize subs - = (++) <$> sortBySize (sort lclFits) - <*> sortBySize (sort gblFits) - where (lclFits, gblFits) = span hfIsLcl subs - - -- To sort by subsumption, we invoke the sortByGraph function, which - -- builds the subsumption graph for the fits and then sorts them using a - -- graph sort. Since we want locals to come first anyway, we can sort - -- them separately. The substitutions are already checked in local then - -- global order, so we can get away with using span here. - -- We use (<*>) to expose the parallelism, in case it becomes useful later. - sortFits BySubsumption subs - = (++) <$> sortByGraph (sort lclFits) - <*> sortByGraph (sort gblFits) - where (lclFits, gblFits) = span hfIsLcl subs - - -- See Note [Relevant Constraints] - relevantCts :: [Ct] - relevantCts = if isEmptyVarSet (fvVarSet hole_fvs) then [] - else filter isRelevant simples - where ctFreeVarSet :: Ct -> VarSet - ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred - hole_fv_set = fvVarSet hole_fvs - anyFVMentioned :: Ct -> Bool - anyFVMentioned ct = not $ isEmptyVarSet $ - ctFreeVarSet ct `intersectVarSet` hole_fv_set - -- We filter out those constraints that have no variables (since - -- they won't be solved by finding a type for the type variable - -- representing the hole) and also other holes, since we're not - -- trying to find hole fits for many holes at once. - isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct)) - && anyFVMentioned ct - && not (isHoleCt ct) - - -- We zonk the hole fits so that the output aligns with the rest - -- of the typed hole error message output. - zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit]) - zonkSubs = zonkSubs' [] - where zonkSubs' zs env [] = return (env, reverse zs) - zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf - ; zonkSubs' (z:zs) env' hfs } - - zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit) - zonkSub env hf@RawHoleFit{} = return (env, hf) - zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp} - = do { (env, ty') <- zonkTidyTcType env ty - ; (env, m') <- zonkTidyTcTypes env m - ; (env, wrp') <- zonkTidyTcTypes env wrp - ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'} - ; return (env, zFit ) } - - -- Based on the flags, we might possibly discard some or all the - -- fits we've found. - possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit]) - possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits) - possiblyDiscard Nothing fits = (False, fits) - - -- Sort by size uses as a measure for relevance the sizes of the - -- different types needed to instantiate the fit to the type of the hole. - -- This is much quicker than sorting by subsumption, and gives reasonable - -- results in most cases. - sortBySize :: [HoleFit] -> TcM [HoleFit] - sortBySize = return . sortOn sizeOfFit - where sizeOfFit :: HoleFit -> TypeSize - sizeOfFit = sizeTypes . nubBy tcEqType . hfWrap - - -- Based on a suggestion by phadej on #ghc, we can sort the found fits - -- by constructing a subsumption graph, and then do a topological sort of - -- the graph. This makes the most specific types appear first, which are - -- probably those most relevant. This takes a lot of work (but results in - -- much more useful output), and can be disabled by - -- '-fno-sort-valid-hole-fits'. - sortByGraph :: [HoleFit] -> TcM [HoleFit] - sortByGraph fits = go [] fits - where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool - tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty) - where fvs = tyCoFVsOfTypes [ht,ty] - go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit] - go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar - ; return $ uncurry (++) - $ partition hfIsLcl topSorted } - where toV (hf, adjs) = (hf, hfId hf, map hfId adjs) - (graph, fromV, _) = graphFromEdges $ map toV sofar - topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph - go sofar (hf:hfs) = - do { adjs <- - filterM (tcSubsumesWCloning (hfType hf) . hfType) fits - ; go ((hf, adjs):sofar) hfs } - --- We don't (as of yet) handle holes in types, only in expressions. -findValidHoleFits env _ _ _ = return (env, empty) - - --- | tcFilterHoleFits filters the candidates by whether, given the implications --- and the relevant constraints, they can be made to match the type by --- running the type checker. Stops after finding limit matches. -tcFilterHoleFits :: Maybe Int - -- ^ How many we should output, if limited - -> TypedHole -- ^ The hole to filter against - -> (TcType, [TcTyVar]) - -- ^ The type to check for fits and a list of refinement - -- variables (free type variables in the type) for emulating - -- additional holes. - -> [HoleFitCandidate] - -- ^ The candidates to check whether fit. - -> TcM (Bool, [HoleFit]) - -- ^ We return whether or not we stopped due to hitting the limit - -- and the fits we found. -tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0 -tcFilterHoleFits limit (TyH {..}) ht@(hole_ty, _) candidates = - do { traceTc "checkingFitsFor {" $ ppr hole_ty - ; (discards, subs) <- go [] emptyVarSet limit ht candidates - ; traceTc "checkingFitsFor }" empty - ; return (discards, subs) } - where - hole_fvs :: FV - hole_fvs = tyCoFVsOfType hole_ty - -- Kickoff the checking of the elements. - -- We iterate over the elements, checking each one in turn for whether - -- it fits, and adding it to the results if it does. - go :: [HoleFit] -- What we've found so far. - -> VarSet -- Ids we've already checked - -> Maybe Int -- How many we're allowed to find, if limited - -> (TcType, [TcTyVar]) -- The type, and its refinement variables. - -> [HoleFitCandidate] -- The elements we've yet to check. - -> TcM (Bool, [HoleFit]) - go subs _ _ _ [] = return (False, reverse subs) - go subs _ (Just 0) _ _ = return (True, reverse subs) - go subs seen maxleft ty (el:elts) = - -- See Note [Leaking errors] - tryTcDiscardingErrs discard_it $ - do { traceTc "lookingUp" $ ppr el - ; maybeThing <- lookup el - ; case maybeThing of - Just id | not_trivial id -> - do { fits <- fitsHole ty (idType id) - ; case fits of - Just (wrp, matches) -> keep_it id wrp matches - _ -> discard_it } - _ -> discard_it } - where - -- We want to filter out undefined and the likes from GHC.Err - not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR - - lookup :: HoleFitCandidate -> TcM (Maybe Id) - lookup (IdHFCand id) = return (Just id) - lookup hfc = do { thing <- tcLookup name - ; return $ case thing of - ATcId {tct_id = id} -> Just id - AGlobal (AnId id) -> Just id - AGlobal (AConLike (RealDataCon con)) -> - Just (dataConWrapId con) - _ -> Nothing } - where name = case hfc of - IdHFCand id -> idName id - GreHFCand gre -> gre_name gre - NameHFCand name -> name - discard_it = go subs seen maxleft ty elts - keep_it eid wrp ms = go (fit:subs) (extendVarSet seen eid) - ((\n -> n - 1) <$> maxleft) ty elts - where - fit = HoleFit { hfId = eid, hfCand = el, hfType = (idType eid) - , hfRefLvl = length (snd ty) - , hfWrap = wrp, hfMatches = ms - , hfDoc = Nothing } - - - - - unfoldWrapper :: HsWrapper -> [Type] - unfoldWrapper = reverse . unfWrp' - where unfWrp' (WpTyApp ty) = [ty] - unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2 - unfWrp' _ = [] - - - -- The real work happens here, where we invoke the type checker using - -- tcCheckHoleFit to see whether the given type fits the hole. - fitsHole :: (TcType, [TcTyVar]) -- The type of the hole wrapped with the - -- refinement variables created to simulate - -- additional holes (if any), and the list - -- of those variables (possibly empty). - -- As an example: If the actual type of the - -- hole (as specified by the hole - -- constraint CHoleExpr passed to - -- findValidHoleFits) is t and we want to - -- simulate N additional holes, h_ty will - -- be r_1 -> ... -> r_N -> t, and - -- ref_vars will be [r_1, ... , r_N]. - -- In the base case with no additional - -- holes, h_ty will just be t and ref_vars - -- will be []. - -> TcType -- The type we're checking to whether it can be - -- instantiated to the type h_ty. - -> TcM (Maybe ([TcType], [TcType])) -- If it is not a match, we - -- return Nothing. Otherwise, - -- we Just return the list of - -- types that quantified type - -- variables in ty would take - -- if used in place of h_ty, - -- and the list types of any - -- additional holes simulated - -- with the refinement - -- variables in ref_vars. - fitsHole (h_ty, ref_vars) ty = - -- We wrap this with the withoutUnification to avoid having side-effects - -- beyond the check, but we rely on the side-effects when looking for - -- refinement hole fits, so we can't wrap the side-effects deeper than this. - withoutUnification fvs $ - do { traceTc "checkingFitOf {" $ ppr ty - ; (fits, wrp) <- tcCheckHoleFit hole h_ty ty - ; traceTc "Did it fit?" $ ppr fits - ; traceTc "wrap is: " $ ppr wrp - ; traceTc "checkingFitOf }" empty - ; z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp) - -- We'd like to avoid refinement suggestions like `id _ _` or - -- `head _ _`, and only suggest refinements where our all phantom - -- variables got unified during the checking. This can be disabled - -- with the `-fabstract-refinement-hole-fits` flag. - -- Here we do the additional handling when there are refinement - -- variables, i.e. zonk them to read their final value to check for - -- abstract refinements, and to report what the type of the simulated - -- holes must be for this to be a match. - ; if fits - then if null ref_vars - then return (Just (z_wrp_tys, [])) - else do { let -- To be concrete matches, matches have to - -- be more than just an invented type variable. - fvSet = fvVarSet fvs - notAbstract :: TcType -> Bool - notAbstract t = case getTyVar_maybe t of - Just tv -> tv `elemVarSet` fvSet - _ -> True - allConcrete = all notAbstract z_wrp_tys - ; z_vars <- zonkTcTyVars ref_vars - ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars - ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs - ; allowAbstract <- goptM Opt_AbstractRefHoleFits - ; if allowAbstract || (allFilled && allConcrete ) - then return $ Just (z_wrp_tys, z_vars) - else return Nothing } - else return Nothing } - where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty - hole = TyH tyHRelevantCts tyHImplics Nothing - - -subsDiscardMsg :: SDoc -subsDiscardMsg = - text "(Some hole fits suppressed;" <+> - text "use -fmax-valid-hole-fits=N" <+> - text "or -fno-max-valid-hole-fits)" - -refSubsDiscardMsg :: SDoc -refSubsDiscardMsg = - text "(Some refinement hole fits suppressed;" <+> - text "use -fmax-refinement-hole-fits=N" <+> - text "or -fno-max-refinement-hole-fits)" - - --- | Checks whether a MetaTyVar is flexible or not. -isFlexiTyVar :: TcTyVar -> TcM Bool -isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv -isFlexiTyVar _ = return False - --- | Takes a list of free variables and restores any Flexi type variables in --- free_vars after the action is run. -withoutUnification :: FV -> TcM a -> TcM a -withoutUnification free_vars action = - do { flexis <- filterM isFlexiTyVar fuvs - ; result <- action - -- Reset any mutated free variables - ; mapM_ restore flexis - ; return result } - where restore = flip writeTcRef Flexi . metaTyVarRef - fuvs = fvVarList free_vars - --- | Reports whether first type (ty_a) subsumes the second type (ty_b), --- discarding any errors. Subsumption here means that the ty_b can fit into the --- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a. -tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool -tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b - where dummyHole = TyH emptyBag [] Nothing - --- | A tcSubsumes which takes into account relevant constraints, to fix trac --- #14273. This makes sure that when checking whether a type fits the hole, --- the type has to be subsumed by type of the hole as well as fulfill all --- constraints on the type of the hole. --- Note: The simplifier may perform unification, so make sure to restore any --- free type variables to avoid side-effects. -tcCheckHoleFit :: TypedHole -- ^ The hole to check against - -> TcSigmaType - -- ^ The type to check against (possibly modified, e.g. refined) - -> TcSigmaType -- ^ The type to check whether fits. - -> TcM (Bool, HsWrapper) - -- ^ Whether it was a match, and the wrapper from hole_ty to ty. -tcCheckHoleFit _ hole_ty ty | hole_ty `eqType` ty - = return (True, idHsWrapper) -tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $ - do { -- We wrap the subtype constraint in the implications to pass along the - -- givens, and so we must ensure that any nested implications and skolems - -- end up with the correct level. The implications are ordered so that - -- the innermost (the one with the highest level) is first, so it - -- suffices to get the level of the first one (or the current level, if - -- there are no implications involved). - innermost_lvl <- case tyHImplics of - [] -> getTcLevel - -- imp is the innermost implication - (imp:_) -> return (ic_tclvl imp) - ; (wrp, wanted) <- setTcLevel innermost_lvl $ captureConstraints $ - tcSubType_NC ExprSigCtxt ty hole_ty - ; traceTc "Checking hole fit {" empty - ; traceTc "wanteds are: " $ ppr wanted - ; if isEmptyWC wanted && isEmptyBag tyHRelevantCts - then traceTc "}" empty >> return (True, wrp) - else do { fresh_binds <- newTcEvBinds - -- The relevant constraints may contain HoleDests, so we must - -- take care to clone them as well (to avoid #15370). - ; cloned_relevants <- mapBagM cloneWanted tyHRelevantCts - -- We wrap the WC in the nested implications, see - -- Note [Nested Implications] - ; let outermost_first = reverse tyHImplics - setWC = setWCAndBinds fresh_binds - -- We add the cloned relevants to the wanteds generated by - -- the call to tcSubType_NC, see Note [Relevant Constraints] - -- There's no need to clone the wanteds, because they are - -- freshly generated by `tcSubtype_NC`. - w_rel_cts = addSimples wanted cloned_relevants - w_givens = foldr setWC w_rel_cts outermost_first - ; traceTc "w_givens are: " $ ppr w_givens - ; rem <- runTcSDeriveds $ simpl_top w_givens - -- We don't want any insoluble or simple constraints left, but - -- solved implications are ok (and necessary for e.g. undefined) - ; traceTc "rems was:" $ ppr rem - ; traceTc "}" empty - ; return (isSolvedWC rem, wrp) } } - where - setWCAndBinds :: EvBindsVar -- Fresh ev binds var. - -> Implication -- The implication to put WC in. - -> WantedConstraints -- The WC constraints to put implic. - -> WantedConstraints -- The new constraints. - setWCAndBinds binds imp wc - = WC { wc_simple = emptyBag - , wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } } - --- | Maps a plugin that needs no state to one with an empty one. -fromPureHFPlugin :: HoleFitPlugin -> HoleFitPluginR -fromPureHFPlugin plug = - HoleFitPluginR { hfPluginInit = newTcRef () - , hfPluginRun = const plug - , hfPluginStop = const $ return () } diff --git a/compiler/typecheck/TcHoleErrors.hs-boot b/compiler/typecheck/TcHoleErrors.hs-boot deleted file mode 100644 index 9c5df86489..0000000000 --- a/compiler/typecheck/TcHoleErrors.hs-boot +++ /dev/null @@ -1,13 +0,0 @@ --- This boot file is in place to break the loop where: --- + TcSimplify calls 'TcErrors.reportUnsolved', --- + which calls 'TcHoleErrors.findValidHoleFits` --- + which calls 'TcSimplify.simpl_top' -module TcHoleErrors where - -import TcRnTypes ( TcM ) -import Constraint ( Ct, Implication ) -import Outputable ( SDoc ) -import GHC.Types.Var.Env ( TidyEnv ) - -findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct - -> TcM (TidyEnv, SDoc) diff --git a/compiler/typecheck/TcHoleFitTypes.hs b/compiler/typecheck/TcHoleFitTypes.hs deleted file mode 100644 index d27aa8fef7..0000000000 --- a/compiler/typecheck/TcHoleFitTypes.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module TcHoleFitTypes ( - TypedHole (..), HoleFit (..), HoleFitCandidate (..), - CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..), - hfIsLcl, pprHoleFitCand - ) where - -import GhcPrelude - -import TcRnTypes -import Constraint -import TcType - -import GHC.Types.Name.Reader - -import GHC.Hs.Doc -import GHC.Types.Id - -import Outputable -import GHC.Types.Name - -import Data.Function ( on ) - -data TypedHole = TyH { tyHRelevantCts :: Cts - -- ^ Any relevant Cts to the hole - , tyHImplics :: [Implication] - -- ^ The nested implications of the hole with the - -- innermost implication first. - , tyHCt :: Maybe Ct - -- ^ The hole constraint itself, if available. - } - -instance Outputable TypedHole where - ppr (TyH rels implics ct) - = hang (text "TypedHole") 2 - (ppr rels $+$ ppr implics $+$ ppr ct) - - --- | HoleFitCandidates are passed to hole fit plugins and then --- checked whether they fit a given typed-hole. -data HoleFitCandidate = IdHFCand Id -- An id, like locals. - | NameHFCand Name -- A name, like built-in syntax. - | GreHFCand GlobalRdrElt -- A global, like imported ids. - deriving (Eq) - -instance Outputable HoleFitCandidate where - ppr = pprHoleFitCand - -pprHoleFitCand :: HoleFitCandidate -> SDoc -pprHoleFitCand (IdHFCand cid) = text "Id HFC: " <> ppr cid -pprHoleFitCand (NameHFCand cname) = text "Name HFC: " <> ppr cname -pprHoleFitCand (GreHFCand cgre) = text "Gre HFC: " <> ppr cgre - - - - -instance NamedThing HoleFitCandidate where - getName hfc = case hfc of - IdHFCand cid -> idName cid - NameHFCand cname -> cname - GreHFCand cgre -> gre_name cgre - getOccName hfc = case hfc of - IdHFCand cid -> occName cid - NameHFCand cname -> occName cname - GreHFCand cgre -> occName (gre_name cgre) - -instance HasOccName HoleFitCandidate where - occName = getOccName - -instance Ord HoleFitCandidate where - compare = compare `on` getName - --- | HoleFit is the type we use for valid hole fits. It contains the --- element that was checked, the Id of that element as found by `tcLookup`, --- and the refinement level of the fit, which is the number of extra argument --- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`). -data HoleFit = - HoleFit { hfId :: Id -- ^ The elements id in the TcM - , hfCand :: HoleFitCandidate -- ^ The candidate that was checked. - , hfType :: TcType -- ^ The type of the id, possibly zonked. - , hfRefLvl :: Int -- ^ The number of holes in this fit. - , hfWrap :: [TcType] -- ^ The wrapper for the match. - , hfMatches :: [TcType] - -- ^ What the refinement variables got matched with, if anything - , hfDoc :: Maybe HsDocString - -- ^ Documentation of this HoleFit, if available. - } - | RawHoleFit SDoc - -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins - -- can inject any fit they want. - --- We define an Eq and Ord instance to be able to build a graph. -instance Eq HoleFit where - (==) = (==) `on` hfId - -instance Outputable HoleFit where - ppr (RawHoleFit sd) = sd - ppr (HoleFit _ cand ty _ _ mtchs _) = - hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty)) - where name = ppr $ getName cand - holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs - --- We compare HoleFits by their name instead of their Id, since we don't --- want our tests to be affected by the non-determinism of `nonDetCmpVar`, --- which is used to compare Ids. When comparing, we want HoleFits with a lower --- refinement level to come first. -instance Ord HoleFit where - compare (RawHoleFit _) (RawHoleFit _) = EQ - compare (RawHoleFit _) _ = LT - compare _ (RawHoleFit _) = GT - compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b - where cmp = if hfRefLvl a == hfRefLvl b - then compare `on` (getName . hfCand) - else compare `on` hfRefLvl - -hfIsLcl :: HoleFit -> Bool -hfIsLcl hf@(HoleFit {}) = case hfCand hf of - IdHFCand _ -> True - NameHFCand _ -> False - GreHFCand gre -> gre_lcl gre -hfIsLcl _ = False - - --- | A plugin for modifying the candidate hole fits *before* they're checked. -type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate] - --- | A plugin for modifying hole fits *after* they've been found. -type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit] - --- | A HoleFitPlugin is a pair of candidate and fit plugins. -data HoleFitPlugin = HoleFitPlugin - { candPlugin :: CandPlugin - , fitPlugin :: FitPlugin } - --- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can --- track internal state. Note the existential quantification, ensuring that --- the state cannot be modified from outside the plugin. -data HoleFitPluginR = forall s. HoleFitPluginR - { hfPluginInit :: TcM (TcRef s) - -- ^ Initializes the TcRef to be passed to the plugin - , hfPluginRun :: TcRef s -> HoleFitPlugin - -- ^ The function defining the plugin itself - , hfPluginStop :: TcRef s -> TcM () - -- ^ Cleanup of state, guaranteed to be called even on error - } diff --git a/compiler/typecheck/TcHoleFitTypes.hs-boot b/compiler/typecheck/TcHoleFitTypes.hs-boot deleted file mode 100644 index fde064e51a..0000000000 --- a/compiler/typecheck/TcHoleFitTypes.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ --- This boot file is in place to break the loop where: --- + TcRnTypes needs 'HoleFitPlugin', --- + which needs 'TcHoleFitTypes' --- + which needs 'TcRnTypes' -module TcHoleFitTypes where - --- Build ordering -import GHC.Base() - -data HoleFitPlugin diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs deleted file mode 100644 index da6f0a39e1..0000000000 --- a/compiler/typecheck/TcHsSyn.hs +++ /dev/null @@ -1,1921 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - - -TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker - -This module is an extension of @HsSyn@ syntax, for use in the type -checker. --} - -{-# LANGUAGE CPP, TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcHsSyn ( - -- * Extracting types from HsSyn - hsLitType, hsPatType, hsLPatType, - - -- * Other HsSyn functions - mkHsDictLet, mkHsApp, - mkHsAppTy, mkHsCaseAlt, - shortCutLit, hsOverLitName, - conLikeResTy, - - -- * re-exported from TcMonad - TcId, TcIdSet, - - -- * Zonking - -- | For a description of "zonking", see Note [What is zonking?] - -- in TcMType - zonkTopDecls, zonkTopExpr, zonkTopLExpr, - zonkTopBndrs, - ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv, - zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX, - zonkTyBndrs, zonkTyBndrsX, - zonkTcTypeToType, zonkTcTypeToTypeX, - zonkTcTypesToTypes, zonkTcTypesToTypesX, - zonkTyVarOcc, - zonkCoToCo, - zonkEvBinds, zonkTcEvBinds, - zonkTcMethInfoToMethInfoX, - lookupTyVarOcc - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Core.Predicate -import TcRnMonad -import PrelNames -import BuildTyCl ( TcMethInfo, MethInfo ) -import TcType -import TcMType -import TcEnv ( tcLookupGlobalOnly ) -import TcEvidence -import GHC.Core.TyCo.Ppr ( pprTyVar ) -import TysPrim -import GHC.Core.TyCon -import TysWiredIn -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Driver.Types -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Platform -import GHC.Types.Basic -import Maybes -import GHC.Types.SrcLoc -import Bag -import Outputable -import Util -import GHC.Types.Unique.FM -import GHC.Core - -import {-# SOURCE #-} TcSplice (runTopSplice) - -import Control.Monad -import Data.List ( partition ) -import Control.Arrow ( second ) - -{- -************************************************************************ -* * - Extracting the type from HsSyn -* * -************************************************************************ - --} - -hsLPatType :: LPat GhcTc -> Type -hsLPatType (L _ p) = hsPatType p - -hsPatType :: Pat GhcTc -> Type -hsPatType (ParPat _ pat) = hsLPatType pat -hsPatType (WildPat ty) = ty -hsPatType (VarPat _ lvar) = idType (unLoc lvar) -hsPatType (BangPat _ pat) = hsLPatType pat -hsPatType (LazyPat _ pat) = hsLPatType pat -hsPatType (LitPat _ lit) = hsLitType lit -hsPatType (AsPat _ var _) = idType (unLoc var) -hsPatType (ViewPat ty _ _) = ty -hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty -hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty -hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make -hsPatType (SumPat tys _ _ _ ) = mkSumTy tys -hsPatType (ConPatOut { pat_con = lcon - , pat_arg_tys = tys }) - = conLikeResTy (unLoc lcon) tys -hsPatType (SigPat ty _ _) = ty -hsPatType (NPat ty _ _ _) = ty -hsPatType (NPlusKPat ty _ _ _ _ _) = ty -hsPatType (CoPat _ _ _ ty) = ty -hsPatType (XPat n) = noExtCon n -hsPatType ConPatIn{} = panic "hsPatType: ConPatIn" -hsPatType SplicePat{} = panic "hsPatType: SplicePat" - -hsLitType :: HsLit (GhcPass p) -> TcType -hsLitType (HsChar _ _) = charTy -hsLitType (HsCharPrim _ _) = charPrimTy -hsLitType (HsString _ _) = stringTy -hsLitType (HsStringPrim _ _) = addrPrimTy -hsLitType (HsInt _ _) = intTy -hsLitType (HsIntPrim _ _) = intPrimTy -hsLitType (HsWordPrim _ _) = wordPrimTy -hsLitType (HsInt64Prim _ _) = int64PrimTy -hsLitType (HsWord64Prim _ _) = word64PrimTy -hsLitType (HsInteger _ _ ty) = ty -hsLitType (HsRat _ _ ty) = ty -hsLitType (HsFloatPrim _ _) = floatPrimTy -hsLitType (HsDoublePrim _ _) = doublePrimTy -hsLitType (XLit nec) = noExtCon nec - --- Overloaded literals. Here mainly because it uses isIntTy etc - -shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) -shortCutLit platform (HsIntegral int@(IL src neg i)) ty - | isIntTy ty && platformInIntRange platform i = Just (HsLit noExtField (HsInt noExtField int)) - | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i)) - | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty)) - | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty - -- The 'otherwise' case is important - -- Consider (3 :: Float). Syntactically it looks like an IntLit, - -- so we'll call shortCutIntLit, but of course it's a float - -- This can make a big difference for programs with a lot of - -- literals, compiled without -O - -shortCutLit _ (HsFractional f) ty - | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) - | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) - | otherwise = Nothing - -shortCutLit _ (HsIsString src s) ty - | isStringTy ty = Just (HsLit noExtField (HsString src s)) - | otherwise = Nothing - -mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc -mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) - ------------------------------- -hsOverLitName :: OverLitVal -> Name --- Get the canonical 'fromX' name for a particular OverLitVal -hsOverLitName (HsIntegral {}) = fromIntegerName -hsOverLitName (HsFractional {}) = fromRationalName -hsOverLitName (HsIsString {}) = fromStringName - -{- -************************************************************************ -* * -\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} -* * -************************************************************************ - -The rest of the zonking is done *after* typechecking. -The main zonking pass runs over the bindings - - a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc - b) convert unbound TcTyVar to Void - c) convert each TcId to an Id by zonking its type - -The type variables are converted by binding mutable tyvars to immutable ones -and then zonking as normal. - -The Ids are converted by binding them in the normal Tc envt; that -way we maintain sharing; eg an Id is zonked at its binding site and they -all occurrences of that Id point to the common zonked copy - -It's all pretty boring stuff, because HsSyn is such a large type, and -the environment manipulation is tiresome. --} - --- Confused by zonking? See Note [What is zonking?] in TcMType. - --- | See Note [The ZonkEnv] --- Confused by zonking? See Note [What is zonking?] in TcMType. -data ZonkEnv -- See Note [The ZonkEnv] - = ZonkEnv { ze_flexi :: ZonkFlexi - , ze_tv_env :: TyCoVarEnv TyCoVar - , ze_id_env :: IdEnv Id - , ze_meta_tv_env :: TcRef (TyVarEnv Type) } - -{- Note [The ZonkEnv] -~~~~~~~~~~~~~~~~~~~~~ -* ze_flexi :: ZonkFlexi says what to do with a - unification variable that is still un-unified. - See Note [Un-unified unification variables] - -* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site - of a tyvar or covar, we zonk the kind right away and add a mapping - to the env. This prevents re-zonking the kind at every - occurrence. But this is *just* an optimisation. - -* ze_id_env : IdEnv Id promotes sharing among Ids, by making all - occurrences of the Id point to a single zonked copy, built at the - binding site. - - Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec. - In a mutually recursive group - rec { f = ...g...; g = ...f... } - we want the occurrence of g to point to the one zonked Id for g, - and the same for f. - - Because it is knot-tied, we must be careful to consult it lazily. - Specifically, zonkIdOcc is not monadic. - -* ze_meta_tv_env: see Note [Sharing when zonking to Type] - - -Notes: - * We must be careful never to put coercion variables (which are Ids, - after all) in the knot-tied ze_id_env, because coercions can - appear in types, and we sometimes inspect a zonked type in this - module. [Question: where, precisely?] - - * In zonkTyVarOcc we consult ze_tv_env in a monadic context, - a second reason that ze_tv_env can't be monadic. - - * An obvious suggestion would be to have one VarEnv Var to - replace both ze_id_env and ze_tv_env, but that doesn't work - because of the knot-tying stuff mentioned above. - -Note [Un-unified unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should we do if we find a Flexi unification variable? -There are three possibilities: - -* DefaultFlexi: this is the common case, in situations like - length @alpha ([] @alpha) - It really doesn't matter what type we choose for alpha. But - we must choose a type! We can't leave mutable unification - variables floating around: after typecheck is complete, every - type variable occurrence must have a binding site. - - So we default it to 'Any' of the right kind. - - All this works for both type and kind variables (indeed - the two are the same thing). - -* SkolemiseFlexi: is a special case for the LHS of RULES. - See Note [Zonking the LHS of a RULE] - -* RuntimeUnkFlexi: is a special case for the GHCi debugger. - It's a way to have a variable that is not a mutable - unification variable, but doesn't have a binding site - either. --} - -data ZonkFlexi -- See Note [Un-unified unification variables] - = DefaultFlexi -- Default unbound unification variables to Any - | SkolemiseFlexi -- Skolemise unbound unification variables - -- See Note [Zonking the LHS of a RULE] - | RuntimeUnkFlexi -- Used in the GHCi debugger - -instance Outputable ZonkEnv where - ppr (ZonkEnv { ze_tv_env = tv_env - , ze_id_env = id_env }) - = text "ZE" <+> braces (vcat - [ text "ze_tv_env =" <+> ppr tv_env - , text "ze_id_env =" <+> ppr id_env ]) - --- The EvBinds have to already be zonked, but that's usually the case. -emptyZonkEnv :: TcM ZonkEnv -emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi - -mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv -mkEmptyZonkEnv flexi - = do { mtv_env_ref <- newTcRef emptyVarEnv - ; return (ZonkEnv { ze_flexi = flexi - , ze_tv_env = emptyVarEnv - , ze_id_env = emptyVarEnv - , ze_meta_tv_env = mtv_env_ref }) } - -initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b -initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi - ; thing_inside ze } - --- | Extend the knot-tied environment. -extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv -extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids - -- NB: Don't look at the var to decide which env't to put it in. That - -- would end up knot-tying all the env'ts. - = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } - -- Given coercion variables will actually end up here. That's OK though: - -- coercion variables are never looked up in the knot-tied env't, so zonking - -- them simply doesn't get optimised. No one gets hurt. An improvement (?) - -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the - -- recursive groups. But perhaps the time it takes to do the analysis is - -- more than the savings. - -extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv -extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars - = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars] - , ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } - where - (tycovars, ids) = partition isTyCoVar vars - -extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv -extendIdZonkEnv ze@(ZonkEnv { ze_id_env = id_env }) id - = ze { ze_id_env = extendVarEnv id_env id id } - -extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv -extendTyZonkEnv ze@(ZonkEnv { ze_tv_env = ty_env }) tv - = ze { ze_tv_env = extendVarEnv ty_env tv tv } - -setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv -setZonkType ze flexi = ze { ze_flexi = flexi } - -zonkEnvIds :: ZonkEnv -> TypeEnv -zonkEnvIds (ZonkEnv { ze_id_env = id_env}) - = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env] - -- It's OK to use nonDetEltsUFM here because we forget the ordering - -- immediately by creating a TypeEnv - -zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id -zonkLIdOcc env = mapLoc (zonkIdOcc env) - -zonkIdOcc :: ZonkEnv -> TcId -> Id --- Ids defined in this module should be in the envt; --- ignore others. (Actually, data constructors are also --- not LocalVars, even when locally defined, but that is fine.) --- (Also foreign-imported things aren't currently in the ZonkEnv; --- that's ok because they don't need zonking.) --- --- Actually, Template Haskell works in 'chunks' of declarations, and --- an earlier chunk won't be in the 'env' that the zonking phase --- carries around. Instead it'll be in the tcg_gbl_env, already fully --- zonked. There's no point in looking it up there (except for error --- checking), and it's not conveniently to hand; hence the simple --- 'orElse' case in the LocalVar branch. --- --- Even without template splices, in module Main, the checking of --- 'main' is done as a separate chunk. -zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id - | isLocalVar id = lookupVarEnv id_env id `orElse` - id - | otherwise = id - -zonkIdOccs :: ZonkEnv -> [TcId] -> [Id] -zonkIdOccs env ids = map (zonkIdOcc env) ids - --- zonkIdBndr is used *after* typechecking to get the Id's type --- to its final form. The TyVarEnv give -zonkIdBndr :: ZonkEnv -> TcId -> TcM Id -zonkIdBndr env v - = do ty' <- zonkTcTypeToTypeX env (idType v) - ensureNotLevPoly ty' - (text "In the type of binder" <+> quotes (ppr v)) - - return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty')) - -zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] -zonkIdBndrs env ids = mapM (zonkIdBndr env) ids - -zonkTopBndrs :: [TcId] -> TcM [Id] -zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids - -zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc) -zonkFieldOcc env (FieldOcc sel lbl) - = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel -zonkFieldOcc _ (XFieldOcc nec) = noExtCon nec - -zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) -zonkEvBndrsX = mapAccumLM zonkEvBndrX - -zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar) --- Works for dictionaries and coercions -zonkEvBndrX env var - = do { var' <- zonkEvBndr env var - ; return (extendZonkEnv env [var'], var') } - -zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar --- Works for dictionaries and coercions --- Does not extend the ZonkEnv -zonkEvBndr env var - = do { let var_ty = varType var - ; ty <- - {-# SCC "zonkEvBndr_zonkTcTypeToType" #-} - zonkTcTypeToTypeX env var_ty - ; return (setVarType var ty) } - -{- -zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm -zonkEvVarOcc env v - | isCoVar v - = EvCoercion <$> zonkCoVarOcc env v - | otherwise - = return (EvId $ zonkIdOcc env v) --} - -zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var) -zonkCoreBndrX env v - | isId v = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv env v', v') } - | otherwise = zonkTyBndrX env v - -zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var]) -zonkCoreBndrsX = mapAccumLM zonkCoreBndrX - -zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar]) -zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs - -zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar]) -zonkTyBndrsX = mapAccumLM zonkTyBndrX - -zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar) --- This guarantees to return a TyVar (not a TcTyVar) --- then we add it to the envt, so all occurrences are replaced --- --- It does not clone: the new TyVar has the sane Name --- as the old one. This important when zonking the --- TyVarBndrs of a TyCon, whose Names may scope. -zonkTyBndrX env tv - = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) ) - do { ki <- zonkTcTypeToTypeX env (tyVarKind tv) - -- Internal names tidy up better, for iface files. - ; let tv' = mkTyVar (tyVarName tv) ki - ; return (extendTyZonkEnv env tv', tv') } - -zonkTyVarBinders :: [VarBndr TcTyVar vis] - -> TcM (ZonkEnv, [VarBndr TyVar vis]) -zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs - -zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis] - -> TcM (ZonkEnv, [VarBndr TyVar vis]) -zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX - -zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis - -> TcM (ZonkEnv, VarBndr TyVar vis) --- Takes a TcTyVar and guarantees to return a TyVar -zonkTyVarBinderX env (Bndr tv vis) - = do { (env', tv') <- zonkTyBndrX env tv - ; return (env', Bndr tv' vis) } - -zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc) -zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e - -zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc) -zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e - -zonkTopDecls :: Bag EvBind - -> LHsBinds GhcTcId - -> [LRuleDecl GhcTcId] -> [LTcSpecPrag] - -> [LForeignDecl GhcTcId] - -> TcM (TypeEnv, - Bag EvBind, - LHsBinds GhcTc, - [LForeignDecl GhcTc], - [LTcSpecPrag], - [LRuleDecl GhcTc]) -zonkTopDecls ev_binds binds rules imp_specs fords - = do { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds - ; (env2, binds') <- zonkRecMonoBinds env1 binds - -- Top level is implicitly recursive - ; rules' <- zonkRules env2 rules - ; specs' <- zonkLTcSpecPrags env2 imp_specs - ; fords' <- zonkForeignExports env2 fords - ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } - ---------------------------------------------- -zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId - -> TcM (ZonkEnv, HsLocalBinds GhcTc) -zonkLocalBinds env (EmptyLocalBinds x) - = return (env, (EmptyLocalBinds x)) - -zonkLocalBinds _ (HsValBinds _ (ValBinds {})) - = panic "zonkLocalBinds" -- Not in typechecker output - -zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs))) - = do { (env1, new_binds) <- go env binds - ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) } - where - go env [] - = return (env, []) - go env ((r,b):bs) - = do { (env1, b') <- zonkRecMonoBinds env b - ; (env2, bs') <- go env1 bs - ; return (env2, (r,b'):bs') } - -zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do - new_binds <- mapM (wrapLocM zonk_ip_bind) binds - let - env1 = extendIdZonkEnvRec env - [ n | (L _ (IPBind _ (Right n) _)) <- new_binds] - (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds - return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) - where - zonk_ip_bind (IPBind x n e) - = do n' <- mapIPNameTc (zonkIdBndr env) n - e' <- zonkLExpr env e - return (IPBind x n' e') - zonk_ip_bind (XIPBind nec) = noExtCon nec - -zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds nec)) - = noExtCon nec -zonkLocalBinds _ (XHsLocalBindsLR nec) - = noExtCon nec - ---------------------------------------------- -zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc) -zonkRecMonoBinds env binds - = fixM (\ ~(_, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds) - ; binds' <- zonkMonoBinds env1 binds - ; return (env1, binds') }) - ---------------------------------------------- -zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc) -zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds - -zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc) -zonk_lbind env = wrapLocM (zonk_bind env) - -zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc) -zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss - , pat_ext = NPatBindTc fvs ty}) - = do { (_env, new_pat) <- zonkPat env pat -- Env already extended - ; new_grhss <- zonkGRHSs env zonkLExpr grhss - ; new_ty <- zonkTcTypeToTypeX env ty - ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss - , pat_ext = NPatBindTc fvs new_ty }) } - -zonk_bind env (VarBind { var_ext = x - , var_id = var, var_rhs = expr }) - = do { new_var <- zonkIdBndr env var - ; new_expr <- zonkLExpr env expr - ; return (VarBind { var_ext = x - , var_id = new_var - , var_rhs = new_expr }) } - -zonk_bind env bind@(FunBind { fun_id = L loc var - , fun_matches = ms - , fun_ext = co_fn }) - = do { new_var <- zonkIdBndr env var - ; (env1, new_co_fn) <- zonkCoFn env co_fn - ; new_ms <- zonkMatchGroup env1 zonkLExpr ms - ; return (bind { fun_id = L loc new_var - , fun_matches = new_ms - , fun_ext = new_co_fn }) } - -zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs - , abs_ev_binds = ev_binds - , abs_exports = exports - , abs_binds = val_binds - , abs_sig = has_sig }) - = ASSERT( all isImmutableTyVar tyvars ) - do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds - ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> - do { let env3 = extendIdZonkEnvRec env2 $ - collectHsBindsBinders new_val_binds - ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds - ; new_exports <- mapM (zonk_export env3) exports - ; return (new_val_binds, new_exports) } - ; return (AbsBinds { abs_ext = noExtField - , abs_tvs = new_tyvars, abs_ev_vars = new_evs - , abs_ev_binds = new_ev_binds - , abs_exports = new_exports, abs_binds = new_val_bind - , abs_sig = has_sig }) } - where - zonk_val_bind env lbind - | has_sig - , (L loc bind@(FunBind { fun_id = L mloc mono_id - , fun_matches = ms - , fun_ext = co_fn })) <- lbind - = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id - -- Specifically /not/ zonkIdBndr; we do not - -- want to complain about a levity-polymorphic binder - ; (env', new_co_fn) <- zonkCoFn env co_fn - ; new_ms <- zonkMatchGroup env' zonkLExpr ms - ; return $ L loc $ - bind { fun_id = L mloc new_mono_id - , fun_matches = new_ms - , fun_ext = new_co_fn } } - | otherwise - = zonk_lbind env lbind -- The normal case - - zonk_export env (ABE{ abe_ext = x - , abe_wrap = wrap - , abe_poly = poly_id - , abe_mono = mono_id - , abe_prags = prags }) - = do new_poly_id <- zonkIdBndr env poly_id - (_, new_wrap) <- zonkCoFn env wrap - new_prags <- zonkSpecPrags env prags - return (ABE{ abe_ext = x - , abe_wrap = new_wrap - , abe_poly = new_poly_id - , abe_mono = zonkIdOcc env mono_id - , abe_prags = new_prags }) - zonk_export _ (XABExport nec) = noExtCon nec - -zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id - , psb_args = details - , psb_def = lpat - , psb_dir = dir })) - = do { id' <- zonkIdBndr env id - ; (env1, lpat') <- zonkPat env lpat - ; let details' = zonkPatSynDetails env1 details - ; (_env2, dir') <- zonkPatSynDir env1 dir - ; return $ PatSynBind x $ - bind { psb_id = L loc id' - , psb_args = details' - , psb_def = lpat' - , psb_dir = dir' } } - -zonk_bind _ (PatSynBind _ (XPatSynBind nec)) = noExtCon nec -zonk_bind _ (XHsBindsLR nec) = noExtCon nec - -zonkPatSynDetails :: ZonkEnv - -> HsPatSynDetails (Located TcId) - -> HsPatSynDetails (Located Id) -zonkPatSynDetails env (PrefixCon as) - = PrefixCon (map (zonkLIdOcc env) as) -zonkPatSynDetails env (InfixCon a1 a2) - = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2) -zonkPatSynDetails env (RecCon flds) - = RecCon (map (fmap (zonkLIdOcc env)) flds) - -zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId - -> TcM (ZonkEnv, HsPatSynDir GhcTc) -zonkPatSynDir env Unidirectional = return (env, Unidirectional) -zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional) -zonkPatSynDir env (ExplicitBidirectional mg) = do - mg' <- zonkMatchGroup env zonkLExpr mg - return (env, ExplicitBidirectional mg') - -zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags -zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod -zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps - ; return (SpecPrags ps') } - -zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] -zonkLTcSpecPrags env ps - = mapM zonk_prag ps - where - zonk_prag (L loc (SpecPrag id co_fn inl)) - = do { (_, co_fn') <- zonkCoFn env co_fn - ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } - -{- -************************************************************************ -* * -\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} -* * -************************************************************************ --} - -zonkMatchGroup :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> MatchGroup GhcTcId (Located (body GhcTcId)) - -> TcM (MatchGroup GhcTc (Located (body GhcTc))) -zonkMatchGroup env zBody (MG { mg_alts = L l ms - , mg_ext = MatchGroupTc arg_tys res_ty - , mg_origin = origin }) - = do { ms' <- mapM (zonkMatch env zBody) ms - ; arg_tys' <- zonkTcTypesToTypesX env arg_tys - ; res_ty' <- zonkTcTypeToTypeX env res_ty - ; return (MG { mg_alts = L l ms' - , mg_ext = MatchGroupTc arg_tys' res_ty' - , mg_origin = origin }) } -zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec - -zonkMatch :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> LMatch GhcTcId (Located (body GhcTcId)) - -> TcM (LMatch GhcTc (Located (body GhcTc))) -zonkMatch env zBody (L loc match@(Match { m_pats = pats - , m_grhss = grhss })) - = do { (env1, new_pats) <- zonkPats env pats - ; new_grhss <- zonkGRHSs env1 zBody grhss - ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } -zonkMatch _ _ (L _ (XMatch nec)) = noExtCon nec - -------------------------------------------------------------------------- -zonkGRHSs :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> GRHSs GhcTcId (Located (body GhcTcId)) - -> TcM (GRHSs GhcTc (Located (body GhcTc))) - -zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do - (new_env, new_binds) <- zonkLocalBinds env binds - let - zonk_grhs (GRHS xx guarded rhs) - = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded - new_rhs <- zBody env2 rhs - return (GRHS xx new_guarded new_rhs) - zonk_grhs (XGRHS nec) = noExtCon nec - new_grhss <- mapM (wrapLocM zonk_grhs) grhss - return (GRHSs x new_grhss (L l new_binds)) -zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec - -{- -************************************************************************ -* * -\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} -* * -************************************************************************ --} - -zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc] -zonkLExpr :: ZonkEnv -> LHsExpr GhcTcId -> TcM (LHsExpr GhcTc) -zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc) - -zonkLExprs env exprs = mapM (zonkLExpr env) exprs -zonkLExpr env expr = wrapLocM (zonkExpr env) expr - -zonkExpr env (HsVar x (L l id)) - = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) - return (HsVar x (L l (zonkIdOcc env id))) - -zonkExpr _ e@(HsConLikeOut {}) = return e - -zonkExpr _ (HsIPVar x id) - = return (HsIPVar x id) - -zonkExpr _ e@HsOverLabel{} = return e - -zonkExpr env (HsLit x (HsRat e f ty)) - = do new_ty <- zonkTcTypeToTypeX env ty - return (HsLit x (HsRat e f new_ty)) - -zonkExpr _ (HsLit x lit) - = return (HsLit x lit) - -zonkExpr env (HsOverLit x lit) - = do { lit' <- zonkOverLit env lit - ; return (HsOverLit x lit') } - -zonkExpr env (HsLam x matches) - = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLam x new_matches) - -zonkExpr env (HsLamCase x matches) - = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLamCase x new_matches) - -zonkExpr env (HsApp x e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (HsApp x new_e1 new_e2) - -zonkExpr env (HsAppType x e t) - = do new_e <- zonkLExpr env e - return (HsAppType x new_e t) - -- NB: the type is an HsType; can't zonk that! - -zonkExpr _ e@(HsRnBracketOut _ _ _) - = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) - -zonkExpr env (HsTcBracketOut x wrap body bs) - = do wrap' <- traverse zonkQuoteWrap wrap - bs' <- mapM (zonk_b env) bs - return (HsTcBracketOut x wrap' body bs') - where - zonkQuoteWrap (QuoteWrapper ev ty) = do - let ev' = zonkIdOcc env ev - ty' <- zonkTcTypeToTypeX env ty - return (QuoteWrapper ev' ty') - - zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e - return (PendingTcSplice n e') - -zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) = - runTopSplice s >>= zonkExpr env - -zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e) - -zonkExpr env (OpApp fixity e1 op e2) - = do new_e1 <- zonkLExpr env e1 - new_op <- zonkLExpr env op - new_e2 <- zonkLExpr env e2 - return (OpApp fixity new_e1 new_op new_e2) - -zonkExpr env (NegApp x expr op) - = do (env', new_op) <- zonkSyntaxExpr env op - new_expr <- zonkLExpr env' expr - return (NegApp x new_expr new_op) - -zonkExpr env (HsPar x e) - = do new_e <- zonkLExpr env e - return (HsPar x new_e) - -zonkExpr env (SectionL x expr op) - = do new_expr <- zonkLExpr env expr - new_op <- zonkLExpr env op - return (SectionL x new_expr new_op) - -zonkExpr env (SectionR x op expr) - = do new_op <- zonkLExpr env op - new_expr <- zonkLExpr env expr - return (SectionR x new_op new_expr) - -zonkExpr env (ExplicitTuple x tup_args boxed) - = do { new_tup_args <- mapM zonk_tup_arg tup_args - ; return (ExplicitTuple x new_tup_args boxed) } - where - zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e - ; return (L l (Present x e')) } - zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t - ; return (L l (Missing t')) } - zonk_tup_arg (L _ (XTupArg nec)) = noExtCon nec - - -zonkExpr env (ExplicitSum args alt arity expr) - = do new_args <- mapM (zonkTcTypeToTypeX env) args - new_expr <- zonkLExpr env expr - return (ExplicitSum new_args alt arity new_expr) - -zonkExpr env (HsCase x expr ms) - = do new_expr <- zonkLExpr env expr - new_ms <- zonkMatchGroup env zonkLExpr ms - return (HsCase x new_expr new_ms) - -zonkExpr env (HsIf x fun e1 e2 e3) - = do (env1, new_fun) <- zonkSyntaxExpr env fun - new_e1 <- zonkLExpr env1 e1 - new_e2 <- zonkLExpr env1 e2 - new_e3 <- zonkLExpr env1 e3 - return (HsIf x new_fun new_e1 new_e2 new_e3) - -zonkExpr env (HsMultiIf ty alts) - = do { alts' <- mapM (wrapLocM zonk_alt) alts - ; ty' <- zonkTcTypeToTypeX env ty - ; return $ HsMultiIf ty' alts' } - where zonk_alt (GRHS x guard expr) - = do { (env', guard') <- zonkStmts env zonkLExpr guard - ; expr' <- zonkLExpr env' expr - ; return $ GRHS x guard' expr' } - zonk_alt (XGRHS nec) = noExtCon nec - -zonkExpr env (HsLet x (L l binds) expr) - = do (new_env, new_binds) <- zonkLocalBinds env binds - new_expr <- zonkLExpr new_env expr - return (HsLet x (L l new_binds) new_expr) - -zonkExpr env (HsDo ty do_or_lc (L l stmts)) - = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts - new_ty <- zonkTcTypeToTypeX env ty - return (HsDo new_ty do_or_lc (L l new_stmts)) - -zonkExpr env (ExplicitList ty wit exprs) - = do (env1, new_wit) <- zonkWit env wit - new_ty <- zonkTcTypeToTypeX env1 ty - new_exprs <- zonkLExprs env1 exprs - return (ExplicitList new_ty new_wit new_exprs) - where zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln - -zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds }) - = do { new_con_expr <- zonkExpr env (rcon_con_expr ext) - ; new_rbinds <- zonkRecFields env rbinds - ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr } - , rcon_flds = new_rbinds }) } - -zonkExpr env (RecordUpd { rupd_flds = rbinds - , rupd_expr = expr - , rupd_ext = RecordUpdTc - { rupd_cons = cons, rupd_in_tys = in_tys - , rupd_out_tys = out_tys, rupd_wrap = req_wrap }}) - = do { new_expr <- zonkLExpr env expr - ; new_in_tys <- mapM (zonkTcTypeToTypeX env) in_tys - ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys - ; new_rbinds <- zonkRecUpdFields env rbinds - ; (_, new_recwrap) <- zonkCoFn env req_wrap - ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds - , rupd_ext = RecordUpdTc - { rupd_cons = cons, rupd_in_tys = new_in_tys - , rupd_out_tys = new_out_tys - , rupd_wrap = new_recwrap }}) } - -zonkExpr env (ExprWithTySig _ e ty) - = do { e' <- zonkLExpr env e - ; return (ExprWithTySig noExtField e' ty) } - -zonkExpr env (ArithSeq expr wit info) - = do (env1, new_wit) <- zonkWit env wit - new_expr <- zonkExpr env expr - new_info <- zonkArithSeq env1 info - return (ArithSeq new_expr new_wit new_info) - where zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln - -zonkExpr env (HsPragE x prag expr) - = do new_expr <- zonkLExpr env expr - return (HsPragE x prag new_expr) - --- arrow notation extensions -zonkExpr env (HsProc x pat body) - = do { (env1, new_pat) <- zonkPat env pat - ; new_body <- zonkCmdTop env1 body - ; return (HsProc x new_pat new_body) } - --- StaticPointers extension -zonkExpr env (HsStatic fvs expr) - = HsStatic fvs <$> zonkLExpr env expr - -zonkExpr env (XExpr (HsWrap co_fn expr)) - = do (env1, new_co_fn) <- zonkCoFn env co_fn - new_expr <- zonkExpr env1 expr - return (XExpr (HsWrap new_co_fn new_expr)) - -zonkExpr _ e@(HsUnboundVar {}) - = return e - -zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) - -------------------------------------------------------------------------- -{- -Note [Skolems in zonkSyntaxExpr] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider rebindable syntax with something like - - (>>=) :: (forall x. blah) -> (forall y. blah') -> blah'' - -The x and y become skolems that are in scope when type-checking the -arguments to the bind. This means that we must extend the ZonkEnv with -these skolems when zonking the arguments to the bind. But the skolems -are different between the two arguments, and so we should theoretically -carry around different environments to use for the different arguments. - -However, this becomes a logistical nightmare, especially in dealing with -the more exotic Stmt forms. So, we simplify by making the critical -assumption that the uniques of the skolems are different. (This assumption -is justified by the use of newUnique in TcMType.instSkolTyCoVarX.) -Now, we can safely just extend one environment. --} - --- See Note [Skolems in zonkSyntaxExpr] -zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId - -> TcM (ZonkEnv, SyntaxExpr GhcTc) -zonkSyntaxExpr env (SyntaxExprTc { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - = do { (env0, res_wrap') <- zonkCoFn env res_wrap - ; expr' <- zonkExpr env0 expr - ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps - ; return (env1, SyntaxExprTc { syn_expr = expr' - , syn_arg_wraps = arg_wraps' - , syn_res_wrap = res_wrap' }) } -zonkSyntaxExpr env NoSyntaxExprTc = return (env, NoSyntaxExprTc) - -------------------------------------------------------------------------- - -zonkLCmd :: ZonkEnv -> LHsCmd GhcTcId -> TcM (LHsCmd GhcTc) -zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc) - -zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd - -zonkCmd env (XCmd (HsWrap w cmd)) - = do { (env1, w') <- zonkCoFn env w - ; cmd' <- zonkCmd env1 cmd - ; return (XCmd (HsWrap w' cmd')) } -zonkCmd env (HsCmdArrApp ty e1 e2 ho rl) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_ty <- zonkTcTypeToTypeX env ty - return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) - -zonkCmd env (HsCmdArrForm x op f fixity args) - = do new_op <- zonkLExpr env op - new_args <- mapM (zonkCmdTop env) args - return (HsCmdArrForm x new_op f fixity new_args) - -zonkCmd env (HsCmdApp x c e) - = do new_c <- zonkLCmd env c - new_e <- zonkLExpr env e - return (HsCmdApp x new_c new_e) - -zonkCmd env (HsCmdLam x matches) - = do new_matches <- zonkMatchGroup env zonkLCmd matches - return (HsCmdLam x new_matches) - -zonkCmd env (HsCmdPar x c) - = do new_c <- zonkLCmd env c - return (HsCmdPar x new_c) - -zonkCmd env (HsCmdCase x expr ms) - = do new_expr <- zonkLExpr env expr - new_ms <- zonkMatchGroup env zonkLCmd ms - return (HsCmdCase x new_expr new_ms) - -zonkCmd env (HsCmdIf x eCond ePred cThen cElse) - = do { (env1, new_eCond) <- zonkSyntaxExpr env eCond - ; new_ePred <- zonkLExpr env1 ePred - ; new_cThen <- zonkLCmd env1 cThen - ; new_cElse <- zonkLCmd env1 cElse - ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } - -zonkCmd env (HsCmdLet x (L l binds) cmd) - = do (new_env, new_binds) <- zonkLocalBinds env binds - new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet x (L l new_binds) new_cmd) - -zonkCmd env (HsCmdDo ty (L l stmts)) - = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts - new_ty <- zonkTcTypeToTypeX env ty - return (HsCmdDo new_ty (L l new_stmts)) - - - -zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc) -zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd - -zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc) -zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) - = do new_cmd <- zonkLCmd env cmd - new_stack_tys <- zonkTcTypeToTypeX env stack_tys - new_ty <- zonkTcTypeToTypeX env ty - new_ids <- mapSndM (zonkExpr env) ids - - MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) ) - -- desugarer assumes that this is not levity polymorphic... - -- but indeed it should always be lifted due to the typing - -- rules for arrows - - return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) -zonk_cmd_top _ (XCmdTop nec) = noExtCon nec - -------------------------------------------------------------------------- -zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) -zonkCoFn env WpHole = return (env, WpHole) -zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; t1' <- zonkTcTypeToTypeX env2 t1 - ; return (env2, WpFun c1' c2' t1' d) } -zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co - ; return (env, WpCast co') } -zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev - ; return (env', WpEvLam ev') } -zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg - ; return (env, WpEvApp arg') } -zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) - do { (env', tv') <- zonkTyBndrX env tv - ; return (env', WpTyLam tv') } -zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToTypeX env ty - ; return (env, WpTyApp ty') } -zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs - ; return (env1, WpLet bs') } - -------------------------------------------------------------------------- -zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc) -zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e }) - = do { ty' <- zonkTcTypeToTypeX env ty - ; e' <- zonkExpr env e - ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) } - -zonkOverLit _ (XOverLit nec) = noExtCon nec - -------------------------------------------------------------------------- -zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc) - -zonkArithSeq env (From e) - = do new_e <- zonkLExpr env e - return (From new_e) - -zonkArithSeq env (FromThen e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (FromThen new_e1 new_e2) - -zonkArithSeq env (FromTo e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (FromTo new_e1 new_e2) - -zonkArithSeq env (FromThenTo e1 e2 e3) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_e3 <- zonkLExpr env e3 - return (FromThenTo new_e1 new_e2 new_e3) - - -------------------------------------------------------------------------- -zonkStmts :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> [LStmt GhcTcId (Located (body GhcTcId))] - -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))]) -zonkStmts env _ [] = return (env, []) -zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s - ; (env2, ss') <- zonkStmts env1 zBody ss - ; return (env2, s' : ss') } - -zonkStmt :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) - -> Stmt GhcTcId (Located (body GhcTcId)) - -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc))) -zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) - = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op - ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty - ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs - ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs - , b <- bs] - env2 = extendIdZonkEnvRec env1 new_binders - ; new_mzip <- zonkExpr env2 mzip_op - ; return (env2 - , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)} - where - zonk_branch env1 (ParStmtBlock x stmts bndrs return_op) - = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts - ; (env3, new_return) <- zonkSyntaxExpr env2 return_op - ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs) - new_return) } - zonk_branch _ (XParStmtBlock nec) = noExtCon nec - -zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs - , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id - , recS_bind_fn = bind_id - , recS_ext = - RecStmtTc { recS_bind_ty = bind_ty - , recS_later_rets = later_rets - , recS_rec_rets = rec_rets - , recS_ret_ty = ret_ty} }) - = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id - ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id - ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id - ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty - ; new_rvs <- zonkIdBndrs env3 rvs - ; new_lvs <- zonkIdBndrs env3 lvs - ; new_ret_ty <- zonkTcTypeToTypeX env3 ret_ty - ; let env4 = extendIdZonkEnvRec env3 new_rvs - ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts - -- Zonk the ret-expressions in an envt that - -- has the polymorphic bindings in the envt - ; new_later_rets <- mapM (zonkExpr env5) later_rets - ; new_rec_rets <- mapM (zonkExpr env5) rec_rets - ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed - RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs - , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id - , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_ext = RecStmtTc - { recS_bind_ty = new_bind_ty - , recS_later_rets = new_later_rets - , recS_rec_rets = new_rec_rets - , recS_ret_ty = new_ret_ty } }) } - -zonkStmt env zBody (BodyStmt ty body then_op guard_op) - = do (env1, new_then_op) <- zonkSyntaxExpr env then_op - (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op - new_body <- zBody env2 body - new_ty <- zonkTcTypeToTypeX env2 ty - return (env2, BodyStmt new_ty new_body new_then_op new_guard_op) - -zonkStmt env zBody (LastStmt x body noret ret_op) - = do (env1, new_ret) <- zonkSyntaxExpr env ret_op - new_body <- zBody env1 body - return (env, LastStmt x new_body noret new_ret) - -zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap - , trS_by = by, trS_form = form, trS_using = using - , trS_ret = return_op, trS_bind = bind_op - , trS_ext = bind_arg_ty - , trS_fmap = liftM_op }) - = do { - ; (env1, bind_op') <- zonkSyntaxExpr env bind_op - ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty - ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts - ; by' <- fmapMaybeM (zonkLExpr env2) by - ; using' <- zonkLExpr env2 using - - ; (env3, return_op') <- zonkSyntaxExpr env2 return_op - ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap - ; liftM_op' <- zonkExpr env3 liftM_op - ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap') - ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' - , trS_by = by', trS_form = form, trS_using = using' - , trS_ret = return_op', trS_bind = bind_op' - , trS_ext = bind_arg_ty' - , trS_fmap = liftM_op' }) } - where - zonkBinderMapEntry env (oldBinder, newBinder) = do - let oldBinder' = zonkIdOcc env oldBinder - newBinder' <- zonkIdBndr env newBinder - return (oldBinder', newBinder') - -zonkStmt env _ (LetStmt x (L l binds)) - = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt x (L l new_binds)) - -zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op) - = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op - ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty - ; new_body <- zBody env1 body - ; (env2, new_pat) <- zonkPat env1 pat - ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op - ; return ( env2 - , BindStmt new_bind_ty new_pat new_body new_bind new_fail) } - --- Scopes: join > ops (in reverse order) > pats (in forward order) --- > rest of stmts -zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) - = do { (env1, new_mb_join) <- zonk_join env mb_join - ; (env2, new_args) <- zonk_args env1 args - ; new_body_ty <- zonkTcTypeToTypeX env2 body_ty - ; return ( env2 - , ApplicativeStmt new_body_ty new_args new_mb_join) } - where - zonk_join env Nothing = return (env, Nothing) - zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j - - get_pat (_, ApplicativeArgOne _ pat _ _ _) = pat - get_pat (_, ApplicativeArgMany _ _ _ pat) = pat - get_pat (_, XApplicativeArg nec) = noExtCon nec - - replace_pat pat (op, ApplicativeArgOne x _ a isBody fail_op) - = (op, ApplicativeArgOne x pat a isBody fail_op) - replace_pat pat (op, ApplicativeArgMany x a b _) - = (op, ApplicativeArgMany x a b pat) - replace_pat _ (_, XApplicativeArg nec) = noExtCon nec - - zonk_args env args - = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args) - ; (env2, new_pats) <- zonkPats env1 (map get_pat args) - ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) } - - -- these need to go backward, because if any operators are higher-rank, - -- later operators may introduce skolems that are in scope for earlier - -- arguments - zonk_args_rev env ((op, arg) : args) - = do { (env1, new_op) <- zonkSyntaxExpr env op - ; new_arg <- zonk_arg env1 arg - ; (env2, new_args) <- zonk_args_rev env1 args - ; return (env2, (new_op, new_arg) : new_args) } - zonk_args_rev env [] = return (env, []) - - zonk_arg env (ApplicativeArgOne x pat expr isBody fail_op) - = do { new_expr <- zonkLExpr env expr - ; (_, new_fail) <- zonkSyntaxExpr env fail_op - ; return (ApplicativeArgOne x pat new_expr isBody new_fail) } - zonk_arg env (ApplicativeArgMany x stmts ret pat) - = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts - ; new_ret <- zonkExpr env1 ret - ; return (ApplicativeArgMany x new_stmts new_ret pat) } - zonk_arg _ (XApplicativeArg nec) = noExtCon nec - -zonkStmt _ _ (XStmtLR nec) = noExtCon nec - -------------------------------------------------------------------------- -zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId) -zonkRecFields env (HsRecFields flds dd) - = do { flds' <- mapM zonk_rbind flds - ; return (HsRecFields flds' dd) } - where - zonk_rbind (L l fld) - = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld) - ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldLbl = new_id - , hsRecFieldArg = new_expr })) } - -zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId] - -> TcM [LHsRecUpdField GhcTcId] -zonkRecUpdFields env = mapM zonk_rbind - where - zonk_rbind (L l fld) - = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) - ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id - , hsRecFieldArg = new_expr })) } - -------------------------------------------------------------------------- -mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a - -> TcM (Either (Located HsIPName) b) -mapIPNameTc _ (Left x) = return (Left x) -mapIPNameTc f (Right x) = do r <- f x - return (Right r) - -{- -************************************************************************ -* * -\subsection[BackSubst-Pats]{Patterns} -* * -************************************************************************ --} - -zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc) --- Extend the environment as we go, because it's possible for one --- pattern to bind something that is used in another (inside or --- to the right) -zonkPat env pat = wrapLocSndM (zonk_pat env) pat - -zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc) -zonk_pat env (ParPat x p) - = do { (env', p') <- zonkPat env p - ; return (env', ParPat x p') } - -zonk_pat env (WildPat ty) - = do { ty' <- zonkTcTypeToTypeX env ty - ; ensureNotLevPoly ty' - (text "In a wildcard pattern") - ; return (env, WildPat ty') } - -zonk_pat env (VarPat x (L l v)) - = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv env v', VarPat x (L l v')) } - -zonk_pat env (LazyPat x pat) - = do { (env', pat') <- zonkPat env pat - ; return (env', LazyPat x pat') } - -zonk_pat env (BangPat x pat) - = do { (env', pat') <- zonkPat env pat - ; return (env', BangPat x pat') } - -zonk_pat env (AsPat x (L loc v) pat) - = do { v' <- zonkIdBndr env v - ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat - ; return (env', AsPat x (L loc v') pat') } - -zonk_pat env (ViewPat ty expr pat) - = do { expr' <- zonkLExpr env expr - ; (env', pat') <- zonkPat env pat - ; ty' <- zonkTcTypeToTypeX env ty - ; return (env', ViewPat ty' expr' pat') } - -zonk_pat env (ListPat (ListPatTc ty Nothing) pats) - = do { ty' <- zonkTcTypeToTypeX env ty - ; (env', pats') <- zonkPats env pats - ; return (env', ListPat (ListPatTc ty' Nothing) pats') } - -zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats) - = do { (env', wit') <- zonkSyntaxExpr env wit - ; ty2' <- zonkTcTypeToTypeX env' ty2 - ; ty' <- zonkTcTypeToTypeX env' ty - ; (env'', pats') <- zonkPats env' pats - ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') } - -zonk_pat env (TuplePat tys pats boxed) - = do { tys' <- mapM (zonkTcTypeToTypeX env) tys - ; (env', pats') <- zonkPats env pats - ; return (env', TuplePat tys' pats' boxed) } - -zonk_pat env (SumPat tys pat alt arity ) - = do { tys' <- mapM (zonkTcTypeToTypeX env) tys - ; (env', pat') <- zonkPat env pat - ; return (env', SumPat tys' pat' alt arity) } - -zonk_pat env p@(ConPatOut { pat_arg_tys = tys - , pat_tvs = tyvars - , pat_dicts = evs - , pat_binds = binds - , pat_args = args - , pat_wrap = wrapper - , pat_con = L _ con }) - = ASSERT( all isImmutableTyVar tyvars ) - do { new_tys <- mapM (zonkTcTypeToTypeX env) tys - - -- an unboxed tuple pattern (but only an unboxed tuple pattern) - -- might have levity-polymorphic arguments. Check for this badness. - ; case con of - RealDataCon dc - | isUnboxedTupleTyCon (dataConTyCon dc) - -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys) - _ -> return () - - ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars - -- Must zonk the existential variables, because their - -- /kind/ need potential zonking. - -- cf typecheck/should_compile/tc221.hs - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_binds) <- zonkTcEvBinds env1 binds - ; (env3, new_wrapper) <- zonkCoFn env2 wrapper - ; (env', new_args) <- zonkConStuff env3 args - ; return (env', p { pat_arg_tys = new_tys, - pat_tvs = new_tyvars, - pat_dicts = new_evs, - pat_binds = new_binds, - pat_args = new_args, - pat_wrap = new_wrapper}) } - where - doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p - -zonk_pat env (LitPat x lit) = return (env, LitPat x lit) - -zonk_pat env (SigPat ty pat hs_ty) - = do { ty' <- zonkTcTypeToTypeX env ty - ; (env', pat') <- zonkPat env pat - ; return (env', SigPat ty' pat' hs_ty) } - -zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) - = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr - ; (env2, mb_neg') <- case mb_neg of - Nothing -> return (env1, Nothing) - Just n -> second Just <$> zonkSyntaxExpr env1 n - - ; lit' <- zonkOverLit env2 lit - ; ty' <- zonkTcTypeToTypeX env2 ty - ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') } - -zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) - = do { (env1, e1') <- zonkSyntaxExpr env e1 - ; (env2, e2') <- zonkSyntaxExpr env1 e2 - ; n' <- zonkIdBndr env2 n - ; lit1' <- zonkOverLit env2 lit1 - ; lit2' <- zonkOverLit env2 lit2 - ; ty' <- zonkTcTypeToTypeX env2 ty - ; return (extendIdZonkEnv env2 n', - NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } - -zonk_pat env (CoPat x co_fn pat ty) - = do { (env', co_fn') <- zonkCoFn env co_fn - ; (env'', pat') <- zonkPat env' (noLoc pat) - ; ty' <- zonkTcTypeToTypeX env'' ty - ; return (env'', CoPat x co_fn' (unLoc pat') ty') } - -zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) - ---------------------------- -zonkConStuff :: ZonkEnv - -> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId)) - -> TcM (ZonkEnv, - HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc))) -zonkConStuff env (PrefixCon pats) - = do { (env', pats') <- zonkPats env pats - ; return (env', PrefixCon pats') } - -zonkConStuff env (InfixCon p1 p2) - = do { (env1, p1') <- zonkPat env p1 - ; (env', p2') <- zonkPat env1 p2 - ; return (env', InfixCon p1' p2') } - -zonkConStuff env (RecCon (HsRecFields rpats dd)) - = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats) - ; let rpats' = zipWith (\(L l rp) p' -> - L l (rp { hsRecFieldArg = p' })) - rpats pats' - ; return (env', RecCon (HsRecFields rpats' dd)) } - -- Field selectors have declared types; hence no zonking - ---------------------------- -zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat GhcTc]) -zonkPats env [] = return (env, []) -zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat - ; (env', pats') <- zonkPats env1 pats - ; return (env', pat':pats') } - -{- -************************************************************************ -* * -\subsection[BackSubst-Foreign]{Foreign exports} -* * -************************************************************************ --} - -zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTcId] - -> TcM [LForeignDecl GhcTc] -zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls - -zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc) -zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co - , fd_fe = spec }) - = return (ForeignExport { fd_name = zonkLIdOcc env i - , fd_sig_ty = undefined, fd_e_ext = co - , fd_fe = spec }) -zonkForeignExport _ for_imp - = return for_imp -- Foreign imports don't need zonking - -zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc] -zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs - -zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc) -zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} - , rd_lhs = lhs - , rd_rhs = rhs }) - = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs - - ; let env_lhs = setZonkType env_inside SkolemiseFlexi - -- See Note [Zonking the LHS of a RULE] - - ; new_lhs <- zonkLExpr env_lhs lhs - ; new_rhs <- zonkLExpr env_inside rhs - - ; return $ rule { rd_tmvs = new_tm_bndrs - , rd_lhs = new_lhs - , rd_rhs = new_rhs } } - where - zonk_tm_bndr env (L l (RuleBndr x (L loc v))) - = do { (env', v') <- zonk_it env v - ; return (env', L l (RuleBndr x (L loc v'))) } - zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" - zonk_tm_bndr _ (L _ (XRuleBndr nec)) = noExtCon nec - - zonk_it env v - | isId v = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnvRec env [v'], v') } - | otherwise = ASSERT( isImmutableTyVar v) - zonkTyBndrX env v - -- DV: used to be return (env,v) but that is plain - -- wrong because we may need to go inside the kind - -- of v and zonk there! -zonkRule _ (XRuleDecl nec) = noExtCon nec - -{- -************************************************************************ -* * - Constraints and evidence -* * -************************************************************************ --} - -zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm -zonkEvTerm env (EvExpr e) - = EvExpr <$> zonkCoreExpr env e -zonkEvTerm env (EvTypeable ty ev) - = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev -zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs - , et_binds = ev_binds, et_body = body_id }) - = do { (env0, new_tvs) <- zonkTyBndrsX env tvs - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds - ; let new_body_id = zonkIdOcc env2 body_id - ; return (EvFun { et_tvs = new_tvs, et_given = new_evs - , et_binds = new_ev_binds, et_body = new_body_id }) } - -zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr -zonkCoreExpr env (Var v) - | isCoVar v - = Coercion <$> zonkCoVarOcc env v - | otherwise - = return (Var $ zonkIdOcc env v) -zonkCoreExpr _ (Lit l) - = return $ Lit l -zonkCoreExpr env (Coercion co) - = Coercion <$> zonkCoToCo env co -zonkCoreExpr env (Type ty) - = Type <$> zonkTcTypeToTypeX env ty - -zonkCoreExpr env (Cast e co) - = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co -zonkCoreExpr env (Tick t e) - = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks? - -zonkCoreExpr env (App e1 e2) - = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2 -zonkCoreExpr env (Lam v e) - = do { (env1, v') <- zonkCoreBndrX env v - ; Lam v' <$> zonkCoreExpr env1 e } -zonkCoreExpr env (Let bind e) - = do (env1, bind') <- zonkCoreBind env bind - Let bind'<$> zonkCoreExpr env1 e -zonkCoreExpr env (Case scrut b ty alts) - = do scrut' <- zonkCoreExpr env scrut - ty' <- zonkTcTypeToTypeX env ty - b' <- zonkIdBndr env b - let env1 = extendIdZonkEnv env b' - alts' <- mapM (zonkCoreAlt env1) alts - return $ Case scrut' b' ty' alts' - -zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt -zonkCoreAlt env (dc, bndrs, rhs) - = do (env1, bndrs') <- zonkCoreBndrsX env bndrs - rhs' <- zonkCoreExpr env1 rhs - return $ (dc, bndrs', rhs') - -zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind) -zonkCoreBind env (NonRec v e) - = do v' <- zonkIdBndr env v - e' <- zonkCoreExpr env e - let env1 = extendIdZonkEnv env v' - return (env1, NonRec v' e') -zonkCoreBind env (Rec pairs) - = do (env1, pairs') <- fixM go - return (env1, Rec pairs') - where - go ~(_, new_pairs) = do - let env1 = extendIdZonkEnvRec env (map fst new_pairs) - pairs' <- mapM (zonkCorePair env1) pairs - return (env1, pairs') - -zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr) -zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e - -zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable -zonkEvTypeable env (EvTypeableTyCon tycon e) - = do { e' <- mapM (zonkEvTerm env) e - ; return $ EvTypeableTyCon tycon e' } -zonkEvTypeable env (EvTypeableTyApp t1 t2) - = do { t1' <- zonkEvTerm env t1 - ; t2' <- zonkEvTerm env t2 - ; return (EvTypeableTyApp t1' t2') } -zonkEvTypeable env (EvTypeableTrFun t1 t2) - = do { t1' <- zonkEvTerm env t1 - ; t2' <- zonkEvTerm env t2 - ; return (EvTypeableTrFun t1' t2') } -zonkEvTypeable env (EvTypeableTyLit t1) - = do { t1' <- zonkEvTerm env t1 - ; return (EvTypeableTyLit t1') } - -zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds]) -zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs - ; return (env, [EvBinds (unionManyBags bs')]) } - -zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) -zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs - ; return (env', EvBinds bs') } - -zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind) -zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var -zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs - -zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind) -zonkEvBindsVar env (EvBindsVar { ebv_binds = ref }) - = do { bs <- readMutVar ref - ; zonkEvBinds env (evBindMapBinds bs) } -zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag) - -zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind) -zonkEvBinds env binds - = {-# SCC "zonkEvBinds" #-} - fixM (\ ~( _, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds) - ; binds' <- mapBagM (zonkEvBind env1) binds - ; return (env1, binds') }) - where - collect_ev_bndrs :: Bag EvBind -> [EvVar] - collect_ev_bndrs = foldr add [] - add (EvBind { eb_lhs = var }) vars = var : vars - -zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind -zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term }) - = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var - - -- Optimise the common case of Refl coercions - -- See Note [Optimise coercion zonking] - -- This has a very big effect on some programs (eg #5030) - - ; term' <- case getEqPredTys_maybe (idType var') of - Just (r, ty1, ty2) | ty1 `eqType` ty2 - -> return (evCoercion (mkTcReflCo r ty1)) - _other -> zonkEvTerm env term - - ; return (bind { eb_lhs = var', eb_rhs = term' }) } - -{- Note [Optimise coercion zonking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When optimising evidence binds we may come across situations where -a coercion looks like - cv = ReflCo ty -or cv1 = cv2 -where the type 'ty' is big. In such cases it is a waste of time to zonk both - * The variable on the LHS - * The coercion on the RHS -Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just -use Refl on the right, ignoring the actual coercion on the RHS. - -This can have a very big effect, because the constraint solver sometimes does go -to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf #5030) - - -************************************************************************ -* * - Zonking types -* * -************************************************************************ --} - -{- Note [Sharing when zonking to Type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Problem: - - In TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to - (Indirect zty), see Note [Sharing in zonking] in TcMType. But we - /can't/ do this when zonking a TcType to a Type (#15552, esp - comment:3). Suppose we have - - alpha -> alpha - where - alpha is already unified: - alpha := T{tc-tycon} Int -> Int - and T is knot-tied - - By "knot-tied" I mean that the occurrence of T is currently a TcTyCon, - but the global env contains a mapping "T" :-> T{knot-tied-tc}. See - Note [Type checking recursive type and class declarations] in - TcTyClsDecls. - - Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow - the same path as Note [Sharing in zonking] in TcMType, we'll - update alpha to - alpha := T{knot-tied-tc} Int -> Int - - But alas, if we encounter alpha for a /second/ time, we end up - looking at T{knot-tied-tc} and fall into a black hole. The whole - point of zonkTcTypeToType is that it produces a type full of - knot-tied tycons, and you must not look at the result!! - - To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not - the same as zonkTcTypeToType. (If we distinguished TcType from - Type, this issue would have been a type error!) - -Solution: (see #15552 for other variants) - - One possible solution is simply not to do the short-circuiting. - That has less sharing, but maybe sharing is rare. And indeed, - that turns out to be viable from a perf point of view - - But the code implements something a bit better - - * ZonkEnv contains ze_meta_tv_env, which maps - from a MetaTyVar (unification variable) - to a Type (not a TcType) - - * In zonkTyVarOcc, we check this map to see if we have zonked - this variable before. If so, use the previous answer; if not - zonk it, and extend the map. - - * The map is of course stateful, held in a TcRef. (That is unlike - the treatment of lexically-scoped variables in ze_tv_env and - ze_id_env.) - - Is the extra work worth it? Some non-sytematic perf measurements - suggest that compiler allocation is reduced overall (by 0.5% or so) - but compile time really doesn't change. --} - -zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType -zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi - , ze_tv_env = tv_env - , ze_meta_tv_env = mtv_env_ref }) tv - | isTcTyVar tv - = case tcTyVarDetails tv of - SkolemTv {} -> lookup_in_tv_env - RuntimeUnk {} -> lookup_in_tv_env - MetaTv { mtv_ref = ref } - -> do { mtv_env <- readTcRef mtv_env_ref - -- See Note [Sharing when zonking to Type] - ; case lookupVarEnv mtv_env tv of - Just ty -> return ty - Nothing -> do { mtv_details <- readTcRef ref - ; zonk_meta mtv_env ref mtv_details } } - | otherwise - = lookup_in_tv_env - - where - lookup_in_tv_env -- Look up in the env just as we do for Ids - = case lookupVarEnv tv_env tv of - Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv - Just tv' -> return (mkTyVarTy tv') - - zonk_meta mtv_env ref Flexi - = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv) - ; ty <- commitFlexi flexi tv kind - ; writeMetaTyVarRef tv ref ty -- Belt and braces - ; finish_meta mtv_env ty } - - zonk_meta mtv_env _ (Indirect ty) - = do { zty <- zonkTcTypeToTypeX env ty - ; finish_meta mtv_env zty } - - finish_meta mtv_env ty - = do { let mtv_env' = extendVarEnv mtv_env tv ty - ; writeTcRef mtv_env_ref mtv_env' - ; return ty } - -lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar -lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv - = lookupVarEnv tv_env tv - -commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type --- Only monadic so we can do tc-tracing -commitFlexi flexi tv zonked_kind - = case flexi of - SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind)) - - DefaultFlexi - | isRuntimeRepTy zonked_kind - -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) - ; return liftedRepTy } - | otherwise - -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv) - ; return (anyTypeOfKind zonked_kind) } - - RuntimeUnkFlexi - -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv) - ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) } - -- This is where RuntimeUnks are born: - -- otherwise-unconstrained unification variables are - -- turned into RuntimeUnks as they leave the - -- typechecker's monad - where - name = tyVarName tv - -zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion -zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv - | Just cv' <- lookupVarEnv tyco_env cv -- don't look in the knot-tied env - = return $ mkCoVarCo cv' - | otherwise - = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') } - -zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion -zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) - = do { contents <- readTcRef ref - ; case contents of - Just co -> do { co' <- zonkCoToCo env co - ; checkCoercionHole cv co' } - - -- This next case should happen only in the presence of - -- (undeferred) type errors. Originally, I put in a panic - -- here, but that caused too many uses of `failIfErrsM`. - Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole) - ; when debugIsOn $ - whenNoErrs $ - MASSERT2( False - , text "Type-correct unfilled coercion hole" - <+> ppr hole ) - ; cv' <- zonkCoVar cv - ; return $ mkCoVarCo cv' } } - -- This will be an out-of-scope variable, but keeping - -- this as a coercion hole led to #15787 - -zonk_tycomapper :: TyCoMapper ZonkEnv TcM -zonk_tycomapper = TyCoMapper - { tcm_tyvar = zonkTyVarOcc - , tcm_covar = zonkCoVarOcc - , tcm_hole = zonkCoHole - , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv - , tcm_tycon = zonkTcTyConToTyCon } - --- Zonk a TyCon by changing a TcTyCon to a regular TyCon -zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon -zonkTcTyConToTyCon tc - | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc) - ; case thing of - ATyCon real_tc -> return real_tc - _ -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) } - | otherwise = return tc -- it's already zonked - --- Confused by zonking? See Note [What is zonking?] in TcMType. -zonkTcTypeToType :: TcType -> TcM Type -zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty - -zonkTcTypesToTypes :: [TcType] -> TcM [Type] -zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys - -zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type -zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type] -zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion -(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _) - = mapTyCoX zonk_tycomapper - -zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo -zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec) - = do { ty' <- zonkTcTypeToTypeX ze ty - ; gdm_spec' <- zonk_gdm gdm_spec - ; return (name, ty', gdm_spec') } - where - zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType)) - -> TcM (Maybe (DefMethSpec (SrcSpan, Type))) - zonk_gdm Nothing = return Nothing - zonk_gdm (Just VanillaDM) = return (Just VanillaDM) - zonk_gdm (Just (GenericDM (loc, ty))) - = do { ty' <- zonkTcTypeToTypeX ze ty - ; return (Just (GenericDM (loc, ty'))) } - ---------------------------------------- -{- Note [Zonking the LHS of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also GHC.HsToCore.Binds Note [Free tyvars on rule LHS] - -We need to gather the type variables mentioned on the LHS so we can -quantify over them. Example: - data T a = C - - foo :: T a -> Int - foo C = 1 - - {-# RULES "myrule" foo C = 1 #-} - -After type checking the LHS becomes (foo alpha (C alpha)) and we do -not want to zap the unbound meta-tyvar 'alpha' to Any, because that -limits the applicability of the rule. Instead, we want to quantify -over it! - -We do this in two stages. - -* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'. We - do this by using zonkTvSkolemising as the UnboundTyVarZonker in the - ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a - UnboundTyVarZonker.) - -* In GHC.HsToCore.Binds, we quantify over it. See GHC.HsToCore.Binds - Note [Free tyvars on rule LHS] - -Quantifying here is awkward because (a) the data type is big and (b) -finding the free type vars of an expression is necessarily monadic -operation. (consider /\a -> f @ b, where b is side-effected to a) --} diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs deleted file mode 100644 index 37bfda6e9f..0000000000 --- a/compiler/typecheck/TcHsType.hs +++ /dev/null @@ -1,3549 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcMonoType]{Typechecking user-specified @MonoTypes@} --} - -{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcHsType ( - -- Type signatures - kcClassSigType, tcClassSigType, - tcHsSigType, tcHsSigWcType, - tcHsPartialSigType, - tcStandaloneKindSig, - funsSigCtxt, addSigCtxt, pprSigCtxt, - - tcHsClsInstType, - tcHsDeriv, tcDerivStrategy, - tcHsTypeApp, - UserTypeCtxt(..), - bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol, - bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol, - bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol, - bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol, - ContextKind(..), - - -- Type checking type and class decls - bindTyClTyVars, - etaExpandAlgTyCon, tcbVisibilities, - - -- tyvars - zonkAndScopedSort, - - -- Kind-checking types - -- No kind generalisation, no checkValidType - InitialKindStrategy(..), - SAKS_or_CUSK(..), - kcDeclHeader, - tcNamedWildCardBinders, - tcHsLiftedType, tcHsOpenType, - tcHsLiftedTypeNC, tcHsOpenTypeNC, - tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType, - tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps, - failIfEmitsConstraints, - solveEqualities, -- useful re-export - - typeLevelMode, kindLevelMode, - - kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone, - - -- Sort-checking kinds - tcLHsKindSig, checkDataKindSig, DataSort(..), - checkClassKindSig, - - -- Pattern type signatures - tcHsPatSigType, tcPatSig, - - -- Error messages - funAppCtxt, addTyConFlavCtxt - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TcRnMonad -import TcOrigin -import GHC.Core.Predicate -import Constraint -import TcEvidence -import TcEnv -import TcMType -import TcValidity -import TcUnify -import GHC.IfaceToCore -import TcSimplify -import TcHsSyn -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import TcErrors ( reportAllUnsolved ) -import TcType -import Inst ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder ) -import GHC.Core.Type -import TysPrim -import GHC.Types.Name.Reader( lookupLocalRdrOcc ) -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Core.TyCon -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.Class -import GHC.Types.Name --- import GHC.Types.Name.Set -import GHC.Types.Var.Env -import TysWiredIn -import GHC.Types.Basic -import GHC.Types.SrcLoc -import Constants ( mAX_CTUPLE_SIZE ) -import ErrUtils( MsgDoc ) -import GHC.Types.Unique -import GHC.Types.Unique.Set -import Util -import GHC.Types.Unique.Supply -import Outputable -import FastString -import PrelNames hiding ( wildCardName ) -import GHC.Driver.Session -import qualified GHC.LanguageExtensions as LangExt - -import Maybes -import Data.List ( find ) -import Control.Monad - -{- - ---------------------------- - General notes - ---------------------------- - -Unlike with expressions, type-checking types both does some checking and -desugars at the same time. This is necessary because we often want to perform -equality checks on the types right away, and it would be incredibly painful -to do this on un-desugared types. Luckily, desugared types are close enough -to HsTypes to make the error messages sane. - -During type-checking, we perform as little validity checking as possible. -Generally, after type-checking, you will want to do validity checking, say -with TcValidity.checkValidType. - -Validity checking -~~~~~~~~~~~~~~~~~ -Some of the validity check could in principle be done by the kind checker, -but not all: - -- During desugaring, we normalise by expanding type synonyms. Only - after this step can we check things like type-synonym saturation - e.g. type T k = k Int - type S a = a - Then (T S) is ok, because T is saturated; (T S) expands to (S Int); - and then S is saturated. This is a GHC extension. - -- Similarly, also a GHC extension, we look through synonyms before complaining - about the form of a class or instance declaration - -- Ambiguity checks involve functional dependencies - -Also, in a mutually recursive group of types, we can't look at the TyCon until we've -finished building the loop. So to keep things simple, we postpone most validity -checking until step (3). - -%************************************************************************ -%* * - Check types AND do validity checking -* * -************************************************************************ --} - -funsSigCtxt :: [Located Name] -> UserTypeCtxt --- Returns FunSigCtxt, with no redundant-context-reporting, --- form a list of located names -funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False -funsSigCtxt [] = panic "funSigCtxt" - -addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a -addSigCtxt ctxt hs_ty thing_inside - = setSrcSpan (getLoc hs_ty) $ - addErrCtxt (pprSigCtxt ctxt hs_ty) $ - thing_inside - -pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc --- (pprSigCtxt ctxt <extra> <type>) --- prints In the type signature for 'f': --- f :: <type> --- The <extra> is either empty or "the ambiguity check for" -pprSigCtxt ctxt hs_ty - | Just n <- isSigMaybe ctxt - = hang (text "In the type signature:") - 2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty) - - | otherwise - = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon) - 2 (ppr hs_ty) - -tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type --- This one is used when we have a LHsSigWcType, but in --- a place where wildcards aren't allowed. The renamer has --- already checked this, so we can simply ignore it. -tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) - -kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM () --- This is a special form of tcClassSigType that is used during the --- kind-checking phase to infer the kind of class variables. Cf. tc_hs_sig_type. --- Importantly, this does *not* kind-generalize. Consider --- class SC f where --- meth :: forall a (x :: f a). Proxy x -> () --- When instantiating Proxy with kappa, we must unify kappa := f a. But we're --- still working out the kind of f, and thus f a will have a coercion in it. --- Coercions block unification (Note [Equalities with incompatible kinds] in --- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll --- end up promoting kappa to the top level (because kind-generalization is --- normally done right before adding a binding to the context), and then we --- can't set kappa := f a, because a is local. -kcClassSigType skol_info names (HsIB { hsib_ext = sig_vars - , hsib_body = hs_ty }) - = addSigCtxt (funsSigCtxt names) hs_ty $ - do { (tc_lvl, (wanted, (spec_tkvs, _))) - <- pushTcLevelM $ - solveLocalEqualitiesX "kcClassSigType" $ - bindImplicitTKBndrs_Skol sig_vars $ - tc_lhs_type typeLevelMode hs_ty liftedTypeKind - - ; emitResidualTvConstraint skol_info Nothing spec_tkvs - tc_lvl wanted } -kcClassSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec - -tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type --- Does not do validity checking -tcClassSigType skol_info names sig_ty - = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $ - snd <$> tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind) - -- Do not zonk-to-Type, nor perform a validity check - -- We are in a knot with the class and associated types - -- Zonking and validity checking is done by tcClassDecl - -- No need to fail here if the type has an error: - -- If we're in the kind-checking phase, the solveEqualities - -- in kcTyClGroup catches the error - -- If we're in the type-checking phase, the solveEqualities - -- in tcClassDecl1 gets it - -- Failing fast here degrades the error message in, e.g., tcfail135: - -- class Foo f where - -- baa :: f a -> f - -- If we fail fast, we're told that f has kind `k1` when we wanted `*`. - -- It should be that f has kind `k2 -> *`, but we never get a chance - -- to run the solver where the kind of f is touchable. This is - -- painfully delicate. - -tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type --- Does validity checking --- See Note [Recipe for checking a signature] -tcHsSigType ctxt sig_ty - = addSigCtxt ctxt (hsSigType sig_ty) $ - do { traceTc "tcHsSigType {" (ppr sig_ty) - - -- Generalise here: see Note [Kind generalisation] - ; (insol, ty) <- tc_hs_sig_type skol_info sig_ty - (expectedKindInCtxt ctxt) - ; ty <- zonkTcType ty - - ; when insol failM - -- See Note [Fail fast if there are insoluble kind equalities] in TcSimplify - - ; checkValidType ctxt ty - ; traceTc "end tcHsSigType }" (ppr ty) - ; return ty } - where - skol_info = SigTypeSkol ctxt - --- Does validity checking and zonking. -tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind) -tcStandaloneKindSig (L _ kisig) = case kisig of - StandaloneKindSig _ (L _ name) ksig -> - let ctxt = StandaloneKindSigCtxt name in - addSigCtxt ctxt (hsSigType ksig) $ - do { kind <- tcTopLHsType kindLevelMode ksig (expectedKindInCtxt ctxt) - ; checkValidType ctxt kind - ; return (name, kind) } - XStandaloneKindSig nec -> noExtCon nec - -tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn - -> ContextKind -> TcM (Bool, TcType) --- Kind-checks/desugars an 'LHsSigType', --- solve equalities, --- and then kind-generalizes. --- This will never emit constraints, as it uses solveEqualities internally. --- No validity checking or zonking --- Returns also a Bool indicating whether the type induced an insoluble constraint; --- True <=> constraint is insoluble -tc_hs_sig_type skol_info hs_sig_type ctxt_kind - | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type - = do { (tc_lvl, (wanted, (spec_tkvs, ty))) - <- pushTcLevelM $ - solveLocalEqualitiesX "tc_hs_sig_type" $ - bindImplicitTKBndrs_Skol sig_vars $ - do { kind <- newExpectedKind ctxt_kind - ; tc_lhs_type typeLevelMode hs_ty kind } - -- Any remaining variables (unsolved in the solveLocalEqualities) - -- should be in the global tyvars, and therefore won't be quantified - - ; spec_tkvs <- zonkAndScopedSort spec_tkvs - ; let ty1 = mkSpecForAllTys spec_tkvs ty - - -- This bit is very much like decideMonoTyVars in TcSimplify, - -- but constraints are so much simpler in kinds, it is much - -- easier here. (In particular, we never quantify over a - -- constraint in a type.) - ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted) - ; let should_gen = not . (`elemVarSet` constrained) - - ; kvs <- kindGeneralizeSome should_gen ty1 - ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs) - tc_lvl wanted - - ; return (insolubleWC wanted, mkInvForAllTys kvs ty1) } - -tc_hs_sig_type _ (XHsImplicitBndrs nec) _ = noExtCon nec - -tcTopLHsType :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type --- tcTopLHsType is used for kind-checking top-level HsType where --- we want to fully solve /all/ equalities, and report errors --- Does zonking, but not validity checking because it's used --- for things (like deriving and instances) that aren't --- ordinary types -tcTopLHsType mode hs_sig_type ctxt_kind - | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type - = do { traceTc "tcTopLHsType {" (ppr hs_ty) - ; (spec_tkvs, ty) - <- pushTcLevelM_ $ - solveEqualities $ - bindImplicitTKBndrs_Skol sig_vars $ - do { kind <- newExpectedKind ctxt_kind - ; tc_lhs_type mode hs_ty kind } - - ; spec_tkvs <- zonkAndScopedSort spec_tkvs - ; let ty1 = mkSpecForAllTys spec_tkvs ty - ; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type - ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1) - ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty]) - ; return final_ty} - -tcTopLHsType _ (XHsImplicitBndrs nec) _ = noExtCon nec - ------------------ -tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) --- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause --- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments --- E.g. class C (a::*) (b::k->k) --- data T a b = ... deriving( C Int ) --- returns ([k], C, [k, Int], [k->k]) --- Return values are fully zonked -tcHsDeriv hs_ty - = do { ty <- checkNoErrs $ -- Avoid redundant error report - -- with "illegal deriving", below - tcTopLHsType typeLevelMode hs_ty AnyKind - ; let (tvs, pred) = splitForAllTys ty - (kind_args, _) = splitFunTys (tcTypeKind pred) - ; case getClassPredTys_maybe pred of - Just (cls, tys) -> return (tvs, cls, tys, kind_args) - Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } - --- | Typecheck a deriving strategy. For most deriving strategies, this is a --- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. -tcDerivStrategy :: - Maybe (LDerivStrategy GhcRn) - -- ^ The deriving strategy - -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar]) - -- ^ The typechecked deriving strategy and the tyvars that it binds - -- (if using 'ViaStrategy'). -tcDerivStrategy mb_lds - = case mb_lds of - Nothing -> boring_case Nothing - Just (L loc ds) -> - setSrcSpan loc $ do - (ds', tvs) <- tc_deriv_strategy ds - pure (Just (L loc ds'), tvs) - where - tc_deriv_strategy :: DerivStrategy GhcRn - -> TcM (DerivStrategy GhcTc, [TyVar]) - tc_deriv_strategy StockStrategy = boring_case StockStrategy - tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy - tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy - tc_deriv_strategy (ViaStrategy ty) = do - ty' <- checkNoErrs $ tcTopLHsType typeLevelMode ty AnyKind - let (via_tvs, via_pred) = splitForAllTys ty' - pure (ViaStrategy via_pred, via_tvs) - - boring_case :: ds -> TcM (ds, [TyVar]) - boring_case ds = pure (ds, []) - -tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt - -> LHsSigType GhcRn - -> TcM Type --- Like tcHsSigType, but for a class instance declaration -tcHsClsInstType user_ctxt hs_inst_ty - = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $ - do { -- Fail eagerly if tcTopLHsType fails. We are at top level so - -- these constraints will never be solved later. And failing - -- eagerly avoids follow-on errors when checkValidInstance - -- sees an unsolved coercion hole - inst_ty <- checkNoErrs $ - tcTopLHsType typeLevelMode hs_inst_ty (TheKind constraintKind) - ; checkValidInstance user_ctxt hs_inst_ty inst_ty - ; return inst_ty } - ----------------------------------------------- --- | Type-check a visible type application -tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type --- See Note [Recipe for checking a signature] in TcHsType -tcHsTypeApp wc_ty kind - | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty - = do { ty <- solveLocalEqualities "tcHsTypeApp" $ - -- We are looking at a user-written type, very like a - -- signature so we want to solve its equalities right now - unsetWOptM Opt_WarnPartialTypeSignatures $ - setXOptM LangExt.PartialTypeSignatures $ - -- See Note [Wildcards in visible type application] - tcNamedWildCardBinders sig_wcs $ \ _ -> - tcCheckLHsType hs_ty (TheKind kind) - -- We do not kind-generalize type applications: we just - -- instantiate with exactly what the user says. - -- See Note [No generalization in type application] - -- We still must call kindGeneralizeNone, though, according - -- to Note [Recipe for checking a signature] - ; kindGeneralizeNone ty - ; ty <- zonkTcType ty - ; checkValidType TypeAppCtxt ty - ; return ty } -tcHsTypeApp (XHsWildCardBndrs nec) _ = noExtCon nec - -{- Note [Wildcards in visible type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so -any unnamed wildcards stay unchanged in hswc_body. When called in -tcHsTypeApp, tcCheckLHsType will call emitAnonWildCardHoleConstraint -on these anonymous wildcards. However, this would trigger -error/warning when an anonymous wildcard is passed in as a visible type -argument, which we do not want because users should be able to write -@_ to skip a instantiating a type variable variable without fuss. The -solution is to switch the PartialTypeSignatures flags here to let the -typechecker know that it's checking a '@_' and do not emit hole -constraints on it. See related Note [Wildcards in visible kind -application] and Note [The wildcard story for types] in GHC.Hs.Types - -Ugh! - -Note [No generalization in type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not kind-generalize type applications. Imagine - - id @(Proxy Nothing) - -If we kind-generalized, we would get - - id @(forall {k}. Proxy @(Maybe k) (Nothing @k)) - -which is very sneakily impredicative instantiation. - -There is also the possibility of mentioning a wildcard -(`id @(Proxy _)`), which definitely should not be kind-generalized. - --} - -{- -************************************************************************ -* * - The main kind checker: no validity checks here -* * -************************************************************************ --} - ---------------------------- -tcHsOpenType, tcHsLiftedType, - tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType --- Used for type signatures --- Do not do validity checking -tcHsOpenType ty = addTypeCtxt ty $ tcHsOpenTypeNC ty -tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty - -tcHsOpenTypeNC ty = do { ek <- newOpenTypeKind - ; tc_lhs_type typeLevelMode ty ek } -tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind - --- Like tcHsType, but takes an expected kind -tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType -tcCheckLHsType hs_ty exp_kind - = addTypeCtxt hs_ty $ - do { ek <- newExpectedKind exp_kind - ; tc_lhs_type typeLevelMode hs_ty ek } - -tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind) --- Called from outside: set the context -tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty) - --- Like tcLHsType, but use it in a context where type synonyms and type families --- do not need to be saturated, like in a GHCi :kind call -tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind) -tcLHsTypeUnsaturated hs_ty - | Just (hs_fun_ty, hs_args) <- splitHsAppTys (unLoc hs_ty) - = addTypeCtxt hs_ty $ - do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty - ; tcInferApps_nosat mode hs_fun_ty fun_ty hs_args } - -- Notice the 'nosat'; do not instantiate trailing - -- invisible arguments of a type family. - -- See Note [Dealing with :kind] - - | otherwise - = addTypeCtxt hs_ty $ - tc_infer_lhs_type mode hs_ty - - where - mode = typeLevelMode - -{- Note [Dealing with :kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this GHCi command - ghci> type family F :: Either j k - ghci> :kind F - F :: forall {j,k}. Either j k - -We will only get the 'forall' if we /refrain/ from saturating those -invisible binders. But generally we /do/ saturate those invisible -binders (see tcInferApps), and we want to do so for nested application -even in GHCi. Consider for example (#16287) - ghci> type family F :: k - ghci> data T :: (forall k. k) -> Type - ghci> :kind T F -We want to reject this. It's just at the very top level that we want -to switch off saturation. - -So tcLHsTypeUnsaturated does a little special case for top level -applications. Actually the common case is a bare variable, as above. - - -************************************************************************ -* * - Type-checking modes -* * -************************************************************************ - -The kind-checker is parameterised by a TcTyMode, which contains some -information about where we're checking a type. - -The renamer issues errors about what it can. All errors issued here must -concern things that the renamer can't handle. - --} - --- | Info about the context in which we're checking a type. Currently, --- differentiates only between types and kinds, but this will likely --- grow, at least to include the distinction between patterns and --- not-patterns. --- --- To find out where the mode is used, search for 'mode_level' -data TcTyMode = TcTyMode { mode_level :: TypeOrKind } - -typeLevelMode :: TcTyMode -typeLevelMode = TcTyMode { mode_level = TypeLevel } - -kindLevelMode :: TcTyMode -kindLevelMode = TcTyMode { mode_level = KindLevel } - --- switch to kind level -kindLevel :: TcTyMode -> TcTyMode -kindLevel mode = mode { mode_level = KindLevel } - -instance Outputable TcTyMode where - ppr = ppr . mode_level - -{- -Note [Bidirectional type checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In expressions, whenever we see a polymorphic identifier, say `id`, we are -free to instantiate it with metavariables, knowing that we can always -re-generalize with type-lambdas when necessary. For example: - - rank2 :: (forall a. a -> a) -> () - x = rank2 id - -When checking the body of `x`, we can instantiate `id` with a metavariable. -Then, when we're checking the application of `rank2`, we notice that we really -need a polymorphic `id`, and then re-generalize over the unconstrained -metavariable. - -In types, however, we're not so lucky, because *we cannot re-generalize*! -There is no lambda. So, we must be careful only to instantiate at the last -possible moment, when we're sure we're never going to want the lost polymorphism -again. This is done in calls to tcInstInvisibleTyBinders. - -To implement this behavior, we use bidirectional type checking, where we -explicitly think about whether we know the kind of the type we're checking -or not. Note that there is a difference between not knowing a kind and -knowing a metavariable kind: the metavariables are TauTvs, and cannot become -forall-quantified kinds. Previously (before dependent types), there were -no higher-rank kinds, and so we could instantiate early and be sure that -no types would have polymorphic kinds, and so we could always assume that -the kind of a type was a fresh metavariable. Not so anymore, thus the -need for two algorithms. - -For HsType forms that can never be kind-polymorphic, we implement only the -"down" direction, where we safely assume a metavariable kind. For HsType forms -that *can* be kind-polymorphic, we implement just the "up" (functions with -"infer" in their name) version, as we gain nothing by also implementing the -"down" version. - -Note [Future-proofing the type checker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As discussed in Note [Bidirectional type checking], each HsType form is -handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions -are mutually recursive, so that either one can work for any type former. -But, we want to make sure that our pattern-matches are complete. So, -we have a bunch of repetitive code just so that we get warnings if we're -missing any patterns. - --} - ------------------------------------------- --- | Check and desugar a type, returning the core type and its --- possibly-polymorphic kind. Much like 'tcInferRho' at the expression --- level. -tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) -tc_infer_lhs_type mode (L span ty) - = setSrcSpan span $ - tc_infer_hs_type mode ty - ---------------------------- --- | Call 'tc_infer_hs_type' and check its result against an expected kind. -tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType -tc_infer_hs_type_ek mode hs_ty ek - = do { (ty, k) <- tc_infer_hs_type mode hs_ty - ; checkExpectedKind hs_ty ty k ek } - ---------------------------- --- | Infer the kind of a type and desugar. This is the "up" type-checker, --- as described in Note [Bidirectional type checking] -tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) - -tc_infer_hs_type mode (HsParTy _ t) - = tc_infer_lhs_type mode t - -tc_infer_hs_type mode ty - | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty - = do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty - ; tcInferApps mode hs_fun_ty fun_ty hs_args } - -tc_infer_hs_type mode (HsKindSig _ ty sig) - = do { sig' <- tcLHsKindSig KindSigCtxt sig - -- We must typecheck the kind signature, and solve all - -- its equalities etc; from this point on we may do - -- things like instantiate its foralls, so it needs - -- to be fully determined (#14904) - ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig') - ; ty' <- tc_lhs_type mode ty sig' - ; return (ty', sig') } - --- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate --- the splice location to the typechecker. Here we skip over it in order to have --- the same kind inferred for a given expression whether it was produced from --- splices or not. --- --- See Note [Delaying modFinalizers in untyped splices]. -tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty))) - = tc_infer_hs_type mode ty - -tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty -tc_infer_hs_type _ (XHsType (NHsCoreTy ty)) - = return (ty, tcTypeKind ty) - -tc_infer_hs_type _ (HsExplicitListTy _ _ tys) - | null tys -- this is so that we can use visible kind application with '[] - -- e.g ... '[] @Bool - = return (mkTyConTy promotedNilDataCon, - mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy) - -tc_infer_hs_type mode other_ty - = do { kv <- newMetaKindVar - ; ty' <- tc_hs_type mode other_ty kv - ; return (ty', kv) } - ------------------------------------------- -tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType -tc_lhs_type mode (L span ty) exp_kind - = setSrcSpan span $ - tc_hs_type mode ty exp_kind - -tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType --- See Note [Bidirectional type checking] - -tc_hs_type mode (HsParTy _ ty) exp_kind = tc_lhs_type mode ty exp_kind -tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind -tc_hs_type _ ty@(HsBangTy _ bang _) _ - -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), - -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of - -- bangs are invalid, so fail. (#7210, #14761) - = do { let bangError err = failWith $ - text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ - text err <+> text "annotation cannot appear nested inside a type" - ; case bang of - HsSrcBang _ SrcUnpack _ -> bangError "UNPACK" - HsSrcBang _ SrcNoUnpack _ -> bangError "NOUNPACK" - HsSrcBang _ NoSrcUnpack SrcLazy -> bangError "laziness" - HsSrcBang _ _ _ -> bangError "strictness" } -tc_hs_type _ ty@(HsRecTy {}) _ - -- Record types (which only show up temporarily in constructor - -- signatures) should have been removed by now - = failWithTc (text "Record syntax is illegal here:" <+> ppr ty) - --- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. --- Here we get rid of it and add the finalizers to the global environment --- while capturing the local environment. --- --- See Note [Delaying modFinalizers in untyped splices]. -tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty))) - exp_kind - = do addModFinalizersWithLclEnv mod_finalizers - tc_hs_type mode ty exp_kind - --- This should never happen; type splices are expanded by the renamer -tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind - = failWithTc (text "Unexpected type splice:" <+> ppr ty) - ----------- Functions and applications -tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind - = tc_fun_type mode ty1 ty2 exp_kind - -tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind - | op `hasKey` funTyConKey - = tc_fun_type mode ty1 ty2 exp_kind - ---------- Foralls -tc_hs_type mode forall@(HsForAllTy { hst_fvf = fvf, hst_bndrs = hs_tvs - , hst_body = ty }) exp_kind - = do { (tclvl, wanted, (tvs', ty')) - <- pushLevelAndCaptureConstraints $ - bindExplicitTKBndrs_Skol hs_tvs $ - tc_lhs_type mode ty exp_kind - -- Do not kind-generalise here! See Note [Kind generalisation] - -- Why exp_kind? See Note [Body kind of HsForAllTy] - ; let argf = case fvf of - ForallVis -> Required - ForallInvis -> Specified - bndrs = mkTyVarBinders argf tvs' - skol_info = ForAllSkol (ppr forall) - m_telescope = Just (sep (map ppr hs_tvs)) - - ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted - - ; return (mkForAllTys bndrs ty') } - -tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind - | null (unLoc ctxt) - = tc_lhs_type mode rn_ty exp_kind - - -- See Note [Body kind of a HsQualTy] - | tcIsConstraintKind exp_kind - = do { ctxt' <- tc_hs_context mode ctxt - ; ty' <- tc_lhs_type mode rn_ty constraintKind - ; return (mkPhiTy ctxt' ty') } - - | otherwise - = do { ctxt' <- tc_hs_context mode ctxt - - ; ek <- newOpenTypeKind -- The body kind (result of the function) can - -- be TYPE r, for any r, hence newOpenTypeKind - ; ty' <- tc_lhs_type mode rn_ty ek - ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty') - liftedTypeKind exp_kind } - ---------- Lists, arrays, and tuples -tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind - = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind - ; checkWiredInTyCon listTyCon - ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } - --- See Note [Distinguishing tuple kinds] in GHC.Hs.Types --- See Note [Inferring tuple kinds] -tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind - -- (NB: not zonking before looking at exp_k, to avoid left-right bias) - | Just tup_sort <- tupKindSort_maybe exp_kind - = traceTc "tc_hs_type tuple" (ppr hs_tys) >> - tc_tuple rn_ty mode tup_sort hs_tys exp_kind - | otherwise - = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) - ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys - ; kinds <- mapM zonkTcType kinds - -- Infer each arg type separately, because errors can be - -- confusing if we give them a shared kind. Eg #7410 - -- (Either Int, Int), we do not want to get an error saying - -- "the second argument of a tuple should have kind *->*" - - ; let (arg_kind, tup_sort) - = case [ (k,s) | k <- kinds - , Just s <- [tupKindSort_maybe k] ] of - ((k,s) : _) -> (k,s) - [] -> (liftedTypeKind, BoxedTuple) - -- In the [] case, it's not clear what the kind is, so guess * - - ; tys' <- sequence [ setSrcSpan loc $ - checkExpectedKind hs_ty ty kind arg_kind - | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ] - - ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind } - - -tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind - = tc_tuple rn_ty mode tup_sort tys exp_kind - where - tup_sort = case hs_tup_sort of -- Fourth case dealt with above - HsUnboxedTuple -> UnboxedTuple - HsBoxedTuple -> BoxedTuple - HsConstraintTuple -> ConstraintTuple - _ -> panic "tc_hs_type HsTupleTy" - -tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind - = do { let arity = length hs_tys - ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys - ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds - ; let arg_reps = map kindRep arg_kinds - arg_tys = arg_reps ++ tau_tys - sum_ty = mkTyConApp (sumTyCon arity) arg_tys - sum_kind = unboxedSumKind arg_reps - ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind - } - ---------- Promoted lists and tuples -tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind - = do { tks <- mapM (tc_infer_lhs_type mode) tys - ; (taus', kind) <- unifyKinds tys tks - ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') - ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind } - where - mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b] - mk_nil k = mkTyConApp (promoteDataCon nilDataCon) [k] - -tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind - -- using newMetaKindVar means that we force instantiations of any polykinded - -- types. At first, I just used tc_infer_lhs_type, but that led to #11255. - = do { ks <- replicateM arity newMetaKindVar - ; taus <- zipWithM (tc_lhs_type mode) tys ks - ; let kind_con = tupleTyCon Boxed arity - ty_con = promotedTupleDataCon Boxed arity - tup_k = mkTyConApp kind_con ks - ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } - where - arity = length tys - ---------- Constraint types -tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind - = do { MASSERT( isTypeLevel (mode_level mode) ) - ; ty' <- tc_lhs_type mode ty liftedTypeKind - ; let n' = mkStrLitTy $ hsIPNameFS n - ; ipClass <- tcLookupClass ipClassName - ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty']) - constraintKind exp_kind } - -tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind - -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to - -- handle it in 'coreView' and 'tcView'. - = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind - ---------- Literals -tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind - = do { checkWiredInTyCon typeNatKindCon - ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind } - -tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind - = do { checkWiredInTyCon typeSymbolKindCon - ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } - ---------- Potentially kind-polymorphic types: call the "up" checker --- See Note [Future-proofing the type checker] -tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsAppKindTy{}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type _ wc@(HsWildCardTy _) ek = tcAnonWildCardOcc wc ek - ------------------------------------------- -tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind - -> TcM TcType -tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of - TypeLevel -> - do { arg_k <- newOpenTypeKind - ; res_k <- newOpenTypeKind - ; ty1' <- tc_lhs_type mode ty1 arg_k - ; ty2' <- tc_lhs_type mode ty2 res_k - ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2') - liftedTypeKind exp_kind } - KindLevel -> -- no representation polymorphism in kinds. yet. - do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind - ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind - ; checkExpectedKind (HsFunTy noExtField ty1 ty2) (mkVisFunTy ty1' ty2') - liftedTypeKind exp_kind } - ---------------------------- -tcAnonWildCardOcc :: HsType GhcRn -> Kind -> TcM TcType -tcAnonWildCardOcc wc exp_kind - = do { wc_tv <- newWildTyVar -- The wildcard's kind will be an un-filled-in meta tyvar - - ; part_tysig <- xoptM LangExt.PartialTypeSignatures - ; warning <- woptM Opt_WarnPartialTypeSignatures - - ; unless (part_tysig && not warning) $ - emitAnonWildCardHoleConstraint wc_tv - -- Why the 'unless' guard? - -- See Note [Wildcards in visible kind application] - - ; checkExpectedKind wc (mkTyVarTy wc_tv) - (tyVarKind wc_tv) exp_kind } - -{- Note [Wildcards in visible kind application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are cases where users might want to pass in a wildcard as a visible kind -argument, for instance: - -data T :: forall k1 k2. k1 → k2 → Type where - MkT :: T a b -x :: T @_ @Nat False n -x = MkT - -So we should allow '@_' without emitting any hole constraints, and -regardless of whether PartialTypeSignatures is enabled or not. But how would -the typechecker know which '_' is being used in VKA and which is not when it -calls emitNamedWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs? -The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs, -but instead give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc. -And whenever we see a '@', we automatically turn on PartialTypeSignatures and -turn off hole constraint warnings, and do not call emitAnonWildCardHoleConstraint -under these conditions. -See related Note [Wildcards in visible type application] here and -Note [The wildcard story for types] in GHC.Hs.Types - --} - -{- ********************************************************************* -* * - Tuples -* * -********************************************************************* -} - ---------------------------- -tupKindSort_maybe :: TcKind -> Maybe TupleSort -tupKindSort_maybe k - | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' - | Just k' <- tcView k = tupKindSort_maybe k' - | tcIsConstraintKind k = Just ConstraintTuple - | tcIsLiftedTypeKind k = Just BoxedTuple - | otherwise = Nothing - -tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType -tc_tuple rn_ty mode tup_sort tys exp_kind - = do { arg_kinds <- case tup_sort of - BoxedTuple -> return (replicate arity liftedTypeKind) - UnboxedTuple -> replicateM arity newOpenTypeKind - ConstraintTuple -> return (replicate arity constraintKind) - ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds - ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind } - where - arity = length tys - -finish_tuple :: HsType GhcRn - -> TupleSort - -> [TcType] -- ^ argument types - -> [TcKind] -- ^ of these kinds - -> TcKind -- ^ expected kind of the whole tuple - -> TcM TcType -finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do - traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind) - case tup_sort of - ConstraintTuple - | [tau_ty] <- tau_tys - -- Drop any uses of 1-tuple constraints here. - -- See Note [Ignore unary constraint tuples] - -> check_expected_kind tau_ty constraintKind - | arity > mAX_CTUPLE_SIZE - -> failWith (bigConstraintTuple arity) - | otherwise - -> do tycon <- tcLookupTyCon (cTupleTyConName arity) - check_expected_kind (mkTyConApp tycon tau_tys) constraintKind - BoxedTuple -> do - let tycon = tupleTyCon Boxed arity - checkWiredInTyCon tycon - check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind - UnboxedTuple -> - let tycon = tupleTyCon Unboxed arity - tau_reps = map kindRep tau_kinds - -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - arg_tys = tau_reps ++ tau_tys - res_kind = unboxedTupleKind tau_reps in - check_expected_kind (mkTyConApp tycon arg_tys) res_kind - where - arity = length tau_tys - check_expected_kind ty act_kind = - checkExpectedKind rn_ty ty act_kind exp_kind - -bigConstraintTuple :: Arity -> MsgDoc -bigConstraintTuple arity - = hang (text "Constraint tuple arity too large:" <+> int arity - <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) - 2 (text "Instead, use a nested tuple") - -{- -Note [Ignore unary constraint tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in -TysWiredIn) but does *not* provide unary constraint tuples. Why? First, -recall the definition of a unary tuple data type: - - data Unit a = Unit a - -Note that `Unit a` is *not* the same thing as `a`, since Unit is boxed and -lazy. Therefore, the presence of `Unit` matters semantically. On the other -hand, suppose we had a unary constraint tuple: - - class a => Unit% a - -This compiles down a newtype (i.e., a cast) in Core, so `Unit% a` is -semantically equivalent to `a`. Therefore, a 1-tuple constraint would have -no user-visible impact, nor would it allow you to express anything that -you couldn't otherwise. - -We could simply add Unit% for consistency with tuples (Unit) and unboxed -tuples (Unit#), but that would require even more magic to wire in another -magical class, so we opt not to do so. We must be careful, however, since -one can try to sneak in uses of unary constraint tuples through Template -Haskell, such as in this program (from #17511): - - f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)] - (ConT ''String))) - -- f :: Unit% (Show Int) => String - f = "abc" - -This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1, -and since it is used in a Constraint position, GHC will attempt to treat -it as thought it were a constraint tuple, which can potentially lead to -trouble if one attempts to look up the name of a constraint tuple of arity -1 (as it won't exist). To avoid this trouble, we simply take any unary -constraint tuples discovered when typechecking and drop them—i.e., treat -"Unit% a" as though the user had written "a". This is always safe to do -since the two constraints should be semantically equivalent. --} - -{- ********************************************************************* -* * - Type applications -* * -********************************************************************* -} - -splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn]) -splitHsAppTys hs_ty - | is_app hs_ty = Just (go (noLoc hs_ty) []) - | otherwise = Nothing - where - is_app :: HsType GhcRn -> Bool - is_app (HsAppKindTy {}) = True - is_app (HsAppTy {}) = True - is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey) - -- I'm not sure why this funTyConKey test is necessary - -- Can it even happen? Perhaps for t1 `(->)` t2 - -- but then maybe it's ok to treat that like a normal - -- application rather than using the special rule for HsFunTy - is_app (HsTyVar {}) = True - is_app (HsParTy _ (L _ ty)) = is_app ty - is_app _ = False - - go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) - go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as) - go (L sp (HsParTy _ f)) as = go f (HsArgPar sp : as) - go (L _ (HsOpTy _ l op@(L sp _) r)) as - = ( L sp (HsTyVar noExtField NotPromoted op) - , HsValArg l : HsValArg r : as ) - go f as = (f, as) - ---------------------------- -tcInferAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) --- Version of tc_infer_lhs_type specialised for the head of an --- application. In particular, for a HsTyVar (which includes type --- constructors, it does not zoom off into tcInferApps and family --- saturation -tcInferAppHead mode (L _ (HsTyVar _ _ (L _ tv))) - = tcTyVar mode tv -tcInferAppHead mode ty - = tc_infer_lhs_type mode ty - ---------------------------- --- | Apply a type of a given kind to a list of arguments. This instantiates --- invisible parameters as necessary. Always consumes all the arguments, --- using matchExpectedFunKind as necessary. --- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.- --- These kinds should be used to instantiate invisible kind variables; --- they come from an enclosing class for an associated type/data family. --- --- tcInferApps also arranges to saturate any trailing invisible arguments --- of a type-family application, which is usually the right thing to do --- tcInferApps_nosat does not do this saturation; it is used only --- by ":kind" in GHCi -tcInferApps, tcInferApps_nosat - :: TcTyMode - -> LHsType GhcRn -- ^ Function (for printing only) - -> TcType -- ^ Function - -> [LHsTypeArg GhcRn] -- ^ Args - -> TcM (TcType, TcKind) -- ^ (f args, args, result kind) -tcInferApps mode hs_ty fun hs_args - = do { (f_args, res_k) <- tcInferApps_nosat mode hs_ty fun hs_args - ; saturateFamApp f_args res_k } - -tcInferApps_nosat mode orig_hs_ty fun orig_hs_args - = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args) - ; (f_args, res_k) <- go_init 1 fun orig_hs_args - ; traceTc "tcInferApps }" (ppr f_args <+> dcolon <+> ppr res_k) - ; return (f_args, res_k) } - where - - -- go_init just initialises the auxiliary - -- arguments of the 'go' loop - go_init n fun all_args - = go n fun empty_subst fun_ki all_args - where - fun_ki = tcTypeKind fun - -- We do (tcTypeKind fun) here, even though the caller - -- knows the function kind, to absolutely guarantee - -- INVARIANT for 'go' - -- Note that in a typical application (F t1 t2 t3), - -- the 'fun' is just a TyCon, so tcTypeKind is fast - - empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfType fun_ki - - go :: Int -- The # of the next argument - -> TcType -- Function applied to some args - -> TCvSubst -- Applies to function kind - -> TcKind -- Function kind - -> [LHsTypeArg GhcRn] -- Un-type-checked args - -> TcM (TcType, TcKind) -- Result type and its kind - -- INVARIANT: in any call (go n fun subst fun_ki args) - -- tcTypeKind fun = subst(fun_ki) - -- So the 'subst' and 'fun_ki' arguments are simply - -- there to avoid repeatedly calling tcTypeKind. - -- - -- Reason for INVARIANT: to support the Purely Kinded Type Invariant - -- it's important that if fun_ki has a forall, then so does - -- (tcTypeKind fun), because the next thing we are going to do - -- is apply 'fun' to an argument type. - - -- Dispatch on all_args first, for performance reasons - go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of - - ---------------- No user-written args left. We're done! - ([], _) -> return (fun, substTy subst fun_ki) - - ---------------- HsArgPar: We don't care about parens here - (HsArgPar _ : args, _) -> go n fun subst fun_ki args - - ---------------- HsTypeArg: a kind application (fun @ki) - (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) -> - case ki_binder of - - -- FunTy with PredTy on LHS, or ForAllTy with Inferred - Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki - Anon InvisArg _ -> instantiate ki_binder inner_ki - - Named (Bndr _ Specified) -> -- Visible kind application - do { traceTc "tcInferApps (vis kind app)" - (vcat [ ppr ki_binder, ppr hs_ki_arg - , ppr (tyBinderType ki_binder) - , ppr subst ]) - - ; let exp_kind = substTy subst $ tyBinderType ki_binder - - ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $ - unsetWOptM Opt_WarnPartialTypeSignatures $ - setXOptM LangExt.PartialTypeSignatures $ - -- Urgh! see Note [Wildcards in visible kind application] - -- ToDo: must kill this ridiculous messing with DynFlags - tc_lhs_type (kindLevel mode) hs_ki_arg exp_kind - - ; traceTc "tcInferApps (vis kind app)" (ppr exp_kind) - ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg - ; go (n+1) fun' subst' inner_ki hs_args } - - -- Attempted visible kind application (fun @ki), but fun_ki is - -- forall k -> blah or k1 -> k2 - -- So we need a normal application. Error. - _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki - - -- No binder; try applying the substitution, or fail if that's not possible - (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $ - ty_app_err ki_arg substed_fun_ki - - ---------------- HsValArg: a normal argument (fun ty) - (HsValArg arg : args, Just (ki_binder, inner_ki)) - -- next binder is invisible; need to instantiate it - | isInvisibleBinder ki_binder -- FunTy with InvisArg on LHS; - -- or ForAllTy with Inferred or Specified - -> instantiate ki_binder inner_ki - - -- "normal" case - | otherwise - -> do { traceTc "tcInferApps (vis normal app)" - (vcat [ ppr ki_binder - , ppr arg - , ppr (tyBinderType ki_binder) - , ppr subst ]) - ; let exp_kind = substTy subst $ tyBinderType ki_binder - ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $ - tc_lhs_type mode arg exp_kind - ; traceTc "tcInferApps (vis normal app) 2" (ppr exp_kind) - ; (subst', fun') <- mkAppTyM subst fun ki_binder arg' - ; go (n+1) fun' subst' inner_ki args } - - -- no binder; try applying the substitution, or infer another arrow in fun kind - (HsValArg _ : _, Nothing) - -> try_again_after_substing_or $ - do { let arrows_needed = n_initial_val_args all_args - ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki - - ; fun' <- zonkTcType (fun `mkTcCastTy` co) - -- This zonk is essential, to expose the fruits - -- of matchExpectedFunKind to the 'go' loop - - ; traceTc "tcInferApps (no binder)" $ - vcat [ ppr fun <+> dcolon <+> ppr fun_ki - , ppr arrows_needed - , ppr co - , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')] - ; go_init n fun' all_args } - -- Use go_init to establish go's INVARIANT - where - instantiate ki_binder inner_ki - = do { traceTc "tcInferApps (need to instantiate)" - (vcat [ ppr ki_binder, ppr subst]) - ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder - ; go n (mkAppTy fun arg') subst' inner_ki all_args } - -- Because tcInvisibleTyBinder instantiate ki_binder, - -- the kind of arg' will have the same shape as the kind - -- of ki_binder. So we don't need mkAppTyM here. - - try_again_after_substing_or fallthrough - | not (isEmptyTCvSubst subst) - = go n fun zapped_subst substed_fun_ki all_args - | otherwise - = fallthrough - - zapped_subst = zapTCvSubst subst - substed_fun_ki = substTy subst fun_ki - hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) - - n_initial_val_args :: [HsArg tm ty] -> Arity - -- Count how many leading HsValArgs we have - n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args - n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args - n_initial_val_args _ = 0 - - ty_app_err arg ty - = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty) - $$ text "to visible kind argument" <+> quotes (ppr arg) - - -mkAppTyM :: TCvSubst - -> TcType -> TyCoBinder -- fun, plus its top-level binder - -> TcType -- arg - -> TcM (TCvSubst, TcType) -- Extended subst, plus (fun arg) --- Precondition: the application (fun arg) is well-kinded after zonking --- That is, the application makes sense --- --- Precondition: for (mkAppTyM subst fun bndr arg) --- tcTypeKind fun = Pi bndr. body --- That is, fun always has a ForAllTy or FunTy at the top --- and 'bndr' is fun's pi-binder --- --- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type --- invariant, then so does the result type (fun arg) --- --- We do not require that --- tcTypeKind arg = tyVarKind (binderVar bndr) --- This must be true after zonking (precondition 1), but it's not --- required for the (PKTI). -mkAppTyM subst fun ki_binder arg - | -- See Note [mkAppTyM]: Nasty case 2 - TyConApp tc args <- fun - , isTypeSynonymTyCon tc - , args `lengthIs` (tyConArity tc - 1) - , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym - = do { arg' <- zonkTcType arg - ; args' <- zonkTcTypes args - ; let subst' = case ki_binder of - Anon {} -> subst - Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg' - ; return (subst', mkTyConApp tc (args' ++ [arg'])) } - - -mkAppTyM subst fun (Anon {}) arg - = return (subst, mk_app_ty fun arg) - -mkAppTyM subst fun (Named (Bndr tv _)) arg - = do { arg' <- if isTrickyTvBinder tv - then -- See Note [mkAppTyM]: Nasty case 1 - zonkTcType arg - else return arg - ; return ( extendTvSubstAndInScope subst tv arg' - , mk_app_ty fun arg' ) } - -mk_app_ty :: TcType -> TcType -> TcType --- This function just adds an ASSERT for mkAppTyM's precondition -mk_app_ty fun arg - = ASSERT2( isPiTy fun_kind - , ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg ) - mkAppTy fun arg - where - fun_kind = tcTypeKind fun - -isTrickyTvBinder :: TcTyVar -> Bool --- NB: isTrickyTvBinder is just an optimisation --- It would be absolutely sound to return True always -isTrickyTvBinder tv = isPiTy (tyVarKind tv) - -{- Note [The Purely Kinded Type Invariant (PKTI)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During type inference, we maintain this invariant - - (PKTI) It is legal to call 'tcTypeKind' on any Type ty, - on any sub-term of ty, /without/ zonking ty - - Moreover, any such returned kind - will itself satisfy (PKTI) - -By "legal to call tcTypeKind" we mean "tcTypeKind will not crash". -The way in which tcTypeKind can crash is in applications - (a t1 t2 .. tn) -if 'a' is a type variable whose kind doesn't have enough arrows -or foralls. (The crash is in piResultTys.) - -The loop in tcInferApps has to be very careful to maintain the (PKTI). -For example, suppose - kappa is a unification variable - We have already unified kappa := Type - yielding co :: Refl (Type -> Type) - a :: kappa -then consider the type - (a Int) -If we call tcTypeKind on that, we'll crash, because the (un-zonked) -kind of 'a' is just kappa, not an arrow kind. So we must zonk first. - -So the type inference engine is very careful when building applications. -This happens in tcInferApps. Suppose we are kind-checking the type (a Int), -where (a :: kappa). Then in tcInferApps we'll run out of binders on -a's kind, so we'll call matchExpectedFunKind, and unify - kappa := kappa1 -> kappa2, with evidence co :: kappa ~ (kappa1 ~ kappa2) -At this point we must zonk the function type to expose the arrrow, so -that (a Int) will satisfy (PKTI). - -The absence of this caused #14174 and #14520. - -The calls to mkAppTyM is the other place we are very careful. - -Note [mkAppTyM] -~~~~~~~~~~~~~~~ -mkAppTyM is trying to guarantee the Purely Kinded Type Invariant -(PKTI) for its result type (fun arg). There are two ways it can go wrong: - -* Nasty case 1: forall types (polykinds/T14174a) - T :: forall (p :: *->*). p Int -> p Bool - Now kind-check (T x), where x::kappa. - Well, T and x both satisfy the PKTI, but - T x :: x Int -> x Bool - and (x Int) does /not/ satisfy the PKTI. - -* Nasty case 2: type synonyms - type S f a = f a - Even though (S ff aa) would satisfy the (PKTI) if S was a data type - (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI) - if S is a type synonym, because the /expansion/ of (S ff aa) is - (ff aa), and /that/ does not satisfy (PKTI). E.g. perhaps - (ff :: kappa), where 'kappa' has already been unified with (*->*). - - We check for nasty case 2 on the final argument of a type synonym. - -Notice that in both cases the trickiness only happens if the -bound variable has a pi-type. Hence isTrickyTvBinder. --} - - -saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) --- Precondition for (saturateFamApp ty kind): --- tcTypeKind ty = kind --- --- If 'ty' is an unsaturated family application with trailing --- invisible arguments, instanttiate them. --- See Note [saturateFamApp] - -saturateFamApp ty kind - | Just (tc, args) <- tcSplitTyConApp_maybe ty - , mustBeSaturated tc - , let n_to_inst = tyConArity tc - length args - = do { (extra_args, ki') <- tcInstInvisibleTyBinders n_to_inst kind - ; return (ty `mkTcAppTys` extra_args, ki') } - | otherwise - = return (ty, kind) - -{- Note [saturateFamApp] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type family F :: Either j k - type instance F @Type = Right Maybe - type instance F @Type = Right Either``` - -Then F :: forall {j,k}. Either j k - -The two type instances do a visible kind application that instantiates -'j' but not 'k'. But we want to end up with instances that look like - type instance F @Type @(*->*) = Right @Type @(*->*) Maybe - -so that F has arity 2. We must instantiate that trailing invisible -binder. In general, Invisible binders precede Specified and Required, -so this is only going to bite for apparently-nullary families. - -Note that - type family F2 :: forall k. k -> * -is quite different and really does have arity 0. - -It's not just type instances where we need to saturate those -unsaturated arguments: see #11246. Hence doing this in tcInferApps. --} - -appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn -appTypeToArg f [] = f -appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args -appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args -appTypeToArg f (HsTypeArg l arg : args) - = appTypeToArg (mkHsAppKindTy l f arg) args - - -{- ********************************************************************* -* * - checkExpectedKind -* * -********************************************************************* -} - --- | This instantiates invisible arguments for the type being checked if it must --- be saturated and is not yet saturated. It then calls and uses the result --- from checkExpectedKindX to build the final type -checkExpectedKind :: HasDebugCallStack - => HsType GhcRn -- ^ type we're checking (for printing) - -> TcType -- ^ type we're checking - -> TcKind -- ^ the known kind of that type - -> TcKind -- ^ the expected kind - -> TcM TcType --- Just a convenience wrapper to save calls to 'ppr' -checkExpectedKind hs_ty ty act_kind exp_kind - = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind) - - ; (new_args, act_kind') <- tcInstInvisibleTyBinders n_to_inst act_kind - - ; let origin = TypeEqOrigin { uo_actual = act_kind' - , uo_expected = exp_kind - , uo_thing = Just (ppr hs_ty) - , uo_visible = True } -- the hs_ty is visible - - ; traceTc "checkExpectedKindX" $ - vcat [ ppr hs_ty - , text "act_kind':" <+> ppr act_kind' - , text "exp_kind:" <+> ppr exp_kind ] - - ; let res_ty = ty `mkTcAppTys` new_args - - ; if act_kind' `tcEqType` exp_kind - then return res_ty -- This is very common - else do { co_k <- uType KindLevel origin act_kind' exp_kind - ; traceTc "checkExpectedKind" (vcat [ ppr act_kind - , ppr exp_kind - , ppr co_k ]) - ; return (res_ty `mkTcCastTy` co_k) } } - where - -- We need to make sure that both kinds have the same number of implicit - -- foralls out front. If the actual kind has more, instantiate accordingly. - -- Otherwise, just pass the type & kind through: the errors are caught - -- in unifyType. - n_exp_invis_bndrs = invisibleTyBndrCount exp_kind - n_act_invis_bndrs = invisibleTyBndrCount act_kind - n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs - ---------------------------- -tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] -tcHsMbContext Nothing = return [] -tcHsMbContext (Just cxt) = tcHsContext cxt - -tcHsContext :: LHsContext GhcRn -> TcM [PredType] -tcHsContext = tc_hs_context typeLevelMode - -tcLHsPredType :: LHsType GhcRn -> TcM PredType -tcLHsPredType = tc_lhs_pred typeLevelMode - -tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType] -tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt) - -tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType -tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind - ---------------------------- -tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind) --- See Note [Type checking recursive type and class declarations] --- in TcTyClsDecls -tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon - = do { traceTc "lk1" (ppr name) - ; thing <- tcLookup name - ; case thing of - ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) - - ATcTyCon tc_tc - -> do { -- See Note [GADT kind self-reference] - unless (isTypeLevel (mode_level mode)) - (promotionErr name TyConPE) - ; check_tc tc_tc - ; return (mkTyConTy tc_tc, tyConKind tc_tc) } - - AGlobal (ATyCon tc) - -> do { check_tc tc - ; return (mkTyConTy tc, tyConKind tc) } - - AGlobal (AConLike (RealDataCon dc)) - -> do { data_kinds <- xoptM LangExt.DataKinds - ; unless (data_kinds || specialPromotedDc dc) $ - promotionErr name NoDataKindsDC - ; when (isFamInstTyCon (dataConTyCon dc)) $ - -- see #15245 - promotionErr name FamDataConPE - ; let (_, _, _, theta, _, _) = dataConFullSig dc - ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta)) - ; case dc_theta_illegal_constraint theta of - Just pred -> promotionErr name $ - ConstrainedDataConPE pred - Nothing -> pure () - ; let tc = promoteDataCon dc - ; return (mkTyConApp tc [], tyConKind tc) } - - APromotionErr err -> promotionErr name err - - _ -> wrongThingErr "type" thing name } - where - check_tc :: TyCon -> TcM () - check_tc tc = do { data_kinds <- xoptM LangExt.DataKinds - ; unless (isTypeLevel (mode_level mode) || - data_kinds || - isKindTyCon tc) $ - promotionErr name NoDataKindsTC } - - -- We cannot promote a data constructor with a context that contains - -- constraints other than equalities, so error if we find one. - -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep - dc_theta_illegal_constraint :: ThetaType -> Maybe PredType - dc_theta_illegal_constraint = find (not . isEqPred) - -{- -Note [GADT kind self-reference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A promoted type cannot be used in the body of that type's declaration. -#11554 shows this example, which made GHC loop: - - import Data.Kind - data P (x :: k) = Q - data A :: Type where - B :: forall (a :: A). P a -> A - -In order to check the constructor B, we need to have the promoted type A, but in -order to get that promoted type, B must first be checked. To prevent looping, a -TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode. -Any ATcTyCon is a TyCon being defined in the current recursive group (see data -type decl for TcTyThing), and all such TyCons are illegal in kinds. - -#11962 proposes checking the head of a data declaration separately from -its constructors. This would allow the example above to pass. - -Note [Body kind of a HsForAllTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The body of a forall is usually a type, but in principle -there's no reason to prohibit *unlifted* types. -In fact, GHC can itself construct a function with an -unboxed tuple inside a for-all (via CPR analysis; see -typecheck/should_compile/tc170). - -Moreover in instance heads we get forall-types with -kind Constraint. - -It's tempting to check that the body kind is either * or #. But this is -wrong. For example: - - class C a b - newtype N = Mk Foo deriving (C a) - -We're doing newtype-deriving for C. But notice how `a` isn't in scope in -the predicate `C a`. So we quantify, yielding `forall a. C a` even though -`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but -convenient. Bottom line: don't check for * or # here. - -Note [Body kind of a HsQualTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If ctxt is non-empty, the HsQualTy really is a /function/, so the -kind of the result really is '*', and in that case the kind of the -body-type can be lifted or unlifted. - -However, consider - instance Eq a => Eq [a] where ... -or - f :: (Eq a => Eq [a]) => blah -Here both body-kind of the HsQualTy is Constraint rather than *. -Rather crudely we tell the difference by looking at exp_kind. It's -very convenient to typecheck instance types like any other HsSigType. - -Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's -better to reject in checkValidType. If we say that the body kind -should be '*' we risk getting TWO error messages, one saying that Eq -[a] doesn't have kind '*', and one saying that we need a Constraint to -the left of the outer (=>). - -How do we figure out the right body kind? Well, it's a bit of a -kludge: I just look at the expected kind. If it's Constraint, we -must be in this instance situation context. It's a kludge because it -wouldn't work if any unification was involved to compute that result -kind -- but it isn't. (The true way might be to use the 'mode' -parameter, but that seemed like a sledgehammer to crack a nut.) - -Note [Inferring tuple kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, -we try to figure out whether it's a tuple of kind * or Constraint. - Step 1: look at the expected kind - Step 2: infer argument kinds - -If after Step 2 it's not clear from the arguments that it's -Constraint, then it must be *. Once having decided that we re-check -the arguments to give good error messages in - e.g. (Maybe, Maybe) - -Note that we will still fail to infer the correct kind in this case: - - type T a = ((a,a), D a) - type family D :: Constraint -> Constraint - -While kind checking T, we do not yet know the kind of D, so we will default the -kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. - -Note [Desugaring types] -~~~~~~~~~~~~~~~~~~~~~~~ -The type desugarer is phase 2 of dealing with HsTypes. Specifically: - - * It transforms from HsType to Type - - * It zonks any kinds. The returned type should have no mutable kind - or type variables (hence returning Type not TcType): - - any unconstrained kind variables are defaulted to (Any *) just - as in TcHsSyn. - - there are no mutable type variables because we are - kind-checking a type - Reason: the returned type may be put in a TyCon or DataCon where - it will never subsequently be zonked. - -You might worry about nested scopes: - ..a:kappa in scope.. - let f :: forall b. T '[a,b] -> Int -In this case, f's type could have a mutable kind variable kappa in it; -and we might then default it to (Any *) when dealing with f's type -signature. But we don't expect this to happen because we can't get a -lexically scoped type variable with a mutable kind variable in it. A -delicate point, this. If it becomes an issue we might need to -distinguish top-level from nested uses. - -Moreover - * it cannot fail, - * it does no unifications - * it does no validity checking, except for structural matters, such as - (a) spurious ! annotations. - (b) a class used as a type - -Note [Kind of a type splice] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider these terms, each with TH type splice inside: - [| e1 :: Maybe $(..blah..) |] - [| e2 :: $(..blah..) |] -When kind-checking the type signature, we'll kind-check the splice -$(..blah..); we want to give it a kind that can fit in any context, -as if $(..blah..) :: forall k. k. - -In the e1 example, the context of the splice fixes kappa to *. But -in the e2 example, we'll desugar the type, zonking the kind unification -variables as we go. When we encounter the unconstrained kappa, we -want to default it to '*', not to (Any *). - -Help functions for type applications -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --} - -addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a - -- Wrap a context around only if we want to show that contexts. - -- Omit invisible ones and ones user's won't grok -addTypeCtxt (L _ (HsWildCardTy _)) thing = thing -- "In the type '_'" just isn't helpful. -addTypeCtxt (L _ ty) thing - = addErrCtxt doc thing - where - doc = text "In the type" <+> quotes (ppr ty) - -{- -************************************************************************ -* * - Type-variable binders -%* * -%************************************************************************ - -Note [Keeping implicitly quantified variables in order] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the user implicitly quantifies over variables (say, in a type -signature), we need to come up with some ordering on these variables. -This is done by bumping the TcLevel, bringing the tyvars into scope, -and then type-checking the thing_inside. The constraints are all -wrapped in an implication, which is then solved. Finally, we can -zonk all the binders and then order them with scopedSort. - -It's critical to solve before zonking and ordering in order to uncover -any unifications. You might worry that this eager solving could cause -trouble elsewhere. I don't think it will. Because it will solve only -in an increased TcLevel, it can't unify anything that was mentioned -elsewhere. Additionally, we require that the order of implicitly -quantified variables is manifest by the scope of these variables, so -we're not going to learn more information later that will help order -these variables. - -Note [Recipe for checking a signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Checking a user-written signature requires several steps: - - 1. Generate constraints. - 2. Solve constraints. - 3. Promote tyvars and/or kind-generalize. - 4. Zonk. - 5. Check validity. - -There may be some surprises in here: - -Step 2 is necessary for two reasons: most signatures also bring -implicitly quantified variables into scope, and solving is necessary -to get these in the right order (see Note [Keeping implicitly -quantified variables in order]). Additionally, solving is necessary in -order to kind-generalize correctly: otherwise, we do not know which -metavariables are left unsolved. - -Step 3 is done by a call to candidateQTyVarsOfType, followed by a call to -kindGeneralize{All,Some,None}. Here, we have to deal with the fact that -metatyvars generated in the type may have a bumped TcLevel, because explicit -foralls raise the TcLevel. To avoid these variables from ever being visible in -the surrounding context, we must obey the following dictum: - - Every metavariable in a type must either be - (A) generalized, or - (B) promoted, or See Note [Promotion in signatures] - (C) a cause to error See Note [Naughty quantification candidates] in TcMType - -The kindGeneralize functions do not require pre-zonking; they zonk as they -go. - -If you are actually doing kind-generalization, you need to bump the level -before generating constraints, as we will only generalize variables with -a TcLevel higher than the ambient one. - -After promoting/generalizing, we need to zonk again because both -promoting and generalizing fill in metavariables. - -Note [Promotion in signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If an unsolved metavariable in a signature is not generalized -(because we're not generalizing the construct -- e.g., pattern -sig -- or because the metavars are constrained -- see kindGeneralizeSome) -we need to promote to maintain (WantedTvInv) of Note [TcLevel and untouchable type variables] -in TcType. Note that promotion is identical in effect to generalizing -and the reinstantiating with a fresh metavariable at the current level. -So in some sense, we generalize *all* variables, but then re-instantiate -some of them. - -Here is an example of why we must promote: - foo (x :: forall a. a -> Proxy b) = ... - -In the pattern signature, `b` is unbound, and will thus be brought into -scope. We do not know its kind: it will be assigned kappa[2]. Note that -kappa is at TcLevel 2, because it is invented under a forall. (A priori, -the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel -than the surrounding context.) This kappa cannot be solved for while checking -the pattern signature (which is not kind-generalized). When we are checking -the *body* of foo, though, we need to unify the type of x with the argument -type of bar. At this point, the ambient TcLevel is 1, and spotting a -matavariable with level 2 would violate the (WantedTvInv) invariant of -Note [TcLevel and untouchable type variables]. So, instead of kind-generalizing, -we promote the metavariable to level 1. This is all done in kindGeneralizeNone. - --} - -tcNamedWildCardBinders :: [Name] - -> ([(Name, TcTyVar)] -> TcM a) - -> TcM a --- Bring into scope the /named/ wildcard binders. Remember that --- plain wildcards _ are anonymous and dealt with by HsWildCardTy --- Soe Note [The wildcard story for types] in GHC.Hs.Types -tcNamedWildCardBinders wc_names thing_inside - = do { wcs <- mapM (const newWildTyVar) wc_names - ; let wc_prs = wc_names `zip` wcs - ; tcExtendNameTyVarEnv wc_prs $ - thing_inside wc_prs } - -newWildTyVar :: TcM TcTyVar --- ^ New unification variable '_' for a wildcard -newWildTyVar - = do { kind <- newMetaKindVar - ; uniq <- newUnique - ; details <- newMetaDetails TauTv - ; let name = mkSysTvName uniq (fsLit "_") - tyvar = mkTcTyVar name kind details - ; traceTc "newWildTyVar" (ppr tyvar) - ; return tyvar } - -{- ********************************************************************* -* * - Kind inference for type declarations -* * -********************************************************************* -} - --- See Note [kcCheckDeclHeader vs kcInferDeclHeader] -data InitialKindStrategy - = InitialKindCheck SAKS_or_CUSK - | InitialKindInfer - --- Does the declaration have a standalone kind signature (SAKS) or a complete --- user-specified kind (CUSK)? -data SAKS_or_CUSK - = SAKS Kind -- Standalone kind signature, fully zonked! (zonkTcTypeToType) - | CUSK -- Complete user-specified kind (CUSK) - -instance Outputable SAKS_or_CUSK where - ppr (SAKS k) = text "SAKS" <+> ppr k - ppr CUSK = text "CUSK" - --- See Note [kcCheckDeclHeader vs kcInferDeclHeader] -kcDeclHeader - :: InitialKindStrategy - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon -kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig -kcDeclHeader InitialKindInfer = kcInferDeclHeader - -{- Note [kcCheckDeclHeader vs kcInferDeclHeader] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind -of a type constructor. - -* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that - case, find the full, final, poly-kinded kind of the TyCon. It's very like a - term-level binding where we have a complete type signature for the function. - -* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a - CUSK. Find a monomorphic kind, with unification variables in it; they will be - generalised later. It's very like a term-level binding where we do not have a - type signature (or, more accurately, where we have a partial type signature), - so we infer the type and generalise. --} - ------------------------------- -kcCheckDeclHeader - :: SAKS_or_CUSK - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM TcTyCon -- ^ A suitably-kinded generalized TcTyCon -kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig -kcCheckDeclHeader CUSK = kcCheckDeclHeader_cusk - -kcCheckDeclHeader_cusk - :: Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded generalized TcTyCon -kcCheckDeclHeader_cusk name flav - (HsQTvs { hsq_ext = kv_ns - , hsq_explicit = hs_tvs }) kc_res_ki - -- CUSK case - -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls - = addTyConFlavCtxt name flav $ - do { (scoped_kvs, (tc_tvs, res_kind)) - <- pushTcLevelM_ $ - solveEqualities $ - bindImplicitTKBndrs_Q_Skol kv_ns $ - bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $ - newExpectedKind =<< kc_res_ki - - -- Now, because we're in a CUSK, - -- we quantify over the mentioned kind vars - ; let spec_req_tkvs = scoped_kvs ++ tc_tvs - all_kinds = res_kind : map tyVarKind spec_req_tkvs - - ; candidates' <- candidateQTyVarsOfKinds all_kinds - -- 'candidates' are all the variables that we are going to - -- skolemise and then quantify over. We do not include spec_req_tvs - -- because they are /already/ skolems - - ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds)) - candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates } - inf_candidates = candidates `delCandidates` spec_req_tkvs - - ; inferred <- quantifyTyVars inf_candidates - -- NB: 'inferred' comes back sorted in dependency order - - ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs - ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs - ; res_kind <- zonkTcType res_kind - - ; let mentioned_kv_set = candidateKindVars candidates - specified = scopedSort scoped_kvs - -- NB: maintain the L-R order of scoped_kvs - - final_tc_binders = mkNamedTyConBinders Inferred inferred - ++ mkNamedTyConBinders Specified specified - ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs - - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs - True -- it is generalised - flav - -- If the ordering from - -- Note [Required, Specified, and Inferred for types] in TcTyClsDecls - -- doesn't work, we catch it here, before an error cascade - ; checkTyConTelescope tycon - - ; traceTc "kcCheckDeclHeader_cusk " $ - vcat [ text "name" <+> ppr name - , text "kv_ns" <+> ppr kv_ns - , text "hs_tvs" <+> ppr hs_tvs - , text "scoped_kvs" <+> ppr scoped_kvs - , text "tc_tvs" <+> ppr tc_tvs - , text "res_kind" <+> ppr res_kind - , text "candidates" <+> ppr candidates - , text "inferred" <+> ppr inferred - , text "specified" <+> ppr specified - , text "final_tc_binders" <+> ppr final_tc_binders - , text "mkTyConKind final_tc_bndrs res_kind" - <+> ppr (mkTyConKind final_tc_binders res_kind) - , text "all_tv_prs" <+> ppr all_tv_prs ] - - ; return tycon } - where - ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind - | otherwise = AnyKind -kcCheckDeclHeader_cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec - --- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and --- other kinds). --- --- This function does not do telescope checking. -kcInferDeclHeader - :: Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded non-generalized TcTyCon -kcInferDeclHeader name flav - (HsQTvs { hsq_ext = kv_ns - , hsq_explicit = hs_tvs }) kc_res_ki - -- No standalane kind signature and no CUSK. - -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls - = addTyConFlavCtxt name flav $ - do { (scoped_kvs, (tc_tvs, res_kind)) - -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar? - -- See Note [Inferring kinds for type declarations] in TcTyClsDecls - <- bindImplicitTKBndrs_Q_Tv kv_ns $ - bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $ - newExpectedKind =<< kc_res_ki - -- Why "_Tv" not "_Skol"? See third wrinkle in - -- Note [Inferring kinds for type declarations] in TcTyClsDecls, - - ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they - -- might unify with kind vars in other types in a mutually - -- recursive group. - -- See Note [Inferring kinds for type declarations] in TcTyClsDecls - - tc_binders = mkAnonTyConBinders VisArg tc_tvs - -- Also, note that tc_binders has the tyvars from only the - -- user-written tyvarbinders. See S1 in Note [How TcTyCons work] - -- in TcTyClsDecls - -- - -- mkAnonTyConBinder: see Note [No polymorphic recursion] - - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - -- NB: bindExplicitTKBndrs_Q_Tv does not clone; - -- ditto Implicit - -- See Note [Non-cloning for tyvar binders] - - tycon = mkTcTyCon name tc_binders res_kind all_tv_prs - False -- not yet generalised - flav - - ; traceTc "kcInferDeclHeader: not-cusk" $ - vcat [ ppr name, ppr kv_ns, ppr hs_tvs - , ppr scoped_kvs - , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] - ; return tycon } - where - ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind - | otherwise = AnyKind - -kcInferDeclHeader _ _ (XLHsQTyVars nec) _ = noExtCon nec - --- | Kind-check a declaration header against a standalone kind signature. --- See Note [Arity inference in kcCheckDeclHeader_sig] -kcCheckDeclHeader_sig - :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon -kcCheckDeclHeader_sig kisig name flav - (HsQTvs { hsq_ext = implicit_nms - , hsq_explicit = explicit_nms }) kc_res_ki - = addTyConFlavCtxt name flav $ - do { -- Step 1: zip user-written binders with quantifiers from the kind signature. - -- For example: - -- - -- type F :: forall k -> k -> forall j. j -> Type - -- data F i a b = ... - -- - -- Results in the following 'zipped_binders': - -- - -- TyBinder LHsTyVarBndr - -- --------------------------------------- - -- ZippedBinder forall k -> i - -- ZippedBinder k -> a - -- ZippedBinder forall j. - -- ZippedBinder j -> b - -- - let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig explicit_nms - - -- Report binders that don't have a corresponding quantifier. - -- For example: - -- - -- type T :: Type -> Type - -- data T b1 b2 b3 = ... - -- - -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders. - -- - ; unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs) - - -- Convert each ZippedBinder to TyConBinder for tyConBinders - -- and to [(Name, TcTyVar)] for tcTyConScopedTyVars - ; (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders - - ; (implicit_tvs, (invis_binders, r_ki)) - <- pushTcLevelM_ $ - solveEqualities $ -- #16687 - bindImplicitTKBndrs_Tv implicit_nms $ - tcExtendNameTyVarEnv explicit_tv_prs $ - do { -- Check that inline kind annotations on binders are valid. - -- For example: - -- - -- type T :: Maybe k -> Type - -- data T (a :: Maybe j) = ... - -- - -- Here we unify Maybe k ~ Maybe j - mapM_ check_zipped_binder zipped_binders - - -- Kind-check the result kind annotation, if present: - -- - -- data T a b :: res_ki where - -- ^^^^^^^^^ - -- We do it here because at this point the environment has been - -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'. - ; ctx_k <- kc_res_ki - ; m_res_ki <- case ctx_k of - AnyKind -> return Nothing - _ -> Just <$> newExpectedKind ctx_k - - -- Step 2: split off invisible binders. - -- For example: - -- - -- type F :: forall k1 k2. (k1, k2) -> Type - -- type family F - -- - -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'? - -- See Note [Arity inference in kcCheckDeclHeader_sig] - ; let (invis_binders, r_ki) = split_invis kisig' m_res_ki - - -- Check that the inline result kind annotation is valid. - -- For example: - -- - -- type T :: Type -> Maybe k - -- type family T a :: Maybe j where - -- - -- Here we unify Maybe k ~ Maybe j - ; whenIsJust m_res_ki $ \res_ki -> - discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind Nothing r_ki res_ki - - ; return (invis_binders, r_ki) } - - -- Zonk the implicitly quantified variables. - ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs - - -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders. - ; invis_tcbs <- mapM invis_to_tcb invis_binders - - -- Build the final, generalized TcTyCon - ; let tcbs = vis_tcbs ++ invis_tcbs - implicit_tv_prs = implicit_nms `zip` implicit_tvs - all_tv_prs = implicit_tv_prs ++ explicit_tv_prs - tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav - - ; traceTc "kcCheckDeclHeader_sig done:" $ vcat - [ text "tyConName = " <+> ppr (tyConName tc) - , text "kisig =" <+> debugPprType kisig - , text "tyConKind =" <+> debugPprType (tyConKind tc) - , text "tyConBinders = " <+> ppr (tyConBinders tc) - , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc) - , text "tyConResKind" <+> debugPprType (tyConResKind tc) - ] - ; return tc } - where - -- Consider this declaration: - -- - -- type T :: forall a. forall b -> (a~b) => Proxy a -> Type - -- data T x p = MkT - -- - -- Here, we have every possible variant of ZippedBinder: - -- - -- TyBinder LHsTyVarBndr - -- ---------------------------------------------- - -- ZippedBinder forall {k}. - -- ZippedBinder forall (a::k). - -- ZippedBinder forall (b::k) -> x - -- ZippedBinder (a~b) => - -- ZippedBinder Proxy a -> p - -- - -- Given a ZippedBinder zipped_to_tcb produces: - -- - -- * TyConBinder for tyConBinders - -- * (Name, TcTyVar) for tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr - -- - zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)]) - zipped_to_tcb zb = case zb of - - -- Inferred variable, no user-written binder. - -- Example: forall {k}. - ZippedBinder (Named (Bndr v Specified)) Nothing -> - return (mkNamedTyConBinder Specified v, []) - - -- Specified variable, no user-written binder. - -- Example: forall (a::k). - ZippedBinder (Named (Bndr v Inferred)) Nothing -> - return (mkNamedTyConBinder Inferred v, []) - - -- Constraint, no user-written binder. - -- Example: (a~b) => - ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do - name <- newSysName (mkTyVarOccFS (fsLit "ev")) - let tv = mkTyVar name bndr_ki - return (mkAnonTyConBinder InvisArg tv, []) - - -- Non-dependent visible argument with a user-written binder. - -- Example: Proxy a -> - ZippedBinder (Anon VisArg bndr_ki) (Just b) -> - return $ - let v_name = getName b - tv = mkTyVar v_name bndr_ki - tcb = mkAnonTyConBinder VisArg tv - in (tcb, [(v_name, tv)]) - - -- Dependent visible argument with a user-written binder. - -- Example: forall (b::k) -> - ZippedBinder (Named (Bndr v Required)) (Just b) -> - return $ - let v_name = getName b - tcb = mkNamedTyConBinder Required v - in (tcb, [(v_name, v)]) - - -- 'zipBinders' does not produce any other variants of ZippedBinder. - _ -> panic "goVis: invalid ZippedBinder" - - -- Given an invisible binder that comes from 'split_invis', - -- convert it to TyConBinder. - invis_to_tcb :: TyCoBinder -> TcM TyConBinder - invis_to_tcb tb = do - (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing) - MASSERT(null stv) - return tcb - - -- Check that the inline kind annotation on a binder is valid - -- by unifying it with the kind of the quantifier. - check_zipped_binder :: ZippedBinder -> TcM () - check_zipped_binder (ZippedBinder _ Nothing) = return () - check_zipped_binder (ZippedBinder tb (Just b)) = - case unLoc b of - UserTyVar _ _ -> return () - KindedTyVar _ v v_hs_ki -> do - v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki - discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind (Just (HsTyVar noExtField NotPromoted v)) - (tyBinderType tb) - v_ki - XTyVarBndr nec -> noExtCon nec - - -- Split the invisible binders that should become a part of 'tyConBinders' - -- rather than 'tyConResKind'. - -- See Note [Arity inference in kcCheckDeclHeader_sig] - split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind) - split_invis sig_ki Nothing = - -- instantiate all invisible binders - splitPiTysInvisible sig_ki - split_invis sig_ki (Just res_ki) = - -- subtraction a la checkExpectedKind - let n_res_invis_bndrs = invisibleTyBndrCount res_ki - n_sig_invis_bndrs = invisibleTyBndrCount sig_ki - n_inst = n_sig_invis_bndrs - n_res_invis_bndrs - in splitPiTysInvisibleN n_inst sig_ki - -kcCheckDeclHeader_sig _ _ _ (XLHsQTyVars nec) _ = noExtCon nec - --- A quantifier from a kind signature zipped with a user-written binder for it. -data ZippedBinder = - ZippedBinder TyBinder (Maybe (LHsTyVarBndr GhcRn)) - --- See Note [Arity inference in kcCheckDeclHeader_sig] -zipBinders - :: Kind -- kind signature - -> [LHsTyVarBndr GhcRn] -- user-written binders - -> ([ZippedBinder], -- zipped binders - [LHsTyVarBndr GhcRn], -- remaining user-written binders - Kind) -- remainder of the kind signature -zipBinders = zip_binders [] - where - zip_binders acc ki [] = (reverse acc, [], ki) - zip_binders acc ki (b:bs) = - case tcSplitPiTy_maybe ki of - Nothing -> (reverse acc, b:bs, ki) - Just (tb, ki') -> - let - (zb, bs') | zippable = (ZippedBinder tb (Just b), bs) - | otherwise = (ZippedBinder tb Nothing, b:bs) - zippable = - case tb of - Named (Bndr _ Specified) -> False - Named (Bndr _ Inferred) -> False - Named (Bndr _ Required) -> True - Anon InvisArg _ -> False - Anon VisArg _ -> True - in - zip_binders (zb:acc) ki' bs' - -tooManyBindersErr :: Kind -> [LHsTyVarBndr GhcRn] -> SDoc -tooManyBindersErr ki bndrs = - hang (text "Not a function kind:") - 4 (ppr ki) $$ - hang (text "but extra binders found:") - 4 (fsep (map ppr bndrs)) - -{- Note [Arity inference in kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig -verifies that the declaration conforms to the signature. The end result is a -TcTyCon 'tc' such that: - - tyConKind tc == kisig - -This TcTyCon would be rather easy to produce if we didn't have to worry about -arity. Consider these declarations: - - type family S1 :: forall k. k -> Type - type family S2 (a :: k) :: Type - -Both S1 and S2 can be given the same standalone kind signature: - - type S2 :: forall k. k -> Type - -And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from -tyConBinders and tyConResKind, such that - - tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc) - -For S1 and S2, tyConBinders and tyConResKind are different: - - tyConBinders S1 == [] - tyConResKind S1 == forall k. k -> Type - tyConKind S1 == forall k. k -> Type - - tyConBinders S2 == [spec k, anon-vis (a :: k)] - tyConResKind S2 == Type - tyConKind S1 == forall k. k -> Type - -This difference determines the arity: - - tyConArity tc == length (tyConBinders tc) - -That is, the arity of S1 is 0, while the arity of S2 is 2. - -'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone -kind signature into binders and the result kind. It does so in two rounds: - -1. zip user-written binders (vis_tcbs) -2. split off invisible binders (invis_tcbs) - -Consider the following declarations: - - type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type - type family F a b - - type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type - type family G a b :: forall r2. (r1, r2) -> Type - -In step 1 (zip user-written binders), we zip the quantifiers in the signature -with the binders in the header using 'zipBinders'. In both F and G, this results in -the following zipped binders: - - TyBinder LHsTyVarBndr - --------------------------------------- - ZippedBinder Type -> a - ZippedBinder forall j. - ZippedBinder j -> b - - -At this point, we have accumulated three zipped binders which correspond to a -prefix of the standalone kind signature: - - Type -> forall j. j -> ... - -In step 2 (split off invisible binders), we have to decide how much remaining -invisible binders of the standalone kind signature to split off: - - forall k1 k2. (k1, k2) -> Type - ^^^^^^^^^^^^^ - split off or not? - -This decision is made in 'split_invis': - -* If a user-written result kind signature is not provided, as in F, - then split off all invisible binders. This is why we need special treatment - for AnyKind. -* If a user-written result kind signature is provided, as in G, - then do as checkExpectedKind does and split off (n_sig - n_res) binders. - That is, split off such an amount of binders that the remainder of the - standalone kind signature and the user-written result kind signature have the - same amount of invisible quantifiers. - -For F, split_invis splits away all invisible binders, and we have 2: - - forall k1 k2. (k1, k2) -> Type - ^^^^^^^^^^^^^ - split away both binders - -The resulting arity of F is 3+2=5. (length vis_tcbs = 3, - length invis_tcbs = 2, - length tcbs = 5) - -For G, split_invis decides to split off 1 invisible binder, so that we have the -same amount of invisible quantifiers left: - - res_ki = forall r2. (r1, r2) -> Type - kisig = forall k1 k2. (k1, k2) -> Type - ^^^ - split off this one. - -The resulting arity of G is 3+1=4. (length vis_tcbs = 3, - length invis_tcbs = 1, - length tcbs = 4) - --} - -{- Note [discardResult in kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use 'unifyKind' to check inline kind annotations in declaration headers -against the signature. - - type T :: [i] -> Maybe j -> Type - data T (a :: [k1]) (b :: Maybe k2) :: Type where ... - -Here, we will unify: - - [k1] ~ [i] - Maybe k2 ~ Maybe j - Type ~ Type - -The end result is that we fill in unification variables k1, k2: - - k1 := i - k2 := j - -We also validate that the user isn't confused: - - type T :: Type -> Type - data T (a :: Bool) = ... - -This will report that (Type ~ Bool) failed to unify. - -Now, consider the following example: - - type family Id a where Id x = x - type T :: Bool -> Type - type T (a :: Id Bool) = ... - -We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion. -However, we are free to discard it, as the kind of 'T' is determined by the -signature, not by the inline kind annotation: - - we have T :: Bool -> Type - rather than T :: Id Bool -> Type - -This (Id Bool) will not show up anywhere after we're done validating it, so we -have no use for the produced coercion. --} - -{- Note [No polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should this kind-check? - data T ka (a::ka) b = MkT (T Type Int Bool) - (T (Type -> Type) Maybe Bool) - -Notice that T is used at two different kinds in its RHS. No! -This should not kind-check. Polymorphic recursion is known to -be a tough nut. - -Previously, we laboriously (with help from the renamer) -tried to give T the polymorphic kind - T :: forall ka -> ka -> kappa -> Type -where kappa is a unification variable, even in the inferInitialKinds -phase (which is what kcInferDeclHeader is all about). But -that is dangerously fragile (see the ticket). - -Solution: make kcInferDeclHeader give T a straightforward -monomorphic kind, with no quantification whatsoever. That's why -we use mkAnonTyConBinder for all arguments when figuring out -tc_binders. - -But notice that (#16322 comment:3) - -* The algorithm successfully kind-checks this declaration: - data T2 ka (a::ka) = MkT2 (T2 Type a) - - Starting with (inferInitialKinds) - T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> * - we get - kappa4 := kappa1 -- from the (a:ka) kind signature - kappa1 := Type -- From application T2 Type - - These constraints are soluble so generaliseTcTyCon gives - T2 :: forall (k::Type) -> k -> * - - But now the /typechecking/ (aka desugaring, tcTyClDecl) phase - fails, because the call (T2 Type a) in the RHS is ill-kinded. - - We'd really prefer all errors to show up in the kind checking - phase. - -* This algorithm still accepts (in all phases) - data T3 ka (a::ka) = forall b. MkT3 (T3 Type b) - although T3 is really polymorphic-recursive too. - Perhaps we should somehow reject that. - -Note [Kind-checking tyvar binders for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When kind-checking the type-variable binders for associated - data/newtype decls - family decls -we behave specially for type variables that are already in scope; -that is, bound by the enclosing class decl. This is done in -kcLHsQTyVarBndrs: - * The use of tcImplicitQTKBndrs - * The tcLookupLocal_maybe code in kc_hs_tv - -See Note [Associated type tyvar names] in GHC.Core.Class and - Note [TyVar binders for associated decls] in GHC.Hs.Decls - -We must do the same for family instance decls, where the in-scope -variables may be bound by the enclosing class instance decl. -Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen. - -Note [Kind variable ordering for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should be the kind of `T` in the following example? (#15591) - - class C (a :: Type) where - type T (x :: f a) - -As per Note [Ordering of implicit variables] in GHC.Rename.Types, we want to quantify -the kind variables in left-to-right order of first occurrence in order to -support visible kind application. But we cannot perform this analysis on just -T alone, since its variable `a` actually occurs /before/ `f` if you consider -the fact that `a` was previously bound by the parent class `C`. That is to say, -the kind of `T` should end up being: - - T :: forall a f. f a -> Type - -(It wouldn't necessarily be /wrong/ if the kind ended up being, say, -forall f a. f a -> Type, but that would not be as predictable for users of -visible kind application.) - -In contrast, if `T` were redefined to be a top-level type family, like `T2` -below: - - type family T2 (x :: f (a :: Type)) - -Then `a` first appears /after/ `f`, so the kind of `T2` should be: - - T2 :: forall f a. f a -> Type - -In order to make this distinction, we need to know (in kcCheckDeclHeader) which -type variables have been bound by the parent class (if there is one). With -the class-bound variables in hand, we can ensure that we always quantify -these first. --} - - -{- ********************************************************************* -* * - Expected kinds -* * -********************************************************************* -} - --- | Describes the kind expected in a certain context. -data ContextKind = TheKind Kind -- ^ a specific kind - | AnyKind -- ^ any kind will do - | OpenKind -- ^ something of the form @TYPE _@ - ------------------------ -newExpectedKind :: ContextKind -> TcM Kind -newExpectedKind (TheKind k) = return k -newExpectedKind AnyKind = newMetaKindVar -newExpectedKind OpenKind = newOpenTypeKind - ------------------------ -expectedKindInCtxt :: UserTypeCtxt -> ContextKind --- Depending on the context, we might accept any kind (for instance, in a TH --- splice), or only certain kinds (like in type signatures). -expectedKindInCtxt (TySynCtxt _) = AnyKind -expectedKindInCtxt ThBrackCtxt = AnyKind -expectedKindInCtxt (GhciCtxt {}) = AnyKind --- The types in a 'default' decl can have varying kinds --- See Note [Extended defaults]" in TcEnv -expectedKindInCtxt DefaultDeclCtxt = AnyKind -expectedKindInCtxt TypeAppCtxt = AnyKind -expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind -expectedKindInCtxt (InstDeclCtxt {}) = TheKind constraintKind -expectedKindInCtxt SpecInstCtxt = TheKind constraintKind -expectedKindInCtxt _ = OpenKind - - -{- ********************************************************************* -* * - Bringing type variables into scope -* * -********************************************************************* -} - -{- Note [Non-cloning for tyvar binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -bindExplictTKBndrs_Q_Skol, bindExplictTKBndrs_Skol, do not clone; -and nor do the Implicit versions. There is no need. - -bindExplictTKBndrs_Q_Tv does not clone; and similarly Implicit. -We take advantage of this in kcInferDeclHeader: - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) -If we cloned, we'd need to take a bit more care here; not hard. - -The main payoff is that avoidng gratuitious cloning means that we can -almost always take the fast path in swizzleTcTyConBndrs. "Almost -always" means not the case of mutual recursion with polymorphic kinds. - - -Note [Cloning for tyvar binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -bindExplicitTKBndrs_Tv does cloning, making up a Name with a fresh Unique, -unlike bindExplicitTKBndrs_Q_Tv. (Nor do the Skol variants clone.) -And similarly for bindImplicit... - -This for a narrow and tricky reason which, alas, I couldn't find a -simpler way round. #16221 is the poster child: - - data SameKind :: k -> k -> * - data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int - -When kind-checking T, we give (a :: kappa1). Then: - -- In kcConDecl we make a TyVarTv unification variable kappa2 for k2 - (as described in Note [Kind-checking for GADTs], even though this - example is an existential) -- So we get (b :: kappa2) via bindExplicitTKBndrs_Tv -- We end up unifying kappa1 := kappa2, because of the (SameKind a b) - -Now we generalise over kappa2. But if kappa2's Name is precisely k2 -(i.e. we did not clone) we'll end up giving T the utterlly final kind - T :: forall k2. k2 -> * -Nothing directly wrong with that but when we typecheck the data constructor -we have k2 in scope; but then it's brought into scope /again/ when we find -the forall k2. This is chaotic, and we end up giving it the type - MkT :: forall k2 (a :: k2) k2 (b :: k2). - SameKind @k2 a b -> Int -> T @{k2} a -which is bogus -- because of the shadowing of k2, we can't -apply T to the kind or a! - -And there no reason /not/ to clone the Name when making a unification -variable. So that's what we do. --} - --------------------------------------- --- Implicit binders --------------------------------------- - -bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv, - bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv - :: [Name] -> TcM a -> TcM ([TcTyVar], a) -bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar) -bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar) -bindImplicitTKBndrs_Skol = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar -bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX cloneFlexiKindedTyVarTyVar - -- newFlexiKinded... see Note [Non-cloning for tyvar binders] - -- cloneFlexiKindedTyVarTyVar: see Note [Cloning for tyvar binders] - -bindImplicitTKBndrsX - :: (Name -> TcM TcTyVar) -- new_tv function - -> [Name] - -> TcM a - -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence - -- with the passed in [Name] -bindImplicitTKBndrsX new_tv tv_names thing_inside - = do { tkvs <- mapM new_tv tv_names - ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs) - ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs) - thing_inside - ; return (tkvs, res) } - -newImplicitTyVarQ :: (Name -> TcM TcTyVar) -> Name -> TcM TcTyVar --- Behave like new_tv, except that if the tyvar is in scope, use it -newImplicitTyVarQ new_tv name - = do { mb_tv <- tcLookupLcl_maybe name - ; case mb_tv of - Just (ATyVar _ tv) -> return tv - _ -> new_tv name } - -newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar -newFlexiKindedTyVar new_tv name - = do { kind <- newMetaKindVar - ; new_tv name kind } - -newFlexiKindedSkolemTyVar :: Name -> TcM TyVar -newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar - -newFlexiKindedTyVarTyVar :: Name -> TcM TyVar -newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar - -cloneFlexiKindedTyVarTyVar :: Name -> TcM TyVar -cloneFlexiKindedTyVarTyVar = newFlexiKindedTyVar cloneTyVarTyVar - -- See Note [Cloning for tyvar binders] - --------------------------------------- --- Explicit binders --------------------------------------- - -bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv - :: [LHsTyVarBndr GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) - -bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar) -bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr cloneTyVarTyVar) - -- newSkolemTyVar: see Note [Non-cloning for tyvar binders] - -- cloneTyVarTyVar: see Note [Cloning for tyvar binders] - -bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv - :: ContextKind - -> [LHsTyVarBndr GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) - -bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar) -bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar) - -- See Note [Non-cloning for tyvar binders] - - -bindExplicitTKBndrsX - :: (HsTyVarBndr GhcRn -> TcM TcTyVar) - -> [LHsTyVarBndr GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence - -- with the passed-in [LHsTyVarBndr] -bindExplicitTKBndrsX tc_tv hs_tvs thing_inside - = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs) - ; go hs_tvs } - where - go [] = do { res <- thing_inside - ; return ([], res) } - go (L _ hs_tv : hs_tvs) - = do { tv <- tc_tv hs_tv - -- Extend the environment as we go, in case a binder - -- is mentioned in the kind of a later binder - -- e.g. forall k (a::k). blah - -- NB: tv's Name may differ from hs_tv's - -- See TcMType Note [Cloning for tyvar binders] - ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $ - go hs_tvs - ; return (tv:tvs, res) } - ------------------ -tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) - -> HsTyVarBndr GhcRn -> TcM TcTyVar -tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm)) - = do { kind <- newMetaKindVar - ; new_tv tv_nm kind } -tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) - = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind - ; new_tv tv_nm kind } -tcHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec - ------------------ -tcHsQTyVarBndr :: ContextKind - -> (Name -> Kind -> TcM TyVar) - -> HsTyVarBndr GhcRn -> TcM TcTyVar --- Just like tcHsTyVarBndr, but also --- - uses the in-scope TyVar from class, if it exists --- - takes a ContextKind to use for the no-sig case -tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ (L _ tv_nm)) - = do { mb_tv <- tcLookupLcl_maybe tv_nm - ; case mb_tv of - Just (ATyVar _ tv) -> return tv - _ -> do { kind <- newExpectedKind ctxt_kind - ; new_tv tv_nm kind } } - -tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) - = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind - ; mb_tv <- tcLookupLcl_maybe tv_nm - ; case mb_tv of - Just (ATyVar _ tv) - -> do { discardResult $ unifyKind (Just hs_tv) - kind (tyVarKind tv) - -- This unify rejects: - -- class C (m :: * -> *) where - -- type F (m :: *) = ... - ; return tv } - - _ -> new_tv tv_nm kind } - where - hs_tv = HsTyVar noExtField NotPromoted (noLoc tv_nm) - -- Used for error messages only - -tcHsQTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec - --------------------------------------- --- Binding type/class variables in the --- kind-checking and typechecking phases --------------------------------------- - -bindTyClTyVars :: Name - -> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a --- ^ Used for the type variables of a type or class decl --- in the "kind checking" and "type checking" pass, --- but not in the initial-kind run. -bindTyClTyVars tycon_name thing_inside - = do { tycon <- tcLookupTcTyCon tycon_name - ; let scoped_prs = tcTyConScopedTyVars tycon - res_kind = tyConResKind tycon - binders = tyConBinders tycon - ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs) - ; tcExtendNameTyVarEnv scoped_prs $ - thing_inside tycon binders res_kind } - - -{- ********************************************************************* -* * - Kind generalisation -* * -********************************************************************* -} - -zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] -zonkAndScopedSort spec_tkvs - = do { spec_tkvs <- mapM zonkAndSkolemise spec_tkvs - -- Use zonkAndSkolemise because a skol_tv might be a TyVarTv - - -- Do a stable topological sort, following - -- Note [Ordering of implicit variables] in GHC.Rename.Types - ; return (scopedSort spec_tkvs) } - --- | Generalize some of the free variables in the given type. --- All such variables should be *kind* variables; any type variables --- should be explicitly quantified (with a `forall`) before now. --- The supplied predicate says which free variables to quantify. --- But in all cases, --- generalize only those variables whose TcLevel is strictly greater --- than the ambient level. This "strictly greater than" means that --- you likely need to push the level before creating whatever type --- gets passed here. Any variable whose level is greater than the --- ambient level but is not selected to be generalized will be --- promoted. (See [Promoting unification variables] in TcSimplify --- and Note [Recipe for checking a signature].) --- The resulting KindVar are the variables to --- quantify over, in the correct, well-scoped order. They should --- generally be Inferred, not Specified, but that's really up to --- the caller of this function. -kindGeneralizeSome :: (TcTyVar -> Bool) - -> TcType -- ^ needn't be zonked - -> TcM [KindVar] -kindGeneralizeSome should_gen kind_or_type - = do { traceTc "kindGeneralizeSome {" (ppr kind_or_type) - - -- use the "Kind" variant here, as any types we see - -- here will already have all type variables quantified; - -- thus, every free variable is really a kv, never a tv. - ; dvs <- candidateQTyVarsOfKind kind_or_type - - -- So 'dvs' are the variables free in kind_or_type, with a level greater - -- than the ambient level, hence candidates for quantification - -- Next: filter out the ones we don't want to generalize (specified by should_gen) - -- and promote them instead - - ; let (to_promote, dvs') = partitionCandidates dvs (not . should_gen) - - ; (_, promoted) <- promoteTyVarSet (dVarSetToVarSet to_promote) - ; qkvs <- quantifyTyVars dvs' - - ; traceTc "kindGeneralizeSome }" $ - vcat [ text "Kind or type:" <+> ppr kind_or_type - , text "dvs:" <+> ppr dvs - , text "dvs':" <+> ppr dvs' - , text "to_promote:" <+> pprTyVars (dVarSetElems to_promote) - , text "promoted:" <+> pprTyVars (nonDetEltsUniqSet promoted) - , text "qkvs:" <+> pprTyVars qkvs ] - - ; return qkvs } - --- | Specialized version of 'kindGeneralizeSome', but where all variables --- can be generalized. Use this variant when you can be sure that no more --- constraints on the type's metavariables will arise or be solved. -kindGeneralizeAll :: TcType -- needn't be zonked - -> TcM [KindVar] -kindGeneralizeAll ty = do { traceTc "kindGeneralizeAll" empty - ; kindGeneralizeSome (const True) ty } - --- | Specialized version of 'kindGeneralizeSome', but where no variables --- can be generalized. Use this variant when it is unknowable whether metavariables --- might later be constrained. --- See Note [Recipe for checking a signature] for why and where this --- function is needed. -kindGeneralizeNone :: TcType -- needn't be zonked - -> TcM () -kindGeneralizeNone ty - = do { traceTc "kindGeneralizeNone" empty - ; kvs <- kindGeneralizeSome (const False) ty - ; MASSERT( null kvs ) - } - -{- Note [Levels and generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = e -with no type signature. We are currently at level i. -We must - * Push the level to level (i+1) - * Allocate a fresh alpha[i+1] for the result type - * Check that e :: alpha[i+1], gathering constraint WC - * Solve WC as far as possible - * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i] - * Find the free variables with level > i, in this case gamma[i] - * Skolemise those free variables and quantify over them, giving - f :: forall g. beta[i-1] -> g - * Emit the residiual constraint wrapped in an implication for g, - thus forall g. WC - -All of this happens for types too. Consider - f :: Int -> (forall a. Proxy a -> Int) - -Note [Kind generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do kind generalisation only at the outer level of a type signature. -For example, consider - T :: forall k. k -> * - f :: (forall a. T a -> Int) -> Int -When kind-checking f's type signature we generalise the kind at -the outermost level, thus: - f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! -and *not* at the inner forall: - f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! -Reason: same as for HM inference on value level declarations, -we want to infer the most general type. The f2 type signature -would be *less applicable* than f1, because it requires a more -polymorphic argument. - -NB: There are no explicit kind variables written in f's signature. -When there are, the renamer adds these kind variables to the list of -variables bound by the forall, so you can indeed have a type that's -higher-rank in its kind. But only by explicit request. - -Note [Kinds of quantified type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyVarBndrsGen quantifies over a specified list of type variables, -*and* over the kind variables mentioned in the kinds of those tyvars. - -Note that we must zonk those kinds (obviously) but less obviously, we -must return type variables whose kinds are zonked too. Example - (a :: k7) where k7 := k9 -> k9 -We must return - [k9, a:k9->k9] -and NOT - [k9, a:k7] -Reason: we're going to turn this into a for-all type, - forall k9. forall (a:k7). blah -which the type checker will then instantiate, and instantiate does not -look through unification variables! - -Hence using zonked_kinds when forming tvs'. - --} - ------------------------------------ -etaExpandAlgTyCon :: [TyConBinder] - -> Kind -- must be zonked - -> TcM ([TyConBinder], Kind) --- GADT decls can have a (perhaps partial) kind signature --- e.g. data T a :: * -> * -> * where ... --- This function makes up suitable (kinded) TyConBinders for the --- argument kinds. E.g. in this case it might return --- ([b::*, c::*], *) --- Never emits constraints. --- It's a little trickier than you might think: see --- Note [TyConBinders for the result kind signature of a data type] --- See Note [Datatype return kinds] in TcTyClsDecls -etaExpandAlgTyCon tc_bndrs kind - = do { loc <- getSrcSpanM - ; uniqs <- newUniqueSupply - ; rdr_env <- getLocalRdrEnv - ; let new_occs = [ occ - | str <- allNameStrings - , let occ = mkOccName tvName str - , isNothing (lookupLocalRdrOcc rdr_env occ) - -- Note [Avoid name clashes for associated data types] - , not (occ `elem` lhs_occs) ] - new_uniqs = uniqsFromSupply uniqs - subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs)) - ; return (go loc new_occs new_uniqs subst [] kind) } - where - lhs_tvs = map binderVar tc_bndrs - lhs_occs = map getOccName lhs_tvs - - go loc occs uniqs subst acc kind - = case splitPiTy_maybe kind of - Nothing -> (reverse acc, substTy subst kind) - - Just (Anon af arg, kind') - -> go loc occs' uniqs' subst' (tcb : acc) kind' - where - arg' = substTy subst arg - tv = mkTyVar (mkInternalName uniq occ loc) arg' - subst' = extendTCvInScope subst tv - tcb = Bndr tv (AnonTCB af) - (uniq:uniqs') = uniqs - (occ:occs') = occs - - Just (Named (Bndr tv vis), kind') - -> go loc occs uniqs subst' (tcb : acc) kind' - where - (subst', tv') = substTyVarBndr subst tv - tcb = Bndr tv' (NamedTCB vis) - --- | A description of whether something is a --- --- * @data@ or @newtype@ ('DataDeclSort') --- --- * @data instance@ or @newtype instance@ ('DataInstanceSort') --- --- * @data family@ ('DataFamilySort') --- --- At present, this data type is only consumed by 'checkDataKindSig'. -data DataSort - = DataDeclSort NewOrData - | DataInstanceSort NewOrData - | DataFamilySort - --- | Checks that the return kind in a data declaration's kind signature is --- permissible. There are three cases: --- --- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@ --- declaration, check that the return kind is @Type@. --- --- If the declaration is a @newtype@ or @newtype instance@ and the --- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so --- that a return kind of the form @TYPE r@ (for some @r@) is permitted. --- See @Note [Implementation of UnliftedNewtypes]@ in "TcTyClsDecls". --- --- If dealing with a @data family@ declaration, check that the return kind is --- either of the form: --- --- 1. @TYPE r@ (for some @r@), or --- --- 2. @k@ (where @k@ is a bare kind variable; see #12369) --- --- See also Note [Datatype return kinds] in TcTyClsDecls -checkDataKindSig :: DataSort -> Kind -> TcM () -checkDataKindSig data_sort kind = do - dflags <- getDynFlags - checkTc (is_TYPE_or_Type dflags || is_kind_var) (err_msg dflags) - where - pp_dec :: SDoc - pp_dec = text $ - case data_sort of - DataDeclSort DataType -> "Data type" - DataDeclSort NewType -> "Newtype" - DataInstanceSort DataType -> "Data instance" - DataInstanceSort NewType -> "Newtype instance" - DataFamilySort -> "Data family" - - is_newtype :: Bool - is_newtype = - case data_sort of - DataDeclSort new_or_data -> new_or_data == NewType - DataInstanceSort new_or_data -> new_or_data == NewType - DataFamilySort -> False - - is_data_family :: Bool - is_data_family = - case data_sort of - DataDeclSort{} -> False - DataInstanceSort{} -> False - DataFamilySort -> True - - tYPE_ok :: DynFlags -> Bool - tYPE_ok dflags = - (is_newtype && xopt LangExt.UnliftedNewtypes dflags) - -- With UnliftedNewtypes, we allow kinds other than Type, but they - -- must still be of the form `TYPE r` since we don't want to accept - -- Constraint or Nat. - -- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls. - || is_data_family - -- If this is a `data family` declaration, we don't need to check if - -- UnliftedNewtypes is enabled, since data family declarations can - -- have return kind `TYPE r` unconditionally (#16827). - - is_TYPE :: Bool - is_TYPE = tcIsRuntimeTypeKind kind - - is_TYPE_or_Type :: DynFlags -> Bool - is_TYPE_or_Type dflags | tYPE_ok dflags = is_TYPE - | otherwise = tcIsLiftedTypeKind kind - - -- In the particular case of a data family, permit a return kind of the - -- form `:: k` (where `k` is a bare kind variable). - is_kind_var :: Bool - is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe kind) - | otherwise = False - - err_msg :: DynFlags -> SDoc - err_msg dflags = - sep [ (sep [ pp_dec <+> - text "has non-" <> - (if tYPE_ok dflags then text "TYPE" else ppr liftedTypeKind) - , (if is_data_family then text "and non-variable" else empty) <+> - text "return kind" <+> quotes (ppr kind) ]) - , if not (tYPE_ok dflags) && is_TYPE && is_newtype && - not (xopt LangExt.UnliftedNewtypes dflags) - then text "Perhaps you intended to use UnliftedNewtypes" - else empty ] - --- | Checks that the result kind of a class is exactly `Constraint`, rejecting --- type synonyms and type families that reduce to `Constraint`. See #16826. -checkClassKindSig :: Kind -> TcM () -checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg - where - err_msg :: SDoc - err_msg = - text "Kind signature on a class must end with" <+> ppr constraintKind $$ - text "unobscured by type families" - -tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] --- Result is in 1-1 correspondence with orig_args -tcbVisibilities tc orig_args - = go (tyConKind tc) init_subst orig_args - where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) - go _ _ [] - = [] - - go fun_kind subst all_args@(arg : args) - | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind - = case tcb of - Anon af _ -> AnonTCB af : go inner_kind subst args - Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args - where - subst' = extendTCvSubst subst tv arg - - | not (isEmptyTCvSubst subst) - = go (substTy subst fun_kind) init_subst all_args - - | otherwise - = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args) - - -{- Note [TyConBinders for the result kind signature of a data type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given - data T (a::*) :: * -> forall k. k -> * -we want to generate the extra TyConBinders for T, so we finally get - (a::*) (b::*) (k::*) (c::k) -The function etaExpandAlgTyCon generates these extra TyConBinders from -the result kind signature. - -We need to take care to give the TyConBinders - (a) OccNames that are fresh (because the TyConBinders of a TyCon - must have distinct OccNames - - (b) Uniques that are fresh (obviously) - -For (a) we need to avoid clashes with the tyvars declared by -the user before the "::"; in the above example that is 'a'. -And also see Note [Avoid name clashes for associated data types]. - -For (b) suppose we have - data T :: forall k. k -> forall k. k -> * -where the two k's are identical even up to their uniques. Surprisingly, -this can happen: see #14515. - -It's reasonably easy to solve all this; just run down the list with a -substitution; hence the recursive 'go' function. But it has to be -done. - -Note [Avoid name clashes for associated data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider class C a b where - data D b :: * -> * -When typechecking the decl for D, we'll invent an extra type variable -for D, to fill out its kind. Ideally we don't want this type variable -to be 'a', because when pretty printing we'll get - class C a b where - data D b a0 -(NB: the tidying happens in the conversion to Iface syntax, which happens -as part of pretty-printing a TyThing.) - -That's why we look in the LocalRdrEnv to see what's in scope. This is -important only to get nice-looking output when doing ":info C" in GHCi. -It isn't essential for correctness. - - -************************************************************************ -* * - Partial signatures -* * -************************************************************************ - --} - -tcHsPartialSigType - :: UserTypeCtxt - -> LHsSigWcType GhcRn -- The type signature - -> TcM ( [(Name, TcTyVar)] -- Wildcards - , Maybe TcType -- Extra-constraints wildcard - , [(Name,TcTyVar)] -- Original tyvar names, in correspondence with - -- the implicitly and explicitly bound type variables - , TcThetaType -- Theta part - , TcType ) -- Tau part --- See Note [Checking partial type signatures] -tcHsPartialSigType ctxt sig_ty - | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty - , HsIB { hsib_ext = implicit_hs_tvs - , hsib_body = hs_ty } <- ib_ty - , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty - = addSigCtxt ctxt hs_ty $ - do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau))) - <- solveLocalEqualities "tcHsPartialSigType" $ - -- This solveLocalEqualiltes fails fast if there are - -- insoluble equalities. See TcSimplify - -- Note [Fail fast if there are insoluble kind equalities] - tcNamedWildCardBinders sig_wcs $ \ wcs -> - bindImplicitTKBndrs_Tv implicit_hs_tvs $ - bindExplicitTKBndrs_Tv explicit_hs_tvs $ - do { -- Instantiate the type-class context; but if there - -- is an extra-constraints wildcard, just discard it here - (theta, wcx) <- tcPartialContext hs_ctxt - - ; tau <- tcHsOpenType hs_tau - - ; return (wcs, wcx, theta, tau) } - - -- No kind-generalization here: - ; kindGeneralizeNone (mkSpecForAllTys implicit_tvs $ - mkSpecForAllTys explicit_tvs $ - mkPhiTy theta $ - tau) - - -- Spit out the wildcards (including the extra-constraints one) - -- as "hole" constraints, so that they'll be reported if necessary - -- See Note [Extra-constraint holes in partial type signatures] - ; emitNamedWildCardHoleConstraints wcs - - -- We return a proper (Name,TyVar) environment, to be sure that - -- we bring the right name into scope in the function body. - -- Test case: partial-sigs/should_compile/LocalDefinitionBug - ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvs) - ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvs) - - -- NB: checkValidType on the final inferred type will be - -- done later by checkInferredPolyId. We can't do it - -- here because we don't have a complete tuype to check - - ; traceTc "tcHsPartialSigType" (ppr tv_prs) - ; return (wcs, wcx, tv_prs, theta, tau) } - -tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec -tcHsPartialSigType _ (XHsWildCardBndrs nec) = noExtCon nec - -tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType) -tcPartialContext hs_theta - | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta - , L wc_loc wc@(HsWildCardTy _) <- ignoreParens hs_ctxt_last - = do { wc_tv_ty <- setSrcSpan wc_loc $ - tcAnonWildCardOcc wc constraintKind - ; theta <- mapM tcLHsPredType hs_theta1 - ; return (theta, Just wc_tv_ty) } - | otherwise - = do { theta <- mapM tcLHsPredType hs_theta - ; return (theta, Nothing) } - -{- Note [Checking partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Recipe for checking a signature] - -When we have a partial signature like - f,g :: forall a. a -> _ -we do the following - -* In TcSigs.tcUserSigType we return a PartialSig, which (unlike - the companion CompleteSig) contains the original, as-yet-unchecked - source-code LHsSigWcType - -* Then, for f and g /separately/, we call tcInstSig, which in turn - call tchsPartialSig (defined near this Note). It kind-checks the - LHsSigWcType, creating fresh unification variables for each "_" - wildcard. It's important that the wildcards for f and g are distinct - because they might get instantiated completely differently. E.g. - f,g :: forall a. a -> _ - f x = a - g x = True - It's really as if we'd written two distinct signatures. - -* Note that we don't make quantified type (forall a. blah) and then - instantiate it -- it makes no sense to instantiate a type with - wildcards in it. Rather, tcHsPartialSigType just returns the - 'a' and the 'blah' separately. - - Nor, for the same reason, do we push a level in tcHsPartialSigType. - -Note [Extra-constraint holes in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: (_) => a -> a - f x = ... - -* The renamer leaves '_' untouched. - -* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in - tcWildCardBinders. - -* TcBinds.chooseInferredQuantifiers fills in that hole TcTyVar - with the inferred constraints, e.g. (Eq a, Show a) - -* TcErrors.mkHoleError finally reports the error. - -An annoying difficulty happens if there are more than 62 inferred -constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple. -Where do we find the TyCon? For good reasons we only have constraint -tuples up to 62 (see Note [How tuples work] in TysWiredIn). So how -can we make a 70-tuple? This was the root cause of #14217. - -It's incredibly tiresome, because we only need this type to fill -in the hole, to communicate to the error reporting machinery. Nothing -more. So I use a HACK: - -* I make an /ordinary/ tuple of the constraints, in - TcBinds.chooseInferredQuantifiers. This is ill-kinded because - ordinary tuples can't contain constraints, but it works fine. And for - ordinary tuples we don't have the same limit as for constraint - tuples (which need selectors and an associated class). - -* Because it is ill-kinded, it trips an assert in writeMetaTyVar, - so now I disable the assertion if we are writing a type of - kind Constraint. (That seldom/never normally happens so we aren't - losing much.) - -Result works fine, but it may eventually bite us. - - -************************************************************************ -* * - Pattern signatures (i.e signatures that occur in patterns) -* * -********************************************************************* -} - -tcHsPatSigType :: UserTypeCtxt - -> LHsSigWcType GhcRn -- The type signature - -> TcM ( [(Name, TcTyVar)] -- Wildcards - , [(Name, TcTyVar)] -- The new bit of type environment, binding - -- the scoped type variables - , TcType) -- The type --- Used for type-checking type signatures in --- (a) patterns e.g f (x::Int) = e --- (b) RULE forall bndrs e.g. forall (x::Int). f x = x --- --- This may emit constraints --- See Note [Recipe for checking a signature] -tcHsPatSigType ctxt sig_ty - | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty - , HsIB { hsib_ext = sig_ns - , hsib_body = hs_ty } <- ib_ty - = addSigCtxt ctxt hs_ty $ - do { sig_tkv_prs <- mapM new_implicit_tv sig_ns - ; (wcs, sig_ty) - <- solveLocalEqualities "tcHsPatSigType" $ - -- Always solve local equalities if possible, - -- else casts get in the way of deep skolemisation - -- (#16033) - tcNamedWildCardBinders sig_wcs $ \ wcs -> - tcExtendNameTyVarEnv sig_tkv_prs $ - do { sig_ty <- tcHsOpenType hs_ty - ; return (wcs, sig_ty) } - - ; emitNamedWildCardHoleConstraints wcs - - -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty - -- contains a forall). Promote these. - -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ... - -- When we instantiate x, we have to compare the kind of the argument - -- to a's kind, which will be a metavariable. - -- kindGeneralizeNone does this: - ; kindGeneralizeNone sig_ty - ; sig_ty <- zonkTcType sig_ty - ; checkValidType ctxt sig_ty - - ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs) - ; return (wcs, sig_tkv_prs, sig_ty) } - where - new_implicit_tv name - = do { kind <- newMetaKindVar - ; tv <- case ctxt of - RuleSigCtxt {} -> newSkolemTyVar name kind - _ -> newPatSigTyVar name kind - -- See Note [Pattern signature binders] - -- NB: tv's Name may be fresh (in the case of newPatSigTyVar) - ; return (name, tv) } - -tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec -tcHsPatSigType _ (XHsWildCardBndrs nec) = noExtCon nec - -tcPatSig :: Bool -- True <=> pattern binding - -> LHsSigWcType GhcRn - -> ExpSigmaType - -> TcM (TcType, -- The type to use for "inside" the signature - [(Name,TcTyVar)], -- The new bit of type environment, binding - -- the scoped type variables - [(Name,TcTyVar)], -- The wildcards - HsWrapper) -- Coercion due to unification with actual ty - -- Of shape: res_ty ~ sig_ty -tcPatSig in_pat_bind sig res_ty - = do { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig - -- sig_tvs are the type variables free in 'sig', - -- and not already in scope. These are the ones - -- that should be brought into scope - - ; if null sig_tvs then do { - -- Just do the subsumption check and return - wrap <- addErrCtxtM (mk_msg sig_ty) $ - tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty - ; return (sig_ty, [], sig_wcs, wrap) - } else do - -- Type signature binds at least one scoped type variable - - -- A pattern binding cannot bind scoped type variables - -- It is more convenient to make the test here - -- than in the renamer - { when in_pat_bind (addErr (patBindSigErr sig_tvs)) - - -- Now do a subsumption check of the pattern signature against res_ty - ; wrap <- addErrCtxtM (mk_msg sig_ty) $ - tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty - - -- Phew! - ; return (sig_ty, sig_tvs, sig_wcs, wrap) - } } - where - mk_msg sig_ty tidy_env - = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty - ; res_ty <- readExpType res_ty -- should be filled in by now - ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty - ; let msg = vcat [ hang (text "When checking that the pattern signature:") - 4 (ppr sig_ty) - , nest 2 (hang (text "fits the type of its context:") - 2 (ppr res_ty)) ] - ; return (tidy_env, msg) } - -patBindSigErr :: [(Name,TcTyVar)] -> SDoc -patBindSigErr sig_tvs - = hang (text "You cannot bind scoped type variable" <> plural sig_tvs - <+> pprQuotedList (map fst sig_tvs)) - 2 (text "in a pattern binding signature") - -{- Note [Pattern signature binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Type variables in the type environment] in TcRnTypes. -Consider - - data T where - MkT :: forall a. a -> (a -> Int) -> T - - f :: T -> ... - f (MkT x (f :: b -> c)) = <blah> - -Here - * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk', - It must be a skolem so that that it retains its identity, and - TcErrors.getSkolemInfo can thereby find the binding site for the skolem. - - * The type signature pattern (f :: b -> c) makes freshs meta-tyvars - beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the - environment - - * Then unification makes beta := a_sk, gamma := Int - That's why we must make beta and gamma a MetaTv, - not a SkolemTv, so that it can unify to a_sk (or Int, respectively). - - * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma, - so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType, - -Another example (#13881): - fl :: forall (l :: [a]). Sing l -> Sing l - fl (SNil :: Sing (l :: [y])) = SNil -When we reach the pattern signature, 'l' is in scope from the -outer 'forall': - "a" :-> a_sk :: * - "l" :-> l_sk :: [a_sk] -We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check -the pattern signature - Sing (l :: [y]) -That unifies y_sig := a_sk. We return from tcHsPatSigType with -the pair ("y" :-> y_sig). - -For RULE binders, though, things are a bit different (yuk). - RULE "foo" forall (x::a) (y::[a]). f x y = ... -Here this really is the binding site of the type variable so we'd like -to use a skolem, so that we get a complaint if we unify two of them -together. Hence the new_tv function in tcHsPatSigType. - - -************************************************************************ -* * - Checking kinds -* * -************************************************************************ - --} - -unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind) -unifyKinds rn_tys act_kinds - = do { kind <- newMetaKindVar - ; let check rn_ty (ty, act_kind) - = checkExpectedKind (unLoc rn_ty) ty act_kind kind - ; tys' <- zipWithM check rn_tys act_kinds - ; return (tys', kind) } - -{- -************************************************************************ -* * - Sort checking kinds -* * -************************************************************************ - -tcLHsKindSig converts a user-written kind to an internal, sort-checked kind. -It does sort checking and desugaring at the same time, in one single pass. --} - -tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind -tcLHsKindSig ctxt hs_kind --- See Note [Recipe for checking a signature] in TcHsType --- Result is zonked - = do { kind <- solveLocalEqualities "tcLHsKindSig" $ - tc_lhs_kind kindLevelMode hs_kind - ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) - -- No generalization: - ; kindGeneralizeNone kind - ; kind <- zonkTcType kind - -- This zonk is very important in the case of higher rank kinds - -- E.g. #13879 f :: forall (p :: forall z (y::z). <blah>). - -- <more blah> - -- When instantiating p's kind at occurrences of p in <more blah> - -- it's crucial that the kind we instantiate is fully zonked, - -- else we may fail to substitute properly - - ; checkValidType ctxt kind - ; traceTc "tcLHsKindSig2" (ppr kind) - ; return kind } - -tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind -tc_lhs_kind mode k - = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $ - tc_lhs_type (kindLevel mode) k liftedTypeKind - -promotionErr :: Name -> PromotionErr -> TcM a -promotionErr name err - = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") - 2 (parens reason)) - where - reason = case err of - ConstrainedDataConPE pred - -> text "it has an unpromotable context" - <+> quotes (ppr pred) - FamDataConPE -> text "it comes from a data family instance" - NoDataKindsTC -> text "perhaps you intended to use DataKinds" - NoDataKindsDC -> text "perhaps you intended to use DataKinds" - PatSynPE -> text "pattern synonyms cannot be promoted" - _ -> text "it is defined and used in the same recursive group" - -{- -************************************************************************ -* * - Error messages and such -* * -************************************************************************ --} - - --- | If the inner action emits constraints, report them as errors and fail; --- otherwise, propagates the return value. Useful as a wrapper around --- 'tcImplicitTKBndrs', which uses solveLocalEqualities, when there won't be --- another chance to solve constraints -failIfEmitsConstraints :: TcM a -> TcM a -failIfEmitsConstraints thing_inside - = checkNoErrs $ -- We say that we fail if there are constraints! - -- c.f same checkNoErrs in solveEqualities - do { (res, lie) <- captureConstraints thing_inside - ; reportAllUnsolved lie - ; return res - } - --- | Make an appropriate message for an error in a function argument. --- Used for both expressions and types. -funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc -funAppCtxt fun arg arg_no - = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"), - quotes (ppr fun) <> text ", namely"]) - 2 (quotes (ppr arg)) - --- | Add a "In the data declaration for T" or some such. -addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a -addTyConFlavCtxt name flav - = addErrCtxt $ hsep [ text "In the", ppr flav - , text "declaration for", quotes (ppr name) ] diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs deleted file mode 100644 index 40bc3853d5..0000000000 --- a/compiler/typecheck/TcInstDcls.hs +++ /dev/null @@ -1,2175 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcInstDecls: Typechecking instance declarations --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TcBinds -import TcTyClsDecls -import TcTyDecls ( addTyConsToGblEnv ) -import TcClassDcl( tcClassDecl2, tcATDefault, - HsSigFun, mkHsSigFun, badMethodErr, - findMethodBind, instantiateMethod ) -import TcSigs -import TcRnMonad -import TcValidity -import TcHsSyn -import TcMType -import TcType -import Constraint -import TcOrigin -import BuildTyCl -import Inst -import ClsInst( AssocInstInfo(..), isNotAssociated ) -import GHC.Core.InstEnv -import FamInst -import GHC.Core.FamInstEnv -import TcDeriv -import TcEnv -import TcHsType -import TcUnify -import GHC.Core ( Expr(..), mkApps, mkVarApps, mkLams ) -import GHC.Core.Make ( nO_METHOD_BINDING_ERROR_ID ) -import GHC.Core.Unfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding ) -import GHC.Core.Type -import TcEvidence -import GHC.Core.TyCon -import GHC.Core.Coercion.Axiom -import GHC.Core.DataCon -import GHC.Core.ConLike -import GHC.Core.Class -import GHC.Types.Var as Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import Bag -import GHC.Types.Basic -import GHC.Driver.Session -import ErrUtils -import FastString -import GHC.Types.Id -import ListSetOps -import GHC.Types.Name -import GHC.Types.Name.Set -import Outputable -import GHC.Types.SrcLoc -import Util -import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Maybes -import Data.List( mapAccumL ) - - -{- -Typechecking instance declarations is done in two passes. The first -pass, made by @tcInstDecls1@, collects information to be used in the -second pass. - -This pre-processed info includes the as-yet-unprocessed bindings -inside the instance declaration. These are type-checked in the second -pass, when the class-instance envs and GVE contain all the info from -all the instance and value decls. Indeed that's the reason we need -two passes over the instance decls. - - -Note [How instance declarations are translated] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is how we translate instance declarations into Core - -Running example: - class C a where - op1, op2 :: Ix b => a -> b -> b - op2 = <dm-rhs> - - instance C a => C [a] - {-# INLINE [2] op1 #-} - op1 = <rhs> -===> - -- Method selectors - op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b - op1 = ... - op2 = ... - - -- Default methods get the 'self' dictionary as argument - -- so they can call other methods at the same type - -- Default methods get the same type as their method selector - $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b - $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs> - -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs> - -- Note [Tricky type variable scoping] - - -- A top-level definition for each instance method - -- Here op1_i, op2_i are the "instance method Ids" - -- The INLINE pragma comes from the user pragma - {-# INLINE [2] op1_i #-} -- From the instance decl bindings - op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b - op1_i = /\a. \(d:C a). - let this :: C [a] - this = df_i a d - -- Note [Subtle interaction of recursion and overlap] - - local_op1 :: forall b. Ix b => [a] -> b -> b - local_op1 = <rhs> - -- Source code; run the type checker on this - -- NB: Type variable 'a' (but not 'b') is in scope in <rhs> - -- Note [Tricky type variable scoping] - - in local_op1 a d - - op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) - - -- The dictionary function itself - {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions - df_i :: forall a. C a -> C [a] - df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) - -- But see Note [Default methods in instances] - -- We can't apply the type checker to the default-method call - - -- Use a RULE to short-circuit applications of the class ops - {-# RULE "op1@C[a]" forall a, d:C a. - op1 [a] (df_i d) = op1_i a d #-} - -Note [Instances and loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Note that df_i may be mutually recursive with both op1_i and op2_i. - It's crucial that df_i is not chosen as the loop breaker, even - though op1_i has a (user-specified) INLINE pragma. - -* Instead the idea is to inline df_i into op1_i, which may then select - methods from the MkC record, and thereby break the recursion with - df_i, leaving a *self*-recursive op1_i. (If op1_i doesn't call op at - the same type, it won't mention df_i, so there won't be recursion in - the first place.) - -* If op1_i is marked INLINE by the user there's a danger that we won't - inline df_i in it, and that in turn means that (since it'll be a - loop-breaker because df_i isn't), op1_i will ironically never be - inlined. But this is OK: the recursion breaking happens by way of - a RULE (the magic ClassOp rule above), and RULES work inside InlineRule - unfoldings. See Note [RULEs enabled in InitialPhase] in GHC.Core.Op.Simplify.Utils - -Note [ClassOp/DFun selection] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One thing we see a lot is stuff like - op2 (df d1 d2) -where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* -'op2' and 'df' to get - case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of - MkD _ op2 _ _ _ -> op2 -And that will reduce to ($cop2 d1 d2) which is what we wanted. - -But it's tricky to make this work in practice, because it requires us to -inline both 'op2' and 'df'. But neither is keen to inline without having -seen the other's result; and it's very easy to get code bloat (from the -big intermediate) if you inline a bit too much. - -Instead we use a cunning trick. - * We arrange that 'df' and 'op2' NEVER inline. - - * We arrange that 'df' is ALWAYS defined in the sylised form - df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ... - - * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..]) - that lists its methods. - - * We make GHC.Core.Unfold.exprIsConApp_maybe spot a DFunUnfolding and return - a suitable constructor application -- inlining df "on the fly" as it - were. - - * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that - extracts the right piece iff its argument satisfies - exprIsConApp_maybe. This is done in GHC.Types.Id.Make.mkDictSelId - - * We make 'df' CONLIKE, so that shared uses still match; eg - let d = df d1 d2 - in ...(op2 d)...(op1 d)... - -Note [Single-method classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the class has just one method (or, more accurately, just one element -of {superclasses + methods}), then we use a different strategy. - - class C a where op :: a -> a - instance C a => C [a] where op = <blah> - -We translate the class decl into a newtype, which just gives a -top-level axiom. The "constructor" MkC expands to a cast, as does the -class-op selector. - - axiom Co:C a :: C a ~ (a->a) - - op :: forall a. C a -> (a -> a) - op a d = d |> (Co:C a) - - MkC :: forall a. (a->a) -> C a - MkC = /\a.\op. op |> (sym Co:C a) - -The clever RULE stuff doesn't work now, because ($df a d) isn't -a constructor application, so exprIsConApp_maybe won't return -Just <blah>. - -Instead, we simply rely on the fact that casts are cheap: - - $df :: forall a. C a => C [a] - {-# INLINE df #-} -- NB: INLINE this - $df = /\a. \d. MkC [a] ($cop_list a d) - = $cop_list |> forall a. C a -> (sym (Co:C [a])) - - $cop_list :: forall a. C a => [a] -> [a] - $cop_list = <blah> - -So if we see - (op ($df a d)) -we'll inline 'op' and '$df', since both are simply casts, and -good things happen. - -Why do we use this different strategy? Because otherwise we -end up with non-inlined dictionaries that look like - $df = $cop |> blah -which adds an extra indirection to every use, which seems stupid. See -#4138 for an example (although the regression reported there -wasn't due to the indirection). - -There is an awkward wrinkle though: we want to be very -careful when we have - instance C a => C [a] where - {-# INLINE op #-} - op = ... -then we'll get an INLINE pragma on $cop_list but it's important that -$cop_list only inlines when it's applied to *two* arguments (the -dictionary and the list argument). So we must not eta-expand $df -above. We ensure that this doesn't happen by putting an INLINE -pragma on the dfun itself; after all, it ends up being just a cast. - -There is one more dark corner to the INLINE story, even more deeply -buried. Consider this (#3772): - - class DeepSeq a => C a where - gen :: Int -> a - - instance C a => C [a] where - gen n = ... - - class DeepSeq a where - deepSeq :: a -> b -> b - - instance DeepSeq a => DeepSeq [a] where - {-# INLINE deepSeq #-} - deepSeq xs b = foldr deepSeq b xs - -That gives rise to these defns: - - $cdeepSeq :: DeepSeq a -> [a] -> b -> b - -- User INLINE( 3 args )! - $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ... - - $fDeepSeq[] :: DeepSeq a -> DeepSeq [a] - -- DFun (with auto INLINE pragma) - $fDeepSeq[] a d = $cdeepSeq a d |> blah - - $cp1 a d :: C a => DeepSep [a] - -- We don't want to eta-expand this, lest - -- $cdeepSeq gets inlined in it! - $cp1 a d = $fDeepSep[] a (scsel a d) - - $fC[] :: C a => C [a] - -- Ordinary DFun - $fC[] a d = MkC ($cp1 a d) ($cgen a d) - -Here $cp1 is the code that generates the superclass for C [a]. The -issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[] -and then $cdeepSeq will inline there, which is definitely wrong. Like -on the dfun, we solve this by adding an INLINE pragma to $cp1. - -Note [Subtle interaction of recursion and overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - class C a where { op1,op2 :: a -> a } - instance C a => C [a] where - op1 x = op2 x ++ op2 x - op2 x = ... - instance C [Int] where - ... - -When type-checking the C [a] instance, we need a C [a] dictionary (for -the call of op2). If we look up in the instance environment, we find -an overlap. And in *general* the right thing is to complain (see Note -[Overlapping instances] in GHC.Core.InstEnv). But in *this* case it's wrong to -complain, because we just want to delegate to the op2 of this same -instance. - -Why is this justified? Because we generate a (C [a]) constraint in -a context in which 'a' cannot be instantiated to anything that matches -other overlapping instances, or else we would not be executing this -version of op1 in the first place. - -It might even be a bit disguised: - - nullFail :: C [a] => [a] -> [a] - nullFail x = op2 x ++ op2 x - - instance C a => C [a] where - op1 x = nullFail x - -Precisely this is used in package 'regex-base', module Context.hs. -See the overlapping instances for RegexContext, and the fact that they -call 'nullFail' just like the example above. The DoCon package also -does the same thing; it shows up in module Fraction.hs. - -Conclusion: when typechecking the methods in a C [a] instance, we want to -treat the 'a' as an *existential* type variable, in the sense described -by Note [Binding when looking up instances]. That is why isOverlappableTyVar -responds True to an InstSkol, which is the kind of skolem we use in -tcInstDecl2. - - -Note [Tricky type variable scoping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In our example - class C a where - op1, op2 :: Ix b => a -> b -> b - op2 = <dm-rhs> - - instance C a => C [a] - {-# INLINE [2] op1 #-} - op1 = <rhs> - -note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is -in scope in <rhs>. In particular, we must make sure that 'b' is in -scope when typechecking <dm-rhs>. This is achieved by subFunTys, -which brings appropriate tyvars into scope. This happens for both -<dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have -complained if 'b' is mentioned in <rhs>. - - - -************************************************************************ -* * -\subsection{Extracting instance decls} -* * -************************************************************************ - -Gather up the instance declarations from their various sources --} - -tcInstDecls1 -- Deal with both source-code and imported instance decls - :: [LInstDecl GhcRn] -- Source code instance decls - -> TcM (TcGblEnv, -- The full inst env - [InstInfo GhcRn], -- Source-code instance decls to process; - -- contains all dfuns for this module - [DerivInfo]) -- From data family instances - -tcInstDecls1 inst_decls - = do { -- Do class and family instance declarations - ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls - - ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff - fam_insts = concat fam_insts_s - local_infos = concat local_infos_s - - ; gbl_env <- addClsInsts local_infos $ - addFamInsts fam_insts $ - getGblEnv - - ; return ( gbl_env - , local_infos - , concat datafam_deriv_infos ) } - --- | Use DerivInfo for data family instances (produced by tcInstDecls1), --- datatype declarations (TyClDecl), and standalone deriving declarations --- (DerivDecl) to check and process all derived class instances. -tcInstDeclsDeriv - :: [DerivInfo] - -> [LDerivDecl GhcRn] - -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn) -tcInstDeclsDeriv deriv_infos derivds - = do th_stage <- getStage -- See Note [Deriving inside TH brackets] - if isBrackStage th_stage - then do { gbl_env <- getGblEnv - ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) } - else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds - ; return (tcg_env, bagToList info_bag, valbinds) } - -addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a -addClsInsts infos thing_inside - = tcExtendLocalInstEnv (map iSpec infos) thing_inside - -addFamInsts :: [FamInst] -> TcM a -> TcM a --- Extend (a) the family instance envt --- (b) the type envt with stuff from data type decls -addFamInsts fam_insts thing_inside - = tcExtendLocalFamInstEnv fam_insts $ - tcExtendGlobalEnv axioms $ - do { traceTc "addFamInsts" (pprFamInsts fam_insts) - ; gbl_env <- addTyConsToGblEnv data_rep_tycons - -- Does not add its axiom; that comes - -- from adding the 'axioms' above - ; setGblEnv gbl_env thing_inside } - where - axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts - data_rep_tycons = famInstsRepTyCons fam_insts - -- The representation tycons for 'data instances' declarations - -{- -Note [Deriving inside TH brackets] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a declaration bracket - [d| data T = A | B deriving( Show ) |] - -there is really no point in generating the derived code for deriving( -Show) and then type-checking it. This will happen at the call site -anyway, and the type check should never fail! Moreover (#6005) -the scoping of the generated code inside the bracket does not seem to -work out. - -The easy solution is simply not to generate the derived instances at -all. (A less brutal solution would be to generate them with no -bindings.) This will become moot when we shift to the new TH plan, so -the brutal solution will do. --} - -tcLocalInstDecl :: LInstDecl GhcRn - -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) - -- A source-file instance declaration - -- Type-check all the stuff before the "where" - -- - -- We check for respectable instance type, and context -tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl })) - = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl) - ; return ([], [fam_inst], []) } - -tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) - = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated (L loc decl) - ; return ([], [fam_inst], maybeToList m_deriv_info) } - -tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) - = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl) - ; return (insts, fam_insts, deriv_infos) } - -tcLocalInstDecl (L _ (XInstDecl nec)) = noExtCon nec - -tcClsInstDecl :: LClsInstDecl GhcRn - -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) --- The returned DerivInfos are for any associated data families -tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds - , cid_sigs = uprags, cid_tyfam_insts = ats - , cid_overlap_mode = overlap_mode - , cid_datafam_insts = adts })) - = setSrcSpan loc $ - addErrCtxt (instDeclCtxt1 hs_ty) $ - do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty - ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty - -- NB: tcHsClsInstType does checkValidInstance - - ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars - ; let tv_skol_prs = [ (tyVarName tv, skol_tv) - | (tv, skol_tv) <- tyvars `zip` skol_tvs ] - n_inferred = countWhile ((== Inferred) . binderArgFlag) $ - fst $ splitForAllVarBndrs dfun_ty - visible_skol_tvs = drop n_inferred skol_tvs - - ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs) - - -- Next, process any associated types. - ; (datafam_stuff, tyfam_insts) - <- tcExtendNameTyVarEnv tv_skol_prs $ - do { let mini_env = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys) - mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env - mb_info = InClsInst { ai_class = clas - , ai_tyvars = visible_skol_tvs - , ai_inst_env = mini_env } - ; df_stuff <- mapAndRecoverM (tcDataFamInstDecl mb_info) adts - ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info) ats - - -- Check for missing associated types and build them - -- from their defaults (if available) - ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats) - (classATItems clas) - - ; return (df_stuff, tf_insts1 ++ concat tf_insts2) } - - - -- Finally, construct the Core representation of the instance. - -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType hs_ty)) - -- Dfun location is that of instance *header* - - ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name - tyvars theta clas inst_tys - - ; let inst_binds = InstBindings - { ib_binds = binds - , ib_tyvars = map Var.varName tyvars -- Scope over bindings - , ib_pragmas = uprags - , ib_extensions = [] - , ib_derived = False } - inst_info = InstInfo { iSpec = ispec, iBinds = inst_binds } - - (datafam_insts, m_deriv_infos) = unzip datafam_stuff - deriv_infos = catMaybes m_deriv_infos - all_insts = tyfam_insts ++ datafam_insts - - -- In hs-boot files there should be no bindings - ; is_boot <- tcIsHsBootOrSig - ; let no_binds = isEmptyLHsBinds binds && null uprags - ; failIfTc (is_boot && not no_binds) badBootDeclErr - - ; return ( [inst_info], all_insts, deriv_infos ) } - where - defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) - `unionNameSet` - mkNameSet (map (unLoc . feqn_tycon - . hsib_body - . dfid_eqn - . unLoc) adts) - -tcClsInstDecl (L _ (XClsInstDecl nec)) = noExtCon nec - -{- -************************************************************************ -* * - Type family instances -* * -************************************************************************ - -Family instances are somewhat of a hybrid. They are processed together with -class instance heads, but can contain data constructors and hence they share a -lot of kinding and type checking code with ordinary algebraic data types (and -GADTs). --} - -tcTyFamInstDecl :: AssocInstInfo - -> LTyFamInstDecl GhcRn -> TcM FamInst - -- "type instance" - -- See Note [Associated type instances] -tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) - = setSrcSpan loc $ - tcAddTyFamInstCtxt decl $ - do { let fam_lname = feqn_tycon (hsib_body eqn) - ; fam_tc <- tcLookupLocatedTyCon fam_lname - ; tcFamInstDeclChecks mb_clsinfo fam_tc - - -- (0) Check it's an open type family - ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc) - - -- (1) do the work of verifying the synonym group - ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo - (L (getLoc fam_lname) eqn) - - - -- (2) check for validity - ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch - ; checkValidCoAxBranch fam_tc co_ax_branch - - -- (3) construct coercion axiom - ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch] - ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch - ; newFamInst SynFamilyInst axiom } - - ---------------------- -tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM () --- Used for both type and data families -tcFamInstDeclChecks mb_clsinfo fam_tc - = do { -- Type family instances require -XTypeFamilies - -- and can't (currently) be in an hs-boot file - ; traceTc "tcFamInstDecl" (ppr fam_tc) - ; type_families <- xoptM LangExt.TypeFamilies - ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? - ; checkTc type_families $ badFamInstDecl fam_tc - ; checkTc (not is_boot) $ badBootFamInstDeclErr - - -- Check that it is a family TyCon, and that - -- oplevel type instances are not for associated types. - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) - - ; when (isNotAssociated mb_clsinfo && -- Not in a class decl - isTyConAssoc fam_tc) -- but an associated type - (addErr $ assocInClassErr fam_tc) - } - -{- Note [Associated type instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow this: - class C a where - type T x a - instance C Int where - type T (S y) Int = y - type T Z Int = Char - -Note that - a) The variable 'x' is not bound by the class decl - b) 'x' is instantiated to a non-type-variable in the instance - c) There are several type instance decls for T in the instance - -All this is fine. Of course, you can't give any *more* instances -for (T ty Int) elsewhere, because it's an *associated* type. - - -************************************************************************ -* * - Data family instances -* * -************************************************************************ - -For some reason data family instances are a lot more complicated -than type family instances --} - -tcDataFamInstDecl :: AssocInstInfo - -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo) - -- "newtype instance" and "data instance" -tcDataFamInstDecl mb_clsinfo - (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars - , hsib_body = - FamEqn { feqn_bndrs = mb_bndrs - , feqn_pats = hs_pats - , feqn_tycon = lfam_name@(L _ fam_name) - , feqn_fixity = fixity - , feqn_rhs = HsDataDefn { dd_ND = new_or_data - , dd_cType = cType - , dd_ctxt = hs_ctxt - , dd_cons = hs_cons - , dd_kindSig = m_ksig - , dd_derivs = derivs } }}})) - = setSrcSpan loc $ - tcAddDataFamInstCtxt decl $ - do { fam_tc <- tcLookupLocatedTyCon lfam_name - - ; tcFamInstDeclChecks mb_clsinfo fam_tc - - -- Check that the family declaration is for the right kind - ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons - -- Do /not/ check that the number of patterns = tyConArity fam_tc - -- See [Arity of data families] in GHC.Core.FamInstEnv - ; (qtvs, pats, res_kind, stupid_theta) - <- tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs - fixity hs_ctxt hs_pats m_ksig hs_cons - new_or_data - - -- Eta-reduce the axiom if possible - -- Quite tricky: see Note [Implementing eta reduction for data families] - ; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats - eta_tvs = map binderVar eta_tcbs - post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs - - full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs - (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind)) - ++ eta_tcbs - -- Put the eta-removed tyvars at the end - -- Remember, qtvs is in arbitrary order, except kind vars are - -- first, so there is no reason to suppose that the eta_tvs - -- (obtained from the pats) are at the end (#11148) - - -- Eta-expand the representation tycon until it has result - -- kind `TYPE r`, for some `r`. If UnliftedNewtypes is not enabled, we - -- go one step further and ensure that it has kind `TYPE 'LiftedRep`. - -- - -- See also Note [Arity of data families] in GHC.Core.FamInstEnv - -- NB: we can do this after eta-reducing the axiom, because if - -- we did it before the "extra" tvs from etaExpandAlgTyCon - -- would always be eta-reduced - -- - -- See also Note [Datatype return kinds] in TcTyClsDecls - ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind - ; checkDataKindSig (DataInstanceSort new_or_data) final_res_kind - ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs - all_pats = pats `chkAppend` extra_pats - orig_res_ty = mkTyConApp fam_tc all_pats - ty_binders = full_tcbs `chkAppend` extra_tcbs - - ; traceTc "tcDataFamInstDecl" $ - vcat [ text "Fam tycon:" <+> ppr fam_tc - , text "Pats:" <+> ppr pats - , text "visibliities:" <+> ppr (tcbVisibilities fam_tc pats) - , text "all_pats:" <+> ppr all_pats - , text "ty_binders" <+> ppr ty_binders - , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc) - , text "eta_pats" <+> ppr eta_pats - , text "eta_tcbs" <+> ppr eta_tcbs ] - - ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) -> - do { data_cons <- tcExtendTyVarEnv qtvs $ - -- For H98 decls, the tyvars scope - -- over the data constructors - tcConDecls rec_rep_tc new_or_data ty_binders final_res_kind - orig_res_ty hs_cons - - ; rep_tc_name <- newFamInstTyConName lfam_name pats - ; axiom_name <- newFamInstAxiomName lfam_name [pats] - ; tc_rhs <- case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) - - ; let axiom = mkSingleCoAxiom Representational axiom_name - post_eta_qtvs eta_tvs [] fam_tc eta_pats - (mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs)) - parent = DataFamInstTyCon axiom fam_tc all_pats - - -- NB: Use the full ty_binders from the pats. See bullet toward - -- the end of Note [Data type families] in GHC.Core.TyCon - rep_tc = mkAlgTyCon rep_tc_name - ty_binders final_res_kind - (map (const Nominal) ty_binders) - (fmap unLoc cType) stupid_theta - tc_rhs parent - gadt_syntax - -- We always assume that indexed types are recursive. Why? - -- (1) Due to their open nature, we can never be sure that a - -- further instance might not introduce a new recursive - -- dependency. (2) They are always valid loop breakers as - -- they involve a coercion. - ; return (rep_tc, axiom) } - - -- Remember to check validity; no recursion to worry about here - -- Check that left-hand sides are ok (mono-types, no type families, - -- consistent instantiations, etc) - ; let ax_branch = coAxiomSingleBranch axiom - ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch - ; checkValidCoAxBranch fam_tc ax_branch - ; checkValidTyCon rep_tc - - ; let m_deriv_info = case derivs of - L _ [] -> Nothing - L _ preds -> - Just $ DerivInfo { di_rep_tc = rep_tc - , di_scoped_tvs = mkTyVarNamePairs (tyConTyVars rep_tc) - , di_clauses = preds - , di_ctxt = tcMkDataFamInstCtxt decl } - - ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom - ; return (fam_inst, m_deriv_info) } - where - eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder]) - -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom - -- Splits the incoming patterns into two: the [TyVar] - -- are the patterns that can be eta-reduced away. - -- e.g. T [a] Int a d c ==> (T [a] Int a, [d,c]) - -- - -- NB: quadratic algorithm, but types are small here - eta_reduce fam_tc pats - = go (reverse (zip3 pats fvs_s vis_s)) [] - where - vis_s :: [TyConBndrVis] - vis_s = tcbVisibilities fam_tc pats - - fvs_s :: [TyCoVarSet] -- 1-1 correspondence with pats - -- Each elt is the free vars of all /earlier/ pats - (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats - add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs) - - go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs - | Just tv <- getTyVar_maybe pat - , not (tv `elemVarSet` fvs_to_the_left) - = go pats (Bndr tv tcb_vis : etad_tvs) - go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs) - -tcDataFamInstDecl _ _ = panic "tcDataFamInstDecl" - ------------------------ -tcDataFamInstHeader - :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn] - -> LexicalFixity -> LHsContext GhcRn - -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn] - -> NewOrData - -> TcM ([TyVar], [Type], Kind, ThetaType) --- The "header" of a data family instance is the part other than --- the data constructors themselves --- e.g. data instance D [a] :: * -> * where ... --- Here the "header" is the bit before the "where" -tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity - hs_ctxt hs_pats m_ksig hs_cons new_or_data - = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, lhs_applied_kind))) - <- pushTcLevelM_ $ - solveEqualities $ - bindImplicitTKBndrs_Q_Skol imp_vars $ - bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ - do { stupid_theta <- tcHsContext hs_ctxt - ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats - - -- Ensure that the instance is consistent - -- with its parent class - ; addConsistencyConstraints mb_clsinfo lhs_ty - - -- Add constraints from the result signature - ; res_kind <- tc_kind_sig m_ksig - - -- Add constraints from the data constructors - ; kcConDecls new_or_data res_kind hs_cons - - -- See Note [Datatype return kinds] in TcTyClsDecls, point (7). - ; (lhs_extra_args, lhs_applied_kind) - <- tcInstInvisibleTyBinders (invisibleTyBndrCount lhs_kind) - lhs_kind - ; let lhs_applied_ty = lhs_ty `mkTcAppTys` lhs_extra_args - hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats - ; _ <- unifyKind (Just (unLoc hs_lhs)) lhs_applied_kind res_kind - - ; return ( stupid_theta - , lhs_applied_ty - , lhs_applied_kind ) } - - -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts] - -- This code (and the stuff immediately above) is very similar - -- to that in tcTyFamInstEqnGuts. Maybe we should abstract the - -- common code; but for the moment I concluded that it's - -- clearer to duplicate it. Still, if you fix a bug here, - -- check there too! - ; let scoped_tvs = imp_tvs ++ exp_tvs - ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) - ; qtvs <- quantifyTyVars dvs - - -- Zonk the patterns etc into the Type world - ; (ze, qtvs) <- zonkTyBndrs qtvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta - ; lhs_applied_kind <- zonkTcTypeToTypeX ze lhs_applied_kind - - -- Check that type patterns match the class instance head - -- The call to splitTyConApp_maybe here is just an inlining of - -- the body of unravelFamInstPats. - ; pats <- case splitTyConApp_maybe lhs_ty of - Just (_, pats) -> pure pats - Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty) - ; return (qtvs, pats, lhs_applied_kind, stupid_theta) } - where - fam_name = tyConName fam_tc - data_ctxt = DataKindCtxt fam_name - exp_bndrs = mb_bndrs `orElse` [] - - -- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls, wrinkle (2). - tc_kind_sig Nothing - = do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; if unlifted_newtypes && new_or_data == NewType - then newOpenTypeKind - else pure liftedTypeKind - } - - -- See Note [Result kind signature for a data family instance] - tc_kind_sig (Just hs_kind) - = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind - ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind - ; lvl <- getTcLevel - ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs - -- Perhaps surprisingly, we don't need the skolemised tvs themselves - ; let final_kind = substTy subst inner_kind - ; checkDataKindSig (DataInstanceSort new_or_data) $ - snd $ tcSplitPiTys final_kind - -- See Note [Datatype return kinds], end of point (4) - ; return final_kind } - -{- Note [Result kind signature for a data family instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The expected type might have a forall at the type. Normally, we -can't skolemise in kinds because we don't have type-level lambda. -But here, we're at the top-level of an instance declaration, so -we actually have a place to put the regeneralised variables. -Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise -Examples in indexed-types/should_compile/T12369 - -Note [Implementing eta reduction for data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data D :: * -> * -> * -> * -> * - - data instance D [(a,b)] p q :: * -> * where - D1 :: blah1 - D2 :: blah2 - -Then we'll generate a representation data type - data Drep a b p q z where - D1 :: blah1 - D2 :: blah2 - -and an axiom to connect them - axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z - -except that we'll eta-reduce the axiom to - axiom AxDrep forall a b. D [(a,b]] = Drep a b - -This is described at some length in Note [Eta reduction for data families] -in GHC.Core.Coercion.Axiom. There are several fiddly subtleties lurking here, -however, so this Note aims to describe these subtleties: - -* The representation tycon Drep is parameterised over the free - variables of the pattern, in no particular order. So there is no - guarantee that 'p' and 'q' will come last in Drep's parameters, and - in the right order. So, if the /patterns/ of the family insatance - are eta-reducible, we re-order Drep's parameters to put the - eta-reduced type variables last. - -* Although we eta-reduce the axiom, we eta-/expand/ the representation - tycon Drep. The kind of D says it takes four arguments, but the - data instance header only supplies three. But the AlgTyCon for Drep - itself must have enough TyConBinders so that its result kind is Type. - So, with etaExpandAlgTyCon we make up some extra TyConBinders. - See point (3) in Note [Datatype return kinds] in TcTyClsDecls. - -* The result kind in the instance might be a polykind, like this: - data family DP a :: forall k. k -> * - data instance DP [b] :: forall k1 k2. (k1,k2) -> * - - So in type-checking the LHS (DP Int) we need to check that it is - more polymorphic than the signature. To do that we must skolemise - the signature and instantiate the call of DP. So we end up with - data instance DP [b] @(k1,k2) (z :: (k1,k2)) where - - Note that we must parameterise the representation tycon DPrep over - 'k1' and 'k2', as well as 'b'. - - The skolemise bit is done in tc_kind_sig, while the instantiate bit - is done by tcFamTyPats. - -* Very fiddly point. When we eta-reduce to - axiom AxDrep forall a b. D [(a,b]] = Drep a b - - we want the kind of (D [(a,b)]) to be the same as the kind of - (Drep a b). This ensures that applying the axiom doesn't change the - kind. Why is that hard? Because the kind of (Drep a b) depends on - the TyConBndrVis on Drep's arguments. In particular do we have - (forall (k::*). blah) or (* -> blah)? - - We must match whatever D does! In #15817 we had - data family X a :: forall k. * -> * -- Note: a forall that is not used - data instance X Int b = MkX - - So the data instance is really - data istance X Int @k b = MkX - - The axiom will look like - axiom X Int = Xrep - - and it's important that XRep :: forall k * -> *, following X. - - To achieve this we get the TyConBndrVis flags from tcbVisibilities, - and use those flags for any eta-reduced arguments. Sigh. - -* The final turn of the knife is that tcbVisibilities is itself - tricky to sort out. Consider - data family D k :: k - Then consider D (forall k2. k2 -> k2) Type Type - The visibility flags on an application of D may affected by the arguments - themselves. Heavy sigh. But not truly hard; that's what tcbVisibilities - does. - --} - - -{- ********************************************************************* -* * - Class instance declarations, pass 2 -* * -********************************************************************* -} - -tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] - -> TcM (LHsBinds GhcTc) --- (a) From each class declaration, --- generate any default-method bindings --- (b) From each instance decl --- generate the dfun binding - -tcInstDecls2 tycl_decls inst_decls - = do { -- (a) Default methods from class decls - let class_decls = filter (isClassDecl . unLoc) tycl_decls - ; dm_binds_s <- mapM tcClassDecl2 class_decls - ; let dm_binds = unionManyBags dm_binds_s - - -- (b) instance declarations - ; let dm_ids = collectHsBindsBinders dm_binds - -- Add the default method Ids (again) - -- (they were arready added in TcTyDecls.tcAddImplicits) - -- See Note [Default methods in the type environment] - ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ - mapM tcInstDecl2 inst_decls - - -- Done - ; return (dm_binds `unionBags` unionManyBags inst_binds_s) } - -{- Note [Default methods in the type environment] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The default method Ids are already in the type environment (see Note -[Default method Ids and Template Haskell] in TcTyDcls), BUT they -don't have their InlinePragmas yet. Usually that would not matter, -because the simplifier propagates information from binding site to -use. But, unusually, when compiling instance decls we *copy* the -INLINE pragma from the default method to the method for that -particular operation (see Note [INLINE and default methods] below). - -So right here in tcInstDecls2 we must re-extend the type envt with -the default method Ids replete with their INLINE pragmas. Urk. --} - -tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) - -- Returns a binding for the dfun -tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) - = recoverM (return emptyLHsBinds) $ - setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ - do { -- Instantiate the instance decl with skolem constants - ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id - ; dfun_ev_vars <- newEvVars dfun_theta - -- We instantiate the dfun_id with superSkolems. - -- See Note [Subtle interaction of recursion and overlap] - -- and Note [Binding when looking up instances] - - ; let (clas, inst_tys) = tcSplitDFunHead inst_head - (class_tyvars, sc_theta, _, op_items) = classBigSig clas - sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta - - ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta']) - - -- Deal with 'SPECIALISE instance' pragmas - -- See Note [SPECIALISE instance pragmas] - ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds - - -- Typecheck superclasses and methods - -- See Note [Typechecking plan for instance declarations] - ; dfun_ev_binds_var <- newTcEvBinds - ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var - ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) - <- pushTcLevelM $ - do { (sc_ids, sc_binds, sc_implics) - <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars - inst_tys dfun_ev_binds - sc_theta' - - -- Typecheck the methods - ; (meth_ids, meth_binds, meth_implics) - <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars - inst_tys dfun_ev_binds spec_inst_info - op_items ibinds - - ; return ( sc_ids ++ meth_ids - , sc_binds `unionBags` meth_binds - , sc_implics `unionBags` meth_implics ) } - - ; imp <- newImplication - ; emitImplication $ - imp { ic_tclvl = tclvl - , ic_skols = inst_tyvars - , ic_given = dfun_ev_vars - , ic_wanted = mkImplicWC sc_meth_implics - , ic_binds = dfun_ev_binds_var - , ic_info = InstSkol } - - -- Create the result bindings - ; self_dict <- newDict clas inst_tys - ; let class_tc = classTyCon clas - [dict_constr] = tyConDataCons class_tc - dict_bind = mkVarBind self_dict (L loc con_app_args) - - -- We don't produce a binding for the dict_constr; instead we - -- rely on the simplifier to unfold this saturated application - -- We do this rather than generate an HsCon directly, because - -- it means that the special cases (e.g. dictionary with only one - -- member) are dealt with by the common MkId.mkDataConWrapId - -- code rather than needing to be repeated here. - -- con_app_tys = MkD ty1 ty2 - -- con_app_scs = MkD ty1 ty2 sc1 sc2 - -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 - con_app_tys = mkHsWrap (mkWpTyApps inst_tys) - (HsConLikeOut noExtField (RealDataCon dict_constr)) - -- NB: We *can* have covars in inst_tys, in the case of - -- promoted GADT constructors. - - con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids - - app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc - app_to_meth fun meth_id = HsApp noExtField (L loc fun) - (L loc (wrapId arg_wrapper meth_id)) - - inst_tv_tys = mkTyVarTys inst_tyvars - arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys - - is_newtype = isNewTyCon class_tc - dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids - dfun_spec_prags - | is_newtype = SpecPrags [] - | otherwise = SpecPrags spec_inst_prags - -- Newtype dfuns just inline unconditionally, - -- so don't attempt to specialise them - - export = ABE { abe_ext = noExtField - , abe_wrap = idHsWrapper - , abe_poly = dfun_id_w_prags - , abe_mono = self_dict - , abe_prags = dfun_spec_prags } - -- NB: see Note [SPECIALISE instance pragmas] - main_bind = AbsBinds { abs_ext = noExtField - , abs_tvs = inst_tyvars - , abs_ev_vars = dfun_ev_vars - , abs_exports = [export] - , abs_ev_binds = [] - , abs_binds = unitBag dict_bind - , abs_sig = True } - - ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds) - } - where - dfun_id = instanceDFunId ispec - loc = getSrcSpan dfun_id - -addDFunPrags :: DFunId -> [Id] -> DFunId --- DFuns need a special Unfolding and InlinePrag --- See Note [ClassOp/DFun selection] --- and Note [Single-method classes] --- It's easiest to create those unfoldings right here, where --- have all the pieces in hand, even though we are messing with --- Core at this point, which the typechecker doesn't usually do --- However we take care to build the unfolding using the TyVars from --- the DFunId rather than from the skolem pieces that the typechecker --- is messing with. -addDFunPrags dfun_id sc_meth_ids - | is_newtype - = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app - `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } - | otherwise - = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args - `setInlinePragma` dfunInlinePragma - where - con_app = mkLams dfun_bndrs $ - mkApps (Var (dataConWrapId dict_con)) dict_args - -- mkApps is OK because of the checkForLevPoly call in checkValidClass - -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad - dict_args = map Type inst_tys ++ - [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] - - (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id) - ev_ids = mkTemplateLocalsNum 1 dfun_theta - dfun_bndrs = dfun_tvs ++ ev_ids - clas_tc = classTyCon clas - [dict_con] = tyConDataCons clas_tc - is_newtype = isNewTyCon clas_tc - -wrapId :: HsWrapper -> Id -> HsExpr GhcTc -wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id)) - -{- Note [Typechecking plan for instance declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For instance declarations we generate the following bindings and implication -constraints. Example: - - instance Ord a => Ord [a] where compare = <compare-rhs> - -generates this: - - Bindings: - -- Method bindings - $ccompare :: forall a. Ord a => a -> a -> Ordering - $ccompare = /\a \(d:Ord a). let <meth-ev-binds> in ... - - -- Superclass bindings - $cp1Ord :: forall a. Ord a => Eq [a] - $cp1Ord = /\a \(d:Ord a). let <sc-ev-binds> - in dfEqList (dw :: Eq a) - - Constraints: - forall a. Ord a => - -- Method constraint - (forall. (empty) => <constraints from compare-rhs>) - -- Superclass constraint - /\ (forall. (empty) => dw :: Eq a) - -Notice that - - * Per-meth/sc implication. There is one inner implication per - superclass or method, with no skolem variables or givens. The only - reason for this one is to gather the evidence bindings privately - for this superclass or method. This implication is generated - by checkInstConstraints. - - * Overall instance implication. There is an overall enclosing - implication for the whole instance declaration, with the expected - skolems and givens. We need this to get the correct "redundant - constraint" warnings, gathering all the uses from all the methods - and superclasses. See TcSimplify Note [Tracking redundant - constraints] - - * The given constraints in the outer implication may generate - evidence, notably by superclass selection. Since the method and - superclass bindings are top-level, we want that evidence copied - into *every* method or superclass definition. (Some of it will - be usused in some, but dead-code elimination will drop it.) - - We achieve this by putting the evidence variable for the overall - instance implication into the AbsBinds for each method/superclass. - Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses. - (And that in turn is why the abs_ev_binds field of AbBinds is a - [TcEvBinds] rather than simply TcEvBinds. - - This is a bit of a hack, but works very nicely in practice. - - * Note that if a method has a locally-polymorphic binding, there will - be yet another implication for that, generated by tcPolyCheck - in tcMethodBody. E.g. - class C a where - foo :: forall b. Ord b => blah - - -************************************************************************ -* * - Type-checking superclasses -* * -************************************************************************ --} - -tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] - -> TcEvBinds - -> TcThetaType - -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication) --- Make a new top-level function binding for each superclass, --- something like --- $Ordp1 :: forall a. Ord a => Eq [a] --- $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d) --- --- See Note [Recursive superclasses] for why this is so hard! --- In effect, we build a special-purpose solver for the first step --- of solving each superclass constraint -tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta - = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..]) - ; return (ids, listToBag binds, listToBag implics) } - where - loc = getSrcSpan dfun_id - size = sizeTypes inst_tys - tc_super (sc_pred, n) - = do { (sc_implic, ev_binds_var, sc_ev_tm) - <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred - - ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) - ; sc_ev_id <- newEvVar sc_pred - ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm - ; let sc_top_ty = mkInvForAllTys tyvars $ - mkPhiTy (map idType dfun_evs) sc_pred - sc_top_id = mkLocalId sc_top_name sc_top_ty - export = ABE { abe_ext = noExtField - , abe_wrap = idHsWrapper - , abe_poly = sc_top_id - , abe_mono = sc_ev_id - , abe_prags = noSpecPrags } - local_ev_binds = TcEvBinds ev_binds_var - bind = AbsBinds { abs_ext = noExtField - , abs_tvs = tyvars - , abs_ev_vars = dfun_evs - , abs_exports = [export] - , abs_ev_binds = [dfun_ev_binds, local_ev_binds] - , abs_binds = emptyBag - , abs_sig = False } - ; return (sc_top_id, L loc bind, sc_implic) } - -------------------- -checkInstConstraints :: TcM result - -> TcM (Implication, EvBindsVar, result) --- See Note [Typechecking plan for instance declarations] -checkInstConstraints thing_inside - = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $ - thing_inside - - ; ev_binds_var <- newTcEvBinds - ; implic <- newImplication - ; let implic' = implic { ic_tclvl = tclvl - , ic_wanted = wanted - , ic_binds = ev_binds_var - , ic_info = InstSkol } - - ; return (implic', ev_binds_var, result) } - -{- -Note [Recursive superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #3731, #4809, #5751, #5913, #6117, #6161, which all -describe somewhat more complicated situations, but ones -encountered in practice. - -See also tests tcrun020, tcrun021, tcrun033, and #11427. - ------ THE PROBLEM -------- -The problem is that it is all too easy to create a class whose -superclass is bottom when it should not be. - -Consider the following (extreme) situation: - class C a => D a where ... - instance D [a] => D [a] where ... (dfunD) - instance C [a] => C [a] where ... (dfunC) -Although this looks wrong (assume D [a] to prove D [a]), it is only a -more extreme case of what happens with recursive dictionaries, and it -can, just about, make sense because the methods do some work before -recursing. - -To implement the dfunD we must generate code for the superclass C [a], -which we had better not get by superclass selection from the supplied -argument: - dfunD :: forall a. D [a] -> D [a] - dfunD = \d::D [a] -> MkD (scsel d) .. - -Otherwise if we later encounter a situation where -we have a [Wanted] dw::D [a] we might solve it thus: - dw := dfunD dw -Which is all fine except that now ** the superclass C is bottom **! - -The instance we want is: - dfunD :: forall a. D [a] -> D [a] - dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ... - ------ THE SOLUTION -------- -The basic solution is simple: be very careful about using superclass -selection to generate a superclass witness in a dictionary function -definition. More precisely: - - Superclass Invariant: in every class dictionary, - every superclass dictionary field - is non-bottom - -To achieve the Superclass Invariant, in a dfun definition we can -generate a guaranteed-non-bottom superclass witness from: - (sc1) one of the dictionary arguments itself (all non-bottom) - (sc2) an immediate superclass of a smaller dictionary - (sc3) a call of a dfun (always returns a dictionary constructor) - -The tricky case is (sc2). We proceed by induction on the size of -the (type of) the dictionary, defined by TcValidity.sizeTypes. -Let's suppose we are building a dictionary of size 3, and -suppose the Superclass Invariant holds of smaller dictionaries. -Then if we have a smaller dictionary, its immediate superclasses -will be non-bottom by induction. - -What does "we have a smaller dictionary" mean? It might be -one of the arguments of the instance, or one of its superclasses. -Here is an example, taken from CmmExpr: - class Ord r => UserOfRegs r a where ... -(i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where -(i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where - -For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a), -since it is smaller than the thing we are building (UserOfRegs r (Maybe a). - -But for (i2) that isn't the case, so we must add an explicit, and -perhaps surprising, (Ord r) argument to the instance declaration. - -Here's another example from #6161: - - class Super a => Duper a where ... - class Duper (Fam a) => Foo a where ... -(i3) instance Foo a => Duper (Fam a) where ... -(i4) instance Foo Float where ... - -It would be horribly wrong to define - dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3) - dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ... - - dfFooFloat :: Foo Float -- from (i4) - dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ... - -Now the Super superclass of Duper is definitely bottom! - -This won't happen because when processing (i3) we can use the -superclasses of (Foo a), which is smaller, namely Duper (Fam a). But -that is *not* smaller than the target so we can't take *its* -superclasses. As a result the program is rightly rejected, unless you -add (Super (Fam a)) to the context of (i3). - -Note [Solving superclass constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How do we ensure that every superclass witness is generated by -one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses]. -Answer: - - * Superclass "wanted" constraints have CtOrigin of (ScOrigin size) - where 'size' is the size of the instance declaration. e.g. - class C a => D a where... - instance blah => D [a] where ... - The wanted superclass constraint for C [a] has origin - ScOrigin size, where size = size( D [a] ). - - * (sc1) When we rewrite such a wanted constraint, it retains its - origin. But if we apply an instance declaration, we can set the - origin to (ScOrigin infinity), thus lifting any restrictions by - making prohibitedSuperClassSolve return False. - - * (sc2) ScOrigin wanted constraints can't be solved from a - superclass selection, except at a smaller type. This test is - implemented by TcInteract.prohibitedSuperClassSolve - - * The "given" constraints of an instance decl have CtOrigin - GivenOrigin InstSkol. - - * When we make a superclass selection from InstSkol we use - a SkolemInfo of (InstSC size), where 'size' is the size of - the constraint whose superclass we are taking. A similarly - when taking the superclass of an InstSC. This is implemented - in TcCanonical.newSCWorkFromFlavored - -Note [Silent superclass arguments] (historical interest only) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB1: this note describes our *old* solution to the - recursive-superclass problem. I'm keeping the Note - for now, just as institutional memory. - However, the code for silent superclass arguments - was removed in late Dec 2014 - -NB2: the silent-superclass solution introduced new problems - of its own, in the form of instance overlap. Tests - SilentParametersOverlapping, T5051, and T7862 are examples - -NB3: the silent-superclass solution also generated tons of - extra dictionaries. For example, in monad-transformer - code, when constructing a Monad dictionary you had to pass - an Applicative dictionary; and to construct that you need - a Functor dictionary. Yet these extra dictionaries were - often never used. Test T3064 compiled *far* faster after - silent superclasses were eliminated. - -Our solution to this problem "silent superclass arguments". We pass -to each dfun some ``silent superclass arguments’’, which are the -immediate superclasses of the dictionary we are trying to -construct. In our example: - dfun :: forall a. C [a] -> D [a] -> D [a] - dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... -Notice the extra (dc :: C [a]) argument compared to the previous version. - -This gives us: - - ----------------------------------------------------------- - DFun Superclass Invariant - ~~~~~~~~~~~~~~~~~~~~~~~~ - In the body of a DFun, every superclass argument to the - returned dictionary is - either * one of the arguments of the DFun, - or * constant, bound at top level - ----------------------------------------------------------- - -This net effect is that it is safe to treat a dfun application as -wrapping a dictionary constructor around its arguments (in particular, -a dfun never picks superclasses from the arguments under the -dictionary constructor). No superclass is hidden inside a dfun -application. - -The extra arguments required to satisfy the DFun Superclass Invariant -always come first, and are called the "silent" arguments. You can -find out how many silent arguments there are using Id.dfunNSilent; -and then you can just drop that number of arguments to see the ones -that were in the original instance declaration. - -DFun types are built (only) by MkId.mkDictFunId, so that is where we -decide what silent arguments are to be added. --} - -{- -************************************************************************ -* * - Type-checking an instance method -* * -************************************************************************ - -tcMethod -- Make the method bindings, as a [(NonRec, HsBinds)], one per method -- Remembering to use fresh Name (the instance method Name) as the binder -- Bring the instance method Ids into scope, for the benefit of tcInstSig -- Use sig_fn mapping instance method Name -> instance tyvars -- Ditto prag_fn -- Use tcValBinds to do the checking --} - -tcMethods :: DFunId -> Class - -> [TcTyVar] -> [EvVar] - -> [TcType] - -> TcEvBinds - -> ([Located TcSpecPrag], TcPragEnv) - -> [ClassOpItem] - -> InstBindings GhcRn - -> TcM ([Id], LHsBinds GhcTc, Bag Implication) - -- The returned inst_meth_ids all have types starting - -- forall tvs. theta => ... -tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds (spec_inst_prags, prag_fn) op_items - (InstBindings { ib_binds = binds - , ib_tyvars = lexical_tvs - , ib_pragmas = sigs - , ib_extensions = exts - , ib_derived = is_derived }) - = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $ - -- The lexical_tvs scope over the 'where' part - do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) - ; checkMinimalDefinition - ; checkMethBindMembership - ; (ids, binds, mb_implics) <- set_exts exts $ - unset_warnings_deriving $ - mapAndUnzip3M tc_item op_items - ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) } - where - set_exts :: [LangExt.Extension] -> TcM a -> TcM a - set_exts es thing = foldr setXOptM thing es - - -- See Note [Avoid -Winaccessible-code when deriving] - unset_warnings_deriving :: TcM a -> TcM a - unset_warnings_deriving - | is_derived = unsetWOptM Opt_WarnInaccessibleCode - | otherwise = id - - hs_sig_fn = mkHsSigFun sigs - inst_loc = getSrcSpan dfun_id - - ---------------------- - tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication) - tc_item (sel_id, dm_info) - | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn - = tcMethodBody clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds is_derived hs_sig_fn - spec_inst_prags prags - sel_id user_bind bndr_loc - | otherwise - = do { traceTc "tc_def" (ppr sel_id) - ; tc_default sel_id dm_info } - - ---------------------- - tc_default :: Id -> DefMethInfo - -> TcM (TcId, LHsBind GhcTc, Maybe Implication) - - tc_default sel_id (Just (dm_name, _)) - = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name - ; tcMethodBody clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds is_derived hs_sig_fn - spec_inst_prags inline_prags - sel_id meth_bind inst_loc } - - tc_default sel_id Nothing -- No default method at all - = do { traceTc "tc_def: warn" (ppr sel_id) - ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id - ; dflags <- getDynFlags - ; let meth_bind = mkVarBind meth_id $ - mkLHsWrap lam_wrapper (error_rhs dflags) - ; return (meth_id, meth_bind, Nothing) } - where - error_rhs dflags = L inst_loc $ HsApp noExtField error_fun (error_msg dflags) - error_fun = L inst_loc $ - wrapId (mkWpTyApps - [ getRuntimeRep meth_tau, meth_tau]) - nO_METHOD_BINDING_ERROR_ID - error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText - (unsafeMkByteString (error_string dflags)))) - meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys) - error_string dflags = showSDoc dflags - (hcat [ppr inst_loc, vbar, ppr sel_id ]) - lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars - - ---------------------- - -- Check if one of the minimal complete definitions is satisfied - checkMinimalDefinition - = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ - warnUnsatisfiedMinimalDefinition - - methodExists meth = isJust (findMethodBind meth binds prag_fn) - - ---------------------- - -- Check if any method bindings do not correspond to the class. - -- See Note [Mismatched class methods and associated type families]. - checkMethBindMembership - = mapM_ (addErrTc . badMethodErr clas) mismatched_meths - where - bind_nms = map unLoc $ collectMethodBinders binds - cls_meth_nms = map (idName . fst) op_items - mismatched_meths = bind_nms `minusList` cls_meth_nms - -{- -Note [Mismatched class methods and associated type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's entirely possible for someone to put methods or associated type family -instances inside of a class in which it doesn't belong. For instance, we'd -want to fail if someone wrote this: - - instance Eq () where - type Rep () = Maybe - compare = undefined - -Since neither the type family `Rep` nor the method `compare` belong to the -class `Eq`. Normally, this is caught in the renamer when resolving RdrNames, -since that would discover that the parent class `Eq` is incorrect. - -However, there is a scenario in which the renamer could fail to catch this: -if the instance was generated through Template Haskell, as in #12387. In that -case, Template Haskell will provide fully resolved names (e.g., -`GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going -on. For this reason, we also put an extra validity check for this in the -typechecker as a last resort. - -Note [Avoid -Winaccessible-code when deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --Winaccessible-code can be particularly noisy when deriving instances for -GADTs. Consider the following example (adapted from #8128): - - data T a where - MkT1 :: Int -> T Int - MkT2 :: T Bool - MkT3 :: T Bool - deriving instance Eq (T a) - deriving instance Ord (T a) - -In the derived Ord instance, GHC will generate the following code: - - instance Ord (T a) where - compare x y - = case x of - MkT2 - -> case y of - MkT1 {} -> GT - MkT2 -> EQ - _ -> LT - ... - -However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2 -differ, so if -Winaccessible-code is enabled, then deriving this instance will -result in unwelcome warnings. - -One conceivable approach to fixing this issue would be to change `deriving Ord` -such that it becomes smarter about not generating unreachable cases. This, -however, would be a highly nontrivial refactor, as we'd have to propagate -through typing information everywhere in the algorithm that generates Ord -instances in order to determine which cases were unreachable. This seems like -a lot of work for minimal gain, so we have opted not to go for this approach. - -Instead, we take the much simpler approach of always disabling --Winaccessible-code for derived code. To accomplish this, we do the following: - -1. In tcMethods (which typechecks method bindings), disable - -Winaccessible-code. -2. When creating Implications during typechecking, record this flag - (in ic_warn_inaccessible) at the time of creation. -3. After typechecking comes error reporting, where GHC must decide how to - report inaccessible code to the user, on an Implication-by-Implication - basis. If an Implication's DynFlags indicate that -Winaccessible-code was - disabled, then don't bother reporting it. That's it! --} - ------------------------- -tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType] - -> TcEvBinds -> Bool - -> HsSigFun - -> [LTcSpecPrag] -> [LSig GhcRn] - -> Id -> LHsBind GhcRn -> SrcSpan - -> TcM (TcId, LHsBind GhcTc, Maybe Implication) -tcMethodBody clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds is_derived - sig_fn spec_inst_prags prags - sel_id (L bind_loc meth_bind) bndr_loc - = add_meth_ctxt $ - do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc) - ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $ - mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id - - ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) } - -- Substitute the local_meth_name for the binder - -- NB: the binding is always a FunBind - - -- taking instance signature into account might change the type of - -- the local_meth_id - ; (meth_implic, ev_binds_var, tc_bind) - <- checkInstConstraints $ - tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind) - - ; global_meth_id <- addInlinePrags global_meth_id prags - ; spec_prags <- tcSpecPrags global_meth_id prags - - ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags - export = ABE { abe_ext = noExtField - , abe_poly = global_meth_id - , abe_mono = local_meth_id - , abe_wrap = idHsWrapper - , abe_prags = specs } - - local_ev_binds = TcEvBinds ev_binds_var - full_bind = AbsBinds { abs_ext = noExtField - , abs_tvs = tyvars - , abs_ev_vars = dfun_ev_vars - , abs_exports = [export] - , abs_ev_binds = [dfun_ev_binds, local_ev_binds] - , abs_binds = tc_bind - , abs_sig = True } - - ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) } - where - -- For instance decls that come from deriving clauses - -- we want to print out the full source code if there's an error - -- because otherwise the user won't see the code at all - add_meth_ctxt thing - | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing - | otherwise = thing - -tcMethodBodyHelp :: HsSigFun -> Id -> TcId - -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId) -tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind - | Just hs_sig_ty <- hs_sig_fn sel_name - -- There is a signature in the instance - -- See Note [Instance method signatures] - = do { let ctxt = FunSigCtxt sel_name True - ; (sig_ty, hs_wrap) - <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $ - do { inst_sigs <- xoptM LangExt.InstanceSigs - ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty) - ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty - ; let local_meth_ty = idType local_meth_id - ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $ - tcSubType_NC ctxt sig_ty local_meth_ty - ; return (sig_ty, hs_wrap) } - - ; inner_meth_name <- newName (nameOccName sel_name) - ; let inner_meth_id = mkLocalId inner_meth_name sig_ty - inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id - , sig_ctxt = ctxt - , sig_loc = getLoc (hsSigType hs_sig_ty) } - - - ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind - - ; let export = ABE { abe_ext = noExtField - , abe_poly = local_meth_id - , abe_mono = inner_id - , abe_wrap = hs_wrap - , abe_prags = noSpecPrags } - - ; return (unitBag $ L (getLoc meth_bind) $ - AbsBinds { abs_ext = noExtField, abs_tvs = [], abs_ev_vars = [] - , abs_exports = [export] - , abs_binds = tc_bind, abs_ev_binds = [] - , abs_sig = True }) } - - | otherwise -- No instance signature - = do { let ctxt = FunSigCtxt sel_name False - -- False <=> don't report redundant constraints - -- The signature is not under the users control! - tc_sig = completeSigFromId ctxt local_meth_id - -- Absent a type sig, there are no new scoped type variables here - -- Only the ones from the instance decl itself, which are already - -- in scope. Example: - -- class C a where { op :: forall b. Eq b => ... } - -- instance C [c] where { op = <rhs> } - -- In <rhs>, 'c' is scope but 'b' is not! - - ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind - ; return tc_bind } - - where - sel_name = idName sel_id - no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; - -- they are all for meth_id - - ------------------------- -mkMethIds :: Class -> [TcTyVar] -> [EvVar] - -> [TcType] -> Id -> TcM (TcId, TcId) - -- returns (poly_id, local_id), but ignoring any instance signature - -- See Note [Instance method signatures] -mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ) - ; local_meth_name <- newName sel_occ - -- Base the local_meth_name on the selector name, because - -- type errors from tcMethodBody come from here - ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty - local_meth_id = mkLocalId local_meth_name local_meth_ty - - ; return (poly_meth_id, local_meth_id) } - where - sel_name = idName sel_id - sel_occ = nameOccName sel_name - local_meth_ty = instantiateMethod clas sel_id inst_tys - poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty - theta = map idType dfun_ev_vars - -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) -methSigCtxt sel_name sig_ty meth_ty env0 - = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty - ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty - ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name)) - 2 (vcat [ text "is more general than its signature in the class" - , text "Instance sig:" <+> ppr sig_ty - , text " Class sig:" <+> ppr meth_ty ]) - ; return (env2, msg) } - -misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc -misplacedInstSig name hs_ty - = vcat [ hang (text "Illegal type signature in instance declaration:") - 2 (hang (pprPrefixName name) - 2 (dcolon <+> ppr hs_ty)) - , text "(Use InstanceSigs to allow this)" ] - -{- Note [Instance method signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -XInstanceSigs we allow the user to supply a signature for the -method in an instance declaration. Here is an artificial example: - - data T a = MkT a - instance Ord a => Ord (T a) where - (>) :: forall b. b -> b -> Bool - (>) = error "You can't compare Ts" - -The instance signature can be *more* polymorphic than the instantiated -class method (in this case: Age -> Age -> Bool), but it cannot be less -polymorphic. Moreover, if a signature is given, the implementation -code should match the signature, and type variables bound in the -singature should scope over the method body. - -We achieve this by building a TcSigInfo for the method, whether or not -there is an instance method signature, and using that to typecheck -the declaration (in tcMethodBody). That means, conveniently, -that the type variables bound in the signature will scope over the body. - -What about the check that the instance method signature is more -polymorphic than the instantiated class method type? We just do a -tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like -this (for the example above - - AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a] - , abs_exports - = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool - , gr_lcl :: T a -> T a -> Bool } - , abs_binds - = AbsBind { abs_tvs = [], abs_ev_vars = [] - , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool - , gr_inner :: forall b. b -> b -> Bool } - , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = [] - , ..etc.. } - } } - -Wow! Three nested AbsBinds! - * The outer one abstracts over the tyvars and dicts for the instance - * The middle one is only present if there is an instance signature, - and does the impedance matching for that signature - * The inner one is for the method binding itself against either the - signature from the class, or the instance signature. --} - ----------------------- -mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags - -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id - -- There are two sources: - -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-} - -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-} - -- These ones have the dfun inside, but [perhaps surprisingly] - -- the correct wrapper. - -- See Note [Handling SPECIALISE pragmas] in TcBinds -mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me - = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) - where - spec_prags_from_inst - | isInlinePragma (idInlinePragma meth_id) - = [] -- Do not inherit SPECIALISE from the instance if the - -- method is marked INLINE, because then it'll be inlined - -- and the specialisation would do nothing. (Indeed it'll provoke - -- a warning from the desugarer - | otherwise - = [ L inst_loc (SpecPrag meth_id wrap inl) - | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] - - -mkDefMethBind :: Class -> [Type] -> Id -> Name - -> TcM (LHsBind GhcRn, [LSig GhcRn]) --- The is a default method (vanailla or generic) defined in the class --- So make a binding op = $dmop @t1 @t2 --- where $dmop is the name of the default method in the class, --- and t1,t2 are the instance types. --- See Note [Default methods in instances] for why we use --- visible type application here -mkDefMethBind clas inst_tys sel_id dm_name - = do { dflags <- getDynFlags - ; dm_id <- tcLookupId dm_name - ; let inline_prag = idInlinePragma dm_id - inline_prags | isAnyInlinePragma inline_prag - = [noLoc (InlineSig noExtField fn inline_prag)] - | otherwise - = [] - -- Copy the inline pragma (if any) from the default method - -- to this version. Note [INLINE and default methods] - - fn = noLoc (idName sel_id) - visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys - , tyConBinderArgFlag tcb /= Inferred ] - rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys - bind = noLoc $ mkTopFunBind Generated fn $ - [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] - - ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" - FormatHaskell - (vcat [ppr clas <+> ppr inst_tys, - nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) - - ; return (bind, inline_prags) } - where - mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn - mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy - $ noLoc $ XHsType $ NHsCoreTy ty)) - -- NB: use visible type application - -- See Note [Default methods in instances] - ----------------------- -derivBindCtxt :: Id -> Class -> [Type ] -> SDoc -derivBindCtxt sel_id clas tys - = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id) - , nest 2 (text "in a derived instance for" - <+> quotes (pprClassPred clas tys) <> colon) - , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ] - -warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () -warnUnsatisfiedMinimalDefinition mindef - = do { warn <- woptM Opt_WarnMissingMethods - ; warnTc (Reason Opt_WarnMissingMethods) warn message - } - where - message = vcat [text "No explicit implementation for" - ,nest 2 $ pprBooleanFormulaNice mindef - ] - -{- -Note [Export helper functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We arrange to export the "helper functions" of an instance declaration, -so that they are not subject to preInlineUnconditionally, even if their -RHS is trivial. Reason: they are mentioned in the DFunUnfolding of -the dict fun as Ids, not as CoreExprs, so we can't substitute a -non-variable for them. - -We could change this by making DFunUnfoldings have CoreExprs, but it -seems a bit simpler this way. - -Note [Default methods in instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - - class Baz v x where - foo :: x -> x - foo y = <blah> - - instance Baz Int Int - -From the class decl we get - - $dmfoo :: forall v x. Baz v x => x -> x - $dmfoo y = <blah> - -Notice that the type is ambiguous. So we use Visible Type Application -to disambiguate: - - $dBazIntInt = MkBaz fooIntInt - fooIntInt = $dmfoo @Int @Int - -Lacking VTA we'd get ambiguity errors involving the default method. This applies -equally to vanilla default methods (#1061) and generic default methods -(#12220). - -Historical note: before we had VTA we had to generate -post-type-checked code, which took a lot more code, and didn't work for -generic default methods. - -Note [INLINE and default methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Default methods need special case. They are supposed to behave rather like -macros. For example - - class Foo a where - op1, op2 :: Bool -> a -> a - - {-# INLINE op1 #-} - op1 b x = op2 (not b) x - - instance Foo Int where - -- op1 via default method - op2 b x = <blah> - -The instance declaration should behave - - just as if 'op1' had been defined with the - code, and INLINE pragma, from its original - definition. - -That is, just as if you'd written - - instance Foo Int where - op2 b x = <blah> - - {-# INLINE op1 #-} - op1 b x = op2 (not b) x - -So for the above example we generate: - - {-# INLINE $dmop1 #-} - -- $dmop1 has an InlineCompulsory unfolding - $dmop1 d b x = op2 d (not b) x - - $fFooInt = MkD $cop1 $cop2 - - {-# INLINE $cop1 #-} - $cop1 = $dmop1 $fFooInt - - $cop2 = <blah> - -Note carefully: - -* We *copy* any INLINE pragma from the default method $dmop1 to the - instance $cop1. Otherwise we'll just inline the former in the - latter and stop, which isn't what the user expected - -* Regardless of its pragma, we give the default method an - unfolding with an InlineCompulsory source. That means - that it'll be inlined at every use site, notably in - each instance declaration, such as $cop1. This inlining - must happen even though - a) $dmop1 is not saturated in $cop1 - b) $cop1 itself has an INLINE pragma - - It's vital that $dmop1 *is* inlined in this way, to allow the mutual - recursion between $fooInt and $cop1 to be broken - -* To communicate the need for an InlineCompulsory to the desugarer - (which makes the Unfoldings), we use the IsDefaultMethod constructor - in TcSpecPrags. - - -************************************************************************ -* * - Specialise instance pragmas -* * -************************************************************************ - -Note [SPECIALISE instance pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - instance (Ix a, Ix b) => Ix (a,b) where - {-# SPECIALISE instance Ix (Int,Int) #-} - range (x,y) = ... - -We make a specialised version of the dictionary function, AND -specialised versions of each *method*. Thus we should generate -something like this: - - $dfIxPair :: (Ix a, Ix b) => Ix (a,b) - {-# DFUN [$crangePair, ...] #-} - {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-} - $dfIxPair da db = Ix ($crangePair da db) (...other methods...) - - $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] - {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} - $crange da db = <blah> - -The SPECIALISE pragmas are acted upon by the desugarer, which generate - - dii :: Ix Int - dii = ... - - $s$dfIxPair :: Ix ((Int,Int),(Int,Int)) - {-# DFUN [$crangePair di di, ...] #-} - $s$dfIxPair = Ix ($crangePair di di) (...) - - {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-} - - $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)] - $c$crangePair = ...specialised RHS of $crangePair... - - {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-} - -Note that - - * The specialised dictionary $s$dfIxPair is very much needed, in case we - call a function that takes a dictionary, but in a context where the - specialised dictionary can be used. See #7797. - - * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because - it still has a DFunUnfolding. See Note [ClassOp/DFun selection] - - * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways: - --> {ClassOp rule for range} $crangePair Int Int d1 d2 - --> {SPEC rule for $crangePair} $s$crangePair - or thus: - --> {SPEC rule for $dfIxPair} range $s$dfIxPair - --> {ClassOpRule for range} $s$crangePair - It doesn't matter which way. - - * We want to specialise the RHS of both $dfIxPair and $crangePair, - but the SAME HsWrapper will do for both! We can call tcSpecPrag - just once, and pass the result (in spec_inst_info) to tcMethods. --} - -tcSpecInstPrags :: DFunId -> InstBindings GhcRn - -> TcM ([Located TcSpecPrag], TcPragEnv) -tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) - = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ - filter isSpecInstLSig uprags - -- The filter removes the pragmas for methods - ; return (spec_inst_prags, mkPragEnv uprags binds) } - ------------------------------- -tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag -tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty) - = addErrCtxt (spec_ctxt prag) $ - do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty - ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty - ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } - where - spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) - -tcSpecInst _ _ = panic "tcSpecInst" - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -instDeclCtxt1 :: LHsSigType GhcRn -> SDoc -instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - -instDeclCtxt2 :: Type -> SDoc -instDeclCtxt2 dfun_ty - = inst_decl_ctxt (ppr (mkClassPred cls tys)) - where - (_,_,cls,tys) = tcSplitDFunTy dfun_ty - -inst_decl_ctxt :: SDoc -> SDoc -inst_decl_ctxt doc = hang (text "In the instance declaration for") - 2 (quotes doc) - -badBootFamInstDeclErr :: SDoc -badBootFamInstDeclErr - = text "Illegal family instance in hs-boot file" - -notFamily :: TyCon -> SDoc -notFamily tycon - = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) - , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] - -assocInClassErr :: TyCon -> SDoc -assocInClassErr name - = text "Associated type" <+> quotes (ppr name) <+> - text "must be inside a class instance" - -badFamInstDecl :: TyCon -> SDoc -badFamInstDecl tc_name - = vcat [ text "Illegal family instance for" <+> - quotes (ppr tc_name) - , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] - -notOpenFamily :: TyCon -> SDoc -notOpenFamily tc - = text "Illegal instance for closed family" <+> quotes (ppr tc) diff --git a/compiler/typecheck/TcInstDcls.hs-boot b/compiler/typecheck/TcInstDcls.hs-boot deleted file mode 100644 index c65016efa0..0000000000 --- a/compiler/typecheck/TcInstDcls.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -module TcInstDcls ( tcInstDecls1 ) where - -import GHC.Hs -import TcRnTypes -import TcEnv( InstInfo ) -import TcDeriv - --- We need this because of the mutual recursion --- between TcTyClsDecls and TcInstDcls -tcInstDecls1 :: [LInstDecl GhcRn] - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs deleted file mode 100644 index d0f1e0d1b1..0000000000 --- a/compiler/typecheck/TcInteract.hs +++ /dev/null @@ -1,2700 +0,0 @@ -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcInteract ( - solveSimpleGivens, -- Solves [Ct] - solveSimpleWanteds, -- Solves Cts - ) where - -#include "HsVersions.h" - -import GhcPrelude -import GHC.Types.Basic ( SwapFlag(..), isSwapped, - infinity, IntWithInf, intGtLimit ) -import TcCanonical -import TcFlatten -import TcUnify( canSolveByUnification ) -import GHC.Types.Var.Set -import GHC.Core.Type as Type -import GHC.Core.Coercion ( BlockSubstFlag(..) ) -import GHC.Core.InstEnv ( DFunInstType ) -import GHC.Core.Coercion.Axiom ( sfInteractTop, sfInteractInert ) - -import GHC.Types.Var -import TcType -import PrelNames ( coercibleTyConKey, - heqTyConKey, eqTyConKey, ipClassKey ) -import GHC.Core.Coercion.Axiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches ) -import GHC.Core.Class -import GHC.Core.TyCon -import FunDeps -import FamInst -import ClsInst( InstanceWhat(..), safeOverlap ) -import GHC.Core.FamInstEnv -import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) - -import TcEvidence -import Outputable - -import TcRnTypes -import Constraint -import GHC.Core.Predicate -import TcOrigin -import TcSMonad -import Bag -import MonadUtils ( concatMapM, foldlM ) - -import GHC.Core -import Data.List( partition, deleteFirstsBy ) -import GHC.Types.SrcLoc -import GHC.Types.Var.Env - -import Control.Monad -import Maybes( isJust ) -import Pair (Pair(..)) -import GHC.Types.Unique( hasKey ) -import GHC.Driver.Session -import Util -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe - -{- -********************************************************************** -* * -* Main Interaction Solver * -* * -********************************************************************** - -Note [Basic Simplifier Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -1. Pick an element from the WorkList if there exists one with depth - less than our context-stack depth. - -2. Run it down the 'stage' pipeline. Stages are: - - canonicalization - - inert reactions - - spontaneous reactions - - top-level interactions - Each stage returns a StopOrContinue and may have sideffected - the inerts or worklist. - - The threading of the stages is as follows: - - If (Stop) is returned by a stage then we start again from Step 1. - - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to - the next stage in the pipeline. -4. If the element has survived (i.e. ContinueWith x) the last stage - then we add him in the inerts and jump back to Step 1. - -If in Step 1 no such element exists, we have exceeded our context-stack -depth and will simply fail. - -Note [Unflatten after solving the simple wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We unflatten after solving the wc_simples of an implication, and before attempting -to float. This means that - - * The fsk/fmv flatten-skolems only survive during solveSimples. We don't - need to worry about them across successive passes over the constraint tree. - (E.g. we don't need the old ic_fsk field of an implication. - - * When floating an equality outwards, we don't need to worry about floating its - associated flattening constraints. - - * Another tricky case becomes easy: #4935 - type instance F True a b = a - type instance F False a b = b - - [w] F c a b ~ gamma - (c ~ True) => a ~ gamma - (c ~ False) => b ~ gamma - - Obviously this is soluble with gamma := F c a b, and unflattening - will do exactly that after solving the simple constraints and before - attempting the implications. Before, when we were not unflattening, - we had to push Wanted funeqs in as new givens. Yuk! - - Another example that becomes easy: indexed_types/should_fail/T7786 - [W] BuriedUnder sub k Empty ~ fsk - [W] Intersect fsk inv ~ s - [w] xxx[1] ~ s - [W] forall[2] . (xxx[1] ~ Empty) - => Intersect (BuriedUnder sub k Empty) inv ~ Empty - -Note [Running plugins on unflattened wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is an annoying mismatch between solveSimpleGivens and -solveSimpleWanteds, because the latter needs to fiddle with the inert -set, unflatten and zonk the wanteds. It passes the zonked wanteds -to runTcPluginsWanteds, which produces a replacement set of wanteds, -some additional insolubles and a flag indicating whether to go round -the loop again. If so, prepareInertsForImplications is used to remove -the previous wanteds (which will still be in the inert set). Note -that prepareInertsForImplications will discard the insolubles, so we -must keep track of them separately. --} - -solveSimpleGivens :: [Ct] -> TcS () -solveSimpleGivens givens - | null givens -- Shortcut for common case - = return () - | otherwise - = do { traceTcS "solveSimpleGivens {" (ppr givens) - ; go givens - ; traceTcS "End solveSimpleGivens }" empty } - where - go givens = do { solveSimples (listToBag givens) - ; new_givens <- runTcPluginsGiven - ; when (notNull new_givens) $ - go new_givens } - -solveSimpleWanteds :: Cts -> TcS WantedConstraints --- NB: 'simples' may contain /derived/ equalities, floated --- out from a nested implication. So don't discard deriveds! --- The result is not necessarily zonked -solveSimpleWanteds simples - = do { traceTcS "solveSimpleWanteds {" (ppr simples) - ; dflags <- getDynFlags - ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples }) - ; traceTcS "solveSimpleWanteds end }" $ - vcat [ text "iterations =" <+> ppr n - , text "residual =" <+> ppr wc ] - ; return wc } - where - go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints) - go n limit wc - | n `intGtLimit` limit - = failTcS (hang (text "solveSimpleWanteds: too many iterations" - <+> parens (text "limit =" <+> ppr limit)) - 2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" - , text "Simples =" <+> ppr simples - , text "WC =" <+> ppr wc ])) - - | isEmptyBag (wc_simple wc) - = return (n,wc) - - | otherwise - = do { -- Solve - (unif_count, wc1) <- solve_simple_wanteds wc - - -- Run plugins - ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1 - -- See Note [Running plugins on unflattened wanteds] - - ; if unif_count == 0 && not rerun_plugin - then return (n, wc2) -- Done - else do { traceTcS "solveSimple going round again:" $ - ppr unif_count $$ ppr rerun_plugin - ; go (n+1) limit wc2 } } -- Loop - - -solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints) --- Try solving these constraints --- Affects the unification state (of course) but not the inert set --- The result is not necessarily zonked -solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1 }) - = nestTcS $ - do { solveSimples simples1 - ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts - ; (unif_count, unflattened_eqs) <- reportUnifications $ - unflattenWanteds tv_eqs fun_eqs - -- See Note [Unflatten after solving the simple wanteds] - ; return ( unif_count - , WC { wc_simple = others `andCts` unflattened_eqs - , wc_impl = implics1 `unionBags` implics2 }) } - -{- Note [The solveSimpleWanteds loop] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Solving a bunch of simple constraints is done in a loop, -(the 'go' loop of 'solveSimpleWanteds'): - 1. Try to solve them; unflattening may lead to improvement that - was not exploitable during solving - 2. Try the plugin - 3. If step 1 did improvement during unflattening; or if the plugin - wants to run again, go back to step 1 - -Non-obviously, improvement can also take place during -the unflattening that takes place in step (1). See TcFlatten, -See Note [Unflattening can force the solver to iterate] --} - --- The main solver loop implements Note [Basic Simplifier Plan] ---------------------------------------------------------------- -solveSimples :: Cts -> TcS () --- Returns the final InertSet in TcS --- Has no effect on work-list or residual-implications --- The constraints are initially examined in left-to-right order - -solveSimples cts - = {-# SCC "solveSimples" #-} - do { updWorkListTcS (\wl -> foldr extendWorkListCt wl cts) - ; solve_loop } - where - solve_loop - = {-# SCC "solve_loop" #-} - do { sel <- selectNextWorkItem - ; case sel of - Nothing -> return () - Just ct -> do { runSolverPipeline thePipeline ct - ; solve_loop } } - --- | Extract the (inert) givens and invoke the plugins on them. --- Remove solved givens from the inert set and emit insolubles, but --- return new work produced so that 'solveSimpleGivens' can feed it back --- into the main solver. -runTcPluginsGiven :: TcS [Ct] -runTcPluginsGiven - = do { plugins <- getTcPlugins - ; if null plugins then return [] else - do { givens <- getInertGivens - ; if null givens then return [] else - do { p <- runTcPlugins plugins (givens,[],[]) - ; let (solved_givens, _, _) = pluginSolvedCts p - insols = pluginBadCts p - ; updInertCans (removeInertCts solved_givens) - ; updInertIrreds (\irreds -> extendCtsList irreds insols) - ; return (pluginNewCts p) } } } - --- | Given a bag of (flattened, zonked) wanteds, invoke the plugins on --- them and produce an updated bag of wanteds (possibly with some new --- work) and a bag of insolubles. The boolean indicates whether --- 'solveSimpleWanteds' should feed the updated wanteds back into the --- main solver. -runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints) -runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_impl = implics1 }) - | isEmptyBag simples1 - = return (False, wc) - | otherwise - = do { plugins <- getTcPlugins - ; if null plugins then return (False, wc) else - - do { given <- getInertGivens - ; simples1 <- zonkSimples simples1 -- Plugin requires zonked inputs - ; let (wanted, derived) = partition isWantedCt (bagToList simples1) - ; p <- runTcPlugins plugins (given, derived, wanted) - ; let (_, _, solved_wanted) = pluginSolvedCts p - (_, unsolved_derived, unsolved_wanted) = pluginInputCts p - new_wanted = pluginNewCts p - insols = pluginBadCts p - --- SLPJ: I'm deeply suspicious of this --- ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds) - - ; mapM_ setEv solved_wanted - ; return ( notNull (pluginNewCts p) - , WC { wc_simple = listToBag new_wanted `andCts` - listToBag unsolved_wanted `andCts` - listToBag unsolved_derived `andCts` - listToBag insols - , wc_impl = implics1 } ) } } - where - setEv :: (EvTerm,Ct) -> TcS () - setEv (ev,ct) = case ctEvidence ct of - CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev - _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" - --- | A triple of (given, derived, wanted) constraints to pass to plugins -type SplitCts = ([Ct], [Ct], [Ct]) - --- | A solved triple of constraints, with evidence for wanteds -type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)]) - --- | Represents collections of constraints generated by typechecker --- plugins -data TcPluginProgress = TcPluginProgress - { pluginInputCts :: SplitCts - -- ^ Original inputs to the plugins with solved/bad constraints - -- removed, but otherwise unmodified - , pluginSolvedCts :: SolvedCts - -- ^ Constraints solved by plugins - , pluginBadCts :: [Ct] - -- ^ Constraints reported as insoluble by plugins - , pluginNewCts :: [Ct] - -- ^ New constraints emitted by plugins - } - -getTcPlugins :: TcS [TcPluginSolver] -getTcPlugins = do { tcg_env <- getGblEnv; return (tcg_tc_plugins tcg_env) } - --- | Starting from a triple of (given, derived, wanted) constraints, --- invoke each of the typechecker plugins in turn and return --- --- * the remaining unmodified constraints, --- * constraints that have been solved, --- * constraints that are insoluble, and --- * new work. --- --- Note that new work generated by one plugin will not be seen by --- other plugins on this pass (but the main constraint solver will be --- re-invoked and they will see it later). There is no check that new --- work differs from the original constraints supplied to the plugin: --- the plugin itself should perform this check if necessary. -runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress -runTcPlugins plugins all_cts - = foldM do_plugin initialProgress plugins - where - do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress - do_plugin p solver = do - result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p)) - return $ progress p result - - progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress - progress p (TcPluginContradiction bad_cts) = - p { pluginInputCts = discard bad_cts (pluginInputCts p) - , pluginBadCts = bad_cts ++ pluginBadCts p - } - progress p (TcPluginOk solved_cts new_cts) = - p { pluginInputCts = discard (map snd solved_cts) (pluginInputCts p) - , pluginSolvedCts = add solved_cts (pluginSolvedCts p) - , pluginNewCts = new_cts ++ pluginNewCts p - } - - initialProgress = TcPluginProgress all_cts ([], [], []) [] [] - - discard :: [Ct] -> SplitCts -> SplitCts - discard cts (xs, ys, zs) = - (xs `without` cts, ys `without` cts, zs `without` cts) - - without :: [Ct] -> [Ct] -> [Ct] - without = deleteFirstsBy eqCt - - eqCt :: Ct -> Ct -> Bool - eqCt c c' = ctFlavour c == ctFlavour c' - && ctPred c `tcEqType` ctPred c' - - add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts - add xs scs = foldl' addOne scs xs - - addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts - addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of - CtGiven {} -> (ct:givens, deriveds, wanteds) - CtDerived{} -> (givens, ct:deriveds, wanteds) - CtWanted {} -> (givens, deriveds, (ev,ct):wanteds) - - -type WorkItem = Ct -type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct) - -runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline - -> WorkItem -- The work item - -> TcS () --- Run this item down the pipeline, leaving behind new work and inerts -runSolverPipeline pipeline workItem - = do { wl <- getWorkList - ; inerts <- getTcSInerts - ; tclevel <- getTcLevel - ; traceTcS "----------------------------- " empty - ; traceTcS "Start solver pipeline {" $ - vcat [ text "tclevel =" <+> ppr tclevel - , text "work item =" <+> ppr workItem - , text "inerts =" <+> ppr inerts - , text "rest of worklist =" <+> ppr wl ] - - ; bumpStepCountTcS -- One step for each constraint processed - ; final_res <- run_pipeline pipeline (ContinueWith workItem) - - ; case final_res of - Stop ev s -> do { traceFireTcS ev s - ; traceTcS "End solver pipeline (discharged) }" empty - ; return () } - ContinueWith ct -> do { addInertCan ct - ; traceFireTcS (ctEvidence ct) (text "Kept as inert") - ; traceTcS "End solver pipeline (kept as inert) }" $ - (text "final_item =" <+> ppr ct) } - } - where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct - -> TcS (StopOrContinue Ct) - run_pipeline [] res = return res - run_pipeline _ (Stop ev s) = return (Stop ev s) - run_pipeline ((stg_name,stg):stgs) (ContinueWith ct) - = do { traceTcS ("runStage " ++ stg_name ++ " {") - (text "workitem = " <+> ppr ct) - ; res <- stg ct - ; traceTcS ("end stage " ++ stg_name ++ " }") empty - ; run_pipeline stgs res } - -{- -Example 1: - Inert: {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given) - Reagent: a ~ [b] (given) - -React with (c~d) ==> IR (ContinueWith (a~[b])) True [] -React with (F a ~ t) ==> IR (ContinueWith (a~[b])) False [F [b] ~ t] -React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True [] - -Example 2: - Inert: {c ~w d, F a ~g t, b ~w Int, a ~w ty} - Reagent: a ~w [b] - -React with (c ~w d) ==> IR (ContinueWith (a~[b])) True [] -React with (F a ~g t) ==> IR (ContinueWith (a~[b])) True [] (can't rewrite given with wanted!) -etc. - -Example 3: - Inert: {a ~ Int, F Int ~ b} (given) - Reagent: F a ~ b (wanted) - -React with (a ~ Int) ==> IR (ContinueWith (F Int ~ b)) True [] -React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canonicalize and get nothing --} - -thePipeline :: [(String,SimplifierStage)] -thePipeline = [ ("canonicalization", TcCanonical.canonicalize) - , ("interact with inerts", interactWithInertsStage) - , ("top-level reactions", topReactionsStage) ] - -{- -********************************************************************************* -* * - The interact-with-inert Stage -* * -********************************************************************************* - -Note [The Solver Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We always add Givens first. So you might think that the solver has -the invariant - - If the work-item is Given, - then the inert item must Given - -But this isn't quite true. Suppose we have, - c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int -After processing the first two, we get - c1: [G] beta ~ [alpha], c2 : [W] blah -Now, c3 does not interact with the given c1, so when we spontaneously -solve c3, we must re-react it with the inert set. So we can attempt a -reaction between inert c2 [W] and work-item c3 [G]. - -It *is* true that [Solver Invariant] - If the work-item is Given, - AND there is a reaction - then the inert item must Given -or, equivalently, - If the work-item is Given, - and the inert item is Wanted/Derived - then there is no reaction --} - --- Interaction result of WorkItem <~> Ct - -interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct) --- Precondition: if the workitem is a CTyEqCan then it will not be able to --- react with anything at this stage. - -interactWithInertsStage wi - = do { inerts <- getTcSInerts - ; let ics = inert_cans inerts - ; case wi of - CTyEqCan {} -> interactTyVarEq ics wi - CFunEqCan {} -> interactFunEq ics wi - CIrredCan {} -> interactIrred ics wi - CDictCan {} -> interactDict ics wi - _ -> pprPanic "interactWithInerts" (ppr wi) } - -- CHoleCan are put straight into inert_frozen, so never get here - -- CNonCanonical have been canonicalised - -data InteractResult - = KeepInert -- Keep the inert item, and solve the work item from it - -- (if the latter is Wanted; just discard it if not) - | KeepWork -- Keep the work item, and solve the intert item from it - -instance Outputable InteractResult where - ppr KeepInert = text "keep inert" - ppr KeepWork = text "keep work-item" - -solveOneFromTheOther :: CtEvidence -- Inert - -> CtEvidence -- WorkItem - -> TcS InteractResult --- Precondition: --- * inert and work item represent evidence for the /same/ predicate --- --- We can always solve one from the other: even if both are wanted, --- although we don't rewrite wanteds with wanteds, we can combine --- two wanteds into one by solving one from the other - -solveOneFromTheOther ev_i ev_w - | isDerived ev_w -- Work item is Derived; just discard it - = return KeepInert - - | isDerived ev_i -- The inert item is Derived, we can just throw it away, - = return KeepWork -- The ev_w is inert wrt earlier inert-set items, - -- so it's safe to continue on from this point - - | CtWanted { ctev_loc = loc_w } <- ev_w - , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w - = -- inert must be Given - do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) - ; return KeepWork } - - | CtWanted {} <- ev_w - -- Inert is Given or Wanted - = return KeepInert - - -- From here on the work-item is Given - - | CtWanted { ctev_loc = loc_i } <- ev_i - , prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i - = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w) - ; return KeepInert } -- Just discard the un-usable Given - -- This never actually happens because - -- Givens get processed first - - | CtWanted {} <- ev_i - = return KeepWork - - -- From here on both are Given - -- See Note [Replacement vs keeping] - - | lvl_i == lvl_w - = do { ev_binds_var <- getTcEvBindsVar - ; binds <- getTcEvBindsMap ev_binds_var - ; return (same_level_strategy binds) } - - | otherwise -- Both are Given, levels differ - = return different_level_strategy - where - pred = ctEvPred ev_i - loc_i = ctEvLoc ev_i - loc_w = ctEvLoc ev_w - lvl_i = ctLocLevel loc_i - lvl_w = ctLocLevel loc_w - ev_id_i = ctEvEvId ev_i - ev_id_w = ctEvEvId ev_w - - different_level_strategy -- Both Given - | isIPPred pred = if lvl_w > lvl_i then KeepWork else KeepInert - | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork - -- See Note [Replacement vs keeping] (the different-level bullet) - -- For the isIPPred case see Note [Shadowing of Implicit Parameters] - - same_level_strategy binds -- Both Given - | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i - = case ctLocOrigin loc_w of - GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork - | otherwise -> KeepInert - _ -> KeepWork - - | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w - = KeepInert - - | has_binding binds ev_id_w - , not (has_binding binds ev_id_i) - , not (ev_id_i `elemVarSet` findNeededEvVars binds (unitVarSet ev_id_w)) - = KeepWork - - | otherwise - = KeepInert - - has_binding binds ev_id = isJust (lookupEvBind binds ev_id) - -{- -Note [Replacement vs keeping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have two Given constraints both of type (C tys), say, which should -we keep? More subtle than you might think! - - * Constraints come from different levels (different_level_strategy) - - - For implicit parameters we want to keep the innermost (deepest) - one, so that it overrides the outer one. - See Note [Shadowing of Implicit Parameters] - - - For everything else, we want to keep the outermost one. Reason: that - makes it more likely that the inner one will turn out to be unused, - and can be reported as redundant. See Note [Tracking redundant constraints] - in TcSimplify. - - It transpires that using the outermost one is responsible for an - 8% performance improvement in nofib cryptarithm2, compared to - just rolling the dice. I didn't investigate why. - - * Constraints coming from the same level (i.e. same implication) - - (a) Always get rid of InstSC ones if possible, since they are less - useful for solving. If both are InstSC, choose the one with - the smallest TypeSize - See Note [Solving superclass constraints] in TcInstDcls - - (b) Keep the one that has a non-trivial evidence binding. - Example: f :: (Eq a, Ord a) => blah - then we may find [G] d3 :: Eq a - [G] d2 :: Eq a - with bindings d3 = sc_sel (d1::Ord a) - We want to discard d2 in favour of the superclass selection from - the Ord dictionary. - Why? See Note [Tracking redundant constraints] in TcSimplify again. - - (c) But don't do (b) if the evidence binding depends transitively on the - one without a binding. Example (with RecursiveSuperClasses) - class C a => D a - class D a => C a - Inert: d1 :: C a, d2 :: D a - Binds: d3 = sc_sel d2, d2 = sc_sel d1 - Work item: d3 :: C a - Then it'd be ridiculous to replace d1 with d3 in the inert set! - Hence the findNeedEvVars test. See #14774. - - * Finally, when there is still a choice, use KeepInert rather than - KeepWork, for two reasons: - - to avoid unnecessary munging of the inert set. - - to cut off superclass loops; see Note [Superclass loops] in TcCanonical - -Doing the depth-check for implicit parameters, rather than making the work item -always override, is important. Consider - - data T a where { T1 :: (?x::Int) => T Int; T2 :: T a } - - f :: (?x::a) => T a -> Int - f T1 = ?x - f T2 = 3 - -We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add -two new givens in the work-list: [G] (?x::Int) - [G] (a ~ Int) -Now consider these steps - - process a~Int, kicking out (?x::a) - - process (?x::Int), the inner given, adding to inert set - - process (?x::a), the outer given, overriding the inner given -Wrong! The depth-check ensures that the inner implicit parameter wins. -(Actually I think that the order in which the work-list is processed means -that this chain of events won't happen, but that's very fragile.) - -********************************************************************************* -* * - interactIrred -* * -********************************************************************************* - -Note [Multiple matching irreds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might think that it's impossible to have multiple irreds all match the -work item; after all, interactIrred looks for matches and solves one from the -other. However, note that interacting insoluble, non-droppable irreds does not -do this matching. We thus might end up with several insoluble, non-droppable, -matching irreds in the inert set. When another irred comes along that we have -not yet labeled insoluble, we can find multiple matches. These multiple matches -cause no harm, but it would be wrong to ASSERT that they aren't there (as we -once had done). This problem can be tickled by typecheck/should_compile/holes. - --} - --- Two pieces of irreducible evidence: if their types are *exactly identical* --- we can rewrite them. We can never improve using this: --- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not --- mean that (ty1 ~ ty2) -interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) - -interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_status = status }) - | InsolubleCIS <- status - -- For insolubles, don't allow the constraint to be dropped - -- which can happen with solveOneFromTheOther, so that - -- we get distinct error messages with -fdefer-type-errors - -- See Note [Do not add duplicate derived insolubles] - , not (isDroppableCt workItem) - = continueWith workItem - - | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w - , ((ct_i, swap) : _rest) <- bagToList matching_irreds - -- See Note [Multiple matching irreds] - , let ev_i = ctEvidence ct_i - = do { what_next <- solveOneFromTheOther ev_i ev_w - ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i) - ; case what_next of - KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i) - ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) } - KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w) - ; updInertIrreds (\_ -> others) - ; continueWith workItem } } - - | otherwise - = continueWith workItem - - where - swap_me :: SwapFlag -> CtEvidence -> EvTerm - swap_me swap ev - = case swap of - NotSwapped -> ctEvTerm ev - IsSwapped -> evCoercion (mkTcSymCo (evTermCoercion (ctEvTerm ev))) - -interactIrred _ wi = pprPanic "interactIrred" (ppr wi) - -findMatchingIrreds :: Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Bag Ct) -findMatchingIrreds irreds ev - | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred - -- See Note [Solving irreducible equalities] - = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds - | otherwise - = partitionBagWith match_non_eq irreds - where - pred = ctEvPred ev - match_non_eq ct - | ctPred ct `tcEqTypeNoKindCheck` pred = Left (ct, NotSwapped) - | otherwise = Right ct - - match_eq eq_rel1 lty1 rty1 ct - | EqPred eq_rel2 lty2 rty2 <- classifyPredType (ctPred ct) - , eq_rel1 == eq_rel2 - , Just swap <- match_eq_help lty1 rty1 lty2 rty2 - = Left (ct, swap) - | otherwise - = Right ct - - match_eq_help lty1 rty1 lty2 rty2 - | lty1 `tcEqTypeNoKindCheck` lty2, rty1 `tcEqTypeNoKindCheck` rty2 - = Just NotSwapped - | lty1 `tcEqTypeNoKindCheck` rty2, rty1 `tcEqTypeNoKindCheck` lty2 - = Just IsSwapped - | otherwise - = Nothing - -{- Note [Solving irreducible equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14333) - [G] a b ~R# c d - [W] c d ~R# a b -Clearly we should be able to solve this! Even though the constraints are -not decomposable. We solve this when looking up the work-item in the -irreducible constraints to look for an identical one. When doing this -lookup, findMatchingIrreds spots the equality case, and matches either -way around. It has to return a swap-flag so we can generate evidence -that is the right way round too. - -Note [Do not add duplicate derived insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we *must* add an insoluble (Int ~ Bool) even if there is -one such there already, because they may come from distinct call -sites. Not only do we want an error message for each, but with --fdefer-type-errors we must generate evidence for each. But for -*derived* insolubles, we only want to report each one once. Why? - -(a) A constraint (C r s t) where r -> s, say, may generate the same fundep - equality many times, as the original constraint is successively rewritten. - -(b) Ditto the successive iterations of the main solver itself, as it traverses - the constraint tree. See example below. - -Also for *given* insolubles we may get repeated errors, as we -repeatedly traverse the constraint tree. These are relatively rare -anyway, so removing duplicates seems ok. (Alternatively we could take -the SrcLoc into account.) - -Note that the test does not need to be particularly efficient because -it is only used if the program has a type error anyway. - -Example of (b): assume a top-level class and instance declaration: - - class D a b | a -> b - instance D [a] [a] - -Assume we have started with an implication: - - forall c. Eq c => { wc_simple = D [c] c [W] } - -which we have simplified to: - - forall c. Eq c => { wc_simple = D [c] c [W] - (c ~ [c]) [D] } - -For some reason, e.g. because we floated an equality somewhere else, -we might try to re-solve this implication. If we do not do a -dropDerivedWC, then we will end up trying to solve the following -constraints the second time: - - (D [c] c) [W] - (c ~ [c]) [D] - -which will result in two Deriveds to end up in the insoluble set: - - wc_simple = D [c] c [W] - (c ~ [c]) [D], (c ~ [c]) [D] --} - -{- -********************************************************************************* -* * - interactDict -* * -********************************************************************************* - -Note [Shortcut solving] -~~~~~~~~~~~~~~~~~~~~~~~ -When we interact a [W] constraint with a [G] constraint that solves it, there is -a possibility that we could produce better code if instead we solved from a -top-level instance declaration (See #12791, #5835). For example: - - class M a b where m :: a -> b - - type C a b = (Num a, M a b) - - f :: C Int b => b -> Int -> Int - f _ x = x + 1 - -The body of `f` requires a [W] `Num Int` instance. We could solve this -constraint from the givens because we have `C Int b` and that provides us a -solution for `Num Int`. This would let us produce core like the following -(with -O2): - - f :: forall b. C Int b => b -> Int -> Int - f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) -> - + @ Int - (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%)) - eta1 - A.f1 - -This is bad! We could do /much/ better if we solved [W] `Num Int` directly -from the instance that we have in scope: - - f :: forall b. C Int b => b -> Int -> Int - f = \ (@ b) _ _ (x :: Int) -> - case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) } - -** NB: It is important to emphasize that all this is purely an optimization: -** exactly the same programs should typecheck with or without this -** procedure. - -Solving fully -~~~~~~~~~~~~~ -There is a reason why the solver does not simply try to solve such -constraints with top-level instances. If the solver finds a relevant -instance declaration in scope, that instance may require a context -that can't be solved for. A good example of this is: - - f :: Ord [a] => ... - f x = ..Need Eq [a]... - -If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would -be left with the obligation to solve the constraint Eq a, which we cannot. So we -must be conservative in our attempt to use an instance declaration to solve the -[W] constraint we're interested in. - -Our rule is that we try to solve all of the instance's subgoals -recursively all at once. Precisely: We only attempt to solve -constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci -are themselves class constraints of the form `C1', ... Cm' => C' t1' -... tn'` and we only succeed if the entire tree of constraints is -solvable from instances. - -An example that succeeds: - - class Eq a => C a b | b -> a where - m :: b -> a - - f :: C [Int] b => b -> Bool - f x = m x == [] - -We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This -produces the following core: - - f :: forall b. C [Int] b => b -> Bool - f = \ (@ b) ($dC :: C [Int] b) (x :: b) -> - GHC.Classes.$fEq[]_$s$c== - (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int) - -An example that fails: - - class Eq a => C a b | b -> a where - m :: b -> a - - f :: C [a] b => b -> Bool - f x = m x == [] - -Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces: - - f :: forall a b. C [a] b => b -> Bool - f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) -> - == - @ [a] - (A.$p1C @ [a] @ b $dC) - (m @ [a] @ b $dC eta) - (GHC.Types.[] @ a) - -Note [Shortcut solving: type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have (#13943) - class Take (n :: Nat) where ... - instance {-# OVERLAPPING #-} Take 0 where .. - instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where .. - -And we have [W] Take 3. That only matches one instance so we get -[W] Take (3-1). Really we should now flatten to reduce the (3-1) to 2, and -so on -- but that is reproducing yet more of the solver. Sigh. For now, -we just give up (remember all this is just an optimisation). - -But we must not just naively try to lookup (Take (3-1)) in the -InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a -unique match on the (Take n) instance. That leads immediately to an -infinite loop. Hence the check that 'preds' have no type families -(isTyFamFree). - -Note [Shortcut solving: incoherence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This optimization relies on coherence of dictionaries to be correct. When we -cannot assume coherence because of IncoherentInstances then this optimization -can change the behavior of the user's code. - -The following four modules produce a program whose output would change depending -on whether we apply this optimization when IncoherentInstances is in effect: - -######### - {-# LANGUAGE MultiParamTypeClasses #-} - module A where - - class A a where - int :: a -> Int - - class A a => C a b where - m :: b -> a -> a - -######### - {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} - module B where - - import A - - instance A a where - int _ = 1 - - instance C a [b] where - m _ = id - -######### - {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} - {-# LANGUAGE IncoherentInstances #-} - module C where - - import A - - instance A Int where - int _ = 2 - - instance C Int [Int] where - m _ = id - - intC :: C Int a => a -> Int -> Int - intC _ x = int x - -######### - module Main where - - import A - import B - import C - - main :: IO () - main = print (intC [] (0::Int)) - -The output of `main` if we avoid the optimization under the effect of -IncoherentInstances is `1`. If we were to do the optimization, the output of -`main` would be `2`. - -Note [Shortcut try_solve_from_instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The workhorse of the short-cut solver is - try_solve_from_instance :: (EvBindMap, DictMap CtEvidence) - -> CtEvidence -- Solve this - -> MaybeT TcS (EvBindMap, DictMap CtEvidence) -Note that: - -* The CtEvidence is the goal to be solved - -* The MaybeT manages early failure if we find a subgoal that - cannot be solved from instances. - -* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional - state that allows try_solve_from_instance to augmennt the evidence - bindings and inert_solved_dicts as it goes. - - If it succeeds, we commit all these bindings and solved dicts to the - main TcS InertSet. If not, we abandon it all entirely. - -Passing along the solved_dicts important for two reasons: - -* We need to be able to handle recursive super classes. The - solved_dicts state ensures that we remember what we have already - tried to solve to avoid looping. - -* As #15164 showed, it can be important to exploit sharing between - goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H; - and to solve G2 we may need H. If we don't spot this sharing we may - solve H twice; and if this pattern repeats we may get exponentially bad - behaviour. --} - -interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) - | Just ev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys - = -- There is a matching dictionary in the inert set - do { -- First to try to solve it /completely/ from top level instances - -- See Note [Shortcut solving] - dflags <- getDynFlags - ; short_cut_worked <- shortCutSolver dflags ev_w ev_i - ; if short_cut_worked - then stopWith ev_w "interactDict/solved from instance" - else - - do { -- Ths short-cut solver didn't fire, so we - -- solve ev_w from the matching inert ev_i we found - what_next <- solveOneFromTheOther ev_i ev_w - ; traceTcS "lookupInertDict" (ppr what_next) - ; case what_next of - KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i) - ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } - KeepWork -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w) - ; updInertDicts $ \ ds -> delDict ds cls tys - ; continueWith workItem } } } - - | cls `hasKey` ipClassKey - , isGiven ev_w - = interactGivenIP inerts workItem - - | otherwise - = do { addFunDepWork inerts ev_w cls - ; continueWith workItem } - -interactDict _ wi = pprPanic "interactDict" (ppr wi) - --- See Note [Shortcut solving] -shortCutSolver :: DynFlags - -> CtEvidence -- Work item - -> CtEvidence -- Inert we want to try to replace - -> TcS Bool -- True <=> success -shortCutSolver dflags ev_w ev_i - | isWanted ev_w - && isGiven ev_i - -- We are about to solve a [W] constraint from a [G] constraint. We take - -- a moment to see if we can get a better solution using an instance. - -- Note that we only do this for the sake of performance. Exactly the same - -- programs should typecheck regardless of whether we take this step or - -- not. See Note [Shortcut solving] - - && not (xopt LangExt.IncoherentInstances dflags) - -- If IncoherentInstances is on then we cannot rely on coherence of proofs - -- in order to justify this optimization: The proof provided by the - -- [G] constraint's superclass may be different from the top-level proof. - -- See Note [Shortcut solving: incoherence] - - && gopt Opt_SolveConstantDicts dflags - -- Enabled by the -fsolve-constant-dicts flag - = do { ev_binds_var <- getTcEvBindsVar - ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w ) - getTcEvBindsMap ev_binds_var - ; solved_dicts <- getSolvedDicts - - ; mb_stuff <- runMaybeT $ try_solve_from_instance - (ev_binds, solved_dicts) ev_w - - ; case mb_stuff of - Nothing -> return False - Just (ev_binds', solved_dicts') - -> do { setTcEvBindsMap ev_binds_var ev_binds' - ; setSolvedDicts solved_dicts' - ; return True } } - - | otherwise - = return False - where - -- This `CtLoc` is used only to check the well-staged condition of any - -- candidate DFun. Our subgoals all have the same stage as our root - -- [W] constraint so it is safe to use this while solving them. - loc_w = ctEvLoc ev_w - - try_solve_from_instance -- See Note [Shortcut try_solve_from_instance] - :: (EvBindMap, DictMap CtEvidence) -> CtEvidence - -> MaybeT TcS (EvBindMap, DictMap CtEvidence) - try_solve_from_instance (ev_binds, solved_dicts) ev - | let pred = ctEvPred ev - loc = ctEvLoc ev - , ClassPred cls tys <- classifyPredType pred - = do { inst_res <- lift $ matchGlobalInst dflags True cls tys - ; case inst_res of - OneInst { cir_new_theta = preds - , cir_mk_ev = mk_ev - , cir_what = what } - | safeOverlap what - , all isTyFamFree preds -- Note [Shortcut solving: type families] - -> do { let solved_dicts' = addDict solved_dicts cls tys ev - -- solved_dicts': it is important that we add our goal - -- to the cache before we solve! Otherwise we may end - -- up in a loop while solving recursive dictionaries. - - ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds) - ; loc' <- lift $ checkInstanceOK loc what pred - - ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds - -- Emit work for subgoals but use our local cache - -- so we can solve recursive dictionaries. - - ; let ev_tm = mk_ev (map getEvExpr evc_vs) - ev_binds' = extendEvBinds ev_binds $ - mkWantedEvBind (ctEvEvId ev) ev_tm - - ; foldlM try_solve_from_instance - (ev_binds', solved_dicts') - (freshGoals evc_vs) } - - _ -> mzero } - | otherwise = mzero - - - -- Use a local cache of solved dicts while emitting EvVars for new work - -- We bail out of the entire computation if we need to emit an EvVar for - -- a subgoal that isn't a ClassPred. - new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew - new_wanted_cached loc cache pty - | ClassPred cls tys <- classifyPredType pty - = lift $ case findDict cache loc_w cls tys of - Just ctev -> return $ Cached (ctEvExpr ctev) - Nothing -> Fresh <$> newWantedNC loc pty - | otherwise = mzero - -addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS () --- Add derived constraints from type-class functional dependencies. -addFunDepWork inerts work_ev cls - | isImprovable work_ev - = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls) - -- No need to check flavour; fundeps work between - -- any pair of constraints, regardless of flavour - -- Importantly we don't throw workitem back in the - -- worklist because this can cause loops (see #5236) - | otherwise - = return () - where - work_pred = ctEvPred work_ev - work_loc = ctEvLoc work_ev - - add_fds inert_ct - | isImprovable inert_ev - = do { traceTcS "addFunDepWork" (vcat - [ ppr work_ev - , pprCtLoc work_loc, ppr (isGivenLoc work_loc) - , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc) - , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) ; - - emitFunDepDeriveds $ - improveFromAnother derived_loc inert_pred work_pred - -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok - -- NB: We do create FDs for given to report insoluble equations that arise - -- from pairs of Givens, and also because of floating when we approximate - -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs - } - | otherwise - = return () - where - inert_ev = ctEvidence inert_ct - inert_pred = ctEvPred inert_ev - inert_loc = ctEvLoc inert_ev - derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth` - ctl_depth inert_loc - , ctl_origin = FunDepOrigin1 work_pred - (ctLocOrigin work_loc) - (ctLocSpan work_loc) - inert_pred - (ctLocOrigin inert_loc) - (ctLocSpan inert_loc) } - -{- -********************************************************************** -* * - Implicit parameters -* * -********************************************************************** --} - -interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- Work item is Given (?x:ty) --- See Note [Shadowing of Implicit Parameters] -interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = tys@(ip_str:_) }) - = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem } - ; stopWith ev "Given IP" } - where - dicts = inert_dicts inerts - ip_dicts = findDictsByClass dicts cls - other_ip_dicts = filterBag (not . is_this_ip) ip_dicts - filtered_dicts = addDictsByClass dicts cls other_ip_dicts - - -- Pick out any Given constraints for the same implicit parameter - is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ }) - = isGiven ev && ip_str `tcEqType` ip_str' - is_this_ip _ = False - -interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi) - -{- Note [Shadowing of Implicit Parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example: - -f :: (?x :: Char) => Char -f = let ?x = 'a' in ?x - -The "let ?x = ..." generates an implication constraint of the form: - -?x :: Char => ?x :: Char - -Furthermore, the signature for `f` also generates an implication -constraint, so we end up with the following nested implication: - -?x :: Char => (?x :: Char => ?x :: Char) - -Note that the wanted (?x :: Char) constraint may be solved in -two incompatible ways: either by using the parameter from the -signature, or by using the local definition. Our intention is -that the local definition should "shadow" the parameter of the -signature, and we implement this as follows: when we add a new -*given* implicit parameter to the inert set, it replaces any existing -givens for the same implicit parameter. - -Similarly, consider - f :: (?x::a) => Bool -> a - - g v = let ?x::Int = 3 - in (f v, let ?x::Bool = True in f v) - -This should probably be well typed, with - g :: Bool -> (Int, Bool) - -So the inner binding for ?x::Bool *overrides* the outer one. - -See ticket #17104 for a rather tricky example of this overriding -behaviour. - -All this works for the normal cases but it has an odd side effect in -some pathological programs like this: --- This is accepted, the second parameter shadows -f1 :: (?x :: Int, ?x :: Char) => Char -f1 = ?x - --- This is rejected, the second parameter shadows -f2 :: (?x :: Int, ?x :: Char) => Int -f2 = ?x - -Both of these are actually wrong: when we try to use either one, -we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char), -which would lead to an error. - -I can think of two ways to fix this: - - 1. Simply disallow multiple constraints for the same implicit - parameter---this is never useful, and it can be detected completely - syntactically. - - 2. Move the shadowing machinery to the location where we nest - implications, and add some code here that will produce an - error if we get multiple givens for the same implicit parameter. - - -********************************************************************** -* * - interactFunEq -* * -********************************************************************** --} - -interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- Try interacting the work item with the inert set -interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc - , cc_tyargs = args, cc_fsk = fsk }) - | Just inert_ct@(CFunEqCan { cc_ev = ev_i - , cc_fsk = fsk_i }) - <- findFunEq (inert_funeqs inerts) tc args - , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev - = do { traceTcS "reactFunEq (rewrite inert item):" $ - vcat [ text "work_item =" <+> ppr work_item - , text "inertItem=" <+> ppr ev_i - , text "(swap_flag, upgrade)" <+> ppr pr ] - ; if isSwapped swap_flag - then do { -- Rewrite inert using work-item - let work_item' | upgrade_flag = upgradeWanted work_item - | otherwise = work_item - ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item' - -- Do the updInertFunEqs before the reactFunEq, so that - -- we don't kick out the inertItem as well as consuming it! - ; reactFunEq ev fsk ev_i fsk_i - ; stopWith ev "Work item rewrites inert" } - else do { -- Rewrite work-item using inert - ; when upgrade_flag $ - updInertFunEqs $ \ feqs -> insertFunEq feqs tc args - (upgradeWanted inert_ct) - ; reactFunEq ev_i fsk_i ev fsk - ; stopWith ev "Inert rewrites work item" } } - - | otherwise -- Try improvement - = do { improveLocalFunEqs ev inerts tc args fsk - ; continueWith work_item } - -interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item) - -upgradeWanted :: Ct -> Ct --- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2 --- so upgrade the [W] to [WD] before putting it in the inert set -upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) } - where - upgrade_ev ev = ASSERT2( isWanted ev, ppr ct ) - ev { ctev_nosh = WDeriv } - -improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar - -> TcS () --- Generate derived improvement equalities, by comparing --- the current work item with inert CFunEqs --- E.g. x + y ~ z, x + y' ~ z => [D] y ~ y' --- --- See Note [FunDep and implicit parameter reactions] -improveLocalFunEqs work_ev inerts fam_tc args fsk - | isGiven work_ev -- See Note [No FunEq improvement for Givens] - || not (isImprovable work_ev) - = return () - - | otherwise - = do { eqns <- improvement_eqns - ; if not (null eqns) - then do { traceTcS "interactFunEq improvements: " $ - vcat [ text "Eqns:" <+> ppr eqns - , text "Candidates:" <+> ppr funeqs_for_tc - , text "Inert eqs:" <+> ppr (inert_eqs inerts) ] - ; emitFunDepDeriveds eqns } - else return () } - - where - funeqs = inert_funeqs inerts - funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc - work_loc = ctEvLoc work_ev - work_pred = ctEvPred work_ev - fam_inj_info = tyConInjectivityInfo fam_tc - - -------------------- - improvement_eqns :: TcS [FunDepEqn CtLoc] - improvement_eqns - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = -- Try built-in families, notably for arithmethic - do { rhs <- rewriteTyVar fsk - ; concatMapM (do_one_built_in ops rhs) funeqs_for_tc } - - | Injective injective_args <- fam_inj_info - = -- Try improvement from type families with injectivity annotations - do { rhs <- rewriteTyVar fsk - ; concatMapM (do_one_injective injective_args rhs) funeqs_for_tc } - - | otherwise - = return [] - - -------------------- - do_one_built_in ops rhs (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev }) - = do { inert_rhs <- rewriteTyVar ifsk - ; return $ mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs inert_rhs) } - - do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) - - -------------------- - -- See Note [Type inference for type families with injectivity] - do_one_injective inj_args rhs (CFunEqCan { cc_tyargs = inert_args - , cc_fsk = ifsk, cc_ev = inert_ev }) - | isImprovable inert_ev - = do { inert_rhs <- rewriteTyVar ifsk - ; return $ if rhs `tcEqType` inert_rhs - then mk_fd_eqns inert_ev $ - [ Pair arg iarg - | (arg, iarg, True) <- zip3 args inert_args inj_args ] - else [] } - | otherwise - = return [] - - do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) - - -------------------- - mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc] - mk_fd_eqns inert_ev eqns - | null eqns = [] - | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns - , fd_pred1 = work_pred - , fd_pred2 = ctEvPred inert_ev - , fd_loc = loc } ] - where - inert_loc = ctEvLoc inert_ev - loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` - ctl_depth work_loc } - -------------- -reactFunEq :: CtEvidence -> TcTyVar -- From this :: F args1 ~ fsk1 - -> CtEvidence -> TcTyVar -- Solve this :: F args2 ~ fsk2 - -> TcS () -reactFunEq from_this fsk1 solve_this fsk2 - = do { traceTcS "reactFunEq" - (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2]) - ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1) - ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$ - ppr solve_this $$ ppr fsk2) } - -{- Note [Type inference for type families with injectivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a type family with an injectivity annotation: - type family F a b = r | r -> b - -Then if we have two CFunEqCan constraints for F with the same RHS - F s1 t1 ~ rhs - F s2 t2 ~ rhs -then we can use the injectivity to get a new Derived constraint on -the injective argument - [D] t1 ~ t2 - -That in turn can help GHC solve constraints that would otherwise require -guessing. For example, consider the ambiguity check for - f :: F Int b -> Int -We get the constraint - [W] F Int b ~ F Int beta -where beta is a unification variable. Injectivity lets us pick beta ~ b. - -Injectivity information is also used at the call sites. For example: - g = f True -gives rise to - [W] F Int b ~ Bool -from which we can derive b. This requires looking at the defining equations of -a type family, ie. finding equation with a matching RHS (Bool in this example) -and inferring values of type variables (b in this example) from the LHS patterns -of the matching equation. For closed type families we have to perform -additional apartness check for the selected equation to check that the selected -is guaranteed to fire for given LHS arguments. - -These new constraints are simply *Derived* constraints; they have no evidence. -We could go further and offer evidence from decomposing injective type-function -applications, but that would require new evidence forms, and an extension to -FC, so we don't do that right now (Dec 14). - -See also Note [Injective type families] in GHC.Core.TyCon - - -Note [Cache-caused loops] -~~~~~~~~~~~~~~~~~~~~~~~~~ -It is very dangerous to cache a rewritten wanted family equation as 'solved' in our -solved cache (which is the default behaviour or xCtEvidence), because the interaction -may not be contributing towards a solution. Here is an example: - -Initial inert set: - [W] g1 : F a ~ beta1 -Work item: - [W] g2 : F a ~ beta2 -The work item will react with the inert yielding the _same_ inert set plus: - (i) Will set g2 := g1 `cast` g3 - (ii) Will add to our solved cache that [S] g2 : F a ~ beta2 - (iii) Will emit [W] g3 : beta1 ~ beta2 -Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 -and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it -will set - g1 := g ; sym g3 -and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but -remember that we have this in our solved cache, and it is ... g2! In short we -created the evidence loop: - - g2 := g1 ; g3 - g3 := refl - g1 := g2 ; sym g3 - -To avoid this situation we do not cache as solved any workitems (or inert) -which did not really made a 'step' towards proving some goal. Solved's are -just an optimization so we don't lose anything in terms of completeness of -solving. - - -Note [Efficient Orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are interacting two FunEqCans with the same LHS: - (inert) ci :: (F ty ~ xi_i) - (work) cw :: (F ty ~ xi_w) -We prefer to keep the inert (else we pass the work item on down -the pipeline, which is a bit silly). If we keep the inert, we -will (a) discharge 'cw' - (b) produce a new equality work-item (xi_w ~ xi_i) -Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w): - new_work :: xi_w ~ xi_i - cw := ci ; sym new_work -Why? Consider the simplest case when xi1 is a type variable. If -we generate xi1~xi2, processing that constraint will kick out 'ci'. -If we generate xi2~xi1, there is less chance of that happening. -Of course it can and should still happen if xi1=a, xi1=Int, say. -But we want to avoid it happening needlessly. - -Similarly, if we *can't* keep the inert item (because inert is Wanted, -and work is Given, say), we prefer to orient the new equality (xi_i ~ -xi_w). - -Note [Carefully solve the right CFunEqCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ---- OLD COMMENT, NOW NOT NEEDED - ---- because we now allow multiple - ---- wanted FunEqs with the same head -Consider the constraints - c1 :: F Int ~ a -- Arising from an application line 5 - c2 :: F Int ~ Bool -- Arising from an application line 10 -Suppose that 'a' is a unification variable, arising only from -flattening. So there is no error on line 5; it's just a flattening -variable. But there is (or might be) an error on line 10. - -Two ways to combine them, leaving either (Plan A) - c1 :: F Int ~ a -- Arising from an application line 5 - c3 :: a ~ Bool -- Arising from an application line 10 -or (Plan B) - c2 :: F Int ~ Bool -- Arising from an application line 10 - c4 :: a ~ Bool -- Arising from an application line 5 - -Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error -on the *totally innocent* line 5. An example is test SimpleFail16 -where the expected/actual message comes out backwards if we use -the wrong plan. - -The second is the right thing to do. Hence the isMetaTyVarTy -test when solving pairwise CFunEqCan. - - -********************************************************************** -* * - interactTyVarEq -* * -********************************************************************** --} - -inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole - -> Maybe ( CtEvidence -- The evidence for the inert - , SwapFlag -- Whether we need mkSymCo - , Bool) -- True <=> keep a [D] version - -- of the [WD] constraint -inertsCanDischarge inerts tv rhs fr - | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i - , cc_eq_rel = eq_rel } - <- findTyEqs inerts tv - , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr - , rhs_i `tcEqType` rhs ] - = -- Inert: a ~ ty - -- Work item: a ~ ty - Just (ev_i, NotSwapped, keep_deriv ev_i) - - | Just tv_rhs <- getTyVar_maybe rhs - , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i - , cc_eq_rel = eq_rel } - <- findTyEqs inerts tv_rhs - , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr - , rhs_i `tcEqType` mkTyVarTy tv ] - = -- Inert: a ~ b - -- Work item: b ~ a - Just (ev_i, IsSwapped, keep_deriv ev_i) - - | otherwise - = Nothing - - where - keep_deriv ev_i - | Wanted WOnly <- ctEvFlavour ev_i -- inert is [W] - , (Wanted WDeriv, _) <- fr -- work item is [WD] - = True -- Keep a derived version of the work item - | otherwise - = False -- Work item is fully discharged - -interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- CTyEqCans are always consumed, so always returns Stop -interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv - , cc_rhs = rhs - , cc_ev = ev - , cc_eq_rel = eq_rel }) - | Just (ev_i, swapped, keep_deriv) - <- inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel) - = do { setEvBindIfWanted ev $ - evCoercion (maybeSym swapped $ - tcDowngradeRole (eqRelRole eq_rel) - (ctEvRole ev_i) - (ctEvCoercion ev_i)) - - ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev - , ctev_loc = ctEvLoc ev } - ; when keep_deriv $ - emitWork [workItem { cc_ev = deriv_ev }] - -- As a Derived it might not be fully rewritten, - -- so we emit it as new work - - ; stopWith ev "Solved from inert" } - - | ReprEq <- eq_rel -- See Note [Do not unify representational equalities] - = do { traceTcS "Not unifying representational equality" (ppr workItem) - ; continueWith workItem } - - | isGiven ev -- See Note [Touchables and givens] - = continueWith workItem - - | otherwise - = do { tclvl <- getTcLevel - ; if canSolveByUnification tclvl tv rhs - then do { solveByUnification ev tv rhs - ; n_kicked <- kickOutAfterUnification tv - ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) } - - else continueWith workItem } - -interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi) - -solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () --- Solve with the identity coercion --- Precondition: kind(xi) equals kind(tv) --- Precondition: CtEvidence is Wanted or Derived --- Precondition: CtEvidence is nominal --- Returns: workItem where --- workItem = the new Given constraint --- --- NB: No need for an occurs check here, because solveByUnification always --- arises from a CTyEqCan, a *canonical* constraint. Its invariant (TyEq:OC) --- says that in (a ~ xi), the type variable a does not appear in xi. --- See Constraint.Ct invariants. --- --- Post: tv is unified (by side effect) with xi; --- we often write tv := xi -solveByUnification wd tv xi - = do { let tv_ty = mkTyVarTy tv - ; traceTcS "Sneaky unification:" $ - vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi, - text "Coercion:" <+> pprEq tv_ty xi, - text "Left Kind is:" <+> ppr (tcTypeKind tv_ty), - text "Right Kind is:" <+> ppr (tcTypeKind xi) ] - - ; unifyTyVar tv xi - ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) } - -{- Note [Avoid double unifications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The spontaneous solver has to return a given which mentions the unified unification -variable *on the left* of the equality. Here is what happens if not: - Original wanted: (a ~ alpha), (alpha ~ Int) -We spontaneously solve the first wanted, without changing the order! - given : a ~ alpha [having unified alpha := a] -Now the second wanted comes along, but he cannot rewrite the given, so we simply continue. -At the end we spontaneously solve that guy, *reunifying* [alpha := Int] - -We avoid this problem by orienting the resulting given so that the unification -variable is on the left. [Note that alternatively we could attempt to -enforce this at canonicalization] - -See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding -double unifications is the main reason we disallow touchable -unification variables as RHS of type family equations: F xis ~ alpha. - -Note [Do not unify representational equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [W] alpha ~R# b -where alpha is touchable. Should we unify alpha := b? - -Certainly not! Unifying forces alpha and be to be the same; but they -only need to be representationally equal types. - -For example, we might have another constraint [W] alpha ~# N b -where - newtype N b = MkN b -and we want to get alpha := N b. - -See also #15144, which was caused by unifying a representational -equality (in the unflattener). - - -************************************************************************ -* * -* Functional dependencies, instantiation of equations -* * -************************************************************************ - -When we spot an equality arising from a functional dependency, -we now use that equality (a "wanted") to rewrite the work-item -constraint right away. This avoids two dangers - - Danger 1: If we send the original constraint on down the pipeline - it may react with an instance declaration, and in delicate - situations (when a Given overlaps with an instance) that - may produce new insoluble goals: see #4952 - - Danger 2: If we don't rewrite the constraint, it may re-react - with the same thing later, and produce the same equality - again --> termination worries. - -To achieve this required some refactoring of FunDeps.hs (nicer -now!). - -Note [FunDep and implicit parameter reactions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Currently, our story of interacting two dictionaries (or a dictionary -and top-level instances) for functional dependencies, and implicit -parameters, is that we simply produce new Derived equalities. So for example - - class D a b | a -> b where ... - Inert: - d1 :g D Int Bool - WorkItem: - d2 :w D Int alpha - - We generate the extra work item - cv :d alpha ~ Bool - where 'cv' is currently unused. However, this new item can perhaps be - spontaneously solved to become given and react with d2, - discharging it in favour of a new constraint d2' thus: - d2' :w D Int Bool - d2 := d2' |> D Int cv - Now d2' can be discharged from d1 - -We could be more aggressive and try to *immediately* solve the dictionary -using those extra equalities, but that requires those equalities to carry -evidence and derived do not carry evidence. - -If that were the case with the same inert set and work item we might dischard -d2 directly: - - cv :w alpha ~ Bool - d2 := d1 |> D Int cv - -But in general it's a bit painful to figure out the necessary coercion, -so we just take the first approach. Here is a better example. Consider: - class C a b c | a -> b -And: - [Given] d1 : C T Int Char - [Wanted] d2 : C T beta Int -In this case, it's *not even possible* to solve the wanted immediately. -So we should simply output the functional dependency and add this guy -[but NOT its superclasses] back in the worklist. Even worse: - [Given] d1 : C T Int beta - [Wanted] d2: C T beta Int -Then it is solvable, but its very hard to detect this on the spot. - -It's exactly the same with implicit parameters, except that the -"aggressive" approach would be much easier to implement. - -Note [Weird fundeps] -~~~~~~~~~~~~~~~~~~~~ -Consider class Het a b | a -> b where - het :: m (f c) -> a -> m b - - class GHet (a :: * -> *) (b :: * -> *) | a -> b - instance GHet (K a) (K [a]) - instance Het a b => GHet (K a) (K b) - -The two instances don't actually conflict on their fundeps, -although it's pretty strange. So they are both accepted. Now -try [W] GHet (K Int) (K Bool) -This triggers fundeps from both instance decls; - [D] K Bool ~ K [a] - [D] K Bool ~ K beta -And there's a risk of complaining about Bool ~ [a]. But in fact -the Wanted matches the second instance, so we never get as far -as the fundeps. - -#7875 is a case in point. --} - -emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS () --- See Note [FunDep and implicit parameter reactions] -emitFunDepDeriveds fd_eqns - = mapM_ do_one_FDEqn fd_eqns - where - do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc }) - | null tvs -- Common shortcut - = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc)) - ; mapM_ (unifyDerived loc Nominal) eqs } - | otherwise - = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs) - ; subst <- instFlexi tvs -- Takes account of kind substitution - ; mapM_ (do_one_eq loc subst) eqs } - - do_one_eq loc subst (Pair ty1 ty2) - = unifyDerived loc Nominal $ - Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2) - -{- -********************************************************************** -* * - The top-reaction Stage -* * -********************************************************************** --} - -topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) --- The work item does not react with the inert set, --- so try interaction with top-level instances. Note: -topReactionsStage work_item - = do { traceTcS "doTopReact" (ppr work_item) - ; case work_item of - CDictCan {} -> do { inerts <- getTcSInerts - ; doTopReactDict inerts work_item } - CFunEqCan {} -> doTopReactFunEq work_item - CIrredCan {} -> doTopReactOther work_item - CTyEqCan {} -> doTopReactOther work_item - _ -> -- Any other work item does not react with any top-level equations - continueWith work_item } - - --------------------- -doTopReactOther :: Ct -> TcS (StopOrContinue Ct) --- Try local quantified constraints for --- CTyEqCan e.g. (a ~# ty) --- and CIrredCan e.g. (c a) --- --- Why equalities? See TcCanonical --- Note [Equality superclasses in quantified constraints] -doTopReactOther work_item - | isGiven ev - = continueWith work_item - - | EqPred eq_rel t1 t2 <- classifyPredType pred - = doTopReactEqPred work_item eq_rel t1 t2 - - | otherwise - = do { res <- matchLocalInst pred loc - ; case res of - OneInst {} -> chooseInstance work_item res - _ -> continueWith work_item } - - where - ev = ctEvidence work_item - loc = ctEvLoc ev - pred = ctEvPred ev - -doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) -doTopReactEqPred work_item eq_rel t1 t2 - -- See Note [Looking up primitive equalities in quantified constraints] - | Just (cls, tys) <- boxEqPred eq_rel t1 t2 - = do { res <- matchLocalInst (mkClassPred cls tys) loc - ; case res of - OneInst { cir_mk_ev = mk_ev } - -> chooseInstance work_item - (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) - _ -> continueWith work_item } - - | otherwise - = continueWith work_item - where - ev = ctEvidence work_item - loc = ctEvLoc ev - - mk_eq_ev cls tys mk_ev evs - = case (mk_ev evs) of - EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e) - ev -> pprPanic "mk_eq_ev" (ppr ev) - where - [sc_id] = classSCSelIds cls - -{- Note [Looking up primitive equalities in quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For equalities (a ~# b) look up (a ~ b), and then do a superclass -selection. This avoids having to support quantified constraints whose -kind is not Constraint, such as (forall a. F a ~# b) - -See - * Note [Evidence for quantified constraints] in GHC.Core.Predicate - * Note [Equality superclasses in quantified constraints] - in TcCanonical - -Note [Flatten when discharging CFunEqCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have the following scenario (#16512): - -type family LV (as :: [Type]) (b :: Type) = (r :: Type) | r -> as b where - LV (a ': as) b = a -> LV as b - -[WD] w1 :: LV as0 (a -> b) ~ fmv1 (CFunEqCan) -[WD] w2 :: fmv1 ~ (a -> fmv2) (CTyEqCan) -[WD] w3 :: LV as0 b ~ fmv2 (CFunEqCan) - -We start with w1. Because LV is injective, we wish to see if the RHS of the -equation matches the RHS of the CFunEqCan. The RHS of a CFunEqCan is always an -fmv, so we "look through" to get (a -> fmv2). Then we run tcUnifyTyWithTFs. -That performs the match, but it allows a type family application (such as the -LV in the RHS of the equation) to match with anything. (See "Injective type -families" by Stolarek et al., HS'15, Fig. 2) The matching succeeds, which -means we can improve as0 (and b, but that's not interesting here). However, -because the RHS of w1 can't see through fmv2 (we have no way of looking up a -LHS of a CFunEqCan from its RHS, and this use case isn't compelling enough), -we invent a new unification variable here. We thus get (as0 := a : as1). -Rewriting: - -[WD] w1 :: LV (a : as1) (a -> b) ~ fmv1 -[WD] w2 :: fmv1 ~ (a -> fmv2) -[WD] w3 :: LV (a : as1) b ~ fmv2 - -We can now reduce both CFunEqCans, using the equation for LV. We get - -[WD] w2 :: (a -> LV as1 (a -> b)) ~ (a -> a -> LV as1 b) - -Now we decompose (and flatten) to - -[WD] w4 :: LV as1 (a -> b) ~ fmv3 -[WD] w5 :: fmv3 ~ (a -> fmv1) -[WD] w6 :: LV as1 b ~ fmv4 - -which is exactly where we started. These goals really are insoluble, but -we would prefer not to loop. We thus need to find a way to bump the reduction -depth, so that we can detect the loop and abort. - -The key observation is that we are performing a reduction. We thus wish -to bump the level when discharging a CFunEqCan. Where does this bumped -level go, though? It can't just go on the reduct, as that's a type. Instead, -it must go on any CFunEqCans produced after flattening. We thus flatten -when discharging, making sure that the level is bumped in the new -fun-eqs. The flattening happens in reduce_top_fun_eq and the level -is bumped when setting up the FlatM monad in TcFlatten.runFlatten. -(This bumping will happen for call sites other than this one, but that -makes sense -- any constraints emitted by the flattener are offshoots -the work item and should have a higher level. We don't have any test -cases that require the bumping in this other cases, but it's convenient -and causes no harm to bump at every flatten.) - -Test case: typecheck/should_fail/T16512a - --} - --------------------- -doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct) -doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc - , cc_tyargs = args, cc_fsk = fsk }) - - | fsk `elemVarSet` tyCoVarsOfTypes args - = no_reduction -- See Note [FunEq occurs-check principle] - - | otherwise -- Note [Reduction for Derived CFunEqCans] - = do { match_res <- matchFam fam_tc args - -- Look up in top-level instances, or built-in axiom - -- See Note [MATCHING-SYNONYMS] - ; case match_res of - Nothing -> no_reduction - Just match_info -> reduce_top_fun_eq old_ev fsk match_info } - where - no_reduction - = do { improveTopFunEqs old_ev fam_tc args fsk - ; continueWith work_item } - -doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w) - -reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType) - -> TcS (StopOrContinue Ct) --- We have found an applicable top-level axiom: use it to reduce --- Precondition: fsk is not free in rhs_ty --- ax_co :: F tys ~ rhs_ty, where F tys is the LHS of the old_ev -reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty) - | not (isDerived old_ev) -- Precondition of shortCutReduction - , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty - , isTypeFamilyTyCon tc - , tc_args `lengthIs` tyConArity tc -- Short-cut - = -- RHS is another type-family application - -- Try shortcut; see Note [Top-level reductions for type functions] - do { shortCutReduction old_ev fsk ax_co tc tc_args - ; stopWith old_ev "Fun/Top (shortcut)" } - - | otherwise - = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty) - , ppr old_ev $$ ppr rhs_ty ) - -- Guaranteed by Note [FunEq occurs-check principle] - do { (rhs_xi, flatten_co) <- flatten FM_FlattenAll old_ev rhs_ty - -- flatten_co :: rhs_xi ~ rhs_ty - -- See Note [Flatten when discharging CFunEqCan] - ; let total_co = ax_co `mkTcTransCo` mkTcSymCo flatten_co - ; dischargeFunEq old_ev fsk total_co rhs_xi - ; traceTcS "doTopReactFunEq" $ - vcat [ text "old_ev:" <+> ppr old_ev - , nest 2 (text ":=") <+> ppr ax_co ] - ; stopWith old_ev "Fun/Top" } - -improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS () --- See Note [FunDep and implicit parameter reactions] -improveTopFunEqs ev fam_tc args fsk - | isGiven ev -- See Note [No FunEq improvement for Givens] - || not (isImprovable ev) - = return () - - | otherwise - = do { fam_envs <- getFamInstEnvs - ; rhs <- rewriteTyVar fsk - ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs - ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs - , ppr eqns ]) - ; mapM_ (unifyDerived loc Nominal) eqns } - where - loc = bumpCtLocDepth (ctEvLoc ev) - -- ToDo: this location is wrong; it should be FunDepOrigin2 - -- See #14778 - -improve_top_fun_eqs :: FamInstEnvs - -> TyCon -> [TcType] -> TcType - -> TcS [TypeEqn] -improve_top_fun_eqs fam_envs fam_tc args rhs_ty - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = return (sfInteractTop ops args rhs_ty) - - -- see Note [Type inference for type families with injectivity] - | isOpenTypeFamilyTyCon fam_tc - , Injective injective_args <- tyConInjectivityInfo fam_tc - , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc - = -- it is possible to have several compatible equations in an open type - -- family but we only want to derive equalities from one such equation. - do { let improvs = buildImprovementData fam_insts - fi_tvs fi_tys fi_rhs (const Nothing) - - ; traceTcS "improve_top_fun_eqs2" (ppr improvs) - ; concatMapM (injImproveEqns injective_args) $ - take 1 improvs } - - | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc - , Injective injective_args <- tyConInjectivityInfo fam_tc - = concatMapM (injImproveEqns injective_args) $ - buildImprovementData (fromBranches (co_ax_branches ax)) - cab_tvs cab_lhs cab_rhs Just - - | otherwise - = return [] - - where - buildImprovementData - :: [a] -- axioms for a TF (FamInst or CoAxBranch) - -> (a -> [TyVar]) -- get bound tyvars of an axiom - -> (a -> [Type]) -- get LHS of an axiom - -> (a -> Type) -- get RHS of an axiom - -> (a -> Maybe CoAxBranch) -- Just => apartness check required - -> [( [Type], TCvSubst, [TyVar], Maybe CoAxBranch )] - -- Result: - -- ( [arguments of a matching axiom] - -- , RHS-unifying substitution - -- , axiom variables without substitution - -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] ) - buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap = - [ (ax_args, subst, unsubstTvs, wrap axiom) - | axiom <- axioms - , let ax_args = axiomLHS axiom - ax_rhs = axiomRHS axiom - ax_tvs = axiomTVs axiom - , Just subst <- [tcUnifyTyWithTFs False ax_rhs rhs_ty] - , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst) - unsubstTvs = filter (notInSubst <&&> isTyVar) ax_tvs ] - -- The order of unsubstTvs is important; it must be - -- in telescope order e.g. (k:*) (a:k) - - injImproveEqns :: [Bool] - -> ([Type], TCvSubst, [TyCoVar], Maybe CoAxBranch) - -> TcS [TypeEqn] - injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr) - = do { subst <- instFlexiX subst unsubstTvs - -- If the current substitution bind [k -> *], and - -- one of the un-substituted tyvars is (a::k), we'd better - -- be sure to apply the current substitution to a's kind. - -- Hence instFlexiX. #13135 was an example. - - ; return [ Pair (substTyUnchecked subst ax_arg) arg - -- NB: the ax_arg part is on the left - -- see Note [Improvement orientation] - | case cabr of - Just cabr' -> apartnessCheck (substTys subst ax_args) cabr' - _ -> True - , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] } - - -shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion - -> TyCon -> [TcType] -> TcS () --- See Note [Top-level reductions for type functions] --- Previously, we flattened the tc_args here, but there's no need to do so. --- And, if we did, this function would have all the complication of --- TcCanonical.canCFunEqCan. See Note [canCFunEqCan] -shortCutReduction old_ev fsk ax_co fam_tc tc_args - = ASSERT( ctEvEqRel old_ev == NomEq) - -- ax_co :: F args ~ G tc_args - -- old_ev :: F args ~ fsk - do { new_ev <- case ctEvFlavour old_ev of - Given -> newGivenEvVar deeper_loc - ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk) - , evCoercion (mkTcSymCo ax_co - `mkTcTransCo` ctEvCoercion old_ev) ) - - Wanted {} -> - -- See TcCanonical Note [Equalities with incompatible kinds] about NoBlockSubst - do { (new_ev, new_co) <- newWantedEq_SI NoBlockSubst WDeriv deeper_loc Nominal - (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk) - ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co - ; return new_ev } - - Derived -> pprPanic "shortCutReduction" (ppr old_ev) - - ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc - , cc_tyargs = tc_args, cc_fsk = fsk } - ; updWorkListTcS (extendWorkListFunEq new_ct) } - where - deeper_loc = bumpCtLocDepth (ctEvLoc old_ev) - -{- Note [Top-level reductions for type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -c.f. Note [The flattening story] in TcFlatten - -Suppose we have a CFunEqCan F tys ~ fmv/fsk, and a matching axiom. -Here is what we do, in four cases: - -* Wanteds: general firing rule - (work item) [W] x : F tys ~ fmv - instantiate axiom: ax_co : F tys ~ rhs - - Then: - Discharge fmv := rhs - Discharge x := ax_co ; sym x2 - This is *the* way that fmv's get unified; even though they are - "untouchable". - - NB: Given Note [FunEq occurs-check principle], fmv does not appear - in tys, and hence does not appear in the instantiated RHS. So - the unification can't make an infinite type. - -* Wanteds: short cut firing rule - Applies when the RHS of the axiom is another type-function application - (work item) [W] x : F tys ~ fmv - instantiate axiom: ax_co : F tys ~ G rhs_tys - - It would be a waste to create yet another fmv for (G rhs_tys). - Instead (shortCutReduction): - - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis) - - Add G rhs_xis ~ fmv to flat cache (note: the same old fmv) - - New canonical wanted [W] x2 : G rhs_xis ~ fmv (CFunEqCan) - - Discharge x := ax_co ; G cos ; x2 - -* Givens: general firing rule - (work item) [G] g : F tys ~ fsk - instantiate axiom: ax_co : F tys ~ rhs - - Now add non-canonical given (since rhs is not flat) - [G] (sym g ; ax_co) : fsk ~ rhs (Non-canonical) - -* Givens: short cut firing rule - Applies when the RHS of the axiom is another type-function application - (work item) [G] g : F tys ~ fsk - instantiate axiom: ax_co : F tys ~ G rhs_tys - - It would be a waste to create yet another fsk for (G rhs_tys). - Instead (shortCutReduction): - - Flatten rhs_tys: flat_cos : tys ~ flat_tys - - Add new Canonical given - [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk (CFunEqCan) - -Note [FunEq occurs-check principle] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I have spent a lot of time finding a good way to deal with -CFunEqCan constraints like - F (fuv, a) ~ fuv -where flatten-skolem occurs on the LHS. Now in principle we -might may progress by doing a reduction, but in practice its -hard to find examples where it is useful, and easy to find examples -where we fall into an infinite reduction loop. A rule that works -very well is this: - - *** FunEq occurs-check principle *** - - Do not reduce a CFunEqCan - F tys ~ fsk - if fsk appears free in tys - Instead we treat it as stuck. - -Examples: - -* #5837 has [G] a ~ TF (a,Int), with an instance - type instance TF (a,b) = (TF a, TF b) - This readily loops when solving givens. But with the FunEq occurs - check principle, it rapidly gets stuck which is fine. - -* #12444 is a good example, explained in comment:2. We have - type instance F (Succ x) = Succ (F x) - [W] alpha ~ Succ (F alpha) - If we allow the reduction to happen, we get an infinite loop - -Note [Cached solved FunEqs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When trying to solve, say (FunExpensive big-type ~ ty), it's important -to see if we have reduced (FunExpensive big-type) before, lest we -simply repeat it. Hence the lookup in inert_solved_funeqs. Moreover -we must use `funEqCanDischarge` because both uses might (say) be Wanteds, -and we *still* want to save the re-computation. - -Note [MATCHING-SYNONYMS] -~~~~~~~~~~~~~~~~~~~~~~~~ -When trying to match a dictionary (D tau) to a top-level instance, or a -type family equation (F taus_1 ~ tau_2) to a top-level family instance, -we do *not* need to expand type synonyms because the matcher will do that for us. - -Note [Improvement orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A very delicate point is the orientation of derived equalities -arising from injectivity improvement (#12522). Suppose we have - type family F x = t | t -> x - type instance F (a, Int) = (Int, G a) -where G is injective; and wanted constraints - - [W] TF (alpha, beta) ~ fuv - [W] fuv ~ (Int, <some type>) - -The injectivity will give rise to derived constraints - - [D] gamma1 ~ alpha - [D] Int ~ beta - -The fresh unification variable gamma1 comes from the fact that we -can only do "partial improvement" here; see Section 5.2 of -"Injective type families for Haskell" (HS'15). - -Now, it's very important to orient the equations this way round, -so that the fresh unification variable will be eliminated in -favour of alpha. If we instead had - [D] alpha ~ gamma1 -then we would unify alpha := gamma1; and kick out the wanted -constraint. But when we grough it back in, it'd look like - [W] TF (gamma1, beta) ~ fuv -and exactly the same thing would happen again! Infinite loop. - -This all seems fragile, and it might seem more robust to avoid -introducing gamma1 in the first place, in the case where the -actual argument (alpha, beta) partly matches the improvement -template. But that's a bit tricky, esp when we remember that the -kinds much match too; so it's easier to let the normal machinery -handle it. Instead we are careful to orient the new derived -equality with the template on the left. Delicate, but it works. - -Note [No FunEq improvement for Givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't do improvements (injectivity etc) for Givens. Why? - -* It generates Derived constraints on skolems, which don't do us - much good, except perhaps identify inaccessible branches. - (They'd be perfectly valid though.) - -* For type-nat stuff the derived constraints include type families; - e.g. (a < b), (b < c) ==> a < c If we generate a Derived for this, - we'll generate a Derived/Wanted CFunEqCan; and, since the same - InertCans (after solving Givens) are used for each iteration, that - massively confused the unflattening step (TcFlatten.unflatten). - - In fact it led to some infinite loops: - indexed-types/should_compile/T10806 - indexed-types/should_compile/T10507 - polykinds/T10742 - -Note [Reduction for Derived CFunEqCans] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You may wonder if it's important to use top-level instances to -simplify [D] CFunEqCan's. But it is. Here's an example (T10226). - - type instance F Int = Int - type instance FInv Int = Int - -Suppose we have to solve - [WD] FInv (F alpha) ~ alpha - [WD] F alpha ~ Int - - --> flatten - [WD] F alpha ~ fuv0 - [WD] FInv fuv0 ~ fuv1 -- (A) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int -- (B) - - --> Rewwrite (A) with (B), splitting it - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] FInv Int ~ fuv1 -- (C) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int - - --> Reduce (C) with top-level instance - **** This is the key step *** - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] fuv1 ~ Int -- (D) - [WD] fuv1 ~ alpha -- (E) - [WD] fuv0 ~ Int - - --> Rewrite (D) with (E) - [WD] F alpha ~ fuv0 - [W] FInv fuv0 ~ fuv1 - [D] alpha ~ Int -- (F) - [WD] fuv1 ~ alpha - [WD] fuv0 ~ Int - - --> unify (F) alpha := Int, and that solves it - -Another example is indexed-types/should_compile/T10634 --} - -{- ******************************************************************* -* * - Top-level reaction for class constraints (CDictCan) -* * -**********************************************************************-} - -doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct) --- Try to use type-class instance declarations to simplify the constraint -doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = xis }) - | isGiven ev -- Never use instances for Given constraints - = do { try_fundep_improvement - ; continueWith work_item } - - | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis -- Cached - = do { setEvBindIfWanted ev (ctEvTerm solved_ev) - ; stopWith ev "Dict/Top (cached)" } - - | otherwise -- Wanted or Derived, but not cached - = do { dflags <- getDynFlags - ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc - ; case lkup_res of - OneInst { cir_what = what } - -> do { insertSafeOverlapFailureTcS what work_item - ; addSolvedDict what ev cls xis - ; chooseInstance work_item lkup_res } - _ -> -- NoInstance or NotSure - do { when (isImprovable ev) $ - try_fundep_improvement - ; continueWith work_item } } - where - dict_pred = mkClassPred cls xis - dict_loc = ctEvLoc ev - dict_origin = ctLocOrigin dict_loc - - -- We didn't solve it; so try functional dependencies with - -- the instance environment, and return - -- See also Note [Weird fundeps] - try_fundep_improvement - = do { traceTcS "try_fundeps" (ppr work_item) - ; instEnvs <- getInstEnvs - ; emitFunDepDeriveds $ - improveFromInstEnv instEnvs mk_ct_loc dict_pred } - - mk_ct_loc :: PredType -- From instance decl - -> SrcSpan -- also from instance deol - -> CtLoc - mk_ct_loc inst_pred inst_loc - = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin - inst_pred inst_loc } - -doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) - - -chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct) -chooseInstance work_item - (OneInst { cir_new_theta = theta - , cir_what = what - , cir_mk_ev = mk_ev }) - = do { traceTcS "doTopReact/found instance for" $ ppr ev - ; deeper_loc <- checkInstanceOK loc what pred - ; if isDerived ev then finish_derived deeper_loc theta - else finish_wanted deeper_loc theta mk_ev } - where - ev = ctEvidence work_item - pred = ctEvPred ev - loc = ctEvLoc ev - - finish_wanted :: CtLoc -> [TcPredType] - -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct) - -- Precondition: evidence term matches the predicate workItem - finish_wanted loc theta mk_ev - = do { evb <- getTcEvBindsVar - ; if isCoEvBindsVar evb - then -- See Note [Instances in no-evidence implications] - continueWith work_item - else - do { evc_vars <- mapM (newWanted loc) theta - ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars)) - ; emitWorkNC (freshGoals evc_vars) - ; stopWith ev "Dict/Top (solved wanted)" } } - - finish_derived loc theta - = -- Use type-class instances for Deriveds, in the hope - -- of generating some improvements - -- C.f. Example 3 of Note [The improvement story] - -- It's easy because no evidence is involved - do { emitNewDeriveds loc theta - ; traceTcS "finish_derived" (ppr (ctl_depth loc)) - ; stopWith ev "Dict/Top (solved derived)" } - -chooseInstance work_item lookup_res - = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res) - -checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc --- Check that it's OK to use this insstance: --- (a) the use is well staged in the Template Haskell sense --- (b) we have not recursed too deep --- Returns the CtLoc to used for sub-goals -checkInstanceOK loc what pred - = do { checkWellStagedDFun loc what pred - ; checkReductionDepth deeper_loc pred - ; return deeper_loc } - where - deeper_loc = zap_origin (bumpCtLocDepth loc) - origin = ctLocOrigin loc - - zap_origin loc -- After applying an instance we can set ScOrigin to - -- infinity, so that prohibitedSuperClassSolve never fires - | ScOrigin {} <- origin - = setCtLocOrigin loc (ScOrigin infinity) - | otherwise - = loc - -{- Note [Instances in no-evidence implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #15290 we had - [G] forall p q. Coercible p q => Coercible (m p) (m q)) - [W] forall <no-ev> a. m (Int, IntStateT m a) - ~R# - m (Int, StateT Int m a) - -The Given is an ordinary quantified constraint; the Wanted is an implication -equality that arises from - [W] (forall a. t1) ~R# (forall a. t2) - -But because the (t1 ~R# t2) is solved "inside a type" (under that forall a) -we can't generate any term evidence. So we can't actually use that -lovely quantified constraint. Alas! - -This test arranges to ignore the instance-based solution under these -(rare) circumstances. It's sad, but I really don't see what else we can do. --} - - -matchClassInst :: DynFlags -> InertSet - -> Class -> [Type] - -> CtLoc -> TcS ClsInstResult -matchClassInst dflags inerts clas tys loc --- First check whether there is an in-scope Given that could --- match this constraint. In that case, do not use any instance --- whether top level, or local quantified constraints. --- ee Note [Instance and Given overlap] - | not (xopt LangExt.IncoherentInstances dflags) - , not (naturallyCoherentClass clas) - , let matchable_givens = matchableGivens loc pred inerts - , not (isEmptyBag matchable_givens) - = do { traceTcS "Delaying instance application" $ - vcat [ text "Work item=" <+> pprClassPred clas tys - , text "Potential matching givens:" <+> ppr matchable_givens ] - ; return NotSure } - - | otherwise - = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{' - ; local_res <- matchLocalInst pred loc - ; case local_res of - OneInst {} -> -- See Note [Local instances and incoherence] - do { traceTcS "} matchClassInst local match" $ ppr local_res - ; return local_res } - - NotSure -> -- In the NotSure case for local instances - -- we don't want to try global instances - do { traceTcS "} matchClassInst local not sure" empty - ; return local_res } - - NoInstance -- No local instances, so try global ones - -> do { global_res <- matchGlobalInst dflags False clas tys - ; traceTcS "} matchClassInst global result" $ ppr global_res - ; return global_res } } - where - pred = mkClassPred clas tys - --- | If a class is "naturally coherent", then we needn't worry at all, in any --- way, about overlapping/incoherent instances. Just solve the thing! --- See Note [Naturally coherent classes] --- See also Note [The equality class story] in TysPrim. -naturallyCoherentClass :: Class -> Bool -naturallyCoherentClass cls - = isCTupleClass cls - || cls `hasKey` heqTyConKey - || cls `hasKey` eqTyConKey - || cls `hasKey` coercibleTyConKey - - -{- Note [Instance and Given overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Example, from the OutsideIn(X) paper: - instance P x => Q [x] - instance (x ~ y) => R y [x] - - wob :: forall a b. (Q [b], R b a) => a -> Int - - g :: forall a. Q [a] => [a] -> Int - g x = wob x - -From 'g' we get the implication constraint: - forall a. Q [a] => (Q [beta], R beta [a]) -If we react (Q [beta]) with its top-level axiom, we end up with a -(P beta), which we have no way of discharging. On the other hand, -if we react R beta [a] with the top-level we get (beta ~ a), which -is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is -now solvable by the given Q [a]. - -The partial solution is that: - In matchClassInst (and thus in topReact), we return a matching - instance only when there is no Given in the inerts which is - unifiable to this particular dictionary. - - We treat any meta-tyvar as "unifiable" for this purpose, - *including* untouchable ones. But not skolems like 'a' in - the implication constraint above. - -The end effect is that, much as we do for overlapping instances, we -delay choosing a class instance if there is a possibility of another -instance OR a given to match our constraint later on. This fixes -#4981 and #5002. - -Other notes: - -* The check is done *first*, so that it also covers classes - with built-in instance solving, such as - - constraint tuples - - natural numbers - - Typeable - -* Flatten-skolems: we do not treat a flatten-skolem as unifiable - for this purpose. - E.g. f :: Eq (F a) => [a] -> [a] - f xs = ....(xs==xs)..... - Here we get [W] Eq [a], and we don't want to refrain from solving - it because of the given (Eq (F a)) constraint! - -* The given-overlap problem is arguably not easy to appear in practice - due to our aggressive prioritization of equality solving over other - constraints, but it is possible. I've added a test case in - typecheck/should-compile/GivenOverlapping.hs - -* Another "live" example is #10195; another is #10177. - -* We ignore the overlap problem if -XIncoherentInstances is in force: - see #6002 for a worked-out example where this makes a - difference. - -* Moreover notice that our goals here are different than the goals of - the top-level overlapping checks. There we are interested in - validating the following principle: - - If we inline a function f at a site where the same global - instance environment is available as the instance environment at - the definition site of f then we should get the same behaviour. - - But for the Given Overlap check our goal is just related to completeness of - constraint solving. - -* The solution is only a partial one. Consider the above example with - g :: forall a. Q [a] => [a] -> Int - g x = let v = wob x - in v - and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most - general type for 'v'. When generalising v's type we'll simplify its - Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we - will use the instance declaration after all. #11948 was a case - in point. - -All of this is disgustingly delicate, so to discourage people from writing -simplifiable class givens, we warn about signatures that contain them; -see TcValidity Note [Simplifiable given constraints]. - -Note [Naturally coherent classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A few built-in classes are "naturally coherent". This term means that -the "instance" for the class is bidirectional with its superclass(es). -For example, consider (~~), which behaves as if it was defined like -this: - class a ~# b => a ~~ b - instance a ~# b => a ~~ b -(See Note [The equality types story] in TysPrim.) - -Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2, -without worrying about Note [Instance and Given overlap]. Why? Because -if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and -so the reduction of the [W] constraint does not risk losing any solutions. - -On the other hand, it can be fatal to /fail/ to reduce such -equalities, on the grounds of Note [Instance and Given overlap], -because many good things flow from [W] t1 ~# t2. - -The same reasoning applies to - -* (~~) heqTyCOn -* (~) eqTyCon -* Coercible coercibleTyCon - -And less obviously to: - -* Tuple classes. For reasons described in TcSMonad - Note [Tuples hiding implicit parameters], we may have a constraint - [W] (?x::Int, C a) - with an exactly-matching Given constraint. We must decompose this - tuple and solve the components separately, otherwise we won't solve - it at all! It is perfectly safe to decompose it, because again the - superclasses invert the instance; e.g. - class (c1, c2) => (% c1, c2 %) - instance (c1, c2) => (% c1, c2 %) - Example in #14218 - -Exammples: T5853, T10432, T5315, T9222, T2627b, T3028b - -PS: the term "naturally coherent" doesn't really seem helpful. -Perhaps "invertible" or something? I left it for now though. - -Note [Local instances and incoherence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall b c. (Eq b, forall a. Eq a => Eq (c a)) - => c b -> Bool - f x = x==x - -We get [W] Eq (c b), and we must use the local instance to solve it. - -BUT that wanted also unifies with the top-level Eq [a] instance, -and Eq (Maybe a) etc. We want the local instance to "win", otherwise -we can't solve the wanted at all. So we mark it as Incohherent. -According to Note [Rules for instance lookup] in GHC.Core.InstEnv, that'll -make it win even if there are other instances that unify. - -Moreover this is not a hack! The evidence for this local instance -will be constructed by GHC at a call site... from the very instances -that unify with it here. It is not like an incoherent user-written -instance which might have utterly different behaviour. - -Consdider f :: Eq a => blah. If we have [W] Eq a, we certainly -get it from the Eq a context, without worrying that there are -lots of top-level instances that unify with [W] Eq a! We'll use -those instances to build evidence to pass to f. That's just the -nullary case of what's happening here. --} - -matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult --- Look up the predicate in Given quantified constraints, --- which are effectively just local instance declarations. -matchLocalInst pred loc - = do { ics <- getInertCans - ; case match_local_inst (inert_insts ics) of - ([], False) -> do { traceTcS "No local instance for" (ppr pred) - ; return NoInstance } - ([(dfun_ev, inst_tys)], unifs) - | not unifs - -> do { let dfun_id = ctEvEvId dfun_ev - ; (tys, theta) <- instDFunType dfun_id inst_tys - ; let result = OneInst { cir_new_theta = theta - , cir_mk_ev = evDFunApp dfun_id tys - , cir_what = LocalInstance } - ; traceTcS "Local inst found:" (ppr result) - ; return result } - _ -> do { traceTcS "Multiple local instances for" (ppr pred) - ; return NotSure }} - where - pred_tv_set = tyCoVarsOfType pred - - match_local_inst :: [QCInst] - -> ( [(CtEvidence, [DFunInstType])] - , Bool ) -- True <=> Some unify but do not match - match_local_inst [] - = ([], False) - match_local_inst (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred - , qci_ev = ev }) - : qcis) - | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set) - , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) - emptyTvSubstEnv qpred pred - , let match = (ev, map (lookupVarEnv tv_subst) qtvs) - = (match:matches, unif) - - | otherwise - = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred) - , ppr qci $$ ppr pred ) - -- ASSERT: unification relies on the - -- quantified variables being fresh - (matches, unif || this_unif) - where - qtv_set = mkVarSet qtvs - this_unif = mightMatchLater qpred (ctEvLoc ev) pred loc - (matches, unif) = match_local_inst qcis diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs deleted file mode 100644 index e234c5195c..0000000000 --- a/compiler/typecheck/TcMType.hs +++ /dev/null @@ -1,2420 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Monadic type operations - -This module contains monadic operations over types that contain -mutable type variables. --} - -{-# LANGUAGE CPP, TupleSections, MultiWayIf #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcMType ( - TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet, - - -------------------------------- - -- Creating new mutable type variables - newFlexiTyVar, - newNamedFlexiTyVar, - newFlexiTyVarTy, -- Kind -> TcM TcType - newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] - newOpenFlexiTyVarTy, newOpenTypeKind, - newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel, - cloneMetaTyVar, - newFmvTyVar, newFskTyVar, - - readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, - newMetaDetails, isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, - - -------------------------------- - -- Expected types - ExpType(..), ExpSigmaType, ExpRhoType, - mkCheckExpType, - newInferExpType, newInferExpTypeInst, newInferExpTypeNoInst, - readExpType, readExpType_maybe, - expTypeToType, checkingExpType_maybe, checkingExpType, - tauifyExpType, inferResultToType, - - -------------------------------- - -- Creating new evidence variables - newEvVar, newEvVars, newDict, - newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC, - emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, - emitDerivedEqs, - newTcEvBinds, newNoTcEvBinds, addTcEvBind, - - newCoercionHole, fillCoercionHole, isFilledCoercionHole, - unpackCoercionHole, unpackCoercionHole_maybe, - checkCoercionHole, - - newImplication, - - -------------------------------- - -- Instantiation - newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, - newMetaTyVarTyVars, newMetaTyVarTyVarX, - newTyVarTyVar, cloneTyVarTyVar, - newPatSigTyVar, newSkolemTyVar, newWildCardX, - tcInstType, - tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, - tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, - - freshenTyVarBndrs, freshenCoVarBndrsX, - - -------------------------------- - -- Zonking and tidying - zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, - tidyEvVar, tidyCt, tidySkolemInfo, - zonkTcTyVar, zonkTcTyVars, - zonkTcTyVarToTyVar, zonkTyVarTyVarPairs, - zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, - zonkTyCoVarsAndFVList, - candidateQTyVarsOfType, candidateQTyVarsOfKind, - candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, - CandidatesQTvs(..), delCandidates, candidateKindVars, partitionCandidates, - zonkAndSkolemise, skolemiseQuantifiedTyVar, - defaultTyVar, quantifyTyVars, isQuantifiableTv, - zonkTcType, zonkTcTypes, zonkCo, - zonkTyCoVarKind, - - zonkEvVar, zonkWC, zonkSimples, - zonkId, zonkCoVar, - zonkCt, zonkSkolemInfo, - - skolemiseUnboundMetaTyVar, - - ------------------------------ - -- Levity polymorphism - ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr - ) where - -#include "HsVersions.h" - --- friends: -import GhcPrelude - -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import TcType -import GHC.Core.Type -import GHC.Core.TyCon -import GHC.Core.Coercion -import GHC.Core.Class -import GHC.Types.Var -import GHC.Core.Predicate -import TcOrigin - --- others: -import TcRnMonad -- TcType, amongst others -import Constraint -import TcEvidence -import GHC.Types.Id as Id -import GHC.Types.Name -import GHC.Types.Var.Set -import TysWiredIn -import TysPrim -import GHC.Types.Var.Env -import GHC.Types.Name.Env -import PrelNames -import Util -import Outputable -import FastString -import Bag -import Pair -import GHC.Types.Unique.Set -import GHC.Driver.Session -import qualified GHC.LanguageExtensions as LangExt -import GHC.Types.Basic ( TypeOrKind(..) ) - -import Control.Monad -import Maybes -import Data.List ( mapAccumL ) -import Control.Arrow ( second ) -import qualified Data.Semigroup as Semi - -{- -************************************************************************ -* * - Kind variables -* * -************************************************************************ --} - -mkKindName :: Unique -> Name -mkKindName unique = mkSystemName unique kind_var_occ - -kind_var_occ :: OccName -- Just one for all MetaKindVars - -- They may be jiggled by tidying -kind_var_occ = mkOccName tvName "k" - -newMetaKindVar :: TcM TcKind -newMetaKindVar - = do { details <- newMetaDetails TauTv - ; uniq <- newUnique - ; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details - ; traceTc "newMetaKindVar" (ppr kv) - ; return (mkTyVarTy kv) } - -newMetaKindVars :: Int -> TcM [TcKind] -newMetaKindVars n = replicateM n newMetaKindVar - -{- -************************************************************************ -* * - Evidence variables; range over constraints we can abstract over -* * -************************************************************************ --} - -newEvVars :: TcThetaType -> TcM [EvVar] -newEvVars theta = mapM newEvVar theta - --------------- - -newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar --- Creates new *rigid* variables for predicates -newEvVar ty = do { name <- newSysName (predTypeOccName ty) - ; return (mkLocalIdOrCoVar name ty) } - -newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence --- Deals with both equality and non-equality predicates -newWanted orig t_or_k pty - = do loc <- getCtLocM orig t_or_k - d <- if isEqPrimPred pty then HoleDest <$> newCoercionHole YesBlockSubst pty - else EvVarDest <$> newEvVar pty - return $ CtWanted { ctev_dest = d - , ctev_pred = pty - , ctev_nosh = WDeriv - , ctev_loc = loc } - -newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] -newWanteds orig = mapM (newWanted orig Nothing) - --- | Create a new 'CHoleCan' 'Ct'. -newHoleCt :: HoleSort -> Id -> Type -> TcM Ct -newHoleCt hole ev ty = do - loc <- getCtLocM HoleOrigin Nothing - pure $ CHoleCan { cc_ev = CtWanted { ctev_pred = ty - , ctev_dest = EvVarDest ev - , ctev_nosh = WDeriv - , ctev_loc = loc } - , cc_occ = getOccName ev - , cc_hole = hole } - ----------------------------------------------- --- Cloning constraints ----------------------------------------------- - -cloneWanted :: Ct -> TcM Ct -cloneWanted ct - | ev@(CtWanted { ctev_dest = HoleDest old_hole, ctev_pred = pty }) <- ctEvidence ct - = do { co_hole <- newCoercionHole (ch_blocker old_hole) pty - ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) } - | otherwise - = return ct - -cloneWC :: WantedConstraints -> TcM WantedConstraints --- Clone all the evidence bindings in --- a) the ic_bind field of any implications --- b) the CoercionHoles of any wanted constraints --- so that solving the WantedConstraints will not have any visible side --- effect, /except/ from causing unifications -cloneWC wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { simples' <- mapBagM cloneWanted simples - ; implics' <- mapBagM cloneImplication implics - ; return (wc { wc_simple = simples', wc_impl = implics' }) } - -cloneImplication :: Implication -> TcM Implication -cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted }) - = do { binds' <- cloneEvBindsVar binds - ; inner_wanted' <- cloneWC inner_wanted - ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) } - ----------------------------------------------- --- Emitting constraints ----------------------------------------------- - --- | Emits a new Wanted. Deals with both equalities and non-equalities. -emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm -emitWanted origin pty - = do { ev <- newWanted origin Nothing pty - ; emitSimple $ mkNonCanonical ev - ; return $ ctEvTerm ev } - -emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () --- Emit some new derived nominal equalities -emitDerivedEqs origin pairs - | null pairs - = return () - | otherwise - = do { loc <- getCtLocM origin Nothing - ; emitSimples (listToBag (map (mk_one loc) pairs)) } - where - mk_one loc (ty1, ty2) - = mkNonCanonical $ - CtDerived { ctev_pred = mkPrimEqPred ty1 ty2 - , ctev_loc = loc } - --- | Emits a new equality constraint -emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion -emitWantedEq origin t_or_k role ty1 ty2 - = do { hole <- newCoercionHole YesBlockSubst pty - ; loc <- getCtLocM origin (Just t_or_k) - ; emitSimple $ mkNonCanonical $ - CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole - , ctev_nosh = WDeriv, ctev_loc = loc } - ; return (HoleCo hole) } - where - pty = mkPrimEqPredRole role ty1 ty2 - --- | Creates a new EvVar and immediately emits it as a Wanted. --- No equality predicates here. -emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar -emitWantedEvVar origin ty - = do { new_cv <- newEvVar ty - ; loc <- getCtLocM origin Nothing - ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv - , ctev_pred = ty - , ctev_nosh = WDeriv - , ctev_loc = loc } - ; emitSimple $ mkNonCanonical ctev - ; return new_cv } - -emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar] -emitWantedEvVars orig = mapM (emitWantedEvVar orig) - -newDict :: Class -> [TcType] -> TcM DictId -newDict cls tys - = do { name <- newSysName (mkDictOcc (getOccName cls)) - ; return (mkLocalId name (mkClassPred cls tys)) } - -predTypeOccName :: PredType -> OccName -predTypeOccName ty = case classifyPredType ty of - ClassPred cls _ -> mkDictOcc (getOccName cls) - EqPred {} -> mkVarOccFS (fsLit "co") - IrredPred {} -> mkVarOccFS (fsLit "irred") - ForAllPred {} -> mkVarOccFS (fsLit "df") - --- | Create a new 'Implication' with as many sensible defaults for its fields --- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do --- /not/ have sensible defaults, so they are initialized with lazy thunks that --- will 'panic' if forced, so one should take care to initialize these fields --- after creation. --- --- This is monadic to look up the 'TcLclEnv', which is used to initialize --- 'ic_env', and to set the -Winaccessible-code flag. See --- Note [Avoid -Winaccessible-code when deriving] in TcInstDcls. -newImplication :: TcM Implication -newImplication - = do env <- getLclEnv - warn_inaccessible <- woptM Opt_WarnInaccessibleCode - return (implicationPrototype { ic_env = env - , ic_warn_inaccessible = warn_inaccessible }) - -{- -************************************************************************ -* * - Coercion holes -* * -************************************************************************ --} - -newCoercionHole :: BlockSubstFlag -- should the presence of this hole block substitution? - -- See sub-wrinkle in TcCanonical - -- Note [Equalities with incompatible kinds] - -> TcPredType -> TcM CoercionHole -newCoercionHole blocker pred_ty - = do { co_var <- newEvVar pred_ty - ; traceTc "New coercion hole:" (ppr co_var <+> ppr blocker) - ; ref <- newMutVar Nothing - ; return $ CoercionHole { ch_co_var = co_var, ch_blocker = blocker - , ch_ref = ref } } - --- | Put a value in a coercion hole -fillCoercionHole :: CoercionHole -> Coercion -> TcM () -fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co - = do { -#if defined(DEBUG) - ; cts <- readTcRef ref - ; whenIsJust cts $ \old_co -> - pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co) -#endif - ; traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co) - ; writeTcRef ref (Just co) } - --- | Is a coercion hole filled in? -isFilledCoercionHole :: CoercionHole -> TcM Bool -isFilledCoercionHole (CoercionHole { ch_ref = ref }) = isJust <$> readTcRef ref - --- | Retrieve the contents of a coercion hole. Panics if the hole --- is unfilled -unpackCoercionHole :: CoercionHole -> TcM Coercion -unpackCoercionHole hole - = do { contents <- unpackCoercionHole_maybe hole - ; case contents of - Just co -> return co - Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } - --- | Retrieve the contents of a coercion hole, if it is filled -unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion) -unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref - --- | Check that a coercion is appropriate for filling a hole. (The hole --- itself is needed only for printing. --- Always returns the checked coercion, but this return value is necessary --- so that the input coercion is forced only when the output is forced. -checkCoercionHole :: CoVar -> Coercion -> TcM Coercion -checkCoercionHole cv co - | debugIsOn - = do { cv_ty <- zonkTcType (varType cv) - -- co is already zonked, but cv might not be - ; return $ - ASSERT2( ok cv_ty - , (text "Bad coercion hole" <+> - ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role - , ppr cv_ty ]) ) - co } - | otherwise - = return co - - where - (Pair t1 t2, role) = coercionKindRole co - ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty - = t1 `eqType` cv_t1 - && t2 `eqType` cv_t2 - && role == eqRelRole cv_rel - | otherwise - = False - -{- -************************************************************************ -* - Expected types -* -************************************************************************ - -Note [ExpType] -~~~~~~~~~~~~~~ - -An ExpType is used as the "expected type" when type-checking an expression. -An ExpType can hold a "hole" that can be filled in by the type-checker. -This allows us to have one tcExpr that works in both checking mode and -synthesis mode (that is, bidirectional type-checking). Previously, this -was achieved by using ordinary unification variables, but we don't need -or want that generality. (For example, #11397 was caused by doing the -wrong thing with unification variables.) Instead, we observe that these -holes should - -1. never be nested -2. never appear as the type of a variable -3. be used linearly (never be duplicated) - -By defining ExpType, separately from Type, we can achieve goals 1 and 2 -statically. - -See also [wiki:typechecking] - -Note [TcLevel of ExpType] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data G a where - MkG :: G Bool - - foo MkG = True - -This is a classic untouchable-variable / ambiguous GADT return type -scenario. But, with ExpTypes, we'll be inferring the type of the RHS. -And, because there is only one branch of the case, we won't trigger -Note [Case branches must never infer a non-tau type] of TcMatches. -We thus must track a TcLevel in an Inferring ExpType. If we try to -fill the ExpType and find that the TcLevels don't work out, we -fill the ExpType with a tau-tv at the low TcLevel, hopefully to -be worked out later by some means. This is triggered in -test gadt/gadt-escape1. - --} - --- actual data definition is in TcType - --- | Make an 'ExpType' suitable for inferring a type of kind * or #. -newInferExpTypeNoInst :: TcM ExpSigmaType -newInferExpTypeNoInst = newInferExpType False - -newInferExpTypeInst :: TcM ExpRhoType -newInferExpTypeInst = newInferExpType True - -newInferExpType :: Bool -> TcM ExpType -newInferExpType inst - = do { u <- newUnique - ; tclvl <- getTcLevel - ; traceTc "newOpenInferExpType" (ppr u <+> ppr inst <+> ppr tclvl) - ; ref <- newMutVar Nothing - ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl - , ir_ref = ref, ir_inst = inst })) } - --- | Extract a type out of an ExpType, if one exists. But one should always --- exist. Unless you're quite sure you know what you're doing. -readExpType_maybe :: ExpType -> TcM (Maybe TcType) -readExpType_maybe (Check ty) = return (Just ty) -readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref - --- | Extract a type out of an ExpType. Otherwise, panics. -readExpType :: ExpType -> TcM TcType -readExpType exp_ty - = do { mb_ty <- readExpType_maybe exp_ty - ; case mb_ty of - Just ty -> return ty - Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) } - --- | Returns the expected type when in checking mode. -checkingExpType_maybe :: ExpType -> Maybe TcType -checkingExpType_maybe (Check ty) = Just ty -checkingExpType_maybe _ = Nothing - --- | Returns the expected type when in checking mode. Panics if in inference --- mode. -checkingExpType :: String -> ExpType -> TcType -checkingExpType _ (Check ty) = ty -checkingExpType err et = pprPanic "checkingExpType" (text err $$ ppr et) - -tauifyExpType :: ExpType -> TcM ExpType --- ^ Turn a (Infer hole) type into a (Check alpha), --- where alpha is a fresh unification variable -tauifyExpType (Check ty) = return (Check ty) -- No-op for (Check ty) -tauifyExpType (Infer inf_res) = do { ty <- inferResultToType inf_res - ; return (Check ty) } - --- | Extracts the expected type if there is one, or generates a new --- TauTv if there isn't. -expTypeToType :: ExpType -> TcM TcType -expTypeToType (Check ty) = return ty -expTypeToType (Infer inf_res) = inferResultToType inf_res - -inferResultToType :: InferResult -> TcM Type -inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl - , ir_ref = ref }) - = do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy - ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr) - -- See Note [TcLevel of ExpType] - ; writeMutVar ref (Just tau) - ; traceTc "Forcing ExpType to be monomorphic:" - (ppr u <+> text ":=" <+> ppr tau) - ; return tau } - - -{- ********************************************************************* -* * - SkolemTvs (immutable) -* * -********************************************************************* -} - -tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar])) - -- ^ How to instantiate the type variables - -> Id -- ^ Type to instantiate - -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result - -- (type vars, preds (incl equalities), rho) -tcInstType inst_tyvars id - = case tcSplitForAllTys (idType id) of - ([], rho) -> let -- There may be overloading despite no type variables; - -- (?x :: Int) => Int -> Int - (theta, tau) = tcSplitPhiTy rho - in - return ([], theta, tau) - - (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars - ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho) - tv_prs = map tyVarName tyvars `zip` tyvars' - ; return (tv_prs, theta, tau) } - -tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType) --- Instantiate a type signature with skolem constants. --- We could give them fresh names, but no need to do so -tcSkolDFunType dfun - = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun - ; return (map snd tv_prs, theta, tau) } - -tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar]) --- Make skolem constants, but do *not* give them new names, as above --- Moreover, make them "super skolems"; see comments with superSkolemTv --- see Note [Kind substitution when instantiating] --- Precondition: tyvars should be ordered by scoping -tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst - -tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar) -tcSuperSkolTyVar subst tv - = (extendTvSubstWithClone subst tv new_tv, new_tv) - where - kind = substTyUnchecked subst (tyVarKind tv) - new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv - --- | Given a list of @['TyVar']@, skolemize the type variables, --- returning a substitution mapping the original tyvars to the --- skolems, and the list of newly bound skolems. -tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- See Note [Skolemising type variables] -tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst - -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- See Note [Skolemising type variables] -tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False - -tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- See Note [Skolemising type variables] -tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst - -tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- See Note [Skolemising type variables] -tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst - -tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar] - -> TcM (TCvSubst, [TcTyVar]) --- Skolemise one level deeper, hence pushTcLevel --- See Note [Skolemising type variables] -tcInstSkolTyVarsPushLevel overlappable subst tvs - = do { tc_lvl <- getTcLevel - ; let pushed_lvl = pushTcLevel tc_lvl - ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs } - -tcInstSkolTyVarsAt :: TcLevel -> Bool - -> TCvSubst -> [TyVar] - -> TcM (TCvSubst, [TcTyVar]) -tcInstSkolTyVarsAt lvl overlappable subst tvs - = freshenTyCoVarsX new_skol_tv subst tvs - where - details = SkolemTv lvl overlappable - new_skol_tv name kind = mkTcTyVar name kind details - ------------------- -freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar]) --- ^ Give fresh uniques to a bunch of TyVars, but they stay --- as TyVars, rather than becoming TcTyVars --- Used in FamInst.newFamInst, and Inst.newClsInst -freshenTyVarBndrs = freshenTyCoVars mkTyVar - -freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar]) --- ^ Give fresh uniques to a bunch of CoVars --- Used in FamInst.newFamInst -freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst - ------------------- -freshenTyCoVars :: (Name -> Kind -> TyCoVar) - -> [TyVar] -> TcM (TCvSubst, [TyCoVar]) -freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst - -freshenTyCoVarsX :: (Name -> Kind -> TyCoVar) - -> TCvSubst -> [TyCoVar] - -> TcM (TCvSubst, [TyCoVar]) -freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv) - -freshenTyCoVarX :: (Name -> Kind -> TyCoVar) - -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar) --- This a complete freshening operation: --- the skolems have a fresh unique, and a location from the monad --- See Note [Skolemising type variables] -freshenTyCoVarX mk_tcv subst tycovar - = do { loc <- getSrcSpanM - ; uniq <- newUnique - ; let old_name = tyVarName tycovar - new_name = mkInternalName uniq (getOccName old_name) loc - new_kind = substTyUnchecked subst (tyVarKind tycovar) - new_tcv = mk_tcv new_name new_kind - subst1 = extendTCvSubstWithClone subst tycovar new_tcv - ; return (subst1, new_tcv) } - -{- Note [Skolemising type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The tcInstSkolTyVars family of functions instantiate a list of TyVars -to fresh skolem TcTyVars. Important notes: - -a) Level allocation. We generally skolemise /before/ calling - pushLevelAndCaptureConstraints. So we want their level to the level - of the soon-to-be-created implication, which has a level ONE HIGHER - than the current level. Hence the pushTcLevel. It feels like a - slight hack. - -b) The [TyVar] should be ordered (kind vars first) - See Note [Kind substitution when instantiating] - -c) It's a complete freshening operation: the skolems have a fresh - unique, and a location from the monad - -d) The resulting skolems are - non-overlappable for tcInstSkolTyVars, - but overlappable for tcInstSuperSkolTyVars - See TcDerivInfer Note [Overlap and deriving] for an example - of where this matters. - -Note [Kind substitution when instantiating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we instantiate a bunch of kind and type variables, first we -expect them to be topologically sorted. -Then we have to instantiate the kind variables, build a substitution -from old variables to the new variables, then instantiate the type -variables substituting the original kind. - -Exemple: If we want to instantiate - [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)] -we want - [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)] -instead of the buggous - [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)] - - -************************************************************************ -* * - MetaTvs (meta type variables; mutable) -* * -************************************************************************ --} - -{- -Note [TyVarTv] -~~~~~~~~~~~~ - -A TyVarTv can unify with type *variables* only, including other TyVarTvs and -skolems. Sometimes, they can unify with type variables that the user would -rather keep distinct; see #11203 for an example. So, any client of this -function needs to either allow the TyVarTvs to unify with each other or check -that they don't (say, with a call to findDubTyVarTvs). - -Before #15050 this (under the name SigTv) was used for ScopedTypeVariables in -patterns, to make sure these type variables only refer to other type variables, -but this restriction was dropped, and ScopedTypeVariables can now refer to full -types (GHC Proposal 29). - -The remaining uses of newTyVarTyVars are -* In kind signatures, see - TcTyClsDecls Note [Inferring kinds for type declarations] - and Note [Kind checking for GADTs] -* In partial type signatures, see Note [Quantified variables in partial type signatures] --} - -newMetaTyVarName :: FastString -> TcM Name --- Makes a /System/ Name, which is eagerly eliminated by --- the unifier; see TcUnify.nicer_to_update_tv1, and --- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2) -newMetaTyVarName str - = do { uniq <- newUnique - ; return (mkSystemName uniq (mkTyVarOccFS str)) } - -cloneMetaTyVarName :: Name -> TcM Name -cloneMetaTyVarName name - = do { uniq <- newUnique - ; return (mkSystemName uniq (nameOccName name)) } - -- See Note [Name of an instantiated type variable] - -{- Note [Name of an instantiated type variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At the moment we give a unification variable a System Name, which -influences the way it is tidied; see TypeRep.tidyTyVarBndr. --} - -metaInfoToTyVarName :: MetaInfo -> FastString -metaInfoToTyVarName meta_info = - case meta_info of - TauTv -> fsLit "t" - FlatMetaTv -> fsLit "fmv" - FlatSkolTv -> fsLit "fsk" - TyVarTv -> fsLit "a" - -newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar -newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi - -newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar --- Make a new meta tyvar out of thin air -newNamedAnonMetaTyVar tyvar_name meta_info kind - - = do { name <- newMetaTyVarName tyvar_name - ; details <- newMetaDetails meta_info - ; let tyvar = mkTcTyVar name kind details - ; traceTc "newAnonMetaTyVar" (ppr tyvar) - ; return tyvar } - --- makes a new skolem tv -newSkolemTyVar :: Name -> Kind -> TcM TcTyVar -newSkolemTyVar name kind - = do { lvl <- getTcLevel - ; return (mkTcTyVar name kind (SkolemTv lvl False)) } - -newTyVarTyVar :: Name -> Kind -> TcM TcTyVar --- See Note [TyVarTv] --- Does not clone a fresh unique -newTyVarTyVar name kind - = do { details <- newMetaDetails TyVarTv - ; let tyvar = mkTcTyVar name kind details - ; traceTc "newTyVarTyVar" (ppr tyvar) - ; return tyvar } - -cloneTyVarTyVar :: Name -> Kind -> TcM TcTyVar --- See Note [TyVarTv] --- Clones a fresh unique -cloneTyVarTyVar name kind - = do { details <- newMetaDetails TyVarTv - ; uniq <- newUnique - ; let name' = name `setNameUnique` uniq - tyvar = mkTcTyVar name' kind details - -- Don't use cloneMetaTyVar, which makes a SystemName - -- We want to keep the original more user-friendly Name - -- In practical terms that means that in error messages, - -- when the Name is tidied we get 'a' rather than 'a0' - ; traceTc "cloneTyVarTyVar" (ppr tyvar) - ; return tyvar } - -newPatSigTyVar :: Name -> Kind -> TcM TcTyVar -newPatSigTyVar name kind - = do { details <- newMetaDetails TauTv - ; uniq <- newUnique - ; let name' = name `setNameUnique` uniq - tyvar = mkTcTyVar name' kind details - -- Don't use cloneMetaTyVar; - -- same reasoning as in newTyVarTyVar - ; traceTc "newPatSigTyVar" (ppr tyvar) - ; return tyvar } - -cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar --- Make a fresh MetaTyVar, basing the name --- on that of the supplied TyVar -cloneAnonMetaTyVar info tv kind - = do { details <- newMetaDetails info - ; name <- cloneMetaTyVarName (tyVarName tv) - ; let tyvar = mkTcTyVar name kind details - ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)) - ; return tyvar } - -newFskTyVar :: TcType -> TcM TcTyVar -newFskTyVar fam_ty - = do { details <- newMetaDetails FlatSkolTv - ; name <- newMetaTyVarName (fsLit "fsk") - ; return (mkTcTyVar name (tcTypeKind fam_ty) details) } - -newFmvTyVar :: TcType -> TcM TcTyVar --- Very like newMetaTyVar, except sets mtv_tclvl to one less --- so that the fmv is untouchable. -newFmvTyVar fam_ty - = do { details <- newMetaDetails FlatMetaTv - ; name <- newMetaTyVarName (fsLit "s") - ; return (mkTcTyVar name (tcTypeKind fam_ty) details) } - -newMetaDetails :: MetaInfo -> TcM TcTyVarDetails -newMetaDetails info - = do { ref <- newMutVar Flexi - ; tclvl <- getTcLevel - ; return (MetaTv { mtv_info = info - , mtv_ref = ref - , mtv_tclvl = tclvl }) } - -cloneMetaTyVar :: TcTyVar -> TcM TcTyVar -cloneMetaTyVar tv - = ASSERT( isTcTyVar tv ) - do { ref <- newMutVar Flexi - ; name' <- cloneMetaTyVarName (tyVarName tv) - ; let details' = case tcTyVarDetails tv of - details@(MetaTv {}) -> details { mtv_ref = ref } - _ -> pprPanic "cloneMetaTyVar" (ppr tv) - tyvar = mkTcTyVar name' (tyVarKind tv) details' - ; traceTc "cloneMetaTyVar" (ppr tyvar) - ; return tyvar } - --- Works for both type and kind variables -readMetaTyVar :: TyVar -> TcM MetaDetails -readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) - readMutVar (metaTyVarRef tyvar) - -isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) -isFilledMetaTyVar_maybe tv - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv - = do { cts <- readTcRef ref - ; case cts of - Indirect ty -> return (Just ty) - Flexi -> return Nothing } - | otherwise - = return Nothing - -isFilledMetaTyVar :: TyVar -> TcM Bool --- True of a filled-in (Indirect) meta type variable -isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv - -isUnfilledMetaTyVar :: TyVar -> TcM Bool --- True of a un-filled-in (Flexi) meta type variable --- NB: Not the opposite of isFilledMetaTyVar -isUnfilledMetaTyVar tv - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv - = do { details <- readMutVar ref - ; return (isFlexi details) } - | otherwise = return False - --------------------- --- Works with both type and kind variables -writeMetaTyVar :: TcTyVar -> TcType -> TcM () --- Write into a currently-empty MetaTyVar - -writeMetaTyVar tyvar ty - | not debugIsOn - = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty - --- Everything from here on only happens if DEBUG is on - | not (isTcTyVar tyvar) - = ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar ) - return () - - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar - = writeMetaTyVarRef tyvar ref ty - - | otherwise - = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar ) - return () - --------------------- -writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () --- Here the tyvar is for error checking only; --- the ref cell must be for the same tyvar -writeMetaTyVarRef tyvar ref ty - | not debugIsOn - = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) - <+> text ":=" <+> ppr ty) - ; writeTcRef ref (Indirect ty) } - - -- Everything from here on only happens if DEBUG is on - | otherwise - = do { meta_details <- readMutVar ref; - -- Zonk kinds to allow the error check to work - ; zonked_tv_kind <- zonkTcType tv_kind - ; zonked_ty_kind <- zonkTcType ty_kind - ; let kind_check_ok = tcIsConstraintKind zonked_tv_kind - || tcEqKind zonked_ty_kind zonked_tv_kind - -- Hack alert! tcIsConstraintKind: see TcHsType - -- Note [Extra-constraint holes in partial type signatures] - - kind_msg = hang (text "Ill-kinded update to meta tyvar") - 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) - <+> text ":=" - <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) ) - - ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) - - -- Check for double updates - ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details ) - - -- Check for level OK - -- See Note [Level check when unifying] - ; MASSERT2( level_check_ok, level_check_msg ) - - -- Check Kinds ok - ; MASSERT2( kind_check_ok, kind_msg ) - - -- Do the write - ; writeMutVar ref (Indirect ty) } - where - tv_kind = tyVarKind tyvar - ty_kind = tcTypeKind ty - - tv_lvl = tcTyVarLevel tyvar - ty_lvl = tcTypeLevel ty - - level_check_ok = not (ty_lvl `strictlyDeeperThan` tv_lvl) - level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty - - double_upd_msg details = hang (text "Double update of meta tyvar") - 2 (ppr tyvar $$ ppr details) - -{- Note [Level check when unifying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When unifying - alpha:lvl := ty -we expect that the TcLevel of 'ty' will be <= lvl. -However, during unflatting we do - fuv:l := ty:(l+1) -which is usually wrong; hence the check isFmmvTyVar in level_check_ok. -See Note [TcLevel assignment] in TcType. --} - -{- -% Generating fresh variables for pattern match check --} - - -{- -************************************************************************ -* * - MetaTvs: TauTvs -* * -************************************************************************ - -Note [Never need to instantiate coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With coercion variables sloshing around in types, it might seem that we -sometimes need to instantiate coercion variables. This would be problematic, -because coercion variables inhabit unboxed equality (~#), and the constraint -solver thinks in terms only of boxed equality (~). The solution is that -we never need to instantiate coercion variables in the first place. - -The tyvars that we need to instantiate come from the types of functions, -data constructors, and patterns. These will never be quantified over -coercion variables, except for the special case of the promoted Eq#. But, -that can't ever appear in user code, so we're safe! --} - - -newFlexiTyVar :: Kind -> TcM TcTyVar -newFlexiTyVar kind = newAnonMetaTyVar TauTv kind - --- | Create a new flexi ty var with a specific name -newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar -newNamedFlexiTyVar fs kind = newNamedAnonMetaTyVar fs TauTv kind - -newFlexiTyVarTy :: Kind -> TcM TcType -newFlexiTyVarTy kind = do - tc_tyvar <- newFlexiTyVar kind - return (mkTyVarTy tc_tyvar) - -newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] -newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind) - -newOpenTypeKind :: TcM TcKind -newOpenTypeKind - = do { rr <- newFlexiTyVarTy runtimeRepTy - ; return (tYPE rr) } - --- | Create a tyvar that can be a lifted or unlifted type. --- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh -newOpenFlexiTyVarTy :: TcM TcType -newOpenFlexiTyVarTy - = do { kind <- newOpenTypeKind - ; newFlexiTyVarTy kind } - -newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- Instantiate with META type variables --- Note that this works for a sequence of kind, type, and coercion variables --- variables. Eg [ (k:*), (a:k->k) ] --- Gives [ (k7:*), (a8:k7->k7) ] -newMetaTyVars = newMetaTyVarsX emptyTCvSubst - -- emptyTCvSubst has an empty in-scope set, but that's fine here - -- Since the tyvars are freshly made, they cannot possibly be - -- captured by any existing for-alls. - -newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) --- Just like newMetaTyVars, but start with an existing substitution. -newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst - -newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) --- Make a new unification variable tyvar whose Name and Kind come from --- an existing TyVar. We substitute kind variables in the kind. -newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar - -newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst - -newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) --- Just like newMetaTyVarX, but make a TyVarTv -newMetaTyVarTyVarX subst tyvar = new_meta_tv_x TyVarTv subst tyvar - -newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -newWildCardX subst tv - = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv)) - ; return (extendTvSubstWithClone subst tv new_tv, new_tv) } - -new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -new_meta_tv_x info subst tv - = do { new_tv <- cloneAnonMetaTyVar info tv substd_kind - ; let subst1 = extendTvSubstWithClone subst tv new_tv - ; return (subst1, new_tv) } - where - substd_kind = substTyUnchecked subst (tyVarKind tv) - -- NOTE: #12549 is fixed so we could use - -- substTy here, but the tc_infer_args problem - -- is not yet fixed so leaving as unchecked for now. - -- OLD NOTE: - -- Unchecked because we call newMetaTyVarX from - -- tcInstTyBinder, which is called from tcInferApps - -- which does not yet take enough trouble to ensure - -- the in-scope set is right; e.g. #12785 trips - -- if we use substTy here - -newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType -newMetaTyVarTyAtLevel tc_lvl kind - = do { ref <- newMutVar Flexi - ; name <- newMetaTyVarName (fsLit "p") - ; let details = MetaTv { mtv_info = TauTv - , mtv_ref = ref - , mtv_tclvl = tc_lvl } - ; return (mkTyVarTy (mkTcTyVar name kind details)) } - -{- ********************************************************************* -* * - Finding variables to quantify over -* * -********************************************************************* -} - -{- Note [Dependent type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Haskell type inference we quantify over type variables; but we only -quantify over /kind/ variables when -XPolyKinds is on. Without -XPolyKinds -we default the kind variables to *. - -So, to support this defaulting, and only for that reason, when -collecting the free vars of a type (in candidateQTyVarsOfType and friends), -prior to quantifying, we must keep the type and kind variables separate. - -But what does that mean in a system where kind variables /are/ type -variables? It's a fairly arbitrary distinction based on how the -variables appear: - - - "Kind variables" appear in the kind of some other free variable - or in the kind of a locally quantified type variable - (forall (a :: kappa). ...) or in the kind of a coercion - (a |> (co :: kappa1 ~ kappa2)). - - These are the ones we default to * if -XPolyKinds is off - - - "Type variables" are all free vars that are not kind variables - -E.g. In the type T k (a::k) - 'k' is a kind variable, because it occurs in the kind of 'a', - even though it also appears at "top level" of the type - 'a' is a type variable, because it doesn't - -We gather these variables using a CandidatesQTvs record: - DV { dv_kvs: Variables free in the kind of a free type variable - or of a forall-bound type variable - , dv_tvs: Variables syntactically free in the type } - -So: dv_kvs are the kind variables of the type - (dv_tvs - dv_kvs) are the type variable of the type - -Note that - -* A variable can occur in both. - T k (x::k) The first occurrence of k makes it - show up in dv_tvs, the second in dv_kvs - -* We include any coercion variables in the "dependent", - "kind-variable" set because we never quantify over them. - -* The "kind variables" might depend on each other; e.g - (k1 :: k2), (k2 :: *) - The "type variables" do not depend on each other; if - one did, it'd be classified as a kind variable! - -Note [CandidatesQTvs determinism and order] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Determinism: when we quantify over type variables we decide the - order in which they appear in the final type. Because the order of - type variables in the type can end up in the interface file and - affects some optimizations like worker-wrapper, we want this order to - be deterministic. - - To achieve that we use deterministic sets of variables that can be - converted to lists in a deterministic order. For more information - about deterministic sets see Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. - -* Order: as well as being deterministic, we use an - accumulating-parameter style for candidateQTyVarsOfType so that we - add variables one at a time, left to right. That means we tend to - produce the variables in left-to-right order. This is just to make - it bit more predictable for the programmer. - -Note [Naughty quantification candidates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14880, dependent/should_compile/T14880-2), suppose -we are trying to generalise this type: - - forall arg. ... (alpha[tau]:arg) ... - -We have a metavariable alpha whose kind mentions a skolem variable -bound inside the very type we are generalising. -This can arise while type-checking a user-written type signature -(see the test case for the full code). - -We cannot generalise over alpha! That would produce a type like - forall {a :: arg}. forall arg. ...blah... -The fact that alpha's kind mentions arg renders it completely -ineligible for generalisation. - -However, we are not going to learn any new constraints on alpha, -because its kind isn't even in scope in the outer context (but see Wrinkle). -So alpha is entirely unconstrained. - -What then should we do with alpha? During generalization, every -metavariable is either (A) promoted, (B) generalized, or (C) zapped -(according to Note [Recipe for checking a signature] in TcHsType). - - * We can't generalise it. - * We can't promote it, because its kind prevents that - * We can't simply leave it be, because this type is about to - go into the typing environment (as the type of some let-bound - variable, say), and then chaos erupts when we try to instantiate. - -Previously, we zapped it to Any. This worked, but it had the unfortunate -effect of causing Any sometimes to appear in error messages. If this -kind of signature happens, the user probably has made a mistake -- no -one really wants Any in their types. So we now error. This must be -a hard error (failure in the monad) to avoid other messages from mentioning -Any. - -We do this eager erroring in candidateQTyVars, which always precedes -generalisation, because at that moment we have a clear picture of what -skolems are in scope within the type itself (e.g. that 'forall arg'). - -Wrinkle: - -We must make absolutely sure that alpha indeed is not -from an outer context. (Otherwise, we might indeed learn more information -about it.) This can be done easily: we just check alpha's TcLevel. -That level must be strictly greater than the ambient TcLevel in order -to treat it as naughty. We say "strictly greater than" because the call to -candidateQTyVars is made outside the bumped TcLevel, as stated in the -comment to candidateQTyVarsOfType. The level check is done in go_tv -in collect_cand_qtvs. Skipping this check caused #16517. - --} - -data CandidatesQTvs - -- See Note [Dependent type variables] - -- See Note [CandidatesQTvs determinism and order] - -- - -- Invariants: - -- * All variables are fully zonked, including their kinds - -- * All variables are at a level greater than the ambient level - -- See Note [Use level numbers for quantification] - -- - -- This *can* contain skolems. For example, in `data X k :: k -> Type` - -- we need to know that the k is a dependent variable. This is done - -- by collecting the candidates in the kind after skolemising. It also - -- comes up when generalizing a associated type instance, where instance - -- variables are skolems. (Recall that associated type instances are generalized - -- independently from their enclosing class instance, and the associated - -- type instance may be generalized by more, fewer, or different variables - -- than the class instance.) - -- - = DV { dv_kvs :: DTyVarSet -- "kind" metavariables (dependent) - , dv_tvs :: DTyVarSet -- "type" metavariables (non-dependent) - -- A variable may appear in both sets - -- E.g. T k (x::k) The first occurrence of k makes it - -- show up in dv_tvs, the second in dv_kvs - -- See Note [Dependent type variables] - - , dv_cvs :: CoVarSet - -- These are covars. Included only so that we don't repeatedly - -- look at covars' kinds in accumulator. Not used by quantifyTyVars. - } - -instance Semi.Semigroup CandidatesQTvs where - (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 }) - <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 }) - = DV { dv_kvs = kv1 `unionDVarSet` kv2 - , dv_tvs = tv1 `unionDVarSet` tv2 - , dv_cvs = cv1 `unionVarSet` cv2 } - -instance Monoid CandidatesQTvs where - mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet } - mappend = (Semi.<>) - -instance Outputable CandidatesQTvs where - ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) - = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs - , text "dv_tvs =" <+> ppr tvs - , text "dv_cvs =" <+> ppr cvs ]) - - -candidateKindVars :: CandidatesQTvs -> TyVarSet -candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) - -partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (DTyVarSet, CandidatesQTvs) -partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred - = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs }) - where - (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs - (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs - extracted = extracted_kvs `unionDVarSet` extracted_tvs - --- | Gathers free variables to use as quantification candidates (in --- 'quantifyTyVars'). This might output the same var --- in both sets, if it's used in both a type and a kind. --- The variables to quantify must have a TcLevel strictly greater than --- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) --- See Note [CandidatesQTvs determinism and order] --- See Note [Dependent type variables] -candidateQTyVarsOfType :: TcType -- not necessarily zonked - -> TcM CandidatesQTvs -candidateQTyVarsOfType ty = collect_cand_qtvs ty False emptyVarSet mempty ty - --- | Like 'candidateQTyVarsOfType', but over a list of types --- The variables to quantify must have a TcLevel strictly greater than --- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) -candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs -candidateQTyVarsOfTypes tys = foldlM (\acc ty -> collect_cand_qtvs ty False emptyVarSet acc ty) - mempty tys - --- | Like 'candidateQTyVarsOfType', but consider every free variable --- to be dependent. This is appropriate when generalizing a *kind*, --- instead of a type. (That way, -XNoPolyKinds will default the variables --- to Type.) -candidateQTyVarsOfKind :: TcKind -- Not necessarily zonked - -> TcM CandidatesQTvs -candidateQTyVarsOfKind ty = collect_cand_qtvs ty True emptyVarSet mempty ty - -candidateQTyVarsOfKinds :: [TcKind] -- Not necessarily zonked - -> TcM CandidatesQTvs -candidateQTyVarsOfKinds tys = foldM (\acc ty -> collect_cand_qtvs ty True emptyVarSet acc ty) - mempty tys - -delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs -delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars - = DV { dv_kvs = kvs `delDVarSetList` vars - , dv_tvs = tvs `delDVarSetList` vars - , dv_cvs = cvs `delVarSetList` vars } - -collect_cand_qtvs - :: TcType -- original type that we started recurring into; for errors - -> Bool -- True <=> consider every fv in Type to be dependent - -> VarSet -- Bound variables (locals only) - -> CandidatesQTvs -- Accumulating parameter - -> Type -- Not necessarily zonked - -> TcM CandidatesQTvs - --- Key points: --- * Looks through meta-tyvars as it goes; --- no need to zonk in advance --- --- * Needs to be monadic anyway, because it handles naughty --- quantification; see Note [Naughty quantification candidates] --- --- * Returns fully-zonked CandidateQTvs, including their kinds --- so that subsequent dependency analysis (to build a well --- scoped telescope) works correctly - -collect_cand_qtvs orig_ty is_dep bound dvs ty - = go dvs ty - where - is_bound tv = tv `elemVarSet` bound - - ----------------- - go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs - -- Uses accumulating-parameter style - go dv (AppTy t1 t2) = foldlM go dv [t1, t2] - go dv (TyConApp _ tys) = foldlM go dv tys - go dv (FunTy _ arg res) = foldlM go dv [arg, res] - go dv (LitTy {}) = return dv - go dv (CastTy ty co) = do dv1 <- go dv ty - collect_cand_qtvs_co orig_ty bound dv1 co - go dv (CoercionTy co) = collect_cand_qtvs_co orig_ty bound dv co - - go dv (TyVarTy tv) - | is_bound tv = return dv - | otherwise = do { m_contents <- isFilledMetaTyVar_maybe tv - ; case m_contents of - Just ind_ty -> go dv ind_ty - Nothing -> go_tv dv tv } - - go dv (ForAllTy (Bndr tv _) ty) - = do { dv1 <- collect_cand_qtvs orig_ty True bound dv (tyVarKind tv) - ; collect_cand_qtvs orig_ty is_dep (bound `extendVarSet` tv) dv1 ty } - - ----------------- - go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv - | tv `elemDVarSet` kvs - = return dv -- We have met this tyvar already - - | not is_dep - , tv `elemDVarSet` tvs - = return dv -- We have met this tyvar already - - | otherwise - = do { tv_kind <- zonkTcType (tyVarKind tv) - -- This zonk is annoying, but it is necessary, both to - -- ensure that the collected candidates have zonked kinds - -- (#15795) and to make the naughty check - -- (which comes next) works correctly - - ; let tv_kind_vars = tyCoVarsOfType tv_kind - ; cur_lvl <- getTcLevel - ; if | tcTyVarLevel tv <= cur_lvl - -> return dv -- this variable is from an outer context; skip - -- See Note [Use level numbers ofor quantification] - - | intersectsVarSet bound tv_kind_vars - -- the tyvar must not be from an outer context, but we have - -- already checked for this. - -- See Note [Naughty quantification candidates] - -> do { traceTc "Naughty quantifier" $ - vcat [ ppr tv <+> dcolon <+> ppr tv_kind - , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound) - , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet tv_kind_vars) ] - - ; let escapees = intersectVarSet bound tv_kind_vars - ; naughtyQuantification orig_ty tv escapees } - - | otherwise - -> do { let tv' = tv `setTyVarKind` tv_kind - dv' | is_dep = dv { dv_kvs = kvs `extendDVarSet` tv' } - | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' } - -- See Note [Order of accumulation] - - -- See Note [Recurring into kinds for candidateQTyVars] - ; collect_cand_qtvs orig_ty True bound dv' tv_kind } } - -collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors - -> VarSet -- bound variables - -> CandidatesQTvs -> Coercion - -> TcM CandidatesQTvs -collect_cand_qtvs_co orig_ty bound = go_co - where - go_co dv (Refl ty) = collect_cand_qtvs orig_ty True bound dv ty - go_co dv (GRefl _ ty mco) = do dv1 <- collect_cand_qtvs orig_ty True bound dv ty - go_mco dv1 mco - go_co dv (TyConAppCo _ _ cos) = foldlM go_co dv cos - go_co dv (AppCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (FunCo _ co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos - go_co dv (AxiomRuleCo _ cos) = foldlM go_co dv cos - go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov - dv2 <- collect_cand_qtvs orig_ty True bound dv1 t1 - collect_cand_qtvs orig_ty True bound dv2 t2 - go_co dv (SymCo co) = go_co dv co - go_co dv (TransCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (NthCo _ _ co) = go_co dv co - go_co dv (LRCo _ co) = go_co dv co - go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (KindCo co) = go_co dv co - go_co dv (SubCo co) = go_co dv co - - go_co dv (HoleCo hole) - = do m_co <- unpackCoercionHole_maybe hole - case m_co of - Just co -> go_co dv co - Nothing -> go_cv dv (coHoleCoVar hole) - - go_co dv (CoVarCo cv) = go_cv dv cv - - go_co dv (ForAllCo tcv kind_co co) - = do { dv1 <- go_co dv kind_co - ; collect_cand_qtvs_co orig_ty (bound `extendVarSet` tcv) dv1 co } - - go_mco dv MRefl = return dv - go_mco dv (MCo co) = go_co dv co - - go_prov dv (PhantomProv co) = go_co dv co - go_prov dv (ProofIrrelProv co) = go_co dv co - go_prov dv (PluginProv _) = return dv - - go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs - go_cv dv@(DV { dv_cvs = cvs }) cv - | is_bound cv = return dv - | cv `elemVarSet` cvs = return dv - - -- See Note [Recurring into kinds for candidateQTyVars] - | otherwise = collect_cand_qtvs orig_ty True bound - (dv { dv_cvs = cvs `extendVarSet` cv }) - (idType cv) - - is_bound tv = tv `elemVarSet` bound - -{- Note [Order of accumulation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might be tempted (like I was) to use unitDVarSet and mappend -rather than extendDVarSet. However, the union algorithm for -deterministic sets depends on (roughly) the size of the sets. The -elements from the smaller set end up to the right of the elements from -the larger one. When sets are equal, the left-hand argument to -`mappend` goes to the right of the right-hand argument. - -In our case, if we use unitDVarSet and mappend, we learn that the free -variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify -over them in that order. (The a comes after the b because we union the -singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter, -the size criterion works to our advantage.) This is just annoying to -users, so I use `extendDVarSet`, which unambiguously puts the new -element to the right. - -Note that the unitDVarSet/mappend implementation would not be wrong -against any specification -- just suboptimal and confounding to users. - -Note [Recurring into kinds for candidateQTyVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -First, read Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs, paying -attention to the end of the Note about using an empty bound set when -traversing a variable's kind. - -That Note concludes with the recommendation that we empty out the bound -set when recurring into the kind of a type variable. Yet, we do not do -this here. I have two tasks in order to convince you that this code is -right. First, I must show why it is safe to ignore the reasoning in that -Note. Then, I must show why is is necessary to contradict the reasoning in -that Note. - -Why it is safe: There can be no -shadowing in the candidateQ... functions: they work on the output of -type inference, which is seeded by the renamer and its insistence to -use different Uniques for different variables. (In contrast, the Core -functions work on the output of optimizations, which may introduce -shadowing.) Without shadowing, the problem studied by -Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs cannot happen. - -Why it is necessary: -Wiping the bound set would be just plain wrong here. Consider - - forall k1 k2 (a :: k1). Proxy k2 (a |> (hole :: k1 ~# k2)) - -We really don't want to think k1 and k2 are free here. (It's true that we'll -never be able to fill in `hole`, but we don't want to go off the rails just -because we have an insoluble coercion hole.) So: why is it wrong to wipe -the bound variables here but right in Core? Because the final statement -in Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs is wrong: not -every variable is either free or bound. A variable can be a hole, too! -The reasoning in that Note then breaks down. - -And the reasoning applies just as well to free non-hole variables, so we -retain the bound set always. - --} - -{- ********************************************************************* -* * - Quantification -* * -************************************************************************ - -Note [quantifyTyVars] -~~~~~~~~~~~~~~~~~~~~~ -quantifyTyVars is given the free vars of a type that we -are about to wrap in a forall. - -It takes these free type/kind variables (partitioned into dependent and -non-dependent variables) skolemises metavariables with a TcLevel greater -than the ambient level (see Note [Use level numbers of quantification]). - -* This function distinguishes between dependent and non-dependent - variables only to keep correct defaulting behavior with -XNoPolyKinds. - With -XPolyKinds, it treats both classes of variables identically. - -* quantifyTyVars never quantifies over - - a coercion variable (or any tv mentioned in the kind of a covar) - - a runtime-rep variable - -Note [Use level numbers for quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The level numbers assigned to metavariables are very useful. Not only -do they track touchability (Note [TcLevel and untouchable type variables] -in TcType), but they also allow us to determine which variables to -generalise. The rule is this: - - When generalising, quantify only metavariables with a TcLevel greater - than the ambient level. - -This works because we bump the level every time we go inside a new -source-level construct. In a traditional generalisation algorithm, we -would gather all free variables that aren't free in an environment. -However, if a variable is in that environment, it will always have a lower -TcLevel: it came from an outer scope. So we can replace the "free in -environment" check with a level-number check. - -Here is an example: - - f x = x + (z True) - where - z y = x * x - -We start by saying (x :: alpha[1]). When inferring the type of z, we'll -quickly discover that z :: alpha[1]. But it would be disastrous to -generalise over alpha in the type of z. So we need to know that alpha -comes from an outer environment. By contrast, the type of y is beta[2], -and we are free to generalise over it. What's the difference between -alpha[1] and beta[2]? Their levels. beta[2] has the right TcLevel for -generalisation, and so we generalise it. alpha[1] does not, and so -we leave it alone. - -Note that not *every* variable with a higher level will get generalised, -either due to the monomorphism restriction or other quirks. See, for -example, the code in TcSimplify.decideMonoTyVars and in -TcHsType.kindGeneralizeSome, both of which exclude certain otherwise-eligible -variables from being generalised. - -Using level numbers for quantification is implemented in the candidateQTyVars... -functions, by adding only those variables with a level strictly higher than -the ambient level to the set of candidates. - -Note [quantifyTyVars determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The results of quantifyTyVars are wrapped in a forall and can end up in the -interface file. One such example is inferred type signatures. They also affect -the results of optimizations, for example worker-wrapper. This means that to -get deterministic builds quantifyTyVars needs to be deterministic. - -To achieve this CandidatesQTvs is backed by deterministic sets which allows them -to be later converted to a list in a deterministic order. - -For more information about deterministic sets see -Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. --} - -quantifyTyVars - :: CandidatesQTvs -- See Note [Dependent type variables] - -- Already zonked - -> TcM [TcTyVar] --- See Note [quantifyTyVars] --- Can be given a mixture of TcTyVars and TyVars, in the case of --- associated type declarations. Also accepts covars, but *never* returns any. --- According to Note [Use level numbers for quantification] and the --- invariants on CandidateQTvs, we do not have to filter out variables --- free in the environment here. Just quantify unconditionally, subject --- to the restrictions in Note [quantifyTyVars]. -quantifyTyVars dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs }) - -- short-circuit common case - | isEmptyDVarSet dep_tkvs - , isEmptyDVarSet nondep_tkvs - = do { traceTc "quantifyTyVars has nothing to quantify" empty - ; return [] } - - | otherwise - = do { traceTc "quantifyTyVars 1" (ppr dvs) - - ; let dep_kvs = scopedSort $ dVarSetElems dep_tkvs - -- scopedSort: put the kind variables into - -- well-scoped order. - -- E.g. [k, (a::k)] not the other way round - - nondep_tvs = dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs) - -- See Note [Dependent type variables] - -- The `minus` dep_tkvs removes any kind-level vars - -- e.g. T k (a::k) Since k appear in a kind it'll - -- be in dv_kvs, and is dependent. So remove it from - -- dv_tvs which will also contain k - -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV - - -- In the non-PolyKinds case, default the kind variables - -- to *, and zonk the tyvars as usual. Notice that this - -- may make quantifyTyVars return a shorter list - -- than it was passed, but that's ok - ; poly_kinds <- xoptM LangExt.PolyKinds - ; dep_kvs' <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs - ; nondep_tvs' <- mapMaybeM (zonk_quant False) nondep_tvs - ; let final_qtvs = dep_kvs' ++ nondep_tvs' - -- Because of the order, any kind variables - -- mentioned in the kinds of the nondep_tvs' - -- now refer to the dep_kvs' - - ; traceTc "quantifyTyVars 2" - (vcat [ text "nondep:" <+> pprTyVars nondep_tvs - , text "dep:" <+> pprTyVars dep_kvs - , text "dep_kvs'" <+> pprTyVars dep_kvs' - , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ]) - - -- We should never quantify over coercion variables; check this - ; let co_vars = filter isCoVar final_qtvs - ; MASSERT2( null co_vars, ppr co_vars ) - - ; return final_qtvs } - where - -- zonk_quant returns a tyvar if it should be quantified over; - -- otherwise, it returns Nothing. The latter case happens for - -- * Kind variables, with -XNoPolyKinds: don't quantify over these - -- * RuntimeRep variables: we never quantify over these - zonk_quant default_kind tkv - | not (isTyVar tkv) - = return Nothing -- this can happen for a covar that's associated with - -- a coercion hole. Test case: typecheck/should_compile/T2494 - - | not (isTcTyVar tkv) - = return (Just tkv) -- For associated types in a class with a standalone - -- kind signature, we have the class variables in - -- scope, and they are TyVars not TcTyVars - | otherwise - = do { deflt_done <- defaultTyVar default_kind tkv - ; case deflt_done of - True -> return Nothing - False -> do { tv <- skolemiseQuantifiedTyVar tkv - ; return (Just tv) } } - -isQuantifiableTv :: TcLevel -- Level of the context, outside the quantification - -> TcTyVar - -> Bool -isQuantifiableTv outer_tclvl tcv - | isTcTyVar tcv -- Might be a CoVar; change this when gather covars separately - = tcTyVarLevel tcv > outer_tclvl - | otherwise - = False - -zonkAndSkolemise :: TcTyCoVar -> TcM TcTyCoVar --- A tyvar binder is never a unification variable (TauTv), --- rather it is always a skolem. It *might* be a TyVarTv. --- (Because non-CUSK type declarations use TyVarTvs.) --- Regardless, it may have a kind that has not yet been zonked, --- and may include kind unification variables. -zonkAndSkolemise tyvar - | isTyVarTyVar tyvar - -- We want to preserve the binding location of the original TyVarTv. - -- This is important for error messages. If we don't do this, then - -- we get bad locations in, e.g., typecheck/should_fail/T2688 - = do { zonked_tyvar <- zonkTcTyVarToTyVar tyvar - ; skolemiseQuantifiedTyVar zonked_tyvar } - - | otherwise - = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar ) - zonkTyCoVarKind tyvar - -skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar --- The quantified type variables often include meta type variables --- we want to freeze them into ordinary type variables --- The meta tyvar is updated to point to the new skolem TyVar. Now any --- bound occurrences of the original type variable will get zonked to --- the immutable version. --- --- We leave skolem TyVars alone; they are immutable. --- --- This function is called on both kind and type variables, --- but kind variables *only* if PolyKinds is on. - -skolemiseQuantifiedTyVar tv - = case tcTyVarDetails tv of - SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv) - ; return (setTyVarKind tv kind) } - -- It might be a skolem type variable, - -- for example from a user type signature - - MetaTv {} -> skolemiseUnboundMetaTyVar tv - - _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk - -defaultTyVar :: Bool -- True <=> please default this kind variable to * - -> TcTyVar -- If it's a MetaTyVar then it is unbound - -> TcM Bool -- True <=> defaulted away altogether - -defaultTyVar default_kind tv - | not (isMetaTyVar tv) - = return False - - | isTyVarTyVar tv - -- Do not default TyVarTvs. Doing so would violate the invariants - -- on TyVarTvs; see Note [Signature skolems] in TcType. - -- #13343 is an example; #14555 is another - -- See Note [Inferring kinds for type declarations] in TcTyClsDecls - = return False - - - | isRuntimeRepVar tv -- Do not quantify over a RuntimeRep var - -- unless it is a TyVarTv, handled earlier - = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) - ; writeMetaTyVar tv liftedRepTy - ; return True } - - | default_kind -- -XNoPolyKinds and this is a kind var - = default_kind_var tv -- so default it to * if possible - - | otherwise - = return False - - where - default_kind_var :: TyVar -> TcM Bool - -- defaultKindVar is used exclusively with -XNoPolyKinds - -- See Note [Defaulting with -XNoPolyKinds] - -- It takes an (unconstrained) meta tyvar and defaults it. - -- Works only on vars of type *; for other kinds, it issues an error. - default_kind_var kv - | isLiftedTypeKind (tyVarKind kv) - = do { traceTc "Defaulting a kind var to *" (ppr kv) - ; writeMetaTyVar kv liftedTypeKind - ; return True } - | otherwise - = do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') - , text "of kind:" <+> ppr (tyVarKind kv') - , text "Perhaps enable PolyKinds or add a kind signature" ]) - -- We failed to default it, so return False to say so. - -- Hence, it'll get skolemised. That might seem odd, but we must either - -- promote, skolemise, or zap-to-Any, to satisfy TcHsType - -- Note [Recipe for checking a signature] - -- Otherwise we get level-number assertion failures. It doesn't matter much - -- because we are in an error situation anyway. - ; return False - } - where - (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv - -skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar --- We have a Meta tyvar with a ref-cell inside it --- Skolemise it, so that we are totally out of Meta-tyvar-land --- We create a skolem TcTyVar, not a regular TyVar --- See Note [Zonking to Skolem] -skolemiseUnboundMetaTyVar tv - = ASSERT2( isMetaTyVar tv, ppr tv ) - do { when debugIsOn (check_empty tv) - ; here <- getSrcSpanM -- Get the location from "here" - -- ie where we are generalising - ; kind <- zonkTcType (tyVarKind tv) - ; let tv_name = tyVarName tv - -- See Note [Skolemising and identity] - final_name | isSystemName tv_name - = mkInternalName (nameUnique tv_name) - (nameOccName tv_name) here - | otherwise - = tv_name - final_tv = mkTcTyVar final_name kind details - - ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) - ; writeMetaTyVar tv (mkTyVarTy final_tv) - ; return final_tv } - - where - details = SkolemTv (metaTyVarTcLevel tv) False - check_empty tv -- [Sept 04] Check for non-empty. - = when debugIsOn $ -- See note [Silly Type Synonym] - do { cts <- readMetaTyVar tv - ; case cts of - Flexi -> return () - Indirect ty -> WARN( True, ppr tv $$ ppr ty ) - return () } - -{- Note [Defaulting with -XNoPolyKinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data Compose f g a = Mk (f (g a)) - -We infer - - Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> * - Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1). - f (g a) -> Compose k1 k2 f g a - -Now, in another module, we have -XNoPolyKinds -XDataKinds in effect. -What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds, -we just defaulted all kind variables to *. But that's no good here, -because the kind variables in 'Mk aren't of kind *, so defaulting to * -is ill-kinded. - -After some debate on #11334, we decided to issue an error in this case. -The code is in defaultKindVar. - -Note [What is a meta variable?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "meta type-variable", also know as a "unification variable" is a placeholder -introduced by the typechecker for an as-yet-unknown monotype. - -For example, when we see a call `reverse (f xs)`, we know that we calling - reverse :: forall a. [a] -> [a] -So we know that the argument `f xs` must be a "list of something". But what is -the "something"? We don't know until we explore the `f xs` a bit more. So we set -out what we do know at the call of `reverse` by instantiating its type with a fresh -meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the -result, is `[alpha]`. The unification variable `alpha` stands for the -as-yet-unknown type of the elements of the list. - -As type inference progresses we may learn more about `alpha`. For example, suppose -`f` has the type - f :: forall b. b -> [Maybe b] -Then we instantiate `f`'s type with another fresh unification variable, say -`beta`; and equate `f`'s result type with reverse's argument type, thus -`[alpha] ~ [Maybe beta]`. - -Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've -refined our knowledge about `alpha`. And so on. - -If you found this Note useful, you may also want to have a look at -Section 5 of "Practical type inference for higher rank types" (Peyton Jones, -Vytiniotis, Weirich and Shields. J. Functional Programming. 2011). - -Note [What is zonking?] -~~~~~~~~~~~~~~~~~~~~~~~ -GHC relies heavily on mutability in the typechecker for efficient operation. -For this reason, throughout much of the type checking process meta type -variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable -variables (known as TcRefs). - -Zonking is the process of ripping out these mutable variables and replacing them -with a real Type. This involves traversing the entire type expression, but the -interesting part of replacing the mutable variables occurs in zonkTyVarOcc. - -There are two ways to zonk a Type: - - * zonkTcTypeToType, which is intended to be used at the end of type-checking - for the final zonk. It has to deal with unfilled metavars, either by filling - it with a value like Any or failing (determined by the UnboundTyVarZonker - used). - - * zonkTcType, which will happily ignore unfilled metavars. This is the - appropriate function to use while in the middle of type-checking. - -Note [Zonking to Skolem] -~~~~~~~~~~~~~~~~~~~~~~~~ -We used to zonk quantified type variables to regular TyVars. However, this -leads to problems. Consider this program from the regression test suite: - - eval :: Int -> String -> String -> String - eval 0 root actual = evalRHS 0 root actual - - evalRHS :: Int -> a - evalRHS 0 root actual = eval 0 root actual - -It leads to the deferral of an equality (wrapped in an implication constraint) - - forall a. () => ((String -> String -> String) ~ a) - -which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck). -In the meantime `a' is zonked and quantified to form `evalRHS's signature. -This has the *side effect* of also zonking the `a' in the deferred equality -(which at this point is being handed around wrapped in an implication -constraint). - -Finally, the equality (with the zonked `a') will be handed back to the -simplifier by TcRnDriver.tcRnSrcDecls calling TcSimplify.tcSimplifyTop. -If we zonk `a' with a regular type variable, we will have this regular type -variable now floating around in the simplifier, which in many places assumes to -only see proper TcTyVars. - -We can avoid this problem by zonking with a skolem TcTyVar. The -skolem is rigid (which we require for a quantified variable), but is -still a TcTyVar that the simplifier knows how to deal with. - -Note [Skolemising and identity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some places, we make a TyVarTv for a binder. E.g. - class C a where ... -As Note [Inferring kinds for type declarations] discusses, -we make a TyVarTv for 'a'. Later we skolemise it, and we'd -like to retain its identity, location info etc. (If we don't -retain its identity we'll have to do some pointless swizzling; -see TcTyClsDecls.swizzleTcTyConBndrs. If we retain its identity -but not its location we'll lose the detailed binding site info. - -Conclusion: use the Name of the TyVarTv. But we don't want -to do that when skolemising random unification variables; -there the location we want is the skolemisation site. - -Fortunately we can tell the difference: random unification -variables have System Names. That's why final_name is -set based on the isSystemName test. - - -Note [Silly Type Synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - type C u a = u -- Note 'a' unused - - foo :: (forall a. C u a -> C u a) -> u - foo x = ... - - bar :: Num u => u - bar = foo (\t -> t + t) - -* From the (\t -> t+t) we get type {Num d} => d -> d - where d is fresh. - -* Now unify with type of foo's arg, and we get: - {Num (C d a)} => C d a -> C d a - where a is fresh. - -* Now abstract over the 'a', but float out the Num (C d a) constraint - because it does not 'really' mention a. (see exactTyVarsOfType) - The arg to foo becomes - \/\a -> \t -> t+t - -* So we get a dict binding for Num (C d a), which is zonked to give - a = () - [Note Sept 04: now that we are zonking quantified type variables - on construction, the 'a' will be frozen as a regular tyvar on - quantification, so the floated dict will still have type (C d a). - Which renders this whole note moot; happily!] - -* Then the \/\a abstraction has a zonked 'a' in it. - -All very silly. I think its harmless to ignore the problem. We'll end up with -a \/\a in the final result but all the occurrences of a will be zonked to () - -************************************************************************ -* * - Zonking types -* * -************************************************************************ - --} - -zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet --- Zonk a type and take its free variables --- With kind polymorphism it can be essential to zonk *first* --- so that we find the right set of free variables. Eg --- forall k1. forall (a:k2). a --- where k2:=k1 is in the substitution. We don't want --- k2 to look free in this type! -zonkTcTypeAndFV ty - = tyCoVarsOfTypeDSet <$> zonkTcType ty - -zonkTyCoVar :: TyCoVar -> TcM TcType --- Works on TyVars and TcTyVars -zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv - | isTyVar tv = mkTyVarTy <$> zonkTyCoVarKind tv - | otherwise = ASSERT2( isCoVar tv, ppr tv ) - mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv - -- Hackily, when typechecking type and class decls - -- we have TyVars in scope added (only) in - -- TcHsType.bindTyClTyVars, but it seems - -- painful to make them into TcTyVars there - -zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet -zonkTyCoVarsAndFV tycovars - = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars) - -- It's OK to use nonDetEltsUniqSet here because we immediately forget about - -- the ordering by turning it into a nondeterministic set and the order - -- of zonking doesn't matter for determinism. - -zonkDTyCoVarSetAndFV :: DTyCoVarSet -> TcM DTyCoVarSet -zonkDTyCoVarSetAndFV tycovars - = mkDVarSet <$> (zonkTyCoVarsAndFVList $ dVarSetElems tycovars) - --- Takes a list of TyCoVars, zonks them and returns a --- deterministically ordered list of their free variables. -zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar] -zonkTyCoVarsAndFVList tycovars - = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars - -zonkTcTyVars :: [TcTyVar] -> TcM [TcType] -zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars - ------------------ Types -zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar -zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) - ; return (setTyVarKind tv kind') } - -{- -************************************************************************ -* * - Zonking constraints -* * -************************************************************************ --} - -zonkImplication :: Implication -> TcM Implication -zonkImplication implic@(Implic { ic_skols = skols - , ic_given = given - , ic_wanted = wanted - , ic_info = info }) - = do { skols' <- mapM zonkTyCoVarKind skols -- Need to zonk their kinds! - -- as #7230 showed - ; given' <- mapM zonkEvVar given - ; info' <- zonkSkolemInfo info - ; wanted' <- zonkWCRec wanted - ; return (implic { ic_skols = skols' - , ic_given = given' - , ic_wanted = wanted' - , ic_info = info' }) } - -zonkEvVar :: EvVar -> TcM EvVar -zonkEvVar var = do { ty' <- zonkTcType (varType var) - ; return (setVarType var ty') } - - -zonkWC :: WantedConstraints -> TcM WantedConstraints -zonkWC wc = zonkWCRec wc - -zonkWCRec :: WantedConstraints -> TcM WantedConstraints -zonkWCRec (WC { wc_simple = simple, wc_impl = implic }) - = do { simple' <- zonkSimples simple - ; implic' <- mapBagM zonkImplication implic - ; return (WC { wc_simple = simple', wc_impl = implic' }) } - -zonkSimples :: Cts -> TcM Cts -zonkSimples cts = do { cts' <- mapBagM zonkCt cts - ; traceTc "zonkSimples done:" (ppr cts') - ; return cts' } - -{- Note [zonkCt behaviour] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -zonkCt tries to maintain the canonical form of a Ct. For example, - - a CDictCan should stay a CDictCan; - - a CHoleCan should stay a CHoleCan - - a CIrredCan should stay a CIrredCan with its cc_status flag intact - -Why?, for example: -- For CDictCan, the @TcSimplify.expandSuperClasses@ step, which runs after the - simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use, - constraints are zonked before being passed to the plugin. This means if we - don't preserve a canonical form, @expandSuperClasses@ fails to expand - superclasses. This is what happened in #11525. - -- For CHoleCan, once we forget that it's a hole, we can never recover that info. - -- For CIrredCan we want to see if a constraint is insoluble with insolubleWC - -On the other hand, we change CTyEqCan to CNonCanonical, because of all of -CTyEqCan's invariants, which can break during zonking. Besides, the constraint -will be canonicalised again, so there is little benefit in keeping the -CTyEqCan structure. - -NB: we do not expect to see any CFunEqCans, because zonkCt is only -called on unflattened constraints. - -NB: Constraints are always re-flattened etc by the canonicaliser in -@TcCanonical@ even if they come in as CDictCan. Only canonical constraints that -are actually in the inert set carry all the guarantees. So it is okay if zonkCt -creates e.g. a CDictCan where the cc_tyars are /not/ function free. --} - -zonkCt :: Ct -> TcM Ct --- See Note [zonkCt behaviour] -zonkCt ct@(CHoleCan { cc_ev = ev }) - = do { ev' <- zonkCtEvidence ev - ; return $ ct { cc_ev = ev' } } - -zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args }) - = do { ev' <- zonkCtEvidence ev - ; args' <- mapM zonkTcType args - ; return $ ct { cc_ev = ev', cc_tyargs = args' } } - -zonkCt (CTyEqCan { cc_ev = ev }) - = mkNonCanonical <$> zonkCtEvidence ev - -zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_status flag - = do { ev' <- zonkCtEvidence ev - ; return (ct { cc_ev = ev' }) } - -zonkCt ct - = ASSERT( not (isCFunEqCan ct) ) - -- We do not expect to see any CFunEqCans, because zonkCt is only called on - -- unflattened constraints. - do { fl' <- zonkCtEvidence (ctEvidence ct) - ; return (mkNonCanonical fl') } - -zonkCtEvidence :: CtEvidence -> TcM CtEvidence -zonkCtEvidence ctev@(CtGiven { ctev_pred = pred }) - = do { pred' <- zonkTcType pred - ; return (ctev { ctev_pred = pred'}) } -zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest }) - = do { pred' <- zonkTcType pred - ; let dest' = case dest of - EvVarDest ev -> EvVarDest $ setVarType ev pred' - -- necessary in simplifyInfer - HoleDest h -> HoleDest h - ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) } -zonkCtEvidence ctev@(CtDerived { ctev_pred = pred }) - = do { pred' <- zonkTcType pred - ; return (ctev { ctev_pred = pred' }) } - -zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo -zonkSkolemInfo (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty - ; return (SigSkol cx ty' tv_prs) } -zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys - ; return (InferSkol ntys') } - where - do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } -zonkSkolemInfo skol_info = return skol_info - -{- -%************************************************************************ -%* * -\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar} -* * -* For internal use only! * -* * -************************************************************************ - --} - --- For unbound, mutable tyvars, zonkType uses the function given to it --- For tyvars bound at a for-all, zonkType zonks them to an immutable --- type variable and zonks the kind too -zonkTcType :: TcType -> TcM TcType -zonkTcTypes :: [TcType] -> TcM [TcType] -zonkCo :: Coercion -> TcM Coercion - -(zonkTcType, zonkTcTypes, zonkCo, _) - = mapTyCo zonkTcTypeMapper - --- | A suitable TyCoMapper for zonking a type during type-checking, --- before all metavars are filled in. -zonkTcTypeMapper :: TyCoMapper () TcM -zonkTcTypeMapper = TyCoMapper - { tcm_tyvar = const zonkTcTyVar - , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv) - , tcm_hole = hole - , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv - , tcm_tycon = zonkTcTyCon } - where - hole :: () -> CoercionHole -> TcM Coercion - hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) - = do { contents <- readTcRef ref - ; case contents of - Just co -> do { co' <- zonkCo co - ; checkCoercionHole cv co' } - Nothing -> do { cv' <- zonkCoVar cv - ; return $ HoleCo (hole { ch_co_var = cv' }) } } - -zonkTcTyCon :: TcTyCon -> TcM TcTyCon --- Only called on TcTyCons --- A non-poly TcTyCon may have unification --- variables that need zonking, but poly ones cannot -zonkTcTyCon tc - | tcTyConIsPoly tc = return tc - | otherwise = do { tck' <- zonkTcType (tyConKind tc) - ; return (setTcTyConKind tc tck') } - -zonkTcTyVar :: TcTyVar -> TcM TcType --- Simply look through all Flexis -zonkTcTyVar tv - | isTcTyVar tv - = case tcTyVarDetails tv of - SkolemTv {} -> zonk_kind_and_return - RuntimeUnk {} -> zonk_kind_and_return - MetaTv { mtv_ref = ref } - -> do { cts <- readMutVar ref - ; case cts of - Flexi -> zonk_kind_and_return - Indirect ty -> do { zty <- zonkTcType ty - ; writeTcRef ref (Indirect zty) - -- See Note [Sharing in zonking] - ; return zty } } - - | otherwise -- coercion variable - = zonk_kind_and_return - where - zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv - ; return (mkTyVarTy z_tv) } - --- Variant that assumes that any result of zonking is still a TyVar. --- Should be used only on skolems and TyVarTvs -zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar -zonkTcTyVarToTyVar tv - = do { ty <- zonkTcTyVar tv - ; let tv' = case tcGetTyVar_maybe ty of - Just tv' -> tv' - Nothing -> pprPanic "zonkTcTyVarToTyVar" - (ppr tv $$ ppr ty) - ; return tv' } - -zonkTyVarTyVarPairs :: [(Name,TcTyVar)] -> TcM [(Name,TcTyVar)] -zonkTyVarTyVarPairs prs - = mapM do_one prs - where - do_one (nm, tv) = do { tv' <- zonkTcTyVarToTyVar tv - ; return (nm, tv') } - --- zonkId is used *during* typechecking just to zonk the Id's type -zonkId :: TcId -> TcM TcId -zonkId id - = do { ty' <- zonkTcType (idType id) - ; return (Id.setIdType id ty') } - -zonkCoVar :: CoVar -> TcM CoVar -zonkCoVar = zonkId - -{- Note [Sharing in zonking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - alpha :-> beta :-> gamma :-> ty -where the ":->" means that the unification variable has been -filled in with Indirect. Then when zonking alpha, it'd be nice -to short-circuit beta too, so we end up with - alpha :-> zty - beta :-> zty - gamma :-> zty -where zty is the zonked version of ty. That way, if we come across -beta later, we'll have less work to do. (And indeed the same for -alpha.) - -This is easily achieved: just overwrite (Indirect ty) with (Indirect -zty). Non-systematic perf comparisons suggest that this is a modest -win. - -But c.f Note [Sharing when zonking to Type] in TcHsSyn. - -%************************************************************************ -%* * - Tidying -* * -************************************************************************ --} - -zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) -zonkTidyTcType env ty = do { ty' <- zonkTcType ty - ; return (tidyOpenType env ty') } - -zonkTidyTcTypes :: TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType]) -zonkTidyTcTypes = zonkTidyTcTypes' [] - where zonkTidyTcTypes' zs env [] = return (env, reverse zs) - zonkTidyTcTypes' zs env (ty:tys) - = do { (env', ty') <- zonkTidyTcType env ty - ; zonkTidyTcTypes' (ty':zs) env' tys } - -zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin) -zonkTidyOrigin env (GivenOrigin skol_info) - = do { skol_info1 <- zonkSkolemInfo skol_info - ; let skol_info2 = tidySkolemInfo env skol_info1 - ; return (env, GivenOrigin skol_info2) } -zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act - , uo_expected = exp }) - = do { (env1, act') <- zonkTidyTcType env act - ; (env2, exp') <- zonkTidyTcType env1 exp - ; return ( env2, orig { uo_actual = act' - , uo_expected = exp' }) } -zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k) - = do { (env1, ty1') <- zonkTidyTcType env ty1 - ; (env2, m_ty2') <- case m_ty2 of - Just ty2 -> second Just <$> zonkTidyTcType env1 ty2 - Nothing -> return (env1, Nothing) - ; (env3, orig') <- zonkTidyOrigin env2 orig - ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) } -zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) - = do { (env1, p1') <- zonkTidyTcType env p1 - ; (env2, p2') <- zonkTidyTcType env1 p2 - ; return (env2, FunDepOrigin1 p1' o1 l1 p2' o2 l2) } -zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) - = do { (env1, p1') <- zonkTidyTcType env p1 - ; (env2, p2') <- zonkTidyTcType env1 p2 - ; (env3, o1') <- zonkTidyOrigin env2 o1 - ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } -zonkTidyOrigin env orig = return (env, orig) - ----------------- -tidyCt :: TidyEnv -> Ct -> Ct --- Used only in error reporting -tidyCt env ct - = ct { cc_ev = tidy_ev env (ctEvidence ct) } - where - tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence - -- NB: we do not tidy the ctev_evar field because we don't - -- show it in error messages - tidy_ev env ctev@(CtGiven { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - tidy_ev env ctev@(CtWanted { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - tidy_ev env ctev@(CtDerived { ctev_pred = pred }) - = ctev { ctev_pred = tidyType env pred } - ----------------- -tidyEvVar :: TidyEnv -> EvVar -> EvVar -tidyEvVar env var = setVarType var (tidyType env (varType var)) - ----------------- -tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo -tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty) -tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs -tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) -tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) -tidySkolemInfo _ info = info - -tidySigSkol :: TidyEnv -> UserTypeCtxt - -> TcType -> [(Name,TcTyVar)] -> SkolemInfo --- We need to take special care when tidying SigSkol --- See Note [SigSkol SkolemInfo] in Origin -tidySigSkol env cx ty tv_prs - = SigSkol cx (tidy_ty env ty) tv_prs' - where - tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs - inst_env = mkNameEnv tv_prs' - - tidy_ty env (ForAllTy (Bndr tv vis) ty) - = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) - where - (env', tv') = tidy_tv_bndr env tv - - tidy_ty env ty@(FunTy _ arg res) - = ty { ft_arg = tidyType env arg, ft_res = tidy_ty env res } - - tidy_ty env ty = tidyType env ty - - tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) - tidy_tv_bndr env@(occ_env, subst) tv - | Just tv' <- lookupNameEnv inst_env (tyVarName tv) - = ((occ_env, extendVarEnv subst tv tv'), tv') - - | otherwise - = tidyVarBndr env tv - -------------------------------------------------------------------------- -{- -%************************************************************************ -%* * - Levity polymorphism checks -* * -************************************************************************* - -See Note [Levity polymorphism checking] in GHC.HsToCore.Monad - --} - --- | According to the rules around representation polymorphism --- (see https://gitlab.haskell.org/ghc/ghc/wikis/no-sub-kinds), no binder --- can have a representation-polymorphic type. This check ensures --- that we respect this rule. It is a bit regrettable that this error --- occurs in zonking, after which we should have reported all errors. --- But it's hard to see where else to do it, because this can be discovered --- only after all solving is done. And, perhaps most importantly, this --- isn't really a compositional property of a type system, so it's --- not a terrible surprise that the check has to go in an awkward spot. -ensureNotLevPoly :: Type -- its zonked type - -> SDoc -- where this happened - -> TcM () -ensureNotLevPoly ty doc - = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type - -- forall a. a. See, for example, test ghci/scripts/T9140 - checkForLevPoly doc ty - - -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad -checkForLevPoly :: SDoc -> Type -> TcM () -checkForLevPoly = checkForLevPolyX addErr - -checkForLevPolyX :: Monad m - => (SDoc -> m ()) -- how to report an error - -> SDoc -> Type -> m () -checkForLevPolyX add_err extra ty - | isTypeLevPoly ty - = add_err (formatLevPolyErr ty $$ extra) - | otherwise - = return () - -formatLevPolyErr :: Type -- levity-polymorphic type - -> SDoc -formatLevPolyErr ty - = hang (text "A levity-polymorphic type is not allowed here:") - 2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty - , text "Kind:" <+> pprWithTYPE tidy_ki ]) - where - (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty - tidy_ki = tidyType tidy_env (tcTypeKind ty) - -{- -%************************************************************************ -%* * - Error messages -* * -************************************************************************* - --} - --- See Note [Naughty quantification candidates] -naughtyQuantification :: TcType -- original type user wanted to quantify - -> TcTyVar -- naughty var - -> TyVarSet -- skolems that would escape - -> TcM a -naughtyQuantification orig_ty tv escapees - = do { orig_ty1 <- zonkTcType orig_ty -- in case it's not zonked - - ; escapees' <- mapM zonkTcTyVarToTyVar $ - nonDetEltsUniqSet escapees - -- we'll just be printing, so no harmful non-determinism - - ; let fvs = tyCoVarsOfTypeWellScoped orig_ty1 - env0 = tidyFreeTyCoVars emptyTidyEnv fvs - env = env0 `delTidyEnvList` escapees' - -- this avoids gratuitous renaming of the escaped - -- variables; very confusing to users! - - orig_ty' = tidyType env orig_ty1 - ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env) - doc = pprWithExplicitKindsWhen True $ - vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees' - , quotes $ ppr_tidied escapees' - , text "would escape" <+> itsOrTheir escapees' <+> text "scope" - ] - , sep [ text "if I tried to quantify" - , ppr_tidied [tv] - , text "in this type:" - ] - , nest 2 (pprTidiedType orig_ty') - , text "(Indeed, I sometimes struggle even printing this correctly," - , text " due to its ill-scoped nature.)" - ] - - ; failWithTcM (env, doc) } diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs deleted file mode 100644 index a3f2649039..0000000000 --- a/compiler/typecheck/TcMatches.hs +++ /dev/null @@ -1,1113 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcMatches: Typecheck some @Matches@ --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, - TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker, - tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, - tcDoStmt, tcGuardStmt - ) where - -import GhcPrelude - -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho - , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr ) - -import GHC.Types.Basic (LexicalFixity(..)) -import GHC.Hs -import TcRnMonad -import TcEnv -import TcPat -import TcMType -import TcType -import TcBinds -import TcUnify -import TcOrigin -import GHC.Types.Name -import TysWiredIn -import GHC.Types.Id -import GHC.Core.TyCon -import TysPrim -import TcEvidence -import Outputable -import Util -import GHC.Types.SrcLoc - --- Create chunkified tuple tybes for monad comprehensions -import GHC.Core.Make - -import Control.Monad -import Control.Arrow ( second ) - -#include "HsVersions.h" - -{- -************************************************************************ -* * -\subsection{tcMatchesFun, tcMatchesCase} -* * -************************************************************************ - -@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a -@FunMonoBind@. The second argument is the name of the function, which -is used in error messages. It checks that all the equations have the -same number of arguments before using @tcMatches@ to do the work. - -Note [Polymorphic expected type for tcMatchesFun] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcMatchesFun may be given a *sigma* (polymorphic) type -so it must be prepared to use tcSkolemise to skolemise it. -See Note [sig_tau may be polymorphic] in TcPat. --} - -tcMatchesFun :: Located Name - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpSigmaType -- Expected type of function - -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)) - -- Returns type of body -tcMatchesFun fn@(L _ fun_name) matches exp_ty - = do { -- Check that they all have the same no of arguments - -- Location is in the monad, set the caller so that - -- any inter-equation error messages get some vaguely - -- sensible location. Note: we have to do this odd - -- ann-grabbing, because we don't always have annotations in - -- hand when we call tcMatchesFun... - traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty) - ; checkArgs fun_name matches - - ; (wrap_gen, (wrap_fun, group)) - <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho -> - -- Note [Polymorphic expected type for tcMatchesFun] - do { (matches', wrap_fun) - <- matchExpectedFunTys herald arity exp_rho $ - \ pat_tys rhs_ty -> - tcMatches match_ctxt pat_tys rhs_ty matches - ; return (wrap_fun, matches') } - ; return (wrap_gen <.> wrap_fun, group) } - where - arity = matchGroupArity matches - herald = text "The equation(s) for" - <+> quotes (ppr fun_name) <+> text "have" - what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness } - match_ctxt = MC { mc_what = what, mc_body = tcBody } - strictness - | [L _ match] <- unLoc $ mg_alts matches - , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match - = SrcStrict - | otherwise - = NoSrcStrict - -{- -@tcMatchesCase@ doesn't do the argument-count check because the -parser guarantees that each equation has exactly one argument. --} - -tcMatchesCase :: (Outputable (body GhcRn)) => - TcMatchCtxt body -- Case context - -> TcSigmaType -- Type of scrutinee - -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives - -> ExpRhoType -- Type of whole case expressions - -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) - -- Translated alternatives - -- wrapper goes from MatchGroup's ty to expected ty - -tcMatchesCase ctxt scrut_ty matches res_ty - = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches - -tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify - -> TcMatchCtxt HsExpr - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpRhoType -- deeply skolemised - -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper) -tcMatchLambda herald match_ctxt match res_ty - = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty -> - tcMatches match_ctxt pat_tys rhs_ty match - where - n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case - | otherwise = matchGroupArity match - --- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. - -tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType - -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId)) --- Used for pattern bindings -tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty) - where - match_ctxt = MC { mc_what = PatBindRhs, - mc_body = tcBody } - -{- -************************************************************************ -* * -\subsection{tcMatch} -* * -************************************************************************ - -Note [Case branches must never infer a non-tau type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - case ... of - ... -> \(x :: forall a. a -> a) -> x - ... -> \y -> y - -Should that type-check? The problem is that, if we check the second branch -first, then we'll get a type (b -> b) for the branches, which won't unify -with the polytype in the first branch. If we check the first branch first, -then everything is OK. This order-dependency is terrible. So we want only -proper tau-types in branches (unless a sigma-type is pushed down). -This is what expTypeToType ensures: it replaces an Infer with a fresh -tau-type. - -An even trickier case looks like - - f x True = x undefined - f x False = x () - -Here, we see that the arguments must also be non-Infer. Thus, we must -use expTypeToType on the output of matchExpectedFunTys, not the input. - -But we make a special case for a one-branch case. This is so that - - f = \(x :: forall a. a -> a) -> x - -still gets assigned a polytype. --} - --- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the --- expected type into TauTvs. --- See Note [Case branches must never infer a non-tau type] -tauifyMultipleMatches :: [LMatch id body] - -> [ExpType] -> TcM [ExpType] -tauifyMultipleMatches group exp_tys - | isSingletonMatchGroup group = return exp_tys - | otherwise = mapM tauifyExpType exp_tys - -- NB: In the empty-match case, this ensures we fill in the ExpType - --- | Type-check a MatchGroup. -tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body - -> [ExpSigmaType] -- Expected pattern types - -> ExpRhoType -- Expected result-type of the Match. - -> MatchGroup GhcRn (Located (body GhcRn)) - -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) - -data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module - = MC { mc_what :: HsMatchContext GhcRn, -- What kind of thing this is - mc_body :: Located (body GhcRn) -- Type checker for a body of - -- an alternative - -> ExpRhoType - -> TcM (Located (body GhcTcId)) } - -tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches - , mg_origin = origin }) - = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys) - -- See Note [Case branches must never infer a non-tau type] - - ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches - ; pat_tys <- mapM readExpType pat_tys - ; rhs_ty <- readExpType rhs_ty - ; return (MG { mg_alts = L l matches' - , mg_ext = MatchGroupTc pat_tys rhs_ty - , mg_origin = origin }) } -tcMatches _ _ _ (XMatchGroup nec) = noExtCon nec - -------------- -tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body - -> [ExpSigmaType] -- Expected pattern types - -> ExpRhoType -- Expected result-type of the Match. - -> LMatch GhcRn (Located (body GhcRn)) - -> TcM (LMatch GhcTcId (Located (body GhcTcId))) - -tcMatch ctxt pat_tys rhs_ty match - = wrapLocM (tc_match ctxt pat_tys rhs_ty) match - where - tc_match ctxt pat_tys rhs_ty - match@(Match { m_pats = pats, m_grhss = grhss }) - = add_match_ctxt match $ - do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ - tcGRHSs ctxt grhss rhs_ty - ; return (Match { m_ext = noExtField - , m_ctxt = mc_what ctxt, m_pats = pats' - , m_grhss = grhss' }) } - tc_match _ _ _ (XMatch nec) = noExtCon nec - - -- For (\x -> e), tcExpr has already said "In the expression \x->e" - -- so we don't want to add "In the lambda abstraction \x->e" - add_match_ctxt match thing_inside - = case mc_what ctxt of - LambdaExpr -> thing_inside - _ -> addErrCtxt (pprMatchInCtxt match) thing_inside - -------------- -tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType - -> TcM (GRHSs GhcTcId (Located (body GhcTcId))) - --- Notice that we pass in the full res_ty, so that we get --- good inference from simple things like --- f = \(x::forall a.a->a) -> <stuff> --- We used to force it to be a monotype when there was more than one guard --- but we don't need to do that any more - -tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty - = do { (binds', grhss') - <- tcLocalBinds binds $ - mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss - - ; return (GRHSs noExtField grhss' (L l binds')) } -tcGRHSs _ (XGRHSs nec) _ = noExtCon nec - -------------- -tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn)) - -> TcM (GRHS GhcTcId (Located (body GhcTcId))) - -tcGRHS ctxt res_ty (GRHS _ guards rhs) - = do { (guards', rhs') - <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ - mc_body ctxt rhs - ; return (GRHS noExtField guards' rhs') } - where - stmt_ctxt = PatGuard (mc_what ctxt) -tcGRHS _ _ (XGRHS nec) = noExtCon nec - -{- -************************************************************************ -* * -\subsection{@tcDoStmts@ typechecks a {\em list} of do statements} -* * -************************************************************************ --} - -tcDoStmts :: HsStmtContext GhcRn - -> Located [LStmt GhcRn (LHsExpr GhcRn)] - -> ExpRhoType - -> TcM (HsExpr GhcTcId) -- Returns a HsDo -tcDoStmts ListComp (L l stmts) res_ty - = do { res_ty <- expTypeToType res_ty - ; (co, elt_ty) <- matchExpectedListTy res_ty - ; let list_ty = mkListTy elt_ty - ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts - (mkCheckExpType elt_ty) - ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) } - -tcDoStmts DoExpr (L l stmts) res_ty - = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo res_ty DoExpr (L l stmts')) } - -tcDoStmts MDoExpr (L l stmts) res_ty - = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo res_ty MDoExpr (L l stmts')) } - -tcDoStmts MonadComp (L l stmts) res_ty - = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo res_ty MonadComp (L l stmts')) } - -tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) - -tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId) -tcBody body res_ty - = do { traceTc "tcBody" (ppr res_ty) - ; tcMonoExpr body res_ty - } - -{- -************************************************************************ -* * -\subsection{tcStmts} -* * -************************************************************************ --} - -type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType -type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType - -type TcStmtChecker body rho_type - = forall thing. HsStmtContext GhcRn - -> Stmt GhcRn (Located (body GhcRn)) - -> rho_type -- Result type for comprehension - -> (rho_type -> TcM thing) -- Checker for what follows the stmt - -> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing) - -tcStmts :: (Outputable (body GhcRn)) => HsStmtContext GhcRn - -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt GhcRn (Located (body GhcRn))] - -> rho_type - -> TcM [LStmt GhcTcId (Located (body GhcTcId))] -tcStmts ctxt stmt_chk stmts res_ty - = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ - const (return ()) - ; return stmts' } - -tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext GhcRn - -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt GhcRn (Located (body GhcRn))] - -> rho_type - -> (rho_type -> TcM thing) - -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing) - --- Note the higher-rank type. stmt_chk is applied at different --- types in the equations for tcStmts - -tcStmtsAndThen _ _ [] res_ty thing_inside - = do { thing <- thing_inside res_ty - ; return ([], thing) } - --- LetStmts are handled uniformly, regardless of context -tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts) - res_ty thing_inside - = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ - tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside - ; return (L loc (LetStmt x (L l binds')) : stmts', thing) } - --- Don't set the error context for an ApplicativeStmt. It ought to be --- possible to do this with a popErrCtxt in the tcStmt case for --- ApplicativeStmt, but it did something strange and broke a test (ado002). -tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside - | ApplicativeStmt{} <- stmt - = do { (stmt', (stmts', thing)) <- - stmt_chk ctxt stmt res_ty $ \ res_ty' -> - tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ - thing_inside - ; return (L loc stmt' : stmts', thing) } - - -- For the vanilla case, handle the location-setting part - | otherwise - = do { (stmt', (stmts', thing)) <- - setSrcSpan loc $ - addErrCtxt (pprStmtInCtxt ctxt stmt) $ - stmt_chk ctxt stmt res_ty $ \ res_ty' -> - popErrCtxt $ - tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ - thing_inside - ; return (L loc stmt' : stmts', thing) } - ---------------------------------------------------- --- Pattern guards ---------------------------------------------------- - -tcGuardStmt :: TcExprStmtChecker -tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside - = do { guard' <- tcMonoExpr guard (mkCheckExpType boolTy) - ; thing <- thing_inside res_ty - ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } - -tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside - = do { (rhs', rhs_ty) <- tcInferRhoNC rhs - -- Stmt has a context already - ; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) - pat (mkCheckExpType rhs_ty) $ - thing_inside res_ty - ; return (mkTcBindStmt pat' rhs', thing) } - -tcGuardStmt _ stmt _ _ - = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt) - - ---------------------------------------------------- --- List comprehensions --- (no rebindable syntax) ---------------------------------------------------- - --- Dealt with separately, rather than by tcMcStmt, because --- a) We have special desugaring rules for list comprehensions, --- which avoid creating intermediate lists. They in turn --- assume that the bind/return operations are the regular --- polymorphic ones, and in particular don't have any --- coercion matching stuff in them. It's hard to avoid the --- potential for non-trivial coercions in tcMcStmt - -tcLcStmt :: TyCon -- The list type constructor ([]) - -> TcExprStmtChecker - -tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside - = do { body' <- tcMonoExprNC body elt_ty - ; thing <- thing_inside (panic "tcLcStmt: thing_inside") - ; return (LastStmt x body' noret noSyntaxExpr, thing) } - --- A generator, pat <- rhs -tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside - = do { pat_ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty]) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - thing_inside elt_ty - ; return (mkTcBindStmt pat' rhs', thing) } - --- A boolean guard -tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside - = do { rhs' <- tcMonoExpr rhs (mkCheckExpType boolTy) - ; thing <- thing_inside elt_ty - ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } - --- ParStmt: See notes with tcMcStmt -tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside - = do { (pairs', thing) <- loop bndr_stmts_s - ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) } - where - -- loop :: [([LStmt GhcRn], [GhcRn])] - -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing) - loop [] = do { thing <- thing_inside elt_ty - ; return ([], thing) } -- matching in the branches - - loop (ParStmtBlock x stmts names _ : pairs) - = do { (stmts', (ids, pairs', thing)) - <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> - do { ids <- tcLookupLocalIds names - ; (pairs', thing) <- loop pairs - ; return (ids, pairs', thing) } - ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) } - loop (XParStmtBlock nec:_) = noExtCon nec - -tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts - , trS_bndrs = bindersMap - , trS_by = by, trS_using = using }) elt_ty thing_inside - = do { let (bndr_names, n_bndr_names) = unzip bindersMap - unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) - -- The inner 'stmts' lack a LastStmt, so the element type - -- passed in to tcStmtsAndThen is never looked at - ; (stmts', (bndr_ids, by')) - <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do - { by' <- traverse tcInferRho by - ; bndr_ids <- tcLookupLocalIds bndr_names - ; return (bndr_ids, by') } - - ; let m_app ty = mkTyConApp m_tc [ty] - - --------------- Typecheck the 'using' function ------------- - -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm) - -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm) - - -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm - ; let n_app = case form of - ThenForm -> (\ty -> ty) - _ -> m_app - - by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present - by_arrow = case by' of - Nothing -> \ty -> ty - Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTy` e_ty) `mkVisFunTy` ty - - tup_ty = mkBigCoreVarTupTy bndr_ids - poly_arg_ty = m_app alphaTy - poly_res_ty = m_app (n_app alphaTy) - using_poly_ty = mkInvForAllTy alphaTyVar $ - by_arrow $ - poly_arg_ty `mkVisFunTy` poly_res_ty - - ; using' <- tcPolyExpr using using_poly_ty - ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' - - -- 'stmts' returns a result of type (m1_ty tuple_ty), - -- typically something like [(Int,Bool,Int)] - -- We don't know what tuple_ty is yet, so we use a variable - ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) - - -- Ensure that every old binder of type `b` is linked up with its - -- new binder which should have type `n b` - -- See Note [GroupStmt binder map] in GHC.Hs.Expr - n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids - bindersMap' = bndr_ids `zip` n_bndr_ids - - -- Type check the thing in the environment with - -- these new binders and return the result - ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty) - - ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' - , trS_by = fmap fst by', trS_using = final_using - , trS_ret = noSyntaxExpr - , trS_bind = noSyntaxExpr - , trS_fmap = noExpr - , trS_ext = unitTy - , trS_form = form }, thing) } - -tcLcStmt _ _ stmt _ _ - = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) - - ---------------------------------------------------- --- Monad comprehensions --- (supports rebindable syntax) ---------------------------------------------------- - -tcMcStmt :: TcExprStmtChecker - -tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside - = do { (body', return_op') - <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $ - \ [a_ty] -> - tcMonoExprNC body (mkCheckExpType a_ty) - ; thing <- thing_inside (panic "tcMcStmt: thing_inside") - ; return (LastStmt x body' noret return_op', thing) } - --- Generators for monad comprehensions ( pat <- rhs ) --- --- [ body | q <- gen ] -> gen :: m a --- q :: a --- - -tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside - -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty - = do { ((rhs', pat', thing, new_res_ty), bind_op') - <- tcSyntaxOp MCompOrigin bind_op - [SynRho, SynFun SynAny SynRho] res_ty $ - \ [rhs_ty, pat_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat - (mkCheckExpType pat_ty) $ - thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', pat', thing, new_res_ty) } - - -- If (but only if) the pattern can fail, typecheck the 'fail' operator - ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty - - ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) } - --- Boolean expressions. --- --- [ body | stmts, expr ] -> expr :: m Bool --- -tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside - = do { -- Deal with rebindable syntax: - -- guard_op :: test_ty -> rhs_ty - -- then_op :: rhs_ty -> new_res_ty -> res_ty - -- Where test_ty is, for example, Bool - ; ((thing, rhs', rhs_ty, guard_op'), then_op') - <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $ - \ [rhs_ty, new_res_ty] -> - do { (rhs', guard_op') - <- tcSyntaxOp MCompOrigin guard_op [SynAny] - (mkCheckExpType rhs_ty) $ - \ [test_ty] -> - tcMonoExpr rhs (mkCheckExpType test_ty) - ; thing <- thing_inside (mkCheckExpType new_res_ty) - ; return (thing, rhs', rhs_ty, guard_op') } - ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) } - --- Grouping statements --- --- [ body | stmts, then group by e using f ] --- -> e :: t --- f :: forall a. (a -> t) -> m a -> m (m a) --- [ body | stmts, then group using f ] --- -> f :: forall a. m a -> m (m a) - --- We type [ body | (stmts, group by e using f), ... ] --- f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body.... --- --- We type the functions as follows: --- f <optional by> :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm) --- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm) --- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm) --- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm) --- -tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap - , trS_by = by, trS_using = using, trS_form = form - , trS_ret = return_op, trS_bind = bind_op - , trS_fmap = fmap_op }) res_ty thing_inside - = do { m1_ty <- newFlexiTyVarTy typeToTypeKind - ; m2_ty <- newFlexiTyVarTy typeToTypeKind - ; tup_ty <- newFlexiTyVarTy liftedTypeKind - ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any) - - -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm - ; n_app <- case form of - ThenForm -> return (\ty -> ty) - _ -> do { n_ty <- newFlexiTyVarTy typeToTypeKind - ; return (n_ty `mkAppTy`) } - ; let by_arrow :: Type -> Type - -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present) - -- or res ('by' absent) - by_arrow = case by of - Nothing -> \res -> res - Just {} -> \res -> (alphaTy `mkVisFunTy` by_e_ty) `mkVisFunTy` res - - poly_arg_ty = m1_ty `mkAppTy` alphaTy - using_arg_ty = m1_ty `mkAppTy` tup_ty - poly_res_ty = m2_ty `mkAppTy` n_app alphaTy - using_res_ty = m2_ty `mkAppTy` n_app tup_ty - using_poly_ty = mkInvForAllTy alphaTyVar $ - by_arrow $ - poly_arg_ty `mkVisFunTy` poly_res_ty - - -- 'stmts' returns a result of type (m1_ty tuple_ty), - -- typically something like [(Int,Bool,Int)] - -- We don't know what tuple_ty is yet, so we use a variable - ; let (bndr_names, n_bndr_names) = unzip bindersMap - ; (stmts', (bndr_ids, by', return_op')) <- - tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts - (mkCheckExpType using_arg_ty) $ \res_ty' -> do - { by' <- case by of - Nothing -> return Nothing - Just e -> do { e' <- tcMonoExpr e - (mkCheckExpType by_e_ty) - ; return (Just e') } - - -- Find the Ids (and hence types) of all old binders - ; bndr_ids <- tcLookupLocalIds bndr_names - - -- 'return' is only used for the binders, so we know its type. - -- return :: (a,b,c,..) -> m (a,b,c,..) - ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op - [synKnownType (mkBigCoreVarTupTy bndr_ids)] - res_ty' $ \ _ -> return () - - ; return (bndr_ids, by', return_op') } - - --------------- Typecheck the 'bind' function ------------- - -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty - ; new_res_ty <- newFlexiTyVarTy liftedTypeKind - ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op - [ synKnownType using_res_ty - , synKnownType (n_app tup_ty `mkVisFunTy` new_res_ty) ] - res_ty $ \ _ -> return () - - --------------- Typecheck the 'fmap' function ------------- - ; fmap_op' <- case form of - ThenForm -> return noExpr - _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ - mkInvForAllTy alphaTyVar $ - mkInvForAllTy betaTyVar $ - (alphaTy `mkVisFunTy` betaTy) - `mkVisFunTy` (n_app alphaTy) - `mkVisFunTy` (n_app betaTy) - - --------------- Typecheck the 'using' function ------------- - -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) - - ; using' <- tcPolyExpr using using_poly_ty - ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' - - --------------- Building the bindersMap ---------------- - ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) - - -- Ensure that every old binder of type `b` is linked up with its - -- new binder which should have type `n b` - -- See Note [GroupStmt binder map] in GHC.Hs.Expr - n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids - bindersMap' = bndr_ids `zip` n_bndr_ids - - -- Type check the thing in the environment with - -- these new binders and return the result - ; thing <- tcExtendIdEnv n_bndr_ids $ - thing_inside (mkCheckExpType new_res_ty) - - ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' - , trS_by = by', trS_using = final_using - , trS_ret = return_op', trS_bind = bind_op' - , trS_ext = n_app tup_ty - , trS_fmap = fmap_op', trS_form = form }, thing) } - --- A parallel set of comprehensions --- [ (g x, h x) | ... ; let g v = ... --- | ... ; let h v = ... ] --- --- It's possible that g,h are overloaded, so we need to feed the LIE from the --- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods). --- Similarly if we had an existential pattern match: --- --- data T = forall a. Show a => C a --- --- [ (show x, show y) | ... ; C x <- ... --- | ... ; C y <- ... ] --- --- Then we need the LIE from (show x, show y) to be simplified against --- the bindings for x and y. --- --- It's difficult to do this in parallel, so we rely on the renamer to --- ensure that g,h and x,y don't duplicate, and simply grow the environment. --- So the binders of the first parallel group will be in scope in the second --- group. But that's fine; there's no shadowing to worry about. --- --- Note: The `mzip` function will get typechecked via: --- --- ParStmt [st1::t1, st2::t2, st3::t3] --- --- mzip :: m st1 --- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call --- -> m (st1, (st2, st3)) --- -tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside - = do { m_ty <- newFlexiTyVarTy typeToTypeKind - - ; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $ - (m_ty `mkAppTy` alphaTy) - `mkVisFunTy` - (m_ty `mkAppTy` betaTy) - `mkVisFunTy` - (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) - ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty - - -- type dummies since we don't know all binder types yet - ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) - [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ] - - -- Typecheck bind: - ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ] - tuple_ty = mk_tuple_ty tup_tys - - ; (((blocks', thing), inner_res_ty), bind_op') - <- tcSyntaxOp MCompOrigin bind_op - [ synKnownType (m_ty `mkAppTy` tuple_ty) - , SynFun (synKnownType tuple_ty) SynRho ] res_ty $ - \ [inner_res_ty] -> - do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) - tup_tys bndr_stmts_s - ; return (stuff, inner_res_ty) } - - ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) } - - where - mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys - - -- loop :: Type -- m_ty - -- -> ExpRhoType -- inner_res_ty - -- -> [TcType] -- tup_tys - -- -> [ParStmtBlock Name] - -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing) - loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty - ; return ([], thing) } - -- matching in the branches - - loop m_ty inner_res_ty (tup_ty_in : tup_tys_in) - (ParStmtBlock x stmts names return_op : pairs) - = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in - ; (stmts', (ids, return_op', pairs', thing)) - <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $ - \m_tup_ty' -> - do { ids <- tcLookupLocalIds names - ; let tup_ty = mkBigCoreVarTupTy ids - ; (_, return_op') <- - tcSyntaxOp MCompOrigin return_op - [synKnownType tup_ty] m_tup_ty' $ - \ _ -> return () - ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs - ; return (ids, return_op', pairs', thing) } - ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) } - loop _ _ _ _ = panic "tcMcStmt.loop" - -tcMcStmt _ stmt _ _ - = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) - - ---------------------------------------------------- --- Do-notation --- (supports rebindable syntax) ---------------------------------------------------- - -tcDoStmt :: TcExprStmtChecker - -tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside - = do { body' <- tcMonoExprNC body res_ty - ; thing <- thing_inside (panic "tcDoStmt: thing_inside") - ; return (LastStmt x body' noret noSyntaxExpr, thing) } - -tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside - = do { -- Deal with rebindable syntax: - -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty - -- This level of generality is needed for using do-notation - -- in full generality; see #1537 - - ((rhs', pat', new_res_ty, thing), bind_op') - <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $ - \ [rhs_ty, pat_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat - (mkCheckExpType pat_ty) $ - thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', pat', new_res_ty, thing) } - - -- If (but only if) the pattern can fail, typecheck the 'fail' operator - ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty - - ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) } - -tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside - = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $ - thing_inside . mkCheckExpType - ; ((pairs', body_ty, thing), mb_join') <- case mb_join of - Nothing -> (, Nothing) <$> tc_app_stmts res_ty - Just join_op -> - second Just <$> - (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ - \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty)) - - ; return (ApplicativeStmt body_ty pairs' mb_join', thing) } - -tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside - = do { -- Deal with rebindable syntax; - -- (>>) :: rhs_ty -> new_res_ty -> res_ty - ; ((rhs', rhs_ty, thing), then_op') - <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ - \ [rhs_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; thing <- thing_inside (mkCheckExpType new_res_ty) - ; return (rhs', rhs_ty, thing) } - ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } - -tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names - , recS_rec_ids = rec_names, recS_ret_fn = ret_op - , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) - res_ty thing_inside - = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names - ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys - tup_ty = mkBigCoreTupTy tup_elt_tys - - ; tcExtendIdEnv tup_ids $ do - { ((stmts', (ret_op', tup_rets)), stmts_ty) - <- tcInferInst $ \ exp_ty -> - tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty -> - do { tup_rets <- zipWithM tcCheckId tup_names - (map mkCheckExpType tup_elt_tys) - -- Unify the types of the "final" Ids (which may - -- be polymorphic) with those of "knot-tied" Ids - ; (_, ret_op') - <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty] - inner_res_ty $ \_ -> return () - ; return (ret_op', tup_rets) } - - ; ((_, mfix_op'), mfix_res_ty) - <- tcInferInst $ \ exp_ty -> - tcSyntaxOp DoOrigin mfix_op - [synKnownType (mkVisFunTy tup_ty stmts_ty)] exp_ty $ - \ _ -> return () - - ; ((thing, new_res_ty), bind_op') - <- tcSyntaxOp DoOrigin bind_op - [ synKnownType mfix_res_ty - , synKnownType tup_ty `SynFun` SynRho ] - res_ty $ - \ [new_res_ty] -> - do { thing <- thing_inside (mkCheckExpType new_res_ty) - ; return (thing, new_res_ty) } - - ; let rec_ids = takeList rec_names tup_ids - ; later_ids <- tcLookupLocalIds later_names - ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids), - ppr later_ids <+> ppr (map idType later_ids)] - ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' - , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' - , recS_ext = RecStmtTc - { recS_bind_ty = new_res_ty - , recS_later_rets = [] - , recS_rec_rets = tup_rets - , recS_ret_ty = stmts_ty} }, thing) - }} - -tcDoStmt _ stmt _ _ - = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) - - - ---------------------------------------------------- --- MonadFail Proposal warnings ---------------------------------------------------- - --- The idea behind issuing MonadFail warnings is that we add them whenever a --- failable pattern is encountered. However, instead of throwing a type error --- when the constraint cannot be satisfied, we only issue a warning in --- TcErrors.hs. - -tcMonadFailOp :: CtOrigin - -> LPat GhcTcId - -> SyntaxExpr GhcRn -- The fail op - -> TcType -- Type of the whole do-expression - -> TcRn (SyntaxExpr GhcTcId) -- Typechecked fail op --- Get a 'fail' operator expression, to use if the pattern --- match fails. If the pattern is irrefutatable, just return --- noSyntaxExpr; it won't be used -tcMonadFailOp orig pat fail_op res_ty - | isIrrefutableHsPat pat - = return noSyntaxExpr - - | otherwise - = snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] - (mkCheckExpType res_ty) $ \_ -> return ()) - -{- -Note [Treat rebindable syntax first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking - do { bar; ... } :: IO () -we want to typecheck 'bar' in the knowledge that it should be an IO thing, -pushing info from the context into the RHS. To do this, we check the -rebindable syntax first, and push that information into (tcMonoExprNC rhs). -Otherwise the error shows up when checking the rebindable syntax, and -the expected/inferred stuff is back to front (see #3613). - -Note [typechecking ApplicativeStmt] - -join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en) - -fresh type variables: - pat_ty_1..pat_ty_n - exp_ty_1..exp_ty_n - t_1..t_(n-1) - -body :: body_ty -(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty -pat_i :: pat_ty_i -e_i :: exp_ty_i -<$> :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1 -<*>_i :: t_(i-1) -> exp_ty_i -> t_i -join :: tn -> res_ty --} - -tcApplicativeStmts - :: HsStmtContext GhcRn - -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] - -> ExpRhoType -- rhs_ty - -> (TcRhoType -> TcM t) -- thing_inside - -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t) - -tcApplicativeStmts ctxt pairs rhs_ty thing_inside - = do { body_ty <- newFlexiTyVarTy liftedTypeKind - ; let arity = length pairs - ; ts <- replicateM (arity-1) $ newInferExpTypeInst - ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind - ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind - ; let fun_ty = mkVisFunTys pat_tys body_ty - - -- NB. do the <$>,<*> operators first, we don't want type errors here - -- i.e. goOps before goArgs - -- See Note [Treat rebindable syntax first] - ; let (ops, args) = unzip pairs - ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys) - - -- Typecheck each ApplicativeArg separately - -- See Note [ApplicativeDo and constraints] - ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys) - - -- Bring into scope all the things bound by the args, - -- and typecheck the thing_inside - -- See Note [ApplicativeDo and constraints] - ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $ - thing_inside body_ty - - ; return (zip ops' args', body_ty, res) } - where - goOps _ [] = return [] - goOps t_left ((op,t_i,exp_ty) : ops) - = do { (_, op') - <- tcSyntaxOp DoOrigin op - [synKnownType t_left, synKnownType exp_ty] t_i $ - \ _ -> return () - ; t_i <- readExpType t_i - ; ops' <- goOps t_i ops - ; return (op' : ops') } - - goArg :: Type -> (ApplicativeArg GhcRn, Type, Type) - -> TcM (ApplicativeArg GhcTcId) - - goArg body_ty (ApplicativeArgOne - { app_arg_pattern = pat - , arg_expr = rhs - , fail_operator = fail_op - , .. - }, pat_ty, exp_ty) - = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ - addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $ - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty) - ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - return () - ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op body_ty - - ; return (ApplicativeArgOne - { app_arg_pattern = pat' - , arg_expr = rhs' - , fail_operator = fail_op' - , .. } - ) } - - goArg _body_ty (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty) - = do { (stmts', (ret',pat')) <- - tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ - \res_ty -> do - { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty - ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ - return () - ; return (ret', pat') - } - ; return (ApplicativeArgMany x stmts' ret' pat') } - - goArg _body_ty (XApplicativeArg nec, _, _) = noExtCon nec - - get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id] - get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat - get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat - get_arg_bndrs (XApplicativeArg nec) = noExtCon nec - -{- Note [ApplicativeDo and constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An applicative-do is supposed to take place in parallel, so -constraints bound in one arm can't possibly be available in another -(#13242). Our current rule is this (more details and discussion -on the ticket). Consider - - ...stmts... - ApplicativeStmts [arg1, arg2, ... argN] - ...more stmts... - -where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts. -Now, we say that: - -* Constraints required by the argi can be solved from - constraint bound by ...stmts... - -* Constraints and existentials bound by the argi are not available - to solve constraints required either by argj (where i /= j), - or by ...more stmts.... - -* Within the stmts of each 'argi' individually, however, constraints bound - by earlier stmts can be used to solve later ones. - -To achieve this, we just typecheck each 'argi' separately, bring all -the variables they bind into scope, and typecheck the thing_inside. - -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same -number of args are used in each equation. --} - -checkArgs :: Name -> MatchGroup GhcRn body -> TcM () -checkArgs _ (MG { mg_alts = L _ [] }) - = return () -checkArgs fun (MG { mg_alts = L _ (match1:matches) }) - | null bad_matches - = return () - | otherwise - = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+> - text "have different numbers of arguments" - , nest 2 (ppr (getLoc match1)) - , nest 2 (ppr (getLoc (head bad_matches)))]) - where - n_args1 = args_in_match match1 - bad_matches = [m | m <- matches, args_in_match m /= n_args1] - - args_in_match :: LMatch GhcRn body -> Int - args_in_match (L _ (Match { m_pats = pats })) = length pats - args_in_match (L _ (XMatch nec)) = noExtCon nec -checkArgs _ (XMatchGroup nec) = noExtCon nec diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot deleted file mode 100644 index ec3ada52a4..0000000000 --- a/compiler/typecheck/TcMatches.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -module TcMatches where -import GHC.Hs ( GRHSs, MatchGroup, LHsExpr ) -import TcEvidence ( HsWrapper ) -import GHC.Types.Name ( Name ) -import TcType ( ExpSigmaType, TcRhoType ) -import TcRnTypes ( TcM ) -import GHC.Types.SrcLoc ( Located ) -import GHC.Hs.Extension ( GhcRn, GhcTcId ) - -tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) - -> TcRhoType - -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId)) - -tcMatchesFun :: Located Name - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpSigmaType - -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)) diff --git a/compiler/typecheck/TcOrigin.hs b/compiler/typecheck/TcOrigin.hs deleted file mode 100644 index 502edc6a48..0000000000 --- a/compiler/typecheck/TcOrigin.hs +++ /dev/null @@ -1,656 +0,0 @@ -{- - -Describes the provenance of types as they flow through the type-checker. -The datatypes here are mainly used for error message generation. - --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcOrigin ( - -- UserTypeCtxt - UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe, - - -- SkolemInfo - SkolemInfo(..), pprSigSkolInfo, pprSkolInfo, - - -- CtOrigin - CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, - isVisibleOrigin, toInvisibleOrigin, - pprCtOrigin, isGivenOrigin - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcType - -import GHC.Hs - -import GHC.Types.Id -import GHC.Core.DataCon -import GHC.Core.ConLike -import GHC.Core.TyCon -import GHC.Core.InstEnv -import GHC.Core.PatSyn - -import GHC.Types.Module -import GHC.Types.Name -import GHC.Types.Name.Reader - -import GHC.Types.SrcLoc -import FastString -import Outputable -import GHC.Types.Basic - -{- ********************************************************************* -* * - UserTypeCtxt -* * -********************************************************************* -} - -------------------------------------- --- | UserTypeCtxt describes the origin of the polymorphic type --- in the places where we need an expression to have that type -data UserTypeCtxt - = FunSigCtxt -- Function type signature, when checking the type - -- Also used for types in SPECIALISE pragmas - Name -- Name of the function - Bool -- True <=> report redundant constraints - -- This is usually True, but False for - -- * Record selectors (not important here) - -- * Class and instance methods. Here - -- the code may legitimately be more - -- polymorphic than the signature - -- generated from the class - -- declaration - - | InfSigCtxt Name -- Inferred type for function - | ExprSigCtxt -- Expression type signature - | KindSigCtxt -- Kind signature - | StandaloneKindSigCtxt -- Standalone kind signature - Name -- Name of the type/class - | TypeAppCtxt -- Visible type application - | ConArgCtxt Name -- Data constructor argument - | TySynCtxt Name -- RHS of a type synonym decl - | PatSynCtxt Name -- Type sig for a pattern synonym - | PatSigCtxt -- Type sig in pattern - -- eg f (x::t) = ... - -- or (x::t, y) = e - | RuleSigCtxt Name -- LHS of a RULE forall - -- RULE "foo" forall (x :: a -> a). f (Just x) = ... - | ResSigCtxt -- Result type sig - -- f x :: t = .... - | ForSigCtxt Name -- Foreign import or export signature - | DefaultDeclCtxt -- Types in a default declaration - | InstDeclCtxt Bool -- An instance declaration - -- True: stand-alone deriving - -- False: vanilla instance declaration - | SpecInstCtxt -- SPECIALISE instance pragma - | ThBrackCtxt -- Template Haskell type brackets [t| ... |] - | GenSigCtxt -- Higher-rank or impredicative situations - -- e.g. (f e) where f has a higher-rank type - -- We might want to elaborate this - | GhciCtxt Bool -- GHCi command :kind <type> - -- The Bool indicates if we are checking the outermost - -- type application. - -- See Note [Unsaturated type synonyms in GHCi] in - -- TcValidity. - - | ClassSCCtxt Name -- Superclasses of a class - | SigmaCtxt -- Theta part of a normal for-all type - -- f :: <S> => a -> a - | DataTyCtxt Name -- The "stupid theta" part of a data decl - -- data <S> => T a = MkT a - | DerivClauseCtxt -- A 'deriving' clause - | TyVarBndrKindCtxt Name -- The kind of a type variable being bound - | DataKindCtxt Name -- The kind of a data/newtype (instance) - | TySynKindCtxt Name -- The kind of the RHS of a type synonym - | TyFamResKindCtxt Name -- The result kind of a type family - -{- --- Notes re TySynCtxt --- We allow type synonyms that aren't types; e.g. type List = [] --- --- If the RHS mentions tyvars that aren't in scope, we'll --- quantify over them: --- e.g. type T = a->a --- will become type T = forall a. a->a --- --- With gla-exts that's right, but for H98 we should complain. --} - - -pprUserTypeCtxt :: UserTypeCtxt -> SDoc -pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) -pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) -pprUserTypeCtxt (RuleSigCtxt n) = text "a RULE for" <+> quotes (ppr n) -pprUserTypeCtxt ExprSigCtxt = text "an expression type signature" -pprUserTypeCtxt KindSigCtxt = text "a kind signature" -pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) -pprUserTypeCtxt TypeAppCtxt = text "a type argument" -pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) -pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) -pprUserTypeCtxt ThBrackCtxt = text "a Template Haskell quotation [t|...|]" -pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" -pprUserTypeCtxt ResSigCtxt = text "a result type signature" -pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) -pprUserTypeCtxt DefaultDeclCtxt = text "a type in a `default' declaration" -pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration" -pprUserTypeCtxt (InstDeclCtxt True) = text "a stand-alone deriving instance declaration" -pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" -pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" -pprUserTypeCtxt (GhciCtxt {}) = text "a type in a GHCi command" -pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) -pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" -pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) -pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n) -pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause" -pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n) -pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) -pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) -pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n) - -isSigMaybe :: UserTypeCtxt -> Maybe Name -isSigMaybe (FunSigCtxt n _) = Just n -isSigMaybe (ConArgCtxt n) = Just n -isSigMaybe (ForSigCtxt n) = Just n -isSigMaybe (PatSynCtxt n) = Just n -isSigMaybe _ = Nothing - -{- -************************************************************************ -* * - SkolemInfo -* * -************************************************************************ --} - --- SkolemInfo gives the origin of *given* constraints --- a) type variables are skolemised --- b) an implication constraint is generated -data SkolemInfo - = SigSkol -- A skolem that is created by instantiating - -- a programmer-supplied type signature - -- Location of the binding site is on the TyVar - -- See Note [SigSkol SkolemInfo] - UserTypeCtxt -- What sort of signature - TcType -- Original type signature (before skolemisation) - [(Name,TcTyVar)] -- Maps the original name of the skolemised tyvar - -- to its instantiated version - - | SigTypeSkol UserTypeCtxt - -- like SigSkol, but when we're kind-checking the *type* - -- hence, we have less info - - | ForAllSkol SDoc -- Bound by a user-written "forall". - - | DerivSkol Type -- Bound by a 'deriving' clause; - -- the type is the instance we are trying to derive - - | InstSkol -- Bound at an instance decl - | InstSC TypeSize -- A "given" constraint obtained by superclass selection. - -- If (C ty1 .. tyn) is the largest class from - -- which we made a superclass selection in the chain, - -- then TypeSize = sizeTypes [ty1, .., tyn] - -- See Note [Solving superclass constraints] in TcInstDcls - - | FamInstSkol -- Bound at a family instance decl - | PatSkol -- An existential type variable bound by a pattern for - ConLike -- a data constructor with an existential type. - (HsMatchContext GhcRn) - -- e.g. data T = forall a. Eq a => MkT a - -- f (MkT x) = ... - -- The pattern MkT x will allocate an existential type - -- variable for 'a'. - - | ArrowSkol -- An arrow form (see TcArrows) - - | IPSkol [HsIPName] -- Binding site of an implicit parameter - - | RuleSkol RuleName -- The LHS of a RULE - - | InferSkol [(Name,TcType)] - -- We have inferred a type for these (mutually-recursivive) - -- polymorphic Ids, and are now checking that their RHS - -- constraints are satisfied. - - | BracketSkol -- Template Haskell bracket - - | UnifyForAllSkol -- We are unifying two for-all types - TcType -- The instantiated type *inside* the forall - - | TyConSkol TyConFlavour Name -- bound in a type declaration of the given flavour - - | DataConSkol Name -- bound as an existential in a Haskell98 datacon decl or - -- as any variable in a GADT datacon decl - - | ReifySkol -- Bound during Template Haskell reification - - | QuantCtxtSkol -- Quantified context, e.g. - -- f :: forall c. (forall a. c a => c [a]) => blah - - | RuntimeUnkSkol -- Runtime skolem from the GHCi debugger #14628 - - | UnkSkol -- Unhelpful info (until I improve it) - -instance Outputable SkolemInfo where - ppr = pprSkolInfo - -pprSkolInfo :: SkolemInfo -> SDoc --- Complete the sentence "is a rigid type variable bound by..." -pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty -pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx -pprSkolInfo (ForAllSkol doc) = quotes doc -pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" - <+> pprWithCommas ppr ips -pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) -pprSkolInfo InstSkol = text "the instance declaration" -pprSkolInfo (InstSC n) = text "the instance declaration" <> whenPprDebug (parens (ppr n)) -pprSkolInfo FamInstSkol = text "a family instance declaration" -pprSkolInfo BracketSkol = text "a Template Haskell bracket" -pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name -pprSkolInfo ArrowSkol = text "an arrow form" -pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl - , text "in" <+> pprMatchContext mc ] -pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of") - 2 (vcat [ ppr name <+> dcolon <+> ppr ty - | (name,ty) <- ids ]) -pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty -pprSkolInfo (TyConSkol flav name) = text "the" <+> ppr flav <+> text "declaration for" <+> quotes (ppr name) -pprSkolInfo (DataConSkol name)= text "the data constructor" <+> quotes (ppr name) -pprSkolInfo ReifySkol = text "the type being reified" - -pprSkolInfo (QuantCtxtSkol {}) = text "a quantified context" -pprSkolInfo RuntimeUnkSkol = text "Unknown type from GHCi runtime" - --- UnkSkol --- For type variables the others are dealt with by pprSkolTvBinding. --- For Insts, these cases should not happen -pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol" - -pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc --- The type is already tidied -pprSigSkolInfo ctxt ty - = case ctxt of - FunSigCtxt f _ -> vcat [ text "the type signature for:" - , nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ] - PatSynCtxt {} -> pprUserTypeCtxt ctxt -- See Note [Skolem info for pattern synonyms] - _ -> vcat [ pprUserTypeCtxt ctxt <> colon - , nest 2 (ppr ty) ] - -pprPatSkolInfo :: ConLike -> SDoc -pprPatSkolInfo (RealDataCon dc) - = sep [ text "a pattern with constructor:" - , nest 2 $ ppr dc <+> dcolon - <+> pprType (dataConUserType dc) <> comma ] - -- pprType prints forall's regardless of -fprint-explicit-foralls - -- which is what we want here, since we might be saying - -- type variable 't' is bound by ... - -pprPatSkolInfo (PatSynCon ps) - = sep [ text "a pattern with pattern synonym:" - , nest 2 $ ppr ps <+> dcolon - <+> pprPatSynType ps <> comma ] - -{- Note [Skolem info for pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For pattern synonym SkolemInfo we have - SigSkol (PatSynCtxt p) ty _ -but the type 'ty' is not very helpful. The full pattern-synonym type -has the provided and required pieces, which it is inconvenient to -record and display here. So we simply don't display the type at all, -contenting outselves with just the name of the pattern synonym, which -is fine. We could do more, but it doesn't seem worth it. - -Note [SigSkol SkolemInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we (deeply) skolemise a type - f :: forall a. a -> forall b. b -> a -Then we'll instantiate [a :-> a', b :-> b'], and with the instantiated - a' -> b' -> a. -But when, in an error message, we report that "b is a rigid type -variable bound by the type signature for f", we want to show the foralls -in the right place. So we proceed as follows: - -* In SigSkol we record - - the original signature forall a. a -> forall b. b -> a - - the instantiation mapping [a :-> a', b :-> b'] - -* Then when tidying in TcMType.tidySkolemInfo, we first tidy a' to - whatever it tidies to, say a''; and then we walk over the type - replacing the binder a by the tidied version a'', to give - forall a''. a'' -> forall b''. b'' -> a'' - We need to do this under function arrows, to match what deeplySkolemise - does. - -* Typically a'' will have a nice pretty name like "a", but the point is - that the foral-bound variables of the signature we report line up with - the instantiated skolems lying around in other types. - - -************************************************************************ -* * - CtOrigin -* * -************************************************************************ --} - -data CtOrigin - = GivenOrigin SkolemInfo - - -- All the others are for *wanted* constraints - | OccurrenceOf Name -- Occurrence of an overloaded identifier - | OccurrenceOfRecSel RdrName -- Occurrence of a record selector - | AppOrigin -- An application of some kind - - | SpecPragOrigin UserTypeCtxt -- Specialisation pragma for - -- function or instance - - | TypeEqOrigin { uo_actual :: TcType - , uo_expected :: TcType - , uo_thing :: Maybe SDoc - -- ^ The thing that has type "actual" - , uo_visible :: Bool - -- ^ Is at least one of the three elements above visible? - -- (Errors from the polymorphic subsumption check are considered - -- visible.) Only used for prioritizing error messages. - } - - | KindEqOrigin - TcType (Maybe TcType) -- A kind equality arising from unifying these two types - CtOrigin -- originally arising from this - (Maybe TypeOrKind) -- the level of the eq this arises from - - | IPOccOrigin HsIPName -- Occurrence of an implicit parameter - | OverLabelOrigin FastString -- Occurrence of an overloaded label - - | LiteralOrigin (HsOverLit GhcRn) -- Occurrence of a literal - | NegateOrigin -- Occurrence of syntactic negation - - | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc - | AssocFamPatOrigin -- When matching the patterns of an associated - -- family instance with that of its parent class - | SectionOrigin - | TupleOrigin -- (..,..) - | ExprSigOrigin -- e :: ty - | PatSigOrigin -- p :: ty - | PatOrigin -- Instantiating a polytyped pattern at a constructor - | ProvCtxtOrigin -- The "provided" context of a pattern synonym signature - (PatSynBind GhcRn GhcRn) -- Information about the pattern synonym, in - -- particular the name and the right-hand side - | RecordUpdOrigin - | ViewPatOrigin - - | ScOrigin TypeSize -- Typechecking superclasses of an instance declaration - -- If the instance head is C ty1 .. tyn - -- then TypeSize = sizeTypes [ty1, .., tyn] - -- See Note [Solving superclass constraints] in TcInstDcls - - | DerivClauseOrigin -- Typechecking a deriving clause (as opposed to - -- standalone deriving). - | DerivOriginDC DataCon Int Bool - -- Checking constraints arising from this data con and field index. The - -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if - -- standalong deriving (with a wildcard constraint) is being used. This - -- is used to inform error messages on how to recommended fixes (e.g., if - -- the argument is True, then don't recommend "use standalone deriving", - -- but rather "fill in the wildcard constraint yourself"). - -- See Note [Inferring the instance context] in TcDerivInfer - | DerivOriginCoerce Id Type Type Bool - -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from - -- `ty1` to `ty2`. - | StandAloneDerivOrigin -- Typechecking stand-alone deriving. Useful for - -- constraints coming from a wildcard constraint, - -- e.g., deriving instance _ => Eq (Foo a) - -- See Note [Inferring the instance context] - -- in TcDerivInfer - | DefaultOrigin -- Typechecking a default decl - | DoOrigin -- Arising from a do expression - | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in - -- a do expression - | MCompOrigin -- Arising from a monad comprehension - | MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a - -- monad comprehension - | IfOrigin -- Arising from an if statement - | ProcOrigin -- Arising from a proc expression - | AnnOrigin -- An annotation - - | FunDepOrigin1 -- A functional dependency from combining - PredType CtOrigin RealSrcSpan -- This constraint arising from ... - PredType CtOrigin RealSrcSpan -- and this constraint arising from ... - - | FunDepOrigin2 -- A functional dependency from combining - PredType CtOrigin -- This constraint arising from ... - PredType SrcSpan -- and this top-level instance - -- We only need a CtOrigin on the first, because the location - -- is pinned on the entire error message - - | HoleOrigin - | UnboundOccurrenceOf OccName - | ListOrigin -- An overloaded list - | BracketOrigin -- An overloaded quotation bracket - | StaticOrigin -- A static form - | Shouldn'tHappenOrigin String - -- the user should never see this one, - -- unless ImpredicativeTypes is on, where all - -- bets are off - | InstProvidedOrigin Module ClsInst - -- Skolem variable arose when we were testing if an instance - -- is solvable or not. --- An origin is visible if the place where the constraint arises is manifest --- in user code. Currently, all origins are visible except for invisible --- TypeEqOrigins. This is used when choosing which error of --- several to report -isVisibleOrigin :: CtOrigin -> Bool -isVisibleOrigin (TypeEqOrigin { uo_visible = vis }) = vis -isVisibleOrigin (KindEqOrigin _ _ sub_orig _) = isVisibleOrigin sub_orig -isVisibleOrigin _ = True - --- Converts a visible origin to an invisible one, if possible. Currently, --- this works only for TypeEqOrigin -toInvisibleOrigin :: CtOrigin -> CtOrigin -toInvisibleOrigin orig@(TypeEqOrigin {}) = orig { uo_visible = False } -toInvisibleOrigin orig = orig - -isGivenOrigin :: CtOrigin -> Bool -isGivenOrigin (GivenOrigin {}) = True -isGivenOrigin (FunDepOrigin1 _ o1 _ _ o2 _) = isGivenOrigin o1 && isGivenOrigin o2 -isGivenOrigin (FunDepOrigin2 _ o1 _ _) = isGivenOrigin o1 -isGivenOrigin _ = False - -instance Outputable CtOrigin where - ppr = pprCtOrigin - -ctoHerald :: SDoc -ctoHerald = text "arising from" - --- | Extract a suitable CtOrigin from a HsExpr -lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin -lexprCtOrigin (L _ e) = exprCtOrigin e - -exprCtOrigin :: HsExpr GhcRn -> CtOrigin -exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name -exprCtOrigin (HsUnboundVar _ uv) = UnboundOccurrenceOf uv -exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" -exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) -exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l -exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip -exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit -exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" -exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches -exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms -exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1 -exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 -exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op -exprCtOrigin (NegApp _ e _) = lexprCtOrigin e -exprCtOrigin (HsPar _ e) = lexprCtOrigin e -exprCtOrigin (SectionL _ _ _) = SectionOrigin -exprCtOrigin (SectionR _ _ _) = SectionOrigin -exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" -exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" -exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches -exprCtOrigin (HsIf _ (SyntaxExprRn syn) _ _ _) = exprCtOrigin syn -exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" -exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs -exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e -exprCtOrigin (HsDo {}) = DoOrigin -exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list" -exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" -exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" -exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin -exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" -exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e -exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket" -exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut" -exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut" -exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" -exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" -exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" -exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e -exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e -exprCtOrigin (XExpr nec) = noExtCon nec - --- | Extract a suitable CtOrigin from a MatchGroup -matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin -matchesCtOrigin (MG { mg_alts = alts }) - | L _ [L _ match] <- alts - , Match { m_grhss = grhss } <- match - = grhssCtOrigin grhss - - | otherwise - = Shouldn'tHappenOrigin "multi-way match" -matchesCtOrigin (XMatchGroup nec) = noExtCon nec - --- | Extract a suitable CtOrigin from guarded RHSs -grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin -grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss -grhssCtOrigin (XGRHSs nec) = noExtCon nec - --- | Extract a suitable CtOrigin from a list of guarded RHSs -lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin -lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e -lGRHSCtOrigin [L _ (XGRHS nec)] = noExtCon nec -lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" - -pprCtOrigin :: CtOrigin -> SDoc --- "arising from ..." --- Not an instance of Outputable because of the "arising from" prefix -pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk - -pprCtOrigin (SpecPragOrigin ctxt) - = case ctxt of - FunSigCtxt n _ -> text "for" <+> quotes (ppr n) - SpecInstCtxt -> text "a SPECIALISE INSTANCE pragma" - _ -> text "a SPECIALISE pragma" -- Never happens I think - -pprCtOrigin (FunDepOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) - = hang (ctoHerald <+> text "a functional dependency between constraints:") - 2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtOrigin orig1 <+> text "at" <+> ppr loc1) - , hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ]) - -pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) - = hang (ctoHerald <+> text "a functional dependency between:") - 2 (vcat [ hang (text "constraint" <+> quotes (ppr pred1)) - 2 (pprCtOrigin orig1 ) - , hang (text "instance" <+> quotes (ppr pred2)) - 2 (text "at" <+> ppr loc2) ]) - -pprCtOrigin (KindEqOrigin t1 (Just t2) _ _) - = hang (ctoHerald <+> text "a kind equality arising from") - 2 (sep [ppr t1, char '~', ppr t2]) - -pprCtOrigin AssocFamPatOrigin - = text "when matching a family LHS with its class instance head" - -pprCtOrigin (KindEqOrigin t1 Nothing _ _) - = hang (ctoHerald <+> text "a kind equality when matching") - 2 (ppr t1) - -pprCtOrigin (UnboundOccurrenceOf name) - = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name) - -pprCtOrigin (DerivOriginDC dc n _) - = hang (ctoHerald <+> text "the" <+> speakNth n - <+> text "field of" <+> quotes (ppr dc)) - 2 (parens (text "type" <+> quotes (ppr ty))) - where - ty = dataConOrigArgTys dc !! (n-1) - -pprCtOrigin (DerivOriginCoerce meth ty1 ty2 _) - = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth)) - 2 (sep [ text "from type" <+> quotes (ppr ty1) - , nest 2 $ text "to type" <+> quotes (ppr ty2) ]) - -pprCtOrigin (DoPatOrigin pat) - = ctoHerald <+> text "a do statement" - $$ - text "with the failable pattern" <+> quotes (ppr pat) - -pprCtOrigin (MCompPatOrigin pat) - = ctoHerald <+> hsep [ text "the failable pattern" - , quotes (ppr pat) - , text "in a statement in a monad comprehension" ] - -pprCtOrigin (Shouldn'tHappenOrigin note) - = sdocOption sdocImpredicativeTypes $ \case - True -> text "a situation created by impredicative types" - False -> vcat [ text "<< This should not appear in error messages. If you see this" - , text "in an error message, please report a bug mentioning" - <+> quotes (text note) <+> text "at" - , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>" - ] - -pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) }) - = hang (ctoHerald <+> text "the \"provided\" constraints claimed by") - 2 (text "the signature of" <+> quotes (ppr name)) - -pprCtOrigin (InstProvidedOrigin mod cls_inst) - = vcat [ text "arising when attempting to show that" - , ppr cls_inst - , text "is provided by" <+> quotes (ppr mod)] - -pprCtOrigin simple_origin - = ctoHerald <+> pprCtO simple_origin - --- | Short one-liners -pprCtO :: CtOrigin -> SDoc -pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] -pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] -pprCtO AppOrigin = text "an application" -pprCtO (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)] -pprCtO (OverLabelOrigin l) = hsep [text "the overloaded label" - ,quotes (char '#' <> ppr l)] -pprCtO RecordUpdOrigin = text "a record update" -pprCtO ExprSigOrigin = text "an expression type signature" -pprCtO PatSigOrigin = text "a pattern type signature" -pprCtO PatOrigin = text "a pattern" -pprCtO ViewPatOrigin = text "a view pattern" -pprCtO IfOrigin = text "an if expression" -pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] -pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] -pprCtO SectionOrigin = text "an operator section" -pprCtO AssocFamPatOrigin = text "the LHS of a family instance" -pprCtO TupleOrigin = text "a tuple" -pprCtO NegateOrigin = text "a use of syntactic negation" -pprCtO (ScOrigin n) = text "the superclasses of an instance declaration" - <> whenPprDebug (parens (ppr n)) -pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" -pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" -pprCtO DefaultOrigin = text "a 'default' declaration" -pprCtO DoOrigin = text "a do statement" -pprCtO MCompOrigin = text "a statement in a monad comprehension" -pprCtO ProcOrigin = text "a proc expression" -pprCtO (TypeEqOrigin t1 t2 _ _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2] -pprCtO AnnOrigin = text "an annotation" -pprCtO HoleOrigin = text "a use of" <+> quotes (text "_") -pprCtO ListOrigin = text "an overloaded list" -pprCtO StaticOrigin = text "a static form" -pprCtO BracketOrigin = text "a quotation bracket" -pprCtO _ = panic "pprCtOrigin" diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs deleted file mode 100644 index 0d3679eecd..0000000000 --- a/compiler/typecheck/TcPat.hs +++ /dev/null @@ -1,1206 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcPat: Typechecking patterns --} - -{-# LANGUAGE CPP, RankNTypes, TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..) - , tcPat, tcPat_O, tcPats - , addDataConStupidTheta, badFieldCon, polyPatSig ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma ) - -import GHC.Hs -import TcHsSyn -import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags ) -import TcRnMonad -import Inst -import GHC.Types.Id -import GHC.Types.Var -import GHC.Types.Name -import GHC.Types.Name.Reader -import TcEnv -import TcMType -import TcValidity( arityErr ) -import GHC.Core.TyCo.Ppr ( pprTyVars ) -import TcType -import TcUnify -import TcHsType -import TysWiredIn -import TcEvidence -import TcOrigin -import GHC.Core.TyCon -import GHC.Core.DataCon -import GHC.Core.PatSyn -import GHC.Core.ConLike -import PrelNames -import GHC.Types.Basic hiding (SuccessFlag(..)) -import GHC.Driver.Session -import GHC.Types.SrcLoc -import GHC.Types.Var.Set -import Util -import Outputable -import qualified GHC.LanguageExtensions as LangExt -import Control.Arrow ( second ) -import ListSetOps ( getNth ) - -{- -************************************************************************ -* * - External interface -* * -************************************************************************ --} - -tcLetPat :: (Name -> Maybe TcId) - -> LetBndrSpec - -> LPat GhcRn -> ExpSigmaType - -> TcM a - -> TcM (LPat GhcTcId, a) -tcLetPat sig_fn no_gen pat pat_ty thing_inside - = do { bind_lvl <- getTcLevel - ; let ctxt = LetPat { pc_lvl = bind_lvl - , pc_sig_fn = sig_fn - , pc_new = no_gen } - penv = PE { pe_lazy = True - , pe_ctxt = ctxt - , pe_orig = PatOrigin } - - ; tc_lpat pat pat_ty penv thing_inside } - ------------------ -tcPats :: HsMatchContext GhcRn - -> [LPat GhcRn] -- Patterns, - -> [ExpSigmaType] -- and their types - -> TcM a -- and the checker for the body - -> TcM ([LPat GhcTcId], a) - --- This is the externally-callable wrapper function --- Typecheck the patterns, extend the environment to bind the variables, --- do the thing inside, use any existentially-bound dictionaries to --- discharge parts of the returning LIE, and deal with pattern type --- signatures - --- 1. Initialise the PatState --- 2. Check the patterns --- 3. Check the body --- 4. Check that no existentials escape - -tcPats ctxt pats pat_tys thing_inside - = tc_lpats penv pats pat_tys thing_inside - where - penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } - -tcPat :: HsMatchContext GhcRn - -> LPat GhcRn -> ExpSigmaType - -> TcM a -- Checker for body - -> TcM (LPat GhcTcId, a) -tcPat ctxt = tcPat_O ctxt PatOrigin - --- | A variant of 'tcPat' that takes a custom origin -tcPat_O :: HsMatchContext GhcRn - -> CtOrigin -- ^ origin to use if the type needs inst'ing - -> LPat GhcRn -> ExpSigmaType - -> TcM a -- Checker for body - -> TcM (LPat GhcTcId, a) -tcPat_O ctxt orig pat pat_ty thing_inside - = tc_lpat pat pat_ty penv thing_inside - where - penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig } - - -{- -************************************************************************ -* * - PatEnv, PatCtxt, LetBndrSpec -* * -************************************************************************ --} - -data PatEnv - = PE { pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed - , pe_ctxt :: PatCtxt -- Context in which the whole pattern appears - , pe_orig :: CtOrigin -- origin to use if the pat_ty needs inst'ing - } - -data PatCtxt - = LamPat -- Used for lambdas, case etc - (HsMatchContext GhcRn) - - | LetPat -- Used only for let(rec) pattern bindings - -- See Note [Typing patterns in pattern bindings] - { pc_lvl :: TcLevel - -- Level of the binding group - - , pc_sig_fn :: Name -> Maybe TcId - -- Tells the expected type - -- for binders with a signature - - , pc_new :: LetBndrSpec - -- How to make a new binder - } -- for binders without signatures - -data LetBndrSpec - = LetLclBndr -- We are going to generalise, and wrap in an AbsBinds - -- so clone a fresh binder for the local monomorphic Id - - | LetGblBndr TcPragEnv -- Generalisation plan is NoGen, so there isn't going - -- to be an AbsBinds; So we must bind the global version - -- of the binder right away. - -- And here is the inline-pragma information - -instance Outputable LetBndrSpec where - ppr LetLclBndr = text "LetLclBndr" - ppr (LetGblBndr {}) = text "LetGblBndr" - -makeLazy :: PatEnv -> PatEnv -makeLazy penv = penv { pe_lazy = True } - -inPatBind :: PatEnv -> Bool -inPatBind (PE { pe_ctxt = LetPat {} }) = True -inPatBind (PE { pe_ctxt = LamPat {} }) = False - -{- ********************************************************************* -* * - Binders -* * -********************************************************************* -} - -tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (HsWrapper, TcId) --- (coi, xp) = tcPatBndr penv x pat_ty --- Then coi : pat_ty ~ typeof(xp) --- -tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl - , pc_sig_fn = sig_fn - , pc_new = no_gen } }) - bndr_name exp_pat_ty - -- For the LetPat cases, see - -- Note [Typechecking pattern bindings] in TcBinds - - | Just bndr_id <- sig_fn bndr_name -- There is a signature - = do { wrap <- tcSubTypePat penv exp_pat_ty (idType bndr_id) - -- See Note [Subsumption check at pattern variables] - ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty) - ; return (wrap, bndr_id) } - - | otherwise -- No signature - = do { (co, bndr_ty) <- case exp_pat_ty of - Check pat_ty -> promoteTcType bind_lvl pat_ty - Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res ) - -- If we were under a constructor that bumped - -- the level, we'd be in checking mode - do { bndr_ty <- inferResultToType infer_res - ; return (mkTcNomReflCo bndr_ty, bndr_ty) } - ; bndr_id <- newLetBndr no_gen bndr_name bndr_ty - ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl - , ppr exp_pat_ty, ppr bndr_ty, ppr co - , ppr bndr_id ]) - ; return (mkWpCastN co, bndr_id) } - -tcPatBndr _ bndr_name pat_ty - = do { pat_ty <- expTypeToType pat_ty - ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty) - ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name pat_ty) } - -- We should not have "OrCoVar" here, this is a bug (#17545) - -- Whether or not there is a sig is irrelevant, - -- as this is local - -newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId --- Make up a suitable Id for the pattern-binder. --- See Note [Typechecking pattern bindings], item (4) in TcBinds --- --- In the polymorphic case when we are going to generalise --- (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version" --- of the Id; the original name will be bound to the polymorphic version --- by the AbsBinds --- In the monomorphic case when we are not going to generalise --- (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds, --- and we use the original name directly -newLetBndr LetLclBndr name ty - = do { mono_name <- cloneLocalName name - ; return (mkLocalId mono_name ty) } -newLetBndr (LetGblBndr prags) name ty - = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name) - -tcSubTypePat :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper --- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt --- Used when typechecking patterns -tcSubTypePat penv t1 t2 = tcSubTypeET (pe_orig penv) GenSigCtxt t1 t2 - -{- Note [Subsumption check at pattern variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come across a variable with a type signature, we need to do a -subsumption, not equality, check against the context type. e.g. - - data T = MkT (forall a. a->a) - f :: forall b. [b]->[b] - MkT f = blah - -Since 'blah' returns a value of type T, its payload is a polymorphic -function of type (forall a. a->a). And that's enough to bind the -less-polymorphic function 'f', but we need some impedance matching -to witness the instantiation. - - -************************************************************************ -* * - The main worker functions -* * -************************************************************************ - -Note [Nesting] -~~~~~~~~~~~~~~ -tcPat takes a "thing inside" over which the pattern scopes. This is partly -so that tcPat can extend the environment for the thing_inside, but also -so that constraints arising in the thing_inside can be discharged by the -pattern. - -This does not work so well for the ErrCtxt carried by the monad: we don't -want the error-context for the pattern to scope over the RHS. -Hence the getErrCtxt/setErrCtxt stuff in tcMultiple --} - --------------------- -type Checker inp out = forall r. - inp - -> PatEnv - -> TcM r - -> TcM (out, r) - -tcMultiple :: Checker inp out -> Checker [inp] [out] -tcMultiple tc_pat args penv thing_inside - = do { err_ctxt <- getErrCtxt - ; let loop _ [] - = do { res <- thing_inside - ; return ([], res) } - - loop penv (arg:args) - = do { (p', (ps', res)) - <- tc_pat arg penv $ - setErrCtxt err_ctxt $ - loop penv args - -- setErrCtxt: restore context before doing the next pattern - -- See note [Nesting] above - - ; return (p':ps', res) } - - ; loop penv args } - --------------------- -tc_lpat :: LPat GhcRn - -> ExpSigmaType - -> PatEnv - -> TcM a - -> TcM (LPat GhcTcId, a) -tc_lpat (L span pat) pat_ty penv thing_inside - = setSrcSpan span $ - do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) - thing_inside - ; return (L span pat', res) } - -tc_lpats :: PatEnv - -> [LPat GhcRn] -> [ExpSigmaType] - -> TcM a - -> TcM ([LPat GhcTcId], a) -tc_lpats penv pats tys thing_inside - = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys ) - tcMultiple (\(p,t) -> tc_lpat p t) - (zipEqual "tc_lpats" pats tys) - penv thing_inside - --------------------- -tc_pat :: PatEnv - -> Pat GhcRn - -> ExpSigmaType -- Fully refined result type - -> TcM a -- Thing inside - -> TcM (Pat GhcTcId, -- Translated pattern - a) -- Result of thing inside - -tc_pat penv (VarPat x (L l name)) pat_ty thing_inside - = do { (wrap, id) <- tcPatBndr penv name pat_ty - ; res <- tcExtendIdEnv1 name id thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } - -tc_pat penv (ParPat x pat) pat_ty thing_inside - = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (ParPat x pat', res) } - -tc_pat penv (BangPat x pat) pat_ty thing_inside - = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (BangPat x pat', res) } - -tc_pat penv (LazyPat x pat) pat_ty thing_inside - = do { (pat', (res, pat_ct)) - <- tc_lpat pat pat_ty (makeLazy penv) $ - captureConstraints thing_inside - -- Ignore refined penv', revert to penv - - ; emitConstraints pat_ct - -- captureConstraints/extendConstraints: - -- see Note [Hopping the LIE in lazy patterns] - - -- Check that the expected pattern type is itself lifted - ; pat_ty <- readExpType pat_ty - ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind - - ; return (LazyPat x pat', res) } - -tc_pat _ (WildPat _) pat_ty thing_inside - = do { res <- thing_inside - ; pat_ty <- expTypeToType pat_ty - ; return (WildPat pat_ty, res) } - -tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside - = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) - ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ - tc_lpat pat (mkCheckExpType $ idType bndr_id) - penv thing_inside - -- NB: if we do inference on: - -- \ (y@(x::forall a. a->a)) = e - -- we'll fail. The as-pattern infers a monotype for 'y', which then - -- fails to unify with the polymorphic type for 'x'. This could - -- perhaps be fixed, but only with a bit more work. - -- - -- If you fix it, don't forget the bindInstsOfPatIds! - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, - res) } - -tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside - = do { - -- Expr must have type `forall a1...aN. OPT' -> B` - -- where overall_pat_ty is an instance of OPT'. - ; (expr',expr'_inferred) <- tcInferSigma expr - - -- expression must be a function - ; let expr_orig = lexprCtOrigin expr - herald = text "A view pattern expression expects" - ; (expr_wrap1, [inf_arg_ty], inf_res_ty) - <- matchActualFunTys herald expr_orig (Just (unLoc expr)) 1 expr'_inferred - -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty) - - -- check that overall pattern is more polymorphic than arg type - ; expr_wrap2 <- tcSubTypePat penv overall_pat_ty inf_arg_ty - -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty - - -- pattern must have inf_res_ty - ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside - - ; overall_pat_ty <- readExpType overall_pat_ty - ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper - overall_pat_ty inf_res_ty doc - -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->" - -- (overall_pat_ty -> inf_res_ty) - expr_wrap = expr_wrap2' <.> expr_wrap1 - doc = text "When checking the view pattern function:" <+> (ppr expr) - ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)} - --- Type signatures in patterns --- See Note [Pattern coercions] below -tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside - = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) - sig_ty pat_ty - -- Using tcExtendNameTyVarEnv is appropriate here - -- because we're not really bringing fresh tyvars into scope. - -- We're *naming* existing tyvars. Note that it is OK for a tyvar - -- from an outer scope to mention one of these tyvars in its kind. - ; (pat', res) <- tcExtendNameTyVarEnv wcs $ - tcExtendNameTyVarEnv tv_binds $ - tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) } - ------------------------- --- Lists, tuples, arrays -tc_pat penv (ListPat Nothing pats) pat_ty thing_inside - = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty - ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) - pats penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi - (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res) -} - -tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside - = do { tau_pat_ty <- expTypeToType pat_ty - ; ((pats', res, elt_ty), e') - <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] - SynList $ - \ [elt_ty] -> - do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) - pats penv thing_inside - ; return (pats', res, elt_ty) } - ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res) -} - -tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside - = do { let arity = length pats - tc = tupleTyCon boxity arity - -- NB: tupleTyCon does not flatten 1-tuples - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make - ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) - penv pat_ty - -- Unboxed tuples have RuntimeRep vars, which we discard: - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys - Boxed -> arg_tys - ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys) - thing_inside - - ; dflags <- getDynFlags - - -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) - -- so that we can experiment with lazy tuple-matching. - -- This is a pretty odd place to make the switch, but - -- it was easy to do. - ; let - unmangled_result = TuplePat con_arg_tys pats' boxity - -- pat_ty /= pat_ty iff coi /= IdCo - possibly_mangled_result - | gopt Opt_IrrefutableTuples dflags && - isBoxed boxity = LazyPat noExtField (noLoc unmangled_result) - | otherwise = unmangled_result - - ; pat_ty <- readExpType pat_ty - ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced - return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) - } - -tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside - = do { let tc = sumTyCon arity - ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) - penv pat_ty - ; -- Drop levity vars, we don't care about them here - let con_arg_tys = drop arity arg_tys - ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1))) - penv thing_inside - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty - , res) - } - ------------------------- --- Data constructors -tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside - = tcConPat penv con pat_ty arg_pats thing_inside - ------------------------- --- Literal patterns -tc_pat penv (LitPat x simple_lit) pat_ty thing_inside - = do { let lit_ty = hsLitType simple_lit - ; wrap <- tcSubTypePat penv pat_ty lit_ty - ; res <- thing_inside - ; pat_ty <- readExpType pat_ty - ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty - , res) } - ------------------------- --- Overloaded patterns: n, and n+k - --- In the case of a negative literal (the more complicated case), --- we get --- --- case v of (-5) -> blah --- --- becoming --- --- if v == (negate (fromInteger 5)) then blah else ... --- --- There are two bits of rebindable syntax: --- (==) :: pat_ty -> neg_lit_ty -> Bool --- negate :: lit_ty -> neg_lit_ty --- where lit_ty is the type of the overloaded literal 5. --- --- When there is no negation, neg_lit_ty and lit_ty are the same -tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside - = do { let orig = LiteralOrigin over_lit - ; ((lit', mb_neg'), eq') - <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] - (mkCheckExpType boolTy) $ - \ [neg_lit_ty] -> - let new_over_lit lit_ty = newOverloadedLit over_lit - (mkCheckExpType lit_ty) - in case mb_neg of - Nothing -> (, Nothing) <$> new_over_lit neg_lit_ty - Just neg -> -- Negative literal - -- The 'negate' is re-mappable syntax - second Just <$> - (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $ - \ [lit_ty] -> new_over_lit lit_ty) - - ; res <- thing_inside - ; pat_ty <- readExpType pat_ty - ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } - -{- -Note [NPlusK patterns] -~~~~~~~~~~~~~~~~~~~~~~ -From - - case v of x + 5 -> blah - -we get - - if v >= 5 then (\x -> blah) (v - 5) else ... - -There are two bits of rebindable syntax: - (>=) :: pat_ty -> lit1_ty -> Bool - (-) :: pat_ty -> lit2_ty -> var_ty - -lit1_ty and lit2_ty could conceivably be different. -var_ty is the type inferred for x, the variable in the pattern. - -If the pushed-down pattern type isn't a tau-type, the two pat_ty's above -could conceivably be different specializations. But this is very much -like the situation in Note [Case branches must be taus] in TcMatches. -So we tauify the pat_ty before proceeding. - -Note that we need to type-check the literal twice, because it is used -twice, and may be used at different types. The second HsOverLit stored in the -AST is used for the subtraction operation. --} - --- See Note [NPlusK patterns] -tc_pat penv (NPlusKPat _ (L nm_loc name) - (L loc lit) _ ge minus) pat_ty - thing_inside - = do { pat_ty <- expTypeToType pat_ty - ; let orig = LiteralOrigin lit - ; (lit1', ge') - <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho] - (mkCheckExpType boolTy) $ - \ [lit1_ty] -> - newOverloadedLit lit (mkCheckExpType lit1_ty) - ; ((lit2', minus_wrap, bndr_id), minus') - <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $ - \ [lit2_ty, var_ty] -> - do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) - ; (wrap, bndr_id) <- setSrcSpan nm_loc $ - tcPatBndr penv name (mkCheckExpType var_ty) - -- co :: var_ty ~ idType bndr_id - - -- minus_wrap is applicable to minus' - ; return (lit2', wrap, bndr_id) } - - -- The Report says that n+k patterns must be in Integral - -- but it's silly to insist on this in the RebindableSyntax case - ; unlessM (xoptM LangExt.RebindableSyntax) $ - do { icls <- tcLookupClass integralClassName - ; instStupidTheta orig [mkClassPred icls [pat_ty]] } - - ; res <- tcExtendIdEnv1 name bndr_id thing_inside - - ; let minus'' = case minus' of - NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus') - -- this should be statically avoidable - -- Case (3) from Note [NoSyntaxExpr] in Hs.Expr - SyntaxExprTc { syn_expr = minus'_expr - , syn_arg_wraps = minus'_arg_wraps - , syn_res_wrap = minus'_res_wrap } - -> SyntaxExprTc { syn_expr = minus'_expr - , syn_arg_wraps = minus'_arg_wraps - , syn_res_wrap = minus_wrap <.> minus'_res_wrap } - -- Oy. This should really be a record update, but - -- we get warnings if we try. #17783 - pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' - ge' minus'' - ; return (pat', res) } - --- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSplicePat'. --- Here we get rid of it and add the finalizers to the global environment. --- --- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. -tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat))) - pat_ty thing_inside - = do addModFinalizersWithLclEnv mod_finalizers - tc_pat penv pat pat_ty thing_inside - -tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut - - -{- -Note [Hopping the LIE in lazy patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a lazy pattern, we must *not* discharge constraints from the RHS -from dictionaries bound in the pattern. E.g. - f ~(C x) = 3 -We can't discharge the Num constraint from dictionaries bound by -the pattern C! - -So we have to make the constraints from thing_inside "hop around" -the pattern. Hence the captureConstraints and emitConstraints. - -The same thing ensures that equality constraints in a lazy match -are not made available in the RHS of the match. For example - data T a where { T1 :: Int -> T Int; ... } - f :: T a -> Int -> a - f ~(T1 i) y = y -It's obviously not sound to refine a to Int in the right -hand side, because the argument might not match T1 at all! - -Finally, a lazy pattern should not bind any existential type variables -because they won't be in scope when we do the desugaring - - -************************************************************************ -* * - Most of the work for constructors is here - (the rest is in the ConPatIn case of tc_pat) -* * -************************************************************************ - -[Pattern matching indexed data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following declarations: - - data family Map k :: * -> * - data instance Map (a, b) v = MapPair (Map a (Pair b v)) - -and a case expression - - case x :: Map (Int, c) w of MapPair m -> ... - -As explained by [Wrappers for data instance tycons] in GHC.Types.Id.Make, the -worker/wrapper types for MapPair are - - $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v - $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v - -So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is -:R123Map, which means the straight use of boxySplitTyConApp would give a type -error. Hence, the smart wrapper function boxySplitTyConAppWithFamily calls -boxySplitTyConApp with the family tycon Map instead, which gives us the family -type list {(Int, c), w}. To get the correct split for :R123Map, we need to -unify the family type list {(Int, c), w} with the instance types {(a, b), v} -(provided by tyConFamInst_maybe together with the family tycon). This -unification yields the substitution [a -> Int, b -> c, v -> w], which gives us -the split arguments for the representation tycon :R123Map as {Int, c, w} - -In other words, boxySplitTyConAppWithFamily implicitly takes the coercion - - Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} - -moving between representation and family type into account. To produce type -correct Core, this coercion needs to be used to case the type of the scrutinee -from the family to the representation type. This is achieved by -unwrapFamInstScrutinee using a CoPat around the result pattern. - -Now it might appear seem as if we could have used the previous GADT type -refinement infrastructure of refineAlt and friends instead of the explicit -unification and CoPat generation. However, that would be wrong. Why? The -whole point of GADT refinement is that the refinement is local to the case -alternative. In contrast, the substitution generated by the unification of -the family type list and instance types needs to be propagated to the outside. -Imagine that in the above example, the type of the scrutinee would have been -(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the -substitution [x -> (a, b), v -> w]. In contrast to GADT matching, the -instantiation of x with (a, b) must be global; ie, it must be valid in *all* -alternatives of the case expression, whereas in the GADT case it might vary -between alternatives. - -RIP GADT refinement: refinements have been replaced by the use of explicit -equality constraints that are used in conjunction with implication constraints -to express the local scope of GADT refinements. --} - --- Running example: --- MkT :: forall a b c. (a~[b]) => b -> c -> T a --- with scrutinee of type (T ty) - -tcConPat :: PatEnv -> Located Name - -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails GhcRn -> TcM a - -> TcM (Pat GhcTcId, a) -tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside - = do { con_like <- tcLookupConLike con_name - ; case con_like of - RealDataCon data_con -> tcDataConPat penv con_lname data_con - pat_ty arg_pats thing_inside - PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn - pat_ty arg_pats thing_inside - } - -tcDataConPat :: PatEnv -> Located Name -> DataCon - -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails GhcRn -> TcM a - -> TcM (Pat GhcTcId, a) -tcDataConPat penv (L con_span con_name) data_con pat_ty - arg_pats thing_inside - = do { let tycon = dataConTyCon data_con - -- For data families this is the representation tycon - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) - = dataConFullSig data_con - header = L con_span (RealDataCon data_con) - - -- Instantiate the constructor type variables [a->ty] - -- This may involve doing a family-instance coercion, - -- and building a wrapper - ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty - ; pat_ty <- readExpType pat_ty - - -- Add the stupid theta - ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys - - ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys - ; checkExistentials ex_tvs all_arg_tys penv - - ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys - -- NB: Do not use zipTvSubst! See #14154 - -- We want to create a well-kinded substitution, so - -- that the instantiated type is well-kinded - - ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs - -- Get location from monad, not from ex_tvs - - ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys - -- pat_ty' is type of the actual constructor application - -- pat_ty' /= pat_ty iff coi /= IdCo - - arg_tys' = substTys tenv arg_tys - - ; traceTc "tcConPat" (vcat [ ppr con_name - , pprTyVars univ_tvs - , pprTyVars ex_tvs - , ppr eq_spec - , ppr theta - , pprTyVars ex_tvs' - , ppr ctxt_res_tys - , ppr arg_tys' - , ppr arg_pats ]) - ; if null ex_tvs && null eq_spec && null theta - then do { -- The common case; no class bindings etc - -- (see Note [Arrows and patterns]) - (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys' - arg_pats penv thing_inside - ; let res_pat = ConPatOut { pat_con = header, - pat_tvs = [], pat_dicts = [], - pat_binds = emptyTcEvBinds, - pat_args = arg_pats', - pat_arg_tys = ctxt_res_tys, - pat_wrap = idHsWrapper } - - ; return (mkHsWrapPat wrap res_pat pat_ty, res) } - - else do -- The general case, with existential, - -- and local equality constraints - { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) - -- order is *important* as we generate the list of - -- dictionary binders from theta' - no_equalities = null eq_spec && not (any isEqPred theta) - skol_info = PatSkol (RealDataCon data_con) mc - mc = case pe_ctxt penv of - LamPat mc -> mc - LetPat {} -> PatBindRhs - - ; gadts_on <- xoptM LangExt.GADTs - ; families_on <- xoptM LangExt.TypeFamilies - ; checkTc (no_equalities || gadts_on || families_on) - (text "A pattern match on a GADT requires the" <+> - text "GADTs or TypeFamilies language extension") - -- #2905 decided that a *pattern-match* of a GADT - -- should require the GADT language flag. - -- Re TypeFamilies see also #7156 - - ; given <- newEvVars theta' - ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info ex_tvs' given $ - tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside - - ; let res_pat = ConPatOut { pat_con = header, - pat_tvs = ex_tvs', - pat_dicts = given, - pat_binds = ev_binds, - pat_args = arg_pats', - pat_arg_tys = ctxt_res_tys, - pat_wrap = idHsWrapper } - ; return (mkHsWrapPat wrap res_pat pat_ty, res) - } } - -tcPatSynPat :: PatEnv -> Located Name -> PatSyn - -> ExpSigmaType -- Type of the pattern - -> HsConPatDetails GhcRn -> TcM a - -> TcM (Pat GhcTcId, a) -tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside - = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn - - ; (subst, univ_tvs') <- newMetaTyVars univ_tvs - - ; let all_arg_tys = ty : prov_theta ++ arg_tys - ; checkExistentials ex_tvs all_arg_tys penv - ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs - ; let ty' = substTy tenv ty - arg_tys' = substTys tenv arg_tys - prov_theta' = substTheta tenv prov_theta - req_theta' = substTheta tenv req_theta - - ; wrap <- tcSubTypePat penv pat_ty ty' - ; traceTc "tcPatSynPat" (ppr pat_syn $$ - ppr pat_ty $$ - ppr ty' $$ - ppr ex_tvs' $$ - ppr prov_theta' $$ - ppr req_theta' $$ - ppr arg_tys') - - ; prov_dicts' <- newEvVars prov_theta' - - ; let skol_info = case pe_ctxt penv of - LamPat mc -> PatSkol (PatSynCon pat_syn) mc - LetPat {} -> UnkSkol -- Doesn't matter - - ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta' - ; traceTc "instCall" (ppr req_wrap) - - ; traceTc "checkConstraints {" Outputable.empty - ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info ex_tvs' prov_dicts' $ - tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside - - ; traceTc "checkConstraints }" (ppr ev_binds) - ; let res_pat = ConPatOut { pat_con = L con_span $ PatSynCon pat_syn, - pat_tvs = ex_tvs', - pat_dicts = prov_dicts', - pat_binds = ev_binds, - pat_args = arg_pats', - pat_arg_tys = mkTyVarTys univ_tvs', - pat_wrap = req_wrap } - ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap res_pat pat_ty, res) } - ----------------------------- --- | Convenient wrapper for calling a matchExpectedXXX function -matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a)) - -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a) --- See Note [Matching polytyped patterns] --- Returns a wrapper : pat_ty ~R inner_ty -matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty - = do { pat_ty <- expTypeToType pat_ty - ; (wrap, pat_rho) <- topInstantiate orig pat_ty - ; (co, res) <- inner_match pat_rho - ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap) - ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) } - ----------------------------- -matchExpectedConTy :: PatEnv - -> TyCon -- The TyCon that this data - -- constructor actually returns - -- In the case of a data family this is - -- the /representation/ TyCon - -> ExpSigmaType -- The type of the pattern; in the case - -- of a data family this would mention - -- the /family/ TyCon - -> TcM (HsWrapper, [TcSigmaType]) --- See Note [Matching constructor patterns] --- Returns a wrapper : pat_ty "->" T ty1 ... tyn -matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty - | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc - -- Comments refer to Note [Matching constructor patterns] - -- co_tc :: forall a. T [a] ~ T7 a - = do { pat_ty <- expTypeToType exp_pat_ty - ; (wrap, pat_rho) <- topInstantiate orig pat_ty - - ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc) - -- tys = [ty1,ty2] - - ; traceTc "matchExpectedConTy" (vcat [ppr data_tc, - ppr (tyConTyVars data_tc), - ppr fam_tc, ppr fam_args, - ppr exp_pat_ty, - ppr pat_ty, - ppr pat_rho, ppr wrap]) - ; co1 <- unifyType Nothing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho - -- co1 : T (ty1,ty2) ~N pat_rho - -- could use tcSubType here... but it's the wrong way round - -- for actual vs. expected in error messages. - - ; let tys' = mkTyVarTys tvs' - co2 = mkTcUnbranchedAxInstCo co_tc tys' [] - -- co2 : T (ty1,ty2) ~R T7 ty1 ty2 - - full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2 - -- full_co :: pat_rho ~R T7 ty1 ty2 - - ; return ( mkWpCastR full_co <.> wrap, tys') } - - | otherwise - = do { pat_ty <- expTypeToType exp_pat_ty - ; (wrap, pat_rho) <- topInstantiate orig pat_ty - ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho - ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) } - -{- -Note [Matching constructor patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose (coi, tys) = matchExpectedConType data_tc pat_ty - - * In the simple case, pat_ty = tc tys - - * If pat_ty is a polytype, we want to instantiate it - This is like part of a subsumption check. Eg - f :: (forall a. [a]) -> blah - f [] = blah - - * In a type family case, suppose we have - data family T a - data instance T (p,q) = A p | B q - Then we'll have internally generated - data T7 p q = A p | B q - axiom coT7 p q :: T (p,q) ~ T7 p q - - So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that - coi = coi2 . coi1 : T7 t ~ pat_ty - coi1 : T (ty1,ty2) ~ pat_ty - coi2 : T7 ty1 ty2 ~ T (ty1,ty2) - - For families we do all this matching here, not in the unifier, - because we never want a whisper of the data_tycon to appear in - error messages; it's a purely internal thing --} - -tcConArgs :: ConLike -> [TcSigmaType] - -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) - -tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside - = do { checkTc (con_arity == no_of_args) -- Check correct arity - (arityErr (text "constructor") con_like con_arity no_of_args) - ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys - ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys - penv thing_inside - ; return (PrefixCon arg_pats', res) } - where - con_arity = conLikeArity con_like - no_of_args = length arg_pats - -tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside - = do { checkTc (con_arity == 2) -- Check correct arity - (arityErr (text "constructor") con_like con_arity 2) - ; let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after the arity check - ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)] - penv thing_inside - ; return (InfixCon p1' p2', res) } - where - con_arity = conLikeArity con_like - -tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside - = do { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside - ; return (RecCon (HsRecFields rpats' dd), res) } - where - tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) - (LHsRecField GhcTcId (LPat GhcTcId)) - tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) - penv thing_inside - = do { sel' <- tcLookupId sel - ; pat_ty <- setSrcSpan loc $ find_field_ty sel - (occNameFS $ rdrNameOcc rdr) - ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside - ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' - pun), res) } - tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _ - = panic "tcConArgs" - - - find_field_ty :: Name -> FieldLabelString -> TcM TcType - find_field_ty sel lbl - = case [ty | (fl, ty) <- field_tys, flSelector fl == sel] of - - -- No matching field; chances are this field label comes from some - -- other record type (or maybe none). If this happens, just fail, - -- otherwise we get crashes later (#8570), and similar: - -- f (R { foo = (a,b) }) = a+b - -- If foo isn't one of R's fields, we don't want to crash when - -- typechecking the "a+b". - [] -> failWith (badFieldCon con_like lbl) - - -- The normal case, when the field comes from the right constructor - (pat_ty : extras) -> do - traceTc "find_field" (ppr pat_ty <+> ppr extras) - ASSERT( null extras ) (return pat_ty) - - field_tys :: [(FieldLabel, TcType)] - field_tys = zip (conLikeFieldLabels con_like) arg_tys - -- Don't use zipEqual! If the constructor isn't really a record, then - -- dataConFieldLabels will be empty (and each field in the pattern - -- will generate an error below). - -tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc) -tcConArg (arg_pat, arg_ty) penv thing_inside - = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside - -addDataConStupidTheta :: DataCon -> [TcType] -> TcM () --- Instantiate the "stupid theta" of the data con, and throw --- the constraints into the constraint set -addDataConStupidTheta data_con inst_tys - | null stupid_theta = return () - | otherwise = instStupidTheta origin inst_theta - where - origin = OccurrenceOf (dataConName data_con) - -- The origin should always report "occurrence of C" - -- even when C occurs in a pattern - stupid_theta = dataConStupidTheta data_con - univ_tvs = dataConUnivTyVars data_con - tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys) - -- NB: inst_tys can be longer than the univ tyvars - -- because the constructor might have existentials - inst_theta = substTheta tenv stupid_theta - -{- -Note [Arrows and patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -(Oct 07) Arrow notation has the odd property that it involves -"holes in the scope". For example: - expr :: Arrow a => a () Int - expr = proc (y,z) -> do - x <- term -< y - expr' -< x - -Here the 'proc (y,z)' binding scopes over the arrow tails but not the -arrow body (e.g 'term'). As things stand (bogusly) all the -constraints from the proc body are gathered together, so constraints -from 'term' will be seen by the tcPat for (y,z). But we must *not* -bind constraints from 'term' here, because the desugarer will not make -these bindings scope over 'term'. - -The Right Thing is not to confuse these constraints together. But for -now the Easy Thing is to ensure that we do not have existential or -GADT constraints in a 'proc', and to short-cut the constraint -simplification for such vanilla patterns so that it binds no -constraints. Hence the 'fast path' in tcConPat; but it's also a good -plan for ordinary vanilla patterns to bypass the constraint -simplification step. - -************************************************************************ -* * - Note [Pattern coercions] -* * -************************************************************************ - -In principle, these program would be reasonable: - - f :: (forall a. a->a) -> Int - f (x :: Int->Int) = x 3 - - g :: (forall a. [a]) -> Bool - g [] = True - -In both cases, the function type signature restricts what arguments can be passed -in a call (to polymorphic ones). The pattern type signature then instantiates this -type. For example, in the first case, (forall a. a->a) <= Int -> Int, and we -generate the translated term - f = \x' :: (forall a. a->a). let x = x' Int in x 3 - -From a type-system point of view, this is perfectly fine, but it's *very* seldom useful. -And it requires a significant amount of code to implement, because we need to decorate -the translated pattern with coercion functions (generated from the subsumption check -by tcSub). - -So for now I'm just insisting on type *equality* in patterns. No subsumption. - -Old notes about desugaring, at a time when pattern coercions were handled: - -A SigPat is a type coercion and must be handled one at a time. We can't -combine them unless the type of the pattern inside is identical, and we don't -bother to check for that. For example: - - data T = T1 Int | T2 Bool - f :: (forall a. a -> a) -> T -> t - f (g::Int->Int) (T1 i) = T1 (g i) - f (g::Bool->Bool) (T2 b) = T2 (g b) - -We desugar this as follows: - - f = \ g::(forall a. a->a) t::T -> - let gi = g Int - in case t of { T1 i -> T1 (gi i) - other -> - let gb = g Bool - in case t of { T2 b -> T2 (gb b) - other -> fail }} - -Note that we do not treat the first column of patterns as a -column of variables, because the coerced variables (gi, gb) -would be of different types. So we get rather grotty code. -But I don't think this is a common case, and if it was we could -doubtless improve it. - -Meanwhile, the strategy is: - * treat each SigPat coercion (always non-identity coercions) - as a separate block - * deal with the stuff inside, and then wrap a binding round - the result to bind the new variable (gi, gb, etc) - - -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -Note [Existential check] -~~~~~~~~~~~~~~~~~~~~~~~~ -Lazy patterns can't bind existentials. They arise in two ways: - * Let bindings let { C a b = e } in b - * Twiddle patterns f ~(C a b) = e -The pe_lazy field of PatEnv says whether we are inside a lazy -pattern (perhaps deeply) - -See also Note [Typechecking pattern bindings] in TcBinds --} - -maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b --- Not all patterns are worth pushing a context -maybeWrapPatCtxt pat tcm thing_inside - | not (worth_wrapping pat) = tcm thing_inside - | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside - -- Remember to pop before doing thing_inside - where - worth_wrapping (VarPat {}) = False - worth_wrapping (ParPat {}) = False - worth_wrapping (AsPat {}) = False - worth_wrapping _ = True - msg = hang (text "In the pattern:") 2 (ppr pat) - ------------------------------------------------ -checkExistentials :: [TyVar] -- existentials - -> [Type] -- argument types - -> PatEnv -> TcM () - -- See Note [Existential check]] - -- See Note [Arrows and patterns] -checkExistentials ex_tvs tys _ - | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return () -checkExistentials _ _ (PE { pe_ctxt = LetPat {}}) = return () -checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr }) = failWithTc existentialProcPat -checkExistentials _ _ (PE { pe_lazy = True }) = failWithTc existentialLazyPat -checkExistentials _ _ _ = return () - -existentialLazyPat :: SDoc -existentialLazyPat - = hang (text "An existential or GADT data constructor cannot be used") - 2 (text "inside a lazy (~) pattern") - -existentialProcPat :: SDoc -existentialProcPat - = text "Proc patterns cannot use existential or GADT data constructors" - -badFieldCon :: ConLike -> FieldLabelString -> SDoc -badFieldCon con field - = hsep [text "Constructor" <+> quotes (ppr con), - text "does not have field", quotes (ppr field)] - -polyPatSig :: TcType -> SDoc -polyPatSig sig_ty - = hang (text "Illegal polymorphic type signature in pattern:") - 2 (ppr sig_ty) diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs deleted file mode 100644 index 4114eeca58..0000000000 --- a/compiler/typecheck/TcPatSyn.hs +++ /dev/null @@ -1,1150 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcPatSyn]{Typechecking pattern synonym declarations} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind - , tcPatSynBuilderOcc, nonBidirectionalErr - ) where - -import GhcPrelude - -import GHC.Hs -import TcPat -import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) -import TcRnMonad -import TcSigs( emptyPragEnv, completeSigFromId ) -import TcEnv -import TcMType -import TcHsSyn -import TysPrim -import GHC.Types.Name -import GHC.Types.SrcLoc -import GHC.Core.PatSyn -import GHC.Types.Name.Set -import Panic -import Outputable -import FastString -import GHC.Types.Var -import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSet ) -import GHC.Types.Id -import GHC.Types.Id.Info( RecSelParent(..), setLevityInfoWithType ) -import TcBinds -import GHC.Types.Basic -import TcSimplify -import TcUnify -import GHC.Core.Predicate -import TysWiredIn -import TcType -import TcEvidence -import TcOrigin -import BuildTyCl -import GHC.Types.Var.Set -import GHC.Types.Id.Make -import TcTyDecls -import GHC.Core.ConLike -import GHC.Types.FieldLabel -import Bag -import Util -import ErrUtils -import Data.Maybe( mapMaybe ) -import Control.Monad ( zipWithM ) -import Data.List( partition ) - -#include "HsVersions.h" - -{- -************************************************************************ -* * - Type checking a pattern synonym -* * -************************************************************************ --} - -tcPatSynDecl :: PatSynBind GhcRn GhcRn - -> Maybe TcSigInfo - -> TcM (LHsBinds GhcTc, TcGblEnv) -tcPatSynDecl psb mb_sig - = recoverM (recoverPSB psb) $ - case mb_sig of - Nothing -> tcInferPatSynDecl psb - Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi - _ -> panic "tcPatSynDecl" - -recoverPSB :: PatSynBind GhcRn GhcRn - -> TcM (LHsBinds GhcTc, TcGblEnv) --- See Note [Pattern synonym error recovery] -recoverPSB (PSB { psb_id = L _ name - , psb_args = details }) - = do { matcher_name <- newImplicitBinder name mkMatcherOcc - ; let placeholder = AConLike $ PatSynCon $ - mk_placeholder matcher_name - ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv - ; return (emptyBag, gbl_env) } - where - (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details - mk_placeholder matcher_name - = mkPatSyn name is_infix - ([mkTyVarBinder Specified alphaTyVar], []) ([], []) - [] -- Arg tys - alphaTy - (matcher_id, True) Nothing - [] -- Field labels - where - -- The matcher_id is used only by the desugarer, so actually - -- and error-thunk would probably do just as well here. - matcher_id = mkLocalId matcher_name $ - mkSpecForAllTys [alphaTyVar] alphaTy - -recoverPSB (XPatSynBind nec) = noExtCon nec - -{- Note [Pattern synonym error recovery] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If type inference for a pattern synonym fails, we can't continue with -the rest of tc_patsyn_finish, because we may get knock-on errors, or -even a crash. E.g. from - pattern What = True :: Maybe -we get a kind error; and we must stop right away (#15289). - -We stop if there are /any/ unsolved constraints, not just insoluble -ones; because pattern synonyms are top-level things, we will never -solve them later if we can't solve them now. And if we were to carry -on, tc_patsyn_finish does zonkTcTypeToType, which defaults any -unsolved unificatdion variables to Any, which confuses the error -reporting no end (#15685). - -So we use simplifyTop to completely solve the constraint, report -any errors, throw an exception. - -Even in the event of such an error we can recover and carry on, just -as we do for value bindings, provided we plug in placeholder for the -pattern synonym: see recoverPSB. The goal of the placeholder is not -to cause a raft of follow-on errors. I've used the simplest thing for -now, but we might need to elaborate it a bit later. (e.g. I've given -it zero args, which may cause knock-on errors if it is used in a -pattern.) But it'll do for now. - --} - -tcInferPatSynDecl :: PatSynBind GhcRn GhcRn - -> TcM (LHsBinds GhcTc, TcGblEnv) -tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details - , psb_def = lpat, psb_dir = dir }) - = addPatSynCtxt lname $ - do { traceTc "tcInferPatSynDecl {" $ ppr name - - ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details - ; (tclvl, wanted, ((lpat', args), pat_ty)) - <- pushLevelAndCaptureConstraints $ - tcInferNoInst $ \ exp_ty -> - tcPat PatSyn lpat exp_ty $ - mapM tcLookupId arg_names - - ; let (ex_tvs, prov_dicts) = tcCollectEx lpat' - - named_taus = (name, pat_ty) : map mk_named_tau args - mk_named_tau arg - = (getName arg, mkSpecForAllTys ex_tvs (varType arg)) - -- The mkSpecForAllTys is important (#14552), albeit - -- slightly artificial (there is no variable with this funny type). - -- We do not want to quantify over variable (alpha::k) - -- that mention the existentially-bound type variables - -- ex_tvs in its kind k. - -- See Note [Type variables whose kind is captured] - - ; (univ_tvs, req_dicts, ev_binds, residual, _) - <- simplifyInfer tclvl NoRestrictions [] named_taus wanted - ; top_ev_binds <- checkNoErrs (simplifyTop residual) - ; addTopEvBinds top_ev_binds $ - - do { prov_dicts <- mapM zonkId prov_dicts - ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts - -- Filtering: see Note [Remove redundant provided dicts] - (prov_theta, prov_evs) - = unzip (mapMaybe mkProvEvidence filtered_prov_dicts) - req_theta = map evVarPred req_dicts - - -- Report coercions that escape - -- See Note [Coercions that escape] - ; args <- mapM zonkId args - ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts - , let bad_cos = filterDVarSet isId $ - (tyCoVarsOfTypeDSet (idType arg)) - , not (isEmptyDVarSet bad_cos) ] - ; mapM_ dependentArgErr bad_args - - ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) - ; tc_patsyn_finish lname dir is_infix lpat' - (mkTyVarBinders Inferred univ_tvs - , req_theta, ev_binds, req_dicts) - (mkTyVarBinders Inferred ex_tvs - , mkTyVarTys ex_tvs, prov_theta, prov_evs) - (map nlHsVar args, map idType args) - pat_ty rec_fields } } -tcInferPatSynDecl (XPatSynBind nec) = noExtCon nec - -mkProvEvidence :: EvId -> Maybe (PredType, EvTerm) --- See Note [Equality evidence in pattern synonyms] -mkProvEvidence ev_id - | EqPred r ty1 ty2 <- classifyPredType pred - , let k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 - is_homo = k1 `tcEqType` k2 - homo_tys = [k1, ty1, ty2] - hetero_tys = [k1, k2, ty1, ty2] - = case r of - ReprEq | is_homo - -> Just ( mkClassPred coercibleClass homo_tys - , evDataConApp coercibleDataCon homo_tys eq_con_args ) - | otherwise -> Nothing - NomEq | is_homo - -> Just ( mkClassPred eqClass homo_tys - , evDataConApp eqDataCon homo_tys eq_con_args ) - | otherwise - -> Just ( mkClassPred heqClass hetero_tys - , evDataConApp heqDataCon hetero_tys eq_con_args ) - - | otherwise - = Just (pred, EvExpr (evId ev_id)) - where - pred = evVarPred ev_id - eq_con_args = [evId ev_id] - -dependentArgErr :: (Id, DTyCoVarSet) -> TcM () --- See Note [Coercions that escape] -dependentArgErr (arg, bad_cos) - = addErrTc $ - vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!" - , hang (text "Pattern-bound variable") - 2 (ppr arg <+> dcolon <+> ppr (idType arg)) - , nest 2 $ - hang (text "has a type that mentions pattern-bound coercion" - <> plural bad_co_list <> colon) - 2 (pprWithCommas ppr bad_co_list) - , text "Hint: use -fprint-explicit-coercions to see the coercions" - , text "Probable fix: add a pattern signature" ] - where - bad_co_list = dVarSetElems bad_cos - -{- Note [Type variables whose kind is captured] -~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data AST a = Sym [a] - class Prj s where { prj :: [a] -> Maybe (s a) } - pattern P x <= Sym (prj -> Just x) - -Here we get a matcher with this type - $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r - -No problem. But note that 's' is not fixed by the type of the -pattern (AST a), nor is it existentially bound. It's really only -fixed by the type of the continuation. - -#14552 showed that this can go wrong if the kind of 's' mentions -existentially bound variables. We obviously can't make a type like - $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r) - -> r -> r -But neither is 's' itself existentially bound, so the forall (s::k->*) -can't go in the inner forall either. (What would the matcher apply -the continuation to?) - -Solution: do not quantiify over any unification variable whose kind -mentions the existentials. We can conveniently do that by making the -"taus" passed to simplifyInfer look like - forall ex_tvs. arg_ty - -After that, Note [Naughty quantification candidates] in TcMType takes -over and errors. - -Note [Remove redundant provided dicts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recall that - HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2) - => a1 :~~: a2 -(NB: technically the (k1~k2) existential dictionary is not necessary, -but it's there at the moment.) - -Now consider (#14394): - pattern Foo = HRefl -in a non-poly-kinded module. We don't want to get - pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b -with that redundant (* ~ *). We'd like to remove it; hence the call to -mkMinimalWithSCs. - -Similarly consider - data S a where { MkS :: Ord a => a -> S a } - pattern Bam x y <- (MkS (x::a), MkS (y::a))) - -The pattern (Bam x y) binds two (Ord a) dictionaries, but we only -need one. Again mkMimimalWithSCs removes the redundant one. - -Note [Equality evidence in pattern synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data X a where - MkX :: Eq a => [a] -> X (Maybe a) - pattern P x = MkG x - -Then there is a danger that GHC will infer - P :: forall a. () => - forall b. (a ~# Maybe b, Eq b) => [b] -> X a - -The 'builder' for P, which is called in user-code, will then -have type - $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a - -and that is bad because (a ~# Maybe b) is not a predicate type -(see Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep -and is not implicitly instantiated. - -So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and -marginally less efficient, if the builder/martcher are not inlined. - -See also Note [Lift equality constraints when quantifying] in TcType - -Note [Coercions that escape] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#14507 showed an example where the inferred type of the matcher -for the pattern synonym was something like - $mSO :: forall (r :: TYPE rep) kk (a :: k). - TypeRep k a - -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r) - -> (Void# -> r) - -> r - -What is that co_a2sv :: Bool ~# *?? It was bound (via a superclass -selection) by the pattern being matched; and indeed it is implicit in -the context (Bool ~ k). You could imagine trying to extract it like -this: - $mSO :: forall (r :: TYPE rep) kk (a :: k). - TypeRep k a - -> ( co :: ((Bool :: *) ~ (k :: *)) => - let co_a2sv = sc_sel co - in TypeRep Bool (a |> co_a2sv) -> r) - -> (Void# -> r) - -> r - -But we simply don't allow that in types. Maybe one day but not now. - -How to detect this situation? We just look for free coercion variables -in the types of any of the arguments to the matcher. The error message -is not very helpful, but at least we don't get a Lint error. --} - -tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn - -> TcPatSynInfo - -> TcM (LHsBinds GhcTc, TcGblEnv) -tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details - , psb_def = lpat, psb_dir = dir } - TPSI{ patsig_implicit_bndrs = implicit_tvs - , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta - , patsig_ex_bndrs = explicit_ex_tvs, patsig_req = req_theta - , patsig_body_ty = sig_body_ty } - = addPatSynCtxt lname $ - do { let decl_arity = length arg_names - (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details - - ; traceTc "tcCheckPatSynDecl" $ - vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta - , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ] - - ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of - Right stuff -> return stuff - Left missing -> wrongNumberOfParmsErr name decl_arity missing - - -- Complain about: pattern P :: () => forall x. x -> P x - -- The existential 'x' should not appear in the result type - -- Can't check this until we know P's arity - ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs - ; checkTc (null bad_tvs) $ - hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma - , text "namely" <+> quotes (ppr pat_ty) ]) - 2 (text "mentions existential type variable" <> plural bad_tvs - <+> pprQuotedList bad_tvs) - - -- See Note [The pattern-synonym signature splitting rule] in TcSigs - ; let univ_fvs = closeOverKinds $ - (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs) - (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs - univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs - ex_bndrs = extra_ex ++ mkTyVarBinders Specified explicit_ex_tvs - univ_tvs = binderVars univ_bndrs - ex_tvs = binderVars ex_bndrs - - -- Right! Let's check the pattern against the signature - -- See Note [Checking against a pattern signature] - ; req_dicts <- newEvVars req_theta - ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <- - ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys ) - pushLevelAndCaptureConstraints $ - tcExtendTyVarEnv univ_tvs $ - tcPat PatSyn lpat (mkCheckExpType pat_ty) $ - do { let in_scope = mkInScopeSet (mkVarSet univ_tvs) - empty_subst = mkEmptyTCvSubst in_scope - ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs - -- newMetaTyVarX: see the "Existential type variables" - -- part of Note [Checking against a pattern signature] - ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs]) - ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs']) - ; let prov_theta' = substTheta subst prov_theta - -- Add univ_tvs to the in_scope set to - -- satisfy the substitution invariant. There's no need to - -- add 'ex_tvs' as they are already in the domain of the - -- substitution. - -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. - ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta' - ; args' <- zipWithM (tc_arg subst) arg_names arg_tys - ; return (ex_tvs', prov_dicts, args') } - - ; let skol_info = SigSkol (PatSynCtxt name) pat_ty [] - -- The type here is a bit bogus, but we do not print - -- the type for PatSynCtxt, so it doesn't matter - -- See Note [Skolem info for pattern synonyms] in Origin - ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted - - -- Solve the constraints now, because we are about to make a PatSyn, - -- which should not contain unification variables and the like (#10997) - ; simplifyTopImplic implics - - -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct - -- Otherwise we may get a type error when typechecking the builder, - -- when that should be impossible - - ; traceTc "tcCheckPatSynDecl }" $ ppr name - ; tc_patsyn_finish lname dir is_infix lpat' - (univ_bndrs, req_theta, ev_binds, req_dicts) - (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts) - (args', arg_tys) - pat_ty rec_fields } - where - tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId) - tc_arg subst arg_name arg_ty - = do { -- Look up the variable actually bound by lpat - -- and check that it has the expected type - arg_id <- tcLookupId arg_name - ; wrap <- tcSubType_NC GenSigCtxt - (idType arg_id) - (substTyUnchecked subst arg_ty) - -- Why do we need tcSubType here? - -- See Note [Pattern synonyms and higher rank types] - ; return (mkLHsWrap wrap $ nlHsVar arg_id) } -tcCheckPatSynDecl (XPatSynBind nec) _ = noExtCon nec - -{- [Pattern synonyms and higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = MkT (forall a. a->a) - - pattern P :: (Int -> Int) -> T - pattern P x <- MkT x - -This should work. But in the matcher we must match against MkT, and then -instantiate its argument 'x', to get a function of type (Int -> Int). -Equality is not enough! #13752 was an example. - - -Note [The pattern-synonym signature splitting rule] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a pattern signature, we must split - the kind-generalised variables, and - the implicitly-bound variables -into universal and existential. The rule is this -(see discussion on #11224): - - The universal tyvars are the ones mentioned in - - univ_tvs: the user-specified (forall'd) universals - - req_theta - - res_ty - The existential tyvars are all the rest - -For example - - pattern P :: () => b -> T a - pattern P x = ... - -Here 'a' is universal, and 'b' is existential. But there is a wrinkle: -how do we split the arg_tys from req_ty? Consider - - pattern Q :: () => b -> S c -> T a - pattern Q x = ... - -This is an odd example because Q has only one syntactic argument, and -so presumably is defined by a view pattern matching a function. But -it can happen (#11977, #12108). - -We don't know Q's arity from the pattern signature, so we have to wait -until we see the pattern declaration itself before deciding res_ty is, -and hence which variables are existential and which are universal. - -And that in turn is why TcPatSynInfo has a separate field, -patsig_implicit_bndrs, to capture the implicitly bound type variables, -because we don't yet know how to split them up. - -It's a slight compromise, because it means we don't really know the -pattern synonym's real signature until we see its declaration. So, -for example, in hs-boot file, we may need to think what to do... -(eg don't have any implicitly-bound variables). - - -Note [Checking against a pattern signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When checking the actual supplied pattern against the pattern synonym -signature, we need to be quite careful. - ------ Provided constraints -Example - - data T a where - MkT :: Ord a => a -> T a - - pattern P :: () => Eq a => a -> [T a] - pattern P x = [MkT x] - -We must check that the (Eq a) that P claims to bind (and to -make available to matches against P), is derivable from the -actual pattern. For example: - f (P (x::a)) = ...here (Eq a) should be available... -And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs. - ------ Existential type variables -Unusually, we instantiate the existential tyvars of the pattern with -*meta* type variables. For example - - data S where - MkS :: Eq a => [a] -> S - - pattern P :: () => Eq x => x -> S - pattern P x <- MkS x - -The pattern synonym conceals from its client the fact that MkS has a -list inside it. The client just thinks it's a type 'x'. So we must -unify x := [a] during type checking, and then use the instantiating type -[a] (called ex_tys) when building the matcher. In this case we'll get - - $mP :: S -> (forall x. Ex x => x -> r) -> r -> r - $mP x k = case x of - MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a] - dl = $dfunEqList d - in k [a] dl ys - -All this applies when type-checking the /matching/ side of -a pattern synonym. What about the /building/ side? - -* For Unidirectional, there is no builder - -* For ExplicitBidirectional, the builder is completely separate - code, typechecked in tcPatSynBuilderBind - -* For ImplicitBidirectional, the builder is still typechecked in - tcPatSynBuilderBind, by converting the pattern to an expression and - typechecking it. - - At one point, for ImplicitBidirectional I used TyVarTvs (instead of - TauTvs) in tcCheckPatSynDecl. But (a) strengthening the check here - is redundant since tcPatSynBuilderBind does the job, (b) it was - still incomplete (TyVarTvs can unify with each other), and (c) it - didn't even work (#13441 was accepted with - ExplicitBidirectional, but rejected if expressed in - ImplicitBidirectional form. Conclusion: trying to be too clever is - a bad idea. --} - -collectPatSynArgInfo :: HsPatSynDetails (Located Name) - -> ([Name], [Name], Bool) -collectPatSynArgInfo details = - case details of - PrefixCon names -> (map unLoc names, [], False) - InfixCon name1 name2 -> (map unLoc [name1, name2], [], True) - RecCon names -> (vars, sels, False) - where - (vars, sels) = unzip (map splitRecordPatSyn names) - where - splitRecordPatSyn :: RecordPatSynField (Located Name) - -> (Name, Name) - splitRecordPatSyn (RecordPatSynField - { recordPatSynPatVar = L _ patVar - , recordPatSynSelectorId = L _ selId }) - = (patVar, selId) - -addPatSynCtxt :: Located Name -> TcM a -> TcM a -addPatSynCtxt (L loc name) thing_inside - = setSrcSpan loc $ - addErrCtxt (text "In the declaration for pattern synonym" - <+> quotes (ppr name)) $ - thing_inside - -wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a -wrongNumberOfParmsErr name decl_arity missing - = failWithTc $ - hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has") - <+> speakNOf decl_arity (text "argument")) - 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") - -------------------------- --- Shared by both tcInferPatSyn and tcCheckPatSyn -tc_patsyn_finish :: Located Name -- ^ PatSyn Name - -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) - -> Bool -- ^ Whether infix - -> LPat GhcTc -- ^ Pattern of the PatSyn - -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar]) - -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm]) - -> ([LHsExpr GhcTcId], [TcType]) -- ^ Pattern arguments and - -- types - -> TcType -- ^ Pattern type - -> [Name] -- ^ Selector names - -- ^ Whether fields, empty if not record PatSyn - -> TcM (LHsBinds GhcTc, TcGblEnv) -tc_patsyn_finish lname dir is_infix lpat' - (univ_tvs, req_theta, req_ev_binds, req_dicts) - (ex_tvs, ex_tys, prov_theta, prov_dicts) - (args, arg_tys) - pat_ty field_labels - = do { -- Zonk everything. We are about to build a final PatSyn - -- so there had better be no unification variables in there - - (ze, univ_tvs') <- zonkTyVarBinders univ_tvs - ; req_theta' <- zonkTcTypesToTypesX ze req_theta - ; (ze, ex_tvs') <- zonkTyVarBindersX ze ex_tvs - ; prov_theta' <- zonkTcTypesToTypesX ze prov_theta - ; pat_ty' <- zonkTcTypeToTypeX ze pat_ty - ; arg_tys' <- zonkTcTypesToTypesX ze arg_tys - - ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs' - (env2, ex_tvs) = tidyTyCoVarBinders env1 ex_tvs' - req_theta = tidyTypes env2 req_theta' - prov_theta = tidyTypes env2 prov_theta' - arg_tys = tidyTypes env2 arg_tys' - pat_ty = tidyType env2 pat_ty' - - ; traceTc "tc_patsyn_finish {" $ - ppr (unLoc lname) $$ ppr (unLoc lpat') $$ - ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$ - ppr (ex_tvs, prov_theta, prov_dicts) $$ - ppr args $$ - ppr arg_tys $$ - ppr pat_ty - - -- Make the 'matcher' - ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' - (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts) - (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts) - (args, arg_tys) - pat_ty - - -- Make the 'builder' - ; builder_id <- mkPatSynBuilderId dir lname - univ_tvs req_theta - ex_tvs prov_theta - arg_tys pat_ty - - -- TODO: Make this have the proper information - ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name) - , flIsOverloaded = False - , flSelector = name } - field_labels' = map mkFieldLabel field_labels - - - -- Make the PatSyn itself - ; let patSyn = mkPatSyn (unLoc lname) is_infix - (univ_tvs, req_theta) - (ex_tvs, prov_theta) - arg_tys - pat_ty - matcher_id builder_id - field_labels' - - -- Selectors - ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) - tything = AConLike (PatSynCon patSyn) - ; tcg_env <- tcExtendGlobalEnv [tything] $ - tcRecSelBinds rn_rec_sel_binds - - ; traceTc "tc_patsyn_finish }" empty - ; return (matcher_bind, tcg_env) } - -{- -************************************************************************ -* * - Constructing the "matcher" Id and its binding -* * -************************************************************************ --} - -tcPatSynMatcher :: Located Name - -> LPat GhcTc - -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) - -> ([TcTyVar], [TcType], ThetaType, [EvTerm]) - -> ([LHsExpr GhcTcId], [TcType]) - -> TcType - -> TcM ((Id, Bool), LHsBinds GhcTc) --- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn -tcPatSynMatcher (L loc name) lpat - (univ_tvs, req_theta, req_ev_binds, req_dicts) - (ex_tvs, ex_tys, prov_theta, prov_dicts) - (args, arg_tys) pat_ty - = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc - ; tv_name <- newNameAt (mkTyVarOcc "r") loc - ; let rr_tv = mkTyVar rr_name runtimeRepTy - rr = mkTyVarTy rr_tv - res_tv = mkTyVar tv_name (tYPE rr) - res_ty = mkTyVarTy res_tv - is_unlifted = null args && null prov_dicts - (cont_args, cont_arg_tys) - | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy]) - | otherwise = (args, arg_tys) - cont_ty = mkInfSigmaTy ex_tvs prov_theta $ - mkVisFunTys cont_arg_tys res_ty - - fail_ty = mkVisFunTy voidPrimTy res_ty - - ; matcher_name <- newImplicitBinder name mkMatcherOcc - ; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty - ; cont <- newSysLocalId (fsLit "cont") cont_ty - ; fail <- newSysLocalId (fsLit "fail") fail_ty - - ; let matcher_tau = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty - matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau - matcher_id = mkExportedVanillaId matcher_name matcher_sigma - -- See Note [Exported LocalIds] in GHC.Types.Id - - inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys - cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args - - fail' = nlHsApps fail [nlHsVar voidPrimId] - - args = map nlVarPat [scrutinee, cont, fail] - lwpat = noLoc $ WildPat pat_ty - cases = if isIrrefutableHsPat lpat - then [mkHsCaseAlt lpat cont'] - else [mkHsCaseAlt lpat cont', - mkHsCaseAlt lwpat fail'] - body = mkLHsWrap (mkWpLet req_ev_binds) $ - L (getLoc lpat) $ - HsCase noExtField (nlHsVar scrutinee) $ - MG{ mg_alts = L (getLoc lpat) cases - , mg_ext = MatchGroupTc [pat_ty] res_ty - , mg_origin = Generated - } - body' = noLoc $ - HsLam noExtField $ - MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr - args body] - , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty - , mg_origin = Generated - } - match = mkMatch (mkPrefixFunRhs (L loc name)) [] - (mkHsLams (rr_tv:res_tv:univ_tvs) - req_dicts body') - (noLoc (EmptyLocalBinds noExtField)) - mg :: MatchGroup GhcTc (LHsExpr GhcTc) - mg = MG{ mg_alts = L (getLoc match) [match] - , mg_ext = MatchGroupTc [] res_ty - , mg_origin = Generated - } - - ; let bind = FunBind{ fun_id = L loc matcher_id - , fun_matches = mg - , fun_ext = idHsWrapper - , fun_tick = [] } - matcher_bind = unitBag (noLoc bind) - - ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) - ; traceTc "tcPatSynMatcher" (ppr matcher_bind) - - ; return ((matcher_id, is_unlifted), matcher_bind) } - -mkPatSynRecSelBinds :: PatSyn - -> [FieldLabel] -- ^ Visible field labels - -> [(Id, LHsBind GhcRn)] -mkPatSynRecSelBinds ps fields - = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl - | fld_lbl <- fields ] - -isUnidirectional :: HsPatSynDir a -> Bool -isUnidirectional Unidirectional = True -isUnidirectional ImplicitBidirectional = False -isUnidirectional ExplicitBidirectional{} = False - -{- -************************************************************************ -* * - Constructing the "builder" Id -* * -************************************************************************ --} - -mkPatSynBuilderId :: HsPatSynDir a -> Located Name - -> [TyVarBinder] -> ThetaType - -> [TyVarBinder] -> ThetaType - -> [Type] -> Type - -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (L _ name) - univ_bndrs req_theta ex_bndrs prov_theta - arg_tys pat_ty - | isUnidirectional dir - = return Nothing - | otherwise - = do { builder_name <- newImplicitBinder name mkBuilderOcc - ; let theta = req_theta ++ prov_theta - need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta - builder_sigma = add_void need_dummy_arg $ - mkForAllTys univ_bndrs $ - mkForAllTys ex_bndrs $ - mkPhiTy theta $ - mkVisFunTys arg_tys $ - pat_ty - builder_id = mkExportedVanillaId builder_name builder_sigma - -- See Note [Exported LocalIds] in GHC.Types.Id - - builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id - - ; return (Just (builder_id', need_dummy_arg)) } - where - -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn - -> TcM (LHsBinds GhcTc) --- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn -tcPatSynBuilderBind (PSB { psb_id = L loc name - , psb_def = lpat - , psb_dir = dir - , psb_args = details }) - | isUnidirectional dir - = return emptyBag - - | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLoc lpat) $ failWithTc $ - vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" - <+> quotes (ppr name) <> colon) - 2 why - , text "RHS pattern:" <+> ppr lpat ] - - | Right match_group <- mb_match_group -- Bidirectional - = do { patsyn <- tcLookupPatSyn name - ; case patSynBuilder patsyn of { - Nothing -> return emptyBag ; - -- This case happens if we found a type error in the - -- pattern synonym, recovered, and put a placeholder - -- with patSynBuilder=Nothing in the environment - - Just (builder_id, need_dummy_arg) -> -- Normal case - do { -- Bidirectional, so patSynBuilder returns Just - let match_group' | need_dummy_arg = add_dummy_arg match_group - | otherwise = match_group - - bind = FunBind { fun_id = L loc (idName builder_id) - , fun_matches = match_group' - , fun_ext = emptyNameSet - , fun_tick = [] } - - sig = completeSigFromId (PatSynCtxt name) builder_id - - ; traceTc "tcPatSynBuilderBind {" $ - ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id) - ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) - ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds - ; return builder_binds } } } - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "tcPatSynBuilderBind" -- Both cases dealt with -#endif - where - mb_match_group - = case dir of - ExplicitBidirectional explicit_mg -> Right explicit_mg - ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat) - Unidirectional -> panic "tcPatSynBuilderBind" - - mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) - mk_mg body = mkMatchGroup Generated [builder_match] - where - builder_args = [L loc (VarPat noExtField (L loc n)) - | L loc n <- args] - builder_match = mkMatch (mkPrefixFunRhs (L loc name)) - builder_args body - (noLoc (EmptyLocalBinds noExtField)) - - args = case details of - PrefixCon args -> args - InfixCon arg1 arg2 -> [arg1, arg2] - RecCon args -> map recordPatSynPatVar args - - add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn) - -> MatchGroup GhcRn (LHsExpr GhcRn) - add_dummy_arg mg@(MG { mg_alts = - (L l [L loc match@(Match { m_pats = pats })]) }) - = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } - add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ - pprMatches other_mg -tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec - -tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType) --- monadic only for failure -tcPatSynBuilderOcc ps - | Just (builder_id, add_void_arg) <- builder - , let builder_expr = HsConLikeOut noExtField (PatSynCon ps) - builder_ty = idType builder_id - = return $ - if add_void_arg - then ( builder_expr -- still just return builder_expr; the void# arg is added - -- by dsConLike in the desugarer - , tcFunResultTy builder_ty ) - else (builder_expr, builder_ty) - - | otherwise -- Unidirectional - = nonBidirectionalErr name - where - name = patSynName ps - builder = patSynBuilder ps - -add_void :: Bool -> Type -> Type -add_void need_dummy_arg ty - | need_dummy_arg = mkVisFunTy voidPrimTy ty - | otherwise = ty - -tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn - -> Either MsgDoc (LHsExpr GhcRn) --- Given a /pattern/, return an /expression/ that builds a value --- that matches the pattern. E.g. if the pattern is (Just [x]), --- the expression is (Just [x]). They look the same, but the --- input uses constructors from HsPat and the output uses constructors --- from HsExpr. --- --- Returns (Left r) if the pattern is not invertible, for reason r. --- See Note [Builder for a bidirectional pattern synonym] -tcPatToExpr name args pat = go pat - where - lhsVars = mkNameSet (map unLoc args) - - -- Make a prefix con for prefix and infix patterns for simplicity - mkPrefixConExpr :: Located Name -> [LPat GhcRn] - -> Either MsgDoc (HsExpr GhcRn) - mkPrefixConExpr lcon@(L loc _) pats - = do { exprs <- mapM go pats - ; return (foldl' (\x y -> HsApp noExtField (L loc x) y) - (HsVar noExtField lcon) exprs) } - - mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) - -> Either MsgDoc (HsExpr GhcRn) - mkRecordConExpr con fields - = do { exprFields <- mapM go fields - ; return (RecordCon noExtField con exprFields) } - - go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) - go (L loc p) = L loc <$> go1 p - - go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) - go1 (ConPatIn con info) - = case info of - PrefixCon ps -> mkPrefixConExpr con ps - InfixCon l r -> mkPrefixConExpr con [l,r] - RecCon fields -> mkRecordConExpr con fields - - go1 (SigPat _ pat _) = go1 (unLoc pat) - -- See Note [Type signatures and the builder expression] - - go1 (VarPat _ (L l var)) - | var `elemNameSet` lhsVars - = return $ HsVar noExtField (L l var) - | otherwise - = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") - go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat - go1 p@(ListPat reb pats) - | Nothing <- reb = do { exprs <- mapM go pats - ; return $ ExplicitList noExtField Nothing exprs } - | otherwise = notInvertibleListPat p - go1 (TuplePat _ pats box) = do { exprs <- mapM go pats - ; return $ ExplicitTuple noExtField - (map (noLoc . (Present noExtField)) exprs) - box } - go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) - ; return $ ExplicitSum noExtField alt arity - (noLoc expr) - } - go1 (LitPat _ lit) = return $ HsLit noExtField lit - go1 (NPat _ (L _ n) mb_neg _) - | Just (SyntaxExprRn neg) <- mb_neg - = return $ unLoc $ foldl' nlHsApp (noLoc neg) - [noLoc (HsOverLit noExtField n)] - | otherwise = return $ HsOverLit noExtField n - go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" - go1 (CoPat{}) = panic "CoPat in output of renamer" - go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) - = go1 pat - go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" - - -- The following patterns are not invertible. - go1 p@(BangPat {}) = notInvertible p -- #14112 - go1 p@(LazyPat {}) = notInvertible p - go1 p@(WildPat {}) = notInvertible p - go1 p@(AsPat {}) = notInvertible p - go1 p@(ViewPat {}) = notInvertible p - go1 p@(NPlusKPat {}) = notInvertible p - go1 (XPat nec) = noExtCon nec - go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p - go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p - go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p - go1 (SplicePat _ (XSplice nec)) = noExtCon nec - - notInvertible p = Left (not_invertible_msg p) - - not_invertible_msg p - = text "Pattern" <+> quotes (ppr p) <+> text "is not invertible" - $+$ hang (text "Suggestion: instead use an explicitly bidirectional" - <+> text "pattern synonym, e.g.") - 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow - <+> ppr pat <+> text "where") - 2 (pp_name <+> pp_args <+> equals <+> text "...")) - where - pp_name = ppr name - pp_args = hsep (map ppr args) - - -- We should really be able to invert list patterns, even when - -- rebindable syntax is on, but doing so involves a bit of - -- refactoring; see #14380. Until then we reject with a - -- helpful error message. - notInvertibleListPat p - = Left (vcat [ not_invertible_msg p - , text "Reason: rebindable syntax is on." - , text "This is fixable: add use-case to #14380" ]) - -{- Note [Builder for a bidirectional pattern synonym] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a bidirectional pattern synonym we need to produce an /expression/ -that matches the supplied /pattern/, given values for the arguments -of the pattern synonym. For example - pattern F x y = (Just x, [y]) -The 'builder' for F looks like - $builderF x y = (Just x, [y]) - -We can't always do this: - * Some patterns aren't invertible; e.g. view patterns - pattern F x = (reverse -> x:_) - - * The RHS pattern might bind more variables than the pattern - synonym, so again we can't invert it - pattern F x = (x,y) - - * Ditto wildcards - pattern F x = (x,_) - - -Note [Redundant constraints for builder] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The builder can have redundant constraints, which are awkward to eliminate. -Consider - pattern P = Just 34 -To match against this pattern we need (Eq a, Num a). But to build -(Just 34) we need only (Num a). Fortunately instTcSigFromId sets -sig_warn_redundant to False. - -************************************************************************ -* * - Helper functions -* * -************************************************************************ - -Note [As-patterns in pattern synonym definitions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The rationale for rejecting as-patterns in pattern synonym definitions -is that an as-pattern would introduce nonindependent pattern synonym -arguments, e.g. given a pattern synonym like: - - pattern K x y = x@(Just y) - -one could write a nonsensical function like - - f (K Nothing x) = ... - -or - g (K (Just True) False) = ... - -Note [Type signatures and the builder expression] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - pattern L x = Left x :: Either [a] [b] - -In tc{Infer/Check}PatSynDecl we will check that the pattern has the -specified type. We check the pattern *as a pattern*, so the type -signature is a pattern signature, and so brings 'a' and 'b' into -scope. But we don't have a way to bind 'a, b' in the LHS, as we do -'x', say. Nevertheless, the signature may be useful to constrain -the type. - -When making the binding for the *builder*, though, we don't want - $buildL x = Left x :: Either [a] [b] -because that wil either mean (forall a b. Either [a] [b]), or we'll -get a complaint that 'a' and 'b' are out of scope. (Actually the -latter; #9867.) No, the job of the signature is done, so when -converting the pattern to an expression (for the builder RHS) we -simply discard the signature. - -Note [Record PatSyn Desugaring] -------------------------------- -It is important that prov_theta comes before req_theta as this ordering is used -when desugaring record pattern synonym updates. - -Any change to this ordering should make sure to change GHC.HsToCore.Expr if you -want to avoid difficult to decipher core lint errors! - -} - - -nonBidirectionalErr :: Outputable name => name -> TcM a -nonBidirectionalErr name = failWithTc $ - text "non-bidirectional pattern synonym" - <+> quotes (ppr name) <+> text "used in an expression" - --- Walk the whole pattern and for all ConPatOuts, collect the --- existentially-bound type variables and evidence binding variables. --- --- These are used in computing the type of a pattern synonym and also --- in generating matcher functions, since success continuations need --- to be passed these pattern-bound evidences. -tcCollectEx - :: LPat GhcTc - -> ( [TyVar] -- Existentially-bound type variables - -- in correctly-scoped order; e.g. [ k:*, x:k ] - , [EvVar] ) -- and evidence variables - -tcCollectEx pat = go pat - where - go :: LPat GhcTc -> ([TyVar], [EvVar]) - go = go1 . unLoc - - go1 :: Pat GhcTc -> ([TyVar], [EvVar]) - go1 (LazyPat _ p) = go p - go1 (AsPat _ _ p) = go p - go1 (ParPat _ p) = go p - go1 (BangPat _ p) = go p - go1 (ListPat _ ps) = mergeMany . map go $ ps - go1 (TuplePat _ ps _) = mergeMany . map go $ ps - go1 (SumPat _ p _ _) = go p - go1 (ViewPat _ _ p) = go p - go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $ - goConDetails $ pat_args con - go1 (SigPat _ p _) = go p - go1 (CoPat _ _ p _) = go1 p - go1 (NPlusKPat _ n k _ geq subtract) - = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract - go1 _ = empty - - goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar]) - goConDetails (PrefixCon ps) = mergeMany . map go $ ps - goConDetails (InfixCon p1 p2) = go p1 `merge` go p2 - goConDetails (RecCon HsRecFields{ rec_flds = flds }) - = mergeMany . map goRecFd $ flds - - goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) - goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p - - merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) - mergeMany = foldr merge empty - empty = ([], []) diff --git a/compiler/typecheck/TcPatSyn.hs-boot b/compiler/typecheck/TcPatSyn.hs-boot deleted file mode 100644 index 950d03811a..0000000000 --- a/compiler/typecheck/TcPatSyn.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -module TcPatSyn where - -import GHC.Hs ( PatSynBind, LHsBinds ) -import TcRnTypes ( TcM, TcSigInfo ) -import TcRnMonad ( TcGblEnv) -import Outputable ( Outputable ) -import GHC.Hs.Extension ( GhcRn, GhcTc ) -import Data.Maybe ( Maybe ) - -tcPatSynDecl :: PatSynBind GhcRn GhcRn - -> Maybe TcSigInfo - -> TcM (LHsBinds GhcTc, TcGblEnv) - -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) - -nonBidirectionalErr :: Outputable name => name -> TcM a diff --git a/compiler/typecheck/TcPluginM.hs b/compiler/typecheck/TcPluginM.hs deleted file mode 100644 index 339a13dca2..0000000000 --- a/compiler/typecheck/TcPluginM.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE CPP #-} --- | This module provides an interface for typechecker plugins to --- access select functions of the 'TcM', principally those to do with --- reading parts of the state. -module TcPluginM ( - -- * Basic TcPluginM functionality - TcPluginM, - tcPluginIO, - tcPluginTrace, - unsafeTcPluginTcM, - - -- * Finding Modules and Names - FindResult(..), - findImportedModule, - lookupOrig, - - -- * Looking up Names in the typechecking environment - tcLookupGlobal, - tcLookupTyCon, - tcLookupDataCon, - tcLookupClass, - tcLookup, - tcLookupId, - - -- * Getting the TcM state - getTopEnv, - getEnvs, - getInstEnvs, - getFamInstEnvs, - matchFam, - - -- * Type variables - newUnique, - newFlexiTyVar, - isTouchableTcPluginM, - - -- * Zonking - zonkTcType, - zonkCt, - - -- * Creating constraints - newWanted, - newDerived, - newGiven, - newCoercionHole, - - -- * Manipulating evidence bindings - newEvVar, - setEvBind, - getEvBindsTcPluginM - ) where - -import GhcPrelude - -import qualified TcRnMonad as TcM -import qualified TcSMonad as TcS -import qualified TcEnv as TcM -import qualified TcMType as TcM -import qualified FamInst as TcM -import qualified GHC.Iface.Env as IfaceEnv -import qualified GHC.Driver.Finder as Finder - -import GHC.Core.FamInstEnv ( FamInstEnv ) -import TcRnMonad ( TcGblEnv, TcLclEnv, TcPluginM - , unsafeTcPluginTcM, getEvBindsTcPluginM - , liftIO, traceTc ) -import Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin ) -import TcMType ( TcTyVar, TcType ) -import TcEnv ( TcTyThing ) -import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..) - , EvExpr, EvBind, mkGivenEvBind ) -import GHC.Types.Var ( EvVar ) - -import GHC.Types.Module -import GHC.Types.Name -import GHC.Core.TyCon -import GHC.Core.DataCon -import GHC.Core.Class -import GHC.Driver.Types -import Outputable -import GHC.Core.Type -import GHC.Core.Coercion ( BlockSubstFlag(..) ) -import GHC.Types.Id -import GHC.Core.InstEnv -import FastString -import GHC.Types.Unique - - --- | Perform some IO, typically to interact with an external tool. -tcPluginIO :: IO a -> TcPluginM a -tcPluginIO a = unsafeTcPluginTcM (liftIO a) - --- | Output useful for debugging the compiler. -tcPluginTrace :: String -> SDoc -> TcPluginM () -tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) - - -findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult -findImportedModule mod_name mb_pkg = do - hsc_env <- getTopEnv - tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg - -lookupOrig :: Module -> OccName -> TcPluginM Name -lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod - - -tcLookupGlobal :: Name -> TcPluginM TyThing -tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal - -tcLookupTyCon :: Name -> TcPluginM TyCon -tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon - -tcLookupDataCon :: Name -> TcPluginM DataCon -tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon - -tcLookupClass :: Name -> TcPluginM Class -tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass - -tcLookup :: Name -> TcPluginM TcTyThing -tcLookup = unsafeTcPluginTcM . TcM.tcLookup - -tcLookupId :: Name -> TcPluginM Id -tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId - - -getTopEnv :: TcPluginM HscEnv -getTopEnv = unsafeTcPluginTcM TcM.getTopEnv - -getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) -getEnvs = unsafeTcPluginTcM TcM.getEnvs - -getInstEnvs :: TcPluginM InstEnvs -getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs - -getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv) -getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs - -matchFam :: TyCon -> [Type] - -> TcPluginM (Maybe (TcCoercion, TcType)) -matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args - -newUnique :: TcPluginM Unique -newUnique = unsafeTcPluginTcM TcM.newUnique - -newFlexiTyVar :: Kind -> TcPluginM TcTyVar -newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar - -isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool -isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM - --- Confused by zonking? See Note [What is zonking?] in TcMType. -zonkTcType :: TcType -> TcPluginM TcType -zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType - -zonkCt :: Ct -> TcPluginM Ct -zonkCt = unsafeTcPluginTcM . TcM.zonkCt - - --- | Create a new wanted constraint. -newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence -newWanted loc pty - = unsafeTcPluginTcM (TcM.newWanted (ctLocOrigin loc) Nothing pty) - --- | Create a new derived constraint. -newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence -newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc } - --- | Create a new given constraint, with the supplied evidence. This --- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it --- will panic. -newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence -newGiven loc pty evtm = do - new_ev <- newEvVar pty - setEvBind $ mkGivenEvBind new_ev (EvExpr evtm) - return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc } - --- | Create a fresh evidence variable. -newEvVar :: PredType -> TcPluginM EvVar -newEvVar = unsafeTcPluginTcM . TcM.newEvVar - --- | Create a fresh coercion hole. -newCoercionHole :: PredType -> TcPluginM CoercionHole -newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole YesBlockSubst - --- | Bind an evidence variable. This must not be invoked from --- 'tcPluginInit' or 'tcPluginStop', or it will panic. -setEvBind :: EvBind -> TcPluginM () -setEvBind ev_bind = do - tc_evbinds <- getEvBindsTcPluginM - unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs deleted file mode 100644 index 91ac66b972..0000000000 --- a/compiler/typecheck/TcRnDriver.hs +++ /dev/null @@ -1,3078 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcRnDriver]{Typechecking a whole module} - -https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcRnDriver ( - tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, - tcRnImportDecls, - tcRnLookupRdrName, - getModuleInterface, - tcRnDeclsi, - isGHCiMonad, - runTcInteractive, -- Used by GHC API clients (#8878) - tcRnLookupName, - tcRnGetInfo, - tcRnModule, tcRnModuleTcRnM, - tcTopSrcDecls, - rnTopSrcDecls, - checkBootDecl, checkHiBootIface', - findExtraSigImports, - implicitRequirements, - checkUnitId, - mergeSignatures, - tcRnMergeSignatures, - instantiateSignature, - tcRnInstantiateSignature, - loadUnqualIfaces, - -- More private... - badReexportedBootThing, - checkBootDeclM, - missingBootThing, - getRenamedStuff, RenamedStuff - ) where - -import GhcPrelude - -import {-# SOURCE #-} TcSplice ( finishTH, runRemoteModFinalizers ) -import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) -import GHC.Iface.Env ( externaliseName ) -import TcHsType -import TcValidity( checkValidType ) -import TcMatches -import Inst( deeplyInstantiate ) -import TcUnify( checkConstraints ) -import GHC.Rename.Types -import GHC.Rename.Expr -import GHC.Rename.Utils ( HsDocContext(..) ) -import GHC.Rename.Fixity ( lookupFixityRn ) -import TysWiredIn ( unitTy, mkListTy ) -import GHC.Driver.Plugins -import GHC.Driver.Session -import GHC.Hs -import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) -import GHC.Iface.Type ( ShowForAllFlag(..) ) -import GHC.Core.PatSyn( pprPatSynType ) -import PrelNames -import PrelInfo -import GHC.Types.Name.Reader -import TcHsSyn -import TcExpr -import TcRnMonad -import TcRnExports -import TcEvidence -import Constraint -import TcOrigin -import qualified BooleanFormula as BF -import GHC.Core.Ppr.TyThing ( pprTyThingInContext ) -import GHC.Core.FVs ( orphNamesOfFamInst ) -import FamInst -import GHC.Core.InstEnv -import GHC.Core.FamInstEnv - ( FamInst, pprFamInst, famInstsRepTyCons - , famInstEnvElts, extendFamInstEnvList, normaliseType ) -import TcAnnotations -import TcBinds -import GHC.Iface.Make ( coAxiomToIfaceDecl ) -import HeaderInfo ( mkPrelImports ) -import TcDefaults -import TcEnv -import TcRules -import TcForeign -import TcInstDcls -import GHC.IfaceToCore -import TcMType -import TcType -import TcSimplify -import TcTyClsDecls -import TcTypeable ( mkTypeableBinds ) -import TcBackpack -import GHC.Iface.Load -import GHC.Rename.Names -import GHC.Rename.Env -import GHC.Rename.Source -import ErrUtils -import GHC.Types.Id as Id -import GHC.Types.Id.Info( IdDetails(..) ) -import GHC.Types.Var.Env -import GHC.Types.Module -import GHC.Types.Unique.FM -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Avail -import GHC.Core.TyCon -import GHC.Types.SrcLoc -import GHC.Driver.Types -import ListSetOps -import Outputable -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.Type -import GHC.Core.Class -import GHC.Types.Basic hiding( SuccessFlag(..) ) -import GHC.Core.Coercion.Axiom -import GHC.Types.Annotations -import Data.List ( find, sortBy, sort ) -import Data.Ord -import FastString -import Maybes -import Util -import Bag -import Inst (tcGetInsts) -import qualified GHC.LanguageExtensions as LangExt -import Data.Data ( Data ) -import GHC.Hs.Dump -import qualified Data.Set as S - -import Control.DeepSeq -import Control.Monad - -import TcHoleFitTypes ( HoleFitPluginR (..) ) - - -#include "HsVersions.h" - -{- -************************************************************************ -* * - Typecheck and rename a module -* * -************************************************************************ --} - --- | Top level entry point for typechecker and renamer -tcRnModule :: HscEnv - -> ModSummary - -> Bool -- True <=> save renamed syntax - -> HsParsedModule - -> IO (Messages, Maybe TcGblEnv) - -tcRnModule hsc_env mod_sum save_rn_syntax - parsedModule@HsParsedModule {hpm_module= L loc this_module} - | RealSrcSpan real_loc _ <- loc - = withTiming dflags - (text "Renamer/typechecker"<+>brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ - withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ - - tcRnModuleTcRnM hsc_env mod_sum parsedModule pair - - | otherwise - = return ((emptyBag, unitBag err_msg), Nothing) - - where - hsc_src = ms_hsc_src mod_sum - dflags = hsc_dflags hsc_env - err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $ - text "Module does not have a RealSrcSpan:" <+> ppr this_mod - - this_pkg = thisPackage (hsc_dflags hsc_env) - - pair :: (Module, SrcSpan) - pair@(this_mod,_) - | Just (L mod_loc mod) <- hsmodName this_module - = (mkModule this_pkg mod, mod_loc) - - | otherwise -- 'module M where' is omitted - = (mAIN, srcLocSpan (srcSpanStart loc)) - - - - -tcRnModuleTcRnM :: HscEnv - -> ModSummary - -> HsParsedModule - -> (Module, SrcSpan) - -> TcRn TcGblEnv --- Factored out separately from tcRnModule so that a Core plugin can --- call the type checker directly -tcRnModuleTcRnM hsc_env mod_sum - (HsParsedModule { - hpm_module = - (L loc (HsModule maybe_mod export_ies - import_decls local_decls mod_deprec - maybe_doc_hdr)), - hpm_src_files = src_files - }) - (this_mod, prel_imp_loc) - = setSrcSpan loc $ - do { let { explicit_mod_hdr = isJust maybe_mod - ; hsc_src = ms_hsc_src mod_sum } - ; -- Load the hi-boot interface for this module, if any - -- We do this now so that the boot_names can be passed - -- to tcTyAndClassDecls, because the boot_names are - -- automatically considered to be loop breakers - tcg_env <- getGblEnv - ; boot_info <- tcHiBootIface hsc_src this_mod - ; setGblEnv (tcg_env { tcg_self_boot = boot_info }) - $ do - { -- Deal with imports; first add implicit prelude - implicit_prelude <- xoptM LangExt.ImplicitPrelude - ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc - implicit_prelude import_decls } - - ; whenWOptM Opt_WarnImplicitPrelude $ - when (notNull prel_imports) $ - addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) - - ; -- TODO This is a little skeevy; maybe handle a bit more directly - let { simplifyImport (L _ idecl) = - ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl) - } - ; raw_sig_imports <- liftIO - $ findExtraSigImports hsc_env hsc_src - (moduleName this_mod) - ; raw_req_imports <- liftIO - $ implicitRequirements hsc_env - (map simplifyImport (prel_imports - ++ import_decls)) - ; let { mkImport (Nothing, L _ mod_name) = noLoc - $ (simpleImportDecl mod_name) - { ideclHiding = Just (False, noLoc [])} - ; mkImport _ = panic "mkImport" } - ; let { all_imports = prel_imports ++ import_decls - ++ map mkImport (raw_sig_imports ++ raw_req_imports) } - ; -- OK now finally rename the imports - tcg_env <- {-# SCC "tcRnImports" #-} - tcRnImports hsc_env all_imports - - ; -- If the whole module is warned about or deprecated - -- (via mod_deprec) record that in tcg_warns. If we do thereby add - -- a WarnAll, it will override any subsequent deprecations added to tcg_warns - let { tcg_env1 = case mod_deprec of - Just (L _ txt) -> - tcg_env {tcg_warns = WarnAll txt} - Nothing -> tcg_env - } - ; setGblEnv tcg_env1 - $ do { -- Rename and type check the declarations - traceRn "rn1a" empty - ; tcg_env <- if isHsBootOrSig hsc_src - then tcRnHsBootDecls hsc_src local_decls - else {-# SCC "tcRnSrcDecls" #-} - tcRnSrcDecls explicit_mod_hdr local_decls export_ies - ; setGblEnv tcg_env - $ do { -- Process the export list - traceRn "rn4a: before exports" empty - ; tcg_env <- tcRnExports explicit_mod_hdr export_ies - tcg_env - ; traceRn "rn4b: after exports" empty - ; -- Compare hi-boot iface (if any) with the real thing - -- Must be done after processing the exports - tcg_env <- checkHiBootIface tcg_env boot_info - ; -- The new type env is already available to stuff - -- slurped from interface files, via - -- TcEnv.setGlobalTypeEnv. It's important that this - -- includes the stuff in checkHiBootIface, - -- because the latter might add new bindings for - -- boot_dfuns, which may be mentioned in imported - -- unfoldings. - - -- Don't need to rename the Haddock documentation, - -- it's not parsed by GHC anymore. - tcg_env <- return (tcg_env - { tcg_doc_hdr = maybe_doc_hdr }) - ; -- Report unused names - -- Do this /after/ typeinference, so that when reporting - -- a function with no type signature we can give the - -- inferred type - reportUnusedNames tcg_env - ; -- add extra source files to tcg_dependent_files - addDependentFiles src_files - ; tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env - ; -- Dump output and return - tcDump tcg_env - ; return tcg_env } - } - } - } - -implicitPreludeWarn :: SDoc -implicitPreludeWarn - = text "Module `Prelude' implicitly imported" - -{- -************************************************************************ -* * - Import declarations -* * -************************************************************************ --} - -tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv -tcRnImports hsc_env import_decls - = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; - - ; this_mod <- getModule - ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) - ; dep_mods = imp_dep_mods imports - - -- We want instance declarations from all home-package - -- modules below this one, including boot modules, except - -- ourselves. The 'except ourselves' is so that we don't - -- get the instances from this module's hs-boot file. This - -- filtering also ensures that we don't see instances from - -- modules batch (@--make@) compiled before this one, but - -- which are not below this one. - ; want_instances :: ModuleName -> Bool - ; want_instances mod = mod `elemUFM` dep_mods - && mod /= moduleName this_mod - ; (home_insts, home_fam_insts) = hptInstances hsc_env - want_instances - } ; - - -- Record boot-file info in the EPS, so that it's - -- visible to loadHiBootInterface in tcRnSrcDecls, - -- and any other incrementally-performed imports - ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; - - -- Update the gbl env - ; updGblEnv ( \ gbl -> - gbl { - tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_imports = rn_imports, - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) - home_fam_insts, - tcg_hpc = hpc_info - }) $ do { - - ; traceRn "rn1" (ppr (imp_dep_mods imports)) - -- Fail if there are any errors so far - -- The error printing (if needed) takes advantage - -- of the tcg_env we have now set --- ; traceIf (text "rdr_env: " <+> ppr rdr_env) - ; failIfErrsM - - -- Load any orphan-module (including orphan family - -- instance-module) interfaces, so that their rules and - -- instance decls will be found. But filter out a - -- self hs-boot: these instances will be checked when - -- we define them locally. - -- (We don't need to load non-orphan family instance - -- modules until we either try to use the instances they - -- define, or define our own family instances, at which - -- point we need to check them for consistency.) - ; loadModuleInterfaces (text "Loading orphan modules") - (filter (/= this_mod) (imp_orphs imports)) - - -- Check type-family consistency between imports. - -- See Note [The type family instance consistency story] - ; traceRn "rn1: checking family instance consistency {" empty - ; let { dir_imp_mods = moduleEnvKeys - . imp_mods - $ imports } - ; checkFamInstConsistency dir_imp_mods - ; traceRn "rn1: } checking family instance consistency" empty - - ; getGblEnv } } - -{- -************************************************************************ -* * - Type-checking the top level of a module -* * -************************************************************************ --} - -tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all - -> [LHsDecl GhcPs] -- Declarations - -> Maybe (Located [LIE GhcPs]) - -> TcM TcGblEnv -tcRnSrcDecls explicit_mod_hdr decls export_ies - = do { -- Do all the declarations - ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls - - -- Check for the 'main' declaration - -- Must do this inside the captureTopConstraints - -- NB: always set envs *before* captureTopConstraints - ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $ - captureTopConstraints $ - checkMain explicit_mod_hdr export_ies - - ; setEnvs (tcg_env, tcl_env) $ do { - - -- Simplify constraints - -- - -- We do this after checkMain, so that we use the type info - -- that checkMain adds - -- - -- We do it with both global and local env in scope: - -- * the global env exposes the instances to simplifyTop - -- * the local env exposes the local Ids to simplifyTop, - -- so that we get better error messages (monomorphism restriction) - ; new_ev_binds <- {-# SCC "simplifyTop" #-} - simplifyTop (lie `andWC` lie_main) - - -- Emit Typeable bindings - ; tcg_env <- mkTypeableBinds - - - ; traceTc "Tc9" empty - - ; failIfErrsM -- Don't zonk if there have been errors - -- It's a waste of time; and we may get debug warnings - -- about strangely-typed TyCons! - ; traceTc "Tc10" empty - - -- Zonk the final code. This must be done last. - -- Even simplifyTop may do some unification. - -- This pass also warns about missing type signatures - ; (bind_env, ev_binds', binds', fords', imp_specs', rules') - <- zonkTcGblEnv new_ev_binds tcg_env - - -- Finalizers must run after constraints are simplified, or some types - -- might not be complete when using reify (see #12777). - -- and also after we zonk the first time because we run typed splices - -- in the zonker which gives rise to the finalisers. - ; (tcg_env_mf, _) <- setGblEnv (clearTcGblEnv tcg_env) - run_th_modfinalizers - ; finishTH - ; traceTc "Tc11" empty - - ; -- zonk the new bindings arising from running the finalisers. - -- This won't give rise to any more finalisers as you can't nest - -- finalisers inside finalisers. - ; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) - <- zonkTcGblEnv emptyBag tcg_env_mf - - - ; let { final_type_env = plusTypeEnv (tcg_type_env tcg_env) - (plusTypeEnv bind_env_mf bind_env) - ; tcg_env' = tcg_env_mf - { tcg_binds = binds' `unionBags` binds_mf, - tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf , - tcg_imp_specs = imp_specs' ++ imp_specs_mf , - tcg_rules = rules' ++ rules_mf , - tcg_fords = fords' ++ fords_mf } } ; - - ; setGlobalTypeEnv tcg_env' final_type_env - - } } - -zonkTcGblEnv :: Bag EvBind -> TcGblEnv - -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, - [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc]) -zonkTcGblEnv new_ev_binds tcg_env = - let TcGblEnv { tcg_binds = binds, - tcg_ev_binds = cur_ev_binds, - tcg_imp_specs = imp_specs, - tcg_rules = rules, - tcg_fords = fords } = tcg_env - - all_ev_binds = cur_ev_binds `unionBags` new_ev_binds - - in {-# SCC "zonkTopDecls" #-} - zonkTopDecls all_ev_binds binds rules imp_specs fords - - --- | Remove accumulated bindings, rules and so on from TcGblEnv -clearTcGblEnv :: TcGblEnv -> TcGblEnv -clearTcGblEnv tcg_env - = tcg_env { tcg_binds = emptyBag, - tcg_ev_binds = emptyBag , - tcg_imp_specs = [], - tcg_rules = [], - tcg_fords = [] } - --- | Runs TH finalizers and renames and typechecks the top-level declarations --- that they could introduce. -run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv) -run_th_modfinalizers = do - th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - th_modfinalizers <- readTcRef th_modfinalizers_var - if null th_modfinalizers - then getEnvs - else do - writeTcRef th_modfinalizers_var [] - let run_finalizer (lcl_env, f) = - setLclEnv lcl_env (runRemoteModFinalizers f) - - (_, lie_th) <- captureTopConstraints $ - mapM_ run_finalizer th_modfinalizers - - -- Finalizers can add top-level declarations with addTopDecls, so - -- we have to run tc_rn_src_decls to get them - (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls [] - - setEnvs (tcg_env, tcl_env) $ do - -- Subsequent rounds of finalizers run after any new constraints are - -- simplified, or some types might not be complete when using reify - -- (see #12777). - new_ev_binds <- {-# SCC "simplifyTop2" #-} - simplifyTop (lie_th `andWC` lie_top_decls) - addTopEvBinds new_ev_binds run_th_modfinalizers - -- addTopDecls can add declarations which add new finalizers. - -tc_rn_src_decls :: [LHsDecl GhcPs] - -> TcM (TcGblEnv, TcLclEnv, WantedConstraints) --- Loops around dealing with each top level inter-splice group --- in turn, until it's dealt with the entire module --- Never emits constraints; calls captureTopConstraints internally -tc_rn_src_decls ds - = {-# SCC "tc_rn_src_decls" #-} - do { (first_group, group_tail) <- findSplice ds - -- If ds is [] we get ([], Nothing) - - -- Deal with decls up to, but not including, the first splice - ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group - -- rnTopSrcDecls fails if there are any errors - - -- Get TH-generated top-level declarations and make sure they don't - -- contain any splices since we don't handle that at the moment - -- - -- The plumbing here is a bit odd: see #10853 - ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv - ; th_ds <- readTcRef th_topdecls_var - ; writeTcRef th_topdecls_var [] - - ; (tcg_env, rn_decls) <- - if null th_ds - then return (tcg_env, rn_decls) - else do { (th_group, th_group_tail) <- findSplice th_ds - ; case th_group_tail of - { Nothing -> return () - ; Just (SpliceDecl _ (L loc _) _, _) -> - setSrcSpan loc - $ addErr (text - ("Declaration splices are not " - ++ "permitted inside top-level " - ++ "declarations added with addTopDecls")) - ; Just (XSpliceDecl nec, _) -> noExtCon nec - } - -- Rename TH-generated top-level declarations - ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env - $ rnTopSrcDecls th_group - - -- Dump generated top-level declarations - ; let msg = "top-level declarations added with addTopDecls" - ; traceSplice - $ SpliceInfo { spliceDescription = msg - , spliceIsDecl = True - , spliceSource = Nothing - , spliceGenerated = ppr th_rn_decls } - ; return (tcg_env, appendGroups rn_decls th_rn_decls) - } - - -- Type check all declarations - -- NB: set the env **before** captureTopConstraints so that error messages - -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that - -- the captureTopConstraints must go here, not in tcRnSrcDecls. - ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $ - captureTopConstraints $ - tcTopSrcDecls rn_decls - - -- If there is no splice, we're nearly done - ; setEnvs (tcg_env, tcl_env) $ - case group_tail of - { Nothing -> return (tcg_env, tcl_env, lie1) - - -- If there's a splice, we must carry on - ; Just (SpliceDecl _ (L _ splice) _, rest_ds) -> - do { - -- We need to simplify any constraints from the previous declaration - -- group, or else we might reify metavariables, as in #16980. - ; ev_binds1 <- simplifyTop lie1 - - -- Rename the splice expression, and get its supporting decls - ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice - - -- Glue them on the front of the remaining decls and loop - ; (tcg_env, tcl_env, lie2) <- - setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - addTopEvBinds ev_binds1 $ - tc_rn_src_decls (spliced_decls ++ rest_ds) - - ; return (tcg_env, tcl_env, lie2) - } - ; Just (XSpliceDecl nec, _) -> noExtCon nec - } - } - -{- -************************************************************************ -* * - Compiling hs-boot source files, and - comparing the hi-boot interface with the real thing -* * -************************************************************************ --} - -tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv -tcRnHsBootDecls hsc_src decls - = do { (first_group, group_tail) <- findSplice decls - - -- Rename the declarations - ; (tcg_env, HsGroup { hs_tyclds = tycl_decls - , hs_derivds = deriv_decls - , hs_fords = for_decls - , hs_defds = def_decls - , hs_ruleds = rule_decls - , hs_annds = _ - , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) }) - <- rnTopSrcDecls first_group - - -- The empty list is for extra dependencies coming from .hs-boot files - -- See Note [Extra dependencies from .hs-boot files] in GHC.Rename.Source - - ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do { - -- NB: setGblEnv **before** captureTopConstraints so that - -- if the latter reports errors, it knows what's in scope - - -- Check for illegal declarations - ; case group_tail of - Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d - Just (XSpliceDecl nec, _) -> noExtCon nec - Nothing -> return () - ; mapM_ (badBootDecl hsc_src "foreign") for_decls - ; mapM_ (badBootDecl hsc_src "default") def_decls - ; mapM_ (badBootDecl hsc_src "rule") rule_decls - - -- Typecheck type/class/instance decls - ; traceTc "Tc2 (boot)" empty - ; (tcg_env, inst_infos, _deriv_binds) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds - ; setGblEnv tcg_env $ do { - - -- Emit Typeable bindings - ; tcg_env <- mkTypeableBinds - ; setGblEnv tcg_env $ do { - - -- Typecheck value declarations - ; traceTc "Tc5" empty - ; val_ids <- tcHsBootSigs val_binds val_sigs - - -- Wrap up - -- No simplification or zonking to do - ; traceTc "Tc7a" empty - ; gbl_env <- getGblEnv - - -- Make the final type-env - -- Include the dfun_ids so that their type sigs - -- are written into the interface file. - ; let { type_env0 = tcg_type_env gbl_env - ; type_env1 = extendTypeEnvWithIds type_env0 val_ids - ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; dfun_ids = map iDFunId inst_infos - } - - ; setGlobalTypeEnv gbl_env type_env2 - }}} - ; traceTc "boot" (ppr lie); return gbl_env } - -badBootDecl :: HscSource -> String -> Located decl -> TcM () -badBootDecl hsc_src what (L loc _) - = addErrAt loc (char 'A' <+> text what - <+> text "declaration is not (currently) allowed in a" - <+> (case hsc_src of - HsBootFile -> text "hs-boot" - HsigFile -> text "hsig" - _ -> panic "badBootDecl: should be an hsig or hs-boot file") - <+> text "file") - -{- -Once we've typechecked the body of the module, we want to compare what -we've found (gathered in a TypeEnv) with the hi-boot details (if any). --} - -checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv --- Compare the hi-boot file for this module (if there is one) --- with the type environment we've just come up with --- In the common case where there is no hi-boot file, the list --- of boot_names is empty. - -checkHiBootIface tcg_env boot_info - | NoSelfBoot <- boot_info -- Common case - = return tcg_env - - | HsBootFile <- tcg_src tcg_env -- Current module is already a hs-boot file! - = return tcg_env - - | SelfBoot { sb_mds = boot_details } <- boot_info - , TcGblEnv { tcg_binds = binds - , tcg_insts = local_insts - , tcg_type_env = local_type_env - , tcg_exports = local_exports } <- tcg_env - = do { -- This code is tricky, see Note [DFun knot-tying] - ; dfun_prs <- checkHiBootIface' local_insts local_type_env - local_exports boot_details - - -- Now add the boot-dfun bindings $fxblah = $fblah - -- to (a) the type envt, and (b) the top-level bindings - ; let boot_dfuns = map fst dfun_prs - type_env' = extendTypeEnvWithIds local_type_env boot_dfuns - dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - tcg_env_w_binds - = tcg_env { tcg_binds = binds `unionBags` dfun_binds } - - ; type_env' `seq` - -- Why the seq? Without, we will put a TypeEnv thunk in - -- tcg_type_env_var. That thunk will eventually get - -- forced if we are typechecking interfaces, but that - -- is no good if we are trying to typecheck the very - -- DFun we were going to put in. - -- TODO: Maybe setGlobalTypeEnv should be strict. - setGlobalTypeEnv tcg_env_w_binds type_env' } - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "checkHiBootIface: unreachable code" -#endif - -{- Note [DFun impedance matching] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We return a list of "impedance-matching" bindings for the dfuns -defined in the hs-boot file, such as - $fxEqT = $fEqT -We need these because the module and hi-boot file might differ in -the name it chose for the dfun: the name of a dfun is not -uniquely determined by its type; there might be multiple dfuns -which, individually, would map to the same name (in which case -we have to disambiguate them.) There's no way for the hi file -to know exactly what disambiguation to use... without looking -at the hi-boot file itself. - -In fact, the names will always differ because we always pick names -prefixed with "$fx" for boot dfuns, and "$f" for real dfuns -(so that this impedance matching is always possible). - -Note [DFun knot-tying] -~~~~~~~~~~~~~~~~~~~~~~ -The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from -typechecking the hi-boot file that we are presently implementing. -Suppose we are typechecking the module A: when we typecheck the -hi-boot file, whenever we see an identifier A.T, we knot-tie this -identifier to the *local* type environment (via if_rec_types.) The -contract then is that we don't *look* at 'SelfBootInfo' until we've -finished typechecking the module and updated the type environment with -the new tycons and ids. - -This most works well, but there is one problem: DFuns! We do not want -to look at the mb_insts of the ModDetails in SelfBootInfo, because a -dfun in one of those ClsInsts is gotten (in GHC.IfaceToCore.tcIfaceInst) by a -(lazily evaluated) lookup in the if_rec_types. We could extend the -type env, do a setGloblaTypeEnv etc; but that all seems very indirect. -It is much more directly simply to extract the DFunIds from the -md_types of the SelfBootInfo. - -See #4003, #16038 for why we need to take care here. --} - -checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] - -> ModDetails -> TcM [(Id, Id)] --- Variant which doesn't require a full TcGblEnv; you could get the --- local components from another ModDetails. -checkHiBootIface' - local_insts local_type_env local_exports - (ModDetails { md_types = boot_type_env - , md_fam_insts = boot_fam_insts - , md_exports = boot_exports }) - = do { traceTc "checkHiBootIface" $ vcat - [ ppr boot_type_env, ppr boot_exports] - - -- Check the exports of the boot module, one by one - ; mapM_ check_export boot_exports - - -- Check for no family instances - ; unless (null boot_fam_insts) $ - panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ - "instances in boot files yet...") - -- FIXME: Why? The actual comparison is not hard, but what would - -- be the equivalent to the dfun bindings returned for class - -- instances? We can't easily equate tycons... - - -- Check instance declarations - -- and generate an impedance-matching binding - ; mb_dfun_prs <- mapM check_cls_inst boot_dfuns - - ; failIfErrsM - - ; return (catMaybes mb_dfun_prs) } - - where - boot_dfun_names = map idName boot_dfuns - boot_dfuns = filter isDFunId $ typeEnvIds boot_type_env - -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts - -- We don't want to look at md_insts! - -- Why not? See Note [DFun knot-tying] - - check_export boot_avail -- boot_avail is exported by the boot iface - | name `elem` boot_dfun_names = return () - | isWiredInName name = return () -- No checking for wired-in names. In particular, - -- 'error' is handled by a rather gross hack - -- (see comments in GHC.Err.hs-boot) - - -- Check that the actual module exports the same thing - | not (null missing_names) - = addErrAt (nameSrcSpan (head missing_names)) - (missingBootThing True (head missing_names) "exported by") - - -- If the boot module does not *define* the thing, we are done - -- (it simply re-exports it, and names match, so nothing further to do) - | isNothing mb_boot_thing = return () - - -- Check that the actual module also defines the thing, and - -- then compare the definitions - | Just real_thing <- lookupTypeEnv local_type_env name, - Just boot_thing <- mb_boot_thing - = checkBootDeclM True boot_thing real_thing - - | otherwise - = addErrTc (missingBootThing True name "defined in") - where - name = availName boot_avail - mb_boot_thing = lookupTypeEnv boot_type_env name - missing_names = case lookupNameEnv local_export_env name of - Nothing -> [name] - Just avail -> availNames boot_avail `minusList` availNames avail - - local_export_env :: NameEnv AvailInfo - local_export_env = availsToNameEnv local_exports - - check_cls_inst :: DFunId -> TcM (Maybe (Id, Id)) - -- Returns a pair of the boot dfun in terms of the equivalent - -- real dfun. Delicate (like checkBootDecl) because it depends - -- on the types lining up precisely even to the ordering of - -- the type variables in the foralls. - check_cls_inst boot_dfun - | (real_dfun : _) <- find_real_dfun boot_dfun - , let local_boot_dfun = Id.mkExportedVanillaId - (idName boot_dfun) (idType real_dfun) - = return (Just (local_boot_dfun, real_dfun)) - -- Two tricky points here: - -- - -- * The local_boot_fun should have a Name from the /boot-file/, - -- but type from the dfun defined in /this module/. - -- That ensures that the TyCon etc inside the type are - -- the ones defined in this module, not the ones gotten - -- from the hi-boot file, which may have a lot less info - -- (#8743, comment:10). - -- - -- * The DFunIds from boot_details are /GlobalIds/, because - -- they come from typechecking M.hi-boot. - -- But all bindings in this module should be for /LocalIds/, - -- otherwise dependency analysis fails (#16038). This - -- is another reason for using mkExportedVanillaId, rather - -- that modifying boot_dfun, to make local_boot_fun. - - | otherwise - = setSrcSpan (nameSrcSpan (getName boot_dfun)) $ - do { traceTc "check_cls_inst" $ vcat - [ text "local_insts" <+> - vcat (map (ppr . idType . instanceDFunId) local_insts) - , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ] - - ; addErrTc (instMisMatch boot_dfun) - ; return Nothing } - - find_real_dfun :: DFunId -> [DFunId] - find_real_dfun boot_dfun - = [dfun | inst <- local_insts - , let dfun = instanceDFunId inst - , idType dfun `eqType` boot_dfun_ty ] - where - boot_dfun_ty = idType boot_dfun - - --- In general, to perform these checks we have to --- compare the TyThing from the .hi-boot file to the TyThing --- in the current source file. We must be careful to allow alpha-renaming --- where appropriate, and also the boot declaration is allowed to omit --- constructors and class methods. --- --- See rnfail055 for a good test of this stuff. - --- | Compares two things for equivalence between boot-file and normal code, --- reporting an error if they don't match up. -checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) - -> TyThing -> TyThing -> TcM () -checkBootDeclM is_boot boot_thing real_thing - = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err -> - addErrAt span - (bootMisMatch is_boot err real_thing boot_thing) - where - -- Here we use the span of the boot thing or, if it doesn't have a sensible - -- span, that of the real thing, - span - | let span = nameSrcSpan (getName boot_thing) - , isGoodSrcSpan span - = span - | otherwise - = nameSrcSpan (getName real_thing) - --- | Compares the two things for equivalence between boot-file and normal --- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ --- failure. If the difference will be apparent to the user, @Just empty@ is --- perfectly suitable. -checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc - -checkBootDecl _ (AnId id1) (AnId id2) - = ASSERT(id1 == id2) - check (idType id1 `eqType` idType id2) - (text "The two types are different") - -checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2) - = checkBootTyCon is_boot tc1 tc2 - -checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) - = pprPanic "checkBootDecl" (ppr dc1) - -checkBootDecl _ _ _ = Just empty -- probably shouldn't happen - --- | Combines two potential error messages -andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc -Nothing `andThenCheck` msg = msg -msg `andThenCheck` Nothing = msg -Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2) -infixr 0 `andThenCheck` - --- | If the test in the first parameter is True, succeed with @Nothing@; --- otherwise, return the provided check -checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc -checkUnless True _ = Nothing -checkUnless False k = k - --- | Run the check provided for every pair of elements in the lists. --- The provided SDoc should name the element type, in the plural. -checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc - -> Maybe SDoc -checkListBy check_fun as bs whats = go [] as bs - where - herald = text "The" <+> whats <+> text "do not match" - - go [] [] [] = Nothing - go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs)) - go docs (x:xs) (y:ys) = case check_fun x y of - Just doc -> go (doc:docs) xs ys - Nothing -> go docs xs ys - go _ _ _ = Just (hang (herald <> colon) - 2 (text "There are different numbers of" <+> whats)) - --- | If the test in the first parameter is True, succeed with @Nothing@; --- otherwise, fail with the given SDoc. -check :: Bool -> SDoc -> Maybe SDoc -check True _ = Nothing -check False doc = Just doc - --- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends. -checkSuccess :: Maybe SDoc -checkSuccess = Nothing - ----------------- -checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc -checkBootTyCon is_boot tc1 tc2 - | not (eqType (tyConKind tc1) (tyConKind tc2)) - = Just $ text "The types have different kinds" -- First off, check the kind - - | Just c1 <- tyConClass_maybe tc1 - , Just c2 <- tyConClass_maybe tc2 - , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1) - = classExtraBigSig c1 - (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) - = classExtraBigSig c2 - , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 - = let - eqSig (id1, def_meth1) (id2, def_meth2) - = check (name1 == name2) - (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> - text "are different") `andThenCheck` - check (eqTypeX env op_ty1 op_ty2) - (text "The types of" <+> pname1 <+> - text "are different") `andThenCheck` - if is_boot - then check (eqMaybeBy eqDM def_meth1 def_meth2) - (text "The default methods associated with" <+> pname1 <+> - text "are different") - else check (subDM op_ty1 def_meth1 def_meth2) - (text "The default methods associated with" <+> pname1 <+> - text "are not compatible") - where - name1 = idName id1 - name2 = idName id2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - (_, rho_ty1) = splitForAllTys (idType id1) - op_ty1 = funResultTy rho_ty1 - (_, rho_ty2) = splitForAllTys (idType id2) - op_ty2 = funResultTy rho_ty2 - - eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) - = checkBootTyCon is_boot tc1 tc2 `andThenCheck` - check (eqATDef def_ats1 def_ats2) - (text "The associated type defaults differ") - - eqDM (_, VanillaDM) (_, VanillaDM) = True - eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2 - eqDM _ _ = False - - -- NB: first argument is from hsig, second is from real impl. - -- Order of pattern matching matters. - subDM _ Nothing _ = True - subDM _ _ Nothing = False - -- If the hsig wrote: - -- - -- f :: a -> a - -- default f :: a -> a - -- - -- this should be validly implementable using an old-fashioned - -- vanilla default method. - subDM t1 (Just (_, GenericDM t2)) (Just (_, VanillaDM)) - = eqTypeX env t1 t2 - -- This case can occur when merging signatures - subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2)) - = eqTypeX env t1 t2 - subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True - subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2)) - = eqTypeX env t1 t2 - - -- Ignore the location of the defaults - eqATDef Nothing Nothing = True - eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2 - eqATDef _ _ = False - - eqFD (as1,bs1) (as2,bs2) = - eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && - eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) - in - checkRoles roles1 roles2 `andThenCheck` - -- Checks kind of class - check (eqListBy eqFD clas_fds1 clas_fds2) - (text "The functional dependencies do not match") `andThenCheck` - checkUnless (isAbstractTyCon tc1) $ - check (eqListBy (eqTypeX env) sc_theta1 sc_theta2) - (text "The class constraints do not match") `andThenCheck` - checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` - checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck` - check (classMinimalDef c1 `BF.implies` classMinimalDef c2) - (text "The MINIMAL pragmas are not compatible") - - | Just syn_rhs1 <- synTyConRhs_maybe tc1 - , Just syn_rhs2 <- synTyConRhs_maybe tc2 - , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) - = ASSERT(tc1 == tc2) - checkRoles roles1 roles2 `andThenCheck` - check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say - -- This allows abstract 'data T a' to be implemented using 'type T = ...' - -- and abstract 'class K a' to be implement using 'type K = ...' - -- See Note [Synonyms implement abstract data] - | not is_boot -- don't support for hs-boot yet - , isAbstractTyCon tc1 - , Just (tvs, ty) <- synTyConDefn_maybe tc2 - , Just (tc2', args) <- tcSplitTyConApp_maybe ty - = checkSynAbsData tvs ty tc2' args - -- TODO: When it's a synonym implementing a class, we really - -- should check if the fundeps are satisfied, but - -- there is not an obvious way to do this for a constraint synonym. - -- So for now, let it all through (it won't cause segfaults, anyway). - -- Tracked at #12704. - - -- This allows abstract 'data T :: Nat' to be implemented using - -- 'type T = 42' Since the kinds already match (we have checked this - -- upfront) all we need to check is that the implementation 'type T - -- = ...' defined an actual literal. See #15138 for the case this - -- handles. - | not is_boot - , isAbstractTyCon tc1 - , Just (_,ty2) <- synTyConDefn_maybe tc2 - , isJust (isLitTy ty2) - = Nothing - - | Just fam_flav1 <- famTyConFlav_maybe tc1 - , Just fam_flav2 <- famTyConFlav_maybe tc2 - = ASSERT(tc1 == tc2) - let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True - eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True - -- This case only happens for hsig merging: - eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True - eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True - eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True - eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) - = eqClosedFamilyAx ax1 ax2 - eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2 - eqFamFlav _ _ = False - injInfo1 = tyConInjectivityInfo tc1 - injInfo2 = tyConInjectivityInfo tc2 - in - -- check equality of roles, family flavours and injectivity annotations - -- (NB: Type family roles are always nominal. But the check is - -- harmless enough.) - checkRoles roles1 roles2 `andThenCheck` - check (eqFamFlav fam_flav1 fam_flav2) - (whenPprDebug $ - text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+> - text "do not match") `andThenCheck` - check (injInfo1 == injInfo2) (text "Injectivities do not match") - - | isAlgTyCon tc1 && isAlgTyCon tc2 - , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) - = ASSERT(tc1 == tc2) - checkRoles roles1 roles2 `andThenCheck` - check (eqListBy (eqTypeX env) - (tyConStupidTheta tc1) (tyConStupidTheta tc2)) - (text "The datatype contexts do not match") `andThenCheck` - eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) - - | otherwise = Just empty -- two very different types -- should be obvious - where - roles1 = tyConRoles tc1 -- the abstract one - roles2 = tyConRoles tc2 - roles_msg = text "The roles do not match." $$ - (text "Roles on abstract types default to" <+> - quotes (text "representational") <+> text "in boot files.") - - roles_subtype_msg = text "The roles are not compatible:" $$ - text "Main module:" <+> ppr roles2 $$ - text "Hsig file:" <+> ppr roles1 - - checkRoles r1 r2 - | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping] - = check (r1 == r2) roles_msg - | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg - - -- Note [Role subtyping] - -- ~~~~~~~~~~~~~~~~~~~~~ - -- In the current formulation of roles, role subtyping is only OK if the - -- "abstract" TyCon was not representationally injective. Among the most - -- notable examples of non representationally injective TyCons are abstract - -- data, which can be implemented via newtypes (which are not - -- representationally injective). The key example is - -- in this example from #13140: - -- - -- -- In an hsig file - -- data T a -- abstract! - -- type role T nominal - -- - -- -- Elsewhere - -- foo :: Coercible (T a) (T b) => a -> b - -- foo x = x - -- - -- We must NOT allow foo to typecheck, because if we instantiate - -- T with a concrete data type with a phantom role would cause - -- Coercible (T a) (T b) to be provable. Fortunately, if T is not - -- representationally injective, we cannot make the inference that a ~N b if - -- T a ~R T b. - -- - -- Unconditional role subtyping would be possible if we setup - -- an extra set of roles saying when we can project out coercions - -- (we call these proj-roles); then it would NOT be valid to instantiate T - -- with a data type at phantom since the proj-role subtyping check - -- would fail. See #13140 for more details. - -- - -- One consequence of this is we get no role subtyping for non-abstract - -- data types in signatures. Suppose you have: - -- - -- signature A where - -- type role T nominal - -- data T a = MkT - -- - -- If you write this, we'll treat T as injective, and make inferences - -- like T a ~R T b ==> a ~N b (mkNthCo). But if we can - -- subsequently replace T with one at phantom role, we would then be able to - -- infer things like T Int ~R T Bool which is bad news. - -- - -- We could allow role subtyping here if we didn't treat *any* data types - -- defined in signatures as injective. But this would be a bit surprising, - -- replacing a data type in a module with one in a signature could cause - -- your code to stop typechecking (whereas if you made the type abstract, - -- it is more understandable that the type checker knows less). - -- - -- It would have been best if this was purely a question of defaults - -- (i.e., a user could explicitly ask for one behavior or another) but - -- the current role system isn't expressive enough to do this. - -- Having explicit proj-roles would solve this problem. - - rolesSubtypeOf [] [] = True - -- NB: this relation is the OPPOSITE of the subroling relation - rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys - rolesSubtypeOf _ _ = False - - -- Note [Synonyms implement abstract data] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- An abstract data type or class can be implemented using a type synonym, - -- but ONLY if the type synonym is nullary and has no type family - -- applications. This arises from two properties of skolem abstract data: - -- - -- For any T (with some number of paramaters), - -- - -- 1. T is a valid type (it is "curryable"), and - -- - -- 2. T is valid in an instance head (no type families). - -- - -- See also 'HowAbstract' and Note [Skolem abstract data]. - - -- | Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@, - -- check that this synonym is an acceptable implementation of @tc1@. - -- See Note [Synonyms implement abstract data] - checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc - checkSynAbsData tvs ty tc2' args = - check (null (tcTyFamInsts ty)) - (text "Illegal type family application in implementation of abstract data.") - `andThenCheck` - check (null tvs) - (text "Illegal parameterized type synonym in implementation of abstract data." $$ - text "(Try eta reducing your type synonym so that it is nullary.)") - `andThenCheck` - -- Don't report roles errors unless the type synonym is nullary - checkUnless (not (null tvs)) $ - ASSERT( null roles2 ) - -- If we have something like: - -- - -- signature H where - -- data T a - -- module H where - -- data K a b = ... - -- type T = K Int - -- - -- we need to drop the first role of K when comparing! - checkRoles roles1 (drop (length args) (tyConRoles tc2')) -{- - -- Hypothetically, if we were allow to non-nullary type synonyms, here - -- is how you would check the roles - if length tvs == length roles1 - then checkRoles roles1 roles2 - else case tcSplitTyConApp_maybe ty of - Just (tc2', args) -> - checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2) - Nothing -> Just roles_msg --} - - eqAlgRhs _ AbstractTyCon _rhs2 - = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon - eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} = - checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors") - eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} = - eqCon (data_con tc1) (data_con tc2) - eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+> - text "definition with a" <+> quotes (text "newtype") <+> - text "definition") - - eqCon c1 c2 - = check (name1 == name2) - (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> - text "differ") `andThenCheck` - check (dataConIsInfix c1 == dataConIsInfix c2) - (text "The fixities of" <+> pname1 <+> - text "differ") `andThenCheck` - check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) - (text "The strictness annotations for" <+> pname1 <+> - text "differ") `andThenCheck` - check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) - (text "The record label lists for" <+> pname1 <+> - text "differ") `andThenCheck` - check (eqType (dataConUserType c1) (dataConUserType c2)) - (text "The types for" <+> pname1 <+> text "differ") - where - name1 = dataConName c1 - name2 = dataConName c2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - - eqClosedFamilyAx Nothing Nothing = True - eqClosedFamilyAx Nothing (Just _) = False - eqClosedFamilyAx (Just _) Nothing = False - eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 })) - (Just (CoAxiom { co_ax_branches = branches2 })) - = numBranches branches1 == numBranches branches2 - && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2) - where - branch_list1 = fromBranches branches1 - branch_list2 = fromBranches branches2 - - eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1 - , cab_lhs = lhs1, cab_rhs = rhs1 }) - (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2 - , cab_lhs = lhs2, cab_rhs = rhs2 }) - | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 - , Just env <- eqVarBndrs env1 cvs1 cvs2 - = eqListBy (eqTypeX env) lhs1 lhs2 && - eqTypeX env rhs1 rhs2 - - | otherwise = False - -emptyRnEnv2 :: RnEnv2 -emptyRnEnv2 = mkRnEnv2 emptyInScopeSet - ----------------- -missingBootThing :: Bool -> Name -> String -> SDoc -missingBootThing is_boot name what - = quotes (ppr name) <+> text "is exported by the" - <+> (if is_boot then text "hs-boot" else text "hsig") - <+> text "file, but not" - <+> text what <+> text "the module" - -badReexportedBootThing :: Bool -> Name -> Name -> SDoc -badReexportedBootThing is_boot name name' - = withUserStyle alwaysQualify AllTheWay $ vcat - [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") - <+> text "file (re)exports" <+> quotes (ppr name) - , text "but the implementing module exports a different identifier" <+> quotes (ppr name') - ] - -bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc -bootMisMatch is_boot extra_info real_thing boot_thing - = pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc - where - to_doc - = pprTyThingInContext $ showToHeader { ss_forall = - if is_boot - then ShowForAllMust - else ShowForAllWhen } - - real_doc = to_doc real_thing - boot_doc = to_doc boot_thing - - pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc - pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc - = vcat - [ ppr real_thing <+> - text "has conflicting definitions in the module", - text "and its" <+> - (if is_boot - then text "hs-boot file" - else text "hsig file"), - text "Main module:" <+> real_doc, - (if is_boot - then text "Boot file: " - else text "Hsig file: ") - <+> boot_doc, - extra_info - ] - -instMisMatch :: DFunId -> SDoc -instMisMatch dfun - = hang (text "instance" <+> ppr (idType dfun)) - 2 (text "is defined in the hs-boot file, but not in the module itself") - -{- -************************************************************************ -* * - Type-checking the top level of a module (continued) -* * -************************************************************************ --} - -rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn) --- Fails if there are any errors -rnTopSrcDecls group - = do { -- Rename the source decls - traceRn "rn12" empty ; - (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; - traceRn "rn13" empty ; - (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ; - traceRn "rn13-plugin" empty ; - - -- save the renamed syntax, if we want it - let { tcg_env' - | Just grp <- tcg_rn_decls tcg_env - = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } - | otherwise - = tcg_env }; - - -- Dump trace of renaming part - rnDump rn_decls ; - return (tcg_env', rn_decls) - } - -tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, - hs_derivds = deriv_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_annds = annotation_decls, - hs_ruleds = rule_decls, - hs_valds = hs_val_binds@(XValBindsLR - (NValBinds val_binds val_sigs)) }) - = do { -- Type-check the type and class decls, and all imported decls - -- The latter come in via tycl_decls - traceTc "Tc2 (src)" empty ; - - -- Source-language instances, including derivings, - -- and import the supporting declarations - traceTc "Tc3" empty ; - (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs)) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; - - setGblEnv tcg_env $ do { - - -- Generate Applicative/Monad proposal (AMP) warnings - traceTc "Tc3b" empty ; - - -- Generate Semigroup/Monoid warnings - traceTc "Tc3c" empty ; - tcSemigroupWarnings ; - - -- Foreign import declarations next. - traceTc "Tc4" empty ; - (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; - tcExtendGlobalValEnv fi_ids $ do { - - -- Default declarations - traceTc "Tc4a" empty ; - default_tys <- tcDefaults default_decls ; - updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { - - -- Value declarations next. - -- It is important that we check the top-level value bindings - -- before the GHC-generated derived bindings, since the latter - -- may be defined in terms of the former. (For instance, - -- the bindings produced in a Data instance.) - traceTc "Tc5" empty ; - tc_envs <- tcTopBinds val_binds val_sigs; - setEnvs tc_envs $ do { - - -- Now GHC-generated derived bindings, generics, and selectors - -- Do not generate warnings from compiler-generated code; - -- hence the use of discardWarnings - tc_envs@(tcg_env, tcl_env) - <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ; - setEnvs tc_envs $ do { -- Environment doesn't change now - - -- Second pass over class and instance declarations, - -- now using the kind-checked decls - traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; - - -- Foreign exports - traceTc "Tc7" empty ; - (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ; - - -- Annotations - annotations <- tcAnnotations annotation_decls ; - - -- Rules - rules <- tcRules rule_decls ; - - -- Wrap up - traceTc "Tc7a" empty ; - let { all_binds = inst_binds `unionBags` - foe_binds - - ; fo_gres = fi_gres `unionBags` foe_gres - ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` gre_name gre) - emptyFVs fo_gres - - ; sig_names = mkNameSet (collectHsValBinders hs_val_binds) - `minusNameSet` getTypeSigNames val_sigs - - -- Extend the GblEnv with the (as yet un-zonked) - -- bindings, rules, foreign decls - ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds - , tcg_sigs = tcg_sigs tcg_env `unionNameSet` sig_names - , tcg_rules = tcg_rules tcg_env - ++ flattenRuleDecls rules - , tcg_anns = tcg_anns tcg_env ++ annotations - , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations - , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls - , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; - -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] - - -- See Note [Newtype constructor usage in foreign declarations] - addUsedGREs (bagToList fo_gres) ; - - return (tcg_env', tcl_env) - }}}}}} - -tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" - - -tcSemigroupWarnings :: TcM () -tcSemigroupWarnings = do - traceTc "tcSemigroupWarnings" empty - let warnFlag = Opt_WarnSemigroup - tcPreludeClashWarn warnFlag sappendName - tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName - - --- | Warn on local definitions of names that would clash with future Prelude --- elements. --- --- A name clashes if the following criteria are met: --- 1. It would is imported (unqualified) from Prelude --- 2. It is locally defined in the current module --- 3. It has the same literal name as the reference function --- 4. It is not identical to the reference function -tcPreludeClashWarn :: WarningFlag - -> Name - -> TcM () -tcPreludeClashWarn warnFlag name = do - { warn <- woptM warnFlag - ; when warn $ do - { traceTc "tcPreludeClashWarn/wouldBeImported" empty - -- Is the name imported (unqualified) from Prelude? (Point 4 above) - ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv - -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude - -- will not appear in rnImports automatically if it is set.) - - -- Continue only the name is imported from Prelude - ; when (importedViaPrelude name rnImports) $ do - -- Handle 2.-4. - { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv - - ; let clashes :: GlobalRdrElt -> Bool - clashes x = isLocalDef && nameClashes && isNotInProperModule - where - isLocalDef = gre_lcl x == True - -- Names are identical ... - nameClashes = nameOccName (gre_name x) == nameOccName name - -- ... but not the actual definitions, because we don't want to - -- warn about a bad definition of e.g. <> in Data.Semigroup, which - -- is the (only) proper place where this should be defined - isNotInProperModule = gre_name x /= name - - -- List of all offending definitions - clashingElts :: [GlobalRdrElt] - clashingElts = filter clashes rdrElts - - ; traceTc "tcPreludeClashWarn/prelude_functions" - (hang (ppr name) 4 (sep [ppr clashingElts])) - - ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep - [ text "Local definition of" - , (quotes . ppr . nameOccName . gre_name) x - , text "clashes with a future Prelude name." ] - $$ - text "This will become an error in a future release." ) - ; mapM_ warn_msg clashingElts - }}} - - where - - -- Is the given name imported via Prelude? - -- - -- Possible scenarios: - -- a) Prelude is imported implicitly, issue warnings. - -- b) Prelude is imported explicitly, but without mentioning the name in - -- question. Issue no warnings. - -- c) Prelude is imported hiding the name in question. Issue no warnings. - -- d) Qualified import of Prelude, no warnings. - importedViaPrelude :: Name - -> [ImportDecl GhcRn] - -> Bool - importedViaPrelude name = any importViaPrelude - where - isPrelude :: ImportDecl GhcRn -> Bool - isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME - - -- Implicit (Prelude) import? - isImplicit :: ImportDecl GhcRn -> Bool - isImplicit = ideclImplicit - - -- Unqualified import? - isUnqualified :: ImportDecl GhcRn -> Bool - isUnqualified = not . isImportDeclQualified . ideclQualified - - -- List of explicitly imported (or hidden) Names from a single import. - -- Nothing -> No explicit imports - -- Just (False, <names>) -> Explicit import list of <names> - -- Just (True , <names>) -> Explicit hiding of <names> - importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name]) - importListOf = fmap toImportList . ideclHiding - where - toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc)) - - isExplicit :: ImportDecl GhcRn -> Bool - isExplicit x = case importListOf x of - Nothing -> False - Just (False, explicit) - -> nameOccName name `elem` map nameOccName explicit - Just (True, hidden) - -> nameOccName name `notElem` map nameOccName hidden - - -- Check whether the given name would be imported (unqualified) from - -- an import declaration. - importViaPrelude :: ImportDecl GhcRn -> Bool - importViaPrelude x = isPrelude x - && isUnqualified x - && (isImplicit x || isExplicit x) - - --- Notation: is* is for classes the type is an instance of, should* for those --- that it should also be an instance of based on the corresponding --- is*. -tcMissingParentClassWarn :: WarningFlag - -> Name -- ^ Instances of this ... - -> Name -- ^ should also be instances of this - -> TcM () -tcMissingParentClassWarn warnFlag isName shouldName - = do { warn <- woptM warnFlag - ; when warn $ do - { traceTc "tcMissingParentClassWarn" empty - ; isClass' <- tcLookupClass_maybe isName - ; shouldClass' <- tcLookupClass_maybe shouldName - ; case (isClass', shouldClass') of - (Just isClass, Just shouldClass) -> do - { localInstances <- tcGetInsts - ; let isInstance m = is_cls m == isClass - isInsts = filter isInstance localInstances - ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts) - ; forM_ isInsts (checkShouldInst isClass shouldClass) - } - (is',should') -> - traceTc "tcMissingParentClassWarn/notIsShould" - (hang (ppr isName <> text "/" <> ppr shouldName) 2 ( - (hsep [ quotes (text "Is"), text "lookup for" - , ppr isName - , text "resulted in", ppr is' ]) - $$ - (hsep [ quotes (text "Should"), text "lookup for" - , ppr shouldName - , text "resulted in", ppr should' ]))) - }} - where - -- Check whether the desired superclass exists in a given environment. - checkShouldInst :: Class -- ^ Class of existing instance - -> Class -- ^ Class there should be an instance of - -> ClsInst -- ^ Existing instance - -> TcM () - checkShouldInst isClass shouldClass isInst - = do { instEnv <- tcGetInstEnvs - ; let (instanceMatches, shouldInsts, _) - = lookupInstEnv False instEnv shouldClass (is_tys isInst) - - ; traceTc "tcMissingParentClassWarn/checkShouldInst" - (hang (ppr isInst) 4 - (sep [ppr instanceMatches, ppr shouldInsts])) - - -- "<location>: Warning: <type> is an instance of <is> but not - -- <should>" e.g. "Foo is an instance of Monad but not Applicative" - ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst - warnMsg (Just name:_) = - addWarnAt (Reason warnFlag) instLoc $ - hsep [ (quotes . ppr . nameOccName) name - , text "is an instance of" - , (ppr . nameOccName . className) isClass - , text "but not" - , (ppr . nameOccName . className) shouldClass ] - <> text "." - $$ - hsep [ text "This will become an error in" - , text "a future release." ] - warnMsg _ = pure () - ; when (null shouldInsts && null instanceMatches) $ - warnMsg (is_tcs isInst) - } - - tcLookupClass_maybe :: Name -> TcM (Maybe Class) - tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case - Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls - _else -> pure Nothing - - ---------------------------- -tcTyClsInstDecls :: [TyClGroup GhcRn] - -> [LDerivDecl GhcRn] - -> [(RecFlag, LHsBinds GhcRn)] - -> TcM (TcGblEnv, -- The full inst env - [InstInfo GhcRn], -- Source-code instance decls to - -- process; contains all dfuns for - -- this module - HsValBinds GhcRn) -- Supporting bindings for derived - -- instances - -tcTyClsInstDecls tycl_decls deriv_decls binds - = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ - tcAddPatSynPlaceholders (getPatSynBinds binds) $ - do { (tcg_env, inst_info, deriv_info) - <- tcTyAndClassDecls tycl_decls ; - ; setGblEnv tcg_env $ do { - -- With the @TyClDecl@s and @InstDecl@s checked we're ready to - -- process the deriving clauses, including data family deriving - -- clauses discovered in @tcTyAndClassDecls@. - -- - -- Careful to quit now in case there were instance errors, so that - -- the deriving errors don't pile up as well. - ; failIfErrsM - ; (tcg_env', inst_info', val_binds) - <- tcInstDeclsDeriv deriv_info deriv_decls - ; setGblEnv tcg_env' $ do { - failIfErrsM - ; pure (tcg_env', inst_info' ++ inst_info, val_binds) - }}} - -{- ********************************************************************* -* * - Checking for 'main' -* * -************************************************************************ --} - -checkMain :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE GhcPs]) -- Export specs of Main module - -> TcM TcGblEnv --- If we are in module Main, check that 'main' is defined and exported. -checkMain explicit_mod_hdr export_ies - = do { dflags <- getDynFlags - ; tcg_env <- getGblEnv - ; check_main dflags tcg_env explicit_mod_hdr export_ies } - -check_main :: DynFlags -> TcGblEnv -> Bool -> Maybe (Located [LIE GhcPs]) - -> TcM TcGblEnv -check_main dflags tcg_env explicit_mod_hdr export_ies - | mod /= main_mod - = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >> - return tcg_env - - | otherwise - -- Compare the list of main functions in scope with those - -- specified in the export list. - = do mains_all <- lookupInfoOccRn main_fn - -- get all 'main' functions in scope - -- They may also be imported from other modules! - case exportedMains of -- check the main(s) specified in the export list - [ ] -> do - -- The module has no main functions in the export spec, so we must give - -- some kind of error message. The tricky part is giving an error message - -- that accurately characterizes what the problem is. - -- See Note [Main module without a main function in the export spec] - traceTc "checkMain no main module exported" ppr_mod_mainfn - complain_no_main - -- In order to reduce the number of potential error messages, we check - -- to see if there are any main functions defined (but not exported)... - case getSomeMain mains_all of - Nothing -> return tcg_env - -- ...if there are no such main functions, there is nothing we can do... - Just some_main -> use_as_main some_main - -- ...if there is such a main function, then communicate this to the - -- typechecker. This can prevent a spurious "Ambiguous type variable" - -- error message in certain cases, as described in - -- Note [Main module without a main function in the export spec]. - _ -> do -- The module has one or more main functions in the export spec - let mains = filterInsMains exportedMains mains_all - case mains of - [] -> do -- - traceTc "checkMain fail" ppr_mod_mainfn - complain_no_main - return tcg_env - [main_name] -> use_as_main main_name - _ -> do -- multiple main functions are exported - addAmbiguousNameErr main_fn -- issue error msg - return tcg_env - where - mod = tcg_mod tcg_env - main_mod = mainModIs dflags - main_mod_nm = moduleName main_mod - main_fn = getMainFun dflags - occ_main_fn = occName main_fn - interactive = ghcLink dflags == LinkInMemory - exportedMains = selExportMains export_ies - ppr_mod_mainfn = ppr main_mod <+> ppr main_fn - - -- There is a single exported 'main' function. - use_as_main :: Name -> TcM TcGblEnv - use_as_main main_name = do - { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) - ; let loc = srcLocSpan (getSrcLoc main_name) - ; ioTyCon <- tcLookupTyCon ioTyConName - ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; let io_ty = mkTyConApp ioTyCon [res_ty] - skol_info = SigSkol (FunSigCtxt main_name False) io_ty [] - ; (ev_binds, main_expr) - <- checkConstraints skol_info [] [] $ - addErrCtxt mainCtxt $ - tcMonoExpr (L loc (HsVar noExtField (L loc main_name))) - (mkCheckExpType io_ty) - - -- See Note [Root-main Id] - -- Construct the binding - -- :Main.main :: IO res_ty = runMainIO res_ty main - ; run_main_id <- tcLookupId runMainIOName - ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN - (mkVarOccFS (fsLit "main")) - (getSrcSpan main_name) - ; root_main_id = Id.mkExportedVanillaId root_main_name - (mkTyConApp ioTyCon [res_ty]) - ; co = mkWpTyApps [res_ty] - -- The ev_binds of the `main` function may contain deferred - -- type error when type of `main` is not `IO a`. The `ev_binds` - -- must be put inside `runMainIO` to ensure the deferred type - -- error can be emitted correctly. See #13838. - ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $ - mkHsDictLet ev_binds main_expr - ; main_bind = mkVarBind root_main_id rhs } - - ; return (tcg_env { tcg_main = Just main_name, - tcg_binds = tcg_binds tcg_env - `snocBag` main_bind, - tcg_dus = tcg_dus tcg_env - `plusDU` usesOnly (unitFV main_name) - -- Record the use of 'main', so that we don't - -- complain about it being defined but not used - })} - - complain_no_main = unless (interactive && not explicit_mod_hdr) - (addErrTc noMainMsg) -- #12906 - -- Without an explicit module header... - -- in interactive mode, don't worry about the absence of 'main'. - -- in other modes, add error message and go on with typechecking. - - mainCtxt = text "When checking the type of the" <+> pp_main_fn - noMainMsg = text "The" <+> pp_main_fn - <+> text "is not" <+> text defOrExp <+> text "module" - <+> quotes (ppr main_mod) - defOrExp = if null exportedMains then "exported by" else "defined in" - - pp_main_fn = ppMainFn main_fn - - -- Select the main functions from the export list. - -- Only the module name is needed, the function name is fixed. - selExportMains :: Maybe (Located [LIE GhcPs]) -> [ModuleName] -- #16453 - selExportMains Nothing = [main_mod_nm] - -- no main specified, but there is a header. - selExportMains (Just exps) = fmap fst $ - filter (\(_,n) -> n == occ_main_fn ) texp - where - ies = fmap unLoc $ unLoc exps - texp = mapMaybe transExportIE ies - - -- Filter all main functions in scope that match the export specs - filterInsMains :: [ModuleName] -> [Name] -> [Name] -- #16453 - filterInsMains export_mains inscope_mains = - [mod | mod <- inscope_mains, - (moduleName . nameModule) mod `elem` export_mains] - - -- Transform an export_ie to a (ModuleName, OccName) pair. - -- 'IEVar' constructors contain exported values (functions), eg '(Main.main)' - -- 'IEModuleContents' constructors contain fully exported modules, eg '(Main)' - -- All other 'IE...' constructors are not used and transformed to Nothing. - transExportIE :: IE GhcPs -> Maybe (ModuleName, OccName) -- #16453 - transExportIE (IEVar _ var) = isQual_maybe $ - upqual $ ieWrappedName $ unLoc var - where - -- A module name is always needed, so qualify 'UnQual' rdr names. - upqual (Unqual occ) = Qual main_mod_nm occ - upqual rdr = rdr - transExportIE (IEModuleContents _ mod) = Just (unLoc mod, occ_main_fn) - transExportIE _ = Nothing - - -- Get a main function that is in scope. - -- See Note [Main module without a main function in the export spec] - getSomeMain :: [Name] -> Maybe Name -- #16453 - getSomeMain all_mains = case all_mains of - [] -> Nothing -- No main function in scope - [m] -> Just m -- Just one main function in scope - _ -> case mbMainOfMain of - Nothing -> listToMaybe all_mains -- Take the first main function in scope or Nothing - _ -> mbMainOfMain -- Take the Main module's main function or Nothing - where - mbMainOfMain = find (\n -> (moduleName . nameModule) n == main_mod_nm ) - all_mains -- the main function of the Main module - --- | Get the unqualified name of the function to use as the \"main\" for the main module. --- Either returns the default name or the one configured on the command line with -main-is -getMainFun :: DynFlags -> RdrName -getMainFun dflags = case mainFunIs dflags of - Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) - Nothing -> main_RDR_Unqual - -ppMainFn :: RdrName -> SDoc -ppMainFn main_fn - | rdrNameOcc main_fn == mainOcc - = text "IO action" <+> quotes (ppr main_fn) - | otherwise - = text "main IO action" <+> quotes (ppr main_fn) - -mainOcc :: OccName -mainOcc = mkVarOccFS (fsLit "main") - -{- -Note [Root-main Id] -~~~~~~~~~~~~~~~~~~~ -The function that the RTS invokes is always :Main.main, which we call -root_main_id. (Because GHC allows the user to have a module not -called Main as the main module, we can't rely on the main function -being called "Main.main". That's why root_main_id has a fixed module -":Main".) - -This is unusual: it's a LocalId whose Name has a Module from another -module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we -get two defns for 'main' in the interface file! - - -Note [Main module without a main function in the export spec] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Giving accurate error messages for a Main module that does not export a main -function is surprisingly tricky. To see why, consider a module in a file -`Foo.hs` that has no `main` function in the explicit export specs of the module -header: - - module Main () where - foo = return () - -This does not export a main function and therefore should be rejected, per -chapter 5 of the Haskell Report 2010: - - A Haskell program is a collection of modules, one of which, by convention, - must be called Main and must export the value main. The value of the - program is the value of the identifier main in module Main, which must be - a computation of type IO τ for some type τ. - -In fact, when you compile the program above using `ghc Foo.hs`, you will -actually get *two* errors: - - - The IO action ‘main’ is not defined in module ‘Main’ - - - Ambiguous type variable ‘m0’ arising from a use of ‘return’ - prevents the constraint ‘(Monad m0)’ from being solved. - -The first error is self-explanatory, while the second error message occurs -due to the monomorphism restriction. - -Now consider what would happen if the program above were compiled with -`ghc -main-is foo Foo`. The has the effect of `foo` being designated as the -main function. The program will still be rejected since it does not export -`foo` (and therefore does not export its main function), but there is one -important difference: `foo` will be checked against the type `IO τ`. As a -result, we would *not* expect the monomorphism restriction error message -to occur, since the typechecker should have no trouble figuring out the type -of `foo`. In other words, we should only throw the former error message, -not the latter. - -The implementation uses the function `getSomeMain` to find a potential main -function that is defined but not exported. If one is found, it is passed to -`use_as_main` to inform the typechecker that the main function should be of -type `IO τ`. See also the `T414` and `T17171a` test cases for similar examples -of programs whose error messages are influenced by the situation described in -this Note. - - -********************************************************* -* * - GHCi stuff -* * -********************************************************* --} - -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a) --- Initialise the tcg_inst_env with instances from all home modules. --- This mimics the more selective call to hptInstances in tcRnImports -runTcInteractive hsc_env thing_inside - = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withHoleFitPlugins hsc_env $ - do { traceTc "setInteractiveContext" $ - vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) - , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) - , text "ic_rn_gbl_env (LocalDef)" <+> - vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt) - , let local_gres = filter isLocalGRE gres - , not (null local_gres) ]) ] - - ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface - : dep_orphs (mi_deps iface)) - (loadSrcInterface (text "runTcInteractive") m - False mb_pkg) - - ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> - case i of -- force above: see #15111 - IIModule n -> getOrphans n Nothing - IIDecl i -> - let mb_pkg = sl_fs <$> ideclPkgQual i in - getOrphans (unLoc (ideclName i)) mb_pkg - - ; let imports = emptyImportAvails { - imp_orphs = orphs - } - - ; (gbl_env, lcl_env) <- getEnvs - ; let gbl_env' = gbl_env { - tcg_rdr_env = ic_rn_gbl_env icxt - , tcg_type_env = type_env - , tcg_inst_env = extendInstEnvList - (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) - home_insts - , tcg_fam_inst_env = extendFamInstEnvList - (extendFamInstEnvList (tcg_fam_inst_env gbl_env) - ic_finsts) - home_fam_insts - , tcg_field_env = mkNameEnv con_fields - -- setting tcg_field_env is necessary - -- to make RecordWildCards work (test: ghci049) - , tcg_fix_env = ic_fix_env icxt - , tcg_default = ic_default icxt - -- must calculate imp_orphs of the ImportAvails - -- so that instance visibility is done correctly - , tcg_imports = imports - } - - lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids - - ; setEnvs (gbl_env', lcl_env') thing_inside } - where - (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) - - icxt = hsc_IC hsc_env - (ic_insts, ic_finsts) = ic_instances icxt - (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt) - - is_closed :: TyThing -> Either (Name, TcTyThing) TyThing - -- Put Ids with free type variables (always RuntimeUnks) - -- in the *local* type environment - -- See Note [Initialising the type environment for GHCi] - is_closed thing - | AnId id <- thing - , not (isTypeClosedLetBndr id) - = Left (idName id, ATcId { tct_id = id - , tct_info = NotLetBound }) - | otherwise - = Right thing - - type_env1 = mkTypeEnvWithImplicits top_ty_things - type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts) - -- Putting the dfuns in the type_env - -- is just to keep Core Lint happy - - con_fields = [ (dataConName c, dataConFieldLabels c) - | ATyCon t <- top_ty_things - , c <- tyConDataCons t ] - - -{- Note [Initialising the type environment for GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most of the Ids in ic_things, defined by the user in 'let' stmts, -have closed types. E.g. - ghci> let foo x y = x && not y - -However the GHCi debugger creates top-level bindings for Ids whose -types have free RuntimeUnk skolem variables, standing for unknown -types. If we don't register these free TyVars as global TyVars then -the typechecker will try to quantify over them and fall over in -skolemiseQuantifiedTyVar. so we must add any free TyVars to the -typechecker's global TyVar set. That is done by using -tcExtendLocalTypeEnv. - -We do this by splitting out the Ids with open types, using 'is_closed' -to do the partition. The top-level things go in the global TypeEnv; -the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the -local TypeEnv. - -Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope -things are already in the interactive context's GlobalRdrEnv. -Extending the local RdrEnv isn't terrible, but it means there is an -entry for the same Name in both global and local RdrEnvs, and that -lead to duplicate "perhaps you meant..." suggestions (e.g. T5564). - -We don't bother with the tcl_th_bndrs environment either. --} - --- | The returned [Id] is the list of new Ids bound by this statement. It can --- be used to extend the InteractiveContext via extendInteractiveContext. --- --- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound --- values, coerced to (). -tcRnStmt :: HscEnv -> GhciLStmt GhcPs - -> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) -tcRnStmt hsc_env rdr_stmt - = runTcInteractive hsc_env $ do { - - -- The real work is done here - ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ; - zonked_expr <- zonkTopLExpr tc_expr ; - zonked_ids <- zonkTopBndrs bound_ids ; - - failIfErrsM ; -- we can't do the next step if there are levity polymorphism errors - -- test case: ghci/scripts/T13202{,a} - - -- None of the Ids should be of unboxed type, because we - -- cast them all to HValues in the end! - mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ; - - traceTc "tcs 1" empty ; - this_mod <- getModule ; - global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ; - -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types - -{- --------------------------------------------- - At one stage I removed any shadowed bindings from the type_env; - they are inaccessible but might, I suppose, cause a space leak if we leave them there. - However, with Template Haskell they aren't necessarily inaccessible. Consider this - GHCi session - Prelude> let f n = n * 2 :: Int - Prelude> fName <- runQ [| f |] - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) - 14 - Prelude> let f n = n * 3 :: Int - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) - In the last line we use 'fName', which resolves to the *first* 'f' - in scope. If we delete it from the type env, GHCi crashes because - it doesn't expect that. - - Hence this code is commented out - --------------------------------------------------- -} - - traceOptTcRn Opt_D_dump_tc - (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, - text "Typechecked expr" <+> ppr zonked_expr]) ; - - return (global_ids, zonked_expr, fix_env) - } - where - bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:", - nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) - -{- --------------------------------------------------------------------------- - Typechecking Stmts in GHCi - -Here is the grand plan, implemented in tcUserStmt - - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] - [NB: result not printed] bindings: [it] - - expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] - result showable) bindings: [it] - - expr (of non-IO type, - result not showable) ==> error --} - --- | A plan is an attempt to lift some code into the IO monad. -type PlanResult = ([Id], LHsExpr GhcTc) -type Plan = TcM PlanResult - --- | Try the plans in order. If one fails (by raising an exn), try the next. --- If one succeeds, take it. -runPlans :: [Plan] -> TcM PlanResult -runPlans [] = panic "runPlans" -runPlans [p] = p -runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p - --- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the --- GHCi 'environment'. --- --- By 'lift' and 'environment we mean that the code is changed to --- execute properly in an IO monad. See Note [Interactively-bound Ids --- in GHCi] in GHC.Driver.Types for more details. We do this lifting by trying --- different ways ('plans') of lifting the code into the IO monad and --- type checking each plan until one succeeds. -tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) - --- An expression typed at the prompt is treated very specially -tcUserStmt (L loc (BodyStmt _ expr _ _)) - = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) - -- Don't try to typecheck if the renamer fails! - ; ghciStep <- getGhciStepIO - ; uniq <- newUnique - ; interPrintName <- getInteractivePrintName - ; let fresh_it = itName uniq loc - matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr - (noLoc emptyLocalBinds)] - -- [it = expr] - the_bind = L loc $ (mkTopFunBind FromSource - (L loc fresh_it) matches) - { fun_ext = fvs } - -- Care here! In GHCi the expression might have - -- free variables, and they in turn may have free type variables - -- (if we are at a breakpoint, say). We must put those free vars - - -- [let it = expr] - let_stmt = L loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField - $ XValBindsLR - (NValBinds [(NonRecursive,unitBag the_bind)] []) - - -- [it <- e] - bind_stmt = L loc $ BindStmt noExtField - (L loc (VarPat noExtField (L loc fresh_it))) - (nlHsApp ghciStep rn_expr) - (mkRnSyntaxExpr bindIOName) - noSyntaxExpr - - -- [; print it] - print_it = L loc $ BodyStmt noExtField - (nlHsApp (nlHsVar interPrintName) - (nlHsVar fresh_it)) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - -- NewA - no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName - [rn_expr , nlHsVar interPrintName]) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - no_it_b = L loc $ BodyStmt noExtField (rn_expr) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - no_it_c = L loc $ BodyStmt noExtField - (nlHsApp (nlHsVar interPrintName) rn_expr) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - -- See Note [GHCi Plans] - - it_plans = [ - -- Plan A - do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] - ; it_ty <- zonkTcType (idType it_id) - ; when (isUnitTy $ it_ty) failM - ; return stuff }, - - -- Plan B; a naked bind statement - tcGhciStmts [bind_stmt], - - -- Plan C; check that the let-binding is typeable all by itself. - -- If not, fail; if so, try to print it. - -- The two-step process avoids getting two errors: one from - -- the expression itself, and one from the 'print it' part - -- This two-step story is very clunky, alas - do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) - --- checkNoErrs defeats the error recovery of let-bindings - ; tcGhciStmts [let_stmt, print_it] } ] - - -- Plans where we don't bind "it" - no_it_plans = [ - tcGhciStmts [no_it_a] , - tcGhciStmts [no_it_b] , - tcGhciStmts [no_it_c] ] - - ; generate_it <- goptM Opt_NoIt - - -- We disable `-fdefer-type-errors` in GHCi for naked expressions. - -- See Note [Deferred type errors in GHCi] - - -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes` - -- and `-fdefer-out-of-scope-variables`. However the flag - -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and - -- `-fno-defer-out-of-scope-variables`. Thus the later two flags - -- also need to be unset here. - ; plan <- unsetGOptM Opt_DeferTypeErrors $ - unsetGOptM Opt_DeferTypedHoles $ - unsetGOptM Opt_DeferOutOfScopeVariables $ - runPlans $ if generate_it - then no_it_plans - else it_plans - - ; fix_env <- getFixityEnv - ; return (plan, fix_env) } - -{- Note [Deferred type errors in GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHCi, we ensure that type errors don't get deferred when type checking the -naked expressions. Deferring type errors here is unhelpful because the -expression gets evaluated right away anyway. It also would potentially emit -two redundant type-error warnings, one from each plan. - -#14963 reveals another bug that when deferred type errors is enabled -in GHCi, any reference of imported/loaded variables (directly or indirectly) -in interactively issued naked expressions will cause ghc panic. See more -detailed discussion in #14963. - -The interactively issued declarations, statements, as well as the modules -loaded into GHCi, are not affected. That means, for declaration, you could -have - - Prelude> :set -fdefer-type-errors - Prelude> x :: IO (); x = putStrLn True - <interactive>:14:26: warning: [-Wdeferred-type-errors] - ? Couldn't match type ‘Bool’ with ‘[Char]’ - Expected type: String - Actual type: Bool - ? In the first argument of ‘putStrLn’, namely ‘True’ - In the expression: putStrLn True - In an equation for ‘x’: x = putStrLn True - -But for naked expressions, you will have - - Prelude> :set -fdefer-type-errors - Prelude> putStrLn True - <interactive>:2:10: error: - ? Couldn't match type ‘Bool’ with ‘[Char]’ - Expected type: String - Actual type: Bool - ? In the first argument of ‘putStrLn’, namely ‘True’ - In the expression: putStrLn True - In an equation for ‘it’: it = putStrLn True - - Prelude> let x = putStrLn True - <interactive>:2:18: warning: [-Wdeferred-type-errors] - ? Couldn't match type ‘Bool’ with ‘[Char]’ - Expected type: String - Actual type: Bool - ? In the first argument of ‘putStrLn’, namely ‘True’ - In the expression: putStrLn True - In an equation for ‘x’: x = putStrLn True --} - -tcUserStmt rdr_stmt@(L loc _) - = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ - rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do - fix_env <- getFixityEnv - return (fix_env, emptyFVs) - -- Don't try to typecheck if the renamer fails! - ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) - ; rnDump rn_stmt ; - - ; ghciStep <- getGhciStepIO - ; let gi_stmt - | (L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt - = L loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 - | otherwise = rn_stmt - - ; opt_pr_flag <- goptM Opt_PrintBindResult - ; let print_result_plan - | opt_pr_flag -- The flag says "print result" - , [v] <- collectLStmtBinders gi_stmt -- One binder - = [mk_print_result_plan gi_stmt v] - | otherwise = [] - - -- The plans are: - -- [stmt; print v] if one binder and not v::() - -- [stmt] otherwise - ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) - ; return (plan, fix_env) } - where - mk_print_result_plan stmt v - = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] - ; v_ty <- zonkTcType (idType v_id) - ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM - ; return stuff } - where - print_v = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) - (nlHsVar v)) - (mkRnSyntaxExpr thenIOName) noSyntaxExpr - -{- -Note [GHCi Plans] -~~~~~~~~~~~~~~~~~ -When a user types an expression in the repl we try to print it in three different -ways. Also, depending on whether -fno-it is set, we bind a variable called `it` -which can be used to refer to the result of the expression subsequently in the repl. - -The normal plans are : - A. [it <- e; print e] but not if it::() - B. [it <- e] - C. [let it = e; print it] - -When -fno-it is set, the plans are: - A. [e >>= print] - B. [e] - C. [let it = e in print it] - -The reason for -fno-it is explained in #14336. `it` can lead to the repl -leaking memory as it is repeatedly queried. --} - --- | Typecheck the statements given and then return the results of the --- statement in the form 'IO [()]'. -tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult -tcGhciStmts stmts - = do { ioTyCon <- tcLookupTyCon ioTyConName - ; ret_id <- tcLookupId returnIOName -- return @ IO - ; let ret_ty = mkListTy unitTy - io_ret_ty = mkTyConApp ioTyCon [ret_ty] - tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts - (mkCheckExpType io_ret_ty) - names = collectLStmtsBinders stmts - - -- OK, we're ready to typecheck the stmts - ; traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty - ; ((tc_stmts, ids), lie) <- captureTopConstraints $ - tc_io_stmts $ \ _ -> - mapM tcLookupId names - -- Look up the names right in the middle, - -- where they will all be in scope - - -- Simplify the context - ; traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty - ; const_binds <- checkNoErrs (simplifyInteractive lie) - -- checkNoErrs ensures that the plan fails if context redn fails - - - ; traceTc "TcRnDriver.tcGhciStmts: done" empty - - -- rec_expr is the expression - -- returnIO @ [()] [unsafeCoerce# () x, .., unsafeCorece# () z] - -- - -- Despite the inconvenience of building the type applications etc, - -- this *has* to be done in type-annotated post-typecheck form - -- because we are going to return a list of *polymorphic* values - -- coerced to type (). If we built a *source* stmt - -- return [coerce x, ..., coerce z] - -- then the type checker would instantiate x..z, and we wouldn't - -- get their *polymorphic* values. (And we'd get ambiguity errs - -- if they were overloaded, since they aren't applied to anything.) - - ; AnId unsafe_coerce_id <- tcLookupGlobal unsafeCoercePrimName - -- We use unsafeCoerce# here because of (U11) in - -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce - - ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $ - noLoc $ ExplicitList unitTy Nothing $ - map mk_item ids - - mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id) - , getRuntimeRep unitTy - , idType id, unitTy] - `nlHsApp` nlHsVar id - stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] - - ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts))) - } - --- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) -getGhciStepIO :: TcM (LHsExpr GhcRn) -getGhciStepIO = do - ghciTy <- getGHCiMonad - a_tv <- newName (mkTyVarOccFS (fsLit "a")) - let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) - ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) - - step_ty = noLoc $ HsForAllTy - { hst_fvf = ForallInvis - , hst_bndrs = [noLoc $ UserTyVar noExtField (noLoc a_tv)] - , hst_xforall = noExtField - , hst_body = nlHsFunTy ghciM ioM } - - stepTy :: LHsSigWcType GhcRn - stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) - - return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) - -isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) -isGHCiMonad hsc_env ty - = runTcInteractive hsc_env $ do - rdrEnv <- getGlobalRdrEnv - let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) - case occIO of - Just [n] -> do - let name = gre_name n - ghciClass <- tcLookupClass ghciIoClassName - userTyCon <- tcLookupTyCon name - let userTy = mkTyConApp userTyCon [] - _ <- tcLookupInstance ghciClass [userTy] - return name - - Just _ -> failWithTc $ text "Ambiguous type!" - Nothing -> failWithTc $ text ("Can't find type:" ++ ty) - --- | How should we infer a type? See Note [TcRnExprMode] -data TcRnExprMode = TM_Inst -- ^ Instantiate the type fully (:type) - | TM_NoInst -- ^ Do not instantiate the type (:type +v) - | TM_Default -- ^ Default the type eagerly (:type +d) - --- | tcRnExpr just finds the type of an expression -tcRnExpr :: HscEnv - -> TcRnExprMode - -> LHsExpr GhcPs - -> IO (Messages, Maybe Type) -tcRnExpr hsc_env mode rdr_expr - = runTcInteractive hsc_env $ - do { - - (rn_expr, _fvs) <- rnLExpr rdr_expr ; - failIfErrsM ; - - -- Now typecheck the expression, and generalise its type - -- it might have a rank-2 type (e.g. :t runST) - uniq <- newUnique ; - let { fresh_it = itName uniq (getLoc rdr_expr) - ; orig = lexprCtOrigin rn_expr } ; - ((tclvl, res_ty), lie) - <- captureTopConstraints $ - pushTcLevelM $ - do { (_tc_expr, expr_ty) <- tcInferSigma rn_expr - ; if inst - then snd <$> deeplyInstantiate orig expr_ty - else return expr_ty } ; - - -- Generalise - (qtvs, dicts, _, residual, _) - <- simplifyInfer tclvl infer_mode - [] {- No sig vars -} - [(fresh_it, res_ty)] - lie ; - - -- Ignore the dictionary bindings - _ <- perhaps_disable_default_warnings $ - simplifyInteractive residual ; - - let { all_expr_ty = mkInvForAllTys qtvs $ - mkPhiTy (map idType dicts) res_ty } ; - ty <- zonkTcType all_expr_ty ; - - -- We normalise type families, so that the type of an expression is the - -- same as of a bound expression (TcBinds.mkInferredPolyId). See Trac - -- #10321 for further discussion. - fam_envs <- tcGetFamInstEnvs ; - -- normaliseType returns a coercion which we discard, so the Role is - -- irrelevant - return (snd (normaliseType fam_envs Nominal ty)) - } - where - -- See Note [TcRnExprMode] - (inst, infer_mode, perhaps_disable_default_warnings) = case mode of - TM_Inst -> (True, NoRestrictions, id) - TM_NoInst -> (False, NoRestrictions, id) - TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) - --------------------------- -tcRnImportDecls :: HscEnv - -> [LImportDecl GhcPs] - -> IO (Messages, Maybe GlobalRdrEnv) --- Find the new chunk of GlobalRdrEnv created by this list of import --- decls. In contract tcRnImports *extends* the TcGblEnv. -tcRnImportDecls hsc_env import_decls - = runTcInteractive hsc_env $ - do { gbl_env <- updGblEnv zap_rdr_env $ - tcRnImports hsc_env import_decls - ; return (tcg_rdr_env gbl_env) } - where - zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } - --- tcRnType just finds the kind of a type -tcRnType :: HscEnv - -> ZonkFlexi - -> Bool -- Normalise the returned type - -> LHsType GhcPs - -> IO (Messages, Maybe (Type, Kind)) -tcRnType hsc_env flexi normalise rdr_type - = runTcInteractive hsc_env $ - setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] - do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs) - <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type) - -- The type can have wild cards, but no implicit - -- generalisation; e.g. :kind (T _) - ; failIfErrsM - - -- We follow Note [Recipe for checking a signature] in TcHsType here - - -- Now kind-check the type - -- It can have any rank or kind - -- First bring into scope any wildcards - ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type]) - ; (ty, kind) <- pushTcLevelM_ $ - -- must push level to satisfy level precondition of - -- kindGeneralize, below - solveEqualities $ - tcNamedWildCardBinders wcs $ \ wcs' -> - do { emitNamedWildCardHoleConstraints wcs' - ; tcLHsTypeUnsaturated rn_type } - - -- Do kind generalisation; see Note [Kind-generalise in tcRnType] - ; kvs <- kindGeneralizeAll kind - ; e <- mkEmptyZonkEnv flexi - - ; ty <- zonkTcTypeToTypeX e ty - - -- Do validity checking on type - ; checkValidType (GhciCtxt True) ty - - ; ty' <- if normalise - then do { fam_envs <- tcGetFamInstEnvs - ; let (_, ty') - = normaliseType fam_envs Nominal ty - ; return ty' } - else return ty ; - - ; return (ty', mkInvForAllTys kvs (tcTypeKind ty')) } - -{- Note [TcRnExprMode] -~~~~~~~~~~~~~~~~~~~~~~ -How should we infer a type when a user asks for the type of an expression e -at the GHCi prompt? We offer 3 different possibilities, described below. Each -considers this example, with -fprint-explicit-foralls enabled: - - foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String - :type{,-spec,-def} foo @Int - -:type / TM_Inst - - In this mode, we report the type that would be inferred if a variable - were assigned to expression e, without applying the monomorphism restriction. - This means we deeply instantiate the type and then regeneralize, as discussed - in #11376. - - > :type foo @Int - forall {b} {f :: * -> *}. (Foldable f, Num b) => Int -> f b -> String - - Note that the variables and constraints are reordered here, because this - is possible during regeneralization. Also note that the variables are - reported as Inferred instead of Specified. - -:type +v / TM_NoInst - - This mode is for the benefit of users using TypeApplications. It does no - instantiation whatsoever, sometimes meaning that class constraints are not - solved. - - > :type +v foo @Int - forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String - - Note that Show Int is still reported, because the solver never got a chance - to see it. - -:type +d / TM_Default - - This mode is for the benefit of users who wish to see instantiations of - generalized types, and in particular to instantiate Foldable and Traversable. - In this mode, any type variable that can be defaulted is defaulted. Because - GHCi uses -XExtendedDefaultRules, this means that Foldable and Traversable are - defaulted. - - > :type +d foo @Int - Int -> [Integer] -> String - - Note that this mode can sometimes lead to a type error, if a type variable is - used with a defaultable class but cannot actually be defaulted: - - bar :: (Num a, Monoid a) => a -> a - > :type +d bar - ** error ** - - The error arises because GHC tries to default a but cannot find a concrete - type in the defaulting list that is both Num and Monoid. (If this list is - modified to include an element that is both Num and Monoid, the defaulting - would succeed, of course.) - -Note [Kind-generalise in tcRnType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We switch on PolyKinds when kind-checking a user type, so that we will -kind-generalise the type, even when PolyKinds is not otherwise on. -This gives the right default behaviour at the GHCi prompt, where if -you say ":k T", and T has a polymorphic kind, you'd like to see that -polymorphism. Of course. If T isn't kind-polymorphic you won't get -anything unexpected, but the apparent *loss* of polymorphism, for -types that you know are polymorphic, is quite surprising. See Trac -#7688 for a discussion. - -Note that the goal is to generalise the *kind of the type*, not -the type itself! Example: - ghci> data SameKind :: k -> k -> Type - ghci> :k SameKind _ - -We want to get `k -> Type`, not `Any -> Type`, which is what we would -get without kind-generalisation. Note that `:k SameKind` is OK, as -GHC will not instantiate SameKind here, and so we see its full kind -of `forall k. k -> k -> Type`. - -************************************************************************ -* * - tcRnDeclsi -* * -************************************************************************ - -tcRnDeclsi exists to allow class, data, and other declarations in GHCi. --} - -tcRnDeclsi :: HscEnv - -> [LHsDecl GhcPs] - -> IO (Messages, Maybe TcGblEnv) -tcRnDeclsi hsc_env local_decls - = runTcInteractive hsc_env $ - tcRnSrcDecls False local_decls Nothing - -externaliseAndTidyId :: Module -> Id -> TcM Id -externaliseAndTidyId this_mod id - = do { name' <- externaliseName this_mod (idName id) - ; return $ globaliseId id - `setIdName` name' - `setIdType` tidyTopType (idType id) } - - -{- -************************************************************************ -* * - More GHCi stuff, to do with browsing and getting info -* * -************************************************************************ --} - --- | ASSUMES that the module is either in the 'HomePackageTable' or is --- a package module with an interface on disk. If neither of these is --- true, then the result will be an error indicating the interface --- could not be found. -getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface) -getModuleInterface hsc_env mod - = runTcInteractive hsc_env $ - loadModuleInterface (text "getModuleInterface") mod - -tcRnLookupRdrName :: HscEnv -> Located RdrName - -> IO (Messages, Maybe [Name]) --- ^ Find all the Names that this RdrName could mean, in GHCi -tcRnLookupRdrName hsc_env (L loc rdr_name) - = runTcInteractive hsc_env $ - setSrcSpan loc $ - do { -- If the identifier is a constructor (begins with an - -- upper-case letter), then we need to consider both - -- constructor and type class identifiers. - let rdr_names = dataTcOccs rdr_name - ; names_s <- mapM lookupInfoOccRn rdr_names - ; let names = concat names_s - ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) - ; return names } - -tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) -tcRnLookupName hsc_env name - = runTcInteractive hsc_env $ - tcRnLookupName' name - --- To look up a name we have to look in the local environment (tcl_lcl) --- as well as the global environment, which is what tcLookup does. --- But we also want a TyThing, so we have to convert: - -tcRnLookupName' :: Name -> TcRn TyThing -tcRnLookupName' name = do - tcthing <- tcLookup name - case tcthing of - AGlobal thing -> return thing - ATcId{tct_id=id} -> return (AnId id) - _ -> panic "tcRnLookupName'" - -tcRnGetInfo :: HscEnv - -> Name - -> IO ( Messages - , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) - --- Used to implement :info in GHCi --- --- Look up a RdrName and return all the TyThings it might be --- A capitalised RdrName is given to us in the DataName namespace, --- but we want to treat it as *both* a data constructor --- *and* as a type or class constructor; --- hence the call to dataTcOccs, and we return up to two results -tcRnGetInfo hsc_env name - = runTcInteractive hsc_env $ - do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) - -- Load the interface for all unqualified types and classes - -- That way we will find all the instance declarations - -- (Packages have not orphan modules, and we assume that - -- in the home package all relevant modules are loaded.) - - ; thing <- tcRnLookupName' name - ; fixity <- lookupFixityRn name - ; (cls_insts, fam_insts) <- lookupInsts thing - ; let info = lookupKnownNameInfo name - ; return (thing, fixity, cls_insts, fam_insts, info) } - - --- Lookup all class and family instances for a type constructor. --- --- This function filters all instances in the type environment, so there --- is a lot of duplicated work if it is called many times in the same --- type environment. If this becomes a problem, the NameEnv computed --- in GHC.getNameToInstancesIndex could be cached in TcM and both functions --- could be changed to consult that index. -lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) -lookupInsts (ATyCon tc) - = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs - ; (pkg_fie, home_fie) <- tcGetFamInstEnvs - -- Load all instances for all classes that are - -- in the type environment (which are all the ones - -- we've seen in any interface file so far) - - -- Return only the instances relevant to the given thing, i.e. - -- the instances whose head contains the thing's name. - ; let cls_insts = - [ ispec -- Search all - | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie - , instIsVisible vis_mods ispec - , tc_name `elemNameSet` orphNamesOfClsInst ispec ] - ; let fam_insts = - [ fispec - | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie - , tc_name `elemNameSet` orphNamesOfFamInst fispec ] - ; return (cls_insts, fam_insts) } - where - tc_name = tyConName tc - -lookupInsts _ = return ([],[]) - -loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () --- Load the interface for everything that is in scope unqualified --- This is so that we can accurately report the instances for --- something -loadUnqualIfaces hsc_env ictxt - = initIfaceTcRn $ do - mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) - where - this_pkg = thisPackage (hsc_dflags hsc_env) - - unqual_mods = [ nameModule name - | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) - , let name = gre_name gre - , nameIsFromExternalPackage this_pkg name - , isTcOcc (nameOccName name) -- Types and classes only - , unQualOK gre ] -- In scope unqualified - doc = text "Need interface for module whose export(s) are in scope unqualified" - - - -{- -************************************************************************ -* * - Debugging output - This is what happens when you do -ddump-types -* * -************************************************************************ --} - --- | Dump, with a banner, if -ddump-rn -rnDump :: (Outputable a, Data a) => a -> TcRn () -rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn) - -tcDump :: TcGblEnv -> TcRn () -tcDump env - = do { dflags <- getDynFlags ; - - -- Dump short output if -ddump-types or -ddump-tc - when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types) - "" FormatText short_dump) ; - - -- Dump bindings if -ddump-tc - dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump; - - -- Dump bindings as an hsSyn AST if -ddump-tc-ast - dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell ast_dump - } - where - short_dump = pprTcGblEnv env - full_dump = pprLHsBinds (tcg_binds env) - -- NB: foreign x-d's have undefined's in their types; - -- hence can't show the tc_fords - ast_dump = showAstData NoBlankSrcSpan (tcg_binds env) - --- It's unpleasant having both pprModGuts and pprModDetails here -pprTcGblEnv :: TcGblEnv -> SDoc -pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_rules = rules, - tcg_imports = imports }) - = getPprDebug $ \debug -> - vcat [ ppr_types debug type_env - , ppr_tycons debug fam_insts type_env - , ppr_datacons debug type_env - , ppr_patsyns type_env - , ppr_insts insts - , ppr_fam_insts fam_insts - , ppr_rules rules - , text "Dependent modules:" <+> - pprUFM (imp_dep_mods imports) (ppr . sort) - , text "Dependent packages:" <+> - ppr (S.toList $ imp_dep_pkgs imports)] - where -- The use of sort is just to reduce unnecessary - -- wobbling in testsuite output - -ppr_rules :: [LRuleDecl GhcTc] -> SDoc -ppr_rules rules - = ppUnless (null rules) $ - hang (text "RULES") - 2 (vcat (map ppr rules)) - -ppr_types :: Bool -> TypeEnv -> SDoc -ppr_types debug type_env - = ppr_things "TYPE SIGNATURES" ppr_sig - (sortBy (comparing getOccName) ids) - where - ids = [id | id <- typeEnvIds type_env, want_sig id] - want_sig id - | debug = True - | otherwise = hasTopUserName id - && case idDetails id of - VanillaId -> True - RecSelId {} -> True - ClassOpId {} -> True - FCallId {} -> True - _ -> False - -- Data cons (workers and wrappers), pattern synonyms, - -- etc are suppressed (unless -dppr-debug), - -- because they appear elsewhere - - ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id))) - -ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc -ppr_tycons debug fam_insts type_env - = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons - , ppr_things "COERCION AXIOMS" ppr_ax - (typeEnvCoAxioms type_env) ] - where - fi_tycons = famInstsRepTyCons fam_insts - - tycons = sortBy (comparing getOccName) $ - [tycon | tycon <- typeEnvTyCons type_env - , want_tycon tycon] - -- Sort by OccName to reduce unnecessary changes - want_tycon tycon | debug = True - | otherwise = isExternalName (tyConName tycon) && - not (tycon `elem` fi_tycons) - ppr_tc tc - = vcat [ hang (ppr (tyConFlavour tc) <+> ppr tc - <> braces (ppr (tyConArity tc)) <+> dcolon) - 2 (ppr (tidyTopType (tyConKind tc))) - , nest 2 $ - ppWhen show_roles $ - text "roles" <+> (sep (map ppr roles)) ] - where - show_roles = debug || not (all (== boring_role) roles) - roles = tyConRoles tc - boring_role | isClassTyCon tc = Nominal - | otherwise = Representational - -- Matches the choice in GHC.Iface.Syntax, calls to pprRoles - - ppr_ax ax = ppr (coAxiomToIfaceDecl ax) - -- We go via IfaceDecl rather than using pprCoAxiom - -- This way we get the full axiom (both LHS and RHS) with - -- wildcard binders tidied to _1, _2, etc. - -ppr_datacons :: Bool -> TypeEnv -> SDoc -ppr_datacons debug type_env - = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs - -- The filter gets rid of class data constructors - where - ppr_dc dc = ppr dc <+> dcolon <+> ppr (dataConUserType dc) - all_dcs = typeEnvDataCons type_env - wanted_dcs | debug = all_dcs - | otherwise = filterOut is_cls_dc all_dcs - is_cls_dc dc = isClassTyCon (dataConTyCon dc) - -ppr_patsyns :: TypeEnv -> SDoc -ppr_patsyns type_env - = ppr_things "PATTERN SYNONYMS" ppr_ps - (typeEnvPatSyns type_env) - where - ppr_ps ps = ppr ps <+> dcolon <+> pprPatSynType ps - -ppr_insts :: [ClsInst] -> SDoc -ppr_insts ispecs - = ppr_things "CLASS INSTANCES" pprInstance ispecs - -ppr_fam_insts :: [FamInst] -> SDoc -ppr_fam_insts fam_insts - = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts - -ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc -ppr_things herald ppr_one things - | null things = empty - | otherwise = text herald $$ nest 2 (vcat (map ppr_one things)) - -hasTopUserName :: NamedThing x => x -> Bool --- A top-level thing whose name is not "derived" --- Thus excluding things like $tcX, from Typeable boilerplate --- and C:Coll from class-dictionary data constructors -hasTopUserName x - = isExternalName name && not (isDerivedOccName (nameOccName name)) - where - name = getName x - -{- -******************************************************************************** - -Type Checker Plugins - -******************************************************************************** --} - -withTcPlugins :: HscEnv -> TcM a -> TcM a -withTcPlugins hsc_env m = - do let plugins = getTcPlugins (hsc_dflags hsc_env) - case plugins of - [] -> m -- Common fast case - _ -> do ev_binds_var <- newTcEvBinds - (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins - -- This ensures that tcPluginStop is called even if a type - -- error occurs during compilation (Fix of #10078) - eitherRes <- tryM $ do - updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m - mapM_ (flip runTcPluginM ev_binds_var) stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - startPlugin ev_binds_var (TcPlugin start solve stop) = - do s <- runTcPluginM start ev_binds_var - return (solve s, stop s) - -getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin] -getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args) - - -withHoleFitPlugins :: HscEnv -> TcM a -> TcM a -withHoleFitPlugins hsc_env m = - case (getHfPlugins (hsc_dflags hsc_env)) of - [] -> m -- Common fast case - plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins - -- This ensures that hfPluginStop is called even if a type - -- error occurs during compilation. - eitherRes <- tryM $ do - updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m - sequence_ stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - startPlugin (HoleFitPluginR init plugin stop) = - do ref <- init - return (plugin ref, stop ref) - -getHfPlugins :: DynFlags -> [HoleFitPluginR] -getHfPlugins dflags = - catMaybes $ mapPlugins dflags (\p args -> holeFitPlugin p args) - - -runRenamerPlugin :: TcGblEnv - -> HsGroup GhcRn - -> TcM (TcGblEnv, HsGroup GhcRn) -runRenamerPlugin gbl_env hs_group = do - dflags <- getDynFlags - withPlugins dflags - (\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g)) - (gbl_env, hs_group) - - --- XXX: should this really be a Maybe X? Check under which circumstances this --- can become a Nothing and decide whether this should instead throw an --- exception/signal an error. -type RenamedStuff = - (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe LHsDocString)) - --- | Extract the renamed information from TcGblEnv. -getRenamedStuff :: TcGblEnv -> RenamedStuff -getRenamedStuff tc_result - = fmap (\decls -> ( decls, tcg_rn_imports tc_result - , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) ) - (tcg_rn_decls tc_result) - -runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv -runTypecheckerPlugin sum hsc_env gbl_env = do - let dflags = hsc_dflags hsc_env - withPlugins dflags - (\p opts env -> mark_plugin_unsafe dflags - >> typeCheckResultAction p opts sum env) - gbl_env - -mark_plugin_unsafe :: DynFlags -> TcM () -mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ - recordUnsafeInfer pluginUnsafe - where - unsafeText = "Use of plugins makes the module unsafe" - pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan - (Outputable.text unsafeText) ) diff --git a/compiler/typecheck/TcRnDriver.hs-boot b/compiler/typecheck/TcRnDriver.hs-boot deleted file mode 100644 index a867236c74..0000000000 --- a/compiler/typecheck/TcRnDriver.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module TcRnDriver where - -import GhcPrelude -import GHC.Core.Type(TyThing) -import TcRnTypes (TcM) -import Outputable (SDoc) -import GHC.Types.Name (Name) - -checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) - -> TyThing -> TyThing -> TcM () -missingBootThing :: Bool -> Name -> String -> SDoc -badReexportedBootThing :: Bool -> Name -> Name -> SDoc diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs deleted file mode 100644 index c7c2950e94..0000000000 --- a/compiler/typecheck/TcRnExports.hs +++ /dev/null @@ -1,856 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module TcRnExports (tcRnExports, exports_from_avail) where - -import GhcPrelude - -import GHC.Hs -import PrelNames -import GHC.Types.Name.Reader -import TcRnMonad -import TcEnv -import TcType -import GHC.Rename.Names -import GHC.Rename.Env -import GHC.Rename.Unbound ( reportUnboundName ) -import ErrUtils -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Module -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Avail -import GHC.Core.TyCon -import GHC.Types.SrcLoc as SrcLoc -import GHC.Driver.Types -import Outputable -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.PatSyn -import Maybes -import GHC.Types.Unique.Set -import Util (capitalise) -import FastString (fsLit) - -import Control.Monad -import GHC.Driver.Session -import GHC.Rename.Doc ( rnHsDoc ) -import RdrHsSyn ( setRdrNameSpace ) -import Data.Either ( partitionEithers ) - -{- -************************************************************************ -* * -\subsection{Export list processing} -* * -************************************************************************ - -Processing the export list. - -You might think that we should record things that appear in the export -list as ``occurrences'' (using @addOccurrenceName@), but you'd be -wrong. We do check (here) that they are in scope, but there is no -need to slurp in their actual declaration (which is what -@addOccurrenceName@ forces). - -Indeed, doing so would big trouble when compiling @PrelBase@, because -it re-exports @GHC@, which includes @takeMVar#@, whose type includes -@ConcBase.StateAndSynchVar#@, and so on... - -Note [Exports of data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose you see (#5306) - module M where - import X( F ) - data instance F Int = FInt -What does M export? AvailTC F [FInt] - or AvailTC F [F,FInt]? -The former is strictly right because F isn't defined in this module. -But then you can never do an explicit import of M, thus - import M( F( FInt ) ) -because F isn't exported by M. Nor can you import FInt alone from here - import M( FInt ) -because we don't have syntax to support that. (It looks like an import of -the type FInt.) - -At one point I implemented a compromise: - * When constructing exports with no export list, or with module M( - module M ), we add the parent to the exports as well. - * But not when you see module M( f ), even if f is a - class method with a parent. - * Nor when you see module M( module N ), with N /= M. - -But the compromise seemed too much of a hack, so we backed it out. -You just have to use an explicit export list: - module M( F(..) ) where ... - -Note [Avails of associated data families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose you have (#16077) - - {-# LANGUAGE TypeFamilies #-} - module A (module A) where - - class C a where { data T a } - instance C () where { data T () = D } - -Because @A@ is exported explicitly, GHC tries to produce an export list -from the @GlobalRdrEnv@. In this case, it pulls out the following: - - [ C defined at A.hs:4:1 - , T parent:C defined at A.hs:4:23 - , D parent:T defined at A.hs:5:35 ] - -If map these directly into avails, (via 'availFromGRE'), we get -@[C{C;}, C{T;}, T{D;}]@, which eventually gets merged into @[C{C, T;}, T{D;}]@. -That's not right, because @T{D;}@ violates the AvailTC invariant: @T@ is -exported, but it isn't the first entry in the avail! - -We work around this issue by expanding GREs where the parent and child -are both type constructors into two GRES. - - T parent:C defined at A.hs:4:23 - - => - - [ T parent:C defined at A.hs:4:23 - , T defined at A.hs:4:23 ] - -Then, we get @[C{C;}, C{T;}, T{T;}, T{D;}]@, which eventually gets merged -into @[C{C, T;}, T{T, D;}]@ (which satsifies the AvailTC invariant). --} - -data ExportAccum -- The type of the accumulating parameter of - -- the main worker function in rnExports - = ExportAccum - ExportOccMap -- Tracks exported occurrence names - (UniqSet ModuleName) -- Tracks (re-)exported module names - -emptyExportAccum :: ExportAccum -emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet - -accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y))) - -> [x] - -> TcRn [y] -accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum - where f' acc x = do - m <- attemptM (f acc x) - pure $ case m of - Just (Just (acc', y)) -> (acc', Just y) - _ -> (acc, Nothing) - -type ExportOccMap = OccEnv (Name, IE GhcPs) - -- Tracks what a particular exported OccName - -- in an export list refers to, and which item - -- it came from. It's illegal to export two distinct things - -- that have the same occurrence name - -tcRnExports :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list - -> TcGblEnv - -> RnM TcGblEnv - - -- Complains if two distinct exports have same OccName - -- Warns about identical exports. - -- Complains about exports items not in scope - -tcRnExports explicit_mod exports - tcg_env@TcGblEnv { tcg_mod = this_mod, - tcg_rdr_env = rdr_env, - tcg_imports = imports, - tcg_src = hsc_src } - = unsetWOptM Opt_WarnWarningsDeprecations $ - -- Do not report deprecations arising from the export - -- list, to avoid bleating about re-exporting a deprecated - -- thing (especially via 'module Foo' export item) - do { - ; dflags <- getDynFlags - ; let is_main_mod = mainModIs dflags == this_mod - ; let default_main = case mainFunIs dflags of - Just main_fun - | is_main_mod -> mkUnqual varName (fsLit main_fun) - _ -> main_RDR_Unqual - ; has_main <- (not . null) <$> lookupInfoOccRn default_main -- #17832 - -- If a module has no explicit header, and it has one or more main - -- functions in scope, then add a header like - -- "module Main(main) where ..." #13839 - -- See Note [Modules without a module header] - ; let real_exports - | explicit_mod = exports - | has_main - = Just (noLoc [noLoc (IEVar noExtField - (noLoc (IEName $ noLoc default_main)))]) - -- ToDo: the 'noLoc' here is unhelpful if 'main' - -- turns out to be out of scope - | otherwise = Nothing - - ; let do_it = exports_from_avail real_exports rdr_env imports this_mod - ; (rn_exports, final_avails) - <- if hsc_src == HsigFile - then do (mb_r, msgs) <- tryTc do_it - case mb_r of - Just r -> return r - Nothing -> addMessages msgs >> failM - else checkNoErrs do_it - ; let final_ns = availsToNameSetWithSelectors final_avails - - ; traceRn "rnExports: Exports:" (ppr final_avails) - - ; let new_tcg_env = - tcg_env { tcg_exports = final_avails, - tcg_rn_exports = case tcg_rn_exports tcg_env of - Nothing -> Nothing - Just _ -> rn_exports, - tcg_dus = tcg_dus tcg_env `plusDU` - usesOnly final_ns } - ; failIfErrsM - ; return new_tcg_env } - -exports_from_avail :: Maybe (Located [LIE GhcPs]) - -- ^ 'Nothing' means no explicit export list - -> GlobalRdrEnv - -> ImportAvails - -- ^ Imported modules; this is used to test if a - -- @module Foo@ export is valid (it's not valid - -- if we didn't import @Foo@!) - -> Module - -> RnM (Maybe [(LIE GhcRn, Avails)], Avails) - -- (Nothing, _) <=> no explicit export list - -- if explicit export list is present it contains - -- each renamed export item together with its exported - -- names. - -exports_from_avail Nothing rdr_env _imports _this_mod - -- The same as (module M) where M is the current module name, - -- so that's how we handle it, except we also export the data family - -- when a data instance is exported. - = do { - ; warnMissingExportList <- woptM Opt_WarnMissingExportList - ; warnIfFlag Opt_WarnMissingExportList - warnMissingExportList - (missingModuleExportWarn $ moduleName _this_mod) - ; let avails = - map fix_faminst . gresToAvailInfo - . filter isLocalGRE . globalRdrEnvElts $ rdr_env - ; return (Nothing, avails) } - where - -- #11164: when we define a data instance - -- but not data family, re-export the family - -- Even though we don't check whether this is actually a data family - -- only data families can locally define subordinate things (`ns` here) - -- without locally defining (and instead importing) the parent (`n`) - fix_faminst (AvailTC n ns flds) = - let new_ns = - case ns of - [] -> [n] - (p:_) -> if p == n then ns else n:ns - in AvailTC n new_ns flds - - fix_faminst avail = avail - - -exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod - = do ie_avails <- accumExports do_litem rdr_items - let final_exports = nubAvails (concatMap snd ie_avails) -- Combine families - return (Just ie_avails, final_exports) - where - do_litem :: ExportAccum -> LIE GhcPs - -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) - do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) - - -- Maps a parent to its in-scope children - kids_env :: NameEnv [GlobalRdrElt] - kids_env = mkChildEnv (globalRdrEnvElts rdr_env) - - -- See Note [Avails of associated data families] - expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt] - expand_tyty_gre (gre@GRE { gre_name = me, gre_par = ParentIs p }) - | isTyConName p, isTyConName me = [gre, gre{ gre_par = NoParent }] - expand_tyty_gre gre = [gre] - - imported_modules = [ imv_name imv - | xs <- moduleEnvElts $ imp_mods imports - , imv <- importedByUser xs ] - - exports_from_item :: ExportAccum -> LIE GhcPs - -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) - exports_from_item (ExportAccum occs earlier_mods) - (L loc ie@(IEModuleContents _ lmod@(L _ mod))) - | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M - = do { warnIfFlag Opt_WarnDuplicateExports True - (dupModuleExport mod) ; - return Nothing } - - | otherwise - = do { let { exportValid = (mod `elem` imported_modules) - || (moduleName this_mod == mod) - ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) - ; new_exports = [ availFromGRE gre' - | (gre, _) <- gre_prs - , gre' <- expand_tyty_gre gre ] - ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs - ; mods = addOneToUniqSet earlier_mods mod - } - - ; checkErr exportValid (moduleNotImported mod) - ; warnIfFlag Opt_WarnDodgyExports - (exportValid && null gre_prs) - (nullModuleExport mod) - - ; traceRn "efa" (ppr mod $$ ppr all_gres) - ; addUsedGREs all_gres - - ; occs' <- check_occs ie occs new_exports - -- This check_occs not only finds conflicts - -- between this item and others, but also - -- internally within this item. That is, if - -- 'M.x' is in scope in several ways, we'll have - -- several members of mod_avails with the same - -- OccName. - ; traceRn "export_mod" - (vcat [ ppr mod - , ppr new_exports ]) - - ; return (Just ( ExportAccum occs' mods - , ( L loc (IEModuleContents noExtField lmod) - , new_exports))) } - - exports_from_item acc@(ExportAccum occs mods) (L loc ie) - | isDoc ie - = do new_ie <- lookup_doc_ie ie - return (Just (acc, (L loc new_ie, []))) - - | otherwise - = do (new_ie, avail) <- lookup_ie ie - if isUnboundName (ieName new_ie) - then return Nothing -- Avoid error cascade - else do - - occs' <- check_occs ie occs [avail] - - return (Just ( ExportAccum occs' mods - , (L loc new_ie, [avail]))) - - ------------- - lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) - lookup_ie (IEVar _ (L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEVar noExtField (L l (replaceWrappedName rdr name)), avail) - - lookup_ie (IEThingAbs _ (L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs noExtField (L l (replaceWrappedName rdr name)) - , avail) - - lookup_ie ie@(IEThingAll _ n') - = do - (n, avail, flds) <- lookup_ie_all ie n' - let name = unLoc n - return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n)) - , AvailTC name (name:avail) flds) - - - lookup_ie ie@(IEThingWith _ l wc sub_rdrs _) - = do - (lname, subs, avails, flds) - <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs - (_, all_avail, all_flds) <- - case wc of - NoIEWildcard -> return (lname, [], []) - IEWildcard _ -> lookup_ie_all ie l - let name = unLoc lname - return (IEThingWith noExtField (replaceLWrappedName l name) wc subs - (flds ++ (map noLoc all_flds)), - AvailTC name (name : avails ++ all_avail) - (map unLoc flds ++ all_flds)) - - - lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier - - - lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName] - -> RnM (Located Name, [LIEWrappedName Name], [Name], - [Located FieldLabel]) - lookup_ie_with (L l rdr) sub_rdrs - = do name <- lookupGlobalOccRn $ ieWrappedName rdr - (non_flds, flds) <- lookupChildrenExport name sub_rdrs - if isUnboundName name - then return (L l name, [], [name], []) - else return (L l name, non_flds - , map (ieWrappedName . unLoc) non_flds - , flds) - - lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName - -> RnM (Located Name, [Name], [FieldLabel]) - lookup_ie_all ie (L l rdr) = - do name <- lookupGlobalOccRn $ ieWrappedName rdr - let gres = findChildren kids_env name - (non_flds, flds) = classifyGREs gres - addUsedKids (ieWrappedName rdr) gres - warnDodgyExports <- woptM Opt_WarnDodgyExports - when (null gres) $ - if isTyConName name - then when warnDodgyExports $ - addWarn (Reason Opt_WarnDodgyExports) - (dodgyExportWarn name) - else -- This occurs when you export T(..), but - -- only import T abstractly, or T is a synonym. - addErr (exportItemErr ie) - return (L l name, non_flds, flds) - - ------------- - lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn) - lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc - return (IEGroup noExtField lev rn_doc) - lookup_doc_ie (IEDoc _ doc) = do rn_doc <- rnHsDoc doc - return (IEDoc noExtField rn_doc) - lookup_doc_ie (IEDocNamed _ str) = return (IEDocNamed noExtField str) - lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier - - -- In an export item M.T(A,B,C), we want to treat the uses of - -- A,B,C as if they were M.A, M.B, M.C - -- Happily pickGREs does just the right thing - addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM () - addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres) - -classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel]) -classifyGREs = partitionEithers . map classifyGRE - -classifyGRE :: GlobalRdrElt -> Either Name FieldLabel -classifyGRE gre = case gre_par gre of - FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n) - FldParent _ (Just lbl) -> Right (FieldLabel lbl True n) - _ -> Left n - where - n = gre_name gre - -isDoc :: IE GhcPs -> Bool -isDoc (IEDoc {}) = True -isDoc (IEDocNamed {}) = True -isDoc (IEGroup {}) = True -isDoc _ = False - --- Renaming and typechecking of exports happens after everything else has --- been typechecked. - -{- -Note [Modules without a module header] --------------------------------------------------- - -The Haskell 2010 report says in section 5.1: - ->> An abbreviated form of module, consisting only of the module body, is ->> permitted. If this is used, the header is assumed to be ->> ‘module Main(main) where’. - -For modules without a module header, this is implemented the -following way: - -If the module has a main function in scope: - Then create a module header and export the main function, - as if a module header like ‘module Main(main) where...’ would exist. - This has the effect to mark the main function and all top level - functions called directly or indirectly via main as 'used', - and later on, unused top-level functions can be reported correctly. - There is no distinction between GHC and GHCi. -If the module has several main functions in scope: - Then generate a header as above. The ambiguity is reported later in - module `TcRnDriver.hs` function `check_main`. -If the module has NO main function: - Then export all top-level functions. This marks all top level - functions as 'used'. - In GHCi this has the effect, that we don't get any 'non-used' warnings. - In GHC, however, the 'has-main-module' check in the module - compiler/typecheck/TcRnDriver (functions checkMain / check-main) fires, - and we get the error: - The IO action ‘main’ is not defined in module ‘Main’ --} - - --- Renaming exports lists is a minefield. Five different things can appear in --- children export lists ( T(A, B, C) ). --- 1. Record selectors --- 2. Type constructors --- 3. Data constructors --- 4. Pattern Synonyms --- 5. Pattern Synonym Selectors --- --- However, things get put into weird name spaces. --- 1. Some type constructors are parsed as variables (-.->) for example. --- 2. All data constructors are parsed as type constructors --- 3. When there is ambiguity, we default type constructors to data --- constructors and require the explicit `type` keyword for type --- constructors. --- --- This function first establishes the possible namespaces that an --- identifier might be in (`choosePossibleNameSpaces`). --- --- Then for each namespace in turn, tries to find the correct identifier --- there returning the first positive result or the first terminating --- error. --- - - - -lookupChildrenExport :: Name -> [LIEWrappedName RdrName] - -> RnM ([LIEWrappedName Name], [Located FieldLabel]) -lookupChildrenExport spec_parent rdr_items = - do - xs <- mapAndReportM doOne rdr_items - return $ partitionEithers xs - where - -- Pick out the possible namespaces in order of priority - -- This is a consequence of how the parser parses all - -- data constructors as type constructors. - choosePossibleNamespaces :: NameSpace -> [NameSpace] - choosePossibleNamespaces ns - | ns == varName = [varName, tcName] - | ns == tcName = [dataName, tcName] - | otherwise = [ns] - -- Process an individual child - doOne :: LIEWrappedName RdrName - -> RnM (Either (LIEWrappedName Name) (Located FieldLabel)) - doOne n = do - - let bareName = (ieWrappedName . unLoc) n - lkup v = lookupSubBndrOcc_helper False True - spec_parent (setRdrNameSpace bareName v) - - name <- combineChildLookupResult $ map lkup $ - choosePossibleNamespaces (rdrNameSpace bareName) - traceRn "lookupChildrenExport" (ppr name) - -- Default to data constructors for slightly better error - -- messages - let unboundName :: RdrName - unboundName = if rdrNameSpace bareName == varName - then bareName - else setRdrNameSpace bareName dataName - - case name of - NameNotFound -> do { ub <- reportUnboundName unboundName - ; let l = getLoc n - ; return (Left (L l (IEName (L l ub))))} - FoundFL fls -> return $ Right (L (getLoc n) fls) - FoundName par name -> do { checkPatSynParent spec_parent par name - ; return - $ Left (replaceLWrappedName n name) } - IncorrectParent p g td gs -> failWithDcErr p g td gs - - --- Note: [Typing Pattern Synonym Exports] --- It proved quite a challenge to precisely specify which pattern synonyms --- should be allowed to be bundled with which type constructors. --- In the end it was decided to be quite liberal in what we allow. Below is --- how Simon described the implementation. --- --- "Personally I think we should Keep It Simple. All this talk of --- satisfiability makes me shiver. I suggest this: allow T( P ) in all --- situations except where `P`'s type is ''visibly incompatible'' with --- `T`. --- --- What does "visibly incompatible" mean? `P` is visibly incompatible --- with --- `T` if --- * `P`'s type is of form `... -> S t1 t2` --- * `S` is a data/newtype constructor distinct from `T` --- --- Nothing harmful happens if we allow `P` to be exported with --- a type it can't possibly be useful for, but specifying a tighter --- relationship is very awkward as you have discovered." --- --- Note that this allows *any* pattern synonym to be bundled with any --- datatype type constructor. For example, the following pattern `P` can be --- bundled with any type. --- --- ``` --- pattern P :: (A ~ f) => f --- ``` --- --- So we provide basic type checking in order to help the user out, most --- pattern synonyms are defined with definite type constructors, but don't --- actually prevent a library author completely confusing their users if --- they want to. --- --- So, we check for exactly four things --- 1. The name arises from a pattern synonym definition. (Either a pattern --- synonym constructor or a pattern synonym selector) --- 2. The pattern synonym is only bundled with a datatype or newtype. --- 3. Check that the head of the result type constructor is an actual type --- constructor and not a type variable. (See above example) --- 4. Is so, check that this type constructor is the same as the parent --- type constructor. --- --- --- Note: [Types of TyCon] --- --- This check appears to be overlly complicated, Richard asked why it --- is not simply just `isAlgTyCon`. The answer for this is that --- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow. --- (It is either a newtype or data depending on the number of methods) --- - --- | Given a resolved name in the children export list and a parent. Decide --- whether we are allowed to export the child with the parent. --- Invariant: gre_par == NoParent --- See note [Typing Pattern Synonym Exports] -checkPatSynParent :: Name -- ^ Alleged parent type constructor - -- User wrote T( P, Q ) - -> Parent -- The parent of P we discovered - -> Name -- ^ Either a - -- a) Pattern Synonym Constructor - -- b) A pattern synonym selector - -> TcM () -- Fails if wrong parent -checkPatSynParent _ (ParentIs {}) _ - = return () - -checkPatSynParent _ (FldParent {}) _ - = return () - -checkPatSynParent parent NoParent mpat_syn - | isUnboundName parent -- Avoid an error cascade - = return () - - | otherwise - = do { parent_ty_con <- tcLookupTyCon parent - ; mpat_syn_thing <- tcLookupGlobal mpat_syn - - -- 1. Check that the Id was actually from a thing associated with patsyns - ; case mpat_syn_thing of - AnId i | isId i - , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i - -> handle_pat_syn (selErr i) parent_ty_con p - - AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p - - _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] } - where - psErr = exportErrCtxt "pattern synonym" - selErr = exportErrCtxt "pattern synonym record selector" - - assocClassErr :: SDoc - assocClassErr = text "Pattern synonyms can be bundled only with datatypes." - - handle_pat_syn :: SDoc - -> TyCon -- ^ Parent TyCon - -> PatSyn -- ^ Corresponding bundled PatSyn - -- and pretty printed origin - -> TcM () - handle_pat_syn doc ty_con pat_syn - - -- 2. See note [Types of TyCon] - | not $ isTyConWithSrcDataCons ty_con - = addErrCtxt doc $ failWithTc assocClassErr - - -- 3. Is the head a type variable? - | Nothing <- mtycon - = return () - -- 4. Ok. Check they are actually the same type constructor. - - | Just p_ty_con <- mtycon, p_ty_con /= ty_con - = addErrCtxt doc $ failWithTc typeMismatchError - - -- 5. We passed! - | otherwise - = return () - - where - expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con)) - (_, _, _, _, _, res_ty) = patSynSig pat_syn - mtycon = fst <$> tcSplitTyConApp_maybe res_ty - typeMismatchError :: SDoc - typeMismatchError = - text "Pattern synonyms can only be bundled with matching type constructors" - $$ text "Couldn't match expected type of" - <+> quotes (ppr expected_res_ty) - <+> text "with actual type of" - <+> quotes (ppr res_ty) - - -{-===========================================================================-} -check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo] - -> RnM ExportOccMap -check_occs ie occs avails - -- 'names' and 'fls' are the entities specified by 'ie' - = foldlM check occs names_with_occs - where - -- Each Name specified by 'ie', paired with the OccName used to - -- refer to it in the GlobalRdrEnv - -- (see Note [Representing fields in AvailInfo] in GHC.Types.Avail). - -- - -- We check for export clashes using the selector Name, but need - -- the field label OccName for presenting error messages. - names_with_occs = availsNamesWithOccs avails - - check occs (name, occ) - = case lookupOccEnv occs name_occ of - Nothing -> return (extendOccEnv occs name_occ (name, ie)) - - Just (name', ie') - | name == name' -- Duplicate export - -- But we don't want to warn if the same thing is exported - -- by two different module exports. See ticket #4478. - -> do { warnIfFlag Opt_WarnDuplicateExports - (not (dupExport_ok name ie ie')) - (dupExportWarn occ ie ie') - ; return occs } - - | otherwise -- Same occ name but different names: an error - -> do { global_env <- getGlobalRdrEnv ; - addErr (exportClashErr global_env occ name' name ie' ie) ; - return occs } - where - name_occ = nameOccName name - - -dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool --- The Name is exported by both IEs. Is that ok? --- "No" iff the name is mentioned explicitly in both IEs --- or one of the IEs mentions the name *alone* --- "Yes" otherwise --- --- Examples of "no": module M( f, f ) --- module M( fmap, Functor(..) ) --- module M( module Data.List, head ) --- --- Example of "yes" --- module M( module A, module B ) where --- import A( f ) --- import B( f ) --- --- Example of "yes" (#2436) --- module M( C(..), T(..) ) where --- class C a where { data T a } --- instance C Int where { data T Int = TInt } --- --- Example of "yes" (#2436) --- module Foo ( T ) where --- data family T a --- module Bar ( T(..), module Foo ) where --- import Foo --- data instance T Int = TInt - -dupExport_ok n ie1 ie2 - = not ( single ie1 || single ie2 - || (explicit_in ie1 && explicit_in ie2) ) - where - explicit_in (IEModuleContents {}) = False -- module M - explicit_in (IEThingAll _ r) - = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..) - explicit_in _ = True - - single IEVar {} = True - single IEThingAbs {} = True - single _ = False - - -dupModuleExport :: ModuleName -> SDoc -dupModuleExport mod - = hsep [text "Duplicate", - quotes (text "Module" <+> ppr mod), - text "in export list"] - -moduleNotImported :: ModuleName -> SDoc -moduleNotImported mod - = hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "is not imported"] - -nullModuleExport :: ModuleName -> SDoc -nullModuleExport mod - = hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "exports nothing"] - -missingModuleExportWarn :: ModuleName -> SDoc -missingModuleExportWarn mod - = hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "is missing an export list"] - - -dodgyExportWarn :: Name -> SDoc -dodgyExportWarn item - = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn) - -exportErrCtxt :: Outputable o => String -> o -> SDoc -exportErrCtxt herald exp = - text "In the" <+> text (herald ++ ":") <+> ppr exp - - -addExportErrCtxt :: (OutputableBndrId p) - => IE (GhcPass p) -> TcM a -> TcM a -addExportErrCtxt ie = addErrCtxt exportCtxt - where - exportCtxt = text "In the export:" <+> ppr ie - -exportItemErr :: IE GhcPs -> SDoc -exportItemErr export_item - = sep [ text "The export item" <+> quotes (ppr export_item), - text "attempts to export constructors or class methods that are not visible here" ] - - -dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc -dupExportWarn occ_name ie1 ie2 - = hsep [quotes (ppr occ_name), - text "is exported by", quotes (ppr ie1), - text "and", quotes (ppr ie2)] - -dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc -dcErrMsg ty_con what_is thing parents = - text "The type constructor" <+> quotes (ppr ty_con) - <+> text "is not the parent of the" <+> text what_is - <+> quotes thing <> char '.' - $$ text (capitalise what_is) - <> text "s can only be exported with their parent type constructor." - $$ (case parents of - [] -> empty - [_] -> text "Parent:" - _ -> text "Parents:") <+> fsep (punctuate comma parents) - -failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a -failWithDcErr parent thing thing_doc parents = do - ty_thing <- tcLookupGlobal thing - failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing) - thing_doc (map ppr parents) - where - tyThingCategory' :: TyThing -> String - tyThingCategory' (AnId i) - | isRecordSelector i = "record selector" - tyThingCategory' i = tyThingCategory i - - -exportClashErr :: GlobalRdrEnv -> OccName - -> Name -> Name - -> IE GhcPs -> IE GhcPs - -> MsgDoc -exportClashErr global_env occ name1 name2 ie1 ie2 - = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon - , ppr_export ie1' name1' - , ppr_export ie2' name2' ] - where - ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> - quotes (ppr_name name)) - 2 (pprNameProvenance (get_gre name))) - - -- DuplicateRecordFields means that nameOccName might be a mangled - -- $sel-prefixed thing, in which case show the correct OccName alone - ppr_name name - | nameOccName name == occ = ppr name - | otherwise = ppr occ - - -- get_gre finds a GRE for the Name, so that we can show its provenance - get_gre name - = fromMaybe (pprPanic "exportClashErr" (ppr name)) - (lookupGRE_Name_OccName global_env name occ) - get_loc name = greSrcSpan (get_gre name) - (name1', ie1', name2', ie2') = - case SrcLoc.leftmost_smallest (get_loc name1) (get_loc name2) of - LT -> (name1, ie1, name2, ie2) - GT -> (name2, ie2, name1, ie1) - EQ -> panic "exportClashErr: clashing exports have idential location" diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs deleted file mode 100644 index 2145b88de9..0000000000 --- a/compiler/typecheck/TcRnMonad.hs +++ /dev/null @@ -1,1998 +0,0 @@ -{- -(c) The University of Glasgow 2006 - - -Functions for working with the typechecker environment (setters, getters...). --} - -{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# LANGUAGE ViewPatterns #-} - - -module TcRnMonad( - -- * Initialisation - initTc, initTcWithGbl, initTcInteractive, initTcRnIf, - - -- * Simple accessors - discardResult, - getTopEnv, updTopEnv, getGblEnv, updGblEnv, - setGblEnv, getLclEnv, updLclEnv, setLclEnv, - getEnvs, setEnvs, - xoptM, doptM, goptM, woptM, - setXOptM, unsetXOptM, unsetGOptM, unsetWOptM, - whenDOptM, whenGOptM, whenWOptM, - whenXOptM, unlessXOptM, - getGhcMode, - withDoDynamicToo, - getEpsVar, - getEps, - updateEps, updateEps_, - getHpt, getEpsAndHpt, - - -- * Arrow scopes - newArrowScope, escapeArrowScope, - - -- * Unique supply - newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName, - newSysName, newSysLocalId, newSysLocalIds, - - -- * Accessing input/output - newTcRef, readTcRef, writeTcRef, updTcRef, - - -- * Debugging - traceTc, traceRn, traceOptTcRn, dumpOptTcRn, - dumpTcRn, - getPrintUnqualified, - printForUserTcRn, - traceIf, traceHiDiffs, traceOptIf, - debugTc, - - -- * Typechecker global environment - getIsGHCi, getGHCiMonad, getInteractivePrintName, - tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, - getRdrEnvs, getImports, - getFixityEnv, extendFixityEnv, getRecFieldEnv, - getDeclaredDefaultTys, - addDependentFiles, - - -- * Error management - getSrcSpanM, setSrcSpan, addLocM, - wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_, - getErrsVar, setErrsVar, - addErr, - failWith, failAt, - addErrAt, addErrs, - checkErr, - addMessages, - discardWarnings, - - -- * Shared error message stuff: renamer and typechecker - mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError, - reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, - attemptM, tryTc, - askNoErrs, discardErrs, tryTcDiscardingErrs, - checkNoErrs, whenNoErrs, - ifErrsM, failIfErrsM, - - -- * Context management for the type checker - getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, - addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM, - - -- * Error message generation (type checker) - addErrTc, addErrsTc, - addErrTcM, mkErrTcM, mkErrTc, - failWithTc, failWithTcM, - checkTc, checkTcM, - failIfTc, failIfTcM, - warnIfFlag, warnIf, warnTc, warnTcM, - addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn, - mkErrInfo, - - -- * Type constraints - newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, - addTcEvBind, addTopEvBinds, - getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, - chooseUniqueOccTc, - getConstraintVar, setConstraintVar, - emitConstraints, emitStaticConstraints, emitSimple, emitSimples, - emitImplication, emitImplications, emitInsoluble, - discardConstraints, captureConstraints, tryCaptureConstraints, - pushLevelAndCaptureConstraints, - pushTcLevelM_, pushTcLevelM, pushTcLevelsM, - getTcLevel, setTcLevel, isTouchableTcM, - getLclTypeEnv, setLclTypeEnv, - traceTcConstraints, - emitNamedWildCardHoleConstraints, emitAnonWildCardHoleConstraint, - - -- * Template Haskell context - recordThUse, recordThSpliceUse, - keepAlive, getStage, getStageAndBindLevel, setStage, - addModFinalizersWithLclEnv, - - -- * Safe Haskell context - recordUnsafeInfer, finalSafeMode, fixSafeInstances, - - -- * Stuff for the renamer's local env - getLocalRdrEnv, setLocalRdrEnv, - - -- * Stuff for interface decls - mkIfLclEnv, - initIfaceTcRn, - initIfaceCheck, - initIfaceLcl, - initIfaceLclWithSubst, - initIfaceLoad, - getIfModule, - failIfM, - forkM_maybe, - forkM, - setImplicitEnvM, - - withException, - - -- * Stuff for cost centres. - ContainsCostCentreState(..), getCCIndexM, - - -- * Types etc. - module TcRnTypes, - module IOEnv - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnTypes -- Re-export all -import IOEnv -- Re-export all -import Constraint -import TcEvidence -import TcOrigin - -import GHC.Hs hiding (LIE) -import GHC.Driver.Types -import GHC.Types.Module -import GHC.Types.Name.Reader -import GHC.Types.Name -import GHC.Core.Type - -import TcType -import GHC.Core.InstEnv -import GHC.Core.FamInstEnv -import PrelNames - -import GHC.Types.Id -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import ErrUtils -import GHC.Types.SrcLoc -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import Bag -import Outputable -import GHC.Types.Unique.Supply -import GHC.Driver.Session -import FastString -import Panic -import Util -import GHC.Types.Annotations -import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) ) -import Maybes -import GHC.Types.CostCentre.State - -import qualified GHC.LanguageExtensions as LangExt - -import Data.IORef -import Control.Monad - -import {-# SOURCE #-} TcEnv ( tcInitTidyEnv ) - -import qualified Data.Map as Map - -{- -************************************************************************ -* * - initTc -* * -************************************************************************ --} - --- | Setup the initial typechecking environment -initTc :: HscEnv - -> HscSource - -> Bool -- True <=> retain renamed syntax trees - -> Module - -> RealSrcSpan - -> TcM r - -> IO (Messages, Maybe r) - -- Nothing => error thrown by the thing inside - -- (error messages should have been printed already) - -initTc hsc_env hsc_src keep_rn_syntax mod loc do_this - = do { keep_var <- newIORef emptyNameSet ; - used_gre_var <- newIORef [] ; - th_var <- newIORef False ; - th_splice_var<- newIORef False ; - infer_var <- newIORef (True, emptyBag) ; - dfun_n_var <- newIORef emptyOccSet ; - type_env_var <- case hsc_type_env_var hsc_env of { - Just (_mod, te_var) -> return te_var ; - Nothing -> newIORef emptyNameEnv } ; - - dependent_files_var <- newIORef [] ; - static_wc_var <- newIORef emptyWC ; - cc_st_var <- newIORef newCostCentreState ; - th_topdecls_var <- newIORef [] ; - th_foreign_files_var <- newIORef [] ; - th_topnames_var <- newIORef emptyNameSet ; - th_modfinalizers_var <- newIORef [] ; - th_coreplugins_var <- newIORef [] ; - th_state_var <- newIORef Map.empty ; - th_remote_state_var <- newIORef Nothing ; - let { - dflags = hsc_dflags hsc_env ; - - maybe_rn_syntax :: forall a. a -> Maybe a ; - maybe_rn_syntax empty_val - | dopt Opt_D_dump_rn_ast dflags = Just empty_val - - | gopt Opt_WriteHie dflags = Just empty_val - - -- We want to serialize the documentation in the .hi-files, - -- and need to extract it from the renamed syntax first. - -- See 'GHC.HsToCore.Docs.extractDocs'. - | gopt Opt_Haddock dflags = Just empty_val - - | keep_rn_syntax = Just empty_val - | otherwise = Nothing ; - - gbl_env = TcGblEnv { - tcg_th_topdecls = th_topdecls_var, - tcg_th_foreign_files = th_foreign_files_var, - tcg_th_topnames = th_topnames_var, - tcg_th_modfinalizers = th_modfinalizers_var, - tcg_th_coreplugins = th_coreplugins_var, - tcg_th_state = th_state_var, - tcg_th_remote_state = th_remote_state_var, - - tcg_mod = mod, - tcg_semantic_mod = - canonicalizeModuleIfHome dflags mod, - tcg_src = hsc_src, - tcg_rdr_env = emptyGlobalRdrEnv, - tcg_fix_env = emptyNameEnv, - tcg_field_env = emptyNameEnv, - tcg_default = if moduleUnitId mod == primUnitId - then Just [] -- See Note [Default types] - else Nothing, - tcg_type_env = emptyNameEnv, - tcg_type_env_var = type_env_var, - tcg_inst_env = emptyInstEnv, - tcg_fam_inst_env = emptyFamInstEnv, - tcg_ann_env = emptyAnnEnv, - tcg_th_used = th_var, - tcg_th_splice_used = th_splice_var, - tcg_exports = [], - tcg_imports = emptyImportAvails, - tcg_used_gres = used_gre_var, - tcg_dus = emptyDUs, - - tcg_rn_imports = [], - tcg_rn_exports = - if hsc_src == HsigFile - -- Always retain renamed syntax, so that we can give - -- better errors. (TODO: how?) - then Just [] - else maybe_rn_syntax [], - tcg_rn_decls = maybe_rn_syntax emptyRnGroup, - tcg_tr_module = Nothing, - tcg_binds = emptyLHsBinds, - tcg_imp_specs = [], - tcg_sigs = emptyNameSet, - tcg_ev_binds = emptyBag, - tcg_warns = NoWarnings, - tcg_anns = [], - tcg_tcs = [], - tcg_insts = [], - tcg_fam_insts = [], - tcg_rules = [], - tcg_fords = [], - tcg_patsyns = [], - tcg_merged = [], - tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var, - tcg_doc_hdr = Nothing, - tcg_hpc = False, - tcg_main = Nothing, - tcg_self_boot = NoSelfBoot, - tcg_safeInfer = infer_var, - tcg_dependent_files = dependent_files_var, - tcg_tc_plugins = [], - tcg_hf_plugins = [], - tcg_top_loc = loc, - tcg_static_wc = static_wc_var, - tcg_complete_matches = [], - tcg_cc_st = cc_st_var - } ; - } ; - - -- OK, here's the business end! - initTcWithGbl hsc_env gbl_env loc do_this - } - --- | Run a 'TcM' action in the context of an existing 'GblEnv'. -initTcWithGbl :: HscEnv - -> TcGblEnv - -> RealSrcSpan - -> TcM r - -> IO (Messages, Maybe r) -initTcWithGbl hsc_env gbl_env loc do_this - = do { lie_var <- newIORef emptyWC - ; errs_var <- newIORef (emptyBag, emptyBag) - ; let lcl_env = TcLclEnv { - tcl_errs = errs_var, - tcl_loc = loc, -- Should be over-ridden very soon! - tcl_ctxt = [], - tcl_rdr = emptyLocalRdrEnv, - tcl_th_ctxt = topStage, - tcl_th_bndrs = emptyNameEnv, - tcl_arrow_ctxt = NoArrowCtxt, - tcl_env = emptyNameEnv, - tcl_bndrs = [], - tcl_lie = lie_var, - tcl_tclvl = topTcLevel - } - - ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ - do { r <- tryM do_this - ; case r of - Right res -> return (Just res) - Left _ -> return Nothing } - - -- Check for unsolved constraints - -- If we succeed (maybe_res = Just r), there should be - -- no unsolved constraints. But if we exit via an - -- exception (maybe_res = Nothing), we may have skipped - -- solving, so don't panic then (#13466) - ; lie <- readIORef (tcl_lie lcl_env) - ; when (isJust maybe_res && not (isEmptyWC lie)) $ - pprPanic "initTc: unsolved constraints" (ppr lie) - - -- Collect any error messages - ; msgs <- readIORef (tcl_errs lcl_env) - - ; let { final_res | errorsFound dflags msgs = Nothing - | otherwise = maybe_res } - - ; return (msgs, final_res) - } - where dflags = hsc_dflags hsc_env - -initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a) --- Initialise the type checker monad for use in GHCi -initTcInteractive hsc_env thing_inside - = initTc hsc_env HsSrcFile False - (icInteractiveModule (hsc_IC hsc_env)) - (realSrcLocSpan interactive_src_loc) - thing_inside - where - interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1 - -{- Note [Default types] -~~~~~~~~~~~~~~~~~~~~~~~ -The Integer type is simply not available in package ghc-prim (it is -declared in integer-gmp). So we set the defaulting types to (Just -[]), meaning there are no default types, rather then Nothing, which -means "use the default default types of Integer, Double". - -If you don't do this, attempted defaulting in package ghc-prim causes -an actual crash (attempting to look up the Integer type). - - -************************************************************************ -* * - Initialisation -* * -************************************************************************ --} - -initTcRnIf :: Char -- ^ Mask for unique supply - -> HscEnv - -> gbl -> lcl - -> TcRnIf gbl lcl a - -> IO a -initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside - = do { let { env = Env { env_top = hsc_env, - env_um = uniq_mask, - env_gbl = gbl_env, - env_lcl = lcl_env} } - - ; runIOEnv env thing_inside - } - -{- -************************************************************************ -* * - Simple accessors -* * -************************************************************************ --} - -discardResult :: TcM a -> TcM () -discardResult a = a >> return () - -getTopEnv :: TcRnIf gbl lcl HscEnv -getTopEnv = do { env <- getEnv; return (env_top env) } - -updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -updTopEnv upd = updEnv (\ env@(Env { env_top = top }) -> - env { env_top = upd top }) - -getGblEnv :: TcRnIf gbl lcl gbl -getGblEnv = do { Env{..} <- getEnv; return env_gbl } - -updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> - env { env_gbl = upd gbl }) - -setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env }) - -getLclEnv :: TcRnIf gbl lcl lcl -getLclEnv = do { Env{..} <- getEnv; return env_lcl } - -updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> - env { env_lcl = upd lcl }) - -setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a -setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) - -getEnvs :: TcRnIf gbl lcl (gbl, lcl) -getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } - -setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a -setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) - --- Command-line flags - -xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool -xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } - -doptM :: DumpFlag -> TcRnIf gbl lcl Bool -doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) } - -goptM :: GeneralFlag -> TcRnIf gbl lcl Bool -goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) } - -woptM :: WarningFlag -> TcRnIf gbl lcl Bool -woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) } - -setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setXOptM flag = - updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag}) - -unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetXOptM flag = - updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag}) - -unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetGOptM flag = - updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag}) - -unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetWOptM flag = - updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag}) - --- | Do it flag is true -whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenDOptM flag thing_inside = do b <- doptM flag - when b thing_inside - -whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenGOptM flag thing_inside = do b <- goptM flag - when b thing_inside - -whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenWOptM flag thing_inside = do b <- woptM flag - when b thing_inside - -whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -whenXOptM flag thing_inside = do b <- xoptM flag - when b thing_inside - -unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -unlessXOptM flag thing_inside = do b <- xoptM flag - unless b thing_inside - -getGhcMode :: TcRnIf gbl lcl GhcMode -getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } - -withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a -withDoDynamicToo = - updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) -> - top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags }) - -getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) -getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } - -getEps :: TcRnIf gbl lcl ExternalPackageState -getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } - --- | Update the external package state. Returns the second result of the --- modifier function. --- --- This is an atomic operation and forces evaluation of the modified EPS in --- order to avoid space leaks. -updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) - -> TcRnIf gbl lcl a -updateEps upd_fn = do - traceIf (text "updating EPS") - eps_var <- getEpsVar - atomicUpdMutVar' eps_var upd_fn - --- | Update the external package state. --- --- This is an atomic operation and forces evaluation of the modified EPS in --- order to avoid space leaks. -updateEps_ :: (ExternalPackageState -> ExternalPackageState) - -> TcRnIf gbl lcl () -updateEps_ upd_fn = do - traceIf (text "updating EPS_") - eps_var <- getEpsVar - atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ())) - -getHpt :: TcRnIf gbl lcl HomePackageTable -getHpt = do { env <- getTopEnv; return (hsc_HPT env) } - -getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) -getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) - ; return (eps, hsc_HPT env) } - --- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing --- an exception if it is an error. -withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a -withException do_this = do - r <- do_this - dflags <- getDynFlags - case r of - Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - Succeeded result -> return result - -{- -************************************************************************ -* * - Arrow scopes -* * -************************************************************************ --} - -newArrowScope :: TcM a -> TcM a -newArrowScope - = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) } - --- Return to the stored environment (from the enclosing proc) -escapeArrowScope :: TcM a -> TcM a -escapeArrowScope - = updLclEnv $ \ env -> - case tcl_arrow_ctxt env of - NoArrowCtxt -> env - ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt - , tcl_lie = lie - , tcl_rdr = rdr_env } - -{- -************************************************************************ -* * - Unique supply -* * -************************************************************************ --} - -newUnique :: TcRnIf gbl lcl Unique -newUnique - = do { env <- getEnv - ; let mask = env_um env - ; liftIO $! uniqFromMask mask } - -newUniqueSupply :: TcRnIf gbl lcl UniqSupply -newUniqueSupply - = do { env <- getEnv - ; let mask = env_um env - ; liftIO $! mkSplitUniqSupply mask } - -cloneLocalName :: Name -> TcM Name --- Make a fresh Internal name with the same OccName and SrcSpan -cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name) - -newName :: OccName -> TcM Name -newName occ = do { loc <- getSrcSpanM - ; newNameAt occ loc } - -newNameAt :: OccName -> SrcSpan -> TcM Name -newNameAt occ span - = do { uniq <- newUnique - ; return (mkInternalName uniq occ span) } - -newSysName :: OccName -> TcRnIf gbl lcl Name -newSysName occ - = do { uniq <- newUnique - ; return (mkSystemName uniq occ) } - -newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId -newSysLocalId fs ty - = do { u <- newUnique - ; return (mkSysLocal fs u ty) } - -newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] -newSysLocalIds fs tys - = do { us <- newUniqueSupply - ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } - -instance MonadUnique (IOEnv (Env gbl lcl)) where - getUniqueM = newUnique - getUniqueSupplyM = newUniqueSupply - -{- -************************************************************************ -* * - Accessing input/output -* * -************************************************************************ --} - -newTcRef :: a -> TcRnIf gbl lcl (TcRef a) -newTcRef = newMutVar - -readTcRef :: TcRef a -> TcRnIf gbl lcl a -readTcRef = readMutVar - -writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl () -writeTcRef = writeMutVar - -updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl () --- Returns () -updTcRef ref fn = liftIO $ do { old <- readIORef ref - ; writeIORef ref (fn old) } - -{- -************************************************************************ -* * - Debugging -* * -************************************************************************ --} - - --- Typechecker trace -traceTc :: String -> SDoc -> TcRn () -traceTc = - labelledTraceOptTcRn Opt_D_dump_tc_trace - --- Renamer Trace -traceRn :: String -> SDoc -> TcRn () -traceRn = - labelledTraceOptTcRn Opt_D_dump_rn_trace - --- | Trace when a certain flag is enabled. This is like `traceOptTcRn` --- but accepts a string as a label and formats the trace message uniformly. -labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn () -labelledTraceOptTcRn flag herald doc = do - traceOptTcRn flag (formatTraceMsg herald doc) - -formatTraceMsg :: String -> SDoc -> SDoc -formatTraceMsg herald doc = hang (text herald) 2 doc - --- | Trace if the given 'DumpFlag' is set. -traceOptTcRn :: DumpFlag -> SDoc -> TcRn () -traceOptTcRn flag doc = do - dflags <- getDynFlags - when (dopt flag dflags) $ - dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc - --- | Dump if the given 'DumpFlag' is set. -dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () -dumpOptTcRn flag title fmt doc = do - dflags <- getDynFlags - when (dopt flag dflags) $ - dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc - --- | Unconditionally dump some trace output --- --- Certain tests (T3017, Roles3, T12763 etc.) expect part of the --- output generated by `-ddump-types` to be in 'PprUser' style. However, --- generally we want all other debugging output to use 'PprDump' --- style. We 'PprUser' style if 'useUserStyle' is True. --- -dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn () -dumpTcRn useUserStyle dumpOpt title fmt doc = do - dflags <- getDynFlags - printer <- getPrintUnqualified dflags - real_doc <- wrapDocLoc doc - let sty = if useUserStyle - then mkUserStyle dflags printer AllTheWay - else mkDumpStyle dflags printer - liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc - --- | Add current location if -dppr-debug --- (otherwise the full location is usually way too much) -wrapDocLoc :: SDoc -> TcRn SDoc -wrapDocLoc doc = do - dflags <- getDynFlags - if hasPprDebug dflags - then do - loc <- getSrcSpanM - return (mkLocMessage SevOutput loc doc) - else - return doc - -getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified -getPrintUnqualified dflags - = do { rdr_env <- getGlobalRdrEnv - ; return $ mkPrintUnqualified dflags rdr_env } - --- | Like logInfoTcRn, but for user consumption -printForUserTcRn :: SDoc -> TcRn () -printForUserTcRn doc - = do { dflags <- getDynFlags - ; printer <- getPrintUnqualified dflags - ; liftIO (printOutputForUser dflags printer doc) } - -{- -traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is -available. Alas, they behave inconsistently with the other stuff; -e.g. are unaffected by -dump-to-file. --} - -traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () -traceIf = traceOptIf Opt_D_dump_if_trace -traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs - - -traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () -traceOptIf flag doc - = whenDOptM flag $ -- No RdrEnv available, so qualify everything - do { dflags <- getDynFlags - ; liftIO (putMsg dflags doc) } - -{- -************************************************************************ -* * - Typechecker global environment -* * -************************************************************************ --} - -getIsGHCi :: TcRn Bool -getIsGHCi = do { mod <- getModule - ; return (isInteractiveModule mod) } - -getGHCiMonad :: TcRn Name -getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } - -getInteractivePrintName :: TcRn Name -getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } - -tcIsHsBootOrSig :: TcRn Bool -tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) } - -tcIsHsig :: TcRn Bool -tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) } - -tcSelfBootInfo :: TcRn SelfBootInfo -tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) } - -getGlobalRdrEnv :: TcRn GlobalRdrEnv -getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } - -getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) -getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } - -getImports :: TcRn ImportAvails -getImports = do { env <- getGblEnv; return (tcg_imports env) } - -getFixityEnv :: TcRn FixityEnv -getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) } - -extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a -extendFixityEnv new_bit - = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> - env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) - -getRecFieldEnv :: TcRn RecFieldEnv -getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } - -getDeclaredDefaultTys :: TcRn (Maybe [Type]) -getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } - -addDependentFiles :: [FilePath] -> TcRn () -addDependentFiles fs = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fs ++ dep_files) - -{- -************************************************************************ -* * - Error management -* * -************************************************************************ --} - -getSrcSpanM :: TcRn SrcSpan - -- Avoid clash with Name.getSrcLoc -getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) } - -setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -setSrcSpan (RealSrcSpan real_loc _) thing_inside - = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside --- Don't overwrite useful info with useless: -setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside - -addLocM :: (a -> TcM b) -> Located a -> TcM b -addLocM fn (L loc a) = setSrcSpan loc $ fn a - -wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) --- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a - ; return (L loc b) } - -wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) -wrapLocFstM fn (L loc a) = - setSrcSpan loc $ do - (b,c) <- fn a - return (L loc b, c) - -wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c) -wrapLocSndM fn (L loc a) = - setSrcSpan loc $ do - (b,c) <- fn a - return (b, L loc c) - -wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM () -wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) - --- Reporting errors - -getErrsVar :: TcRn (TcRef Messages) -getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } - -setErrsVar :: TcRef Messages -> TcRn a -> TcRn a -setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) - -addErr :: MsgDoc -> TcRn () -addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } - -failWith :: MsgDoc -> TcRn a -failWith msg = addErr msg >> failM - -failAt :: SrcSpan -> MsgDoc -> TcRn a -failAt loc msg = addErrAt loc msg >> failM - -addErrAt :: SrcSpan -> MsgDoc -> TcRn () --- addErrAt is mainly (exclusively?) used by the renamer, where --- tidying is not an issue, but it's all lazy so the extra --- work doesn't matter -addErrAt loc msg = do { ctxt <- getErrCtxt - ; tidy_env <- tcInitTidyEnv - ; err_info <- mkErrInfo tidy_env ctxt - ; addLongErrAt loc msg err_info } - -addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () -addErrs msgs = mapM_ add msgs - where - add (loc,msg) = addErrAt loc msg - -checkErr :: Bool -> MsgDoc -> TcRn () --- Add the error if the bool is False -checkErr ok msg = unless ok (addErr msg) - -addMessages :: Messages -> TcRn () -addMessages msgs1 - = do { errs_var <- getErrsVar ; - msgs0 <- readTcRef errs_var ; - writeTcRef errs_var (unionMessages msgs0 msgs1) } - -discardWarnings :: TcRn a -> TcRn a --- Ignore warnings inside the thing inside; --- used to ignore-unused-variable warnings inside derived code -discardWarnings thing_inside - = do { errs_var <- getErrsVar - ; (old_warns, _) <- readTcRef errs_var - - ; result <- thing_inside - - -- Revert warnings to old_warns - ; (_new_warns, new_errs) <- readTcRef errs_var - ; writeTcRef errs_var (old_warns, new_errs) - - ; return result } - -{- -************************************************************************ -* * - Shared error message stuff: renamer and typechecker -* * -************************************************************************ --} - -mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg -mkLongErrAt loc msg extra - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - return $ mkLongErrMsg dflags loc printer msg extra } - -mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg -mkErrDocAt loc errDoc - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - return $ mkErrDoc dflags loc printer errDoc } - -addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () -addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError - -reportErrors :: [ErrMsg] -> TcM () -reportErrors = mapM_ reportError - -reportError :: ErrMsg -> TcRn () -reportError err - = do { traceTc "Adding error:" (pprLocErrMsg err) ; - errs_var <- getErrsVar ; - (warns, errs) <- readTcRef errs_var ; - writeTcRef errs_var (warns, errs `snocBag` err) } - -reportWarning :: WarnReason -> ErrMsg -> TcRn () -reportWarning reason err - = do { let warn = makeIntoWarning reason err - -- 'err' was built by mkLongErrMsg or something like that, - -- so it's of error severity. For a warning we downgrade - -- its severity to SevWarning - - ; traceTc "Adding warning:" (pprLocErrMsg warn) - ; errs_var <- getErrsVar - ; (warns, errs) <- readTcRef errs_var - ; writeTcRef errs_var (warns `snocBag` warn, errs) } - - ------------------------ -checkNoErrs :: TcM r -> TcM r --- (checkNoErrs m) succeeds iff m succeeds and generates no errors --- If m fails then (checkNoErrsTc m) fails. --- If m succeeds, it checks whether m generated any errors messages --- (it might have recovered internally) --- If so, it fails too. --- Regardless, any errors generated by m are propagated to the enclosing context. -checkNoErrs main - = do { (res, no_errs) <- askNoErrs main - ; unless no_errs failM - ; return res } - ------------------------ -whenNoErrs :: TcM () -> TcM () -whenNoErrs thing = ifErrsM (return ()) thing - -ifErrsM :: TcRn r -> TcRn r -> TcRn r --- ifErrsM bale_out normal --- does 'bale_out' if there are errors in errors collection --- otherwise does 'normal' -ifErrsM bale_out normal - = do { errs_var <- getErrsVar ; - msgs <- readTcRef errs_var ; - dflags <- getDynFlags ; - if errorsFound dflags msgs then - bale_out - else - normal } - -failIfErrsM :: TcRn () --- Useful to avoid error cascades -failIfErrsM = ifErrsM failM (return ()) - -{- ********************************************************************* -* * - Context management for the type checker -* * -************************************************************************ --} - -getErrCtxt :: TcM [ErrCtxt] -getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } - -setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a -setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) - --- | Add a fixed message to the error context. This message should not --- do any tidying. -addErrCtxt :: MsgDoc -> TcM a -> TcM a -addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) - --- | Add a message to the error context. This message may do tidying. -addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a -addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts) - --- | Add a fixed landmark message to the error context. A landmark --- message is always sure to be reported, even if there is a lot of --- context. It also doesn't count toward the maximum number of contexts --- reported. -addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a -addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) - --- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations --- and tidying. -addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a -addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts) - --- Helper function for the above -updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a -updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> - env { tcl_ctxt = upd ctxt }) - -popErrCtxt :: TcM a -> TcM a -popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) - -getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc -getCtLocM origin t_or_k - = do { env <- getLclEnv - ; return (CtLoc { ctl_origin = origin - , ctl_env = env - , ctl_t_or_k = t_or_k - , ctl_depth = initialSubGoalDepth }) } - -setCtLocM :: CtLoc -> TcM a -> TcM a --- Set the SrcSpan and error context from the CtLoc -setCtLocM (CtLoc { ctl_env = lcl }) thing_inside - = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl - , tcl_bndrs = tcl_bndrs lcl - , tcl_ctxt = tcl_ctxt lcl }) - thing_inside - - -{- ********************************************************************* -* * - Error recovery and exceptions -* * -********************************************************************* -} - -tcTryM :: TcRn r -> TcRn (Maybe r) --- The most basic function: catch the exception --- Nothing => an exception happened --- Just r => no exception, result R --- Errors and constraints are propagated in both cases --- Never throws an exception -tcTryM thing_inside - = do { either_res <- tryM thing_inside - ; return (case either_res of - Left _ -> Nothing - Right r -> Just r) } - -- In the Left case the exception is always the IOEnv - -- built-in in exception; see IOEnv.failM - ------------------------ -capture_constraints :: TcM r -> TcM (r, WantedConstraints) --- capture_constraints simply captures and returns the --- constraints generated by thing_inside --- Precondition: thing_inside must not throw an exception! --- Reason for precondition: an exception would blow past the place --- where we read the lie_var, and we'd lose the constraints altogether -capture_constraints thing_inside - = do { lie_var <- newTcRef emptyWC - ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $ - thing_inside - ; lie <- readTcRef lie_var - ; return (res, lie) } - -capture_messages :: TcM r -> TcM (r, Messages) --- capture_messages simply captures and returns the --- errors arnd warnings generated by thing_inside --- Precondition: thing_inside must not throw an exception! --- Reason for precondition: an exception would blow past the place --- where we read the msg_var, and we'd lose the constraints altogether -capture_messages thing_inside - = do { msg_var <- newTcRef emptyMessages - ; res <- setErrsVar msg_var thing_inside - ; msgs <- readTcRef msg_var - ; return (res, msgs) } - ------------------------ --- (askNoErrs m) runs m --- If m fails, --- then (askNoErrs m) fails, propagating only --- insoluble constraints --- --- If m succeeds with result r, --- then (askNoErrs m) succeeds with result (r, b), --- where b is True iff m generated no errors --- --- Regardless of success or failure, --- propagate any errors/warnings generated by m -askNoErrs :: TcRn a -> TcRn (a, Bool) -askNoErrs thing_inside - = do { ((mb_res, lie), msgs) <- capture_messages $ - capture_constraints $ - tcTryM thing_inside - ; addMessages msgs - - ; case mb_res of - Nothing -> do { emitConstraints (insolublesOnly lie) - ; failM } - - Just res -> do { emitConstraints lie - ; dflags <- getDynFlags - ; let errs_found = errorsFound dflags msgs - || insolubleWC lie - ; return (res, not errs_found) } } - ------------------------ -tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints) --- (tryCaptureConstraints_maybe m) runs m, --- and returns the type constraints it generates --- It never throws an exception; instead if thing_inside fails, --- it returns Nothing and the /insoluble/ constraints --- Error messages are propagated -tryCaptureConstraints thing_inside - = do { (mb_res, lie) <- capture_constraints $ - tcTryM thing_inside - - -- See Note [Constraints and errors] - ; let lie_to_keep = case mb_res of - Nothing -> insolublesOnly lie - Just {} -> lie - - ; return (mb_res, lie_to_keep) } - -captureConstraints :: TcM a -> TcM (a, WantedConstraints) --- (captureConstraints m) runs m, and returns the type constraints it generates --- If thing_inside fails (throwing an exception), --- then (captureConstraints thing_inside) fails too --- propagating the insoluble constraints only --- Error messages are propagated in either case -captureConstraints thing_inside - = do { (mb_res, lie) <- tryCaptureConstraints thing_inside - - -- See Note [Constraints and errors] - -- If the thing_inside threw an exception, emit the insoluble - -- constraints only (returned by tryCaptureConstraints) - -- so that they are not lost - ; case mb_res of - Nothing -> do { emitConstraints lie; failM } - Just res -> return (res, lie) } - ------------------------ -attemptM :: TcRn r -> TcRn (Maybe r) --- (attemptM thing_inside) runs thing_inside --- If thing_inside succeeds, returning r, --- we return (Just r), and propagate all constraints and errors --- If thing_inside fail, throwing an exception, --- we return Nothing, propagating insoluble constraints, --- and all errors --- attemptM never throws an exception -attemptM thing_inside - = do { (mb_r, lie) <- tryCaptureConstraints thing_inside - ; emitConstraints lie - - -- Debug trace - ; when (isNothing mb_r) $ - traceTc "attemptM recovering with insoluble constraints" $ - (ppr lie) - - ; return mb_r } - ------------------------ -recoverM :: TcRn r -- Recovery action; do this if the main one fails - -> TcRn r -- Main action: do this first; - -- if it generates errors, propagate them all - -> TcRn r --- (recoverM recover thing_inside) runs thing_inside --- If thing_inside fails, propagate its errors and insoluble constraints --- and run 'recover' --- If thing_inside succeeds, propagate all its errors and constraints --- --- Can fail, if 'recover' fails -recoverM recover thing - = do { mb_res <- attemptM thing ; - case mb_res of - Nothing -> recover - Just res -> return res } - ------------------------ - --- | Drop elements of the input that fail, so the result --- list can be shorter than the argument list -mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] -mapAndRecoverM f xs - = do { mb_rs <- mapM (attemptM . f) xs - ; return [r | Just r <- mb_rs] } - --- | Apply the function to all elements on the input list --- If all succeed, return the list of results --- Otherwise fail, propagating all errors -mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b] -mapAndReportM f xs - = do { mb_rs <- mapM (attemptM . f) xs - ; when (any isNothing mb_rs) failM - ; return [r | Just r <- mb_rs] } - --- | The accumulator is not updated if the action fails -foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b -foldAndRecoverM _ acc [] = return acc -foldAndRecoverM f acc (x:xs) = - do { mb_r <- attemptM (f acc x) - ; case mb_r of - Nothing -> foldAndRecoverM f acc xs - Just acc' -> foldAndRecoverM f acc' xs } - ------------------------ -tryTc :: TcRn a -> TcRn (Maybe a, Messages) --- (tryTc m) executes m, and returns --- Just r, if m succeeds (returning r) --- Nothing, if m fails --- It also returns all the errors and warnings accumulated by m --- It always succeeds (never raises an exception) -tryTc thing_inside - = capture_messages (attemptM thing_inside) - ------------------------ -discardErrs :: TcRn a -> TcRn a --- (discardErrs m) runs m, --- discarding all error messages and warnings generated by m --- If m fails, discardErrs fails, and vice versa -discardErrs m - = do { errs_var <- newTcRef emptyMessages - ; setErrsVar errs_var m } - ------------------------ -tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r --- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside'; --- if 'main' succeeds with no error messages, it's the answer --- otherwise discard everything from 'main', including errors, --- and try 'recover' instead. -tryTcDiscardingErrs recover thing_inside - = do { ((mb_res, lie), msgs) <- capture_messages $ - capture_constraints $ - tcTryM thing_inside - ; dflags <- getDynFlags - ; case mb_res of - Just res | not (errorsFound dflags msgs) - , not (insolubleWC lie) - -> -- 'main' succeeded with no errors - do { addMessages msgs -- msgs might still have warnings - ; emitConstraints lie - ; return res } - - _ -> -- 'main' failed, or produced an error message - recover -- Discard all errors and warnings - -- and unsolved constraints entirely - } - -{- -************************************************************************ -* * - Error message generation (type checker) -* * -************************************************************************ - - The addErrTc functions add an error message, but do not cause failure. - The 'M' variants pass a TidyEnv that has already been used to - tidy up the message; we then use it to tidy the context messages --} - -addErrTc :: MsgDoc -> TcM () -addErrTc err_msg = do { env0 <- tcInitTidyEnv - ; addErrTcM (env0, err_msg) } - -addErrsTc :: [MsgDoc] -> TcM () -addErrsTc err_msgs = mapM_ addErrTc err_msgs - -addErrTcM :: (TidyEnv, MsgDoc) -> TcM () -addErrTcM (tidy_env, err_msg) - = do { ctxt <- getErrCtxt ; - loc <- getSrcSpanM ; - add_err_tcm tidy_env err_msg loc ctxt } - --- Return the error message, instead of reporting it straight away -mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg -mkErrTcM (tidy_env, err_msg) - = do { ctxt <- getErrCtxt ; - loc <- getSrcSpanM ; - err_info <- mkErrInfo tidy_env ctxt ; - mkLongErrAt loc err_msg err_info } - -mkErrTc :: MsgDoc -> TcM ErrMsg -mkErrTc msg = do { env0 <- tcInitTidyEnv - ; mkErrTcM (env0, msg) } - --- The failWith functions add an error message and cause failure - -failWithTc :: MsgDoc -> TcM a -- Add an error message and fail -failWithTc err_msg - = addErrTc err_msg >> failM - -failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail -failWithTcM local_and_msg - = addErrTcM local_and_msg >> failM - -checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true -checkTc True _ = return () -checkTc False err = failWithTc err - -checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () -checkTcM True _ = return () -checkTcM False err = failWithTcM err - -failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false -failIfTc False _ = return () -failIfTc True err = failWithTc err - -failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () - -- Check that the boolean is false -failIfTcM False _ = return () -failIfTcM True err = failWithTcM err - - --- Warnings have no 'M' variant, nor failure - --- | Display a warning if a condition is met, --- and the warning is enabled -warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn () -warnIfFlag warn_flag is_bad msg - = do { warn_on <- woptM warn_flag - ; when (warn_on && is_bad) $ - addWarn (Reason warn_flag) msg } - --- | Display a warning if a condition is met. -warnIf :: Bool -> MsgDoc -> TcRn () -warnIf is_bad msg - = when is_bad (addWarn NoReason msg) - --- | Display a warning if a condition is met. -warnTc :: WarnReason -> Bool -> MsgDoc -> TcM () -warnTc reason warn_if_true warn_msg - | warn_if_true = addWarnTc reason warn_msg - | otherwise = return () - --- | Display a warning if a condition is met. -warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM () -warnTcM reason warn_if_true warn_msg - | warn_if_true = addWarnTcM reason warn_msg - | otherwise = return () - --- | Display a warning in the current context. -addWarnTc :: WarnReason -> MsgDoc -> TcM () -addWarnTc reason msg - = do { env0 <- tcInitTidyEnv ; - addWarnTcM reason (env0, msg) } - --- | Display a warning in a given context. -addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM () -addWarnTcM reason (env0, msg) - = do { ctxt <- getErrCtxt ; - err_info <- mkErrInfo env0 ctxt ; - add_warn reason msg err_info } - --- | Display a warning for the current source location. -addWarn :: WarnReason -> MsgDoc -> TcRn () -addWarn reason msg = add_warn reason msg Outputable.empty - --- | Display a warning for a given source location. -addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn () -addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty - --- | Display a warning, with an optional flag, for the current source --- location. -add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn () -add_warn reason msg extra_info - = do { loc <- getSrcSpanM - ; add_warn_at reason loc msg extra_info } - --- | Display a warning, with an optional flag, for a given location. -add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () -add_warn_at reason loc msg extra_info - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - let { warn = mkLongWarnMsg dflags loc printer - msg extra_info } ; - reportWarning reason warn } - - -{- ------------------------------------ - Other helper functions --} - -add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan - -> [ErrCtxt] - -> TcM () -add_err_tcm tidy_env err_msg loc ctxt - = do { err_info <- mkErrInfo tidy_env ctxt ; - addLongErrAt loc err_msg err_info } - -mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc --- Tidy the error info, trimming excessive contexts -mkErrInfo env ctxts --- = do --- dbg <- hasPprDebug <$> getDynFlags --- if dbg -- In -dppr-debug style the output --- then return empty -- just becomes too voluminous --- else go dbg 0 env ctxts - = go False 0 env ctxts - where - go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc - go _ _ _ [] = return empty - go dbg n env ((is_landmark, ctxt) : ctxts) - | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg - = do { (env', msg) <- ctxt env - ; let n' = if is_landmark then n else n+1 - ; rest <- go dbg n' env' ctxts - ; return (msg $$ rest) } - | otherwise - = go dbg n env ctxts - -mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts -mAX_CONTEXTS = 3 - --- debugTc is useful for monadic debugging code - -debugTc :: TcM () -> TcM () -debugTc thing - | debugIsOn = thing - | otherwise = return () - -{- -************************************************************************ -* * - Type constraints -* * -************************************************************************ --} - -addTopEvBinds :: Bag EvBind -> TcM a -> TcM a -addTopEvBinds new_ev_binds thing_inside - =updGblEnv upd_env thing_inside - where - upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env - `unionBags` new_ev_binds } - -newTcEvBinds :: TcM EvBindsVar -newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap - ; tcvs_ref <- newTcRef emptyVarSet - ; uniq <- newUnique - ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq) - ; return (EvBindsVar { ebv_binds = binds_ref - , ebv_tcvs = tcvs_ref - , ebv_uniq = uniq }) } - --- | Creates an EvBindsVar incapable of holding any bindings. It still --- tracks covar usages (see comments on ebv_tcvs in TcEvidence), thus --- must be made monadically -newNoTcEvBinds :: TcM EvBindsVar -newNoTcEvBinds - = do { tcvs_ref <- newTcRef emptyVarSet - ; uniq <- newUnique - ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq) - ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref - , ebv_uniq = uniq }) } - -cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar --- Clone the refs, so that any binding created when --- solving don't pollute the original -cloneEvBindsVar ebv@(EvBindsVar {}) - = do { binds_ref <- newTcRef emptyEvBindMap - ; tcvs_ref <- newTcRef emptyVarSet - ; return (ebv { ebv_binds = binds_ref - , ebv_tcvs = tcvs_ref }) } -cloneEvBindsVar ebv@(CoEvBindsVar {}) - = do { tcvs_ref <- newTcRef emptyVarSet - ; return (ebv { ebv_tcvs = tcvs_ref }) } - -getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet -getTcEvTyCoVars ev_binds_var - = readTcRef (ebv_tcvs ev_binds_var) - -getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap -getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) - = readTcRef ev_ref -getTcEvBindsMap (CoEvBindsVar {}) - = return emptyEvBindMap - -setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM () -setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds - = writeTcRef ev_ref binds -setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds - | isEmptyEvBindMap ev_binds - = return () - | otherwise - = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds) - -addTcEvBind :: EvBindsVar -> EvBind -> TcM () --- Add a binding to the TcEvBinds by side effect -addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind - = do { traceTc "addTcEvBind" $ ppr u $$ - ppr ev_bind - ; bnds <- readTcRef ev_ref - ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) } -addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind - = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u) - -chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName -chooseUniqueOccTc fn = - do { env <- getGblEnv - ; let dfun_n_var = tcg_dfun_n env - ; set <- readTcRef dfun_n_var - ; let occ = fn set - ; writeTcRef dfun_n_var (extendOccSet set occ) - ; return occ } - -getConstraintVar :: TcM (TcRef WantedConstraints) -getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) } - -setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a -setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) - -emitStaticConstraints :: WantedConstraints -> TcM () -emitStaticConstraints static_lie - = do { gbl_env <- getGblEnv - ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) } - -emitConstraints :: WantedConstraints -> TcM () -emitConstraints ct - | isEmptyWC ct - = return () - | otherwise - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`andWC` ct) } - -emitSimple :: Ct -> TcM () -emitSimple ct - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addSimples` unitBag ct) } - -emitSimples :: Cts -> TcM () -emitSimples cts - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addSimples` cts) } - -emitImplication :: Implication -> TcM () -emitImplication ct - = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addImplics` unitBag ct) } - -emitImplications :: Bag Implication -> TcM () -emitImplications ct - = unless (isEmptyBag ct) $ - do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addImplics` ct) } - -emitInsoluble :: Ct -> TcM () -emitInsoluble ct - = do { traceTc "emitInsoluble" (ppr ct) - ; lie_var <- getConstraintVar - ; updTcRef lie_var (`addInsols` unitBag ct) } - -emitInsolubles :: Cts -> TcM () -emitInsolubles cts - | isEmptyBag cts = return () - | otherwise = do { traceTc "emitInsolubles" (ppr cts) - ; lie_var <- getConstraintVar - ; updTcRef lie_var (`addInsols` cts) } - --- | Throw out any constraints emitted by the thing_inside -discardConstraints :: TcM a -> TcM a -discardConstraints thing_inside = fst <$> captureConstraints thing_inside - --- | The name says it all. The returned TcLevel is the *inner* TcLevel. -pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) -pushLevelAndCaptureConstraints thing_inside - = do { env <- getLclEnv - ; let tclvl' = pushTcLevel (tcl_tclvl env) - ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl') - ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $ - captureConstraints thing_inside - ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl') - ; return (tclvl', lie, res) } - -pushTcLevelM_ :: TcM a -> TcM a -pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x - -pushTcLevelM :: TcM a -> TcM (TcLevel, a) --- See Note [TcLevel assignment] in TcType -pushTcLevelM thing_inside - = do { env <- getLclEnv - ; let tclvl' = pushTcLevel (tcl_tclvl env) - ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) - thing_inside - ; return (tclvl', res) } - --- Returns pushed TcLevel -pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel) -pushTcLevelsM num_levels thing_inside - = do { env <- getLclEnv - ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env) - ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $ - thing_inside - ; return (res, tclvl') } - -getTcLevel :: TcM TcLevel -getTcLevel = do { env <- getLclEnv - ; return (tcl_tclvl env) } - -setTcLevel :: TcLevel -> TcM a -> TcM a -setTcLevel tclvl thing_inside - = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside - -isTouchableTcM :: TcTyVar -> TcM Bool -isTouchableTcM tv - = do { lvl <- getTcLevel - ; return (isTouchableMetaTyVar lvl tv) } - -getLclTypeEnv :: TcM TcTypeEnv -getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } - -setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a --- Set the local type envt, but do *not* disturb other fields, --- notably the lie_var -setLclTypeEnv lcl_env thing_inside - = updLclEnv upd thing_inside - where - upd env = env { tcl_env = tcl_env lcl_env } - -traceTcConstraints :: String -> TcM () -traceTcConstraints msg - = do { lie_var <- getConstraintVar - ; lie <- readTcRef lie_var - ; traceOptTcRn Opt_D_dump_tc_trace $ - hang (text (msg ++ ": LIE:")) 2 (ppr lie) - } - -emitAnonWildCardHoleConstraint :: TcTyVar -> TcM () -emitAnonWildCardHoleConstraint tv - = do { ct_loc <- getCtLocM HoleOrigin Nothing - ; emitInsolubles $ unitBag $ - CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv - , ctev_loc = ct_loc } - , cc_occ = mkTyVarOcc "_" - , cc_hole = TypeHole } } - -emitNamedWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM () -emitNamedWildCardHoleConstraints wcs - = do { ct_loc <- getCtLocM HoleOrigin Nothing - ; emitInsolubles $ listToBag $ - map (do_one ct_loc) wcs } - where - do_one :: CtLoc -> (Name, TcTyVar) -> Ct - do_one ct_loc (name, tv) - = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv - , ctev_loc = ct_loc' } - , cc_occ = occName name - , cc_hole = TypeHole } - where - real_span = case nameSrcSpan name of - RealSrcSpan span _ -> span - UnhelpfulSpan str -> pprPanic "emitNamedWildCardHoleConstraints" - (ppr name <+> quotes (ftext str)) - -- Wildcards are defined locally, and so have RealSrcSpans - ct_loc' = setCtLocSpan ct_loc real_span - -{- Note [Constraints and errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#12124): - - foo :: Maybe Int - foo = return (case Left 3 of - Left -> 1 -- Hard error here! - _ -> 0) - -The call to 'return' will generate a (Monad m) wanted constraint; but -then there'll be "hard error" (i.e. an exception in the TcM monad), from -the unsaturated Left constructor pattern. - -We'll recover in tcPolyBinds, using recoverM. But then the final -tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly -un-filled-in, and will emit a misleading error message. - -The underlying problem is that an exception interrupts the constraint -gathering process. Bottom line: if we have an exception, it's best -simply to discard any gathered constraints. Hence in 'attemptM' we -capture the constraints in a fresh variable, and only emit them into -the surrounding context if we exit normally. If an exception is -raised, simply discard the collected constraints... we have a hard -error to report. So this capture-the-emit dance isn't as stupid as it -looks :-). - -However suppose we throw an exception inside an invocation of -captureConstraints, and discard all the constraints. Some of those -constraints might be "variable out of scope" Hole constraints, and that -might have been the actual original cause of the exception! For -example (#12529): - f = p @ Int -Here 'p' is out of scope, so we get an insoluble Hole constraint. But -the visible type application fails in the monad (throws an exception). -We must not discard the out-of-scope error. - -So we /retain the insoluble constraints/ if there is an exception. -Hence: - - insolublesOnly in tryCaptureConstraints - - emitConstraints in the Left case of captureConstraints - -However note that freshly-generated constraints like (Int ~ Bool), or -((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as -insoluble. The constraint solver does that. So they'll be discarded. -That's probably ok; but see th/5358 as a not-so-good example: - t1 :: Int - t1 x = x -- Manifestly wrong - - foo = $(...raises exception...) -We report the exception, but not the bug in t1. Oh well. Possible -solution: make TcUnify.uType spot manifestly-insoluble constraints. - - -************************************************************************ -* * - Template Haskell context -* * -************************************************************************ --} - -recordThUse :: TcM () -recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } - -recordThSpliceUse :: TcM () -recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } - -keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set -keepAlive name - = do { env <- getGblEnv - ; traceRn "keep alive" (ppr name) - ; updTcRef (tcg_keep env) (`extendNameSet` name) } - -getStage :: TcM ThStage -getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } - -getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage)) -getStageAndBindLevel name - = do { env <- getLclEnv; - ; case lookupNameEnv (tcl_th_bndrs env) name of - Nothing -> return Nothing - Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) } - -setStage :: ThStage -> TcM a -> TcRn a -setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) - --- | Adds the given modFinalizers to the global environment and set them to use --- the current local environment. -addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () -addModFinalizersWithLclEnv mod_finalizers - = do lcl_env <- getLclEnv - th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - updTcRef th_modfinalizers_var $ \fins -> - (lcl_env, mod_finalizers) : fins - -{- -************************************************************************ -* * - Safe Haskell context -* * -************************************************************************ --} - --- | Mark that safe inference has failed --- See Note [Safe Haskell Overlapping Instances Implementation] --- although this is used for more than just that failure case. -recordUnsafeInfer :: WarningMessages -> TcM () -recordUnsafeInfer warns = - getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns) - --- | Figure out the final correct safe haskell mode -finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode -finalSafeMode dflags tcg_env = do - safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env) - return $ case safeHaskell dflags of - Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred - | otherwise -> Sf_None - s -> s - --- | Switch instances to safe instances if we're in Safe mode. -fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst] -fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id -fixSafeInstances _ = map fixSafe - where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True } - in inst { is_flag = new_flag } - -{- -************************************************************************ -* * - Stuff for the renamer's local env -* * -************************************************************************ --} - -getLocalRdrEnv :: RnM LocalRdrEnv -getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } - -setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a -setLocalRdrEnv rdr_env thing_inside - = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside - -{- -************************************************************************ -* * - Stuff for interface decls -* * -************************************************************************ --} - -mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv -mkIfLclEnv mod loc boot - = IfLclEnv { if_mod = mod, - if_loc = loc, - if_boot = boot, - if_nsubst = Nothing, - if_implicits_env = Nothing, - if_tv_env = emptyFsEnv, - if_id_env = emptyFsEnv } - --- | Run an 'IfG' (top-level interface monad) computation inside an existing --- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv' --- based on 'TcGblEnv'. -initIfaceTcRn :: IfG a -> TcRn a -initIfaceTcRn thing_inside - = do { tcg_env <- getGblEnv - ; dflags <- getDynFlags - ; let !mod = tcg_semantic_mod tcg_env - -- When we are instantiating a signature, we DEFINITELY - -- do not want to knot tie. - is_instantiate = unitIdIsDefinite (thisPackage dflags) && - not (null (thisUnitIdInsts dflags)) - ; let { if_env = IfGblEnv { - if_doc = text "initIfaceTcRn", - if_rec_types = - if is_instantiate - then Nothing - else Just (mod, get_type_env) - } - ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } - ; setEnvs (if_env, ()) thing_inside } - --- Used when sucking in a ModIface into a ModDetails to put in --- the HPT. Notably, unlike initIfaceCheck, this does NOT use --- hsc_type_env_var (since we're not actually going to typecheck, --- so this variable will never get updated!) -initIfaceLoad :: HscEnv -> IfG a -> IO a -initIfaceLoad hsc_env do_this - = do let gbl_env = IfGblEnv { - if_doc = text "initIfaceLoad", - if_rec_types = Nothing - } - initTcRnIf 'i' hsc_env gbl_env () do_this - -initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a --- Used when checking the up-to-date-ness of the old Iface --- Initialise the environment with no useful info at all -initIfaceCheck doc hsc_env do_this - = do let rec_types = case hsc_type_env_var hsc_env of - Just (mod,var) -> Just (mod, readTcRef var) - Nothing -> Nothing - gbl_env = IfGblEnv { - if_doc = text "initIfaceCheck" <+> doc, - if_rec_types = rec_types - } - initTcRnIf 'i' hsc_env gbl_env () do_this - -initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a -initIfaceLcl mod loc_doc hi_boot_file thing_inside - = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside - --- | Initialize interface typechecking, but with a 'NameShape' --- to apply when typechecking top-level 'OccName's (see --- 'lookupIfaceTop') -initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a -initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside - = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside - -getIfModule :: IfL Module -getIfModule = do { env <- getLclEnv; return (if_mod env) } - --------------------- -failIfM :: MsgDoc -> IfL a --- The Iface monad doesn't have a place to accumulate errors, so we --- just fall over fast if one happens; it "shouldn't happen". --- We use IfL here so that we can get context info out of the local env -failIfM msg - = do { env <- getLclEnv - ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; dflags <- getDynFlags - ; liftIO (putLogMsg dflags NoReason SevFatal - noSrcSpan (defaultErrStyle dflags) full_msg) - ; failM } - --------------------- -forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) --- Run thing_inside in an interleaved thread. --- It shares everything with the parent thread, so this is DANGEROUS. --- --- It returns Nothing if the computation fails --- --- It's used for lazily type-checking interface --- signatures, which is pretty benign - -forkM_maybe doc thing_inside - = do { -- see Note [Masking exceptions in forkM_maybe] - ; unsafeInterleaveM $ uninterruptibleMaskM_ $ - do { traceIf (text "Starting fork {" <+> doc) - ; mb_res <- tryM $ - updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ - thing_inside - ; case mb_res of - Right r -> do { traceIf (text "} ending fork" <+> doc) - ; return (Just r) } - Left exn -> do { - - -- Bleat about errors in the forked thread, if -ddump-if-trace is on - -- Otherwise we silently discard errors. Errors can legitimately - -- happen when compiling interface signatures (see tcInterfaceSigs) - whenDOptM Opt_D_dump_if_trace $ do - dflags <- getDynFlags - let msg = hang (text "forkM failed:" <+> doc) - 2 (text (show exn)) - liftIO $ putLogMsg dflags - NoReason - SevFatal - noSrcSpan - (defaultErrStyle dflags) - msg - - ; traceIf (text "} ending fork (badly)" <+> doc) - ; return Nothing } - }} - -forkM :: SDoc -> IfL a -> IfL a -forkM doc thing_inside - = do { mb_res <- forkM_maybe doc thing_inside - ; return (case mb_res of - Nothing -> pgmError "Cannot continue after interface file error" - -- pprPanic "forkM" doc - Just r -> r) } - -setImplicitEnvM :: TypeEnv -> IfL a -> IfL a -setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl - { if_implicits_env = Just tenv }) m - -{- -Note [Masking exceptions in forkM_maybe] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When using GHC-as-API it must be possible to interrupt snippets of code -executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible -by throwing an asynchronous interrupt to the GHC thread. However, there is a -subtle problem: runStmt first typechecks the code before running it, and the -exception might interrupt the type checker rather than the code. Moreover, the -typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and -more importantly might be inside an exception handler inside that -unsafeInterleaveIO. If that is the case, the exception handler will rethrow the -asynchronous exception as a synchronous exception, and the exception will end -up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed -discussion). We don't currently know a general solution to this problem, but -we can use uninterruptibleMask_ to avoid the situation. --} - --- | Environments which track 'CostCentreState' -class ContainsCostCentreState e where - extractCostCentreState :: e -> TcRef CostCentreState - -instance ContainsCostCentreState TcGblEnv where - extractCostCentreState = tcg_cc_st - -instance ContainsCostCentreState DsGblEnv where - extractCostCentreState = ds_cc_st - --- | Get the next cost centre index associated with a given name. -getCCIndexM :: (ContainsCostCentreState gbl) - => FastString -> TcRnIf gbl lcl CostCentreIndex -getCCIndexM nm = do - env <- getGblEnv - let cc_st_ref = extractCostCentreState env - cc_st <- readTcRef cc_st_ref - let (idx, cc_st') = getCCIndex nm cc_st - writeTcRef cc_st_ref cc_st' - return idx diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs deleted file mode 100644 index aa3c0412ee..0000000000 --- a/compiler/typecheck/TcRnTypes.hs +++ /dev/null @@ -1,1728 +0,0 @@ -{- -(c) The University of Glasgow 2006-2012 -(c) The GRASP Project, Glasgow University, 1992-2002 - - -Various types used during typechecking, please see TcRnMonad as well for -operations on these types. You probably want to import it, instead of this -module. - -All the monads exported here are built on top of the same IOEnv monad. The -monad functions like a Reader monad in the way it passes the environment -around. This is done to allow the environment to be manipulated in a stack -like fashion when entering expressions... etc. - -For state that is global and should be returned at the end (e.g not part -of the stack mechanism), you should use a TcRef (= IORef) to store them. --} - -{-# LANGUAGE CPP, DeriveFunctor, ExistentialQuantification, GeneralizedNewtypeDeriving, - ViewPatterns #-} - -module TcRnTypes( - TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module - TcRef, - - -- The environment types - Env(..), - TcGblEnv(..), TcLclEnv(..), - setLclEnvTcLevel, getLclEnvTcLevel, - setLclEnvLoc, getLclEnvLoc, - IfGblEnv(..), IfLclEnv(..), - tcVisibleOrphanMods, - - -- Frontend types (shouldn't really be here) - FrontendResult(..), - - -- Renamer types - ErrCtxt, RecFieldEnv, pushErrCtxt, pushErrCtxtSameOrigin, - ImportAvails(..), emptyImportAvails, plusImportAvails, - WhereFrom(..), mkModDeps, modDepsElts, - - -- Typechecker types - TcTypeEnv, TcBinderStack, TcBinder(..), - TcTyThing(..), PromotionErr(..), - IdBindingInfo(..), ClosedTypeId, RhsNames, - IsGroupClosed(..), - SelfBootInfo(..), - pprTcTyThingCategory, pprPECategory, CompleteMatch(..), - - -- Desugaring types - DsM, DsLclEnv(..), DsGblEnv(..), - DsMetaEnv, DsMetaVal(..), CompleteMatchMap, - mkCompleteMatchMap, extendCompleteMatchMap, - - -- Template Haskell - ThStage(..), SpliceType(..), PendingStuff(..), - topStage, topAnnStage, topSpliceStage, - ThLevel, impLevel, outerLevel, thLevel, - ForeignSrcLang(..), - - -- Arrows - ArrowCtxt(..), - - -- TcSigInfo - TcSigFun, TcSigInfo(..), TcIdSigInfo(..), - TcIdSigInst(..), TcPatSynInfo(..), - isPartialSig, hasCompleteSig, - - -- Misc other types - TcId, TcIdSet, - NameShape(..), - removeBindingShadowing, - - -- Constraint solver plugins - TcPlugin(..), TcPluginResult(..), TcPluginSolver, - TcPluginM, runTcPluginM, unsafeTcPluginTcM, - getEvBindsTcPluginM, - - -- Role annotations - RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv, - lookupRoleAnnot, getRoleAnnots - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Driver.Types -import TcEvidence -import GHC.Core.Type -import GHC.Core.TyCon ( TyCon, tyConKind ) -import GHC.Core.PatSyn ( PatSyn ) -import GHC.Types.Id ( idType, idName ) -import GHC.Types.FieldLabel ( FieldLabel ) -import TcType -import Constraint -import TcOrigin -import GHC.Types.Annotations -import GHC.Core.InstEnv -import GHC.Core.FamInstEnv -import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Deltas) -import IOEnv -import GHC.Types.Name.Reader -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Avail -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Module -import GHC.Types.SrcLoc -import GHC.Types.Var.Set -import ErrUtils -import GHC.Types.Unique.FM -import GHC.Types.Basic -import Bag -import GHC.Driver.Session -import Outputable -import ListSetOps -import Fingerprint -import Util -import PrelNames ( isUnboundName ) -import GHC.Types.CostCentre.State - -import Control.Monad (ap) -import Data.Set ( Set ) -import qualified Data.Set as S - -import Data.List ( sort ) -import Data.Map ( Map ) -import Data.Dynamic ( Dynamic ) -import Data.Typeable ( TypeRep ) -import Data.Maybe ( mapMaybe ) -import GHCi.Message -import GHCi.RemoteTypes - -import {-# SOURCE #-} TcHoleFitTypes ( HoleFitPlugin ) - -import qualified Language.Haskell.TH as TH - --- | A 'NameShape' is a substitution on 'Name's that can be used --- to refine the identities of a hole while we are renaming interfaces --- (see 'GHC.Iface.Rename'). Specifically, a 'NameShape' for --- 'ns_module_name' @A@, defines a mapping from @{A.T}@ --- (for some 'OccName' @T@) to some arbitrary other 'Name'. --- --- The most intruiging thing about a 'NameShape', however, is --- how it's constructed. A 'NameShape' is *implied* by the --- exported 'AvailInfo's of the implementor of an interface: --- if an implementor of signature @<H>@ exports @M.T@, you implicitly --- define a substitution from @{H.T}@ to @M.T@. So a 'NameShape' --- is computed from the list of 'AvailInfo's that are exported --- by the implementation of a module, or successively merged --- together by the export lists of signatures which are joining --- together. --- --- It's not the most obvious way to go about doing this, but it --- does seem to work! --- --- NB: Can't boot this and put it in NameShape because then we --- start pulling in too many DynFlags things. -data NameShape = NameShape { - ns_mod_name :: ModuleName, - ns_exports :: [AvailInfo], - ns_map :: OccEnv Name - } - - -{- -************************************************************************ -* * - Standard monad definition for TcRn - All the combinators for the monad can be found in TcRnMonad -* * -************************************************************************ - -The monad itself has to be defined here, because it is mentioned by ErrCtxt --} - -type TcRnIf a b = IOEnv (Env a b) -type TcRn = TcRnIf TcGblEnv TcLclEnv -- Type inference -type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff -type IfG = IfM () -- Top level -type IfL = IfM IfLclEnv -- Nested -type DsM = TcRnIf DsGblEnv DsLclEnv -- Desugaring - --- TcRn is the type-checking and renaming monad: the main monad that --- most type-checking takes place in. The global environment is --- 'TcGblEnv', which tracks all of the top-level type-checking --- information we've accumulated while checking a module, while the --- local environment is 'TcLclEnv', which tracks local information as --- we move inside expressions. - --- | Historical "renaming monad" (now it's just 'TcRn'). -type RnM = TcRn - --- | Historical "type-checking monad" (now it's just 'TcRn'). -type TcM = TcRn - --- We 'stack' these envs through the Reader like monad infrastructure --- as we move into an expression (although the change is focused in --- the lcl type). -data Env gbl lcl - = Env { - env_top :: !HscEnv, -- Top-level stuff that never changes - -- Includes all info about imported things - -- BangPattern is to fix leak, see #15111 - - env_um :: !Char, -- Mask for Uniques - - env_gbl :: gbl, -- Info about things defined at the top level - -- of the module being compiled - - env_lcl :: lcl -- Nested stuff; changes as we go into - } - -instance ContainsDynFlags (Env gbl lcl) where - extractDynFlags env = hsc_dflags (env_top env) - -instance ContainsModule gbl => ContainsModule (Env gbl lcl) where - extractModule env = extractModule (env_gbl env) - - -{- -************************************************************************ -* * - The interface environments - Used when dealing with IfaceDecls -* * -************************************************************************ --} - -data IfGblEnv - = IfGblEnv { - -- Some information about where this environment came from; - -- useful for debugging. - if_doc :: SDoc, - -- The type environment for the module being compiled, - -- in case the interface refers back to it via a reference that - -- was originally a hi-boot file. - -- We need the module name so we can test when it's appropriate - -- to look in this env. - -- See Note [Tying the knot] in GHC.IfaceToCore - if_rec_types :: Maybe (Module, IfG TypeEnv) - -- Allows a read effect, so it can be in a mutable - -- variable; c.f. handling the external package type env - -- Nothing => interactive stuff, no loops possible - } - -data IfLclEnv - = IfLclEnv { - -- The module for the current IfaceDecl - -- So if we see f = \x -> x - -- it means M.f = \x -> x, where M is the if_mod - -- NB: This is a semantic module, see - -- Note [Identity versus semantic module] - if_mod :: Module, - - -- Whether or not the IfaceDecl came from a boot - -- file or not; we'll use this to choose between - -- NoUnfolding and BootUnfolding - if_boot :: Bool, - - -- The field is used only for error reporting - -- if (say) there's a Lint error in it - if_loc :: SDoc, - -- Where the interface came from: - -- .hi file, or GHCi state, or ext core - -- plus which bit is currently being examined - - if_nsubst :: Maybe NameShape, - - -- This field is used to make sure "implicit" declarations - -- (anything that cannot be exported in mi_exports) get - -- wired up correctly in typecheckIfacesForMerging. Most - -- of the time it's @Nothing@. See Note [Resolving never-exported Names] - -- in GHC.IfaceToCore. - if_implicits_env :: Maybe TypeEnv, - - if_tv_env :: FastStringEnv TyVar, -- Nested tyvar bindings - if_id_env :: FastStringEnv Id -- Nested id binding - } - -{- -************************************************************************ -* * - Desugarer monad -* * -************************************************************************ - -Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around -a @UniqueSupply@ and some annotations, which -presumably include source-file location information: --} - -data DsGblEnv - = DsGblEnv - { ds_mod :: Module -- For SCC profiling - , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env - , ds_unqual :: PrintUnqualified - , ds_msgs :: IORef Messages -- Warning messages - , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, - -- possibly-imported things - , ds_complete_matches :: CompleteMatchMap - -- Additional complete pattern matches - , ds_cc_st :: IORef CostCentreState - -- Tracking indices for cost centre annotations - } - -instance ContainsModule DsGblEnv where - extractModule = ds_mod - -data DsLclEnv = DsLclEnv { - dsl_meta :: DsMetaEnv, -- Template Haskell bindings - dsl_loc :: RealSrcSpan, -- To put in pattern-matching error msgs - - -- See Note [Note [Type and Term Equality Propagation] in Check.hs - -- The set of reaching values Deltas is augmented as we walk inwards, - -- refined through each pattern match in turn - dsl_deltas :: Deltas - } - --- Inside [| |] brackets, the desugarer looks --- up variables in the DsMetaEnv -type DsMetaEnv = NameEnv DsMetaVal - -data DsMetaVal - = DsBound Id -- Bound by a pattern inside the [| |]. - -- Will be dynamically alpha renamed. - -- The Id has type THSyntax.Var - - | DsSplice (HsExpr GhcTc) -- These bindings are introduced by - -- the PendingSplices on a HsBracketOut - - -{- -************************************************************************ -* * - Global typechecker environment -* * -************************************************************************ --} - --- | 'FrontendResult' describes the result of running the frontend of a Haskell --- module. Currently one always gets a 'FrontendTypecheck', since running the --- frontend involves typechecking a program. hs-sig merges are not handled here. --- --- This data type really should be in GHC.Driver.Types, but it needs --- to have a TcGblEnv which is only defined here. -data FrontendResult - = FrontendTypecheck TcGblEnv - --- Note [Identity versus semantic module] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- When typechecking an hsig file, it is convenient to keep track --- of two different "this module" identifiers: --- --- - The IDENTITY module is simply thisPackage + the module --- name; i.e. it uniquely *identifies* the interface file --- we're compiling. For example, p[A=<A>]:A is an --- identity module identifying the requirement named A --- from library p. --- --- - The SEMANTIC module, which is the actual module that --- this signature is intended to represent (e.g. if --- we have a identity module p[A=base:Data.IORef]:A, --- then the semantic module is base:Data.IORef) --- --- Which one should you use? --- --- - In the desugarer and later phases of compilation, --- identity and semantic modules coincide, since we never compile --- signatures (we just generate blank object files for --- hsig files.) --- --- A corrolary of this is that the following invariant holds at any point --- past desugaring, --- --- if I have a Module, this_mod, in hand representing the module --- currently being compiled, --- then moduleUnitId this_mod == thisPackage dflags --- --- - For any code involving Names, we want semantic modules. --- See lookupIfaceTop in GHC.Iface.Env, mkIface and addFingerprints --- in GHC.Iface.{Make,Recomp}, and tcLookupGlobal in TcEnv --- --- - When reading interfaces, we want the identity module to --- identify the specific interface we want (such interfaces --- should never be loaded into the EPS). However, if a --- hole module <A> is requested, we look for A.hi --- in the home library we are compiling. (See GHC.Iface.Load.) --- Similarly, in GHC.Rename.Names we check for self-imports using --- identity modules, to allow signatures to import their implementor. --- --- - For recompilation avoidance, you want the identity module, --- since that will actually say the specific interface you --- want to track (and recompile if it changes) - --- | 'TcGblEnv' describes the top-level of the module at the --- point at which the typechecker is finished work. --- It is this structure that is handed on to the desugarer --- For state that needs to be updated during the typechecking --- phase and returned at end, use a 'TcRef' (= 'IORef'). -data TcGblEnv - = TcGblEnv { - tcg_mod :: Module, -- ^ Module being compiled - tcg_semantic_mod :: Module, -- ^ If a signature, the backing module - -- See also Note [Identity versus semantic module] - tcg_src :: HscSource, - -- ^ What kind of module (regular Haskell, hs-boot, hsig) - - tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming - tcg_default :: Maybe [Type], - -- ^ Types used for defaulting. @Nothing@ => no @default@ decl - - tcg_fix_env :: FixityEnv, -- ^ Just for things in this module - tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module - -- See Note [The interactive package] in GHC.Driver.Types - - tcg_type_env :: TypeEnv, - -- ^ Global type env for the module we are compiling now. All - -- TyCons and Classes (for this module) end up in here right away, - -- along with their derived constructors, selectors. - -- - -- (Ids defined in this module start in the local envt, though they - -- move to the global envt during zonking) - -- - -- NB: for what "things in this module" means, see - -- Note [The interactive package] in GHC.Driver.Types - - tcg_type_env_var :: TcRef TypeEnv, - -- Used only to initialise the interface-file - -- typechecker in initIfaceTcRn, so that it can see stuff - -- bound in this module when dealing with hi-boot recursions - -- Updated at intervals (e.g. after dealing with types and classes) - - tcg_inst_env :: !InstEnv, - -- ^ Instance envt for all /home-package/ modules; - -- Includes the dfuns in tcg_insts - -- NB. BangPattern is to fix a leak, see #15111 - tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances - -- NB. BangPattern is to fix a leak, see #15111 - tcg_ann_env :: AnnEnv, -- ^ And for annotations - - -- Now a bunch of things about this module that are simply - -- accumulated, but never consulted until the end. - -- Nevertheless, it's convenient to accumulate them along - -- with the rest of the info from this module. - tcg_exports :: [AvailInfo], -- ^ What is exported - tcg_imports :: ImportAvails, - -- ^ Information about what was imported from where, including - -- things bound in this module. Also store Safe Haskell info - -- here about transitive trusted package requirements. - -- - -- There are not many uses of this field, so you can grep for - -- all them. - -- - -- The ImportAvails records information about the following - -- things: - -- - -- 1. All of the modules you directly imported (tcRnImports) - -- 2. The orphans (only!) of all imported modules in a GHCi - -- session (runTcInteractive) - -- 3. The module that instantiated a signature - -- 4. Each of the signatures that merged in - -- - -- It is used in the following ways: - -- - imp_orphs is used to determine what orphan modules should be - -- visible in the context (tcVisibleOrphanMods) - -- - imp_finsts is used to determine what family instances should - -- be visible (tcExtendLocalFamInstEnv) - -- - To resolve the meaning of the export list of a module - -- (tcRnExports) - -- - imp_mods is used to compute usage info (mkIfaceTc, deSugar) - -- - imp_trust_own_pkg is used for Safe Haskell in interfaces - -- (mkIfaceTc, as well as in GHC.Driver.Main) - -- - To create the Dependencies field in interface (mkDependencies) - - -- These three fields track unused bindings and imports - -- See Note [Tracking unused binding and imports] - tcg_dus :: DefUses, - tcg_used_gres :: TcRef [GlobalRdrElt], - tcg_keep :: TcRef NameSet, - - tcg_th_used :: TcRef Bool, - -- ^ @True@ <=> Template Haskell syntax used. - -- - -- We need this so that we can generate a dependency on the - -- Template Haskell package, because the desugarer is going - -- to emit loads of references to TH symbols. The reference - -- is implicit rather than explicit, so we have to zap a - -- mutable variable. - - tcg_th_splice_used :: TcRef Bool, - -- ^ @True@ <=> A Template Haskell splice was used. - -- - -- Splices disable recompilation avoidance (see #481) - - tcg_dfun_n :: TcRef OccSet, - -- ^ Allows us to choose unique DFun names. - - tcg_merged :: [(Module, Fingerprint)], - -- ^ The requirements we merged with; we always have to recompile - -- if any of these changed. - - -- The next fields accumulate the payload of the module - -- The binds, rules and foreign-decl fields are collected - -- initially in un-zonked form and are finally zonked in tcRnSrcDecls - - tcg_rn_exports :: Maybe [(Located (IE GhcRn), Avails)], - -- Nothing <=> no explicit export list - -- Is always Nothing if we don't want to retain renamed - -- exports. - -- If present contains each renamed export list item - -- together with its exported names. - - tcg_rn_imports :: [LImportDecl GhcRn], - -- Keep the renamed imports regardless. They are not - -- voluminous and are needed if you want to report unused imports - - tcg_rn_decls :: Maybe (HsGroup GhcRn), - -- ^ Renamed decls, maybe. @Nothing@ <=> Don't retain renamed - -- decls. - - tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile - - tcg_th_topdecls :: TcRef [LHsDecl GhcPs], - -- ^ Top-level declarations from addTopDecls - - tcg_th_foreign_files :: TcRef [(ForeignSrcLang, FilePath)], - -- ^ Foreign files emitted from TH. - - tcg_th_topnames :: TcRef NameSet, - -- ^ Exact names bound in top-level declarations in tcg_th_topdecls - - tcg_th_modfinalizers :: TcRef [(TcLclEnv, ThModFinalizers)], - -- ^ Template Haskell module finalizers. - -- - -- They can use particular local environments. - - tcg_th_coreplugins :: TcRef [String], - -- ^ Core plugins added by Template Haskell code. - - tcg_th_state :: TcRef (Map TypeRep Dynamic), - tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))), - -- ^ Template Haskell state - - tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings - - -- Things defined in this module, or (in GHCi) - -- in the declarations for a single GHCi command. - -- For the latter, see Note [The interactive package] in GHC.Driver.Types - tcg_tr_module :: Maybe Id, -- Id for $trModule :: GHC.Types.Module - -- for which every module has a top-level defn - -- except in GHCi in which case we have Nothing - tcg_binds :: LHsBinds GhcTc, -- Value bindings in this module - tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature - tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids - tcg_warns :: Warnings, -- ...Warnings and deprecations - tcg_anns :: [Annotation], -- ...Annotations - tcg_tcs :: [TyCon], -- ...TyCons and Classes - tcg_insts :: [ClsInst], -- ...Instances - tcg_fam_insts :: [FamInst], -- ...Family instances - tcg_rules :: [LRuleDecl GhcTc], -- ...Rules - tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports - tcg_patsyns :: [PatSyn], -- ...Pattern synonyms - - tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs - tcg_hpc :: !AnyHpcUsage, -- ^ @True@ if any part of the - -- prog uses hpc instrumentation. - -- NB. BangPattern is to fix a leak, see #15111 - - tcg_self_boot :: SelfBootInfo, -- ^ Whether this module has a - -- corresponding hi-boot file - - tcg_main :: Maybe Name, -- ^ The Name of the main - -- function, if this module is - -- the main module. - - tcg_safeInfer :: TcRef (Bool, WarningMessages), - -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell) - -- See Note [Safe Haskell Overlapping Instances Implementation], - -- although this is used for more than just that failure case. - - tcg_tc_plugins :: [TcPluginSolver], - -- ^ A list of user-defined plugins for the constraint solver. - tcg_hf_plugins :: [HoleFitPlugin], - -- ^ A list of user-defined plugins for hole fit suggestions. - - tcg_top_loc :: RealSrcSpan, - -- ^ The RealSrcSpan this module came from - - tcg_static_wc :: TcRef WantedConstraints, - -- ^ Wanted constraints of static forms. - -- See Note [Constraints in static forms]. - tcg_complete_matches :: [CompleteMatch], - - -- ^ Tracking indices for cost centre annotations - tcg_cc_st :: TcRef CostCentreState - } - --- NB: topModIdentity, not topModSemantic! --- Definition sites of orphan identities will be identity modules, not semantic --- modules. - --- Note [Constraints in static forms] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- When a static form produces constraints like --- --- f :: StaticPtr (Bool -> String) --- f = static show --- --- we collect them in tcg_static_wc and resolve them at the end --- of type checking. They need to be resolved separately because --- we don't want to resolve them in the context of the enclosing --- expression. Consider --- --- g :: Show a => StaticPtr (a -> String) --- g = static show --- --- If the @Show a0@ constraint that the body of the static form produces was --- resolved in the context of the enclosing expression, then the body of the --- static form wouldn't be closed because the Show dictionary would come from --- g's context instead of coming from the top level. - -tcVisibleOrphanMods :: TcGblEnv -> ModuleSet -tcVisibleOrphanMods tcg_env - = mkModuleSet (tcg_mod tcg_env : imp_orphs (tcg_imports tcg_env)) - -instance ContainsModule TcGblEnv where - extractModule env = tcg_semantic_mod env - -type RecFieldEnv = NameEnv [FieldLabel] - -- Maps a constructor name *in this module* - -- to the fields for that constructor. - -- This is used when dealing with ".." notation in record - -- construction and pattern matching. - -- The FieldEnv deals *only* with constructors defined in *this* - -- module. For imported modules, we get the same info from the - -- TypeEnv - -data SelfBootInfo - = NoSelfBoot -- No corresponding hi-boot file - | SelfBoot - { sb_mds :: ModDetails -- There was a hi-boot file, - , sb_tcs :: NameSet } -- defining these TyCons, --- What is sb_tcs used for? See Note [Extra dependencies from .hs-boot files] --- in GHC.Rename.Source - - -{- Note [Tracking unused binding and imports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We gather three sorts of usage information - - * tcg_dus :: DefUses (defs/uses) - Records what is defined in this module and what is used. - - Records *defined* Names (local, top-level) - and *used* Names (local or imported) - - Used (a) to report "defined but not used" - (see GHC.Rename.Names.reportUnusedNames) - (b) to generate version-tracking usage info in interface - files (see GHC.Iface.Make.mkUsedNames) - This usage info is mainly gathered by the renamer's - gathering of free-variables - - * tcg_used_gres :: TcRef [GlobalRdrElt] - Records occurrences of imported entities. - - Used only to report unused import declarations - - Records each *occurrence* an *imported* (not locally-defined) entity. - The occurrence is recorded by keeping a GlobalRdrElt for it. - These is not the GRE that is in the GlobalRdrEnv; rather it - is recorded *after* the filtering done by pickGREs. So it reflect - /how that occurrence is in scope/. See Note [GRE filtering] in - RdrName. - - * tcg_keep :: TcRef NameSet - Records names of the type constructors, data constructors, and Ids that - are used by the constraint solver. - - The typechecker may use find that some imported or - locally-defined things are used, even though they - do not appear to be mentioned in the source code: - - (a) The to/from functions for generic data types - - (b) Top-level variables appearing free in the RHS of an - orphan rule - - (c) Top-level variables appearing free in a TH bracket - See Note [Keeping things alive for Template Haskell] - in GHC.Rename.Splice - - (d) The data constructor of a newtype that is used - to solve a Coercible instance (e.g. #10347). Example - module T10347 (N, mkN) where - import Data.Coerce - newtype N a = MkN Int - mkN :: Int -> N a - mkN = coerce - - Then we wish to record `MkN` as used, since it is (morally) - used to perform the coercion in `mkN`. To do so, the - Coercible solver updates tcg_keep's TcRef whenever it - encounters a use of `coerce` that crosses newtype boundaries. - - The tcg_keep field is used in two distinct ways: - - * Desugar.addExportFlagsAndRules. Where things like (a-c) are locally - defined, we should give them an an Exported flag, so that the - simplifier does not discard them as dead code, and so that they are - exposed in the interface file (but not to export to the user). - - * GHC.Rename.Names.reportUnusedNames. Where newtype data constructors - like (d) are imported, we don't want to report them as unused. - - -************************************************************************ -* * - The local typechecker environment -* * -************************************************************************ - -Note [The Global-Env/Local-Env story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During type checking, we keep in the tcg_type_env - * All types and classes - * All Ids derived from types and classes (constructors, selectors) - -At the end of type checking, we zonk the local bindings, -and as we do so we add to the tcg_type_env - * Locally defined top-level Ids - -Why? Because they are now Ids not TcIds. This final GlobalEnv is - a) fed back (via the knot) to typechecking the - unfoldings of interface signatures - b) used in the ModDetails of this module --} - -data TcLclEnv -- Changes as we move inside an expression - -- Discarded after typecheck/rename; not passed on to desugarer - = TcLclEnv { - tcl_loc :: RealSrcSpan, -- Source span - tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top - tcl_tclvl :: TcLevel, -- Birthplace for new unification variables - - tcl_th_ctxt :: ThStage, -- Template Haskell context - tcl_th_bndrs :: ThBindEnv, -- and binder info - -- The ThBindEnv records the TH binding level of in-scope Names - -- defined in this module (not imported) - -- We can't put this info in the TypeEnv because it's needed - -- (and extended) in the renamer, for untyed splices - - tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context - - tcl_rdr :: LocalRdrEnv, -- Local name envt - -- Maintained during renaming, of course, but also during - -- type checking, solely so that when renaming a Template-Haskell - -- splice we have the right environment for the renamer. - -- - -- Does *not* include global name envt; may shadow it - -- Includes both ordinary variables and type variables; - -- they are kept distinct because tyvar have a different - -- occurrence constructor (Name.TvOcc) - -- We still need the unsullied global name env so that - -- we can look up record field names - - tcl_env :: TcTypeEnv, -- The local type environment: - -- Ids and TyVars defined in this module - - tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, - -- and for tidying types - - tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints - tcl_errs :: TcRef Messages -- Place to accumulate errors - } - -setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv -setLclEnvTcLevel env lvl = env { tcl_tclvl = lvl } - -getLclEnvTcLevel :: TcLclEnv -> TcLevel -getLclEnvTcLevel = tcl_tclvl - -setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv -setLclEnvLoc env loc = env { tcl_loc = loc } - -getLclEnvLoc :: TcLclEnv -> RealSrcSpan -getLclEnvLoc = tcl_loc - -type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) - -- Monadic so that we have a chance - -- to deal with bound type variables just before error - -- message construction - - -- Bool: True <=> this is a landmark context; do not - -- discard it when trimming for display - --- These are here to avoid module loops: one might expect them --- in Constraint, but they refer to ErrCtxt which refers to TcM. --- Easier to just keep these definitions here, alongside TcM. -pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc -pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) - = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } - -pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc --- Just add information w/o updating the origin! -pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl }) - = loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } - -type TcTypeEnv = NameEnv TcTyThing - -type ThBindEnv = NameEnv (TopLevelFlag, ThLevel) - -- Domain = all Ids bound in this module (ie not imported) - -- The TopLevelFlag tells if the binding is syntactically top level. - -- We need to know this, because the cross-stage persistence story allows - -- cross-stage at arbitrary types if the Id is bound at top level. - -- - -- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being - -- bound at top level! See Note [Template Haskell levels] in TcSplice - -{- Note [Given Insts] - ~~~~~~~~~~~~~~~~~~ -Because of GADTs, we have to pass inwards the Insts provided by type signatures -and existential contexts. Consider - data T a where { T1 :: b -> b -> T [b] } - f :: Eq a => T a -> Bool - f (T1 x y) = [x]==[y] - -The constructor T1 binds an existential variable 'b', and we need Eq [b]. -Well, we have it, because Eq a refines to Eq [b], but we can only spot that if we -pass it inwards. - --} - --- | Type alias for 'IORef'; the convention is we'll use this for mutable --- bits of data in 'TcGblEnv' which are updated during typechecking and --- returned at the end. -type TcRef a = IORef a --- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'? -type TcId = Id -type TcIdSet = IdSet - ---------------------------- --- The TcBinderStack ---------------------------- - -type TcBinderStack = [TcBinder] - -- This is a stack of locally-bound ids and tyvars, - -- innermost on top - -- Used only in error reporting (relevantBindings in TcError), - -- and in tidying - -- We can't use the tcl_env type environment, because it doesn't - -- keep track of the nesting order - -data TcBinder - = TcIdBndr - TcId - TopLevelFlag -- Tells whether the binding is syntactically top-level - -- (The monomorphic Ids for a recursive group count - -- as not-top-level for this purpose.) - - | TcIdBndr_ExpType -- Variant that allows the type to be specified as - -- an ExpType - Name - ExpType - TopLevelFlag - - | TcTvBndr -- e.g. case x of P (y::a) -> blah - Name -- We bind the lexical name "a" to the type of y, - TyVar -- which might be an utterly different (perhaps - -- existential) tyvar - -instance Outputable TcBinder where - ppr (TcIdBndr id top_lvl) = ppr id <> brackets (ppr top_lvl) - ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl) - ppr (TcTvBndr name tv) = ppr name <+> ppr tv - -instance HasOccName TcBinder where - occName (TcIdBndr id _) = occName (idName id) - occName (TcIdBndr_ExpType name _ _) = occName name - occName (TcTvBndr name _) = occName name - --- fixes #12177 --- Builds up a list of bindings whose OccName has not been seen before --- i.e., If ys = removeBindingShadowing xs --- then --- - ys is obtained from xs by deleting some elements --- - ys has no duplicate OccNames --- - The first duplicated OccName in xs is retained in ys --- Overloaded so that it can be used for both GlobalRdrElt in typed-hole --- substitutions and TcBinder when looking for relevant bindings. -removeBindingShadowing :: HasOccName a => [a] -> [a] -removeBindingShadowing bindings = reverse $ fst $ foldl - (\(bindingAcc, seenNames) binding -> - if occName binding `elemOccSet` seenNames -- if we've seen it - then (bindingAcc, seenNames) -- skip it - else (binding:bindingAcc, extendOccSet seenNames (occName binding))) - ([], emptyOccSet) bindings - ---------------------------- --- Template Haskell stages and levels ---------------------------- - -data SpliceType = Typed | Untyped - -data ThStage -- See Note [Template Haskell state diagram] - -- and Note [Template Haskell levels] in TcSplice - -- Start at: Comp - -- At bracket: wrap current stage in Brack - -- At splice: currently Brack: return to previous stage - -- currently Comp/Splice: compile and run - = Splice SpliceType -- Inside a top-level splice - -- This code will be run *at compile time*; - -- the result replaces the splice - -- Binding level = 0 - - | RunSplice (TcRef [ForeignRef (TH.Q ())]) - -- Set when running a splice, i.e. NOT when renaming or typechecking the - -- Haskell code for the splice. See Note [RunSplice ThLevel]. - -- - -- Contains a list of mod finalizers collected while executing the splice. - -- - -- 'addModFinalizer' inserts finalizers here, and from here they are taken - -- to construct an @HsSpliced@ annotation for untyped splices. See Note - -- [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. - -- - -- For typed splices, the typechecker takes finalizers from here and - -- inserts them in the list of finalizers in the global environment. - -- - -- See Note [Collecting modFinalizers in typed splices] in "TcSplice". - - | Comp -- Ordinary Haskell code - -- Binding level = 1 - - | Brack -- Inside brackets - ThStage -- Enclosing stage - PendingStuff - -data PendingStuff - = RnPendingUntyped -- Renaming the inside of an *untyped* bracket - (TcRef [PendingRnSplice]) -- Pending splices in here - - | RnPendingTyped -- Renaming the inside of a *typed* bracket - - | TcPending -- Typechecking the inside of a typed bracket - (TcRef [PendingTcSplice]) -- Accumulate pending splices here - (TcRef WantedConstraints) -- and type constraints here - QuoteWrapper -- A type variable and evidence variable - -- for the overall monad of - -- the bracket. Splices are checked - -- against this monad. The evidence - -- variable is used for desugaring - -- `lift`. - - -topStage, topAnnStage, topSpliceStage :: ThStage -topStage = Comp -topAnnStage = Splice Untyped -topSpliceStage = Splice Untyped - -instance Outputable ThStage where - ppr (Splice _) = text "Splice" - ppr (RunSplice _) = text "RunSplice" - ppr Comp = text "Comp" - ppr (Brack s _) = text "Brack" <> parens (ppr s) - -type ThLevel = Int - -- NB: see Note [Template Haskell levels] in TcSplice - -- Incremented when going inside a bracket, - -- decremented when going inside a splice - -- NB: ThLevel is one greater than the 'n' in Fig 2 of the - -- original "Template meta-programming for Haskell" paper - -impLevel, outerLevel :: ThLevel -impLevel = 0 -- Imported things; they can be used inside a top level splice -outerLevel = 1 -- Things defined outside brackets - -thLevel :: ThStage -> ThLevel -thLevel (Splice _) = 0 -thLevel Comp = 1 -thLevel (Brack s _) = thLevel s + 1 -thLevel (RunSplice _) = panic "thLevel: called when running a splice" - -- See Note [RunSplice ThLevel]. - -{- Node [RunSplice ThLevel] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The 'RunSplice' stage is set when executing a splice, and only when running a -splice. In particular it is not set when the splice is renamed or typechecked. - -'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert -the finalizer (see Note [Delaying modFinalizers in untyped splices]), and -'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to -set 'RunSplice' when renaming or typechecking the splice, where 'Splice', -'Brack' or 'Comp' are used instead. - --} - ---------------------------- --- Arrow-notation context ---------------------------- - -{- Note [Escaping the arrow scope] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In arrow notation, a variable bound by a proc (or enclosed let/kappa) -is not in scope to the left of an arrow tail (-<) or the head of (|..|). -For example - - proc x -> (e1 -< e2) - -Here, x is not in scope in e1, but it is in scope in e2. This can get -a bit complicated: - - let x = 3 in - proc y -> (proc z -> e1) -< e2 - -Here, x and z are in scope in e1, but y is not. - -We implement this by -recording the environment when passing a proc (using newArrowScope), -and returning to that (using escapeArrowScope) on the left of -< and the -head of (|..|). - -All this can be dealt with by the *renamer*. But the type checker needs -to be involved too. Example (arrowfail001) - class Foo a where foo :: a -> () - data Bar = forall a. Foo a => Bar a - get :: Bar -> () - get = proc x -> case x of Bar a -> foo -< a -Here the call of 'foo' gives rise to a (Foo a) constraint that should not -be captured by the pattern match on 'Bar'. Rather it should join the -constraints from further out. So we must capture the constraint bag -from further out in the ArrowCtxt that we push inwards. --} - -data ArrowCtxt -- Note [Escaping the arrow scope] - = NoArrowCtxt - | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints) - - ---------------------------- --- TcTyThing ---------------------------- - --- | A typecheckable thing available in a local context. Could be --- 'AGlobal' 'TyThing', but also lexically scoped variables, etc. --- See 'TcEnv' for how to retrieve a 'TyThing' given a 'Name'. -data TcTyThing - = AGlobal TyThing -- Used only in the return type of a lookup - - | ATcId -- Ids defined in this module; may not be fully zonked - { tct_id :: TcId - , tct_info :: IdBindingInfo -- See Note [Meaning of IdBindingInfo] - } - - | ATyVar Name TcTyVar -- See Note [Type variables in the type environment] - - | ATcTyCon TyCon -- Used temporarily, during kind checking, for the - -- tycons and clases in this recursive group - -- The TyCon is always a TcTyCon. Its kind - -- can be a mono-kind or a poly-kind; in TcTyClsDcls see - -- Note [Type checking recursive type and class declarations] - - | APromotionErr PromotionErr - -data PromotionErr - = TyConPE -- TyCon used in a kind before we are ready - -- data T :: T -> * where ... - | ClassPE -- Ditto Class - - | FamDataConPE -- Data constructor for a data family - -- See Note [AFamDataCon: not promoting data family constructors] - -- in TcEnv. - | ConstrainedDataConPE PredType - -- Data constructor with a non-equality context - -- See Note [Don't promote data constructors with - -- non-equality contexts] in TcHsType - | PatSynPE -- Pattern synonyms - -- See Note [Don't promote pattern synonyms] in TcEnv - - | RecDataConPE -- Data constructor in a recursive loop - -- See Note [Recursion and promoting data constructors] in TcTyClsDecls - | NoDataKindsTC -- -XDataKinds not enabled (for a tycon) - | NoDataKindsDC -- -XDataKinds not enabled (for a datacon) - -instance Outputable TcTyThing where -- Debugging only - ppr (AGlobal g) = ppr g - ppr elt@(ATcId {}) = text "Identifier" <> - brackets (ppr (tct_id elt) <> dcolon - <> ppr (varType (tct_id elt)) <> comma - <+> ppr (tct_info elt)) - ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv - <+> dcolon <+> ppr (varType tv) - ppr (ATcTyCon tc) = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc) - ppr (APromotionErr err) = text "APromotionErr" <+> ppr err - --- | IdBindingInfo describes how an Id is bound. --- --- It is used for the following purposes: --- a) for static forms in TcExpr.checkClosedInStaticForm and --- b) to figure out when a nested binding can be generalised, --- in TcBinds.decideGeneralisationPlan. --- -data IdBindingInfo -- See Note [Meaning of IdBindingInfo and ClosedTypeId] - = NotLetBound - | ClosedLet - | NonClosedLet - RhsNames -- Used for (static e) checks only - ClosedTypeId -- Used for generalisation checks - -- and for (static e) checks - --- | IsGroupClosed describes a group of mutually-recursive bindings -data IsGroupClosed - = IsGroupClosed - (NameEnv RhsNames) -- Free var info for the RHS of each binding in the goup - -- Used only for (static e) checks - - ClosedTypeId -- True <=> all the free vars of the group are - -- imported or ClosedLet or - -- NonClosedLet with ClosedTypeId=True. - -- In particular, no tyvars, no NotLetBound - -type RhsNames = NameSet -- Names of variables, mentioned on the RHS of - -- a definition, that are not Global or ClosedLet - -type ClosedTypeId = Bool - -- See Note [Meaning of IdBindingInfo and ClosedTypeId] - -{- Note [Meaning of IdBindingInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NotLetBound means that - the Id is not let-bound (e.g. it is bound in a - lambda-abstraction or in a case pattern) - -ClosedLet means that - - The Id is let-bound, - - Any free term variables are also Global or ClosedLet - - Its type has no free variables (NB: a top-level binding subject - to the MR might have free vars in its type) - These ClosedLets can definitely be floated to top level; and we - may need to do so for static forms. - - Property: ClosedLet - is equivalent to - NonClosedLet emptyNameSet True - -(NonClosedLet (fvs::RhsNames) (cl::ClosedTypeId)) means that - - The Id is let-bound - - - The fvs::RhsNames contains the free names of the RHS, - excluding Global and ClosedLet ones. - - - For the ClosedTypeId field see Note [Bindings with closed types] - -For (static e) to be valid, we need for every 'x' free in 'e', -that x's binding is floatable to the top level. Specifically: - * x's RhsNames must be empty - * x's type has no free variables -See Note [Grand plan for static forms] in StaticPtrTable.hs. -This test is made in TcExpr.checkClosedInStaticForm. -Actually knowing x's RhsNames (rather than just its emptiness -or otherwise) is just so we can produce better error messages - -Note [Bindings with closed types: ClosedTypeId] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - f x = let g ys = map not ys - in ... - -Can we generalise 'g' under the OutsideIn algorithm? Yes, -because all g's free variables are top-level; that is they themselves -have no free type variables, and it is the type variables in the -environment that makes things tricky for OutsideIn generalisation. - -Here's the invariant: - If an Id has ClosedTypeId=True (in its IdBindingInfo), then - the Id's type is /definitely/ closed (has no free type variables). - Specifically, - a) The Id's actual type is closed (has no free tyvars) - b) Either the Id has a (closed) user-supplied type signature - or all its free variables are Global/ClosedLet - or NonClosedLet with ClosedTypeId=True. - In particular, none are NotLetBound. - -Why is (b) needed? Consider - \x. (x :: Int, let y = x+1 in ...) -Initially x::alpha. If we happen to typecheck the 'let' before the -(x::Int), y's type will have a free tyvar; but if the other way round -it won't. So we treat any let-bound variable with a free -non-let-bound variable as not ClosedTypeId, regardless of what the -free vars of its type actually are. - -But if it has a signature, all is well: - \x. ...(let { y::Int; y = x+1 } in - let { v = y+2 } in ...)... -Here the signature on 'v' makes 'y' a ClosedTypeId, so we can -generalise 'v'. - -Note that: - - * A top-level binding may not have ClosedTypeId=True, if it suffers - from the MR - - * A nested binding may be closed (eg 'g' in the example we started - with). Indeed, that's the point; whether a function is defined at - top level or nested is orthogonal to the question of whether or - not it is closed. - - * A binding may be non-closed because it mentions a lexically scoped - *type variable* Eg - f :: forall a. blah - f x = let g y = ...(y::a)... - -Under OutsideIn we are free to generalise an Id all of whose free -variables have ClosedTypeId=True (or imported). This is an extension -compared to the JFP paper on OutsideIn, which used "top-level" as a -proxy for "closed". (It's not a good proxy anyway -- the MR can make -a top-level binding with a free type variable.) - -Note [Type variables in the type environment] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type environment has a binding for each lexically-scoped -type variable that is in scope. For example - - f :: forall a. a -> a - f x = (x :: a) - - g1 :: [a] -> a - g1 (ys :: [b]) = head ys :: b - - g2 :: [Int] -> Int - g2 (ys :: [c]) = head ys :: c - -* The forall'd variable 'a' in the signature scopes over f's RHS. - -* The pattern-bound type variable 'b' in 'g1' scopes over g1's - RHS; note that it is bound to a skolem 'a' which is not itself - lexically in scope. - -* The pattern-bound type variable 'c' in 'g2' is bound to - Int; that is, pattern-bound type variables can stand for - arbitrary types. (see - GHC proposal #128 "Allow ScopedTypeVariables to refer to types" - https://github.com/ghc-proposals/ghc-proposals/pull/128, - and the paper - "Type variables in patterns", Haskell Symposium 2018. - - -This is implemented by the constructor - ATyVar Name TcTyVar -in the type environment. - -* The Name is the name of the original, lexically scoped type - variable - -* The TcTyVar is sometimes a skolem (like in 'f'), and sometimes - a unification variable (like in 'g1', 'g2'). We never zonk the - type environment so in the latter case it always stays as a - unification variable, although that variable may be later - unified with a type (such as Int in 'g2'). --} - -instance Outputable IdBindingInfo where - ppr NotLetBound = text "NotLetBound" - ppr ClosedLet = text "TopLevelLet" - ppr (NonClosedLet fvs closed_type) = - text "TopLevelLet" <+> ppr fvs <+> ppr closed_type - -instance Outputable PromotionErr where - ppr ClassPE = text "ClassPE" - ppr TyConPE = text "TyConPE" - ppr PatSynPE = text "PatSynPE" - ppr FamDataConPE = text "FamDataConPE" - ppr (ConstrainedDataConPE pred) = text "ConstrainedDataConPE" - <+> parens (ppr pred) - ppr RecDataConPE = text "RecDataConPE" - ppr NoDataKindsTC = text "NoDataKindsTC" - ppr NoDataKindsDC = text "NoDataKindsDC" - -pprTcTyThingCategory :: TcTyThing -> SDoc -pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing -pprTcTyThingCategory (ATyVar {}) = text "Type variable" -pprTcTyThingCategory (ATcId {}) = text "Local identifier" -pprTcTyThingCategory (ATcTyCon {}) = text "Local tycon" -pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe - -pprPECategory :: PromotionErr -> SDoc -pprPECategory ClassPE = text "Class" -pprPECategory TyConPE = text "Type constructor" -pprPECategory PatSynPE = text "Pattern synonym" -pprPECategory FamDataConPE = text "Data constructor" -pprPECategory ConstrainedDataConPE{} = text "Data constructor" -pprPECategory RecDataConPE = text "Data constructor" -pprPECategory NoDataKindsTC = text "Type constructor" -pprPECategory NoDataKindsDC = text "Data constructor" - -{- -************************************************************************ -* * - Operations over ImportAvails -* * -************************************************************************ --} - --- | 'ImportAvails' summarises what was imported from where, irrespective of --- whether the imported things are actually used or not. It is used: --- --- * when processing the export list, --- --- * when constructing usage info for the interface file, --- --- * to identify the list of directly imported modules for initialisation --- purposes and for optimised overlap checking of family instances, --- --- * when figuring out what things are really unused --- -data ImportAvails - = ImportAvails { - imp_mods :: ImportedMods, - -- = ModuleEnv [ImportedModsVal], - -- ^ Domain is all directly-imported modules - -- - -- See the documentation on ImportedModsVal in GHC.Driver.Types for the - -- meaning of the fields. - -- - -- We need a full ModuleEnv rather than a ModuleNameEnv here, - -- because we might be importing modules of the same name from - -- different packages. (currently not the case, but might be in the - -- future). - - imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), - -- ^ Home-package modules needed by the module being compiled - -- - -- It doesn't matter whether any of these dependencies - -- are actually /used/ when compiling the module; they - -- are listed if they are below it at all. For - -- example, suppose M imports A which imports X. Then - -- compiling M might not need to consult X.hi, but X - -- is still listed in M's dependencies. - - imp_dep_pkgs :: Set InstalledUnitId, - -- ^ Packages needed by the module being compiled, whether directly, - -- or via other modules in this package, or via modules imported - -- from other packages. - - imp_trust_pkgs :: Set InstalledUnitId, - -- ^ This is strictly a subset of imp_dep_pkgs and records the - -- packages the current module needs to trust for Safe Haskell - -- compilation to succeed. A package is required to be trusted if - -- we are dependent on a trustworthy module in that package. - -- While perhaps making imp_dep_pkgs a tuple of (UnitId, Bool) - -- where True for the bool indicates the package is required to be - -- trusted is the more logical design, doing so complicates a lot - -- of code not concerned with Safe Haskell. - -- See Note [Tracking Trust Transitively] in GHC.Rename.Names - - imp_trust_own_pkg :: Bool, - -- ^ Do we require that our own package is trusted? - -- This is to handle efficiently the case where a Safe module imports - -- a Trustworthy module that resides in the same package as it. - -- See Note [Trust Own Package] in GHC.Rename.Names - - imp_orphs :: [Module], - -- ^ Orphan modules below us in the import tree (and maybe including - -- us for imported modules) - - imp_finsts :: [Module] - -- ^ Family instance modules below us in the import tree (and maybe - -- including us for imported modules) - } - -mkModDeps :: [(ModuleName, IsBootInterface)] - -> ModuleNameEnv (ModuleName, IsBootInterface) -mkModDeps deps = foldl' add emptyUFM deps - where - add env elt@(m,_) = addToUFM env m elt - -modDepsElts - :: ModuleNameEnv (ModuleName, IsBootInterface) - -> [(ModuleName, IsBootInterface)] -modDepsElts = sort . nonDetEltsUFM - -- It's OK to use nonDetEltsUFM here because sorting by module names - -- restores determinism - -emptyImportAvails :: ImportAvails -emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, - imp_dep_mods = emptyUFM, - imp_dep_pkgs = S.empty, - imp_trust_pkgs = S.empty, - imp_trust_own_pkg = False, - imp_orphs = [], - imp_finsts = [] } - --- | Union two ImportAvails --- --- This function is a key part of Import handling, basically --- for each import we create a separate ImportAvails structure --- and then union them all together with this function. -plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails -plusImportAvails - (ImportAvails { imp_mods = mods1, - imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, - imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1, - imp_orphs = orphs1, imp_finsts = finsts1 }) - (ImportAvails { imp_mods = mods2, - imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, - imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, - imp_orphs = orphs2, imp_finsts = finsts2 }) - = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, - imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, - imp_dep_pkgs = dpkgs1 `S.union` dpkgs2, - imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, - imp_trust_own_pkg = tself1 || tself2, - imp_orphs = orphs1 `unionLists` orphs2, - imp_finsts = finsts1 `unionLists` finsts2 } - where - plus_mod_dep r1@(m1, boot1) r2@(m2, boot2) - | ASSERT2( m1 == m2, (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) - boot1 = r2 - | otherwise = r1 - -- If either side can "see" a non-hi-boot interface, use that - -- Reusing existing tuples saves 10% of allocations on test - -- perf/compiler/MultiLayerModules - -{- -************************************************************************ -* * -\subsection{Where from} -* * -************************************************************************ - -The @WhereFrom@ type controls where the renamer looks for an interface file --} - -data WhereFrom - = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) - | ImportBySystem -- Non user import. - | ImportByPlugin -- Importing a plugin; - -- See Note [Care with plugin imports] in GHC.Iface.Load - -instance Outputable WhereFrom where - ppr (ImportByUser is_boot) | is_boot = text "{- SOURCE -}" - | otherwise = empty - ppr ImportBySystem = text "{- SYSTEM -}" - ppr ImportByPlugin = text "{- PLUGIN -}" - - -{- ********************************************************************* -* * - Type signatures -* * -********************************************************************* -} - --- These data types need to be here only because --- TcSimplify uses them, and TcSimplify is fairly --- low down in the module hierarchy - -type TcSigFun = Name -> Maybe TcSigInfo - -data TcSigInfo = TcIdSig TcIdSigInfo - | TcPatSynSig TcPatSynInfo - -data TcIdSigInfo -- See Note [Complete and partial type signatures] - = CompleteSig -- A complete signature with no wildcards, - -- so the complete polymorphic type is known. - { sig_bndr :: TcId -- The polymorphic Id with that type - - , sig_ctxt :: UserTypeCtxt -- In the case of type-class default methods, - -- the Name in the FunSigCtxt is not the same - -- as the TcId; the former is 'op', while the - -- latter is '$dmop' or some such - - , sig_loc :: SrcSpan -- Location of the type signature - } - - | PartialSig -- A partial type signature (i.e. includes one or more - -- wildcards). In this case it doesn't make sense to give - -- the polymorphic Id, because we are going to /infer/ its - -- type, so we can't make the polymorphic Id ab-initio - { psig_name :: Name -- Name of the function; used when report wildcards - , psig_hs_ty :: LHsSigWcType GhcRn -- The original partial signature in - -- HsSyn form - , sig_ctxt :: UserTypeCtxt - , sig_loc :: SrcSpan -- Location of the type signature - } - - -{- Note [Complete and partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A type signature is partial when it contains one or more wildcards -(= type holes). The wildcard can either be: -* A (type) wildcard occurring in sig_theta or sig_tau. These are - stored in sig_wcs. - f :: Bool -> _ - g :: Eq _a => _a -> _a -> Bool -* Or an extra-constraints wildcard, stored in sig_cts: - h :: (Num a, _) => a -> a - -A type signature is a complete type signature when there are no -wildcards in the type signature, i.e. iff sig_wcs is empty and -sig_extra_cts is Nothing. --} - -data TcIdSigInst - = TISI { sig_inst_sig :: TcIdSigInfo - - , sig_inst_skols :: [(Name, TcTyVar)] - -- Instantiated type and kind variables, TyVarTvs - -- The Name is the Name that the renamer chose; - -- but the TcTyVar may come from instantiating - -- the type and hence have a different unique. - -- No need to keep track of whether they are truly lexically - -- scoped because the renamer has named them uniquely - -- See Note [Binding scoped type variables] in TcSigs - -- - -- NB: The order of sig_inst_skols is irrelevant - -- for a CompleteSig, but for a PartialSig see - -- Note [Quantified variables in partial type signatures] - - , sig_inst_theta :: TcThetaType - -- Instantiated theta. In the case of a - -- PartialSig, sig_theta does not include - -- the extra-constraints wildcard - - , sig_inst_tau :: TcSigmaType -- Instantiated tau - -- See Note [sig_inst_tau may be polymorphic] - - -- Relevant for partial signature only - , sig_inst_wcs :: [(Name, TcTyVar)] - -- Like sig_inst_skols, but for /named/ wildcards (_a etc). - -- The named wildcards scope over the binding, and hence - -- their Names may appear in type signatures in the binding - - , sig_inst_wcx :: Maybe TcType - -- Extra-constraints wildcard to fill in, if any - -- If this exists, it is surely of the form (meta_tv |> co) - -- (where the co might be reflexive). This is filled in - -- only from the return value of TcHsType.tcAnonWildCardOcc - } - -{- Note [sig_inst_tau may be polymorphic] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that "sig_inst_tau" might actually be a polymorphic type, -if the original function had a signature like - forall a. Eq a => forall b. Ord b => .... -But that's ok: tcMatchesFun (called by tcRhs) can deal with that -It happens, too! See Note [Polymorphic methods] in TcClassDcl. - -Note [Quantified variables in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall a b. _ -> a -> _ -> b - f (x,y) p q = q - -Then we expect f's final type to be - f :: forall {x,y}. forall a b. (x,y) -> a -> b -> b - -Note that x,y are Inferred, and can't be use for visible type -application (VTA). But a,b are Specified, and remain Specified -in the final type, so we can use VTA for them. (Exception: if -it turns out that a's kind mentions b we need to reorder them -with scopedSort.) - -The sig_inst_skols of the TISI from a partial signature records -that original order, and is used to get the variables of f's -final type in the correct order. - - -Note [Wildcards in partial signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wildcards in psig_wcs may stand for a type mentioning -the universally-quantified tyvars of psig_ty - -E.g. f :: forall a. _ -> a - f x = x -We get sig_inst_skols = [a] - sig_inst_tau = _22 -> a - sig_inst_wcs = [_22] -and _22 in the end is unified with the type 'a' - -Moreover the kind of a wildcard in sig_inst_wcs may mention -the universally-quantified tyvars sig_inst_skols -e.g. f :: t a -> t _ -Here we get - sig_inst_skols = [k:*, (t::k ->*), (a::k)] - sig_inst_tau = t a -> t _22 - sig_inst_wcs = [ _22::k ] --} - -data TcPatSynInfo - = TPSI { - patsig_name :: Name, - patsig_implicit_bndrs :: [TyVarBinder], -- Implicitly-bound kind vars (Inferred) and - -- implicitly-bound type vars (Specified) - -- See Note [The pattern-synonym signature splitting rule] in TcPatSyn - patsig_univ_bndrs :: [TyVar], -- Bound by explicit user forall - patsig_req :: TcThetaType, - patsig_ex_bndrs :: [TyVar], -- Bound by explicit user forall - patsig_prov :: TcThetaType, - patsig_body_ty :: TcSigmaType - } - -instance Outputable TcSigInfo where - ppr (TcIdSig idsi) = ppr idsi - ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi - -instance Outputable TcIdSigInfo where - ppr (CompleteSig { sig_bndr = bndr }) - = ppr bndr <+> dcolon <+> ppr (idType bndr) - ppr (PartialSig { psig_name = name, psig_hs_ty = hs_ty }) - = text "psig" <+> ppr name <+> dcolon <+> ppr hs_ty - -instance Outputable TcIdSigInst where - ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols - , sig_inst_theta = theta, sig_inst_tau = tau }) - = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ]) - -instance Outputable TcPatSynInfo where - ppr (TPSI{ patsig_name = name}) = ppr name - -isPartialSig :: TcIdSigInst -> Bool -isPartialSig (TISI { sig_inst_sig = PartialSig {} }) = True -isPartialSig _ = False - --- | No signature or a partial signature -hasCompleteSig :: TcSigFun -> Name -> Bool -hasCompleteSig sig_fn name - = case sig_fn name of - Just (TcIdSig (CompleteSig {})) -> True - _ -> False - - -{- -Constraint Solver Plugins -------------------------- --} - -type TcPluginSolver = [Ct] -- given - -> [Ct] -- derived - -> [Ct] -- wanted - -> TcPluginM TcPluginResult - -newtype TcPluginM a = TcPluginM (EvBindsVar -> TcM a) deriving (Functor) - -instance Applicative TcPluginM where - pure x = TcPluginM (const $ pure x) - (<*>) = ap - -instance Monad TcPluginM where - TcPluginM m >>= k = - TcPluginM (\ ev -> do a <- m ev - runTcPluginM (k a) ev) - -instance MonadFail TcPluginM where - fail x = TcPluginM (const $ fail x) - -runTcPluginM :: TcPluginM a -> EvBindsVar -> TcM a -runTcPluginM (TcPluginM m) = m - --- | This function provides an escape for direct access to --- the 'TcM` monad. It should not be used lightly, and --- the provided 'TcPluginM' API should be favoured instead. -unsafeTcPluginTcM :: TcM a -> TcPluginM a -unsafeTcPluginTcM = TcPluginM . const - --- | Access the 'EvBindsVar' carried by the 'TcPluginM' during --- constraint solving. Returns 'Nothing' if invoked during --- 'tcPluginInit' or 'tcPluginStop'. -getEvBindsTcPluginM :: TcPluginM EvBindsVar -getEvBindsTcPluginM = TcPluginM return - - -data TcPlugin = forall s. TcPlugin - { tcPluginInit :: TcPluginM s - -- ^ Initialize plugin, when entering type-checker. - - , tcPluginSolve :: s -> TcPluginSolver - -- ^ Solve some constraints. - -- TODO: WRITE MORE DETAILS ON HOW THIS WORKS. - - , tcPluginStop :: s -> TcPluginM () - -- ^ Clean up after the plugin, when exiting the type-checker. - } - -data TcPluginResult - = TcPluginContradiction [Ct] - -- ^ The plugin found a contradiction. - -- The returned constraints are removed from the inert set, - -- and recorded as insoluble. - - | TcPluginOk [(EvTerm,Ct)] [Ct] - -- ^ The first field is for constraints that were solved. - -- These are removed from the inert set, - -- and the evidence for them is recorded. - -- The second field contains new work, that should be processed by - -- the constraint solver. - -{- ********************************************************************* -* * - Role annotations -* * -********************************************************************* -} - -type RoleAnnotEnv = NameEnv (LRoleAnnotDecl GhcRn) - -mkRoleAnnotEnv :: [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv -mkRoleAnnotEnv role_annot_decls - = mkNameEnv [ (name, ra_decl) - | ra_decl <- role_annot_decls - , let name = roleAnnotDeclName (unLoc ra_decl) - , not (isUnboundName name) ] - -- Some of the role annots will be unbound; - -- we don't wish to include these - -emptyRoleAnnotEnv :: RoleAnnotEnv -emptyRoleAnnotEnv = emptyNameEnv - -lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl GhcRn) -lookupRoleAnnot = lookupNameEnv - -getRoleAnnots :: [Name] -> RoleAnnotEnv -> [LRoleAnnotDecl GhcRn] -getRoleAnnots bndrs role_env - = mapMaybe (lookupRoleAnnot role_env) bndrs diff --git a/compiler/typecheck/TcRnTypes.hs-boot b/compiler/typecheck/TcRnTypes.hs-boot deleted file mode 100644 index bd7bf07a47..0000000000 --- a/compiler/typecheck/TcRnTypes.hs-boot +++ /dev/null @@ -1,12 +0,0 @@ -module TcRnTypes where - -import TcType -import GHC.Types.SrcLoc - -data TcLclEnv - -setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv -getLclEnvTcLevel :: TcLclEnv -> TcLevel - -setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv -getLclEnvLoc :: TcLclEnv -> RealSrcSpan diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs deleted file mode 100644 index 3e32cda356..0000000000 --- a/compiler/typecheck/TcRules.hs +++ /dev/null @@ -1,499 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - - -TcRules: Typechecking transformation rules --} - -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - -module TcRules ( tcRules ) where - -import GhcPrelude - -import GHC.Hs -import TcRnTypes -import TcRnMonad -import TcSimplify -import Constraint -import GHC.Core.Predicate -import TcOrigin -import TcMType -import TcType -import TcHsType -import TcExpr -import TcEnv -import TcUnify( buildImplicationFor ) -import TcEvidence( mkTcCoVarCo ) -import GHC.Core.Type -import GHC.Core.TyCon( isTypeFamilyTyCon ) -import GHC.Types.Id -import GHC.Types.Var( EvVar ) -import GHC.Types.Var.Set -import GHC.Types.Basic ( RuleName ) -import GHC.Types.SrcLoc -import Outputable -import FastString -import Bag - -{- -Note [Typechecking rules] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We *infer* the typ of the LHS, and use that type to *check* the type of -the RHS. That means that higher-rank rules work reasonably well. Here's -an example (test simplCore/should_compile/rule2.hs) produced by Roman: - - foo :: (forall m. m a -> m b) -> m a -> m b - foo f = ... - - bar :: (forall m. m a -> m a) -> m a -> m a - bar f = ... - - {-# RULES "foo/bar" foo = bar #-} - -He wanted the rule to typecheck. - -Note [TcLevel in type checking rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Bringing type variables into scope naturally bumps the TcLevel. Thus, we type -check the term-level binders in a bumped level, and we must accordingly bump -the level whenever these binders are in scope. - -Note [Re-quantify type variables in rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example from #17710: - - foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b - foo x = Proxy - {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-} - -Written out in more detail, the "foo" rewrite rule looks like this: - - forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0 - -Where b0 is a unification variable. Where should b0 be quantified? We have to -quantify it after k, since (b0 :: k). But generalization usually puts inferred -type variables (such as b0) at the /front/ of the telescope! This creates a -conflict. - -One option is to simply throw an error, per the principles of -Note [Naughty quantification candidates] in TcMType. This is what would happen -if we were generalising over a normal type signature. On the other hand, the -types in a rewrite rule aren't quite "normal", since the notions of specified -and inferred type variables aren't applicable. - -A more permissive design (and the design that GHC uses) is to simply requantify -all of the type variables. That is, we would end up with this: - - forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b - -It's a bit strange putting the generalized variable `b` after the user-written -variables `k` and `a`. But again, the notion of specificity is not relevant to -rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not -only makes "foo" typecheck, but it also makes the implementation simpler. - -See also Note [Generalising in tcTyFamInstEqnGuts] in TcTyClsDecls, which -explains a very similar design when generalising over a type family instance -equation. --} - -tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId] -tcRules decls = mapM (wrapLocM tcRuleDecls) decls - -tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId) -tcRuleDecls (HsRules { rds_src = src - , rds_rules = decls }) - = do { tc_decls <- mapM (wrapLocM tcRule) decls - ; return $ HsRules { rds_ext = noExtField - , rds_src = src - , rds_rules = tc_decls } } -tcRuleDecls (XRuleDecls nec) = noExtCon nec - -tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId) -tcRule (HsRule { rd_ext = ext - , rd_name = rname@(L _ (_,name)) - , rd_act = act - , rd_tyvs = ty_bndrs - , rd_tmvs = tm_bndrs - , rd_lhs = lhs - , rd_rhs = rhs }) - = addErrCtxt (ruleCtxt name) $ - do { traceTc "---- Rule ------" (pprFullRuleName rname) - - -- Note [Typechecking rules] - ; (tc_lvl, stuff) <- pushTcLevelM $ - generateRuleConstraints ty_bndrs tm_bndrs lhs rhs - - ; let (id_bndrs, lhs', lhs_wanted - , rhs', rhs_wanted, rule_ty) = stuff - - ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname - , ppr lhs_wanted - , ppr rhs_wanted ]) - - ; (lhs_evs, residual_lhs_wanted) - <- simplifyRule name tc_lvl lhs_wanted rhs_wanted - - -- SimplfyRule Plan, step 4 - -- Now figure out what to quantify over - -- c.f. TcSimplify.simplifyInfer - -- We quantify over any tyvars free in *either* the rule - -- *or* the bound variables. The latter is important. Consider - -- ss (x,(y,z)) = (x,z) - -- RULE: forall v. fst (ss v) = fst v - -- The type of the rhs of the rule is just a, but v::(a,(b,c)) - -- - -- We also need to get the completely-unconstrained tyvars of - -- the LHS, lest they otherwise get defaulted to Any; but we do that - -- during zonking (see TcHsSyn.zonkRule) - - ; let tpl_ids = lhs_evs ++ id_bndrs - - -- See Note [Re-quantify type variables in rules] - ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids) - ; qtkvs <- quantifyTyVars forall_tkvs - ; traceTc "tcRule" (vcat [ pprFullRuleName rname - , ppr forall_tkvs - , ppr qtkvs - , ppr rule_ty - , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] - ]) - - -- SimplfyRule Plan, step 5 - -- Simplify the LHS and RHS constraints: - -- For the LHS constraints we must solve the remaining constraints - -- (a) so that we report insoluble ones - -- (b) so that we bind any soluble ones - ; let skol_info = RuleSkol name - ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs - lhs_evs residual_lhs_wanted - ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs - lhs_evs rhs_wanted - - ; emitImplications (lhs_implic `unionBags` rhs_implic) - ; return $ HsRule { rd_ext = ext - , rd_name = rname - , rd_act = act - , rd_tyvs = ty_bndrs -- preserved for ppr-ing - , rd_tmvs = map (noLoc . RuleBndr noExtField . noLoc) - (qtkvs ++ tpl_ids) - , rd_lhs = mkHsDictLet lhs_binds lhs' - , rd_rhs = mkHsDictLet rhs_binds rhs' } } -tcRule (XRuleDecl nec) = noExtCon nec - -generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] - -> LHsExpr GhcRn -> LHsExpr GhcRn - -> TcM ( [TcId] - , LHsExpr GhcTc, WantedConstraints - , LHsExpr GhcTc, WantedConstraints - , TcType ) -generateRuleConstraints ty_bndrs tm_bndrs lhs rhs - = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $ - tcRuleBndrs ty_bndrs tm_bndrs - -- bndr_wanted constraints can include wildcard hole - -- constraints, which we should not forget about. - -- It may mention the skolem type variables bound by - -- the RULE. c.f. #10072 - - ; tcExtendTyVarEnv tv_bndrs $ - tcExtendIdEnv id_bndrs $ - do { -- See Note [Solve order for RULES] - ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) - ; (rhs', rhs_wanted) <- captureConstraints $ - tcMonoExpr rhs (mkCheckExpType rule_ty) - ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted - ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } - --- See Note [TcLevel in type checking rules] -tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] - -> TcM ([TcTyVar], [Id]) -tcRuleBndrs (Just bndrs) xs - = do { (tys1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ - tcRuleTmBndrs xs - ; return (tys1 ++ tys2, tms) } - -tcRuleBndrs Nothing xs - = tcRuleTmBndrs xs - --- See Note [TcLevel in type checking rules] -tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id]) -tcRuleTmBndrs [] = return ([],[]) -tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs) - = do { ty <- newOpenFlexiTyVarTy - ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs - ; return (tyvars, mkLocalId name ty : tmvars) } -tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) --- e.g x :: a->a --- The tyvar 'a' is brought into scope first, just as if you'd written --- a::*, x :: a->a --- If there's an explicit forall, the renamer would have already reported an --- error for each out-of-scope type variable used - = do { let ctxt = RuleSigCtxt name - ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty - ; let id = mkLocalId name id_ty - -- See Note [Pattern signature binders] in TcHsType - - -- The type variables scope over subsequent bindings; yuk - ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $ - tcRuleTmBndrs rule_bndrs - ; return (map snd tvs ++ tyvars, id : tmvars) } -tcRuleTmBndrs (L _ (XRuleBndr nec) : _) = noExtCon nec - -ruleCtxt :: FastString -> SDoc -ruleCtxt name = text "When checking the transformation rule" <+> - doubleQuotes (ftext name) - - -{- -********************************************************************************* -* * - Constraint simplification for rules -* * -*********************************************************************************** - -Note [The SimplifyRule Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Example. Consider the following left-hand side of a rule - f (x == y) (y > z) = ... -If we typecheck this expression we get constraints - d1 :: Ord a, d2 :: Eq a -We do NOT want to "simplify" to the LHS - forall x::a, y::a, z::a, d1::Ord a. - f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... -Instead we want - forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. - f ((==) d2 x y) ((>) d1 y z) = ... - -Here is another example: - fromIntegral :: (Integral a, Num b) => a -> b - {-# RULES "foo" fromIntegral = id :: Int -> Int #-} -In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But -we *dont* want to get - forall dIntegralInt. - fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int -because the scsel will mess up RULE matching. Instead we want - forall dIntegralInt, dNumInt. - fromIntegral Int Int dIntegralInt dNumInt = id Int - -Even if we have - g (x == y) (y == z) = .. -where the two dictionaries are *identical*, we do NOT WANT - forall x::a, y::a, z::a, d1::Eq a - f ((==) d1 x y) ((>) d1 y z) = ... -because that will only match if the dict args are (visibly) equal. -Instead we want to quantify over the dictionaries separately. - -In short, simplifyRuleLhs must *only* squash equalities, leaving -all dicts unchanged, with absolutely no sharing. - -Also note that we can't solve the LHS constraints in isolation: -Example foo :: Ord a => a -> a - foo_spec :: Int -> Int - {-# RULE "foo" foo = foo_spec #-} -Here, it's the RHS that fixes the type variable - -HOWEVER, under a nested implication things are different -Consider - f :: (forall a. Eq a => a->a) -> Bool -> ... - {-# RULES "foo" forall (v::forall b. Eq b => b->b). - f b True = ... - #-} -Here we *must* solve the wanted (Eq a) from the given (Eq a) -resulting from skolemising the argument type of g. So we -revert to SimplCheck when going under an implication. - - ---------- So the SimplifyRule Plan is this ----------------------- - -* Step 0: typecheck the LHS and RHS to get constraints from each - -* Step 1: Simplify the LHS and RHS constraints all together in one bag - We do this to discover all unification equalities - -* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take - advantage of those unifications - -* Setp 3: Partition the LHS constraints into the ones we will - quantify over, and the others. - See Note [RULE quantification over equalities] - -* Step 4: Decide on the type variables to quantify over - -* Step 5: Simplify the LHS and RHS constraints separately, using the - quantified constraints as givens - -Note [Solve order for RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In step 1 above, we need to be a bit careful about solve order. -Consider - f :: Int -> T Int - type instance T Int = Bool - - RULE f 3 = True - -From the RULE we get - lhs-constraints: T Int ~ alpha - rhs-constraints: Bool ~ alpha -where 'alpha' is the type that connects the two. If we glom them -all together, and solve the RHS constraint first, we might solve -with alpha := Bool. But then we'd end up with a RULE like - - RULE: f 3 |> (co :: T Int ~ Bool) = True - -which is terrible. We want - - RULE: f 3 = True |> (sym co :: Bool ~ T Int) - -So we are careful to solve the LHS constraints first, and *then* the -RHS constraints. Actually much of this is done by the on-the-fly -constraint solving, so the same order must be observed in -tcRule. - - -Note [RULE quantification over equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deciding which equalities to quantify over is tricky: - * We do not want to quantify over insoluble equalities (Int ~ Bool) - (a) because we prefer to report a LHS type error - (b) because if such things end up in 'givens' we get a bogus - "inaccessible code" error - - * But we do want to quantify over things like (a ~ F b), where - F is a type function. - -The difficulty is that it's hard to tell what is insoluble! -So we see whether the simplification step yielded any type errors, -and if so refrain from quantifying over *any* equalities. - -Note [Quantifying over coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Equality constraints from the LHS will emit coercion hole Wanteds. -These don't have a name, so we can't quantify over them directly. -Instead, because we really do want to quantify here, invent a new -EvVar for the coercion, fill the hole with the invented EvVar, and -then quantify over the EvVar. Not too tricky -- just some -impedance matching, really. - -Note [Simplify cloned constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At this stage, we're simplifying constraints only for insolubility -and for unification. Note that all the evidence is quickly discarded. -We use a clone of the real constraint. If we don't do this, -then RHS coercion-hole constraints get filled in, only to get filled -in *again* when solving the implications emitted from tcRule. That's -terrible, so we avoid the problem by cloning the constraints. - --} - -simplifyRule :: RuleName - -> TcLevel -- Level at which to solve the constraints - -> WantedConstraints -- Constraints from LHS - -> WantedConstraints -- Constraints from RHS - -> TcM ( [EvVar] -- Quantify over these LHS vars - , WantedConstraints) -- Residual un-quantified LHS constraints --- See Note [The SimplifyRule Plan] --- NB: This consumes all simple constraints on the LHS, but not --- any LHS implication constraints. -simplifyRule name tc_lvl lhs_wanted rhs_wanted - = do { - -- Note [The SimplifyRule Plan] step 1 - -- First solve the LHS and *then* solve the RHS - -- Crucially, this performs unifications - -- Why clone? See Note [Simplify cloned constraints] - ; lhs_clone <- cloneWC lhs_wanted - ; rhs_clone <- cloneWC rhs_wanted - ; setTcLevel tc_lvl $ - runTcSDeriveds $ - do { _ <- solveWanteds lhs_clone - ; _ <- solveWanteds rhs_clone - -- Why do them separately? - -- See Note [Solve order for RULES] - ; return () } - - -- Note [The SimplifyRule Plan] step 2 - ; lhs_wanted <- zonkWC lhs_wanted - ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted - - -- Note [The SimplifyRule Plan] step 3 - ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts) - - ; traceTc "simplifyRule" $ - vcat [ text "LHS of rule" <+> doubleQuotes (ftext name) - , text "lhs_wanted" <+> ppr lhs_wanted - , text "rhs_wanted" <+> ppr rhs_wanted - , text "quant_cts" <+> ppr quant_cts - , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted - ] - - ; return (quant_evs, residual_lhs_wanted) } - - where - mk_quant_ev :: Ct -> TcM EvVar - mk_quant_ev ct - | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct - = case dest of - EvVarDest ev_id -> return ev_id - HoleDest hole -> -- See Note [Quantifying over coercion holes] - do { ev_id <- newEvVar pred - ; fillCoercionHole hole (mkTcCoVarCo ev_id) - ; return ev_id } - mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct) - - -getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints) --- Extract all the constraints we can quantify over, --- also returning the depleted WantedConstraints --- --- NB: we must look inside implications, because with --- -fdefer-type-errors we generate implications rather eagerly; --- see TcUnify.implicationNeeded. Not doing so caused #14732. --- --- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged, --- and attempt to solve them from the quantified constraints. That --- nearly works, but fails for a constraint like (d :: Eq Int). --- We /do/ want to quantify over it, but the short-cut solver --- (see TcInteract Note [Shortcut solving]) ignores the quantified --- and instead solves from the top level. --- --- So we must partition the WantedConstraints ourselves --- Not hard, but tiresome. - -getRuleQuantCts wc - = float_wc emptyVarSet wc - where - float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints) - float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics }) - = ( simple_yes `andCts` implic_yes - , WC { wc_simple = simple_no, wc_impl = implics_no }) - where - (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples - (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs) - emptyBag implics - - float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication) - float_implic skol_tvs yes1 imp - = (yes1 `andCts` yes2, imp { ic_wanted = no }) - where - (yes2, no) = float_wc new_skol_tvs (ic_wanted imp) - new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp - - rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool - rule_quant_ct skol_tvs ct - | EqPred _ t1 t2 <- classifyPredType (ctPred ct) - , not (ok_eq t1 t2) - = False -- Note [RULE quantification over equalities] - | isHoleCt ct - = False -- Don't quantify over type holes, obviously - | otherwise - = tyCoVarsOfCt ct `disjointVarSet` skol_tvs - - ok_eq t1 t2 - | t1 `tcEqType` t2 = False - | otherwise = is_fun_app t1 || is_fun_app t2 - - is_fun_app ty -- ty is of form (F tys) where F is a type function - = case tyConAppTyCon_maybe ty of - Just tc -> isTypeFamilyTyCon tc - Nothing -> False diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs deleted file mode 100644 index bddbcd0451..0000000000 --- a/compiler/typecheck/TcSMonad.hs +++ /dev/null @@ -1,3643 +0,0 @@ -{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - --- Type definitions for the constraint solver -module TcSMonad ( - - -- The work list - WorkList(..), isEmptyWorkList, emptyWorkList, - extendWorkListNonEq, extendWorkListCt, - extendWorkListCts, extendWorkListEq, extendWorkListFunEq, - appendWorkList, - selectNextWorkItem, - workListSize, workListWantedCount, - getWorkList, updWorkListTcS, pushLevelNoWorkList, - - -- The TcS monad - TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, - failTcS, warnTcS, addErrTcS, - runTcSEqualities, - nestTcS, nestImplicTcS, setEvBindsTcS, - emitImplicationTcS, emitTvImplicationTcS, - - runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive, - matchGlobalInst, TcM.ClsInstResult(..), - - QCInst(..), - - -- Tracing etc - panicTcS, traceTcS, - traceFireTcS, bumpStepCountTcS, csTraceTcS, - wrapErrTcS, wrapWarnTcS, - - -- Evidence creation and transformation - MaybeNew(..), freshGoals, isFresh, getEvExpr, - - newTcEvBinds, newNoTcEvBinds, - newWantedEq, newWantedEq_SI, emitNewWantedEq, - newWanted, newWanted_SI, newWantedEvVar, - newWantedNC, newWantedEvVarNC, - newDerivedNC, - newBoundEvVarId, - unifyTyVar, unflattenFmv, reportUnifications, - setEvBind, setWantedEq, - setWantedEvTerm, setEvBindIfWanted, - newEvVar, newGivenEvVar, newGivenEvVars, - emitNewDeriveds, emitNewDerivedEq, - checkReductionDepth, - getSolvedDicts, setSolvedDicts, - - getInstEnvs, getFamInstEnvs, -- Getting the environments - getTopEnv, getGblEnv, getLclEnv, - getTcEvBindsVar, getTcLevel, - getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, - tcLookupClass, tcLookupId, - - -- Inerts - InertSet(..), InertCans(..), - updInertTcS, updInertCans, updInertDicts, updInertIrreds, - getNoGivenEqs, setInertCans, - getInertEqs, getInertCans, getInertGivens, - getInertInsols, - getTcSInerts, setTcSInerts, - matchableGivens, prohibitedSuperClassSolve, mightMatchLater, - getUnsolvedInerts, - removeInertCts, getPendingGivenScs, - addInertCan, insertFunEq, addInertForAll, - emitWorkNC, emitWork, - isImprovable, - - -- The Model - kickOutAfterUnification, - - -- Inert Safe Haskell safe-overlap failures - addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask, - getSafeOverlapFailures, - - -- Inert CDictCans - DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict, - addDictsByClass, delDict, foldDicts, filterDicts, findDict, - - -- Inert CTyEqCans - EqualCtList, findTyEqs, foldTyEqs, isInInertEqs, - lookupInertTyVar, - - -- Inert solved dictionaries - addSolvedDict, lookupSolvedDict, - - -- Irreds - foldIrreds, - - -- The flattening cache - lookupFlatCache, extendFlatCache, newFlattenSkolem, -- Flatten skolems - dischargeFunEq, pprKicked, - - -- Inert CFunEqCans - updInertFunEqs, findFunEq, - findFunEqsByTyCon, - - instDFunType, -- Instantiation - - -- MetaTyVars - newFlexiTcSTy, instFlexi, instFlexiX, - cloneMetaTyVar, demoteUnfilledFmv, - tcInstSkolTyVarsX, - - TcLevel, - isFilledMetaTyVar_maybe, isFilledMetaTyVar, - zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo, - zonkTyCoVarsAndFVList, - zonkSimples, zonkWC, - zonkTyCoVarKind, - - -- References - newTcRef, readTcRef, writeTcRef, updTcRef, - - -- Misc - getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, - matchFam, matchFamTcM, - checkWellStagedDFun, - pprEq -- Smaller utils, re-exported from TcM - -- TODO (DV): these are only really used in the - -- instance matcher in TcSimplify. I am wondering - -- if the whole instance matcher simply belongs - -- here -) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Driver.Types - -import qualified Inst as TcM -import GHC.Core.InstEnv -import FamInst -import GHC.Core.FamInstEnv - -import qualified TcRnMonad as TcM -import qualified TcMType as TcM -import qualified ClsInst as TcM( matchGlobalInst, ClsInstResult(..) ) -import qualified TcEnv as TcM - ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl ) -import ClsInst( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) -import TcType -import GHC.Driver.Session -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.Unify - -import ErrUtils -import TcEvidence -import GHC.Core.Class -import GHC.Core.TyCon -import TcErrors ( solverDepthErrorTcS ) - -import GHC.Types.Name -import GHC.Types.Module ( HasModule, getModule ) -import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt ) -import qualified GHC.Rename.Env as TcM -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import Outputable -import Bag -import GHC.Types.Unique.Supply -import Util -import TcRnTypes -import TcOrigin -import Constraint -import GHC.Core.Predicate - -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Types.Unique.DFM -import Maybes - -import GHC.Core.Map -import Control.Monad -import MonadUtils -import Data.IORef -import Data.List ( partition, mapAccumL ) - -#if defined(DEBUG) -import Digraph -import GHC.Types.Unique.Set -#endif - -{- -************************************************************************ -* * -* Worklists * -* Canonical and non-canonical constraints that the simplifier has to * -* work on. Including their simplification depths. * -* * -* * -************************************************************************ - -Note [WorkList priorities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A WorkList contains canonical and non-canonical items (of all flavors). -Notice that each Ct now has a simplification depth. We may -consider using this depth for prioritization as well in the future. - -As a simple form of priority queue, our worklist separates out - -* equalities (wl_eqs); see Note [Prioritise equalities] -* type-function equalities (wl_funeqs) -* all the rest (wl_rest) - -Note [Prioritise equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very important to process equalities /first/: - -* (Efficiency) The general reason to do so is that if we process a - class constraint first, we may end up putting it into the inert set - and then kicking it out later. That's extra work compared to just - doing the equality first. - -* (Avoiding fundep iteration) As #14723 showed, it's possible to - get non-termination if we - - Emit the Derived fundep equalities for a class constraint, - generating some fresh unification variables. - - That leads to some unification - - Which kicks out the class constraint - - Which isn't solved (because there are still some more Derived - equalities in the work-list), but generates yet more fundeps - Solution: prioritise derived equalities over class constraints - -* (Class equalities) We need to prioritise equalities even if they - are hidden inside a class constraint; - see Note [Prioritise class equalities] - -* (Kick-out) We want to apply this priority scheme to kicked-out - constraints too (see the call to extendWorkListCt in kick_out_rewritable - E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become - homo-kinded when kicked out, and hence we want to prioritise it. - -* (Derived equalities) Originally we tried to postpone processing - Derived equalities, in the hope that we might never need to deal - with them at all; but in fact we must process Derived equalities - eagerly, partly for the (Efficiency) reason, and more importantly - for (Avoiding fundep iteration). - -Note [Prioritise class equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We prioritise equalities in the solver (see selectWorkItem). But class -constraints like (a ~ b) and (a ~~ b) are actually equalities too; -see Note [The equality types story] in TysPrim. - -Failing to prioritise these is inefficient (more kick-outs etc). -But, worse, it can prevent us spotting a "recursive knot" among -Wanted constraints. See comment:10 of #12734 for a worked-out -example. - -So we arrange to put these particular class constraints in the wl_eqs. - - NB: since we do not currently apply the substitution to the - inert_solved_dicts, the knot-tying still seems a bit fragile. - But this makes it better. - --} - --- See Note [WorkList priorities] -data WorkList - = WL { wl_eqs :: [Ct] -- CTyEqCan, CDictCan, CIrredCan - -- Given, Wanted, and Derived - -- Contains both equality constraints and their - -- class-level variants (a~b) and (a~~b); - -- See Note [Prioritise equalities] - -- See Note [Prioritise class equalities] - - , wl_funeqs :: [Ct] - - , wl_rest :: [Ct] - - , wl_implics :: Bag Implication -- See Note [Residual implications] - } - -appendWorkList :: WorkList -> WorkList -> WorkList -appendWorkList - (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1 - , wl_implics = implics1 }) - (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2 - , wl_implics = implics2 }) - = WL { wl_eqs = eqs1 ++ eqs2 - , wl_funeqs = funeqs1 ++ funeqs2 - , wl_rest = rest1 ++ rest2 - , wl_implics = implics1 `unionBags` implics2 } - -workListSize :: WorkList -> Int -workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest }) - = length eqs + length funeqs + length rest - -workListWantedCount :: WorkList -> Int --- Count the things we need to solve --- excluding the insolubles (c.f. inert_count) -workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest }) - = count isWantedCt eqs + count is_wanted rest - where - is_wanted ct - | CIrredCan { cc_status = InsolubleCIS } <- ct - = False - | otherwise - = isWantedCt ct - -extendWorkListEq :: Ct -> WorkList -> WorkList -extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl } - -extendWorkListFunEq :: Ct -> WorkList -> WorkList -extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl } - -extendWorkListNonEq :: Ct -> WorkList -> WorkList --- Extension by non equality -extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } - -extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList -extendWorkListDeriveds evs wl - = extendWorkListCts (map mkNonCanonical evs) wl - -extendWorkListImplic :: Implication -> WorkList -> WorkList -extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl } - -extendWorkListCt :: Ct -> WorkList -> WorkList --- Agnostic -extendWorkListCt ct wl - = case classifyPredType (ctPred ct) of - EqPred NomEq ty1 _ - | Just tc <- tcTyConAppTyCon_maybe ty1 - , isTypeFamilyTyCon tc - -> extendWorkListFunEq ct wl - - EqPred {} - -> extendWorkListEq ct wl - - ClassPred cls _ -- See Note [Prioritise class equalities] - | isEqPredClass cls - -> extendWorkListEq ct wl - - _ -> extendWorkListNonEq ct wl - -extendWorkListCts :: [Ct] -> WorkList -> WorkList --- Agnostic -extendWorkListCts cts wl = foldr extendWorkListCt wl cts - -isEmptyWorkList :: WorkList -> Bool -isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs - , wl_rest = rest, wl_implics = implics }) - = null eqs && null rest && null funeqs && isEmptyBag implics - -emptyWorkList :: WorkList -emptyWorkList = WL { wl_eqs = [], wl_rest = [] - , wl_funeqs = [], wl_implics = emptyBag } - -selectWorkItem :: WorkList -> Maybe (Ct, WorkList) --- See Note [Prioritise equalities] -selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs - , wl_rest = rest }) - | ct:cts <- eqs = Just (ct, wl { wl_eqs = cts }) - | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes }) - | ct:cts <- rest = Just (ct, wl { wl_rest = cts }) - | otherwise = Nothing - -getWorkList :: TcS WorkList -getWorkList = do { wl_var <- getTcSWorkListRef - ; wrapTcS (TcM.readTcRef wl_var) } - -selectNextWorkItem :: TcS (Maybe Ct) --- Pick which work item to do next --- See Note [Prioritise equalities] -selectNextWorkItem - = do { wl_var <- getTcSWorkListRef - ; wl <- readTcRef wl_var - ; case selectWorkItem wl of { - Nothing -> return Nothing ; - Just (ct, new_wl) -> - do { -- checkReductionDepth (ctLoc ct) (ctPred ct) - -- This is done by TcInteract.chooseInstance - ; writeTcRef wl_var new_wl - ; return (Just ct) } } } - --- Pretty printing -instance Outputable WorkList where - ppr (WL { wl_eqs = eqs, wl_funeqs = feqs - , wl_rest = rest, wl_implics = implics }) - = text "WL" <+> (braces $ - vcat [ ppUnless (null eqs) $ - text "Eqs =" <+> vcat (map ppr eqs) - , ppUnless (null feqs) $ - text "Funeqs =" <+> vcat (map ppr feqs) - , ppUnless (null rest) $ - text "Non-eqs =" <+> vcat (map ppr rest) - , ppUnless (isEmptyBag implics) $ - ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics))) - (text "(Implics omitted)") - ]) - - -{- ********************************************************************* -* * - InertSet: the inert set -* * -* * -********************************************************************* -} - -data InertSet - = IS { inert_cans :: InertCans - -- Canonical Given, Wanted, Derived - -- Sometimes called "the inert set" - - , inert_fsks :: [(TcTyVar, TcType)] - -- A list of (fsk, ty) pairs; we add one element when we flatten - -- a function application in a Given constraint, creating - -- a new fsk in newFlattenSkolem. When leaving a nested scope, - -- unflattenGivens unifies fsk := ty - -- - -- We could also get this info from inert_funeqs, filtered by - -- level, but it seems simpler and more direct to capture the - -- fsk as we generate them. - - , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour) - -- See Note [Type family equations] - -- If F tys :-> (co, rhs, flav), - -- then co :: F tys ~ rhs - -- flav is [G] or [WD] - -- - -- Just a hash-cons cache for use when flattening only - -- These include entirely un-processed goals, so don't use - -- them to solve a top-level goal, else you may end up solving - -- (w:F ty ~ a) by setting w:=w! We just use the flat-cache - -- when allocating a new flatten-skolem. - -- Not necessarily inert wrt top-level equations (or inert_cans) - - -- NB: An ExactFunEqMap -- this doesn't match via loose types! - - , inert_solved_dicts :: DictMap CtEvidence - -- All Wanteds, of form ev :: C t1 .. tn - -- See Note [Solved dictionaries] - -- and Note [Do not add superclasses of solved dictionaries] - } - -instance Outputable InertSet where - ppr (IS { inert_cans = ics - , inert_fsks = ifsks - , inert_solved_dicts = solved_dicts }) - = vcat [ ppr ics - , text "Inert fsks =" <+> ppr ifsks - , ppUnless (null dicts) $ - text "Solved dicts =" <+> vcat (map ppr dicts) ] - where - dicts = bagToList (dictsToBag solved_dicts) - -emptyInertCans :: InertCans -emptyInertCans - = IC { inert_count = 0 - , inert_eqs = emptyDVarEnv - , inert_dicts = emptyDicts - , inert_safehask = emptyDicts - , inert_funeqs = emptyFunEqs - , inert_insts = [] - , inert_irreds = emptyCts } - -emptyInert :: InertSet -emptyInert - = IS { inert_cans = emptyInertCans - , inert_fsks = [] - , inert_flat_cache = emptyExactFunEqs - , inert_solved_dicts = emptyDictMap } - - -{- Note [Solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we apply a top-level instance declaration, we add the "solved" -dictionary to the inert_solved_dicts. In general, we use it to avoid -creating a new EvVar when we have a new goal that we have solved in -the past. - -But in particular, we can use it to create *recursive* dictionaries. -The simplest, degenerate case is - instance C [a] => C [a] where ... -If we have - [W] d1 :: C [x] -then we can apply the instance to get - d1 = $dfCList d - [W] d2 :: C [x] -Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1. - d1 = $dfCList d - d2 = d1 - -See Note [Example of recursive dictionaries] - -VERY IMPORTANT INVARIANT: - - (Solved Dictionary Invariant) - Every member of the inert_solved_dicts is the result - of applying an instance declaration that "takes a step" - - An instance "takes a step" if it has the form - dfunDList d1 d2 = MkD (...) (...) (...) - That is, the dfun is lazy in its arguments, and guarantees to - immediately return a dictionary constructor. NB: all dictionary - data constructors are lazy in their arguments. - - This property is crucial to ensure that all dictionaries are - non-bottom, which in turn ensures that the whole "recursive - dictionary" idea works at all, even if we get something like - rec { d = dfunDList d dx } - See Note [Recursive superclasses] in TcInstDcls. - - Reason: - - All instances, except two exceptions listed below, "take a step" - in the above sense - - - Exception 1: local quantified constraints have no such guarantee; - indeed, adding a "solved dictionary" when appling a quantified - constraint led to the ability to define unsafeCoerce - in #17267. - - - Exception 2: the magic built-in instance for (~) has no - such guarantee. It behaves as if we had - class (a ~# b) => (a ~ b) where {} - instance (a ~# b) => (a ~ b) where {} - The "dfun" for the instance is strict in the coercion. - Anyway there's no point in recording a "solved dict" for - (t1 ~ t2); it's not going to allow a recursive dictionary - to be constructed. Ditto (~~) and Coercible. - -THEREFORE we only add a "solved dictionary" - - when applying an instance declaration - - subject to Exceptions 1 and 2 above - -In implementation terms - - TcSMonad.addSolvedDict adds a new solved dictionary, - conditional on the kind of instance - - - It is only called when applying an instance decl, - in TcInteract.doTopReactDict - - - ClsInst.InstanceWhat says what kind of instance was - used to solve the constraint. In particular - * LocalInstance identifies quantified constraints - * BuiltinEqInstance identifies the strange built-in - instances for equality. - - - ClsInst.instanceReturnsDictCon says which kind of - instance guarantees to return a dictionary constructor - -Other notes about solved dictionaries - -* See also Note [Do not add superclasses of solved dictionaries] - -* The inert_solved_dicts field is not rewritten by equalities, - so it may get out of date. - -* The inert_solved_dicts are all Wanteds, never givens - -* We only cache dictionaries from top-level instances, not from - local quantified constraints. Reason: if we cached the latter - we'd need to purge the cache when bringing new quantified - constraints into scope, because quantified constraints "shadow" - top-level instances. - -Note [Do not add superclasses of solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every member of inert_solved_dicts is the result of applying a -dictionary function, NOT of applying superclass selection to anything. -Consider - - class Ord a => C a where - instance Ord [a] => C [a] where ... - -Suppose we are trying to solve - [G] d1 : Ord a - [W] d2 : C [a] - -Then we'll use the instance decl to give - - [G] d1 : Ord a Solved: d2 : C [a] = $dfCList d3 - [W] d3 : Ord [a] - -We must not add d4 : Ord [a] to the 'solved' set (by taking the -superclass of d2), otherwise we'll use it to solve d3, without ever -using d1, which would be a catastrophe. - -Solution: when extending the solved dictionaries, do not add superclasses. -That's why each element of the inert_solved_dicts is the result of applying -a dictionary function. - -Note [Example of recursive dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ---- Example 1 - - data D r = ZeroD | SuccD (r (D r)); - - instance (Eq (r (D r))) => Eq (D r) where - ZeroD == ZeroD = True - (SuccD a) == (SuccD b) = a == b - _ == _ = False; - - equalDC :: D [] -> D [] -> Bool; - equalDC = (==); - -We need to prove (Eq (D [])). Here's how we go: - - [W] d1 : Eq (D []) -By instance decl of Eq (D r): - [W] d2 : Eq [D []] where d1 = dfEqD d2 -By instance decl of Eq [a]: - [W] d3 : Eq (D []) where d2 = dfEqList d3 - d1 = dfEqD d2 -Now this wanted can interact with our "solved" d1 to get: - d3 = d1 - --- Example 2: -This code arises in the context of "Scrap Your Boilerplate with Class" - - class Sat a - class Data ctx a - instance Sat (ctx Char) => Data ctx Char -- dfunData1 - instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2 - - class Data Maybe a => Foo a - - instance Foo t => Sat (Maybe t) -- dfunSat - - instance Data Maybe a => Foo a -- dfunFoo1 - instance Foo a => Foo [a] -- dfunFoo2 - instance Foo [Char] -- dfunFoo3 - -Consider generating the superclasses of the instance declaration - instance Foo a => Foo [a] - -So our problem is this - [G] d0 : Foo t - [W] d1 : Data Maybe [t] -- Desired superclass - -We may add the given in the inert set, along with its superclasses - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - WorkList - [W] d1 : Data Maybe [t] - -Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - WorkList: - [W] d2 : Sat (Maybe [t]) - [W] d3 : Data Maybe t - -Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList: - [W] d3 : Data Maybe t - [W] d4 : Foo [t] - -Now, we can just solve d3 from d01; d3 := d01 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList - [W] d4 : Foo [t] - -Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - d4 : Foo [t] - WorkList: - [W] d5 : Foo t - -Now, d5 can be solved! d5 := d0 - -Result - d1 := dfunData2 d2 d3 - d2 := dfunSat d4 - d3 := d01 - d4 := dfunFoo2 d5 - d5 := d0 --} - -{- ********************************************************************* -* * - InertCans: the canonical inerts -* * -* * -********************************************************************* -} - -data InertCans -- See Note [Detailed InertCans Invariants] for more - = IC { inert_eqs :: InertEqs - -- See Note [inert_eqs: the inert equalities] - -- All CTyEqCans; index is the LHS tyvar - -- Domain = skolems and untouchables; a touchable would be unified - - , inert_funeqs :: FunEqMap Ct - -- All CFunEqCans; index is the whole family head type. - -- All Nominal (that's an invariant of all CFunEqCans) - -- LHS is fully rewritten (modulo eqCanRewrite constraints) - -- wrt inert_eqs - -- Can include all flavours, [G], [W], [WD], [D] - -- See Note [Type family equations] - - , inert_dicts :: DictMap Ct - -- Dictionaries only - -- All fully rewritten (modulo flavour constraints) - -- wrt inert_eqs - - , inert_insts :: [QCInst] - - , inert_safehask :: DictMap Ct - -- Failed dictionary resolution due to Safe Haskell overlapping - -- instances restriction. We keep this separate from inert_dicts - -- as it doesn't cause compilation failure, just safe inference - -- failure. - -- - -- ^ See Note [Safe Haskell Overlapping Instances Implementation] - -- in TcSimplify - - , inert_irreds :: Cts - -- Irreducible predicates that cannot be made canonical, - -- and which don't interact with others (e.g. (c a)) - -- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a]) - - , inert_count :: Int - -- Number of Wanted goals in - -- inert_eqs, inert_dicts, inert_safehask, inert_irreds - -- Does not include insolubles - -- When non-zero, keep trying to solve - } - -type InertEqs = DTyVarEnv EqualCtList -type EqualCtList = [Ct] -- See Note [EqualCtList invariants] - -{- Note [Detailed InertCans Invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The InertCans represents a collection of constraints with the following properties: - - * All canonical - - * No two dictionaries with the same head - * No two CIrreds with the same type - - * Family equations inert wrt top-level family axioms - - * Dictionaries have no matching top-level instance - - * Given family or dictionary constraints don't mention touchable - unification variables - - * Non-CTyEqCan constraints are fully rewritten with respect - to the CTyEqCan equalities (modulo canRewrite of course; - eg a wanted cannot rewrite a given) - - * CTyEqCan equalities: see Note [inert_eqs: the inert equalities] - Also see documentation in Constraint.Ct for a list of invariants - -Note [EqualCtList invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * All are equalities - * All these equalities have the same LHS - * The list is never empty - * No element of the list can rewrite any other - * Derived before Wanted - -From the fourth invariant it follows that the list is - - A single [G], or - - Zero or one [D] or [WD], followed by any number of [W] - -The Wanteds can't rewrite anything which is why we put them last - -Note [Type family equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type-family equations, CFunEqCans, of form (ev : F tys ~ ty), -live in three places - - * The work-list, of course - - * The inert_funeqs are un-solved but fully processed, and in - the InertCans. They can be [G], [W], [WD], or [D]. - - * The inert_flat_cache. This is used when flattening, to get maximal - sharing. Everything in the inert_flat_cache is [G] or [WD] - - It contains lots of things that are still in the work-list. - E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the - work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work - list. Now if we flatten w2 before we get to w3, we still want to - share that (G a). - Because it contains work-list things, DO NOT use the flat cache to solve - a top-level goal. Eg in the above example we don't want to solve w3 - using w3 itself! - -The CFunEqCan Ownership Invariant: - - * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv - It "owns" that fsk/fmv, in the sense that: - - reducing a [W/WD] CFunEqCan fills in the fmv - - unflattening a [W/WD] CFunEqCan fills in the fmv - (in both cases unless an occurs-check would result) - - * In contrast a [D] CFunEqCan does not "own" its fmv: - - reducing a [D] CFunEqCan does not fill in the fmv; - it just generates an equality - - unflattening ignores [D] CFunEqCans altogether - - -Note [inert_eqs: the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Definition [Can-rewrite relation] -A "can-rewrite" relation between flavours, written f1 >= f2, is a -binary relation with the following properties - - (R1) >= is transitive - (R2) If f1 >= f, and f2 >= f, - then either f1 >= f2 or f2 >= f1 - -Lemma. If f1 >= f then f1 >= f1 -Proof. By property (R2), with f1=f2 - -Definition [Generalised substitution] -A "generalised substitution" S is a set of triples (a -f-> t), where - a is a type variable - t is a type - f is a flavour -such that - (WF1) if (a -f1-> t1) in S - (a -f2-> t2) in S - then neither (f1 >= f2) nor (f2 >= f1) hold - (WF2) if (a -f-> t) is in S, then t /= a - -Definition [Applying a generalised substitution] -If S is a generalised substitution - S(f,a) = t, if (a -fs-> t) in S, and fs >= f - = a, otherwise -Application extends naturally to types S(f,t), modulo roles. -See Note [Flavours with roles]. - -Theorem: S(f,a) is well defined as a function. -Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S, - and f1 >= f and f2 >= f - Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1) - -Notation: repeated application. - S^0(f,t) = t - S^(n+1)(f,t) = S(f, S^n(t)) - -Definition: inert generalised substitution -A generalised substitution S is "inert" iff - - (IG1) there is an n such that - for every f,t, S^n(f,t) = S^(n+1)(f,t) - -By (IG1) we define S*(f,t) to be the result of exahaustively -applying S(f,_) to t. - ----------------------------------------------------------------- -Our main invariant: - the inert CTyEqCans should be an inert generalised substitution ----------------------------------------------------------------- - -Note that inertness is not the same as idempotence. To apply S to a -type, you may have to apply it recursive. But inertness does -guarantee that this recursive use will terminate. - -Note [Extending the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Main Theorem [Stability under extension] - Suppose we have a "work item" - a -fw-> t - and an inert generalised substitution S, - THEN the extended substitution T = S+(a -fw-> t) - is an inert generalised substitution - PROVIDED - (T1) S(fw,a) = a -- LHS of work-item is a fixpoint of S(fw,_) - (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_) - (T3) a not in t -- No occurs check in the work item - - AND, for every (b -fs-> s) in S: - (K0) not (fw >= fs) - Reason: suppose we kick out (a -fs-> s), - and add (a -fw-> t) to the inert set. - The latter can't rewrite the former, - so the kick-out achieved nothing - - OR { (K1) not (a = b) - Reason: if fw >= fs, WF1 says we can't have both - a -fw-> t and a -fs-> s - - AND (K2): guarantees inertness of the new substitution - { (K2a) not (fs >= fs) - OR (K2b) fs >= fw - OR (K2d) a not in s } - - AND (K3) See Note [K3: completeness of solving] - { (K3a) If the role of fs is nominal: s /= a - (K3b) If the role of fs is representational: - s is not of form (a t1 .. tn) } } - - -Conditions (T1-T3) are established by the canonicaliser -Conditions (K1-K3) are established by TcSMonad.kickOutRewritable - -The idea is that -* (T1-2) are guaranteed by exhaustively rewriting the work-item - with S(fw,_). - -* T3 is guaranteed by a simple occurs-check on the work item. - This is done during canonicalisation, in canEqTyVar; invariant - (TyEq:OC) of CTyEqCan. - -* (K1-3) are the "kick-out" criteria. (As stated, they are really the - "keep" criteria.) If the current inert S contains a triple that does - not satisfy (K1-3), then we remove it from S by "kicking it out", - and re-processing it. - -* Note that kicking out is a Bad Thing, because it means we have to - re-process a constraint. The less we kick out, the better. - TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed - this but haven't done the empirical study to check. - -* Assume we have G>=G, G>=W and that's all. Then, when performing - a unification we add a new given a -G-> ty. But doing so does NOT require - us to kick out an inert wanted that mentions a, because of (K2a). This - is a common case, hence good not to kick out. - -* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing - Proof: using Definition [Can-rewrite relation], fw can't rewrite anything - and so K0 holds. Intuitively, since fw can't rewrite anything, - adding it cannot cause any loops - This is a common case, because Wanteds cannot rewrite Wanteds. - It's used to avoid even looking for constraint to kick out. - -* Lemma (L1): The conditions of the Main Theorem imply that there is no - (a -fs-> t) in S, s.t. (fs >= fw). - Proof. Suppose the contrary (fs >= fw). Then because of (T1), - S(fw,a)=a. But since fs>=fw, S(fw,a) = s, hence s=a. But now we - have (a -fs-> a) in S, which contradicts (WF2). - -* The extended substitution satisfies (WF1) and (WF2) - - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1). - - (T3) guarantees (WF2). - -* (K2) is about inertness. Intuitively, any infinite chain T^0(f,t), - T^1(f,t), T^2(f,T).... must pass through the new work item infinitely - often, since the substitution without the work item is inert; and must - pass through at least one of the triples in S infinitely often. - - - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f), - and hence this triple never plays a role in application S(f,a). - It is always safe to extend S with such a triple. - - (NB: we could strengten K1) in this way too, but see K3. - - - (K2b): If this holds then, by (T2), b is not in t. So applying the - work item does not generate any new opportunities for applying S - - - (K2c): If this holds, we can't pass through this triple infinitely - often, because if we did then fs>=f, fw>=f, hence by (R2) - * either fw>=fs, contradicting K2c - * or fs>=fw; so by the argument in K2b we can't have a loop - - - (K2d): if a not in s, we hae no further opportunity to apply the - work item, similar to (K2b) - - NB: Dimitrios has a PDF that does this in more detail - -Key lemma to make it watertight. - Under the conditions of the Main Theorem, - forall f st fw >= f, a is not in S^k(f,t), for any k - -Also, consider roles more carefully. See Note [Flavours with roles] - -Note [K3: completeness of solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(K3) is not necessary for the extended substitution -to be inert. In fact K1 could be made stronger by saying - ... then (not (fw >= fs) or not (fs >= fs)) -But it's not enough for S to be inert; we also want completeness. -That is, we want to be able to solve all soluble wanted equalities. -Suppose we have - - work-item b -G-> a - inert-item a -W-> b - -Assuming (G >= W) but not (W >= W), this fulfills all the conditions, -so we could extend the inerts, thus: - - inert-items b -G-> a - a -W-> b - -But if we kicked-out the inert item, we'd get - - work-item a -W-> b - inert-item b -G-> a - -Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl. -So we add one more clause to the kick-out criteria - -Another way to understand (K3) is that we treat an inert item - a -f-> b -in the same way as - b -f-> a -So if we kick out one, we should kick out the other. The orientation -is somewhat accidental. - -When considering roles, we also need the second clause (K3b). Consider - - work-item c -G/N-> a - inert-item a -W/R-> b c - -The work-item doesn't get rewritten by the inert, because (>=) doesn't hold. -But we don't kick out the inert item because not (W/R >= W/R). So we just -add the work item. But then, consider if we hit the following: - - work-item b -G/N-> Id - inert-items a -W/R-> b c - c -G/N-> a -where - newtype Id x = Id x - -For similar reasons, if we only had (K3a), we wouldn't kick the -representational inert out. And then, we'd miss solving the inert, which -now reduced to reflexivity. - -The solution here is to kick out representational inerts whenever the -tyvar of a work item is "exposed", where exposed means being at the -head of the top-level application chain (a t1 .. tn). See -TcType.isTyVarHead. This is encoded in (K3b). - -Beware: if we make this test succeed too often, we kick out too much, -and the solver might loop. Consider (#14363) - work item: [G] a ~R f b - inert item: [G] b ~R f a -In GHC 8.2 the completeness tests more aggressive, and kicked out -the inert item; but no rewriting happened and there was an infinite -loop. All we need is to have the tyvar at the head. - -Note [Flavours with roles] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The system described in Note [inert_eqs: the inert equalities] -discusses an abstract -set of flavours. In GHC, flavours have two components: the flavour proper, -taken from {Wanted, Derived, Given} and the equality relation (often called -role), taken from {NomEq, ReprEq}. -When substituting w.r.t. the inert set, -as described in Note [inert_eqs: the inert equalities], -we must be careful to respect all components of a flavour. -For example, if we have - - inert set: a -G/R-> Int - b -G/R-> Bool - - type role T nominal representational - -and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT -T Int Bool. The reason is that T's first parameter has a nominal role, and -thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of -substitution means that the proof in Note [The inert equalities] may need -to be revisited, but we don't think that the end conclusion is wrong. --} - -instance Outputable InertCans where - ppr (IC { inert_eqs = eqs - , inert_funeqs = funeqs, inert_dicts = dicts - , inert_safehask = safehask, inert_irreds = irreds - , inert_insts = insts - , inert_count = count }) - = braces $ vcat - [ ppUnless (isEmptyDVarEnv eqs) $ - text "Equalities:" - <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs) - , ppUnless (isEmptyTcAppMap funeqs) $ - text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs) - , ppUnless (isEmptyTcAppMap dicts) $ - text "Dictionaries =" <+> pprCts (dictsToBag dicts) - , ppUnless (isEmptyTcAppMap safehask) $ - text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask) - , ppUnless (isEmptyCts irreds) $ - text "Irreds =" <+> pprCts irreds - , ppUnless (null insts) $ - text "Given instances =" <+> vcat (map ppr insts) - , text "Unsolved goals =" <+> int count - ] - -{- ********************************************************************* -* * - Shadow constraints and improvement -* * -************************************************************************ - -Note [The improvement story and derived shadows] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not -rewrite Wanteds] in Constraint), we may miss some opportunities for -solving. Here's a classic example (indexed-types/should_fail/T4093a) - - Ambiguity check for f: (Foo e ~ Maybe e) => Foo e - - We get [G] Foo e ~ Maybe e - [W] Foo e ~ Foo ee -- ee is a unification variable - [W] Foo ee ~ Maybe ee - - Flatten: [G] Foo e ~ fsk - [G] fsk ~ Maybe e -- (A) - - [W] Foo ee ~ fmv - [W] fmv ~ fsk -- (B) From Foo e ~ Foo ee - [W] fmv ~ Maybe ee - - --> rewrite (B) with (A) - [W] Foo ee ~ fmv - [W] fmv ~ Maybe e - [W] fmv ~ Maybe ee - - But now we appear to be stuck, since we don't rewrite Wanteds with - Wanteds. This is silly because we can see that ee := e is the - only solution. - -The basic plan is - * generate Derived constraints that shadow Wanted constraints - * allow Derived to rewrite Derived - * in order to cause some unifications to take place - * that in turn solve the original Wanteds - -The ONLY reason for all these Derived equalities is to tell us how to -unify a variable: that is, what Mark Jones calls "improvement". - -The same idea is sometimes also called "saturation"; find all the -equalities that must hold in any solution. - -Or, equivalently, you can think of the derived shadows as implementing -the "model": a non-idempotent but no-occurs-check substitution, -reflecting *all* *Nominal* equalities (a ~N ty) that are not -immediately soluble by unification. - -More specifically, here's how it works (Oct 16): - -* Wanted constraints are born as [WD]; this behaves like a - [W] and a [D] paired together. - -* When we are about to add a [WD] to the inert set, if it can - be rewritten by a [D] a ~ ty, then we split it into [W] and [D], - putting the latter into the work list (see maybeEmitShadow). - -In the example above, we get to the point where we are stuck: - [WD] Foo ee ~ fmv - [WD] fmv ~ Maybe e - [WD] fmv ~ Maybe ee - -But now when [WD] fmv ~ Maybe ee is about to be added, we'll -split it into [W] and [D], since the inert [WD] fmv ~ Maybe e -can rewrite it. Then: - work item: [D] fmv ~ Maybe ee - inert: [W] fmv ~ Maybe ee - [WD] fmv ~ Maybe e -- (C) - [WD] Foo ee ~ fmv - -See Note [Splitting WD constraints]. Now the work item is rewritten -by (C) and we soon get ee := e. - -Additional notes: - - * The derived shadow equalities live in inert_eqs, along with - the Givens and Wanteds; see Note [EqualCtList invariants]. - - * We make Derived shadows only for Wanteds, not Givens. So we - have only [G], not [GD] and [G] plus splitting. See - Note [Add derived shadows only for Wanteds] - - * We also get Derived equalities from functional dependencies - and type-function injectivity; see calls to unifyDerived. - - * This splitting business applies to CFunEqCans too; and then - we do apply type-function reductions to the [D] CFunEqCan. - See Note [Reduction for Derived CFunEqCans] - - * It's worth having [WD] rather than just [W] and [D] because - * efficiency: silly to process the same thing twice - * inert_funeqs, inert_dicts is a finite map keyed by - the type; it's inconvenient for it to map to TWO constraints - -Note [Splitting WD constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are about to add a [WD] constraint to the inert set; and we -know that the inert set has fully rewritten it. Should we split -it into [W] and [D], and put the [D] in the work list for further -work? - -* CDictCan (C tys) or CFunEqCan (F tys ~ fsk): - Yes if the inert set could rewrite tys to make the class constraint, - or type family, fire. That is, yes if the inert_eqs intersects - with the free vars of tys. For this test we use - (anyRewritableTyVar True) which ignores casts and coercions in tys, - because rewriting the casts or coercions won't make the thing fire - more often. - -* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'. - We need to check both 'a' and 'ty' against the inert set: - - Inert set contains [D] a ~ ty2 - Then we want to put [D] a ~ ty in the worklist, so we'll - get [D] ty ~ ty2 with consequent good things - - - Inert set contains [D] b ~ a, where b is in ty. - We can't just add [WD] a ~ ty[b] to the inert set, because - that breaks the inert-set invariants. If we tried to - canonicalise another [D] constraint mentioning 'a', we'd - get an infinite loop - - Moreover we must use (anyRewritableTyVar False) for the RHS, - because even tyvars in the casts and coercions could give - an infinite loop if we don't expose it - -* CIrredCan: Yes if the inert set can rewrite the constraint. - We used to think splitting irreds was unnecessary, but - see Note [Splitting Irred WD constraints] - -* Others: nothing is gained by splitting. - -Note [Splitting Irred WD constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Splitting Irred constraints can make a difference. Here is the -scenario: - - a[sk] :: F v -- F is a type family - beta :: alpha - - work item: [WD] a ~ beta - -This is heterogeneous, so we try flattening the kinds. - - co :: F v ~ fmv - [WD] (a |> co) ~ beta - -This is still hetero, so we emit a kind equality and make the work item an -inert Irred. - - work item: [D] fmv ~ alpha - inert: [WD] (a |> co) ~ beta (CIrredCan) - -Can't make progress on the work item. Add to inert set. This kicks out the -old inert, because a [D] can rewrite a [WD]. - - work item: [WD] (a |> co) ~ beta - inert: [D] fmv ~ alpha (CTyEqCan) - -Can't make progress on this work item either (although GHC tries by -decomposing the cast and reflattening... but that doesn't make a difference), -which is still hetero. Emit a new kind equality and add to inert set. But, -critically, we split the Irred. - - work list: - [D] fmv ~ alpha (CTyEqCan) - [D] (a |> co) ~ beta (CIrred) -- this one was split off - inert: - [W] (a |> co) ~ beta - [D] fmv ~ alpha - -We quickly solve the first work item, as it's the same as an inert. - - work item: [D] (a |> co) ~ beta - inert: - [W] (a |> co) ~ beta - [D] fmv ~ alpha - -We decompose the cast, yielding - - [D] a ~ beta - -We then flatten the kinds. The lhs kind is F v, which flattens to fmv which -then rewrites to alpha. - - co' :: F v ~ alpha - [D] (a |> co') ~ beta - -Now this equality is homo-kinded. So we swizzle it around to - - [D] beta ~ (a |> co') - -and set beta := a |> co', and go home happy. - -If we don't split the Irreds, we loop. This is all dangerously subtle. - -This is triggered by test case typecheck/should_compile/SplitWD. - -Note [Examples of how Derived shadows helps completeness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#10009, a very nasty example: - - f :: (UnF (F b) ~ b) => F b -> () - - g :: forall a. (UnF (F a) ~ a) => a -> () - g _ = f (undefined :: F a) - - For g we get [G] UnF (F a) ~ a - [WD] UnF (F beta) ~ beta - [WD] F a ~ F beta - Flatten: - [G] g1: F a ~ fsk1 fsk1 := F a - [G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1 - [G] g3: fsk2 ~ a - - [WD] w1: F beta ~ fmv1 - [WD] w2: UnF fmv1 ~ fmv2 - [WD] w3: fmv2 ~ beta - [WD] w4: fmv1 ~ fsk1 -- From F a ~ F beta using flat-cache - -- and re-orient to put meta-var on left - -Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2 -React that with g2: [D] d2: fmv2 ~ fsk2 -React that with w3: [D] beta ~ fsk2 - and g3: [D] beta ~ a -- Hooray beta := a -And that is enough to solve everything - -Note [Add derived shadows only for Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only add shadows for Wanted constraints. That is, we have -[WD] but not [GD]; and maybeEmitShaodw looks only at [WD] -constraints. - -It does just possibly make sense ot add a derived shadow for a -Given. If we created a Derived shadow of a Given, it could be -rewritten by other Deriveds, and that could, conceivably, lead to a -useful unification. - -But (a) I have been unable to come up with an example of this - happening - (b) see #12660 for how adding the derived shadows - of a Given led to an infinite loop. - (c) It's unlikely that rewriting derived Givens will lead - to a unification because Givens don't mention touchable - unification variables - -For (b) there may be other ways to solve the loop, but simply -reraining from adding derived shadows of Givens is particularly -simple. And it's more efficient too! - -Still, here's one possible reason for adding derived shadows -for Givens. Consider - work-item [G] a ~ [b], inerts has [D] b ~ a. -If we added the derived shadow (into the work list) - [D] a ~ [b] -When we process it, we'll rewrite to a ~ [a] and get an -occurs check. Without it we'll miss the occurs check (reporting -inaccessible code); but that's probably OK. - -Note [Keep CDictCan shadows as CDictCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class C a => D a b -and [G] D a b, [G] C a in the inert set. Now we insert -[D] b ~ c. We want to kick out a derived shadow for [D] D a b, -so we can rewrite it with the new constraint, and perhaps get -instance reduction or other consequences. - -BUT we do not want to kick out a *non-canonical* (D a b). If we -did, we would do this: - - rewrite it to [D] D a c, with pend_sc = True - - use expandSuperClasses to add C a - - go round again, which solves C a from the givens -This loop goes on for ever and triggers the simpl_loop limit. - -Solution: kick out the CDictCan which will have pend_sc = False, -because we've already added its superclasses. So we won't re-add -them. If we forget the pend_sc flag, our cunning scheme for avoiding -generating superclasses repeatedly will fail. - -See #11379 for a case of this. - -Note [Do not do improvement for WOnly] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do improvement between two constraints (e.g. for injectivity -or functional dependencies) only if both are "improvable". And -we improve a constraint wrt the top-level instances only if -it is improvable. - -Improvable: [G] [WD] [D} -Not improvable: [W] - -Reasons: - -* It's less work: fewer pairs to compare - -* Every [W] has a shadow [D] so nothing is lost - -* Consider [WD] C Int b, where 'b' is a skolem, and - class C a b | a -> b - instance C Int Bool - We'll do a fundep on it and emit [D] b ~ Bool - That will kick out constraint [WD] C Int b - Then we'll split it to [W] C Int b (keep in inert) - and [D] C Int b (in work list) - When processing the latter we'll rewrite it to - [D] C Int Bool - At that point it would be /stupid/ to interact it - with the inert [W] C Int b in the inert set; after all, - it's the very constraint from which the [D] C Int Bool - was split! We can avoid this by not doing improvement - on [W] constraints. This came up in #12860. --} - -maybeEmitShadow :: InertCans -> Ct -> TcS Ct --- See Note [The improvement story and derived shadows] -maybeEmitShadow ics ct - | let ev = ctEvidence ct - , CtWanted { ctev_pred = pred, ctev_loc = loc - , ctev_nosh = WDeriv } <- ev - , shouldSplitWD (inert_eqs ics) ct - = do { traceTcS "Emit derived shadow" (ppr ct) - ; let derived_ev = CtDerived { ctev_pred = pred - , ctev_loc = loc } - shadow_ct = ct { cc_ev = derived_ev } - -- Te shadow constraint keeps the canonical shape. - -- This just saves work, but is sometimes important; - -- see Note [Keep CDictCan shadows as CDictCan] - ; emitWork [shadow_ct] - - ; let ev' = ev { ctev_nosh = WOnly } - ct' = ct { cc_ev = ev' } - -- Record that it now has a shadow - -- This is /the/ place we set the flag to WOnly - ; return ct' } - - | otherwise - = return ct - -shouldSplitWD :: InertEqs -> Ct -> Bool --- Precondition: 'ct' is [WD], and is inert --- True <=> we should split ct ito [W] and [D] because --- the inert_eqs can make progress on the [D] --- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys }) - = should_split_match_args inert_eqs tys - -- We don't need to split if the tv is the RHS fsk - -shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys }) - = should_split_match_args inert_eqs tys - -- NB True: ignore coercions - -- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty - , cc_eq_rel = eq_rel }) - = tv `elemDVarEnv` inert_eqs - || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty - -- NB False: do not ignore casts and coercions - -- See Note [Splitting WD constraints] - -shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev }) - = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev) - -shouldSplitWD _ _ = False -- No point in splitting otherwise - -should_split_match_args :: InertEqs -> [TcType] -> Bool --- True if the inert_eqs can rewrite anything in the argument --- types, ignoring casts and coercions -should_split_match_args inert_eqs tys - = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys - -- NB True: ignore casts coercions - -- See Note [Splitting WD constraints] - -canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool -canRewriteTv inert_eqs eq_rel tv - | Just (ct : _) <- lookupDVarEnv inert_eqs tv - , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct - = eq_rel1 `eqCanRewrite` eq_rel - | otherwise - = False - -isImprovable :: CtEvidence -> Bool --- See Note [Do not do improvement for WOnly] -isImprovable (CtWanted { ctev_nosh = WOnly }) = False -isImprovable _ = True - - -{- ********************************************************************* -* * - Inert equalities -* * -********************************************************************* -} - -addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs -addTyEq old_eqs tv ct - = extendDVarEnv_C add_eq old_eqs tv [ct] - where - add_eq old_eqs _ - | isWantedCt ct - , (eq1 : eqs) <- old_eqs - = eq1 : ct : eqs - | otherwise - = ct : old_eqs - -foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b -foldTyEqs k eqs z - = foldDVarEnv (\cts z -> foldr k z cts) z eqs - -findTyEqs :: InertCans -> TyVar -> EqualCtList -findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` [] - -delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs -delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv - where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1 - isThisOne _ = False - -lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType -lookupInertTyVar ieqs tv - = case lookupDVarEnv ieqs tv of - Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs - _ -> Nothing - -{- ********************************************************************* -* * - Inert instances: inert_insts -* * -********************************************************************* -} - -addInertForAll :: QCInst -> TcS () --- Add a local Given instance, typically arising from a type signature -addInertForAll new_qci - = do { ics <- getInertCans - ; insts' <- add_qci (inert_insts ics) - ; setInertCans (ics { inert_insts = insts' }) } - where - add_qci :: [QCInst] -> TcS [QCInst] - -- See Note [Do not add duplicate quantified instances] - add_qci qcis - | any same_qci qcis - = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci) - ; return qcis } - - | otherwise - = do { traceTcS "adding new inert quantified instance" (ppr new_qci) - ; return (new_qci : qcis) } - - same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci)) - (ctEvPred (qci_ev new_qci)) - -{- Note [Do not add duplicate quantified instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#15244): - - f :: (C g, D g) => .... - class S g => C g where ... - class S g => D g where ... - class (forall a. Eq a => Eq (g a)) => S g where ... - -Then in f's RHS there are two identical quantified constraints -available, one via the superclasses of C and one via the superclasses -of D. The two are identical, and it seems wrong to reject the program -because of that. But without doing duplicate-elimination we will have -two matching QCInsts when we try to solve constraints arising from f's -RHS. - -The simplest thing is simply to eliminate duplicates, which we do here. --} - -{- ********************************************************************* -* * - Adding an inert -* * -************************************************************************ - -Note [Adding an equality to the InertCans] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When adding an equality to the inerts: - -* Split [WD] into [W] and [D] if the inerts can rewrite the latter; - done by maybeEmitShadow. - -* Kick out any constraints that can be rewritten by the thing - we are adding. Done by kickOutRewritable. - -* Note that unifying a:=ty, is like adding [G] a~ty; just use - kickOutRewritable with Nominal, Given. See kickOutAfterUnification. - -Note [Kicking out CFunEqCan for fundeps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - New: [D] fmv1 ~ fmv2 - Inert: [W] F alpha ~ fmv1 - [W] F beta ~ fmv2 - -where F is injective. The new (derived) equality certainly can't -rewrite the inerts. But we *must* kick out the first one, to get: - - New: [W] F alpha ~ fmv1 - Inert: [W] F beta ~ fmv2 - [D] fmv1 ~ fmv2 - -and now improvement will discover [D] alpha ~ beta. This is important; -eg in #9587. - -So in kickOutRewritable we look at all the tyvars of the -CFunEqCan, including the fsk. --} - -addInertCan :: Ct -> TcS () -- Constraints *other than* equalities --- Precondition: item /is/ canonical --- See Note [Adding an equality to the InertCans] -addInertCan ct - = do { traceTcS "insertInertCan {" $ - text "Trying to insert new inert item:" <+> ppr ct - - ; ics <- getInertCans - ; ct <- maybeEmitShadow ics ct - ; ics <- maybeKickOut ics ct - ; setInertCans (add_item ics ct) - - ; traceTcS "addInertCan }" $ empty } - -maybeKickOut :: InertCans -> Ct -> TcS InertCans --- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan -maybeKickOut ics ct - | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct - = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics - ; return ics' } - | otherwise - = return ics - -add_item :: InertCans -> Ct -> InertCans -add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) - = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item } - -add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev }) - = ics { inert_eqs = addTyEq (inert_eqs ics) tv item - , inert_count = bumpUnsolvedCount ev (inert_count ics) } - -add_item ics@(IC { inert_irreds = irreds, inert_count = count }) - item@(CIrredCan { cc_ev = ev, cc_status = status }) - = ics { inert_irreds = irreds `Bag.snocBag` item - , inert_count = case status of - InsolubleCIS -> count - _ -> bumpUnsolvedCount ev count } - -- inert_count does not include insolubles - - -add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) - = ics { inert_dicts = addDict (inert_dicts ics) cls tys item - , inert_count = bumpUnsolvedCount ev (inert_count ics) } - -add_item _ item - = pprPanic "upd_inert set: can't happen! Inserting " $ - ppr item -- Can't be CNonCanonical, CHoleCan, - -- because they only land in inert_irreds - -bumpUnsolvedCount :: CtEvidence -> Int -> Int -bumpUnsolvedCount ev n | isWanted ev = n+1 - | otherwise = n - - ------------------------------------------ -kickOutRewritable :: CtFlavourRole -- Flavour/role of the equality that - -- is being added to the inert set - -> TcTyVar -- The new equality is tv ~ ty - -> InertCans - -> TcS (Int, InertCans) -kickOutRewritable new_fr new_tv ics - = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics - n_kicked = workListSize kicked_out - - ; unless (n_kicked == 0) $ - do { updWorkListTcS (appendWorkList kicked_out) - ; csTraceTcS $ - hang (text "Kick out, tv =" <+> ppr new_tv) - 2 (vcat [ text "n-kicked =" <+> int n_kicked - , text "kicked_out =" <+> ppr kicked_out - , text "Residual inerts =" <+> ppr ics' ]) } - - ; return (n_kicked, ics') } - -kick_out_rewritable :: CtFlavourRole -- Flavour/role of the equality that - -- is being added to the inert set - -> TcTyVar -- The new equality is tv ~ ty - -> InertCans - -> (WorkList, InertCans) --- See Note [kickOutRewritable] -kick_out_rewritable new_fr new_tv - ics@(IC { inert_eqs = tv_eqs - , inert_dicts = dictmap - , inert_safehask = safehask - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_insts = old_insts - , inert_count = n }) - | not (new_fr `eqMayRewriteFR` new_fr) - = (emptyWorkList, ics) - -- If new_fr can't rewrite itself, it can't rewrite - -- anything else, so no need to kick out anything. - -- (This is a common case: wanteds can't rewrite wanteds) - -- Lemma (L2) in Note [Extending the inert equalities] - - | otherwise - = (kicked_out, inert_cans_in) - where - inert_cans_in = IC { inert_eqs = tv_eqs_in - , inert_dicts = dicts_in - , inert_safehask = safehask -- ?? - , inert_funeqs = feqs_in - , inert_irreds = irs_in - , inert_insts = insts_in - , inert_count = n - workListWantedCount kicked_out } - - kicked_out :: WorkList - -- NB: use extendWorkList to ensure that kicked-out equalities get priority - -- See Note [Prioritise equalities] (Kick-out). - -- The irreds may include non-canonical (hetero-kinded) equality - -- constraints, which perhaps may have become soluble after new_tv - -- is substituted; ditto the dictionaries, which may include (a~b) - -- or (a~~b) constraints. - kicked_out = foldr extendWorkListCt - (emptyWorkList { wl_eqs = tv_eqs_out - , wl_funeqs = feqs_out }) - ((dicts_out `andCts` irs_out) - `extendCtsList` insts_out) - - (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs - (feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap - -- See Note [Kicking out CFunEqCan for fundeps] - (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap - (irs_out, irs_in) = partitionBag kick_out_ct irreds - -- Kick out even insolubles: See Note [Rewrite insolubles] - -- Of course we must kick out irreducibles like (c a), in case - -- we can rewrite 'c' to something more useful - - -- Kick-out for inert instances - -- See Note [Quantified constraints] in TcCanonical - insts_out :: [Ct] - insts_in :: [QCInst] - (insts_out, insts_in) - | fr_may_rewrite (Given, NomEq) -- All the insts are Givens - = partitionWith kick_out_qci old_insts - | otherwise - = ([], old_insts) - kick_out_qci qci - | let ev = qci_ev qci - , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci)) - = Left (mkNonCanonical ev) - | otherwise - = Right qci - - (_, new_role) = new_fr - - fr_can_rewrite_ty :: EqRel -> Type -> Bool - fr_can_rewrite_ty role ty = anyRewritableTyVar False role - fr_can_rewrite_tv ty - fr_can_rewrite_tv :: EqRel -> TyVar -> Bool - fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role - && tv == new_tv - - fr_may_rewrite :: CtFlavourRole -> Bool - fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs - -- Can the new item rewrite the inert item? - - kick_out_ct :: Ct -> Bool - -- Kick it out if the new CTyEqCan can rewrite the inert one - -- See Note [kickOutRewritable] - kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct - = fr_may_rewrite fs - && fr_can_rewrite_ty role (ctPred ct) - -- False: ignore casts and coercions - -- NB: this includes the fsk of a CFunEqCan. It can't - -- actually be rewritten, but we need to kick it out - -- so we get to take advantage of injectivity - -- See Note [Kicking out CFunEqCan for fundeps] - - kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList) - -> ([Ct], DTyVarEnv EqualCtList) - kick_out_eqs eqs (acc_out, acc_in) - = (eqs_out ++ acc_out, case eqs_in of - [] -> acc_in - (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in) - where - (eqs_out, eqs_in) = partition kick_out_eq eqs - - -- Implements criteria K1-K3 in Note [Extending the inert equalities] - kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty - , cc_ev = ev, cc_eq_rel = eq_rel }) - | not (fr_may_rewrite fs) - = False -- Keep it in the inert set if the new thing can't rewrite it - - -- Below here (fr_may_rewrite fs) is True - | tv == new_tv = True -- (K1) - | kick_out_for_inertness = True - | kick_out_for_completeness = True - | otherwise = False - - where - fs = (ctEvFlavour ev, eq_rel) - kick_out_for_inertness - = (fs `eqMayRewriteFR` fs) -- (K2a) - && not (fs `eqMayRewriteFR` new_fr) -- (K2b) - && fr_can_rewrite_ty eq_rel rhs_ty -- (K2d) - -- (K2c) is guaranteed by the first guard of keep_eq - - kick_out_for_completeness - = case eq_rel of - NomEq -> rhs_ty `eqType` mkTyVarTy new_tv - ReprEq -> isTyVarHead new_tv rhs_ty - - kick_out_eq ct = pprPanic "keep_eq" (ppr ct) - -kickOutAfterUnification :: TcTyVar -> TcS Int -kickOutAfterUnification new_tv - = do { ics <- getInertCans - ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq) - new_tv ics - -- Given because the tv := xi is given; NomEq because - -- only nominal equalities are solved by unification - - ; setInertCans ics2 - ; return n_kicked } - --- See Wrinkle (2b) in Note [Equalities with incompatible kinds] in TcCanonical -kickOutAfterFillingCoercionHole :: CoercionHole -> TcS () -kickOutAfterFillingCoercionHole hole - = do { ics <- getInertCans - ; let (kicked_out, ics') = kick_out ics - n_kicked = workListSize kicked_out - - ; unless (n_kicked == 0) $ - do { updWorkListTcS (appendWorkList kicked_out) - ; csTraceTcS $ - hang (text "Kick out, hole =" <+> ppr hole) - 2 (vcat [ text "n-kicked =" <+> int n_kicked - , text "kicked_out =" <+> ppr kicked_out - , text "Residual inerts =" <+> ppr ics' ]) } - - ; setInertCans ics' } - where - kick_out :: InertCans -> (WorkList, InertCans) - kick_out ics@(IC { inert_irreds = irreds }) - = let (to_kick, to_keep) = partitionBag kick_ct irreds - - kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList - ics' = ics { inert_irreds = to_keep } - in - (kicked_out, ics') - - kick_ct :: Ct -> Bool - -- This is not particularly efficient. Ways to do better: - -- 1) Have a custom function that looks for a coercion hole and returns a Bool - -- 2) Keep co-hole-blocked constraints in a separate part of the inert set, - -- keyed by their co-hole. (Is it possible for more than one co-hole to be - -- in a constraint? I doubt it.) - kick_ct (CIrredCan { cc_ev = ev, cc_status = BlockedCIS }) - = coHoleCoVar hole `elemVarSet` tyCoVarsOfType (ctEvPred ev) - kick_ct _other = False - -{- Note [kickOutRewritable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [inert_eqs: the inert equalities]. - -When we add a new inert equality (a ~N ty) to the inert set, -we must kick out any inert items that could be rewritten by the -new equality, to maintain the inert-set invariants. - - - We want to kick out an existing inert constraint if - a) the new constraint can rewrite the inert one - b) 'a' is free in the inert constraint (so that it *will*) - rewrite it if we kick it out. - - For (b) we use tyCoVarsOfCt, which returns the type variables /and - the kind variables/ that are directly visible in the type. Hence - we will have exposed all the rewriting we care about to make the - most precise kinds visible for matching classes etc. No need to - kick out constraints that mention type variables whose kinds - contain this variable! - - - A Derived equality can kick out [D] constraints in inert_eqs, - inert_dicts, inert_irreds etc. - - - We don't kick out constraints from inert_solved_dicts, and - inert_solved_funeqs optimistically. But when we lookup we have to - take the substitution into account - - -Note [Rewrite insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an insoluble alpha ~ [alpha], which is insoluble -because an occurs check. And then we unify alpha := [Int]. Then we -really want to rewrite the insoluble to [Int] ~ [[Int]]. Now it can -be decomposed. Otherwise we end up with a "Can't match [Int] ~ -[[Int]]" which is true, but a bit confusing because the outer type -constructors match. - -Similarly, if we have a CHoleCan, we'd like to rewrite it with any -Givens, to give as informative an error messasge as possible -(#12468, #11325). - -Hence: - * In the main simplifier loops in TcSimplify (solveWanteds, - simpl_loop), we feed the insolubles in solveSimpleWanteds, - so that they get rewritten (albeit not solved). - - * We kick insolubles out of the inert set, if they can be - rewritten (see TcSMonad.kick_out_rewritable) - - * We rewrite those insolubles in TcCanonical. - See Note [Make sure that insolubles are fully rewritten] --} - - - --------------- -addInertSafehask :: InertCans -> Ct -> InertCans -addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) - = ics { inert_safehask = addDict (inert_dicts ics) cls tys item } - -addInertSafehask _ item - = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item - -insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS () --- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -insertSafeOverlapFailureTcS what item - | safeOverlap what = return () - | otherwise = updInertCans (\ics -> addInertSafehask ics item) - -getSafeOverlapFailures :: TcS Cts --- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify -getSafeOverlapFailures - = do { IC { inert_safehask = safehask } <- getInertCans - ; return $ foldDicts consCts safehask emptyCts } - --------------- -addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS () --- Conditionally add a new item in the solved set of the monad --- See Note [Solved dictionaries] -addSolvedDict what item cls tys - | isWanted item - , instanceReturnsDictCon what - = do { traceTcS "updSolvedSetTcs:" $ ppr item - ; updInertTcS $ \ ics -> - ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } } - | otherwise - = return () - -getSolvedDicts :: TcS (DictMap CtEvidence) -getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) } - -setSolvedDicts :: DictMap CtEvidence -> TcS () -setSolvedDicts solved_dicts - = updInertTcS $ \ ics -> - ics { inert_solved_dicts = solved_dicts } - - -{- ********************************************************************* -* * - Other inert-set operations -* * -********************************************************************* -} - -updInertTcS :: (InertSet -> InertSet) -> TcS () --- Modify the inert set with the supplied function -updInertTcS upd_fn - = do { is_var <- getTcSInertsRef - ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var - ; TcM.writeTcRef is_var (upd_fn curr_inert) }) } - -getInertCans :: TcS InertCans -getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) } - -setInertCans :: InertCans -> TcS () -setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics } - -updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a --- Modify the inert set with the supplied function -updRetInertCans upd_fn - = do { is_var <- getTcSInertsRef - ; wrapTcS (do { inerts <- TcM.readTcRef is_var - ; let (res, cans') = upd_fn (inert_cans inerts) - ; TcM.writeTcRef is_var (inerts { inert_cans = cans' }) - ; return res }) } - -updInertCans :: (InertCans -> InertCans) -> TcS () --- Modify the inert set with the supplied function -updInertCans upd_fn - = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) } - -updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertDicts upd_fn - = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) } - -updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertSafehask upd_fn - = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) } - -updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertFunEqs upd_fn - = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) } - -updInertIrreds :: (Cts -> Cts) -> TcS () --- Modify the inert set with the supplied function -updInertIrreds upd_fn - = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) } - -getInertEqs :: TcS (DTyVarEnv EqualCtList) -getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } - -getInertInsols :: TcS Cts --- Returns insoluble equality constraints --- specifically including Givens -getInertInsols = do { inert <- getInertCans - ; return (filterBag insolubleEqCt (inert_irreds inert)) } - -getInertGivens :: TcS [Ct] --- Returns the Given constraints in the inert set, --- with type functions *not* unflattened -getInertGivens - = do { inerts <- getInertCans - ; let all_cts = foldDicts (:) (inert_dicts inerts) - $ foldFunEqs (:) (inert_funeqs inerts) - $ concat (dVarEnvElts (inert_eqs inerts)) - ; return (filter isGivenCt all_cts) } - -getPendingGivenScs :: TcS [Ct] --- Find all inert Given dictionaries, or quantified constraints, --- whose cc_pend_sc flag is True --- and that belong to the current level --- Set their cc_pend_sc flag to False in the inert set, and return that Ct -getPendingGivenScs = do { lvl <- getTcLevel - ; updRetInertCans (get_sc_pending lvl) } - -get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans) -get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts }) - = ASSERT2( all isGivenCt sc_pending, ppr sc_pending ) - -- When getPendingScDics is called, - -- there are never any Wanteds in the inert set - (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' }) - where - sc_pending = sc_pend_insts ++ sc_pend_dicts - - sc_pend_dicts = foldDicts get_pending dicts [] - dicts' = foldr add dicts sc_pend_dicts - - (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts - - get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc = True - -- but flipping the flag - get_pending dict dicts - | Just dict' <- isPendingScDict dict - , belongs_to_this_level (ctEvidence dict) - = dict' : dicts - | otherwise - = dicts - - add :: Ct -> DictMap Ct -> DictMap Ct - add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts - = addDict dicts cls tys ct - add ct _ = pprPanic "getPendingScDicts" (ppr ct) - - get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) - get_pending_inst cts qci@(QCI { qci_ev = ev }) - | Just qci' <- isPendingScInst qci - , belongs_to_this_level ev - = (CQuantCan qci' : cts, qci') - | otherwise - = (cts, qci) - - belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl - -- We only want Givens from this level; see (3a) in - -- Note [The superclass story] in TcCanonical - -getUnsolvedInerts :: TcS ( Bag Implication - , Cts -- Tyvar eqs: a ~ ty - , Cts -- Fun eqs: F a ~ ty - , Cts ) -- All others --- Return all the unsolved [Wanted] or [Derived] constraints --- --- Post-condition: the returned simple constraints are all fully zonked --- (because they come from the inert set) --- the unsolved implics may not be -getUnsolvedInerts - = do { IC { inert_eqs = tv_eqs - , inert_funeqs = fun_eqs - , inert_irreds = irreds - , inert_dicts = idicts - } <- getInertCans - - ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts - unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts - unsolved_irreds = Bag.filterBag is_unsolved irreds - unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts - unsolved_others = unsolved_irreds `unionBags` unsolved_dicts - - ; implics <- getWorkListImplics - - ; traceTcS "getUnsolvedInerts" $ - vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs - , text "fun eqs =" <+> ppr unsolved_fun_eqs - , text "others =" <+> ppr unsolved_others - , text "implics =" <+> ppr implics ] - - ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, unsolved_others) } - where - add_if_unsolved :: Ct -> Cts -> Cts - add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts - | otherwise = cts - - is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived - - -- For CFunEqCans we ignore the Derived ones, and keep - -- only the Wanteds for flattening. The Derived ones - -- share a unification variable with the corresponding - -- Wanted, so we definitely don't want to participate - -- in unflattening - -- See Note [Type family equations] - add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts - | otherwise = cts - -isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool --- True if (a ~N ty) is in the inert set, in either Given or Wanted -isInInertEqs eqs tv rhs - = case lookupDVarEnv eqs tv of - Nothing -> False - Just cts -> any (same_pred rhs) cts - where - same_pred rhs ct - | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct - , NomEq <- eq_rel - , rhs `eqType` rhs2 = True - | otherwise = False - -getNoGivenEqs :: TcLevel -- TcLevel of this implication - -> [TcTyVar] -- Skolems of this implication - -> TcS ( Bool -- True <=> definitely no residual given equalities - , Cts ) -- Insoluble equalities arising from givens --- See Note [When does an implication have given equalities?] -getNoGivenEqs tclvl skol_tvs - = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds }) - <- getInertCans - ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds - || anyDVarEnv eqs_given_here ieqs - insols = filterBag insolubleEqCt irreds - -- Specifically includes ones that originated in some - -- outer context but were refined to an insoluble by - -- a local equality; so do /not/ add ct_given_here. - - ; traceTcS "getNoGivenEqs" $ - vcat [ if has_given_eqs then text "May have given equalities" - else text "No given equalities" - , text "Skols:" <+> ppr skol_tvs - , text "Inerts:" <+> ppr inerts - , text "Insols:" <+> ppr insols] - ; return (not has_given_eqs, insols) } - where - eqs_given_here :: EqualCtList -> Bool - eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })] - -- Givens are always a singleton - = not (skolem_bound_here tv) && ct_given_here ct - eqs_given_here _ = False - - ct_given_here :: Ct -> Bool - -- True for a Given bound by the current implication, - -- i.e. the current level - ct_given_here ct = isGiven ev - && tclvl == ctLocLevel (ctEvLoc ev) - where - ev = ctEvidence ct - - skol_tv_set = mkVarSet skol_tvs - skolem_bound_here tv -- See Note [Let-bound skolems] - = case tcTyVarDetails tv of - SkolemTv {} -> tv `elemVarSet` skol_tv_set - _ -> False - --- | Returns Given constraints that might, --- potentially, match the given pred. This is used when checking to see if a --- Given might overlap with an instance. See Note [Instance and Given overlap] --- in TcInteract. -matchableGivens :: CtLoc -> PredType -> InertSet -> Cts -matchableGivens loc_w pred_w (IS { inert_cans = inert_cans }) - = filterBag matchable_given all_relevant_givens - where - -- just look in class constraints and irreds. matchableGivens does get called - -- for ~R constraints, but we don't need to look through equalities, because - -- canonical equalities are used for rewriting. We'll only get caught by - -- non-canonical -- that is, irreducible -- equalities. - all_relevant_givens :: Cts - all_relevant_givens - | Just (clas, _) <- getClassPredTys_maybe pred_w - = findDictsByClass (inert_dicts inert_cans) clas - `unionBags` inert_irreds inert_cans - | otherwise - = inert_irreds inert_cans - - matchable_given :: Ct -> Bool - matchable_given ct - | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct - = mightMatchLater pred_g loc_g pred_w loc_w - - | otherwise - = False - -mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool -mightMatchLater given_pred given_loc wanted_pred wanted_loc - = not (prohibitedSuperClassSolve given_loc wanted_loc) - && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred]) - where - bind_meta_tv :: TcTyVar -> BindFlag - -- Any meta tyvar may be unified later, so we treat it as - -- bindable when unifying with givens. That ensures that we - -- conservatively assume that a meta tyvar might get unified with - -- something that matches the 'given', until demonstrated - -- otherwise. More info in Note [Instance and Given overlap] - -- in TcInteract - bind_meta_tv tv | isMetaTyVar tv - , not (isFskTyVar tv) = BindMe - | otherwise = Skolem - -prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool --- See Note [Solving superclass constraints] in TcInstDcls -prohibitedSuperClassSolve from_loc solve_loc - | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc - , ScOrigin wanted_size <- ctLocOrigin solve_loc - = given_size >= wanted_size - | otherwise - = False - -{- Note [Unsolved Derived equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In getUnsolvedInerts, we return a derived equality from the inert_eqs -because it is a candidate for floating out of this implication. We -only float equalities with a meta-tyvar on the left, so we only pull -those out here. - -Note [When does an implication have given equalities?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider an implication - beta => alpha ~ Int -where beta is a unification variable that has already been unified -to () in an outer scope. Then we can float the (alpha ~ Int) out -just fine. So when deciding whether the givens contain an equality, -we should canonicalise first, rather than just looking at the original -givens (#8644). - -So we simply look at the inert, canonical Givens and see if there are -any equalities among them, the calculation of has_given_eqs. There -are some wrinkles: - - * We must know which ones are bound in *this* implication and which - are bound further out. We can find that out from the TcLevel - of the Given, which is itself recorded in the tcl_tclvl field - of the TcLclEnv stored in the Given (ev_given_here). - - What about interactions between inner and outer givens? - - Outer given is rewritten by an inner given, then there must - have been an inner given equality, hence the “given-eq” flag - will be true anyway. - - - Inner given rewritten by outer, retains its level (ie. The inner one) - - * We must take account of *potential* equalities, like the one above: - beta => ...blah... - If we still don't know what beta is, we conservatively treat it as potentially - becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs. - - * When flattening givens, we generate Given equalities like - <F [a]> : F [a] ~ f, - with Refl evidence, and we *don't* want those to count as an equality - in the givens! After all, the entire flattening business is just an - internal matter, and the evidence does not mention any of the 'givens' - of this implication. So we do not treat inert_funeqs as a 'given equality'. - - * See Note [Let-bound skolems] for another wrinkle - - * We do *not* need to worry about representational equalities, because - these do not affect the ability to float constraints. - -Note [Let-bound skolems] -~~~~~~~~~~~~~~~~~~~~~~~~ -If * the inert set contains a canonical Given CTyEqCan (a ~ ty) -and * 'a' is a skolem bound in this very implication, - -then: -a) The Given is pretty much a let-binding, like - f :: (a ~ b->c) => a -> a - Here the equality constraint is like saying - let a = b->c in ... - It is not adding any new, local equality information, - and hence can be ignored by has_given_eqs - -b) 'a' will have been completely substituted out in the inert set, - so we can safely discard it. Notably, it doesn't need to be - returned as part of 'fsks' - -For an example, see #9211. - -See also TcUnify Note [Deeper level on the left] for how we ensure -that the right variable is on the left of the equality when both are -tyvars. - -You might wonder whether the skokem really needs to be bound "in the -very same implication" as the equuality constraint. -(c.f. #15009) Consider this: - - data S a where - MkS :: (a ~ Int) => S a - - g :: forall a. S a -> a -> blah - g x y = let h = \z. ( z :: Int - , case x of - MkS -> [y,z]) - in ... - -From the type signature for `g`, we get `y::a` . Then when when we -encounter the `\z`, we'll assign `z :: alpha[1]`, say. Next, from the -body of the lambda we'll get - - [W] alpha[1] ~ Int -- From z::Int - [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a -- From [y,z] - -Now, suppose we decide to float `alpha ~ a` out of the implication -and then unify `alpha := a`. Now we are stuck! But if treat -`alpha ~ Int` first, and unify `alpha := Int`, all is fine. -But we absolutely cannot float that equality or we will get stuck. --} - -removeInertCts :: [Ct] -> InertCans -> InertCans --- ^ Remove inert constraints from the 'InertCans', for use when a --- typechecker plugin wishes to discard a given. -removeInertCts cts icans = foldl' removeInertCt icans cts - -removeInertCt :: InertCans -> Ct -> InertCans -removeInertCt is ct = - case ct of - - CDictCan { cc_class = cl, cc_tyargs = tys } -> - is { inert_dicts = delDict (inert_dicts is) cl tys } - - CFunEqCan { cc_fun = tf, cc_tyargs = tys } -> - is { inert_funeqs = delFunEq (inert_funeqs is) tf tys } - - CTyEqCan { cc_tyvar = x, cc_rhs = ty } -> - is { inert_eqs = delTyEq (inert_eqs is) x ty } - - CQuantCan {} -> panic "removeInertCt: CQuantCan" - CIrredCan {} -> panic "removeInertCt: CIrredEvCan" - CNonCanonical {} -> panic "removeInertCt: CNonCanonical" - CHoleCan {} -> panic "removeInertCt: CHoleCan" - - -lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour)) -lookupFlatCache fam_tc tys - = do { IS { inert_flat_cache = flat_cache - , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts - ; return (firstJusts [lookup_inerts inert_funeqs, - lookup_flats flat_cache]) } - where - lookup_inerts inert_funeqs - | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis }) - <- findFunEq inert_funeqs fam_tc tys - , tys `eqTypes` xis -- The lookup might find a near-match; see - -- Note [Use loose types in inert set] - = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev) - | otherwise = Nothing - - lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys - - -lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) --- Is this exact predicate type cached in the solved or canonicals of the InertSet? -lookupInInerts loc pty - | ClassPred cls tys <- classifyPredType pty - = do { inerts <- getTcSInerts - ; return (lookupSolvedDict inerts loc cls tys `mplus` - lookupInertDict (inert_cans inerts) loc cls tys) } - | otherwise -- NB: No caching for equalities, IPs, holes, or errors - = return Nothing - --- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not --- match the input exactly. Note [Use loose types in inert set]. -lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence -lookupInertDict (IC { inert_dicts = dicts }) loc cls tys - = case findDict dicts loc cls tys of - Just ct -> Just (ctEvidence ct) - _ -> Nothing - --- | Look up a solved inert. NB: the returned 'CtEvidence' might not --- match the input exactly. See Note [Use loose types in inert set]. -lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence --- Returns just if exactly this predicate type exists in the solved. -lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys - = case findDict solved loc cls tys of - Just ev -> Just ev - _ -> Nothing - -{- ********************************************************************* -* * - Irreds -* * -********************************************************************* -} - -foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b -foldIrreds k irreds z = foldr k z irreds - - -{- ********************************************************************* -* * - TcAppMap -* * -************************************************************************ - -Note [Use loose types in inert set] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Say we know (Eq (a |> c1)) and we need (Eq (a |> c2)). One is clearly -solvable from the other. So, we do lookup in the inert set using -loose types, which omit the kind-check. - -We must be careful when using the result of a lookup because it may -not match the requested info exactly! - --} - -type TcAppMap a = UniqDFM (ListMap LooseTypeMap a) - -- Indexed by tycon then the arg types, using "loose" matching, where - -- we don't require kind equality. This allows, for example, (a |> co) - -- to match (a). - -- See Note [Use loose types in inert set] - -- Used for types and classes; hence UniqDFM - -- See Note [foldTM determinism] for why we use UniqDFM here - -isEmptyTcAppMap :: TcAppMap a -> Bool -isEmptyTcAppMap m = isNullUDFM m - -emptyTcAppMap :: TcAppMap a -emptyTcAppMap = emptyUDFM - -findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a -findTcApp m u tys = do { tys_map <- lookupUDFM m u - ; lookupTM tys tys_map } - -delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a -delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls - -insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a -insertTcApp m cls tys ct = alterUDFM alter_tm m cls - where - alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM)) - --- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b --- mapTcApp f = mapUDFM (mapTM f) - -filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct -filterTcAppMap f m - = mapUDFM do_tm m - where - do_tm tm = foldTM insert_mb tm emptyTM - insert_mb ct tm - | f ct = insertTM tys ct tm - | otherwise = tm - where - tys = case ct of - CFunEqCan { cc_tyargs = tys } -> tys - CDictCan { cc_tyargs = tys } -> tys - _ -> pprPanic "filterTcAppMap" (ppr ct) - -tcAppMapToBag :: TcAppMap a -> Bag a -tcAppMapToBag m = foldTcAppMap consBag m emptyBag - -foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b -foldTcAppMap k m z = foldUDFM (foldTM k) z m - - -{- ********************************************************************* -* * - DictMap -* * -********************************************************************* -} - - -{- Note [Tuples hiding implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f,g :: (?x::Int, C a) => a -> a - f v = let ?x = 4 in g v - -The call to 'g' gives rise to a Wanted constraint (?x::Int, C a). -We must /not/ solve this from the Given (?x::Int, C a), because of -the intervening binding for (?x::Int). #14218. - -We deal with this by arranging that we always fail when looking up a -tuple constraint that hides an implicit parameter. Not that this applies - * both to the inert_dicts (lookupInertDict) - * and to the solved_dicts (looukpSolvedDict) -An alternative would be not to extend these sets with such tuple -constraints, but it seemed more direct to deal with the lookup. - -Note [Solving CallStack constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose f :: HasCallStack => blah. Then - -* Each call to 'f' gives rise to - [W] s1 :: IP "callStack" CallStack -- CtOrigin = OccurrenceOf f - with a CtOrigin that says "OccurrenceOf f". - Remember that HasCallStack is just shorthand for - IP "callStack CallStack - See Note [Overview of implicit CallStacks] in TcEvidence - -* We cannonicalise such constraints, in TcCanonical.canClassNC, by - pushing the call-site info on the stack, and changing the CtOrigin - to record that has been done. - Bind: s1 = pushCallStack <site-info> s2 - [W] s2 :: IP "callStack" CallStack -- CtOrigin = IPOccOrigin - -* Then, and only then, we can solve the constraint from an enclosing - Given. - -So we must be careful /not/ to solve 's1' from the Givens. Again, -we ensure this by arranging that findDict always misses when looking -up souch constraints. --} - -type DictMap a = TcAppMap a - -emptyDictMap :: DictMap a -emptyDictMap = emptyTcAppMap - -findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a -findDict m loc cls tys - | isCTupleClass cls - , any hasIPPred tys -- See Note [Tuples hiding implicit parameters] - = Nothing - - | Just {} <- isCallStackPred cls tys - , OccurrenceOf {} <- ctLocOrigin loc - = Nothing -- See Note [Solving CallStack constraints] - - | otherwise - = findTcApp m (getUnique cls) tys - -findDictsByClass :: DictMap a -> Class -> Bag a -findDictsByClass m cls - | Just tm <- lookupUDFM m cls = foldTM consBag tm emptyBag - | otherwise = emptyBag - -delDict :: DictMap a -> Class -> [Type] -> DictMap a -delDict m cls tys = delTcApp m (getUnique cls) tys - -addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a -addDict m cls tys item = insertTcApp m (getUnique cls) tys item - -addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct -addDictsByClass m cls items - = addToUDFM m cls (foldr add emptyTM items) - where - add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm - add ct _ = pprPanic "addDictsByClass" (ppr ct) - -filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct -filterDicts f m = filterTcAppMap f m - -partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct) -partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts) - where - k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes) - | otherwise = (yeses, add ct noes) - add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m - = addDict m cls tys ct - add ct _ = pprPanic "partitionDicts" (ppr ct) - -dictsToBag :: DictMap a -> Bag a -dictsToBag = tcAppMapToBag - -foldDicts :: (a -> b -> b) -> DictMap a -> b -> b -foldDicts = foldTcAppMap - -emptyDicts :: DictMap a -emptyDicts = emptyTcAppMap - - -{- ********************************************************************* -* * - FunEqMap -* * -********************************************************************* -} - -type FunEqMap a = TcAppMap a -- A map whose key is a (TyCon, [Type]) pair - -emptyFunEqs :: TcAppMap a -emptyFunEqs = emptyTcAppMap - -findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a -findFunEq m tc tys = findTcApp m (getUnique tc) tys - -funEqsToBag :: FunEqMap a -> Bag a -funEqsToBag m = foldTcAppMap consBag m emptyBag - -findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] --- Get inert function equation constraints that have the given tycon --- in their head. Not that the constraints remain in the inert set. --- We use this to check for derived interactions with built-in type-function --- constructors. -findFunEqsByTyCon m tc - | Just tm <- lookupUDFM m tc = foldTM (:) tm [] - | otherwise = [] - -foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b -foldFunEqs = foldTcAppMap - --- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b --- mapFunEqs = mapTcApp - --- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct --- filterFunEqs = filterTcAppMap - -insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a -insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val - -partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct) --- Optimise for the case where the predicate is false --- partitionFunEqs is called only from kick-out, and kick-out usually --- kicks out very few equalities, so we want to optimise for that case -partitionFunEqs f m = (yeses, foldr del m yeses) - where - yeses = foldTcAppMap k m [] - k ct yeses | f ct = ct : yeses - | otherwise = yeses - del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m - = delFunEq m tc tys - del ct _ = pprPanic "partitionFunEqs" (ppr ct) - -delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a -delFunEq m tc tys = delTcApp m (getUnique tc) tys - ------------------------------- -type ExactFunEqMap a = UniqFM (ListMap TypeMap a) - -emptyExactFunEqs :: ExactFunEqMap a -emptyExactFunEqs = emptyUFM - -findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a -findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc) - ; lookupTM tys tys_map } - -insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a -insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc) - where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM)) - -{- -************************************************************************ -* * -* The TcS solver monad * -* * -************************************************************************ - -Note [The TcS monad] -~~~~~~~~~~~~~~~~~~~~ -The TcS monad is a weak form of the main Tc monad - -All you can do is - * fail - * allocate new variables - * fill in evidence variables - -Filling in a dictionary evidence variable means to create a binding -for it, so TcS carries a mutable location where the binding can be -added. This is initialised from the innermost implication constraint. --} - -data TcSEnv - = TcSEnv { - tcs_ev_binds :: EvBindsVar, - - tcs_unified :: IORef Int, - -- The number of unification variables we have filled - -- The important thing is whether it is non-zero - - tcs_count :: IORef Int, -- Global step count - - tcs_inerts :: IORef InertSet, -- Current inert set - - -- The main work-list and the flattening worklist - -- See Note [Work list priorities] and - tcs_worklist :: IORef WorkList -- Current worklist - } - ---------------- -newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor) - -instance Applicative TcS where - pure x = TcS (\_ -> return x) - (<*>) = ap - -instance Monad TcS where - m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs) - -instance MonadFail TcS where - fail err = TcS (\_ -> fail err) - -instance MonadUnique TcS where - getUniqueSupplyM = wrapTcS getUniqueSupplyM - -instance HasModule TcS where - getModule = wrapTcS getModule - -instance MonadThings TcS where - lookupThing n = wrapTcS (lookupThing n) - --- Basic functionality --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -wrapTcS :: TcM a -> TcS a --- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS, --- and TcS is supposed to have limited functionality -wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds - -wrapErrTcS :: TcM a -> TcS a --- The thing wrapped should just fail --- There's no static check; it's up to the user --- Having a variant for each error message is too painful -wrapErrTcS = wrapTcS - -wrapWarnTcS :: TcM a -> TcS a --- The thing wrapped should just add a warning, or no-op --- There's no static check; it's up to the user -wrapWarnTcS = wrapTcS - -failTcS, panicTcS :: SDoc -> TcS a -warnTcS :: WarningFlag -> SDoc -> TcS () -addErrTcS :: SDoc -> TcS () -failTcS = wrapTcS . TcM.failWith -warnTcS flag = wrapTcS . TcM.addWarn (Reason flag) -addErrTcS = wrapTcS . TcM.addErr -panicTcS doc = pprPanic "TcCanonical" doc - -traceTcS :: String -> SDoc -> TcS () -traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) - -runTcPluginTcS :: TcPluginM a -> TcS a -runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar - -instance HasDynFlags TcS where - getDynFlags = wrapTcS getDynFlags - -getGlobalRdrEnvTcS :: TcS GlobalRdrEnv -getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv - -bumpStepCountTcS :: TcS () -bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env - ; n <- TcM.readTcRef ref - ; TcM.writeTcRef ref (n+1) } - -csTraceTcS :: SDoc -> TcS () -csTraceTcS doc - = wrapTcS $ csTraceTcM (return doc) - -traceFireTcS :: CtEvidence -> SDoc -> TcS () --- Dump a rule-firing trace -traceFireTcS ev doc - = TcS $ \env -> csTraceTcM $ - do { n <- TcM.readTcRef (tcs_count env) - ; tclvl <- TcM.getTcLevel - ; return (hang (text "Step" <+> int n - <> brackets (text "l:" <> ppr tclvl <> comma <> - text "d:" <> ppr (ctLocDepth (ctEvLoc ev))) - <+> doc <> colon) - 4 (ppr ev)) } - -csTraceTcM :: TcM SDoc -> TcM () --- Constraint-solver tracing, -ddump-cs-trace -csTraceTcM mk_doc - = do { dflags <- getDynFlags - ; when ( dopt Opt_D_dump_cs_trace dflags - || dopt Opt_D_dump_tc_trace dflags ) - ( do { msg <- mk_doc - ; TcM.dumpTcRn False - (dumpOptionsFromFlag Opt_D_dump_cs_trace) - "" FormatText - msg }) } - -runTcS :: TcS a -- What to run - -> TcM (a, EvBindMap) -runTcS tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; res <- runTcSWithEvBinds ev_binds_var tcs - ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var - ; return (res, ev_binds) } - --- | This variant of 'runTcS' will keep solving, even when only Deriveds --- are left around. It also doesn't return any evidence, as callers won't --- need it. -runTcSDeriveds :: TcS a -> TcM a -runTcSDeriveds tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds ev_binds_var tcs } - --- | This can deal only with equality constraints. -runTcSEqualities :: TcS a -> TcM a -runTcSEqualities thing_inside - = do { ev_binds_var <- TcM.newNoTcEvBinds - ; runTcSWithEvBinds ev_binds_var thing_inside } - -runTcSWithEvBinds :: EvBindsVar - -> TcS a - -> TcM a -runTcSWithEvBinds ev_binds_var tcs - = do { unified_var <- TcM.newTcRef 0 - ; step_count <- TcM.newTcRef 0 - ; inert_var <- TcM.newTcRef emptyInert - ; wl_var <- TcM.newTcRef emptyWorkList - ; let env = TcSEnv { tcs_ev_binds = ev_binds_var - , tcs_unified = unified_var - , tcs_count = step_count - , tcs_inerts = inert_var - , tcs_worklist = wl_var } - - -- Run the computation - ; res <- unTcS tcs env - - ; count <- TcM.readTcRef step_count - ; when (count > 0) $ - csTraceTcM $ return (text "Constraint solver steps =" <+> int count) - - ; unflattenGivens inert_var - -#if defined(DEBUG) - ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var - ; checkForCyclicBinds ev_binds -#endif - - ; return res } - ----------------------------- -#if defined(DEBUG) -checkForCyclicBinds :: EvBindMap -> TcM () -checkForCyclicBinds ev_binds_map - | null cycles - = return () - | null coercion_cycles - = TcM.traceTc "Cycle in evidence binds" $ ppr cycles - | otherwise - = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles - where - ev_binds = evBindMapBinds ev_binds_map - - cycles :: [[EvBind]] - cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges] - - coercion_cycles = [c | c <- cycles, any is_co_bind c] - is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b) - - edges :: [ Node EvVar EvBind ] - edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs)) - | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ] - -- It's OK to use nonDetEltsUFM here as - -- stronglyConnCompFromEdgedVertices is still deterministic even - -- if the edges are in nondeterministic order as explained in - -- Note [Deterministic SCC] in Digraph. -#endif - ----------------------------- -setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a -setEvBindsTcS ref (TcS thing_inside) - = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref }) - -nestImplicTcS :: EvBindsVar - -> TcLevel -> TcS a - -> TcS a -nestImplicTcS ref inner_tclvl (TcS thing_inside) - = TcS $ \ TcSEnv { tcs_unified = unified_var - , tcs_inerts = old_inert_var - , tcs_count = count - } -> - do { inerts <- TcM.readTcRef old_inert_var - ; let nest_inert = emptyInert - { inert_cans = inert_cans inerts - , inert_solved_dicts = inert_solved_dicts inerts } - -- See Note [Do not inherit the flat cache] - ; new_inert_var <- TcM.newTcRef nest_inert - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = TcSEnv { tcs_ev_binds = ref - , tcs_unified = unified_var - , tcs_count = count - , tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var } - ; res <- TcM.setTcLevel inner_tclvl $ - thing_inside nest_env - - ; unflattenGivens new_inert_var - -#if defined(DEBUG) - -- Perform a check that the thing_inside did not cause cycles - ; ev_binds <- TcM.getTcEvBindsMap ref - ; checkForCyclicBinds ev_binds -#endif - ; return res } - -{- Note [Do not inherit the flat cache] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want to inherit the flat cache when processing nested -implications. Consider - a ~ F b, forall c. b~Int => blah -If we have F b ~ fsk in the flat-cache, and we push that into the -nested implication, we might miss that F b can be rewritten to F Int, -and hence perhaps solve it. Moreover, the fsk from outside is -flattened out after solving the outer level, but and we don't -do that flattening recursively. --} - -nestTcS :: TcS a -> TcS a --- Use the current untouchables, augmenting the current --- evidence bindings, and solved dictionaries --- But have no effect on the InertCans, or on the inert_flat_cache --- (we want to inherit the latter from processing the Givens) -nestTcS (TcS thing_inside) - = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> - do { inerts <- TcM.readTcRef inerts_var - ; new_inert_var <- TcM.newTcRef inerts - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = env { tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var } - - ; res <- thing_inside nest_env - - ; new_inerts <- TcM.readTcRef new_inert_var - - -- we want to propagate the safe haskell failures - ; let old_ic = inert_cans inerts - new_ic = inert_cans new_inerts - nxt_ic = old_ic { inert_safehask = inert_safehask new_ic } - - ; TcM.writeTcRef inerts_var -- See Note [Propagate the solved dictionaries] - (inerts { inert_solved_dicts = inert_solved_dicts new_inerts - , inert_cans = nxt_ic }) - - ; return res } - -emitImplicationTcS :: TcLevel -> SkolemInfo - -> [TcTyVar] -- Skolems - -> [EvVar] -- Givens - -> Cts -- Wanteds - -> TcS TcEvBinds --- Add an implication to the TcS monad work-list -emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds - = do { let wc = emptyWC { wc_simple = wanteds } - ; imp <- wrapTcS $ - do { ev_binds_var <- TcM.newTcEvBinds - ; imp <- TcM.newImplication - ; return (imp { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_given = givens - , ic_wanted = wc - , ic_binds = ev_binds_var - , ic_info = skol_info }) } - - ; emitImplication imp - ; return (TcEvBinds (ic_binds imp)) } - -emitTvImplicationTcS :: TcLevel -> SkolemInfo - -> [TcTyVar] -- Skolems - -> Cts -- Wanteds - -> TcS () --- Just like emitImplicationTcS but no givens and no bindings -emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds - = do { let wc = emptyWC { wc_simple = wanteds } - ; imp <- wrapTcS $ - do { ev_binds_var <- TcM.newNoTcEvBinds - ; imp <- TcM.newImplication - ; return (imp { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_wanted = wc - , ic_binds = ev_binds_var - , ic_info = skol_info }) } - - ; emitImplication imp } - - -{- Note [Propagate the solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's really quite important that nestTcS does not discard the solved -dictionaries from the thing_inside. -Consider - Eq [a] - forall b. empty => Eq [a] -We solve the simple (Eq [a]), under nestTcS, and then turn our attention to -the implications. It's definitely fine to use the solved dictionaries on -the inner implications, and it can make a significant performance difference -if you do so. --} - --- Getters and setters of TcEnv fields --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- Getter of inerts and worklist -getTcSInertsRef :: TcS (IORef InertSet) -getTcSInertsRef = TcS (return . tcs_inerts) - -getTcSWorkListRef :: TcS (IORef WorkList) -getTcSWorkListRef = TcS (return . tcs_worklist) - -getTcSInerts :: TcS InertSet -getTcSInerts = getTcSInertsRef >>= readTcRef - -setTcSInerts :: InertSet -> TcS () -setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics } - -getWorkListImplics :: TcS (Bag Implication) -getWorkListImplics - = do { wl_var <- getTcSWorkListRef - ; wl_curr <- readTcRef wl_var - ; return (wl_implics wl_curr) } - -pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a) --- Push the level and run thing_inside --- However, thing_inside should not generate any work items -#if defined(DEBUG) -pushLevelNoWorkList err_doc (TcS thing_inside) - = TcS (\env -> TcM.pushTcLevelM $ - thing_inside (env { tcs_worklist = wl_panic }) - ) - where - wl_panic = pprPanic "TcSMonad.buildImplication" err_doc - -- This panic checks that the thing-inside - -- does not emit any work-list constraints -#else -pushLevelNoWorkList _ (TcS thing_inside) - = TcS (\env -> TcM.pushTcLevelM (thing_inside env)) -- Don't check -#endif - -updWorkListTcS :: (WorkList -> WorkList) -> TcS () -updWorkListTcS f - = do { wl_var <- getTcSWorkListRef - ; updTcRef wl_var f } - -emitWorkNC :: [CtEvidence] -> TcS () -emitWorkNC evs - | null evs - = return () - | otherwise - = emitWork (map mkNonCanonical evs) - -emitWork :: [Ct] -> TcS () -emitWork [] = return () -- avoid printing, among other work -emitWork cts - = do { traceTcS "Emitting fresh work" (vcat (map ppr cts)) - ; updWorkListTcS (extendWorkListCts cts) } - -emitImplication :: Implication -> TcS () -emitImplication implic - = updWorkListTcS (extendWorkListImplic implic) - -newTcRef :: a -> TcS (TcRef a) -newTcRef x = wrapTcS (TcM.newTcRef x) - -readTcRef :: TcRef a -> TcS a -readTcRef ref = wrapTcS (TcM.readTcRef ref) - -writeTcRef :: TcRef a -> a -> TcS () -writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val) - -updTcRef :: TcRef a -> (a->a) -> TcS () -updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn) - -getTcEvBindsVar :: TcS EvBindsVar -getTcEvBindsVar = TcS (return . tcs_ev_binds) - -getTcLevel :: TcS TcLevel -getTcLevel = wrapTcS TcM.getTcLevel - -getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet -getTcEvTyCoVars ev_binds_var - = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var - -getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap -getTcEvBindsMap ev_binds_var - = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var - -setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS () -setTcEvBindsMap ev_binds_var binds - = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds - -unifyTyVar :: TcTyVar -> TcType -> TcS () --- Unify a meta-tyvar with a type --- We keep track of how many unifications have happened in tcs_unified, --- --- We should never unify the same variable twice! -unifyTyVar tv ty - = ASSERT2( isMetaTyVar tv, ppr tv ) - TcS $ \ env -> - do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty) - ; TcM.writeMetaTyVar tv ty - ; TcM.updTcRef (tcs_unified env) (+1) } - -reportUnifications :: TcS a -> TcS (Int, a) -reportUnifications (TcS thing_inside) - = TcS $ \ env -> - do { inner_unified <- TcM.newTcRef 0 - ; res <- thing_inside (env { tcs_unified = inner_unified }) - ; n_unifs <- TcM.readTcRef inner_unified - ; TcM.updTcRef (tcs_unified env) (+ n_unifs) - ; return (n_unifs, res) } - -getDefaultInfo :: TcS ([Type], (Bool, Bool)) -getDefaultInfo = wrapTcS TcM.tcGetDefaultTys - --- Just get some environments needed for instance looking up and matching --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -getInstEnvs :: TcS InstEnvs -getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs - -getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) -getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs - -getTopEnv :: TcS HscEnv -getTopEnv = wrapTcS $ TcM.getTopEnv - -getGblEnv :: TcS TcGblEnv -getGblEnv = wrapTcS $ TcM.getGblEnv - -getLclEnv :: TcS TcLclEnv -getLclEnv = wrapTcS $ TcM.getLclEnv - -tcLookupClass :: Name -> TcS Class -tcLookupClass c = wrapTcS $ TcM.tcLookupClass c - -tcLookupId :: Name -> TcS Id -tcLookupId n = wrapTcS $ TcM.tcLookupId n - --- Setting names as used (used in the deriving of Coercible evidence) --- Too hackish to expose it to TcS? In that case somehow extract the used --- constructors from the result of solveInteract -addUsedGREs :: [GlobalRdrElt] -> TcS () -addUsedGREs gres = wrapTcS $ TcM.addUsedGREs gres - -addUsedGRE :: Bool -> GlobalRdrElt -> TcS () -addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre - -keepAlive :: Name -> TcS () -keepAlive = wrapTcS . TcM.keepAlive - --- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS () --- Check that we do not try to use an instance before it is available. E.g. --- instance Eq T where ... --- f x = $( ... (\(p::T) -> p == p)... ) --- Here we can't use the equality function from the instance in the splice - -checkWellStagedDFun loc what pred - | TopLevInstance { iw_dfun_id = dfun_id } <- what - , let bind_lvl = TcM.topIdLvl dfun_id - , bind_lvl > impLevel - = wrapTcS $ TcM.setCtLocM loc $ - do { use_stage <- TcM.getStage - ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) } - - | otherwise - = return () -- Fast path for common case - where - pp_thing = text "instance for" <+> quotes (ppr pred) - -pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2 - -isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type) -isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv) - -isFilledMetaTyVar :: TcTyVar -> TcS Bool -isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv) - -zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet -zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs) - -zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar] -zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs) - -zonkCo :: Coercion -> TcS Coercion -zonkCo = wrapTcS . TcM.zonkCo - -zonkTcType :: TcType -> TcS TcType -zonkTcType ty = wrapTcS (TcM.zonkTcType ty) - -zonkTcTypes :: [TcType] -> TcS [TcType] -zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys) - -zonkTcTyVar :: TcTyVar -> TcS TcType -zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv) - -zonkSimples :: Cts -> TcS Cts -zonkSimples cts = wrapTcS (TcM.zonkSimples cts) - -zonkWC :: WantedConstraints -> TcS WantedConstraints -zonkWC wc = wrapTcS (TcM.zonkWC wc) - -zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar -zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv) - -{- ********************************************************************* -* * -* Flatten skolems * -* * -********************************************************************* -} - -newFlattenSkolem :: CtFlavour -> CtLoc - -> TyCon -> [TcType] -- F xis - -> TcS (CtEvidence, Coercion, TcTyVar) -- [G/WD] x:: F xis ~ fsk -newFlattenSkolem flav loc tc xis - = do { stuff@(ev, co, fsk) <- new_skolem - ; let fsk_ty = mkTyVarTy fsk - ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev) - ; return stuff } - where - fam_ty = mkTyConApp tc xis - - new_skolem - | Given <- flav - = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty) - - -- Extend the inert_fsks list, for use by unflattenGivens - ; updInertTcS $ \is -> is { inert_fsks = (fsk, fam_ty) : inert_fsks is } - - -- Construct the Refl evidence - ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk) - co = mkNomReflCo fam_ty - ; ev <- newGivenEvVar loc (pred, evCoercion co) - ; return (ev, co, fsk) } - - | otherwise -- Generate a [WD] for both Wanted and Derived - -- See Note [No Derived CFunEqCans] - = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty) - -- See (2a) in TcCanonical - -- Note [Equalities with incompatible kinds] - ; (ev, hole_co) <- newWantedEq_SI NoBlockSubst WDeriv loc Nominal - fam_ty (mkTyVarTy fmv) - ; return (ev, hole_co, fmv) } - ----------------------------- -unflattenGivens :: IORef InertSet -> TcM () --- Unflatten all the fsks created by flattening types in Given --- constraints. We must be sure to do this, else we end up with --- flatten-skolems buried in any residual Wanteds --- --- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv) --- is filled in. Nothing else does so. --- --- It's here (rather than in TcFlatten) because the Right Places --- to call it are in runTcSWithEvBinds/nestImplicTcS, where it --- is nicely paired with the creation an empty inert_fsks list. -unflattenGivens inert_var - = do { inerts <- TcM.readTcRef inert_var - ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts)) - ; mapM_ flatten_one (inert_fsks inerts) } - where - flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty - ----------------------------- -extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS () -extendFlatCache tc xi_args stuff@(_, ty, fl) - | isGivenOrWDeriv fl -- Maintain the invariant that inert_flat_cache - -- only has [G] and [WD] CFunEqCans - = do { dflags <- getDynFlags - ; when (gopt Opt_FlatCache dflags) $ - do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args - , ppr fl, ppr ty ]) - -- 'co' can be bottom, in the case of derived items - ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) -> - is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } } - - | otherwise - = return () - ----------------------------- -unflattenFmv :: TcTyVar -> TcType -> TcS () --- Fill a flatten-meta-var, simply by unifying it. --- This does NOT count as a unification in tcs_unified. -unflattenFmv tv ty - = ASSERT2( isMetaTyVar tv, ppr tv ) - TcS $ \ _ -> - do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty) - ; TcM.writeMetaTyVar tv ty } - ----------------------------- -demoteUnfilledFmv :: TcTyVar -> TcS () --- If a flatten-meta-var is still un-filled, --- turn it into an ordinary meta-var -demoteUnfilledFmv fmv - = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv - ; unless is_filled $ - do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv) - ; TcM.writeMetaTyVar fmv tv_ty } } - ------------------------------ -dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS () --- (dischargeFunEq tv co ty) --- Preconditions --- - ev :: F tys ~ tv is a CFunEqCan --- - tv is a FlatMetaTv of FlatSkolTv --- - co :: F tys ~ xi --- - fmv/fsk `notElem` xi --- - fmv not filled (for Wanteds) --- - xi is flattened (and obeys Note [Almost function-free] in TcRnTypes) --- --- Then for [W] or [WD], we actually fill in the fmv: --- set fmv := xi, --- set ev := co --- kick out any inert things that are now rewritable --- --- For [D], we instead emit an equality that must ultimately hold --- [D] xi ~ fmv --- Does not evaluate 'co' if 'ev' is Derived --- --- For [G], emit this equality --- [G] (sym ev; co) :: fsk ~ xi - --- See TcFlatten Note [The flattening story], --- especially "Ownership of fsk/fmv" -dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi - = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co ) - ; emitWorkNC [new_ev] } - where - new_pred = mkPrimEqPred (mkTyVarTy fsk) xi - new_co = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co - -dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi - = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi ) - do { setWantedEvTerm dest (evCoercion co) - ; unflattenFmv fmv xi - ; n_kicked <- kickOutAfterUnification fmv - ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) } - -dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi - = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv) - -- FunEqs are always at Nominal role - -pprKicked :: Int -> SDoc -pprKicked 0 = empty -pprKicked n = parens (int n <+> text "kicked out") - -{- ********************************************************************* -* * -* Instantiation etc. -* * -********************************************************************* -} - --- Instantiations --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType) -instDFunType dfun_id inst_tys - = wrapTcS $ TcM.instDFunType dfun_id inst_tys - -newFlexiTcSTy :: Kind -> TcS TcType -newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) - -cloneMetaTyVar :: TcTyVar -> TcS TcTyVar -cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) - -instFlexi :: [TKVar] -> TcS TCvSubst -instFlexi = instFlexiX emptyTCvSubst - -instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst -instFlexiX subst tvs - = wrapTcS (foldlM instFlexiHelper subst tvs) - -instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst -instFlexiHelper subst tv - = do { uniq <- TcM.newUnique - ; details <- TcM.newMetaDetails TauTv - ; let name = setNameUnique (tyVarName tv) uniq - kind = substTyUnchecked subst (tyVarKind tv) - ty' = mkTyVarTy (mkTcTyVar name kind details) - ; TcM.traceTc "instFlexi" (ppr ty') - ; return (extendTvSubst subst tv ty') } - -matchGlobalInst :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcS TcM.ClsInstResult -matchGlobalInst dflags short_cut cls tys - = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys) - -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar]) -tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs - --- Creating and setting evidence variables and CtFlavors --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -data MaybeNew = Fresh CtEvidence | Cached EvExpr - -isFresh :: MaybeNew -> Bool -isFresh (Fresh {}) = True -isFresh (Cached {}) = False - -freshGoals :: [MaybeNew] -> [CtEvidence] -freshGoals mns = [ ctev | Fresh ctev <- mns ] - -getEvExpr :: MaybeNew -> EvExpr -getEvExpr (Fresh ctev) = ctEvExpr ctev -getEvExpr (Cached evt) = evt - -setEvBind :: EvBind -> TcS () -setEvBind ev_bind - = do { evb <- getTcEvBindsVar - ; wrapTcS $ TcM.addTcEvBind evb ev_bind } - --- | Mark variables as used filling a coercion hole -useVars :: CoVarSet -> TcS () -useVars co_vars - = do { ev_binds_var <- getTcEvBindsVar - ; let ref = ebv_tcvs ev_binds_var - ; wrapTcS $ - do { tcvs <- TcM.readTcRef ref - ; let tcvs' = tcvs `unionVarSet` co_vars - ; TcM.writeTcRef ref tcvs' } } - --- | Equalities only -setWantedEq :: TcEvDest -> Coercion -> TcS () -setWantedEq (HoleDest hole) co - = do { useVars (coVarsOfCo co) - ; fillCoercionHole hole co } -setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev) - --- | Good for both equalities and non-equalities -setWantedEvTerm :: TcEvDest -> EvTerm -> TcS () -setWantedEvTerm (HoleDest hole) tm - | Just co <- evTermCoercion_maybe tm - = do { useVars (coVarsOfCo co) - ; fillCoercionHole hole co } - | otherwise - = -- See Note [Yukky eq_sel for a HoleDest] - do { let co_var = coHoleCoVar hole - ; setEvBind (mkWantedEvBind co_var tm) - ; fillCoercionHole hole (mkTcCoVarCo co_var) } - -setWantedEvTerm (EvVarDest ev_id) tm - = setEvBind (mkWantedEvBind ev_id tm) - -{- Note [Yukky eq_sel for a HoleDest] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How can it be that a Wanted with HoleDest gets evidence that isn't -just a coercion? i.e. evTermCoercion_maybe returns Nothing. - -Consider [G] forall a. blah => a ~ T - [W] S ~# T - -Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~ -T) in the quantified constraints, and wraps the (boxed) evidence it -gets back in an eq_sel to extract the unboxed (S ~# T). We can't put -that term into a coercion, so we add a value binding - h = eq_sel (...) -and the coercion variable h to fill the coercion hole. -We even re-use the CoHole's Id for this binding! - -Yuk! --} - -fillCoercionHole :: CoercionHole -> Coercion -> TcS () -fillCoercionHole hole co - = do { wrapTcS $ TcM.fillCoercionHole hole co - ; kickOutAfterFillingCoercionHole hole } - -setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () -setEvBindIfWanted ev tm - = case ev of - CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm - _ -> return () - -newTcEvBinds :: TcS EvBindsVar -newTcEvBinds = wrapTcS TcM.newTcEvBinds - -newNoTcEvBinds :: TcS EvBindsVar -newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds - -newEvVar :: TcPredType -> TcS EvVar -newEvVar pred = wrapTcS (TcM.newEvVar pred) - -newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence --- Make a new variable of the given PredType, --- immediately bind it to the given term --- and return its CtEvidence --- See Note [Bind new Givens immediately] in Constraint -newGivenEvVar loc (pred, rhs) - = do { new_ev <- newBoundEvVarId pred rhs - ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) } - --- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the --- given term -newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar -newBoundEvVarId pred rhs - = do { new_ev <- newEvVar pred - ; setEvBind (mkGivenEvBind new_ev rhs) - ; return new_ev } - -newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence] -newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts - -emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion --- | Emit a new Wanted equality into the work-list -emitNewWantedEq loc role ty1 ty2 - = do { (ev, co) <- newWantedEq loc role ty1 ty2 - ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) - ; return co } - --- | Make a new equality CtEvidence -newWantedEq :: CtLoc -> Role -> TcType -> TcType - -> TcS (CtEvidence, Coercion) -newWantedEq = newWantedEq_SI YesBlockSubst WDeriv - -newWantedEq_SI :: BlockSubstFlag -> ShadowInfo -> CtLoc -> Role - -> TcType -> TcType - -> TcS (CtEvidence, Coercion) -newWantedEq_SI blocker si loc role ty1 ty2 - = do { hole <- wrapTcS $ TcM.newCoercionHole blocker pty - ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty) - ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole - , ctev_nosh = si - , ctev_loc = loc} - , mkHoleCo hole ) } - where - pty = mkPrimEqPredRole role ty1 ty2 - --- no equalities here. Use newWantedEq instead -newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence -newWantedEvVarNC = newWantedEvVarNC_SI WDeriv - -newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence --- Don't look up in the solved/inerts; we know it's not there -newWantedEvVarNC_SI si loc pty - = do { new_ev <- newEvVar pty - ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ - pprCtLoc loc) - ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev - , ctev_nosh = si - , ctev_loc = loc })} - -newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew -newWantedEvVar = newWantedEvVar_SI WDeriv - -newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew --- For anything except ClassPred, this is the same as newWantedEvVarNC -newWantedEvVar_SI si loc pty - = do { mb_ct <- lookupInInerts loc pty - ; case mb_ct of - Just ctev - | not (isDerived ctev) - -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev - ; return $ Cached (ctEvExpr ctev) } - _ -> do { ctev <- newWantedEvVarNC_SI si loc pty - ; return (Fresh ctev) } } - -newWanted :: CtLoc -> PredType -> TcS MaybeNew --- Deals with both equalities and non equalities. Tries to look --- up non-equalities in the cache -newWanted = newWanted_SI WDeriv - -newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew -newWanted_SI si loc pty - | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = Fresh . fst <$> newWantedEq_SI YesBlockSubst si loc role ty1 ty2 - | otherwise - = newWantedEvVar_SI si loc pty - --- deals with both equalities and non equalities. Doesn't do any cache lookups. -newWantedNC :: CtLoc -> PredType -> TcS CtEvidence -newWantedNC loc pty - | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = fst <$> newWantedEq loc role ty1 ty2 - | otherwise - = newWantedEvVarNC loc pty - -emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS () -emitNewDeriveds loc preds - | null preds - = return () - | otherwise - = do { evs <- mapM (newDerivedNC loc) preds - ; traceTcS "Emitting new deriveds" (ppr evs) - ; updWorkListTcS (extendWorkListDeriveds evs) } - -emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS () --- Create new equality Derived and put it in the work list --- There's no caching, no lookupInInerts -emitNewDerivedEq loc role ty1 ty2 - = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2) - ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc) - ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) } - -- Very important: put in the wl_eqs - -- See Note [Prioritise equalities] (Avoiding fundep iteration) - -newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence -newDerivedNC loc pred - = do { -- checkReductionDepth loc pred - ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) } - --- --------- Check done in TcInteract.selectNewWorkItem???? --------- --- | Checks if the depth of the given location is too much. Fails if --- it's too big, with an appropriate error message. -checkReductionDepth :: CtLoc -> TcType -- ^ type being reduced - -> TcS () -checkReductionDepth loc ty - = do { dflags <- getDynFlags - ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $ - wrapErrTcS $ - solverDepthErrorTcS loc ty } - -matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType)) --- Given (F tys) return (ty, co), where co :: F tys ~N ty -matchFam tycon args = wrapTcS $ matchFamTcM tycon args - -matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType)) --- Given (F tys) return (ty, co), where co :: F tys ~N ty -matchFamTcM tycon args - = do { fam_envs <- FamInst.tcGetFamInstEnvs - ; let match_fam_result - = reduceTyFamApp_maybe fam_envs Nominal tycon args - ; TcM.traceTc "matchFamTcM" $ - vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args) - , ppr_res match_fam_result ] - ; return match_fam_result } - where - ppr_res Nothing = text "Match failed" - ppr_res (Just (co,ty)) = hang (text "Match succeeded:") - 2 (vcat [ text "Rewrites to:" <+> ppr ty - , text "Coercion:" <+> ppr co ]) - -{- -Note [Residual implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wl_implics in the WorkList are the residual implication -constraints that are generated while solving or canonicalising the -current worklist. Specifically, when canonicalising - (forall a. t1 ~ forall a. t2) -from which we get the implication - (forall a. t1 ~ t2) -See TcSMonad.deferTcSForAllEq --} diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs deleted file mode 100644 index 70b8bb2261..0000000000 --- a/compiler/typecheck/TcSigs.hs +++ /dev/null @@ -1,836 +0,0 @@ -{- -(c) The University of Glasgow 2006-2012 -(c) The GRASP Project, Glasgow University, 1992-2002 - --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module TcSigs( - TcSigInfo(..), - TcIdSigInfo(..), TcIdSigInst, - TcPatSynInfo(..), - TcSigFun, - - isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName, - completeSigPolyId_maybe, - - tcTySigs, tcUserTypeSig, completeSigFromId, - tcInstSig, - - TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv, - mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import TcHsType -import TcRnTypes -import TcRnMonad -import TcOrigin -import TcType -import TcMType -import TcValidity ( checkValidType ) -import TcUnify( tcSkolemise, unifyType ) -import Inst( topInstantiate ) -import TcEnv( tcLookupId ) -import TcEvidence( HsWrapper, (<.>) ) -import GHC.Core.Type ( mkTyVarBinders ) - -import GHC.Driver.Session -import GHC.Types.Var ( TyVar, tyVarKind ) -import GHC.Types.Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) -import PrelNames( mkUnboundName ) -import GHC.Types.Basic -import GHC.Types.Module( getModule ) -import GHC.Types.Name -import GHC.Types.Name.Env -import Outputable -import GHC.Types.SrcLoc -import Util( singleton ) -import Maybes( orElse ) -import Data.Maybe( mapMaybe ) -import Control.Monad( unless ) - - -{- ------------------------------------------------------------- - Note [Overview of type signatures] ----------------------------------------------------------------- -Type signatures, including partial signatures, are jolly tricky, -especially on value bindings. Here's an overview. - - f :: forall a. [a] -> [a] - g :: forall b. _ -> b - - f = ...g... - g = ...f... - -* HsSyn: a signature in a binding starts off as a TypeSig, in - type HsBinds.Sig - -* When starting a mutually recursive group, like f/g above, we - call tcTySig on each signature in the group. - -* tcTySig: Sig -> TcIdSigInfo - - For a /complete/ signature, like 'f' above, tcTySig kind-checks - the HsType, producing a Type, and wraps it in a CompleteSig, and - extend the type environment with this polymorphic 'f'. - - - For a /partial/signature, like 'g' above, tcTySig does nothing - Instead it just wraps the pieces in a PartialSig, to be handled - later. - -* tcInstSig: TcIdSigInfo -> TcIdSigInst - In tcMonoBinds, when looking at an individual binding, we use - tcInstSig to instantiate the signature forall's in the signature, - and attribute that instantiated (monomorphic) type to the - binder. You can see this in TcBinds.tcLhsId. - - The instantiation does the obvious thing for complete signatures, - but for /partial/ signatures it starts from the HsSyn, so it - has to kind-check it etc: tcHsPartialSigType. It's convenient - to do this at the same time as instantiation, because we can - make the wildcards into unification variables right away, raather - than somehow quantifying over them. And the "TcLevel" of those - unification variables is correct because we are in tcMonoBinds. - - -Note [Scoped tyvars] -~~~~~~~~~~~~~~~~~~~~ -The -XScopedTypeVariables flag brings lexically-scoped type variables -into scope for any explicitly forall-quantified type variables: - f :: forall a. a -> a - f x = e -Then 'a' is in scope inside 'e'. - -However, we do *not* support this - - For pattern bindings e.g - f :: forall a. a->a - (f,g) = e - -Note [Binding scoped type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type variables *brought into lexical scope* by a type signature -may be a subset of the *quantified type variables* of the signatures, -for two reasons: - -* With kind polymorphism a signature like - f :: forall f a. f a -> f a - may actually give rise to - f :: forall k. forall (f::k -> *) (a:k). f a -> f a - So the sig_tvs will be [k,f,a], but only f,a are scoped. - NB: the scoped ones are not necessarily the *initial* ones! - -* Even aside from kind polymorphism, there may be more instantiated - type variables than lexically-scoped ones. For example: - type T a = forall b. b -> (a,b) - f :: forall c. T c - Here, the signature for f will have one scoped type variable, c, - but two instantiated type variables, c' and b'. - -However, all of this only applies to the renamer. The typechecker -just puts all of them into the type environment; any lexical-scope -errors were dealt with by the renamer. - --} - - -{- ********************************************************************* -* * - Utility functions for TcSigInfo -* * -********************************************************************* -} - -tcIdSigName :: TcIdSigInfo -> Name -tcIdSigName (CompleteSig { sig_bndr = id }) = idName id -tcIdSigName (PartialSig { psig_name = n }) = n - -tcSigInfoName :: TcSigInfo -> Name -tcSigInfoName (TcIdSig idsi) = tcIdSigName idsi -tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi - -completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId -completeSigPolyId_maybe sig - | TcIdSig sig_info <- sig - , CompleteSig { sig_bndr = id } <- sig_info = Just id - | otherwise = Nothing - - -{- ********************************************************************* -* * - Typechecking user signatures -* * -********************************************************************* -} - -tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun) -tcTySigs hs_sigs - = checkNoErrs $ - do { -- Fail if any of the signatures is duff - -- Hence mapAndReportM - -- See Note [Fail eagerly on bad signatures] - ty_sigs_s <- mapAndReportM tcTySig hs_sigs - - ; let ty_sigs = concat ty_sigs_s - poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs - -- The returned [TcId] are the ones for which we have - -- a complete type signature. - -- See Note [Complete and partial type signatures] - env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs] - - ; return (poly_ids, lookupNameEnv env) } - -tcTySig :: LSig GhcRn -> TcM [TcSigInfo] -tcTySig (L _ (IdSig _ id)) - = do { let ctxt = FunSigCtxt (idName id) False - -- False: do not report redundant constraints - -- The user has no control over the signature! - sig = completeSigFromId ctxt id - ; return [TcIdSig sig] } - -tcTySig (L loc (TypeSig _ names sig_ty)) - = setSrcSpan loc $ - do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name) - | L _ name <- names ] - ; return (map TcIdSig sigs) } - -tcTySig (L loc (PatSynSig _ names sig_ty)) - = setSrcSpan loc $ - do { tpsigs <- sequence [ tcPatSynSig name sig_ty - | L _ name <- names ] - ; return (map TcPatSynSig tpsigs) } - -tcTySig _ = return [] - - -tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name - -> TcM TcIdSigInfo --- A function or expression type signature --- Returns a fully quantified type signature; even the wildcards --- are quantified with ordinary skolems that should be instantiated --- --- The SrcSpan is what to declare as the binding site of the --- any skolems in the signature. For function signatures we --- use the whole `f :: ty' signature; for expression signatures --- just the type part. --- --- Just n => Function type signature name :: type --- Nothing => Expression type signature <expr> :: type -tcUserTypeSig loc hs_sig_ty mb_name - | isCompleteHsSig hs_sig_ty - = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty - ; traceTc "tcuser" (ppr sigma_ty) - ; return $ - CompleteSig { sig_bndr = mkLocalId name sigma_ty - , sig_ctxt = ctxt_T - , sig_loc = loc } } - -- Location of the <type> in f :: <type> - - -- Partial sig with wildcards - | otherwise - = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty - , sig_ctxt = ctxt_F, sig_loc = loc }) - where - name = case mb_name of - Just n -> n - Nothing -> mkUnboundName (mkVarOcc "<expression>") - ctxt_F = case mb_name of - Just n -> FunSigCtxt n False - Nothing -> ExprSigCtxt - ctxt_T = case mb_name of - Just n -> FunSigCtxt n True - Nothing -> ExprSigCtxt - - - -completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo --- Used for instance methods and record selectors -completeSigFromId ctxt id - = CompleteSig { sig_bndr = id - , sig_ctxt = ctxt - , sig_loc = getSrcSpan id } - -isCompleteHsSig :: LHsSigWcType GhcRn -> Bool --- ^ If there are no wildcards, return a LHsSigType -isCompleteHsSig (HsWC { hswc_ext = wcs - , hswc_body = HsIB { hsib_body = hs_ty } }) - = null wcs && no_anon_wc hs_ty -isCompleteHsSig (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec -isCompleteHsSig (XHsWildCardBndrs nec) = noExtCon nec - -no_anon_wc :: LHsType GhcRn -> Bool -no_anon_wc lty = go lty - where - go (L _ ty) = case ty of - HsWildCardTy _ -> False - HsAppTy _ ty1 ty2 -> go ty1 && go ty2 - HsAppKindTy _ ty ki -> go ty && go ki - HsFunTy _ ty1 ty2 -> go ty1 && go ty2 - HsListTy _ ty -> go ty - HsTupleTy _ _ tys -> gos tys - HsSumTy _ tys -> gos tys - HsOpTy _ ty1 _ ty2 -> go ty1 && go ty2 - HsParTy _ ty -> go ty - HsIParamTy _ _ ty -> go ty - HsKindSig _ ty kind -> go ty && go kind - HsDocTy _ ty _ -> go ty - HsBangTy _ _ ty -> go ty - HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds - HsExplicitListTy _ _ tys -> gos tys - HsExplicitTupleTy _ tys -> gos tys - HsForAllTy { hst_bndrs = bndrs - , hst_body = ty } -> no_anon_wc_bndrs bndrs - && go ty - HsQualTy { hst_ctxt = L _ ctxt - , hst_body = ty } -> gos ctxt && go ty - HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty - HsSpliceTy{} -> True - HsTyLit{} -> True - HsTyVar{} -> True - HsStarTy{} -> True - XHsType (NHsCoreTy{}) -> True -- Core type, which does not have any wildcard - - gos = all go - -no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool -no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs - where - go (UserTyVar _ _) = True - go (KindedTyVar _ _ ki) = no_anon_wc ki - go (XTyVarBndr nec) = noExtCon nec - -{- Note [Fail eagerly on bad signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a type signature is wrong, fail immediately: - - * the type sigs may bind type variables, so proceeding without them - can lead to a cascade of errors - - * the type signature might be ambiguous, in which case checking - the code against the signature will give a very similar error - to the ambiguity error. - -ToDo: this means we fall over if any top-level type signature in the -module is wrong, because we typecheck all the signatures together -(see TcBinds.tcValBinds). Moreover, because of top-level -captureTopConstraints, only insoluble constraints will be reported. -We typecheck all signatures at the same time because a signature -like f,g :: blah might have f and g from different SCCs. - -So it's a bit awkward to get better error recovery, and no one -has complained! --} - -{- ********************************************************************* -* * - Type checking a pattern synonym signature -* * -************************************************************************ - -Note [Pattern synonym signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Pattern synonym signatures are surprisingly tricky (see #11224 for example). -In general they look like this: - - pattern P :: forall univ_tvs. req_theta - => forall ex_tvs. prov_theta - => arg1 -> .. -> argn -> res_ty - -For parsing and renaming we treat the signature as an ordinary LHsSigType. - -Once we get to type checking, we decompose it into its parts, in tcPatSynSig. - -* Note that 'forall univ_tvs' and 'req_theta =>' - and 'forall ex_tvs' and 'prov_theta =>' - are all optional. We gather the pieces at the top of tcPatSynSig - -* Initially the implicitly-bound tyvars (added by the renamer) include both - universal and existential vars. - -* After we kind-check the pieces and convert to Types, we do kind generalisation. - -Note [solveEqualities in tcPatSynSig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important that we solve /all/ the equalities in a pattern -synonym signature, because we are going to zonk the signature to -a Type (not a TcType), in TcPatSyn.tc_patsyn_finish, and that -fails if there are un-filled-in coercion variables mentioned -in the type (#15694). - -The best thing is simply to use solveEqualities to solve all the -equalites, rather than leaving them in the ambient constraints -to be solved later. Pattern synonyms are top-level, so there's -no problem with completely solving them. - -(NB: this solveEqualities wraps newImplicitTKBndrs, which itself -does a solveLocalEqualities; so solveEqualities isn't going to -make any further progress; it'll just report any unsolved ones, -and fail, as it should.) --} - -tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo --- See Note [Pattern synonym signatures] --- See Note [Recipe for checking a signature] in TcHsType -tcPatSynSig name sig_ty - | HsIB { hsib_ext = implicit_hs_tvs - , hsib_body = hs_ty } <- sig_ty - , (univ_hs_tvs, hs_req, hs_ty1) <- splitLHsSigmaTyInvis hs_ty - , (ex_hs_tvs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 - = do { traceTc "tcPatSynSig 1" (ppr sig_ty) - ; (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty)))) - <- pushTcLevelM_ $ - solveEqualities $ -- See Note [solveEqualities in tcPatSynSig] - bindImplicitTKBndrs_Skol implicit_hs_tvs $ - bindExplicitTKBndrs_Skol univ_hs_tvs $ - bindExplicitTKBndrs_Skol ex_hs_tvs $ - do { req <- tcHsContext hs_req - ; prov <- tcHsContext hs_prov - ; body_ty <- tcHsOpenType hs_body_ty - -- A (literal) pattern can be unlifted; - -- e.g. pattern Zero <- 0# (#12094) - ; return (req, prov, body_ty) } - - ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs - req ex_tvs prov body_ty - - -- Kind generalisation - ; kvs <- kindGeneralizeAll ungen_patsyn_ty - ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty) - - -- These are /signatures/ so we zonk to squeeze out any kind - -- unification variables. Do this after kindGeneralize which may - -- default kind variables to *. - ; implicit_tvs <- zonkAndScopedSort implicit_tvs - ; univ_tvs <- mapM zonkTyCoVarKind univ_tvs - ; ex_tvs <- mapM zonkTyCoVarKind ex_tvs - ; req <- zonkTcTypes req - ; prov <- zonkTcTypes prov - ; body_ty <- zonkTcType body_ty - - -- Skolems have TcLevels too, though they're used only for debugging. - -- If you don't do this, the debugging checks fail in TcPatSyn. - -- Test case: patsyn/should_compile/T13441 -{- - ; tclvl <- getTcLevel - ; let env0 = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs - (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs - (env2, univ_tvs') = promoteSkolemsX tclvl env1 univ_tvs - (env3, ex_tvs') = promoteSkolemsX tclvl env2 ex_tvs - req' = substTys env3 req - prov' = substTys env3 prov - body_ty' = substTy env3 body_ty --} - ; let implicit_tvs' = implicit_tvs - univ_tvs' = univ_tvs - ex_tvs' = ex_tvs - req' = req - prov' = prov - body_ty' = body_ty - - -- Now do validity checking - ; checkValidType ctxt $ - build_patsyn_type kvs implicit_tvs' univ_tvs' req' ex_tvs' prov' body_ty' - - -- arguments become the types of binders. We thus cannot allow - -- levity polymorphism here - ; let (arg_tys, _) = tcSplitFunTys body_ty' - ; mapM_ (checkForLevPoly empty) arg_tys - - ; traceTc "tcTySig }" $ - vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs' - , text "kvs" <+> ppr_tvs kvs - , text "univ_tvs" <+> ppr_tvs univ_tvs' - , text "req" <+> ppr req' - , text "ex_tvs" <+> ppr_tvs ex_tvs' - , text "prov" <+> ppr prov' - , text "body_ty" <+> ppr body_ty' ] - ; return (TPSI { patsig_name = name - , patsig_implicit_bndrs = mkTyVarBinders Inferred kvs ++ - mkTyVarBinders Specified implicit_tvs' - , patsig_univ_bndrs = univ_tvs' - , patsig_req = req' - , patsig_ex_bndrs = ex_tvs' - , patsig_prov = prov' - , patsig_body_ty = body_ty' }) } - where - ctxt = PatSynCtxt name - - build_patsyn_type kvs imp univ req ex prov body - = mkInvForAllTys kvs $ - mkSpecForAllTys (imp ++ univ) $ - mkPhiTy req $ - mkSpecForAllTys ex $ - mkPhiTy prov $ - body -tcPatSynSig _ (XHsImplicitBndrs nec) = noExtCon nec - -ppr_tvs :: [TyVar] -> SDoc -ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) - | tv <- tvs]) - - -{- ********************************************************************* -* * - Instantiating user signatures -* * -********************************************************************* -} - - -tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst --- Instantiate a type signature; only used with plan InferGen -tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) - = setSrcSpan loc $ -- Set the binding site of the tyvars - do { (tv_prs, theta, tau) <- tcInstType newMetaTyVarTyVars poly_id - -- See Note [Pattern bindings and complete signatures] - - ; return (TISI { sig_inst_sig = sig - , sig_inst_skols = tv_prs - , sig_inst_wcs = [] - , sig_inst_wcx = Nothing - , sig_inst_theta = theta - , sig_inst_tau = tau }) } - -tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty - , sig_ctxt = ctxt - , sig_loc = loc }) - = setSrcSpan loc $ -- Set the binding site of the tyvars - do { traceTc "Staring partial sig {" (ppr hs_sig) - ; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty - -- See Note [Checking partial type signatures] in TcHsType - ; let inst_sig = TISI { sig_inst_sig = hs_sig - , sig_inst_skols = tv_prs - , sig_inst_wcs = wcs - , sig_inst_wcx = wcx - , sig_inst_theta = theta - , sig_inst_tau = tau } - ; traceTc "End partial sig }" (ppr inst_sig) - ; return inst_sig } - - -{- Note [Pattern bindings and complete signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = MkT a a - f :: forall a. a->a - g :: forall b. b->b - MkT f g = MkT (\x->x) (\y->y) -Here we'll infer a type from the pattern of 'T a', but if we feed in -the signature types for f and g, we'll end up unifying 'a' and 'b' - -So we instantiate f and g's signature with TyVarTv skolems -(newMetaTyVarTyVars) that can unify with each other. If too much -unification takes place, we'll find out when we do the final -impedance-matching check in TcBinds.mkExport - -See Note [Signature skolems] in TcType - -None of this applies to a function binding with a complete -signature, which doesn't use tcInstSig. See TcBinds.tcPolyCheck. --} - -{- ********************************************************************* -* * - Pragmas and PragEnv -* * -********************************************************************* -} - -type TcPragEnv = NameEnv [LSig GhcRn] - -emptyPragEnv :: TcPragEnv -emptyPragEnv = emptyNameEnv - -lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn] -lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] - -extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv -extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig - ---------------- -mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv -mkPragEnv sigs binds - = foldl' extendPragEnv emptyNameEnv prs - where - prs = mapMaybe get_sig sigs - - get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn) - get_sig (L l (SpecSig x lnm@(L _ nm) ty inl)) - = Just (nm, L l $ SpecSig x lnm ty (add_arity nm inl)) - get_sig (L l (InlineSig x lnm@(L _ nm) inl)) - = Just (nm, L l $ InlineSig x lnm (add_arity nm inl)) - get_sig (L l (SCCFunSig x st lnm@(L _ nm) str)) - = Just (nm, L l $ SCCFunSig x st lnm str) - get_sig _ = Nothing - - add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function - | Inline <- inl_inline inl_prag - -- add arity only for real INLINE pragmas, not INLINABLE - = case lookupNameEnv ar_env n of - Just ar -> inl_prag { inl_sat = Just ar } - Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n ) - -- There really should be a binding for every INLINE pragma - inl_prag - | otherwise - = inl_prag - - -- ar_env maps a local to the arity of its definition - ar_env :: NameEnv Arity - ar_env = foldr lhsBindArity emptyNameEnv binds - -lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity -lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env - = extendNameEnv env (unLoc id) (matchGroupArity ms) -lhsBindArity _ env = env -- PatBind/VarBind - - ------------------ -addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId -addInlinePrags poly_id prags_for_me - | inl@(L _ prag) : inls <- inl_prags - = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) - ; unless (null inls) (warn_multiple_inlines inl inls) - ; return (poly_id `setInlinePragma` prag) } - | otherwise - = return poly_id - where - inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me] - - warn_multiple_inlines _ [] = return () - - warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls) - | inlinePragmaActivation prag1 == inlinePragmaActivation prag2 - , noUserInlineSpec (inlinePragmaSpec prag1) - = -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop - -- and inl2 is a user NOINLINE pragma; we don't want to complain - warn_multiple_inlines inl2 inls - | otherwise - = setSrcSpan loc $ - addWarnTc NoReason - (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) - 2 (vcat (text "Ignoring all but the first" - : map pp_inl (inl1:inl2:inls)))) - - pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) - - -{- ********************************************************************* -* * - SPECIALISE pragmas -* * -************************************************************************ - -Note [Handling SPECIALISE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea is this: - - foo :: Num a => a -> b -> a - {-# SPECIALISE foo :: Int -> b -> Int #-} - -We check that - (forall a b. Num a => a -> b -> a) - is more polymorphic than - forall b. Int -> b -> Int -(for which we could use tcSubType, but see below), generating a HsWrapper -to connect the two, something like - wrap = /\b. <hole> Int b dNumInt -This wrapper is put in the TcSpecPrag, in the ABExport record of -the AbsBinds. - - - f :: (Eq a, Ix b) => a -> b -> Bool - {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} - f = <poly_rhs> - -From this the typechecker generates - - AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds - - SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX - -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ]) - -From these we generate: - - Rule: forall p, q, (dp:Ix p), (dq:Ix q). - f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq - - Spec bind: f_spec = wrap_fn <poly_rhs> - -Note that - - * The LHS of the rule may mention dictionary *expressions* (eg - $dfIxPair dp dq), and that is essential because the dp, dq are - needed on the RHS. - - * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it - can fully specialise it. - - - -From the TcSpecPrag, in GHC.HsToCore.Binds we generate a binding for f_spec and a RULE: - - f_spec :: Int -> b -> Int - f_spec = wrap<f rhs> - - RULE: forall b (d:Num b). f b d = f_spec b - -The RULE is generated by taking apart the HsWrapper, which is a little -delicate, but works. - -Some wrinkles - -1. We don't use full-on tcSubType, because that does co and contra - variance and that in turn will generate too complex a LHS for the - RULE. So we use a single invocation of skolemise / - topInstantiate in tcSpecWrapper. (Actually I think that even - the "deeply" stuff may be too much, because it introduces lambdas, - though I think it can be made to work without too much trouble.) - -2. We need to take care with type families (#5821). Consider - type instance F Int = Bool - f :: Num a => a -> F a - {-# SPECIALISE foo :: Int -> Bool #-} - - We *could* try to generate an f_spec with precisely the declared type: - f_spec :: Int -> Bool - f_spec = <f rhs> Int dNumInt |> co - - RULE: forall d. f Int d = f_spec |> sym co - - but the 'co' and 'sym co' are (a) playing no useful role, and (b) are - hard to generate. At all costs we must avoid this: - RULE: forall d. f Int d |> co = f_spec - because the LHS will never match (indeed it's rejected in - decomposeRuleLhs). - - So we simply do this: - - Generate a constraint to check that the specialised type (after - skolemiseation) is equal to the instantiated function type. - - But *discard* the evidence (coercion) for that constraint, - so that we ultimately generate the simpler code - f_spec :: Int -> F Int - f_spec = <f rhs> Int dNumInt - - RULE: forall d. f Int d = f_spec - You can see this discarding happening in - -3. Note that the HsWrapper can transform *any* function with the right - type prefix - forall ab. (Eq a, Ix b) => XXX - regardless of XXX. It's sort of polymorphic in XXX. This is - useful: we use the same wrapper to transform each of the class ops, as - well as the dict. That's what goes on in TcInstDcls.mk_meth_spec_prags --} - -tcSpecPrags :: Id -> [LSig GhcRn] - -> TcM [LTcSpecPrag] --- Add INLINE and SPECIALSE pragmas --- INLINE prags are added to the (polymorphic) Id directly --- SPECIALISE prags are passed to the desugarer via TcSpecPrags --- Pre-condition: the poly_id is zonked --- Reason: required by tcSubExp -tcSpecPrags poly_id prag_sigs - = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) - ; unless (null bad_sigs) warn_discarded_sigs - ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs - ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } - where - spec_sigs = filter isSpecLSig prag_sigs - bad_sigs = filter is_bad_sig prag_sigs - is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) - - warn_discarded_sigs - = addWarnTc NoReason - (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) - 2 (vcat (map (ppr . getLoc) bad_sigs))) - --------------- -tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] -tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) --- See Note [Handling SPECIALISE pragmas] --- --- The Name fun_name in the SpecSig may not be the same as that of the poly_id --- Example: SPECIALISE for a class method: the Name in the SpecSig is --- for the selector Id, but the poly_id is something like $cop --- However we want to use fun_name in the error message, since that is --- what the user wrote (#8537) - = addErrCtxt (spec_ctxt prag) $ - do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) - (text "SPECIALISE pragma for non-overloaded function" - <+> quotes (ppr fun_name)) - -- Note [SPECIALISE pragmas] - ; spec_prags <- mapM tc_one hs_tys - ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags))) - ; return spec_prags } - where - name = idName poly_id - poly_ty = idType poly_id - spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) - - tc_one hs_ty - = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty - ; wrap <- tcSpecWrapper (FunSigCtxt name True) poly_ty spec_ty - ; return (SpecPrag poly_id wrap inl) } - -tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag) - --------------- -tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper --- A simpler variant of tcSubType, used for SPECIALISE pragmas --- See Note [Handling SPECIALISE pragmas], wrinkle 1 -tcSpecWrapper ctxt poly_ty spec_ty - = do { (sk_wrap, inst_wrap) - <- tcSkolemise ctxt spec_ty $ \ _ spec_tau -> - do { (inst_wrap, tau) <- topInstantiate orig poly_ty - ; _ <- unifyType Nothing spec_tau tau - -- Deliberately ignore the evidence - -- See Note [Handling SPECIALISE pragmas], - -- wrinkle (2) - ; return inst_wrap } - ; return (sk_wrap <.> inst_wrap) } - where - orig = SpecPragOrigin ctxt - --------------- -tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag] --- SPECIALISE pragmas for imported things -tcImpPrags prags - = do { this_mod <- getModule - ; dflags <- getDynFlags - ; if (not_specialising dflags) then - return [] - else do - { pss <- mapAndRecoverM (wrapLocM tcImpSpec) - [L loc (name,prag) - | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags - , not (nameIsLocalOrFrom this_mod name) ] - ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } } - where - -- Ignore SPECIALISE pragmas for imported things - -- when we aren't specialising, or when we aren't generating - -- code. The latter happens when Haddocking the base library; - -- we don't want complaints about lack of INLINABLE pragmas - not_specialising dflags - | not (gopt Opt_Specialise dflags) = True - | otherwise = case hscTarget dflags of - HscNothing -> True - HscInterpreted -> True - _other -> False - -tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] -tcImpSpec (name, prag) - = do { id <- tcLookupId name - ; unless (isAnyInlinePragma (idInlinePragma id)) - (addWarnTc NoReason (impSpecErr name)) - ; tcSpecPrag id prag } - -impSpecErr :: Name -> SDoc -impSpecErr name - = hang (text "You cannot SPECIALISE" <+> quotes (ppr name)) - 2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma" - , parens $ sep - [ text "or its defining module" <+> quotes (ppr mod) - , text "was compiled without -O"]]) - where - mod = nameModule name diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs deleted file mode 100644 index 1ac4c74921..0000000000 --- a/compiler/typecheck/TcSimplify.hs +++ /dev/null @@ -1,2727 +0,0 @@ -{-# LANGUAGE CPP #-} - -module TcSimplify( - simplifyInfer, InferMode(..), - growThetaTyVars, - simplifyAmbiguityCheck, - simplifyDefault, - simplifyTop, simplifyTopImplic, - simplifyInteractive, - solveEqualities, solveLocalEqualities, solveLocalEqualitiesX, - simplifyWantedsTcM, - tcCheckSatisfiability, - tcNormalise, - - captureTopConstraints, - - simpl_top, - - promoteTyVar, - promoteTyVarSet, - - -- For Rules we need these - solveWanteds, solveWantedsAndDrop, - approximateWC, runTcSDeriveds - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Bag -import GHC.Core.Class ( Class, classKey, classTyCon ) -import GHC.Driver.Session -import GHC.Types.Id ( idType, mkLocalId ) -import Inst -import ListSetOps -import GHC.Types.Name -import Outputable -import PrelInfo -import PrelNames -import TcErrors -import TcEvidence -import TcInteract -import TcCanonical ( makeSuperClasses, solveCallStack ) -import TcMType as TcM -import TcRnMonad as TcM -import TcSMonad as TcS -import Constraint -import GHC.Core.Predicate -import TcOrigin -import TcType -import GHC.Core.Type -import TysWiredIn ( liftedRepTy ) -import GHC.Core.Unify ( tcMatchTyKi ) -import Util -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Unique.Set -import GHC.Types.Basic ( IntWithInf, intGtLimit ) -import ErrUtils ( emptyMessages ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable ( toList ) -import Data.List ( partition ) -import Data.List.NonEmpty ( NonEmpty(..) ) -import Maybes ( isJust ) - -{- -********************************************************************************* -* * -* External interface * -* * -********************************************************************************* --} - -captureTopConstraints :: TcM a -> TcM (a, WantedConstraints) --- (captureTopConstraints m) runs m, and returns the type constraints it --- generates plus the constraints produced by static forms inside. --- If it fails with an exception, it reports any insolubles --- (out of scope variables) before doing so --- --- captureTopConstraints is used exclusively by TcRnDriver at the top --- level of a module. --- --- Importantly, if captureTopConstraints propagates an exception, it --- reports any insoluble constraints first, lest they be lost --- altogether. This is important, because solveLocalEqualities (maybe --- other things too) throws an exception without adding any error --- messages; it just puts the unsolved constraints back into the --- monad. See TcRnMonad Note [Constraints and errors] --- #16376 is an example of what goes wrong if you don't do this. --- --- NB: the caller should bring any environments into scope before --- calling this, so that the reportUnsolved has access to the most --- complete GlobalRdrEnv -captureTopConstraints thing_inside - = do { static_wc_var <- TcM.newTcRef emptyWC ; - ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $ - TcM.tryCaptureConstraints thing_inside - ; stWC <- TcM.readTcRef static_wc_var - - -- See TcRnMonad Note [Constraints and errors] - -- If the thing_inside threw an exception, but generated some insoluble - -- constraints, report the latter before propagating the exception - -- Otherwise they will be lost altogether - ; case mb_res of - Just res -> return (res, lie `andWC` stWC) - Nothing -> do { _ <- simplifyTop lie; failM } } - -- This call to simplifyTop is the reason - -- this function is here instead of TcRnMonad - -- We call simplifyTop so that it does defaulting - -- (esp of runtime-reps) before reporting errors - -simplifyTopImplic :: Bag Implication -> TcM () -simplifyTopImplic implics - = do { empty_binds <- simplifyTop (mkImplicWC implics) - - -- Since all the inputs are implications the returned bindings will be empty - ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds ) - - ; return () } - -simplifyTop :: WantedConstraints -> TcM (Bag EvBind) --- Simplify top-level constraints --- Usually these will be implications, --- but when there is nothing to quantify we don't wrap --- in a degenerate implication, so we do that here instead -simplifyTop wanteds - = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds - ; ((final_wc, unsafe_ol), binds1) <- runTcS $ - do { final_wc <- simpl_top wanteds - ; unsafe_ol <- getSafeOverlapFailures - ; return (final_wc, unsafe_ol) } - ; traceTc "End simplifyTop }" empty - - ; binds2 <- reportUnsolved final_wc - - ; traceTc "reportUnsolved (unsafe overlapping) {" empty - ; unless (isEmptyCts unsafe_ol) $ do { - -- grab current error messages and clear, warnAllUnsolved will - -- update error messages which we'll grab and then restore saved - -- messages. - ; errs_var <- getErrsVar - ; saved_msg <- TcM.readTcRef errs_var - ; TcM.writeTcRef errs_var emptyMessages - - ; warnAllUnsolved $ WC { wc_simple = unsafe_ol - , wc_impl = emptyBag } - - ; whyUnsafe <- fst <$> TcM.readTcRef errs_var - ; TcM.writeTcRef errs_var saved_msg - ; recordUnsafeInfer whyUnsafe - } - ; traceTc "reportUnsolved (unsafe overlapping) }" empty - - ; return (evBindMapBinds binds1 `unionBags` binds2) } - - --- | Type-check a thing that emits only equality constraints, solving any --- constraints we can and re-emitting constraints that we can't. The thing_inside --- should generally bump the TcLevel to make sure that this run of the solver --- doesn't affect anything lying around. -solveLocalEqualities :: String -> TcM a -> TcM a -solveLocalEqualities callsite thing_inside - = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside - ; emitConstraints wanted - - -- See Note [Fail fast if there are insoluble kind equalities] - ; when (insolubleWC wanted) $ - failM - - ; return res } - -{- Note [Fail fast if there are insoluble kind equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Rather like in simplifyInfer, fail fast if there is an insoluble -constraint. Otherwise we'll just succeed in kind-checking a nonsense -type, with a cascade of follow-up errors. - -For example polykinds/T12593, T15577, and many others. - -Take care to ensure that you emit the insoluble constraints before -failing, because they are what will ultimately lead to the error -messsage! --} - -solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a) -solveLocalEqualitiesX callsite thing_inside - = do { traceTc "solveLocalEqualitiesX {" (vcat [ text "Called from" <+> text callsite ]) - - ; (result, wanted) <- captureConstraints thing_inside - - ; traceTc "solveLocalEqualities: running solver" (ppr wanted) - ; residual_wanted <- runTcSEqualities (solveWanteds wanted) - - ; traceTc "solveLocalEqualitiesX end }" $ - text "residual_wanted =" <+> ppr residual_wanted - - ; return (residual_wanted, result) } - --- | Type-check a thing that emits only equality constraints, then --- solve those constraints. Fails outright if there is trouble. --- Use this if you're not going to get another crack at solving --- (because, e.g., you're checking a datatype declaration) -solveEqualities :: TcM a -> TcM a -solveEqualities thing_inside - = checkNoErrs $ -- See Note [Fail fast on kind errors] - do { lvl <- TcM.getTcLevel - ; traceTc "solveEqualities {" (text "level =" <+> ppr lvl) - - ; (result, wanted) <- captureConstraints thing_inside - - ; traceTc "solveEqualities: running solver" $ text "wanted = " <+> ppr wanted - ; final_wc <- runTcSEqualities $ simpl_top wanted - -- NB: Use simpl_top here so that we potentially default RuntimeRep - -- vars to LiftedRep. This is needed to avoid #14991. - - ; traceTc "End solveEqualities }" empty - ; reportAllUnsolved final_wc - ; return result } - --- | Simplify top-level constraints, but without reporting any unsolved --- constraints nor unsafe overlapping. -simpl_top :: WantedConstraints -> TcS WantedConstraints - -- See Note [Top-level Defaulting Plan] -simpl_top wanteds - = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds) - -- This is where the main work happens - ; dflags <- getDynFlags - ; try_tyvar_defaulting dflags wc_first_go } - where - try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints - try_tyvar_defaulting dflags wc - | isEmptyWC wc - = return wc - | insolubleWC wc - , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles] - = try_class_defaulting wc - | otherwise - = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc) - ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs - -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked - -- filter isMetaTyVar: we might have runtime-skolems in GHCi, - -- and we definitely don't want to try to assign to those! - -- The isTyVar is needed to weed out coercion variables - - ; defaulted <- mapM defaultTyVarTcS meta_tvs -- Has unification side effects - ; if or defaulted - then do { wc_residual <- nestTcS (solveWanteds wc) - -- See Note [Must simplify after defaulting] - ; try_class_defaulting wc_residual } - else try_class_defaulting wc } -- No defaulting took place - - try_class_defaulting :: WantedConstraints -> TcS WantedConstraints - try_class_defaulting wc - | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles] - = return wc - | otherwise -- See Note [When to do type-class defaulting] - = do { something_happened <- applyDefaultingRules wc - -- See Note [Top-level Defaulting Plan] - ; if something_happened - then do { wc_residual <- nestTcS (solveWantedsAndDrop wc) - ; try_class_defaulting wc_residual } - -- See Note [Overview of implicit CallStacks] in TcEvidence - else try_callstack_defaulting wc } - - try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints - try_callstack_defaulting wc - | isEmptyWC wc - = return wc - | otherwise - = defaultCallStacks wc - --- | Default any remaining @CallStack@ constraints to empty @CallStack@s. -defaultCallStacks :: WantedConstraints -> TcS WantedConstraints --- See Note [Overview of implicit CallStacks] in TcEvidence -defaultCallStacks wanteds - = do simples <- handle_simples (wc_simple wanteds) - mb_implics <- mapBagM handle_implic (wc_impl wanteds) - return (wanteds { wc_simple = simples - , wc_impl = catBagMaybes mb_implics }) - - where - - handle_simples simples - = catBagMaybes <$> mapBagM defaultCallStack simples - - handle_implic :: Implication -> TcS (Maybe Implication) - -- The Maybe is because solving the CallStack constraint - -- may well allow us to discard the implication entirely - handle_implic implic - | isSolvedStatus (ic_status implic) - = return (Just implic) - | otherwise - = do { wanteds <- setEvBindsTcS (ic_binds implic) $ - -- defaultCallStack sets a binding, so - -- we must set the correct binding group - defaultCallStacks (ic_wanted implic) - ; setImplicationStatus (implic { ic_wanted = wanteds }) } - - defaultCallStack ct - | ClassPred cls tys <- classifyPredType (ctPred ct) - , Just {} <- isCallStackPred cls tys - = do { solveCallStack (ctEvidence ct) EvCsEmpty - ; return Nothing } - - defaultCallStack ct - = return (Just ct) - - -{- Note [Fail fast on kind errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -solveEqualities is used to solve kind equalities when kind-checking -user-written types. If solving fails we should fail outright, rather -than just accumulate an error message, for two reasons: - - * A kind-bogus type signature may cause a cascade of knock-on - errors if we let it pass - - * More seriously, we don't have a convenient term-level place to add - deferred bindings for unsolved kind-equality constraints, so we - don't build evidence bindings (by usine reportAllUnsolved). That - means that we'll be left with with a type that has coercion holes - in it, something like - <type> |> co-hole - where co-hole is not filled in. Eeek! That un-filled-in - hole actually causes GHC to crash with "fvProv falls into a hole" - See #11563, #11520, #11516, #11399 - -So it's important to use 'checkNoErrs' here! - -Note [When to do type-class defaulting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC -was false, on the grounds that defaulting can't help solve insoluble -constraints. But if we *don't* do defaulting we may report a whole -lot of errors that would be solved by defaulting; these errors are -quite spurious because fixing the single insoluble error means that -defaulting happens again, which makes all the other errors go away. -This is jolly confusing: #9033. - -So it seems better to always do type-class defaulting. - -However, always doing defaulting does mean that we'll do it in -situations like this (#5934): - run :: (forall s. GenST s) -> Int - run = fromInteger 0 -We don't unify the return type of fromInteger with the given function -type, because the latter involves foralls. So we're left with - (Num alpha, alpha ~ (forall s. GenST s) -> Int) -Now we do defaulting, get alpha := Integer, and report that we can't -match Integer with (forall s. GenST s) -> Int. That's not totally -stupid, but perhaps a little strange. - -Another potential alternative would be to suppress *all* non-insoluble -errors if there are *any* insoluble errors, anywhere, but that seems -too drastic. - -Note [Must simplify after defaulting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may have a deeply buried constraint - (t:*) ~ (a:Open) -which we couldn't solve because of the kind incompatibility, and 'a' is free. -Then when we default 'a' we can solve the constraint. And we want to do -that before starting in on type classes. We MUST do it before reporting -errors, because it isn't an error! #7967 was due to this. - -Note [Top-level Defaulting Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have considered two design choices for where/when to apply defaulting. - (i) Do it in SimplCheck mode only /whenever/ you try to solve some - simple constraints, maybe deep inside the context of implications. - This used to be the case in GHC 7.4.1. - (ii) Do it in a tight loop at simplifyTop, once all other constraints have - finished. This is the current story. - -Option (i) had many disadvantages: - a) Firstly, it was deep inside the actual solver. - b) Secondly, it was dependent on the context (Infer a type signature, - or Check a type signature, or Interactive) since we did not want - to always start defaulting when inferring (though there is an exception to - this, see Note [Default while Inferring]). - c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs: - f :: Int -> Bool - f x = const True (\y -> let w :: a -> a - w a = const a (y+1) - in w y) - We will get an implication constraint (for beta the type of y): - [untch=beta] forall a. 0 => Num beta - which we really cannot default /while solving/ the implication, since beta is - untouchable. - -Instead our new defaulting story is to pull defaulting out of the solver loop and -go with option (ii), implemented at SimplifyTop. Namely: - - First, have a go at solving the residual constraint of the whole - program - - Try to approximate it with a simple constraint - - Figure out derived defaulting equations for that simple constraint - - Go round the loop again if you did manage to get some equations - -Now, that has to do with class defaulting. However there exists type variable /kind/ -defaulting. Again this is done at the top-level and the plan is: - - At the top-level, once you had a go at solving the constraint, do - figure out /all/ the touchable unification variables of the wanted constraints. - - Apply defaulting to their kinds - -More details in Note [DefaultTyVar]. - -Note [Safe Haskell Overlapping Instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Safe Haskell, we apply an extra restriction to overlapping instances. The -motive is to prevent untrusted code provided by a third-party, changing the -behavior of trusted code through type-classes. This is due to the global and -implicit nature of type-classes that can hide the source of the dictionary. - -Another way to state this is: if a module M compiles without importing another -module N, changing M to import N shouldn't change the behavior of M. - -Overlapping instances with type-classes can violate this principle. However, -overlapping instances aren't always unsafe. They are just unsafe when the most -selected dictionary comes from untrusted code (code compiled with -XSafe) and -overlaps instances provided by other modules. - -In particular, in Safe Haskell at a call site with overlapping instances, we -apply the following rule to determine if it is a 'unsafe' overlap: - - 1) Most specific instance, I1, defined in an `-XSafe` compiled module. - 2) I1 is an orphan instance or a MPTC. - 3) At least one overlapped instance, Ix, is both: - A) from a different module than I1 - B) Ix is not marked `OVERLAPPABLE` - -This is a slightly involved heuristic, but captures the situation of an -imported module N changing the behavior of existing code. For example, if -condition (2) isn't violated, then the module author M must depend either on a -type-class or type defined in N. - -Secondly, when should these heuristics be enforced? We enforced them when the -type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. -This allows `-XUnsafe` modules to operate without restriction, and for Safe -Haskell inferrence to infer modules with unsafe overlaps as unsafe. - -One alternative design would be to also consider if an instance was imported as -a `safe` import or not and only apply the restriction to instances imported -safely. However, since instances are global and can be imported through more -than one path, this alternative doesn't work. - -Note [Safe Haskell Overlapping Instances Implementation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -How is this implemented? It's complicated! So we'll step through it all: - - 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where - we check if a particular type-class method call is safe or unsafe. We do this - through the return type, `ClsInstLookupResult`, where the last parameter is a - list of instances that are unsafe to overlap. When the method call is safe, - the list is null. - - 2) `TcInteract.matchClassInst` -- This module drives the instance resolution - / dictionary generation. The return type is `ClsInstResult`, which either - says no instance matched, or one found, and if it was a safe or unsafe - overlap. - - 3) `TcInteract.doTopReactDict` -- Takes a dictionary / class constraint and - tries to resolve it by calling (in part) `matchClassInst`. The resolving - mechanism has a work list (of constraints) that it process one at a time. If - the constraint can't be resolved, it's added to an inert set. When compiling - an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know - compilation should fail. These are handled as normal constraint resolution - failures from here-on (see step 6). - - Otherwise, we may be inferring safety (or using `-Wunsafe`), and - compilation should succeed, but print warnings and/or mark the compiled module - as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds - the unsafe (but resolved!) constraint to the `inert_safehask` field of - `InertCans`. - - 4) `TcSimplify.simplifyTop`: - * Call simpl_top, the top-level function for driving the simplifier for - constraint resolution. - - * Once finished, call `getSafeOverlapFailures` to retrieve the - list of overlapping instances that were successfully resolved, - but unsafe. Remember, this is only applicable for generating warnings - (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy` - cause compilation failure by not resolving the unsafe constraint at all. - - * For unresolved constraints (all types), call `TcErrors.reportUnsolved`, - while for resolved but unsafe overlapping dictionary constraints, call - `TcErrors.warnAllUnsolved`. Both functions convert constraints into a - warning message for the user. - - * In the case of `warnAllUnsolved` for resolved, but unsafe - dictionary constraints, we collect the generated warning - message (pop it) and call `TcRnMonad.recordUnsafeInfer` to - mark the module we are compiling as unsafe, passing the - warning message along as the reason. - - 5) `TcErrors.*Unsolved` -- Generates error messages for constraints by - actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we - know is the constraint that is unresolved or unsafe. For dictionary, all we - know is that we need a dictionary of type C, but not what instances are - available and how they overlap. So we once again call `lookupInstEnv` to - figure that out so we can generate a helpful error message. - - 6) `TcRnMonad.recordUnsafeInfer` -- Save the unsafe result and reason in an - IORef called `tcg_safeInfer`. - - 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling - `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inferrence - failed. - -Note [No defaulting in the ambiguity check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When simplifying constraints for the ambiguity check, we use -solveWantedsAndDrop, not simpl_top, so that we do no defaulting. -#11947 was an example: - f :: Num a => Int -> Int -This is ambiguous of course, but we don't want to default the -(Num alpha) constraint to (Num Int)! Doing so gives a defaulting -warning, but no error. - -Note [Defaulting insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a set of wanteds is insoluble, we have no hope of accepting the -program. Yet we do not stop constraint solving, etc., because we may -simplify the wanteds to produce better error messages. So, once -we have an insoluble constraint, everything we do is just about producing -helpful error messages. - -Should we default in this case or not? Let's look at an example (tcfail004): - - (f,g) = (1,2,3) - -With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer). -Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard) -find the latter more helpful. Several other test cases (e.g. tcfail005) suggest -similarly. So: we should not do class defaulting with insolubles. - -On the other hand, RuntimeRep-defaulting is different. Witness tcfail078: - - f :: Integer i => i - f = 0 - -Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind -TYPE r0 -> Constraint and then complains that r0 is actually untouchable -(presumably, because it can't be sure if `Integer i` entails an equality). -If we default, we are told of a clash between (* -> Constraint) and Constraint. -The latter seems far better, suggesting we *should* do RuntimeRep-defaulting -even on insolubles. - -But, evidently, not always. Witness UnliftedNewtypesInfinite: - - newtype Foo = FooC (# Int#, Foo #) - -This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes). -If we default RuntimeRep-vars, we get - - Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted - -which is just plain wrong. - -Conclusion: we should do RuntimeRep-defaulting on insolubles only when the user does not -want to hear about RuntimeRep stuff -- that is, when -fprint-explicit-runtime-reps -is not set. --} - ------------------- -simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () -simplifyAmbiguityCheck ty wanteds - = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds) - ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds - -- NB: no defaulting! See Note [No defaulting in the ambiguity check] - - ; traceTc "End simplifyAmbiguityCheck }" empty - - -- Normally report all errors; but with -XAllowAmbiguousTypes - -- report only insoluble ones, since they represent genuinely - -- inaccessible code - ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes - ; traceTc "reportUnsolved(ambig) {" empty - ; unless (allow_ambiguous && not (insolubleWC final_wc)) - (discardResult (reportUnsolved final_wc)) - ; traceTc "reportUnsolved(ambig) }" empty - - ; return () } - ------------------- -simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) -simplifyInteractive wanteds - = traceTc "simplifyInteractive" empty >> - simplifyTop wanteds - ------------------- -simplifyDefault :: ThetaType -- Wanted; has no type variables in it - -> TcM () -- Succeeds if the constraint is soluble -simplifyDefault theta - = do { traceTc "simplifyDefault" empty - ; wanteds <- newWanteds DefaultOrigin theta - ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds)) - ; reportAllUnsolved unsolved - ; return () } - ------------------- -tcCheckSatisfiability :: Bag EvVar -> TcM Bool --- Return True if satisfiable, False if definitely contradictory -tcCheckSatisfiability given_ids - = do { lcl_env <- TcM.getLclEnv - ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env - ; (res, _ev_binds) <- runTcS $ - do { traceTcS "checkSatisfiability {" (ppr given_ids) - ; let given_cts = mkGivens given_loc (bagToList given_ids) - -- See Note [Superclasses and satisfiability] - ; solveSimpleGivens given_cts - ; insols <- getInertInsols - ; insols <- try_harder insols - ; traceTcS "checkSatisfiability }" (ppr insols) - ; return (isEmptyBag insols) } - ; return res } - where - try_harder :: Cts -> TcS Cts - -- Maybe we have to search up the superclass chain to find - -- an unsatisfiable constraint. Example: pmcheck/T3927b. - -- At the moment we try just once - try_harder insols - | not (isEmptyBag insols) -- We've found that it's definitely unsatisfiable - = return insols -- Hurrah -- stop now. - | otherwise - = do { pending_given <- getPendingGivenScs - ; new_given <- makeSuperClasses pending_given - ; solveSimpleGivens new_given - ; getInertInsols } - --- | Normalise a type as much as possible using the given constraints. --- See @Note [tcNormalise]@. -tcNormalise :: Bag EvVar -> Type -> TcM Type -tcNormalise given_ids ty - = do { lcl_env <- TcM.getLclEnv - ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env - ; wanted_ct <- mk_wanted_ct - ; (res, _ev_binds) <- runTcS $ - do { traceTcS "tcNormalise {" (ppr given_ids) - ; let given_cts = mkGivens given_loc (bagToList given_ids) - ; solveSimpleGivens given_cts - ; wcs <- solveSimpleWanteds (unitBag wanted_ct) - -- It's an invariant that this wc_simple will always be - -- a singleton Ct, since that's what we fed in as input. - ; let ty' = case bagToList (wc_simple wcs) of - (ct:_) -> ctEvPred (ctEvidence ct) - cts -> pprPanic "tcNormalise" (ppr cts) - ; traceTcS "tcNormalise }" (ppr ty') - ; pure ty' } - ; return res } - where - mk_wanted_ct :: TcM Ct - mk_wanted_ct = do - let occ = mkVarOcc "$tcNorm" - name <- newSysName occ - let ev = mkLocalId name ty - newHoleCt ExprHole ev ty - -{- Note [Superclasses and satisfiability] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Expand superclasses before starting, because (Int ~ Bool), has -(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool) -as a superclass, and it's the latter that is insoluble. See -Note [The equality types story] in TysPrim. - -If we fail to prove unsatisfiability we (arbitrarily) try just once to -find superclasses, using try_harder. Reason: we might have a type -signature - f :: F op (Implements push) => .. -where F is a type function. This happened in #3972. - -We could do more than once but we'd have to have /some/ limit: in the -the recursive case, we would go on forever in the common case where -the constraints /are/ satisfiable (#10592 comment:12!). - -For stratightforard situations without type functions the try_harder -step does nothing. - -Note [tcNormalise] -~~~~~~~~~~~~~~~~~~ -tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas -most invocations of the constraint solver are intended to simplify a set of -constraints or to decide if a particular set of constraints is satisfiable, -the purpose of tcNormalise is to take a type, plus some local constraints, and -normalise the type as much as possible with respect to those constraints. - -It does *not* reduce type or data family applications or look through newtypes. - -Why is this useful? As one example, when coverage-checking an EmptyCase -expression, it's possible that the type of the scrutinee will only reduce -if some local equalities are solved for. See "Wrinkle: Local equalities" -in Note [Type normalisation] in Check. - -To accomplish its stated goal, tcNormalise first feeds the local constraints -into solveSimpleGivens, then stuffs the argument type in a CHoleCan, and feeds -that singleton Ct into solveSimpleWanteds, which reduces the type in the -CHoleCan as much as possible with respect to the local given constraints. When -solveSimpleWanteds is finished, we dig out the type from the CHoleCan and -return that. - -*********************************************************************************** -* * -* Inference -* * -*********************************************************************************** - -Note [Inferring the type of a let-bound variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = rhs - -To infer f's type we do the following: - * Gather the constraints for the RHS with ambient level *one more than* - the current one. This is done by the call - pushLevelAndCaptureConstraints (tcMonoBinds...) - in TcBinds.tcPolyInfer - - * Call simplifyInfer to simplify the constraints and decide what to - quantify over. We pass in the level used for the RHS constraints, - here called rhs_tclvl. - -This ensures that the implication constraint we generate, if any, -has a strictly-increased level compared to the ambient level outside -the let binding. - --} - --- | How should we choose which constraints to quantify over? -data InferMode = ApplyMR -- ^ Apply the monomorphism restriction, - -- never quantifying over any constraints - | EagerDefaulting -- ^ See Note [TcRnExprMode] in TcRnDriver, - -- the :type +d case; this mode refuses - -- to quantify over any defaultable constraint - | NoRestrictions -- ^ Quantify over any constraint that - -- satisfies TcType.pickQuantifiablePreds - -instance Outputable InferMode where - ppr ApplyMR = text "ApplyMR" - ppr EagerDefaulting = text "EagerDefaulting" - ppr NoRestrictions = text "NoRestrictions" - -simplifyInfer :: TcLevel -- Used when generating the constraints - -> InferMode - -> [TcIdSigInst] -- Any signatures (possibly partial) - -> [(Name, TcTauType)] -- Variables to be generalised, - -- and their tau-types - -> WantedConstraints - -> TcM ([TcTyVar], -- Quantify over these type variables - [EvVar], -- ... and these constraints (fully zonked) - TcEvBinds, -- ... binding these evidence variables - WantedConstraints, -- Redidual as-yet-unsolved constraints - Bool) -- True <=> the residual constraints are insoluble - -simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds - | isEmptyWC wanteds - = do { -- When quantifying, we want to preserve any order of variables as they - -- appear in partial signatures. cf. decideQuantifiedTyVars - let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs - , (_,tv) <- sig_inst_skols sig ] - psig_theta = [ pred | sig <- partial_sigs - , pred <- sig_inst_theta sig ] - - ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) - ; qtkvs <- quantifyTyVars dep_vars - ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) - ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) } - - | otherwise - = do { traceTc "simplifyInfer {" $ vcat - [ text "sigs =" <+> ppr sigs - , text "binds =" <+> ppr name_taus - , text "rhs_tclvl =" <+> ppr rhs_tclvl - , text "infer_mode =" <+> ppr infer_mode - , text "(unzonked) wanted =" <+> ppr wanteds - ] - - ; let psig_theta = concatMap sig_inst_theta partial_sigs - - -- First do full-blown solving - -- NB: we must gather up all the bindings from doing - -- this solving; hence (runTcSWithEvBinds ev_binds_var). - -- And note that since there are nested implications, - -- calling solveWanteds will side-effect their evidence - -- bindings, so we can't just revert to the input - -- constraint. - - ; tc_env <- TcM.getEnv - ; ev_binds_var <- TcM.newTcEvBinds - ; psig_theta_vars <- mapM TcM.newEvVar psig_theta - ; wanted_transformed_incl_derivs - <- setTcLevel rhs_tclvl $ - runTcSWithEvBinds ev_binds_var $ - do { let loc = mkGivenLoc rhs_tclvl UnkSkol $ - env_lcl tc_env - psig_givens = mkGivens loc psig_theta_vars - ; _ <- solveSimpleGivens psig_givens - -- See Note [Add signature contexts as givens] - ; solveWanteds wanteds } - - -- Find quant_pred_candidates, the predicates that - -- we'll consider quantifying over - -- NB1: wanted_transformed does not include anything provable from - -- the psig_theta; it's just the extra bit - -- NB2: We do not do any defaulting when inferring a type, this can lead - -- to less polymorphic types, see Note [Default while Inferring] - ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs - ; let definite_error = insolubleWC wanted_transformed_incl_derivs - -- See Note [Quantification with errors] - -- NB: must include derived errors in this test, - -- hence "incl_derivs" - wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs - quant_pred_candidates - | definite_error = [] - | otherwise = ctsPreds (approximateWC False wanted_transformed) - - -- Decide what type variables and constraints to quantify - -- NB: quant_pred_candidates is already fully zonked - -- NB: bound_theta are constraints we want to quantify over, - -- including the psig_theta, which we always quantify over - -- NB: bound_theta are fully zonked - ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl - name_taus partial_sigs - quant_pred_candidates - ; bound_theta_vars <- mapM TcM.newEvVar bound_theta - - -- We must produce bindings for the psig_theta_vars, because we may have - -- used them in evidence bindings constructed by solveWanteds earlier - -- Easiest way to do this is to emit them as new Wanteds (#14643) - ; ct_loc <- getCtLocM AnnOrigin Nothing - ; let psig_wanted = [ CtWanted { ctev_pred = idType psig_theta_var - , ctev_dest = EvVarDest psig_theta_var - , ctev_nosh = WDeriv - , ctev_loc = ct_loc } - | psig_theta_var <- psig_theta_vars ] - - -- Now construct the residual constraint - ; residual_wanted <- mkResidualConstraints rhs_tclvl ev_binds_var - name_taus co_vars qtvs bound_theta_vars - (wanted_transformed `andWC` mkSimpleWC psig_wanted) - - -- All done! - ; traceTc "} simplifyInfer/produced residual implication for quantification" $ - vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates - , text "psig_theta =" <+> ppr psig_theta - , text "bound_theta =" <+> ppr bound_theta - , text "qtvs =" <+> ppr qtvs - , text "definite_error =" <+> ppr definite_error ] - - ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var - , residual_wanted, definite_error ) } - -- NB: bound_theta_vars must be fully zonked - where - partial_sigs = filter isPartialSig sigs - --------------------- -mkResidualConstraints :: TcLevel -> EvBindsVar - -> [(Name, TcTauType)] - -> VarSet -> [TcTyVar] -> [EvVar] - -> WantedConstraints -> TcM WantedConstraints --- Emit the remaining constraints from the RHS. --- See Note [Emitting the residual implication in simplifyInfer] -mkResidualConstraints rhs_tclvl ev_binds_var - name_taus co_vars qtvs full_theta_vars wanteds - | isEmptyWC wanteds - = return wanteds - - | otherwise - = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds) - ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple - is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars - - ; _ <- promoteTyVarSet (tyCoVarsOfCts outer_simple) - - ; let inner_wanted = wanteds { wc_simple = inner_simple } - ; implics <- if isEmptyWC inner_wanted - then return emptyBag - else do implic1 <- newImplication - return $ unitBag $ - implic1 { ic_tclvl = rhs_tclvl - , ic_skols = qtvs - , ic_telescope = Nothing - , ic_given = full_theta_vars - , ic_wanted = inner_wanted - , ic_binds = ev_binds_var - , ic_no_eqs = False - , ic_info = skol_info } - - ; return (WC { wc_simple = outer_simple - , wc_impl = implics })} - where - full_theta = map idType full_theta_vars - skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty) - | (name, ty) <- name_taus ] - -- Don't add the quantified variables here, because - -- they are also bound in ic_skols and we want them - -- to be tidied uniformly - --------------------- -ctsPreds :: Cts -> [PredType] -ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts - , let ev = ctEvidence ct ] - -{- Note [Emitting the residual implication in simplifyInfer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f = e -where f's type is inferred to be something like (a, Proxy k (Int |> co)) -and we have an as-yet-unsolved, or perhaps insoluble, constraint - [W] co :: Type ~ k -We can't form types like (forall co. blah), so we can't generalise over -the coercion variable, and hence we can't generalise over things free in -its kind, in the case 'k'. But we can still generalise over 'a'. So -we'll generalise to - f :: forall a. (a, Proxy k (Int |> co)) -Now we do NOT want to form the residual implication constraint - forall a. [W] co :: Type ~ k -because then co's eventual binding (which will be a value binding if we -use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose -type mentions 'co'). Instead, just as we don't generalise over 'co', we -should not bury its constraint inside the implication. Instead, we must -put it outside. - -That is the reason for the partitionBag in emitResidualConstraints, -which takes the CoVars free in the inferred type, and pulls their -constraints out. (NB: this set of CoVars should be closed-over-kinds.) - -All rather subtle; see #14584. - -Note [Add signature contexts as givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#11016): - f2 :: (?x :: Int) => _ - f2 = ?x -or this - f3 :: a ~ Bool => (a, _) - f3 = (True, False) -or theis - f4 :: (Ord a, _) => a -> Bool - f4 x = x==x - -We'll use plan InferGen because there are holes in the type. But: - * For f2 we want to have the (?x :: Int) constraint floating around - so that the functional dependencies kick in. Otherwise the - occurrence of ?x on the RHS produces constraint (?x :: alpha), and - we won't unify alpha:=Int. - * For f3 we want the (a ~ Bool) available to solve the wanted (a ~ Bool) - in the RHS - * For f4 we want to use the (Ord a) in the signature to solve the Eq a - constraint. - -Solution: in simplifyInfer, just before simplifying the constraints -gathered from the RHS, add Given constraints for the context of any -type signatures. - -************************************************************************ -* * - Quantification -* * -************************************************************************ - -Note [Deciding quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the monomorphism restriction does not apply, then we quantify as follows: - -* Step 1. Take the global tyvars, and "grow" them using the equality - constraints - E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can - happen because alpha is untouchable here) then do not quantify over - beta, because alpha fixes beta, and beta is effectively free in - the environment too - - We also account for the monomorphism restriction; if it applies, - add the free vars of all the constraints. - - Result is mono_tvs; we will not quantify over these. - -* Step 2. Default any non-mono tyvars (i.e ones that are definitely - not going to become further constrained), and re-simplify the - candidate constraints. - - Motivation for re-simplification (#7857): imagine we have a - constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are - not free in the envt, and instance forall (a::*) (b::*). (C a) => C - (a -> b) The instance doesn't match while l1,l2 are polymorphic, but - it will match when we default them to LiftedRep. - - This is all very tiresome. - -* Step 3: decide which variables to quantify over, as follows: - - - Take the free vars of the tau-type (zonked_tau_tvs) and "grow" - them using all the constraints. These are tau_tvs_plus - - - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being - careful to close over kinds, and to skolemise the quantified tyvars. - (This actually unifies each quantifies meta-tyvar with a fresh skolem.) - - Result is qtvs. - -* Step 4: Filter the constraints using pickQuantifiablePreds and the - qtvs. We have to zonk the constraints first, so they "see" the - freshly created skolems. - --} - -decideQuantification - :: InferMode - -> TcLevel - -> [(Name, TcTauType)] -- Variables to be generalised - -> [TcIdSigInst] -- Partial type signatures (if any) - -> [PredType] -- Candidate theta; already zonked - -> TcM ( [TcTyVar] -- Quantify over these (skolems) - , [PredType] -- and this context (fully zonked) - , VarSet) --- See Note [Deciding quantification] -decideQuantification infer_mode rhs_tclvl name_taus psigs candidates - = do { -- Step 1: find the mono_tvs - ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode - name_taus psigs candidates - - -- Step 2: default any non-mono tyvars, and re-simplify - -- This step may do some unification, but result candidates is zonked - ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates - - -- Step 3: decide which kind/type variables to quantify over - ; qtvs <- decideQuantifiedTyVars name_taus psigs candidates - - -- Step 4: choose which of the remaining candidate - -- predicates to actually quantify over - -- NB: decideQuantifiedTyVars turned some meta tyvars - -- into quantified skolems, so we have to zonk again - ; candidates <- TcM.zonkTcTypes candidates - ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs) - ; let quantifiable_candidates - = pickQuantifiablePreds (mkVarSet qtvs) candidates - -- NB: do /not/ run pickQuantifiablePreds over psig_theta, - -- because we always want to quantify over psig_theta, and not - -- drop any of them; e.g. CallStack constraints. c.f #14658 - - theta = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] - (psig_theta ++ quantifiable_candidates) - - ; traceTc "decideQuantification" - (vcat [ text "infer_mode:" <+> ppr infer_mode - , text "candidates:" <+> ppr candidates - , text "psig_theta:" <+> ppr psig_theta - , text "mono_tvs:" <+> ppr mono_tvs - , text "co_vars:" <+> ppr co_vars - , text "qtvs:" <+> ppr qtvs - , text "theta:" <+> ppr theta ]) - ; return (qtvs, theta, co_vars) } - ------------------- -decideMonoTyVars :: InferMode - -> [(Name,TcType)] - -> [TcIdSigInst] - -> [PredType] - -> TcM (TcTyCoVarSet, [PredType], CoVarSet) --- Decide which tyvars and covars cannot be generalised: --- (a) Free in the environment --- (b) Mentioned in a constraint we can't generalise --- (c) Connected by an equality to (a) or (b) --- Also return CoVars that appear free in the final quantified types --- we can't quantify over these, and we must make sure they are in scope -decideMonoTyVars infer_mode name_taus psigs candidates - = do { (no_quant, maybe_quant) <- pick infer_mode candidates - - -- If possible, we quantify over partial-sig qtvs, so they are - -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs - ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ - concatMap (map snd . sig_inst_skols) psigs - - ; psig_theta <- mapM TcM.zonkTcType $ - concatMap sig_inst_theta psigs - - ; taus <- mapM (TcM.zonkTcType . snd) name_taus - - ; tc_lvl <- TcM.getTcLevel - ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta - - co_vars = coVarsOfTypes (psig_tys ++ taus) - co_var_tvs = closeOverKinds co_vars - -- The co_var_tvs are tvs mentioned in the types of covars or - -- coercion holes. We can't quantify over these covars, so we - -- must include the variable in their types in the mono_tvs. - -- E.g. If we can't quantify over co :: k~Type, then we can't - -- quantify over k either! Hence closeOverKinds - - mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $ - tyCoVarsOfTypes candidates - -- We need to grab all the non-quantifiable tyvars in the - -- candidates so that we can grow this set to find other - -- non-quantifiable tyvars. This can happen with something - -- like - -- f x y = ... - -- where z = x 3 - -- The body of z tries to unify the type of x (call it alpha[1]) - -- with (beta[2] -> gamma[2]). This unification fails because - -- alpha is untouchable. But we need to know not to quantify over - -- beta or gamma, because they are in the equality constraint with - -- alpha. Actual test case: typecheck/should_compile/tc213 - - mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs - - eq_constraints = filter isEqPrimPred candidates - mono_tvs2 = growThetaTyVars eq_constraints mono_tvs1 - - constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $ - (growThetaTyVars eq_constraints - (tyCoVarsOfTypes no_quant) - `minusVarSet` mono_tvs2) - `delVarSetList` psig_qtvs - -- constrained_tvs: the tyvars that we are not going to - -- quantify solely because of the monomorphism restriction - -- - -- (`minusVarSet` mono_tvs2`): a type variable is only - -- "constrained" (so that the MR bites) if it is not - -- free in the environment (#13785) - -- - -- (`delVarSetList` psig_qtvs): if the user has explicitly - -- asked for quantification, then that request "wins" - -- over the MR. Note: do /not/ delete psig_qtvs from - -- mono_tvs1, because mono_tvs1 cannot under any circumstances - -- be quantified (#14479); see - -- Note [Quantification and partial signatures], Wrinkle 3, 4 - - mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs - - -- Warn about the monomorphism restriction - ; warn_mono <- woptM Opt_WarnMonomorphism - ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $ - warnTc (Reason Opt_WarnMonomorphism) - (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) - mr_msg - - ; traceTc "decideMonoTyVars" $ vcat - [ text "mono_tvs0 =" <+> ppr mono_tvs0 - , text "no_quant =" <+> ppr no_quant - , text "maybe_quant =" <+> ppr maybe_quant - , text "eq_constraints =" <+> ppr eq_constraints - , text "mono_tvs =" <+> ppr mono_tvs - , text "co_vars =" <+> ppr co_vars ] - - ; return (mono_tvs, maybe_quant, co_vars) } - where - pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType]) - -- Split the candidates into ones we definitely - -- won't quantify, and ones that we might - pick NoRestrictions cand = return ([], cand) - pick ApplyMR cand = return (cand, []) - pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings - ; return (partition (is_int_ct os) cand) } - - -- For EagerDefaulting, do not quantify over - -- over any interactive class constraint - is_int_ct ovl_strings pred - | Just (cls, _) <- getClassPredTys_maybe pred - = isInteractiveClass ovl_strings cls - | otherwise - = False - - pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus - mr_msg = - hang (sep [ text "The Monomorphism Restriction applies to the binding" - <> plural name_taus - , text "for" <+> pp_bndrs ]) - 2 (hsep [ text "Consider giving" - , text (if isSingleton name_taus then "it" else "them") - , text "a type signature"]) - -------------------- -defaultTyVarsAndSimplify :: TcLevel - -> TyCoVarSet - -> [PredType] -- Assumed zonked - -> TcM [PredType] -- Guaranteed zonked --- Default any tyvar free in the constraints, --- and re-simplify in case the defaulting allows further simplification -defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates - = do { -- Promote any tyvars that we cannot generalise - -- See Note [Promote momomorphic tyvars] - ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs) - ; (prom, _) <- promoteTyVarSet mono_tvs - - -- Default any kind/levity vars - ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} - <- candidateQTyVarsOfTypes candidates - -- any covars should already be handled by - -- the logic in decideMonoTyVars, which looks at - -- the constraints generated - - ; poly_kinds <- xoptM LangExt.PolyKinds - ; default_kvs <- mapM (default_one poly_kinds True) - (dVarSetElems cand_kvs) - ; default_tvs <- mapM (default_one poly_kinds False) - (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) - ; let some_default = or default_kvs || or default_tvs - - ; case () of - _ | some_default -> simplify_cand candidates - | prom -> mapM TcM.zonkTcType candidates - | otherwise -> return candidates - } - where - default_one poly_kinds is_kind_var tv - | not (isMetaTyVar tv) - = return False - | tv `elemVarSet` mono_tvs - = return False - | otherwise - = defaultTyVar (not poly_kinds && is_kind_var) tv - - simplify_cand candidates - = do { clone_wanteds <- newWanteds DefaultOrigin candidates - ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $ - simplifyWantedsTcM clone_wanteds - -- Discard evidence; simples is fully zonked - - ; let new_candidates = ctsPreds simples - ; traceTc "Simplified after defaulting" $ - vcat [ text "Before:" <+> ppr candidates - , text "After:" <+> ppr new_candidates ] - ; return new_candidates } - ------------------- -decideQuantifiedTyVars - :: [(Name,TcType)] -- Annotated theta and (name,tau) pairs - -> [TcIdSigInst] -- Partial signatures - -> [PredType] -- Candidates, zonked - -> TcM [TyVar] --- Fix what tyvars we are going to quantify over, and quantify them -decideQuantifiedTyVars name_taus psigs candidates - = do { -- Why psig_tys? We try to quantify over everything free in here - -- See Note [Quantification and partial signatures] - -- Wrinkles 2 and 3 - ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs - , (_,tv) <- sig_inst_skols sig ] - ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs - , pred <- sig_inst_theta sig ] - ; tau_tys <- mapM (TcM.zonkTcType . snd) name_taus - - ; let -- Try to quantify over variables free in these types - psig_tys = psig_tv_tys ++ psig_theta - seed_tys = psig_tys ++ tau_tys - - -- Now "grow" those seeds to find ones reachable via 'candidates' - grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys) - - -- Now we have to classify them into kind variables and type variables - -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars - -- - -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces - -- them in that order, so that the final qtvs quantifies in the same - -- order as the partial signatures do (#13524) - ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $ - psig_tys ++ candidates ++ tau_tys - ; let pick = (`dVarSetIntersectVarSet` grown_tcvs) - dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs } - - ; traceTc "decideQuantifiedTyVars" (vcat - [ text "candidates =" <+> ppr candidates - , text "tau_tys =" <+> ppr tau_tys - , text "seed_tys =" <+> ppr seed_tys - , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys) - , text "grown_tcvs =" <+> ppr grown_tcvs - , text "dvs =" <+> ppr dvs_plus]) - - ; quantifyTyVars dvs_plus } - ------------------- -growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet --- See Note [Growing the tau-tvs using constraints] -growThetaTyVars theta tcvs - | null theta = tcvs - | otherwise = transCloVarSet mk_next seed_tcvs - where - seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips - (ips, non_ips) = partition isIPPred theta - -- See Note [Inheriting implicit parameters] in TcType - - mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones - mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips - grow_one so_far pred tcvs - | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs - | otherwise = tcvs - where - pred_tcvs = tyCoVarsOfType pred - - -{- Note [Promote momomorphic tyvars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Promote any type variables that are free in the environment. Eg - f :: forall qtvs. bound_theta => zonked_tau -The free vars of f's type become free in the envt, and hence will show -up whenever 'f' is called. They may currently at rhs_tclvl, but they -had better be unifiable at the outer_tclvl! Example: envt mentions -alpha[1] - tau_ty = beta[2] -> beta[2] - constraints = alpha ~ [beta] -we don't quantify over beta (since it is fixed by envt) -so we must promote it! The inferred type is just - f :: beta -> beta - -NB: promoteTyVar ignores coercion variables - -Note [Quantification and partial signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When choosing type variables to quantify, the basic plan is to -quantify over all type variables that are - * free in the tau_tvs, and - * not forced to be monomorphic (mono_tvs), - for example by being free in the environment. - -However, in the case of a partial type signature, be doing inference -*in the presence of a type signature*. For example: - f :: _ -> a - f x = ... -or - g :: (Eq _a) => _b -> _b -In both cases we use plan InferGen, and hence call simplifyInfer. But -those 'a' variables are skolems (actually TyVarTvs), and we should be -sure to quantify over them. This leads to several wrinkles: - -* Wrinkle 1. In the case of a type error - f :: _ -> Maybe a - f x = True && x - The inferred type of 'f' is f :: Bool -> Bool, but there's a - left-over error of form (HoleCan (Maybe a ~ Bool)). The error-reporting - machine expects to find a binding site for the skolem 'a', so we - add it to the quantified tyvars. - -* Wrinkle 2. Consider the partial type signature - f :: (Eq _) => Int -> Int - f x = x - In normal cases that makes sense; e.g. - g :: Eq _a => _a -> _a - g x = x - where the signature makes the type less general than it could - be. But for 'f' we must therefore quantify over the user-annotated - constraints, to get - f :: forall a. Eq a => Int -> Int - (thereby correctly triggering an ambiguity error later). If we don't - we'll end up with a strange open type - f :: Eq alpha => Int -> Int - which isn't ambiguous but is still very wrong. - - Bottom line: Try to quantify over any variable free in psig_theta, - just like the tau-part of the type. - -* Wrinkle 3 (#13482). Also consider - f :: forall a. _ => Int -> Int - f x = if (undefined :: a) == undefined then x else 0 - Here we get an (Eq a) constraint, but it's not mentioned in the - psig_theta nor the type of 'f'. But we still want to quantify - over 'a' even if the monomorphism restriction is on. - -* Wrinkle 4 (#14479) - foo :: Num a => a -> a - foo xxx = g xxx - where - g :: forall b. Num b => _ -> b - g y = xxx + y - - In the signature for 'g', we cannot quantify over 'b' because it turns out to - get unified with 'a', which is free in g's environment. So we carefully - refrain from bogusly quantifying, in TcSimplify.decideMonoTyVars. We - report the error later, in TcBinds.chooseInferredQuantifiers. - -Note [Growing the tau-tvs using constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(growThetaTyVars insts tvs) is the result of extending the set - of tyvars, tvs, using all conceivable links from pred - -E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e} -Then growThetaTyVars preds tvs = {a,b,c} - -Notice that - growThetaTyVars is conservative if v might be fixed by vs - => v `elem` grow(vs,C) - -Note [Quantification with errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we find that the RHS of the definition has some absolutely-insoluble -constraints (including especially "variable not in scope"), we - -* Abandon all attempts to find a context to quantify over, - and instead make the function fully-polymorphic in whatever - type we have found - -* Return a flag from simplifyInfer, indicating that we found an - insoluble constraint. This flag is used to suppress the ambiguity - check for the inferred type, which may well be bogus, and which - tends to obscure the real error. This fix feels a bit clunky, - but I failed to come up with anything better. - -Reasons: - - Avoid downstream errors - - Do not perform an ambiguity test on a bogus type, which might well - fail spuriously, thereby obfuscating the original insoluble error. - #14000 is an example - -I tried an alternative approach: simply failM, after emitting the -residual implication constraint; the exception will be caught in -TcBinds.tcPolyBinds, which gives all the binders in the group the type -(forall a. a). But that didn't work with -fdefer-type-errors, because -the recovery from failM emits no code at all, so there is no function -to run! But -fdefer-type-errors aspires to produce a runnable program. - -NB that we must include *derived* errors in the check for insolubles. -Example: - (a::*) ~ Int# -We get an insoluble derived error *~#, and we don't want to discard -it before doing the isInsolubleWC test! (#8262) - -Note [Default while Inferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Our current plan is that defaulting only happens at simplifyTop and -not simplifyInfer. This may lead to some insoluble deferred constraints. -Example: - -instance D g => C g Int b - -constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha -type inferred = gamma -> gamma - -Now, if we try to default (alpha := Int) we will be able to refine the implication to - (forall b. 0 => C gamma Int b) -which can then be simplified further to - (forall b. 0 => D gamma) -Finally, we /can/ approximate this implication with (D gamma) and infer the quantified -type: forall g. D g => g -> g - -Instead what will currently happen is that we will get a quantified type -(forall g. g -> g) and an implication: - forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha - -Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an -unsolvable implication: - forall g. 0 => (forall b. 0 => D g) - -The concrete example would be: - h :: C g a s => g -> a -> ST s a - f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1) - -But it is quite tedious to do defaulting and resolve the implication constraints, and -we have not observed code breaking because of the lack of defaulting in inference, so -we don't do it for now. - - - -Note [Minimize by Superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we quantify over a constraint, in simplifyInfer we need to -quantify over a constraint that is minimal in some sense: For -instance, if the final wanted constraint is (Eq alpha, Ord alpha), -we'd like to quantify over Ord alpha, because we can just get Eq alpha -from superclass selection from Ord alpha. This minimization is what -mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint -to check the original wanted. - - -Note [Avoid unnecessary constraint simplification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -------- NB NB NB (Jun 12) ------------- - This note not longer applies; see the notes with #4361. - But I'm leaving it in here so we remember the issue.) - ---------------------------------------- -When inferring the type of a let-binding, with simplifyInfer, -try to avoid unnecessarily simplifying class constraints. -Doing so aids sharing, but it also helps with delicate -situations like - - instance C t => C [t] where .. - - f :: C [t] => .... - f x = let g y = ...(constraint C [t])... - in ... -When inferring a type for 'g', we don't want to apply the -instance decl, because then we can't satisfy (C t). So we -just notice that g isn't quantified over 't' and partition -the constraints before simplifying. - -This only half-works, but then let-generalisation only half-works. - -********************************************************************************* -* * -* Main Simplifier * -* * -*********************************************************************************** - --} - -simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints --- Solve the specified Wanted constraints --- Discard the evidence binds --- Discards all Derived stuff in result --- Postcondition: fully zonked and unflattened constraints -simplifyWantedsTcM wanted - = do { traceTc "simplifyWantedsTcM {" (ppr wanted) - ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted)) - ; result <- TcM.zonkWC result - ; traceTc "simplifyWantedsTcM }" (ppr result) - ; return result } - -solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints --- Since solveWanteds returns the residual WantedConstraints, --- it should always be called within a runTcS or something similar, --- Result is not zonked -solveWantedsAndDrop wanted - = do { wc <- solveWanteds wanted - ; return (dropDerivedWC wc) } - -solveWanteds :: WantedConstraints -> TcS WantedConstraints --- so that the inert set doesn't mindlessly propagate. --- NB: wc_simples may be wanted /or/ derived now -solveWanteds wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { cur_lvl <- TcS.getTcLevel - ; traceTcS "solveWanteds {" $ - vcat [ text "Level =" <+> ppr cur_lvl - , ppr wc ] - - ; wc1 <- solveSimpleWanteds simples - -- Any insoluble constraints are in 'simples' and so get rewritten - -- See Note [Rewrite insolubles] in TcSMonad - - ; (floated_eqs, implics2) <- solveNestedImplications $ - implics `unionBags` wc_impl wc1 - - ; dflags <- getDynFlags - ; final_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs - (wc1 { wc_impl = implics2 }) - - ; ev_binds_var <- getTcEvBindsVar - ; bb <- TcS.getTcEvBindsMap ev_binds_var - ; traceTcS "solveWanteds }" $ - vcat [ text "final wc =" <+> ppr final_wc - , text "current evbinds =" <+> ppr (evBindMapBinds bb) ] - - ; return final_wc } - -simpl_loop :: Int -> IntWithInf -> Cts - -> WantedConstraints -> TcS WantedConstraints -simpl_loop n limit floated_eqs wc@(WC { wc_simple = simples }) - | n `intGtLimit` limit - = do { -- Add an error (not a warning) if we blow the limit, - -- Typically if we blow the limit we are going to report some other error - -- (an unsolved constraint), and we don't want that error to suppress - -- the iteration limit warning! - addErrTcS (hang (text "solveWanteds: too many iterations" - <+> parens (text "limit =" <+> ppr limit)) - 2 (vcat [ text "Unsolved:" <+> ppr wc - , ppUnless (isEmptyBag floated_eqs) $ - text "Floated equalities:" <+> ppr floated_eqs - , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" - ])) - ; return wc } - - | not (isEmptyBag floated_eqs) - = simplify_again n limit True (wc { wc_simple = floated_eqs `unionBags` simples }) - -- Put floated_eqs first so they get solved first - -- NB: the floated_eqs may include /derived/ equalities - -- arising from fundeps inside an implication - - | superClassesMightHelp wc - = -- We still have unsolved goals, and apparently no way to solve them, - -- so try expanding superclasses at this level, both Given and Wanted - do { pending_given <- getPendingGivenScs - ; let (pending_wanted, simples1) = getPendingWantedScs simples - ; if null pending_given && null pending_wanted - then return wc -- After all, superclasses did not help - else - do { new_given <- makeSuperClasses pending_given - ; new_wanted <- makeSuperClasses pending_wanted - ; solveSimpleGivens new_given -- Add the new Givens to the inert set - ; simplify_again n limit (null pending_given) - wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } } - - | otherwise - = return wc - -simplify_again :: Int -> IntWithInf -> Bool - -> WantedConstraints -> TcS WantedConstraints --- We have definitely decided to have another go at solving --- the wanted constraints (we have tried at least once already -simplify_again n limit no_new_given_scs - wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { csTraceTcS $ - text "simpl_loop iteration=" <> int n - <+> (parens $ hsep [ text "no new given superclasses =" <+> ppr no_new_given_scs <> comma - , int (lengthBag simples) <+> text "simples to solve" ]) - ; traceTcS "simpl_loop: wc =" (ppr wc) - - ; (unifs1, wc1) <- reportUnifications $ - solveSimpleWanteds $ - simples - - -- See Note [Cutting off simpl_loop] - -- We have already tried to solve the nested implications once - -- Try again only if we have unified some meta-variables - -- (which is a bit like adding more givens), or we have some - -- new Given superclasses - ; let new_implics = wc_impl wc1 - ; if unifs1 == 0 && - no_new_given_scs && - isEmptyBag new_implics - - then -- Do not even try to solve the implications - simpl_loop (n+1) limit emptyBag (wc1 { wc_impl = implics }) - - else -- Try to solve the implications - do { (floated_eqs2, implics2) <- solveNestedImplications $ - implics `unionBags` new_implics - ; simpl_loop (n+1) limit floated_eqs2 (wc1 { wc_impl = implics2 }) - } } - -solveNestedImplications :: Bag Implication - -> TcS (Cts, Bag Implication) --- Precondition: the TcS inerts may contain unsolved simples which have --- to be converted to givens before we go inside a nested implication. -solveNestedImplications implics - | isEmptyBag implics - = return (emptyBag, emptyBag) - | otherwise - = do { traceTcS "solveNestedImplications starting {" empty - ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics - ; let floated_eqs = concatBag floated_eqs_s - - -- ... and we are back in the original TcS inerts - -- Notice that the original includes the _insoluble_simples so it was safe to ignore - -- them in the beginning of this function. - ; traceTcS "solveNestedImplications end }" $ - vcat [ text "all floated_eqs =" <+> ppr floated_eqs - , text "unsolved_implics =" <+> ppr unsolved_implics ] - - ; return (floated_eqs, catBagMaybes unsolved_implics) } - -solveImplication :: Implication -- Wanted - -> TcS (Cts, -- All wanted or derived floated equalities: var = type - Maybe Implication) -- Simplified implication (empty or singleton) --- Precondition: The TcS monad contains an empty worklist and given-only inerts --- which after trying to solve this implication we must restore to their original value -solveImplication imp@(Implic { ic_tclvl = tclvl - , ic_binds = ev_binds_var - , ic_skols = skols - , ic_given = given_ids - , ic_wanted = wanteds - , ic_info = info - , ic_status = status }) - | isSolvedStatus status - = return (emptyCts, Just imp) -- Do nothing - - | otherwise -- Even for IC_Insoluble it is worth doing more work - -- The insoluble stuff might be in one sub-implication - -- and other unsolved goals in another; and we want to - -- solve the latter as much as possible - = do { inerts <- getTcSInerts - ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) - - -- commented out; see `where` clause below - -- ; when debugIsOn check_tc_level - - -- Solve the nested constraints - ; (no_given_eqs, given_insols, residual_wanted) - <- nestImplicTcS ev_binds_var tclvl $ - do { let loc = mkGivenLoc tclvl info (ic_env imp) - givens = mkGivens loc given_ids - ; solveSimpleGivens givens - - ; residual_wanted <- solveWanteds wanteds - -- solveWanteds, *not* solveWantedsAndDrop, because - -- we want to retain derived equalities so we can float - -- them out in floatEqualities - - ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols - -- Call getNoGivenEqs /after/ solveWanteds, because - -- solveWanteds can augment the givens, via expandSuperClasses, - -- to reveal given superclass equalities - - ; return (no_eqs, given_insols, residual_wanted) } - - ; (floated_eqs, residual_wanted) - <- floatEqualities skols given_ids ev_binds_var - no_given_eqs residual_wanted - - ; traceTcS "solveImplication 2" - (ppr given_insols $$ ppr residual_wanted) - ; let final_wanted = residual_wanted `addInsols` given_insols - -- Don't lose track of the insoluble givens, - -- which signal unreachable code; put them in ic_wanted - - ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs - , ic_wanted = final_wanted }) - - ; evbinds <- TcS.getTcEvBindsMap ev_binds_var - ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var - ; traceTcS "solveImplication end }" $ vcat - [ text "no_given_eqs =" <+> ppr no_given_eqs - , text "floated_eqs =" <+> ppr floated_eqs - , text "res_implic =" <+> ppr res_implic - , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) - , text "implication tvcs =" <+> ppr tcvs ] - - ; return (floated_eqs, res_implic) } - - where - -- TcLevels must be strictly increasing (see (ImplicInv) in - -- Note [TcLevel and untouchable type variables] in TcType), - -- and in fact I think they should always increase one level at a time. - - -- Though sensible, this check causes lots of testsuite failures. It is - -- remaining commented out for now. - {- - check_tc_level = do { cur_lvl <- TcS.getTcLevel - ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) } - -} - ----------------------- -setImplicationStatus :: Implication -> TcS (Maybe Implication) --- Finalise the implication returned from solveImplication: --- * Set the ic_status field --- * Trim the ic_wanted field to remove Derived constraints --- Precondition: the ic_status field is not already IC_Solved --- Return Nothing if we can discard the implication altogether -setImplicationStatus implic@(Implic { ic_status = status - , ic_info = info - , ic_wanted = wc - , ic_given = givens }) - | ASSERT2( not (isSolvedStatus status ), ppr info ) - -- Precondition: we only set the status if it is not already solved - not (isSolvedWC pruned_wc) - = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic) - - ; implic <- neededEvVars implic - - ; let new_status | insolubleWC pruned_wc = IC_Insoluble - | otherwise = IC_Unsolved - new_implic = implic { ic_status = new_status - , ic_wanted = pruned_wc } - - ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic) - - ; return $ Just new_implic } - - | otherwise -- Everything is solved - -- Set status to IC_Solved, - -- and compute the dead givens and outer needs - -- See Note [Tracking redundant constraints] - = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic) - - ; implic@(Implic { ic_need_inner = need_inner - , ic_need_outer = need_outer }) <- neededEvVars implic - - ; bad_telescope <- checkBadTelescope implic - - ; let dead_givens | warnRedundantGivens info - = filterOut (`elemVarSet` need_inner) givens - | otherwise = [] -- None to report - - discard_entire_implication -- Can we discard the entire implication? - = null dead_givens -- No warning from this implication - && not bad_telescope - && isEmptyWC pruned_wc -- No live children - && isEmptyVarSet need_outer -- No needed vars to pass up to parent - - final_status - | bad_telescope = IC_BadTelescope - | otherwise = IC_Solved { ics_dead = dead_givens } - final_implic = implic { ic_status = final_status - , ic_wanted = pruned_wc } - - ; traceTcS "setImplicationStatus(all-solved) }" $ - vcat [ text "discard:" <+> ppr discard_entire_implication - , text "new_implic:" <+> ppr final_implic ] - - ; return $ if discard_entire_implication - then Nothing - else Just final_implic } - where - WC { wc_simple = simples, wc_impl = implics } = wc - - pruned_simples = dropDerivedSimples simples - pruned_implics = filterBag keep_me implics - pruned_wc = WC { wc_simple = pruned_simples - , wc_impl = pruned_implics } - - keep_me :: Implication -> Bool - keep_me ic - | IC_Solved { ics_dead = dead_givens } <- ic_status ic - -- Fully solved - , null dead_givens -- No redundant givens to report - , isEmptyBag (wc_impl (ic_wanted ic)) - -- And no children that might have things to report - = False -- Tnen we don't need to keep it - | otherwise - = True -- Otherwise, keep it - -checkBadTelescope :: Implication -> TcS Bool --- True <=> the skolems form a bad telescope --- See Note [Checking telescopes] in Constraint -checkBadTelescope (Implic { ic_telescope = m_telescope - , ic_skols = skols }) - | isJust m_telescope - = do{ skols <- mapM TcS.zonkTyCoVarKind skols - ; return (go emptyVarSet (reverse skols))} - - | otherwise - = return False - - where - go :: TyVarSet -- skolems that appear *later* than the current ones - -> [TcTyVar] -- ordered skolems, in reverse order - -> Bool -- True <=> there is an out-of-order skolem - go _ [] = False - go later_skols (one_skol : earlier_skols) - | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols - = True - | otherwise - = go (later_skols `extendVarSet` one_skol) earlier_skols - -warnRedundantGivens :: SkolemInfo -> Bool -warnRedundantGivens (SigSkol ctxt _ _) - = case ctxt of - FunSigCtxt _ warn_redundant -> warn_redundant - ExprSigCtxt -> True - _ -> False - - -- To think about: do we want to report redundant givens for - -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21. -warnRedundantGivens (InstSkol {}) = True -warnRedundantGivens _ = False - -neededEvVars :: Implication -> TcS Implication --- Find all the evidence variables that are "needed", --- and delete dead evidence bindings --- See Note [Tracking redundant constraints] --- See Note [Delete dead Given evidence bindings] --- --- - Start from initial_seeds (from nested implications) --- --- - Add free vars of RHS of all Wanted evidence bindings --- and coercion variables accumulated in tcvs (all Wanted) --- --- - Generate 'needed', the needed set of EvVars, by doing transitive --- closure through Given bindings --- e.g. Needed {a,b} --- Given a = sc_sel a2 --- Then a2 is needed too --- --- - Prune out all Given bindings that are not needed --- --- - From the 'needed' set, delete ev_bndrs, the binders of the --- evidence bindings, to give the final needed variables --- -neededEvVars implic@(Implic { ic_given = givens - , ic_binds = ev_binds_var - , ic_wanted = WC { wc_impl = implics } - , ic_need_inner = old_needs }) - = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var - ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var - - ; let seeds1 = foldr add_implic_seeds old_needs implics - seeds2 = foldEvBindMap add_wanted seeds1 ev_binds - seeds3 = seeds2 `unionVarSet` tcvs - need_inner = findNeededEvVars ev_binds seeds3 - live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds - need_outer = foldEvBindMap del_ev_bndr need_inner live_ev_binds - `delVarSetList` givens - - ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds - -- See Note [Delete dead Given evidence bindings] - - ; traceTcS "neededEvVars" $ - vcat [ text "old_needs:" <+> ppr old_needs - , text "seeds3:" <+> ppr seeds3 - , text "tcvs:" <+> ppr tcvs - , text "ev_binds:" <+> ppr ev_binds - , text "live_ev_binds:" <+> ppr live_ev_binds ] - - ; return (implic { ic_need_inner = need_inner - , ic_need_outer = need_outer }) } - where - add_implic_seeds (Implic { ic_need_outer = needs }) acc - = needs `unionVarSet` acc - - needed_ev_bind needed (EvBind { eb_lhs = ev_var - , eb_is_given = is_given }) - | is_given = ev_var `elemVarSet` needed - | otherwise = True -- Keep all wanted bindings - - del_ev_bndr :: EvBind -> VarSet -> VarSet - del_ev_bndr (EvBind { eb_lhs = v }) needs = delVarSet needs v - - add_wanted :: EvBind -> VarSet -> VarSet - add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs - | is_given = needs -- Add the rhs vars of the Wanted bindings only - | otherwise = evVarsOfTerm rhs `unionVarSet` needs - - -{- Note [Delete dead Given evidence bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As a result of superclass expansion, we speculatively -generate evidence bindings for Givens. E.g. - f :: (a ~ b) => a -> b -> Bool - f x y = ... -We'll have - [G] d1 :: (a~b) -and we'll speculatively generate the evidence binding - [G] d2 :: (a ~# b) = sc_sel d - -Now d2 is available for solving. But it may not be needed! Usually -such dead superclass selections will eventually be dropped as dead -code, but: - - * It won't always be dropped (#13032). In the case of an - unlifted-equality superclass like d2 above, we generate - case heq_sc d1 of d2 -> ... - and we can't (in general) drop that case expression in case - d1 is bottom. So it's technically unsound to have added it - in the first place. - - * Simply generating all those extra superclasses can generate lots of - code that has to be zonked, only to be discarded later. Better not - to generate it in the first place. - - Moreover, if we simplify this implication more than once - (e.g. because we can't solve it completely on the first iteration - of simpl_looop), we'll generate all the same bindings AGAIN! - -Easy solution: take advantage of the work we are doing to track dead -(unused) Givens, and use it to prune the Given bindings too. This is -all done by neededEvVars. - -This led to a remarkable 25% overall compiler allocation decrease in -test T12227. - -But we don't get to discard all redundant equality superclasses, alas; -see #15205. - -Note [Tracking redundant constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With Opt_WarnRedundantConstraints, GHC can report which -constraints of a type signature (or instance declaration) are -redundant, and can be omitted. Here is an overview of how it -works: - ------ What is a redundant constraint? - -* The things that can be redundant are precisely the Given - constraints of an implication. - -* A constraint can be redundant in two different ways: - a) It is implied by other givens. E.g. - f :: (Eq a, Ord a) => blah -- Eq a unnecessary - g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary - b) It is not needed by the Wanted constraints covered by the - implication E.g. - f :: Eq a => a -> Bool - f x = True -- Equality not used - -* To find (a), when we have two Given constraints, - we must be careful to drop the one that is a naked variable (if poss). - So if we have - f :: (Eq a, Ord a) => blah - then we may find [G] sc_sel (d1::Ord a) :: Eq a - [G] d2 :: Eq a - We want to discard d2 in favour of the superclass selection from - the Ord dictionary. This is done by TcInteract.solveOneFromTheOther - See Note [Replacement vs keeping]. - -* To find (b) we need to know which evidence bindings are 'wanted'; - hence the eb_is_given field on an EvBind. - ------ How tracking works - -* The ic_need fields of an Implic records in-scope (given) evidence - variables bound by the context, that were needed to solve this - implication (so far). See the declaration of Implication. - -* When the constraint solver finishes solving all the wanteds in - an implication, it sets its status to IC_Solved - - - The ics_dead field, of IC_Solved, records the subset of this - implication's ic_given that are redundant (not needed). - -* We compute which evidence variables are needed by an implication - in setImplicationStatus. A variable is needed if - a) it is free in the RHS of a Wanted EvBind, - b) it is free in the RHS of an EvBind whose LHS is needed, - c) it is in the ics_need of a nested implication. - -* We need to be careful not to discard an implication - prematurely, even one that is fully solved, because we might - thereby forget which variables it needs, and hence wrongly - report a constraint as redundant. But we can discard it once - its free vars have been incorporated into its parent; or if it - simply has no free vars. This careful discarding is also - handled in setImplicationStatus. - ------ Reporting redundant constraints - -* TcErrors does the actual warning, in warnRedundantConstraints. - -* We don't report redundant givens for *every* implication; only - for those which reply True to TcSimplify.warnRedundantGivens: - - - For example, in a class declaration, the default method *can* - use the class constraint, but it certainly doesn't *have* to, - and we don't want to report an error there. - - - More subtly, in a function definition - f :: (Ord a, Ord a, Ix a) => a -> a - f x = rhs - we do an ambiguity check on the type (which would find that one - of the Ord a constraints was redundant), and then we check that - the definition has that type (which might find that both are - redundant). We don't want to report the same error twice, so we - disable it for the ambiguity check. Hence using two different - FunSigCtxts, one with the warn-redundant field set True, and the - other set False in - - TcBinds.tcSpecPrag - - TcBinds.tcTySig - - This decision is taken in setImplicationStatus, rather than TcErrors - so that we can discard implication constraints that we don't need. - So ics_dead consists only of the *reportable* redundant givens. - ------ Shortcomings - -Consider (see #9939) - f2 :: (Eq a, Ord a) => a -> a -> Bool - -- Ord a redundant, but Eq a is reported - f2 x y = (x == y) - -We report (Eq a) as redundant, whereas actually (Ord a) is. But it's -really not easy to detect that! - - -Note [Cutting off simpl_loop] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is very important not to iterate in simpl_loop unless there is a chance -of progress. #8474 is a classic example: - - * There's a deeply-nested chain of implication constraints. - ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int - - * From the innermost one we get a [D] alpha ~ Int, - but alpha is untouchable until we get out to the outermost one - - * We float [D] alpha~Int out (it is in floated_eqs), but since alpha - is untouchable, the solveInteract in simpl_loop makes no progress - - * So there is no point in attempting to re-solve - ?yn:betan => [W] ?x:Int - via solveNestedImplications, because we'll just get the - same [D] again - - * If we *do* re-solve, we'll get an infinite loop. It is cut off by - the fixed bound of 10, but solving the next takes 10*10*...*10 (ie - exponentially many) iterations! - -Conclusion: we should call solveNestedImplications only if we did -some unification in solveSimpleWanteds; because that's the only way -we'll get more Givens (a unification is like adding a Given) to -allow the implication to make progress. --} - -promoteTyVar :: TcTyVar -> TcM (Bool, TcTyVar) --- When we float a constraint out of an implication we must restore --- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType --- Return True <=> we did some promotion --- Also returns either the original tyvar (no promotion) or the new one --- See Note [Promoting unification variables] -promoteTyVar tv - = do { tclvl <- TcM.getTcLevel - ; if (isFloatedTouchableMetaTyVar tclvl tv) - then do { cloned_tv <- TcM.cloneMetaTyVar tv - ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl - ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv) - ; return (True, rhs_tv) } - else return (False, tv) } - --- Returns whether or not *any* tyvar is defaulted -promoteTyVarSet :: TcTyVarSet -> TcM (Bool, TcTyVarSet) -promoteTyVarSet tvs - = do { (bools, tyvars) <- mapAndUnzipM promoteTyVar (nonDetEltsUniqSet tvs) - -- non-determinism is OK because order of promotion doesn't matter - - ; return (or bools, mkVarSet tyvars) } - -promoteTyVarTcS :: TcTyVar -> TcS () --- When we float a constraint out of an implication we must restore --- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType --- See Note [Promoting unification variables] --- We don't just call promoteTyVar because we want to use unifyTyVar, --- not writeMetaTyVar -promoteTyVarTcS tv - = do { tclvl <- TcS.getTcLevel - ; when (isFloatedTouchableMetaTyVar tclvl tv) $ - do { cloned_tv <- TcS.cloneMetaTyVar tv - ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl - ; unifyTyVar tv (mkTyVarTy rhs_tv) } } - --- | Like 'defaultTyVar', but in the TcS monad. -defaultTyVarTcS :: TcTyVar -> TcS Bool -defaultTyVarTcS the_tv - | isRuntimeRepVar the_tv - , not (isTyVarTyVar the_tv) - -- TyVarTvs should only be unified with a tyvar - -- never with a type; c.f. TcMType.defaultTyVar - -- and Note [Inferring kinds for type declarations] in TcTyClsDecls - = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) - ; unifyTyVar the_tv liftedRepTy - ; return True } - | otherwise - = return False -- the common case - -approximateWC :: Bool -> WantedConstraints -> Cts --- Postcondition: Wanted or Derived Cts --- See Note [ApproximateWC] -approximateWC float_past_equalities wc - = float_wc emptyVarSet wc - where - float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts - float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) - = filterBag (is_floatable trapping_tvs) simples `unionBags` - do_bag (float_implic trapping_tvs) implics - where - - float_implic :: TcTyCoVarSet -> Implication -> Cts - float_implic trapping_tvs imp - | float_past_equalities || ic_no_eqs imp - = float_wc new_trapping_tvs (ic_wanted imp) - | otherwise -- Take care with equalities - = emptyCts -- See (1) under Note [ApproximateWC] - where - new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp - - do_bag :: (a -> Bag c) -> Bag a -> Bag c - do_bag f = foldr (unionBags.f) emptyBag - - is_floatable skol_tvs ct - | isGivenCt ct = False - | isHoleCt ct = False - | insolubleEqCt ct = False - | otherwise = tyCoVarsOfCt ct `disjointVarSet` skol_tvs - -{- Note [ApproximateWC] -~~~~~~~~~~~~~~~~~~~~~~~ -approximateWC takes a constraint, typically arising from the RHS of a -let-binding whose type we are *inferring*, and extracts from it some -*simple* constraints that we might plausibly abstract over. Of course -the top-level simple constraints are plausible, but we also float constraints -out from inside, if they are not captured by skolems. - -The same function is used when doing type-class defaulting (see the call -to applyDefaultingRules) to extract constraints that that might be defaulted. - -There is one caveat: - -1. When inferring most-general types (in simplifyInfer), we do *not* - float anything out if the implication binds equality constraints, - because that defeats the OutsideIn story. Consider - data T a where - TInt :: T Int - MkT :: T a - - f TInt = 3::Int - - We get the implication (a ~ Int => res ~ Int), where so far we've decided - f :: T a -> res - We don't want to float (res~Int) out because then we'll infer - f :: T a -> Int - which is only on of the possible types. (GHC 7.6 accidentally *did* - float out of such implications, which meant it would happily infer - non-principal types.) - - HOWEVER (#12797) in findDefaultableGroups we are not worried about - the most-general type; and we /do/ want to float out of equalities. - Hence the boolean flag to approximateWC. - ------- Historical note ----------- -There used to be a second caveat, driven by #8155 - - 2. We do not float out an inner constraint that shares a type variable - (transitively) with one that is trapped by a skolem. Eg - forall a. F a ~ beta, Integral beta - We don't want to float out (Integral beta). Doing so would be bad - when defaulting, because then we'll default beta:=Integer, and that - makes the error message much worse; we'd get - Can't solve F a ~ Integer - rather than - Can't solve Integral (F a) - - Moreover, floating out these "contaminated" constraints doesn't help - when generalising either. If we generalise over (Integral b), we still - can't solve the retained implication (forall a. F a ~ b). Indeed, - arguably that too would be a harder error to understand. - -But this transitive closure stuff gives rise to a complex rule for -when defaulting actually happens, and one that was never documented. -Moreover (#12923), the more complex rule is sometimes NOT what -you want. So I simply removed the extra code to implement the -contamination stuff. There was zero effect on the testsuite (not even -#8155). ------- End of historical note ----------- - - -Note [DefaultTyVar] -~~~~~~~~~~~~~~~~~~~ -defaultTyVar is used on any un-instantiated meta type variables to -default any RuntimeRep variables to LiftedRep. This is important -to ensure that instance declarations match. For example consider - - instance Show (a->b) - foo x = show (\_ -> True) - -Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r), -and that won't match the tcTypeKind (*) in the instance decl. See tests -tc217 and tc175. - -We look only at touchable type variables. No further constraints -are going to affect these type variables, so it's time to do it by -hand. However we aren't ready to default them fully to () or -whatever, because the type-class defaulting rules have yet to run. - -An alternate implementation would be to emit a derived constraint setting -the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. - -Note [Promote _and_ default when inferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are inferring a type, we simplify the constraint, and then use -approximateWC to produce a list of candidate constraints. Then we MUST - - a) Promote any meta-tyvars that have been floated out by - approximateWC, to restore invariant (WantedInv) described in - Note [TcLevel and untouchable type variables] in TcType. - - b) Default the kind of any meta-tyvars that are not mentioned in - in the environment. - -To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we -have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it -should! If we don't solve the constraint, we'll stupidly quantify over -(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over -(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332. -#7641 is a simpler example. - -Note [Promoting unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we float an equality out of an implication we must "promote" free -unification variables of the equality, in order to maintain Invariant -(WantedInv) from Note [TcLevel and untouchable type variables] in -TcType. for the leftover implication. - -This is absolutely necessary. Consider the following example. We start -with two implications and a class with a functional dependency. - - class C x y | x -> y - instance C [a] [a] - - (I1) [untch=beta]forall b. 0 => F Int ~ [beta] - (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] - -We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. -They may react to yield that (beta := [alpha]) which can then be pushed inwards -the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that -(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable -beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: - - class C x y | x -> y where - op :: x -> y -> () - - instance C [a] [a] - - type family F a :: * - - h :: F Int -> () - h = undefined - - data TEx where - TEx :: a -> TEx - - f (x::beta) = - let g1 :: forall b. b -> () - g1 _ = h [x] - g2 z = case z of TEx y -> (h [[undefined]], op x [y]) - in (g1 '3', g2 undefined) - - - -********************************************************************************* -* * -* Floating equalities * -* * -********************************************************************************* - -Note [Float Equalities out of Implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For ordinary pattern matches (including existentials) we float -equalities out of implications, for instance: - data T where - MkT :: Eq a => a -> T - f x y = case x of MkT _ -> (y::Int) -We get the implication constraint (x::T) (y::alpha): - forall a. [untouchable=alpha] Eq a => alpha ~ Int -We want to float out the equality into a scope where alpha is no -longer untouchable, to solve the implication! - -But we cannot float equalities out of implications whose givens may -yield or contain equalities: - - data T a where - T1 :: T Int - T2 :: T Bool - T3 :: T a - - h :: T a -> a -> Int - - f x y = case x of - T1 -> y::Int - T2 -> y::Bool - T3 -> h x y - -We generate constraint, for (x::T alpha) and (y :: beta): - [untouchables = beta] (alpha ~ Int => beta ~ Int) -- From 1st branch - [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch - (alpha ~ beta) -- From 3rd branch - -If we float the equality (beta ~ Int) outside of the first implication and -the equality (beta ~ Bool) out of the second we get an insoluble constraint. -But if we just leave them inside the implications, we unify alpha := beta and -solve everything. - -Principle: - We do not want to float equalities out which may - need the given *evidence* to become soluble. - -Consequence: classes with functional dependencies don't matter (since there is -no evidence for a fundep equality), but equality superclasses do matter (since -they carry evidence). --} - -floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool - -> WantedConstraints - -> TcS (Cts, WantedConstraints) --- Main idea: see Note [Float Equalities out of Implications] --- --- Precondition: the wc_simple of the incoming WantedConstraints are --- fully zonked, so that we can see their free variables --- --- Postcondition: The returned floated constraints (Cts) are only --- Wanted or Derived --- --- Also performs some unifications (via promoteTyVar), adding to --- monadically-carried ty_binds. These will be used when processing --- floated_eqs later --- --- Subtleties: Note [Float equalities from under a skolem binding] --- Note [Skolem escape] --- Note [What prevents a constraint from floating] -floatEqualities skols given_ids ev_binds_var no_given_eqs - wanteds@(WC { wc_simple = simples }) - | not no_given_eqs -- There are some given equalities, so don't float - = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] - - | otherwise - = do { -- First zonk: the inert set (from whence they came) is fully - -- zonked, but unflattening may have filled in unification - -- variables, and we /must/ see them. Otherwise we may float - -- constraints that mention the skolems! - simples <- TcS.zonkSimples simples - ; binds <- TcS.getTcEvBindsMap ev_binds_var - - -- Now we can pick the ones to float - -- The constraints are un-flattened and de-canonicalised - ; let (candidate_eqs, no_float_cts) = partitionBag is_float_eq_candidate simples - - seed_skols = mkVarSet skols `unionVarSet` - mkVarSet given_ids `unionVarSet` - foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet` - foldEvBindMap add_one_bind emptyVarSet binds - -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3) - -- Include the EvIds of any non-floating constraints - - extended_skols = transCloVarSet (add_captured_ev_ids candidate_eqs) seed_skols - -- extended_skols contains the EvIds of all the trapped constraints - -- See Note [What prevents a constraint from floating] (3) - - (flt_eqs, no_flt_eqs) = partitionBag (is_floatable extended_skols) - candidate_eqs - - remaining_simples = no_float_cts `andCts` no_flt_eqs - - -- Promote any unification variables mentioned in the floated equalities - -- See Note [Promoting unification variables] - ; mapM_ promoteTyVarTcS (tyCoVarsOfCtsList flt_eqs) - - ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols - , text "Extended skols =" <+> ppr extended_skols - , text "Simples =" <+> ppr simples - , text "Candidate eqs =" <+> ppr candidate_eqs - , text "Floated eqs =" <+> ppr flt_eqs]) - ; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) } - - where - add_one_bind :: EvBind -> VarSet -> VarSet - add_one_bind bind acc = extendVarSet acc (evBindVar bind) - - add_non_flt_ct :: Ct -> VarSet -> VarSet - add_non_flt_ct ct acc | isDerivedCt ct = acc - | otherwise = extendVarSet acc (ctEvId ct) - - is_floatable :: VarSet -> Ct -> Bool - is_floatable skols ct - | isDerivedCt ct = not (tyCoVarsOfCt ct `intersectsVarSet` skols) - | otherwise = not (ctEvId ct `elemVarSet` skols) - - add_captured_ev_ids :: Cts -> VarSet -> VarSet - add_captured_ev_ids cts skols = foldr extra_skol emptyVarSet cts - where - extra_skol ct acc - | isDerivedCt ct = acc - | tyCoVarsOfCt ct `intersectsVarSet` skols = extendVarSet acc (ctEvId ct) - | otherwise = acc - - -- Identify which equalities are candidates for floating - -- Float out alpha ~ ty, or ty ~ alpha which might be unified outside - -- See Note [Which equalities to float] - is_float_eq_candidate ct - | pred <- ctPred ct - , EqPred NomEq ty1 ty2 <- classifyPredType pred - = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of - (Just tv1, _) -> float_tv_eq_candidate tv1 ty2 - (_, Just tv2) -> float_tv_eq_candidate tv2 ty1 - _ -> False - | otherwise = False - - float_tv_eq_candidate tv1 ty2 -- See Note [Which equalities to float] - = isMetaTyVar tv1 - && (not (isTyVarTyVar tv1) || isTyVarTy ty2) - - -{- Note [Float equalities from under a skolem binding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Which of the simple equalities can we float out? Obviously, only -ones that don't mention the skolem-bound variables. But that is -over-eager. Consider - [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int -The second constraint doesn't mention 'a'. But if we float it, -we'll promote gamma[2] to gamma'[1]. Now suppose that we learn that -beta := Bool, and F a Bool = a, and G Bool _ = Int. Then we'll -we left with the constraint - [2] forall a. a ~ gamma'[1] -which is insoluble because gamma became untouchable. - -Solution: float only constraints that stand a jolly good chance of -being soluble simply by being floated, namely ones of form - a ~ ty -where 'a' is a currently-untouchable unification variable, but may -become touchable by being floated (perhaps by more than one level). - -We had a very complicated rule previously, but this is nice and -simple. (To see the notes, look at this Note in a version of -TcSimplify prior to Oct 2014). - -Note [Which equalities to float] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Which equalities should we float? We want to float ones where there -is a decent chance that floating outwards will allow unification to -happen. In particular, float out equalities that are: - -* Of form (alpha ~# ty) or (ty ~# alpha), where - * alpha is a meta-tyvar. - * And 'alpha' is not a TyVarTv with 'ty' being a non-tyvar. In that - case, floating out won't help either, and it may affect grouping - of error messages. - -* Nominal. No point in floating (alpha ~R# ty), because we do not - unify representational equalities even if alpha is touchable. - See Note [Do not unify representational equalities] in TcInteract. - -Note [Skolem escape] -~~~~~~~~~~~~~~~~~~~~ -You might worry about skolem escape with all this floating. -For example, consider - [2] forall a. (a ~ F beta[2] delta, - Maybe beta[2] ~ gamma[1]) - -The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and -solve with gamma := beta. But what if later delta:=Int, and - F b Int = b. -Then we'd get a ~ beta[2], and solve to get beta:=a, and now the -skolem has escaped! - -But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2] -to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be. - -Note [What prevents a constraint from floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What /prevents/ a constraint from floating? If it mentions one of the -"bound variables of the implication". What are they? - -The "bound variables of the implication" are - - 1. The skolem type variables `ic_skols` - - 2. The "given" evidence variables `ic_given`. Example: - forall a. (co :: t1 ~# t2) => [W] co2 : (a ~# b |> co) - Here 'co' is bound - - 3. The binders of all evidence bindings in `ic_binds`. Example - forall a. (d :: t1 ~ t2) - EvBinds { (co :: t1 ~# t2) = superclass-sel d } - => [W] co2 : (a ~# b |> co) - Here `co` is gotten by superclass selection from `d`, and the - wanted constraint co2 must not float. - - 4. And the evidence variable of any equality constraint (incl - Wanted ones) whose type mentions a bound variable. Example: - forall k. [W] co1 :: t1 ~# t2 |> co2 - [W] co2 :: k ~# * - Here, since `k` is bound, so is `co2` and hence so is `co1`. - -Here (1,2,3) are handled by the "seed_skols" calculation, and -(4) is done by the transCloVarSet call. - -The possible dependence on givens, and evidence bindings, is more -subtle than we'd realised at first. See #14584. - -How can (4) arise? Suppose we have (k :: *), (a :: k), and ([G} k ~ *). -Then form an equality like (a ~ Int) we might end up with - [W] co1 :: k ~ * - [W] co2 :: (a |> co1) ~ Int - - -********************************************************************************* -* * -* Defaulting and disambiguation * -* * -********************************************************************************* --} - -applyDefaultingRules :: WantedConstraints -> TcS Bool --- True <=> I did some defaulting, by unifying a meta-tyvar --- Input WantedConstraints are not necessarily zonked - -applyDefaultingRules wanteds - | isEmptyWC wanteds - = return False - | otherwise - = do { info@(default_tys, _) <- getDefaultInfo - ; wanteds <- TcS.zonkWC wanteds - - ; let groups = findDefaultableGroups info wanteds - - ; traceTcS "applyDefaultingRules {" $ - vcat [ text "wanteds =" <+> ppr wanteds - , text "groups =" <+> ppr groups - , text "info =" <+> ppr info ] - - ; something_happeneds <- mapM (disambigGroup default_tys) groups - - ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) - - ; return (or something_happeneds) } - -findDefaultableGroups - :: ( [Type] - , (Bool,Bool) ) -- (Overloaded strings, extended default rules) - -> WantedConstraints -- Unsolved (wanted or derived) - -> [(TyVar, [Ct])] -findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds - | null default_tys - = [] - | otherwise - = [ (tv, map fstOf3 group) - | group'@((_,_,tv) :| _) <- unary_groups - , let group = toList group' - , defaultable_tyvar tv - , defaultable_classes (map sndOf3 group) ] - where - simples = approximateWC True wanteds - (unaries, non_unaries) = partitionWith find_unary (bagToList simples) - unary_groups = equivClasses cmp_tv unaries - - unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints - unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints - non_unaries :: [Ct] -- and *other* constraints - - -- Finds unary type-class constraints - -- But take account of polykinded classes like Typeable, - -- which may look like (Typeable * (a:*)) (#8931) - find_unary :: Ct -> Either (Ct, Class, TyVar) Ct - find_unary cc - | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) - , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys - -- Ignore invisible arguments for this purpose - , Just tv <- tcGetTyVar_maybe ty - , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and - -- we definitely don't want to try to assign to those! - = Left (cc, cls, tv) - find_unary cc = Right cc -- Non unary or non dictionary - - bad_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries - bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries - - cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 - - defaultable_tyvar :: TcTyVar -> Bool - defaultable_tyvar tv - = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] - b2 = not (tv `elemVarSet` bad_tvs) - in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults] - - defaultable_classes :: [Class] -> Bool - defaultable_classes clss - | extended_defaults = any (isInteractiveClass ovl_strings) clss - | otherwise = all is_std_class clss && (any (isNumClass ovl_strings) clss) - - -- is_std_class adds IsString to the standard numeric classes, - -- when -foverloaded-strings is enabled - is_std_class cls = isStandardClass cls || - (ovl_strings && (cls `hasKey` isStringClassKey)) - ------------------------------- -disambigGroup :: [Type] -- The default types - -> (TcTyVar, [Ct]) -- All classes of the form (C a) - -- sharing same type variable - -> TcS Bool -- True <=> something happened, reflected in ty_binds - -disambigGroup [] _ - = return False -disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) - = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ]) - ; fake_ev_binds_var <- TcS.newTcEvBinds - ; tclvl <- TcS.getTcLevel - ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group - - ; if success then - -- Success: record the type variable binding, and return - do { unifyTyVar the_tv default_ty - ; wrapWarnTcS $ warnDefaulting wanteds default_ty - ; traceTcS "disambigGroup succeeded }" (ppr default_ty) - ; return True } - else - -- Failure: try with the next type - do { traceTcS "disambigGroup failed, will try other default types }" - (ppr default_ty) - ; disambigGroup default_tys group } } - where - try_group - | Just subst <- mb_subst - = do { lcl_env <- TcS.getLclEnv - ; tc_lvl <- TcS.getTcLevel - ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env - ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred) - wanteds - ; fmap isEmptyWC $ - solveSimpleWanteds $ listToBag $ - map mkNonCanonical wanted_evs } - - | otherwise - = return False - - the_ty = mkTyVarTy the_tv - mb_subst = tcMatchTyKi the_ty default_ty - -- Make sure the kinds match too; hence this call to tcMatchTyKi - -- E.g. suppose the only constraint was (Typeable k (a::k)) - -- With the addition of polykinded defaulting we also want to reject - -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here. - --- In interactive mode, or with -XExtendedDefaultRules, --- we default Show a to Show () to avoid graututious errors on "show []" -isInteractiveClass :: Bool -- -XOverloadedStrings? - -> Class -> Bool -isInteractiveClass ovl_strings cls - = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys) - - -- isNumClass adds IsString to the standard numeric classes, - -- when -foverloaded-strings is enabled -isNumClass :: Bool -- -XOverloadedStrings? - -> Class -> Bool -isNumClass ovl_strings cls - = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) - - -{- -Note [Avoiding spurious errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When doing the unification for defaulting, we check for skolem -type variables, and simply don't default them. For example: - f = (*) -- Monomorphic - g :: Num a => a -> a - g x = f x x -Here, we get a complaint when checking the type signature for g, -that g isn't polymorphic enough; but then we get another one when -dealing with the (Num a) context arising from f's definition; -we try to unify a with Int (to default it), but find that it's -already been unified with the rigid variable from g's type sig. - -Note [Multi-parameter defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -XExtendedDefaultRules, we default only based on single-variable -constraints, but do not exclude from defaulting any type variables which also -appear in multi-variable constraints. This means that the following will -default properly: - - default (Integer, Double) - - class A b (c :: Symbol) where - a :: b -> Proxy c - - instance A Integer c where a _ = Proxy - - main = print (a 5 :: Proxy "5") - -Note that if we change the above instance ("instance A Integer") to -"instance A Double", we get an error: - - No instance for (A Integer "5") - -This is because the first defaulted type (Integer) has successfully satisfied -its single-parameter constraints (in this case Num). --} diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs deleted file mode 100644 index df32401bc7..0000000000 --- a/compiler/typecheck/TcSplice.hs +++ /dev/null @@ -1,2385 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -TcSplice: Template Haskell splices --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcSplice( - tcSpliceExpr, tcTypedBracket, tcUntypedBracket, --- runQuasiQuoteExpr, runQuasiQuotePat, --- runQuasiQuoteDecl, runQuasiQuoteType, - runAnnotation, - - runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, - tcTopSpliceExpr, lookupThName_maybe, - defaultRunMeta, runMeta', runRemoteModFinalizers, - finishTH, runTopSplice - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Types.Annotations -import GHC.Driver.Finder -import GHC.Types.Name -import TcRnMonad -import TcType - -import Outputable -import TcExpr -import GHC.Types.SrcLoc -import THNames -import TcUnify -import TcEnv -import TcOrigin -import GHC.Core.Coercion( etaExpandCoAxBranch ) -import FileCleanup ( newTempName, TempFileLifetime(..) ) - -import Control.Monad - -import GHCi.Message -import GHCi.RemoteTypes -import GHC.Runtime.Interpreter -import GHC.Runtime.Interpreter.Types -import GHC.Driver.Main - -- These imports are the reason that TcSplice - -- is very high up the module hierarchy -import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) -import GHC.Types.Name.Reader -import GHC.Driver.Types -import GHC.ThToHs -import GHC.Rename.Expr -import GHC.Rename.Env -import GHC.Rename.Utils ( HsDocContext(..) ) -import GHC.Rename.Fixity ( lookupFixityRn_help ) -import GHC.Rename.Types -import TcHsSyn -import TcSimplify -import GHC.Core.Type as Type -import GHC.Types.Name.Set -import TcMType -import TcHsType -import GHC.IfaceToCore -import GHC.Core.TyCo.Rep as TyCoRep -import FamInst -import GHC.Core.FamInstEnv -import GHC.Core.InstEnv as InstEnv -import Inst -import GHC.Types.Name.Env -import PrelNames -import TysWiredIn -import GHC.Types.Name.Occurrence as OccName -import GHC.Driver.Hooks -import GHC.Types.Var -import GHC.Types.Module -import GHC.Iface.Load -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.Coercion.Axiom -import GHC.Core.PatSyn -import GHC.Core.ConLike -import GHC.Core.DataCon as DataCon -import TcEvidence -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.HsToCore.Expr -import GHC.HsToCore.Monad -import GHC.Serialized -import ErrUtils -import Util -import GHC.Types.Unique -import GHC.Types.Var.Set -import Data.List ( find ) -import Data.Maybe -import FastString -import GHC.Types.Basic as BasicTypes hiding( SuccessFlag(..) ) -import Maybes( MaybeErr(..) ) -import GHC.Driver.Session -import Panic -import GHC.Utils.Lexeme -import qualified EnumSet -import GHC.Driver.Plugins -import Bag - -import qualified Language.Haskell.TH as TH --- THSyntax gives access to internal functions and data types -import qualified Language.Haskell.TH.Syntax as TH - -#if defined(HAVE_INTERNAL_INTERPRETER) --- Because GHC.Desugar might not be in the base library of the bootstrapping compiler -import GHC.Desugar ( AnnotationWrapper(..) ) -import Unsafe.Coerce ( unsafeCoerce ) -#endif - -import Control.Exception -import Data.Binary -import Data.Binary.Get -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB -import Data.Dynamic ( fromDynamic, toDyn ) -import qualified Data.Map as Map -import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) -import Data.Data (Data) -import Data.Proxy ( Proxy (..) ) - -{- -************************************************************************ -* * -\subsection{Main interface + stubs for the non-GHCI case -* * -************************************************************************ --} - -tcTypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType - -> TcM (HsExpr GhcTcId) -tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) - -- None of these functions add constraints to the LIE - --- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) --- runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName) --- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName) --- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] - -runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation -{- -************************************************************************ -* * -\subsection{Quoting an expression} -* * -************************************************************************ --} - --- See Note [How brackets and nested splices are handled] --- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) -tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty - = addErrCtxt (quotationCtxtDoc brack) $ - do { cur_stage <- getStage - ; ps_ref <- newMutVar [] - ; lie_var <- getConstraintVar -- Any constraints arising from nested splices - -- should get thrown into the constraint set - -- from outside the bracket - - -- Make a new type variable for the type of the overall quote - ; m_var <- mkTyVarTy <$> mkMetaTyVar - -- Make sure the type variable satisfies Quote - ; ev_var <- emitQuoteWanted m_var - -- Bundle them together so they can be used in GHC.HsToCore.Quote for desugaring - -- brackets. - ; let wrapper = QuoteWrapper ev_var m_var - -- Typecheck expr to make sure it is valid, - -- Throw away the typechecked expression but return its type. - -- We'll typecheck it again when we splice it in somewhere - ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $ - tcInferRhoNC expr - -- NC for no context; tcBracket does that - ; let rep = getRuntimeRep expr_ty - ; meta_ty <- tcTExpTy m_var expr_ty - ; ps' <- readMutVar ps_ref - ; texpco <- tcLookupId unsafeTExpCoerceName - ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") - rn_expr - (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper) - (nlHsTyApp texpco [rep, expr_ty])) - (noLoc (HsTcBracketOut noExtField (Just wrapper) brack ps')))) - meta_ty res_ty } -tcTypedBracket _ other_brack _ - = pprPanic "tcTypedBracket" (ppr other_brack) - --- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId) --- See Note [Typechecking Overloaded Quotes] -tcUntypedBracket rn_expr brack ps res_ty - = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) - - - -- Create the type m Exp for expression bracket, m Type for a type - -- bracket and so on. The brack_info is a Maybe because the - -- VarBracket ('a) isn't overloaded, but also shouldn't contain any - -- splices. - ; (brack_info, expected_type) <- brackTy brack - - -- Match the expected type with the type of all the internal - -- splices. They might have further constrained types and if they do - -- we want to reflect that in the overall type of the bracket. - ; ps' <- case quoteWrapperTyVarTy <$> brack_info of - Just m_var -> mapM (tcPendingSplice m_var) ps - Nothing -> ASSERT(null ps) return [] - - ; traceTc "tc_bracket done untyped" (ppr expected_type) - - -- Unify the overall type of the bracket with the expected result - -- type - ; tcWrapResultO BracketOrigin rn_expr - (HsTcBracketOut noExtField brack_info brack ps') - expected_type res_ty - - } - --- | A type variable with kind * -> * named "m" -mkMetaTyVar :: TcM TyVar -mkMetaTyVar = - newNamedFlexiTyVar (fsLit "m") (mkVisFunTy liftedTypeKind liftedTypeKind) - - --- | For a type 'm', emit the constraint 'Quote m'. -emitQuoteWanted :: Type -> TcM EvVar -emitQuoteWanted m_var = do - quote_con <- tcLookupTyCon quoteClassName - emitWantedEvVar BracketOrigin $ - mkTyConApp quote_con [m_var] - ---------------- --- | Compute the expected type of a quotation, and also the QuoteWrapper in --- the case where it is an overloaded quotation. All quotation forms are --- overloaded aprt from Variable quotations ('foo) -brackTy :: HsBracket GhcRn -> TcM (Maybe QuoteWrapper, Type) -brackTy b = - let mkTy n = do - -- New polymorphic type variable for the bracket - m_var <- mkTyVarTy <$> mkMetaTyVar - -- Emit a Quote constraint for the bracket - ev_var <- emitQuoteWanted m_var - -- Construct the final expected type of the quote, for example - -- m Exp or m Type - final_ty <- mkAppTy m_var <$> tcMetaTy n - -- Return the evidence variable and metavariable to be used during - -- desugaring. - let wrapper = QuoteWrapper ev_var m_var - return (Just wrapper, final_ty) - in - case b of - (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName - -- Result type is Var (not Quote-monadic) - (ExpBr {}) -> mkTy expTyConName -- Result type is m Exp - (TypBr {}) -> mkTy typeTyConName -- Result type is m Type - (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec] - (PatBr {}) -> mkTy patTyConName -- Result type is m Pat - (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL" - (TExpBr {}) -> panic "tcUntypedBracket: Unexpected TExpBr" - (XBracket nec) -> noExtCon nec - ---------------- --- | Typechecking a pending splice from a untyped bracket -tcPendingSplice :: TcType -- Metavariable for the expected overall type of the - -- quotation. - -> PendingRnSplice - -> TcM PendingTcSplice -tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) - -- See Note [Typechecking Overloaded Quotes] - = do { meta_ty <- tcMetaTy meta_ty_name - -- Expected type of splice, e.g. m Exp - ; let expected_type = mkAppTy m_var meta_ty - ; expr' <- tcPolyExpr expr expected_type - ; return (PendingTcSplice splice_name expr') } - where - meta_ty_name = case flavour of - UntypedExpSplice -> expTyConName - UntypedPatSplice -> patTyConName - UntypedTypeSplice -> typeTyConName - UntypedDeclSplice -> decsTyConName - ---------------- --- Takes a m and tau and returns the type m (TExp tau) -tcTExpTy :: TcType -> TcType -> TcM TcType -tcTExpTy m_ty exp_ty - = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty) - ; texp <- tcLookupTyCon tExpTyConName - ; let rep = getRuntimeRep exp_ty - ; return (mkAppTy m_ty (mkTyConApp texp [rep, exp_ty])) } - where - err_msg ty - = vcat [ text "Illegal polytype:" <+> ppr ty - , text "The type of a Typed Template Haskell expression must" <+> - text "not have any quantification." ] - -quotationCtxtDoc :: HsBracket GhcRn -> SDoc -quotationCtxtDoc br_body - = hang (text "In the Template Haskell quotation") - 2 (ppr br_body) - - - -- The whole of the rest of the file is the else-branch (ie stage2 only) - -{- -Note [How top-level splices are handled] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Top-level splices (those not inside a [| .. |] quotation bracket) are handled -very straightforwardly: - - 1. tcTopSpliceExpr: typecheck the body e of the splice $(e) - - 2. runMetaT: desugar, compile, run it, and convert result back to - GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName, - HsExpr RdrName etc) - - 3. treat the result as if that's what you saw in the first place - e.g for HsType, rename and kind-check - for HsExpr, rename and type-check - - (The last step is different for decls, because they can *only* be - top-level: we return the result of step 2.) - -Note [How brackets and nested splices are handled] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Nested splices (those inside a [| .. |] quotation bracket), -are treated quite differently. - -Remember, there are two forms of bracket - typed [|| e ||] - and untyped [| e |] - -The life cycle of a typed bracket: - * Starts as HsBracket - - * When renaming: - * Set the ThStage to (Brack s RnPendingTyped) - * Rename the body - * Result is still a HsBracket - - * When typechecking: - * Set the ThStage to (Brack s (TcPending ps_var lie_var)) - * Typecheck the body, and throw away the elaborated result - * Nested splices (which must be typed) are typechecked, and - the results accumulated in ps_var; their constraints - accumulate in lie_var - * Result is a HsTcBracketOut rn_brack pending_splices - where rn_brack is the incoming renamed bracket - -The life cycle of a un-typed bracket: - * Starts as HsBracket - - * When renaming: - * Set the ThStage to (Brack s (RnPendingUntyped ps_var)) - * Rename the body - * Nested splices (which must be untyped) are renamed, and the - results accumulated in ps_var - * Result is still (HsRnBracketOut rn_body pending_splices) - - * When typechecking a HsRnBracketOut - * Typecheck the pending_splices individually - * Ignore the body of the bracket; just check that the context - expects a bracket of that type (e.g. a [p| pat |] bracket should - be in a context needing a (Q Pat) - * Result is a HsTcBracketOut rn_brack pending_splices - where rn_brack is the incoming renamed bracket - - -In both cases, desugaring happens like this: - * HsTcBracketOut is desugared by GHC.HsToCore.Quote.dsBracket. It - - a) Extends the ds_meta environment with the PendingSplices - attached to the bracket - - b) Converts the quoted (HsExpr Name) to a CoreExpr that, when - run, will produce a suitable TH expression/type/decl. This - is why we leave the *renamed* expression attached to the bracket: - the quoted expression should not be decorated with all the goop - added by the type checker - - * Each splice carries a unique Name, called a "splice point", thus - ${n}(e). The name is initialised to an (Unqual "splice") when the - splice is created; the renamer gives it a unique. - - * When GHC.HsToCore.Quote (used to desugar the body of the bracket) comes across - a splice, it looks up the splice's Name, n, in the ds_meta envt, - to find an (HsExpr Id) that should be substituted for the splice; - it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice). - -Example: - Source: f = [| Just $(g 3) |] - The [| |] part is a HsBracket - - Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3} - The [| |] part is a HsBracketOut, containing *renamed* - (not typechecked) expression - The "s7" is the "splice point"; the (g Int 3) part - is a typechecked expression - - Desugared: f = do { s7 <- g Int 3 - ; return (ConE "Data.Maybe.Just" s7) } - - -Note [Template Haskell state diagram] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here are the ThStages, s, their corresponding level numbers -(the result of (thLevel s)), and their state transitions. -The top level of the program is stage Comp: - - Start here - | - V - ----------- $ ------------ $ - | Comp | ---------> | Splice | -----| - | 1 | | 0 | <----| - ----------- ------------ - ^ | ^ | - $ | | [||] $ | | [||] - | v | v - -------------- ---------------- - | Brack Comp | | Brack Splice | - | 2 | | 1 | - -------------- ---------------- - -* Normal top-level declarations start in state Comp - (which has level 1). - Annotations start in state Splice, since they are - treated very like a splice (only without a '$') - -* Code compiled in state Splice (and only such code) - will be *run at compile time*, with the result replacing - the splice - -* The original paper used level -1 instead of 0, etc. - -* The original paper did not allow a splice within a - splice, but there is no reason not to. This is the - $ transition in the top right. - -Note [Template Haskell levels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Imported things are impLevel (= 0) - -* However things at level 0 are not *necessarily* imported. - eg $( \b -> ... ) here b is bound at level 0 - -* In GHCi, variables bound by a previous command are treated - as impLevel, because we have bytecode for them. - -* Variables are bound at the "current level" - -* The current level starts off at outerLevel (= 1) - -* The level is decremented by splicing $(..) - incremented by brackets [| |] - incremented by name-quoting 'f - -* When a variable is used, checkWellStaged compares - bind: binding level, and - use: current level at usage site - - Generally - bind > use Always error (bound later than used) - [| \x -> $(f x) |] - - bind = use Always OK (bound same stage as used) - [| \x -> $(f [| x |]) |] - - bind < use Inside brackets, it depends - Inside splice, OK - Inside neither, OK - - For (bind < use) inside brackets, there are three cases: - - Imported things OK f = [| map |] - - Top-level things OK g = [| f |] - - Non-top-level Only if there is a liftable instance - h = \(x:Int) -> [| x |] - - To track top-level-ness we use the ThBindEnv in TcLclEnv - - For example: - f = ... - g1 = $(map ...) is OK - g2 = $(f ...) is not OK; because we haven't compiled f yet - -Note [Typechecking Overloaded Quotes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The main function for typechecking untyped quotations is `tcUntypedBracket`. - -Consider an expression quote, `[| e |]`, its type is `forall m . Quote m => m Exp`. -When we typecheck it we therefore create a template of a metavariable `m` applied to `Exp` and -emit a constraint `Quote m`. All this is done in the `brackTy` function. -`brackTy` also selects the correct contents type for the quotation (Exp, Type, Decs etc). - -The meta variable and the constraint evidence variable are -returned together in a `QuoteWrapper` and then passed along to two further places -during compilation: - -1. Typechecking nested splices (immediately in tcPendingSplice) -2. Desugaring quotations (see GHC.HsToCore.Quote) - -`tcPendingSplice` takes the `m` type variable as an argument and checks -each nested splice against this variable `m`. During this -process the variable `m` can either be fixed to a specific value or further constrained by the -nested splices. - -Once we have checked all the nested splices, the quote type is checked against -the expected return type. - -The process is very simple and like typechecking a list where the quotation is -like the container and the splices are the elements of the list which must have -a specific type. - -After the typechecking process is completed, the evidence variable for `Quote m` -and the type `m` is stored in a `QuoteWrapper` which is passed through the pipeline -and used when desugaring quotations. - -Typechecking typed quotations is a similar idea but the `QuoteWrapper` is stored -in the `PendingStuff` as the nested splices are gathered up in a different way -to untyped splices. Untyped splices are found in the renamer but typed splices are -not typechecked and extracted until during typechecking. - --} - --- | We only want to produce warnings for TH-splices if the user requests so. --- See Note [Warnings for TH splices]. -getThSpliceOrigin :: TcM Origin -getThSpliceOrigin = do - warn <- goptM Opt_EnableThSpliceWarnings - if warn then return FromSource else return Generated - -{- Note [Warnings for TH splices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only produce warnings for TH splices when the user requests so -(-fenable-th-splice-warnings). There are multiple reasons: - - * It's not clear that the user that compiles a splice is the author of the code - that produces the warning. Think of the situation where she just splices in - code from a third-party library that produces incomplete pattern matches. - In this scenario, the user isn't even able to fix that warning. - * Gathering information for producing the warnings (pattern-match check - warnings in particular) is costly. There's no point in doing so if the user - is not interested in those warnings. - -That's why we store Origin flags in the Haskell AST. The functions from ThToHs -take such a flag and depending on whether TH splice warnings were enabled or -not, we pass FromSource (if the user requests warnings) or Generated -(otherwise). This is implemented in getThSpliceOrigin. - -For correct pattern-match warnings it's crucial that we annotate the Origin -consistently (#17270). In the future we could offer the Origin as part of the -TH AST. That would enable us to give quotes from the current module get -FromSource origin, and/or third library authors to tag certain parts of -generated code as FromSource to enable warnings. That effort is tracked in -#14838. --} - -{- -************************************************************************ -* * -\subsection{Splicing an expression} -* * -************************************************************************ --} - -tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty - = addErrCtxt (spliceCtxtDoc splice) $ - setSrcSpan (getLoc expr) $ do - { stage <- getStage - ; case stage of - Splice {} -> tcTopSplice expr res_ty - Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty - RunSplice _ -> - -- See Note [RunSplice ThLevel] in "TcRnTypes". - pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++ - "running another splice") (ppr splice) - Comp -> tcTopSplice expr res_ty - } -tcSpliceExpr splice _ - = pprPanic "tcSpliceExpr" (ppr splice) - -{- Note [Collecting modFinalizers in typed splices] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local -environment (see Note [Delaying modFinalizers in untyped splices] in -GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the -finalizer list in the global environment and set them to use the current local -environment (with 'addModFinalizersWithLclEnv'). - --} - -tcNestedSplice :: ThStage -> PendingStuff -> Name - -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) - -- See Note [How brackets and nested splices are handled] - -- A splice inside brackets -tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) splice_name expr res_ty - = do { res_ty <- expTypeToType res_ty - ; let rep = getRuntimeRep res_ty - ; meta_exp_ty <- tcTExpTy m_var res_ty - ; expr' <- setStage pop_stage $ - setConstraintVar lie_var $ - tcMonoExpr expr (mkCheckExpType meta_exp_ty) - ; untypeq <- tcLookupId unTypeQName - ; let expr'' = mkHsApp - (mkLHsWrap (applyQuoteWrapper q) - (nlHsTyApp untypeq [rep, res_ty])) expr' - ; ps <- readMutVar ps_var - ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) - - -- The returned expression is ignored; it's in the pending splices - ; return (panic "tcSpliceExpr") } - -tcNestedSplice _ _ splice_name _ _ - = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) - -tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcTopSplice expr res_ty - = do { -- Typecheck the expression, - -- making sure it has type Q (T res_ty) - res_ty <- expTypeToType res_ty - ; q_type <- tcMetaTy qTyConName - -- Top level splices must still be of type Q (TExp a) - ; meta_exp_ty <- tcTExpTy q_type res_ty - ; q_expr <- tcTopSpliceExpr Typed $ - tcMonoExpr expr (mkCheckExpType meta_exp_ty) - ; lcl_env <- getLclEnv - ; let delayed_splice - = DelayedSplice lcl_env expr res_ty q_expr - ; return (HsSpliceE noExtField (XSplice (HsSplicedT delayed_splice))) - - } - - --- This is called in the zonker --- See Note [Running typed splices in the zonker] -runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) -runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr) - = setLclEnv lcl_env $ do { - zonked_ty <- zonkTcType res_ty - ; zonked_q_expr <- zonkTopLExpr q_expr - -- See Note [Collecting modFinalizers in typed splices]. - ; modfinalizers_ref <- newTcRef [] - -- Run the expression - ; expr2 <- setStage (RunSplice modfinalizers_ref) $ - runMetaE zonked_q_expr - ; mod_finalizers <- readTcRef modfinalizers_ref - ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers - -- We use orig_expr here and not q_expr when tracing as a call to - -- unsafeTExpCoerce is added to the original expression by the - -- typechecker when typed quotes are type checked. - ; traceSplice (SpliceInfo { spliceDescription = "expression" - , spliceIsDecl = False - , spliceSource = Just orig_expr - , spliceGenerated = ppr expr2 }) - -- Rename and typecheck the spliced-in expression, - -- making sure it has type res_ty - -- These steps should never fail; this is a *typed* splice - ; (res, wcs) <- - captureConstraints $ - addErrCtxt (spliceResultDoc zonked_q_expr) $ do - { (exp3, _fvs) <- rnLExpr expr2 - ; tcMonoExpr exp3 (mkCheckExpType zonked_ty)} - ; ev <- simplifyTop wcs - ; return $ unLoc (mkHsDictLet (EvBinds ev) res) - } - - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -spliceCtxtDoc :: HsSplice GhcRn -> SDoc -spliceCtxtDoc splice - = hang (text "In the Template Haskell splice") - 2 (pprSplice splice) - -spliceResultDoc :: LHsExpr GhcTc -> SDoc -spliceResultDoc expr - = sep [ text "In the result of the splice:" - , nest 2 (char '$' <> ppr expr) - , text "To see what the splice expanded to, use -ddump-splices"] - -------------------- -tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) --- Note [How top-level splices are handled] --- Type check an expression that is the body of a top-level splice --- (the caller will compile and run it) --- Note that set the level to Splice, regardless of the original level, --- before typechecking the expression. For example: --- f x = $( ...$(g 3) ... ) --- The recursive call to tcPolyExpr will simply expand the --- inner escape before dealing with the outer one - -tcTopSpliceExpr isTypedSplice tc_action - = checkNoErrs $ -- checkNoErrs: must not try to run the thing - -- if the type checker fails! - unsetGOptM Opt_DeferTypeErrors $ - -- Don't defer type errors. Not only are we - -- going to run this code, but we do an unsafe - -- coerce, so we get a seg-fault if, say we - -- splice a type into a place where an expression - -- is expected (#7276) - setStage (Splice isTypedSplice) $ - do { -- Typecheck the expression - (expr', wanted) <- captureConstraints tc_action - ; const_binds <- simplifyTop wanted - - -- Zonk it and tie the knot of dictionary bindings - ; return $ mkHsDictLet (EvBinds const_binds) expr' } - -{- -************************************************************************ -* * - Annotations -* * -************************************************************************ --} - -runAnnotation target expr = do - -- Find the classes we want instances for in order to call toAnnotationWrapper - loc <- getSrcSpanM - data_class <- tcLookupClass dataClassName - to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName - - -- Check the instances we require live in another module (we want to execute it..) - -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr - -- also resolves the LIE constraints to detect e.g. instance ambiguity - zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped ( - do { (expr', expr_ty) <- tcInferRhoNC expr - -- We manually wrap the typechecked expression in a call to toAnnotationWrapper - -- By instantiating the call >here< it gets registered in the - -- LIE consulted by tcTopSpliceExpr - -- and hence ensures the appropriate dictionary is bound by const_binds - ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] - ; let specialised_to_annotation_wrapper_expr - = L loc (mkHsWrap wrapper - (HsVar noExtField (L loc to_annotation_wrapper_id))) - ; return (L loc (HsApp noExtField - specialised_to_annotation_wrapper_expr expr')) - }) - - -- Run the appropriately wrapped expression to get the value of - -- the annotation and its dictionaries. The return value is of - -- type AnnotationWrapper by construction, so this conversion is - -- safe - serialized <- runMetaAW zonked_wrapped_expr' - return Annotation { - ann_target = target, - ann_value = serialized - } - -convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized) -convertAnnotationWrapper fhv = do - interp <- tcGetInterp - case interp of - ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> do - annotation_wrapper <- liftIO $ wormhole InternalInterp fhv - return $ Right $ - case unsafeCoerce annotation_wrapper of - AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> - -- Got the value and dictionaries: build the serialized value and - -- call it a day. We ensure that we seq the entire serialized value - -- in order that any errors in the user-written code for the - -- annotation are exposed at this point. This is also why we are - -- doing all this stuff inside the context of runMeta: it has the - -- facilities to deal with user error in a meta-level expression - seqSerialized serialized `seq` serialized - --- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms -seqSerialized :: Serialized -> () -seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () - -#endif - -{- -************************************************************************ -* * -\subsection{Running an expression} -* * -************************************************************************ --} - -runQuasi :: TH.Q a -> TcM a -runQuasi act = TH.runQ act - -runRemoteModFinalizers :: ThModFinalizers -> TcM () -runRemoteModFinalizers (ThModFinalizers finRefs) = do - let withForeignRefs [] f = f [] - withForeignRefs (x : xs) f = withForeignRef x $ \r -> - withForeignRefs xs $ \rs -> f (r : rs) - interp <- tcGetInterp - case interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> do - qs <- liftIO (withForeignRefs finRefs $ mapM localRef) - runQuasi $ sequence_ qs -#endif - - ExternalInterp conf iserv -> withIServ_ conf iserv $ \i -> do - tcg <- getGblEnv - th_state <- readTcRef (tcg_th_remote_state tcg) - case th_state of - Nothing -> return () -- TH was not started, nothing to do - Just fhv -> do - liftIO $ withForeignRef fhv $ \st -> - withForeignRefs finRefs $ \qrefs -> - writeIServ i (putMessage (RunModFinalizers st qrefs)) - () <- runRemoteTH i [] - readQResult i - -runQResult - :: (a -> String) - -> (Origin -> SrcSpan -> a -> b) - -> (ForeignHValue -> TcM a) - -> SrcSpan - -> ForeignHValue {- TH.Q a -} - -> TcM b -runQResult show_th f runQ expr_span hval - = do { th_result <- runQ hval - ; th_origin <- getThSpliceOrigin - ; traceTc "Got TH result:" (text (show_th th_result)) - ; return (f th_origin expr_span th_result) } - - ------------------ -runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) - -> LHsExpr GhcTc - -> TcM hs_syn -runMeta unwrap e - = do { h <- getHooked runMetaHook defaultRunMeta - ; unwrap h e } - -defaultRunMeta :: MetaHook TcM -defaultRunMeta (MetaE r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp) -defaultRunMeta (MetaP r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat) -defaultRunMeta (MetaT r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType) -defaultRunMeta (MetaD r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec) -defaultRunMeta (MetaAW r) - = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper) - -- We turn off showing the code in meta-level exceptions because doing so exposes - -- the toAnnotationWrapper function that we slap around the user's code - ----------------- -runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper - -> TcM Serialized -runMetaAW = runMeta metaRequestAW - -runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) - -> TcM (LHsExpr GhcPs) -runMetaE = runMeta metaRequestE - -runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) - -> TcM (LPat GhcPs) -runMetaP = runMeta metaRequestP - -runMetaT :: LHsExpr GhcTc -- Of type (Q Type) - -> TcM (LHsType GhcPs) -runMetaT = runMeta metaRequestT - -runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] - -> TcM [LHsDecl GhcPs] -runMetaD = runMeta metaRequestD - ---------------- -runMeta' :: Bool -- Whether code should be printed in the exception message - -> (hs_syn -> SDoc) -- how to print the code - -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x - -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or - -- something like that - -> TcM hs_syn -- Of type t -runMeta' show_code ppr_hs run_and_convert expr - = do { traceTc "About to run" (ppr expr) - ; recordThSpliceUse -- seems to be the best place to do this, - -- we catch all kinds of splices and annotations. - - -- Check that we've had no errors of any sort so far. - -- For example, if we found an error in an earlier defn f, but - -- recovered giving it type f :: forall a.a, it'd be very dodgy - -- to carry ont. Mind you, the staging restrictions mean we won't - -- actually run f, but it still seems wrong. And, more concretely, - -- see #5358 for an example that fell over when trying to - -- reify a function with a "?" kind in it. (These don't occur - -- in type-correct programs. - ; failIfErrsM - - -- run plugins - ; hsc_env <- getTopEnv - ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr - - -- Desugar - ; ds_expr <- initDsTc (dsLExpr expr') - -- Compile and link it; might fail if linking fails - ; src_span <- getSrcSpanM - ; traceTc "About to run (desugared)" (ppr ds_expr) - ; either_hval <- tryM $ liftIO $ - GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr - ; case either_hval of { - Left exn -> fail_with_exn "compile and link" exn ; - Right hval -> do - - { -- Coerce it to Q t, and run it - - -- Running might fail if it throws an exception of any kind (hence tryAllM) - -- including, say, a pattern-match exception in the code we are running - -- - -- We also do the TH -> HS syntax conversion inside the same - -- exception-catching thing so that if there are any lurking - -- exceptions in the data structure returned by hval, we'll - -- encounter them inside the try - -- - -- See Note [Exceptions in TH] - let expr_span = getLoc expr - ; either_tval <- tryAllM $ - setSrcSpan expr_span $ -- Set the span so that qLocation can - -- see where this splice is - do { mb_result <- run_and_convert expr_span hval - ; case mb_result of - Left err -> failWithTc err - Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) - ; return $! result } } - - ; case either_tval of - Right v -> return v - Left se -> case fromException se of - Just IOEnvFailure -> failM -- Error already in Tc monad - _ -> fail_with_exn "run" se -- Exception - }}} - where - -- see Note [Concealed TH exceptions] - fail_with_exn :: Exception e => String -> e -> TcM a - fail_with_exn phase exn = do - exn_msg <- liftIO $ Panic.safeShowException exn - let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", - nest 2 (text exn_msg), - if show_code then text "Code:" <+> ppr expr else empty] - failWithTc msg - -{- -Note [Running typed splices in the zonker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -See #15471 for the full discussion. - -For many years typed splices were run immediately after they were type checked -however, this is too early as it means to zonk some type variables before -they can be unified with type variables in the surrounding context. - -For example, - -``` -module A where - -test_foo :: forall a . Q (TExp (a -> a)) -test_foo = [|| id ||] - -module B where - -import A - -qux = $$(test_foo) -``` - -We would expect `qux` to have inferred type `forall a . a -> a` but if -we run the splices too early the unified variables are zonked to `Any`. The -inferred type is the unusable `Any -> Any`. - -To run the splice, we must compile `test_foo` all the way to byte code. -But at the moment when the type checker is looking at the splice, test_foo -has type `Q (TExp (alpha -> alpha))` and we -certainly can't compile code involving unification variables! - -We could default `alpha` to `Any` but then we infer `qux :: Any -> Any` -which definitely is not what we want. Moreover, if we had - qux = [$$(test_foo), (\x -> x +1::Int)] -then `alpha` would have to be `Int`. - -Conclusion: we must defer taking decisions about `alpha` until the -typechecker is done; and *then* we can run the splice. It's fine to do it -later, because we know it'll produce type-correct code. - -Deferring running the splice until later, in the zonker, means that the -unification variables propagate upwards from the splice into the surrounding -context and are unified correctly. - -This is implemented by storing the arguments we need for running the splice -in a `DelayedSplice`. In the zonker, the arguments are passed to -`TcSplice.runTopSplice` and the expression inserted into the AST as normal. - - - -Note [Exceptions in TH] -~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have something like this - $( f 4 ) -where - f :: Int -> Q [Dec] - f n | n>3 = fail "Too many declarations" - | otherwise = ... - -The 'fail' is a user-generated failure, and should be displayed as a -perfectly ordinary compiler error message, not a panic or anything -like that. Here's how it's processed: - - * 'fail' is the monad fail. The monad instance for Q in TH.Syntax - effectively transforms (fail s) to - qReport True s >> fail - where 'qReport' comes from the Quasi class and fail from its monad - superclass. - - * The TcM monad is an instance of Quasi (see TcSplice), and it implements - (qReport True s) by using addErr to add an error message to the bag of errors. - The 'fail' in TcM raises an IOEnvFailure exception - - * 'qReport' forces the message to ensure any exception hidden in unevaluated - thunk doesn't get into the bag of errors. Otherwise the following splice - will trigger panic (#8987): - $(fail undefined) - See also Note [Concealed TH exceptions] - - * So, when running a splice, we catch all exceptions; then for - - an IOEnvFailure exception, we assume the error is already - in the error-bag (above) - - other errors, we add an error to the bag - and then fail - -Note [Concealed TH exceptions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When displaying the error message contained in an exception originated from TH -code, we need to make sure that the error message itself does not contain an -exception. For example, when executing the following splice: - - $( error ("foo " ++ error "bar") ) - -the message for the outer exception is a thunk which will throw the inner -exception when evaluated. - -For this reason, we display the message of a TH exception using the -'safeShowException' function, which recursively catches any exception thrown -when showing an error message. - - -To call runQ in the Tc monad, we need to make TcM an instance of Quasi: --} - -instance TH.Quasi TcM where - qNewName s = do { u <- newUnique - ; let i = toInteger (getKey u) - ; return (TH.mkNameU s i) } - - -- 'msg' is forced to ensure exceptions don't escape, - -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr (text msg) - qReport False msg = seqList msg $ addWarn NoReason (text msg) - - qLocation = do { m <- getModule - ; l <- getSrcSpanM - ; r <- case l of - UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" - (ppr l) - RealSrcSpan s _ -> return s - ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) - , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = unitIdString (moduleUnitId m) - , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) - , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } - - qLookupName = lookupName - qReify = reify - qReifyFixity nm = lookupThName nm >>= reifyFixity - qReifyType = reifyTypeOfThing - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness nm = do { nm' <- lookupThName nm - ; dc <- tcLookupDataCon nm' - ; let bangs = dataConImplBangs dc - ; return (map reifyDecidedStrictness bangs) } - - -- For qRecover, discard error messages if - -- the recovery action is chosen. Otherwise - -- we'll only fail higher up. - qRecover recover main = tryTcDiscardingErrs recover main - - qAddDependentFile fp = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fp:dep_files) - - qAddTempFile suffix = do - dflags <- getDynFlags - liftIO $ newTempName dflags TFL_GhcSession suffix - - qAddTopDecls thds = do - l <- getSrcSpanM - th_origin <- getThSpliceOrigin - let either_hval = convertToHsDecls th_origin l thds - ds <- case either_hval of - Left exn -> failWithTc $ - hang (text "Error in a declaration passed to addTopDecls:") - 2 exn - Right ds -> return ds - mapM_ (checkTopDecl . unLoc) ds - th_topdecls_var <- fmap tcg_th_topdecls getGblEnv - updTcRef th_topdecls_var (\topds -> ds ++ topds) - where - checkTopDecl :: HsDecl GhcPs -> TcM () - checkTopDecl (ValD _ binds) - = mapM_ bindName (collectHsBindBinders binds) - checkTopDecl (SigD _ _) - = return () - checkTopDecl (AnnD _ _) - = return () - checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) - = bindName name - checkTopDecl _ - = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" - - bindName :: RdrName -> TcM () - bindName (Exact n) - = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) - } - - bindName name = - addErr $ - hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) - 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") - - qAddForeignFilePath lang fp = do - var <- fmap tcg_th_foreign_files getGblEnv - updTcRef var ((lang, fp) :) - - qAddModFinalizer fin = do - r <- liftIO $ mkRemoteRef fin - fref <- liftIO $ mkForeignRef r (freeRemoteRef r) - addModFinalizerRef fref - - qAddCorePlugin plugin = do - hsc_env <- getTopEnv - r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin) - let err = hang - (text "addCorePlugin: invalid plugin module " - <+> text (show plugin) - ) - 2 - (text "Plugins in the current package can't be specified.") - case r of - Found {} -> addErr err - FoundMultiple {} -> addErr err - _ -> return () - th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv - updTcRef th_coreplugins_var (plugin:) - - qGetQ :: forall a. Typeable a => TcM (Maybe a) - qGetQ = do - th_state_var <- fmap tcg_th_state getGblEnv - th_state <- readTcRef th_state_var - -- See #10596 for why we use a scoped type variable here. - return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) - - qPutQ x = do - th_state_var <- fmap tcg_th_state getGblEnv - updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) - - qIsExtEnabled = xoptM - - qExtsEnabled = - EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv - --- | Adds a mod finalizer reference to the local environment. -addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () -addModFinalizerRef finRef = do - th_stage <- getStage - case th_stage of - RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :) - -- This case happens only if a splice is executed and the caller does - -- not set the 'ThStage' to 'RunSplice' to collect finalizers. - -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. - _ -> - pprPanic "addModFinalizer was called when no finalizers were collected" - (ppr th_stage) - --- | Releases the external interpreter state. -finishTH :: TcM () -finishTH = do - hsc_env <- getTopEnv - case hsc_interp hsc_env of - Nothing -> pure () -#if defined(HAVE_INTERNAL_INTERPRETER) - Just InternalInterp -> pure () -#endif - Just (ExternalInterp {}) -> do - tcg <- getGblEnv - writeTcRef (tcg_th_remote_state tcg) Nothing - - -runTHExp :: ForeignHValue -> TcM TH.Exp -runTHExp = runTH THExp - -runTHPat :: ForeignHValue -> TcM TH.Pat -runTHPat = runTH THPat - -runTHType :: ForeignHValue -> TcM TH.Type -runTHType = runTH THType - -runTHDec :: ForeignHValue -> TcM [TH.Dec] -runTHDec = runTH THDec - -runTH :: Binary a => THResultType -> ForeignHValue -> TcM a -runTH ty fhv = do - interp <- tcGetInterp - case interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> do - -- Run it in the local TcM - hv <- liftIO $ wormhole InternalInterp fhv - r <- runQuasi (unsafeCoerce hv :: TH.Q a) - return r -#endif - - ExternalInterp conf iserv -> - -- Run it on the server. For an overview of how TH works with - -- Remote GHCi, see Note [Remote Template Haskell] in - -- libraries/ghci/GHCi/TH.hs. - withIServ_ conf iserv $ \i -> do - rstate <- getTHState i - loc <- TH.qLocation - liftIO $ - withForeignRef rstate $ \state_hv -> - withForeignRef fhv $ \q_hv -> - writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc))) - runRemoteTH i [] - bs <- readQResult i - return $! runGet get (LB.fromStrict bs) - - --- | communicate with a remotely-running TH computation until it finishes. --- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. -runRemoteTH - :: IServInstance - -> [Messages] -- saved from nested calls to qRecover - -> TcM () -runRemoteTH iserv recovers = do - THMsg msg <- liftIO $ readIServ iserv getTHMessage - case msg of - RunTHDone -> return () - StartRecover -> do -- Note [TH recover with -fexternal-interpreter] - v <- getErrsVar - msgs <- readTcRef v - writeTcRef v emptyMessages - runRemoteTH iserv (msgs : recovers) - EndRecover caught_error -> do - let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of - [] -> panic "EndRecover" - a : b -> (a,b) - v <- getErrsVar - (warn_msgs,_) <- readTcRef v - -- keep the warnings only if there were no errors - writeTcRef v $ if caught_error - then prev_msgs - else (prev_warns `unionBags` warn_msgs, prev_errs) - runRemoteTH iserv rest - _other -> do - r <- handleTHMessage msg - liftIO $ writeIServ iserv (put r) - runRemoteTH iserv recovers - --- | Read a value of type QResult from the iserv -readQResult :: Binary a => IServInstance -> TcM a -readQResult i = do - qr <- liftIO $ readIServ i get - case qr of - QDone a -> return a - QException str -> liftIO $ throwIO (ErrorCall str) - QFail str -> fail str - -{- Note [TH recover with -fexternal-interpreter] - -Recover is slightly tricky to implement. - -The meaning of "recover a b" is - - Do a - - If it finished with no errors, then keep the warnings it generated - - If it failed, discard any messages it generated, and do b - -Note that "failed" here can mean either - (1) threw an exception (failTc) - (2) generated an error message (addErrTcM) - -The messages are managed by GHC in the TcM monad, whereas the -exception-handling is done in the ghc-iserv process, so we have to -coordinate between the two. - -On the server: - - emit a StartRecover message - - run "a; FailIfErrs" inside a try - - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed - - if "a; FailIfErrs" failed, run "b" - -Back in GHC, when we receive: - - FailIfErrrs - failTc if there are any error messages (= failIfErrsM) - StartRecover - save the current messages and start with an empty set. - EndRecover caught_error - Restore the previous messages, - and merge in the new messages if caught_error is false. --} - --- | Retrieve (or create, if it hasn't been created already), the --- remote TH state. The TH state is a remote reference to an IORef --- QState living on the server, and we have to pass this to each RunTH --- call we make. --- --- The TH state is stored in tcg_th_remote_state in the TcGblEnv. --- -getTHState :: IServInstance -> TcM (ForeignRef (IORef QState)) -getTHState i = do - tcg <- getGblEnv - th_state <- readTcRef (tcg_th_remote_state tcg) - case th_state of - Just rhv -> return rhv - Nothing -> do - hsc_env <- getTopEnv - fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH - writeTcRef (tcg_th_remote_state tcg) (Just fhv) - return fhv - -wrapTHResult :: TcM a -> TcM (THResult a) -wrapTHResult tcm = do - e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic - case e of - Left e -> return (THException (show e)) - Right a -> return (THComplete a) - -handleTHMessage :: THMessage a -> TcM a -handleTHMessage msg = case msg of - NewName a -> wrapTHResult $ TH.qNewName a - Report b str -> wrapTHResult $ TH.qReport b str - LookupName b str -> wrapTHResult $ TH.qLookupName b str - Reify n -> wrapTHResult $ TH.qReify n - ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n - ReifyType n -> wrapTHResult $ TH.qReifyType n - ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts - ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n - ReifyAnnotations lookup tyrep -> - wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) - ReifyModule m -> wrapTHResult $ TH.qReifyModule m - ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm - AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f - AddTempFile s -> wrapTHResult $ TH.qAddTempFile s - AddModFinalizer r -> do - hsc_env <- getTopEnv - wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef - AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str - AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs - AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str - IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext - ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled - FailIfErrs -> wrapTHResult failIfErrsM - _ -> panic ("handleTHMessage: unexpected message " ++ show msg) - -getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]] -getAnnotationsByTypeRep th_name tyrep - = do { name <- lookupThAnnLookup th_name - ; topEnv <- getTopEnv - ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing - ; tcg <- getGblEnv - ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep - ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep - ; return (selectedEpsHptAnns ++ selectedTcgAnns) } - -{- -************************************************************************ -* * - Instance Testing -* * -************************************************************************ --} - -reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] -reifyInstances th_nm th_tys - = addErrCtxt (text "In the argument of reifyInstances:" - <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ - do { loc <- getSrcSpanM - ; th_origin <- getThSpliceOrigin - ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys) - -- #9262 says to bring vars into scope, like in HsForAllTy case - -- of rnHsTyKi - ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty - -- Rename to HsType Name - ; ((tv_names, rn_ty), _fvs) - <- checkNoErrs $ -- If there are out-of-scope Names here, then we - -- must error before proceeding to typecheck the - -- renamed type, as that will result in GHC - -- internal errors (#13837). - bindLRdrNames tv_rdrs $ \ tv_names -> - do { (rn_ty, fvs) <- rnLHsType doc rdr_ty - ; return ((tv_names, rn_ty), fvs) } - ; (_tvs, ty) - <- pushTcLevelM_ $ - solveEqualities $ -- Avoid error cascade if there are unsolved - bindImplicitTKBndrs_Skol tv_names $ - fst <$> tcLHsType rn_ty - ; ty <- zonkTcTypeToType ty - -- Substitute out the meta type variables - -- In particular, the type might have kind - -- variables inside it (#7477) - - ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty)) - ; case splitTyConApp_maybe ty of -- This expands any type synonyms - Just (tc, tys) -- See #7910 - | Just cls <- tyConClass_maybe tc - -> do { inst_envs <- tcGetInstEnvs - ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys - ; traceTc "reifyInstances1" (ppr matches) - ; reifyClassInstances cls (map fst matches ++ unifies) } - | isOpenFamilyTyCon tc - -> do { inst_envs <- tcGetFamInstEnvs - ; let matches = lookupFamInstEnv inst_envs tc tys - ; traceTc "reifyInstances2" (ppr matches) - ; reifyFamilyInstances tc (map fim_instance matches) } - _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty)) - 2 (text "is not a class constraint or type family application")) } - where - doc = ClassInstanceCtx - bale_out msg = failWithTc msg - - cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) - cvt origin loc th_ty = case convertToHsType origin loc th_ty of - Left msg -> failWithTc msg - Right ty -> return ty - -{- -************************************************************************ -* * - Reification -* * -************************************************************************ --} - -lookupName :: Bool -- True <=> type namespace - -- False <=> value namespace - -> String -> TcM (Maybe TH.Name) -lookupName is_type_name s - = do { lcl_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv lcl_env rdr_name of - Just n -> return (Just (reifyName n)) - Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name - ; return (fmap reifyName mb_nm) } } - where - th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' - - occ_fs :: FastString - occ_fs = mkFastString (TH.nameBase th_name) - - occ :: OccName - occ | is_type_name - = if isLexVarSym occ_fs || isLexCon occ_fs - then mkTcOccFS occ_fs - else mkTyVarOccFS occ_fs - | otherwise - = if isLexCon occ_fs then mkDataOccFS occ_fs - else mkVarOccFS occ_fs - - rdr_name = case TH.nameModule th_name of - Nothing -> mkRdrUnqual occ - Just mod -> mkRdrQual (mkModuleName mod) occ - -getThing :: TH.Name -> TcM TcTyThing -getThing th_name - = do { name <- lookupThName th_name - ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name) - ; tcLookupTh name } - -- ToDo: this tcLookup could fail, which would give a - -- rather unhelpful error message - where - ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" - ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" - ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" - ppr_ns _ = panic "reify/ppr_ns" - -reify :: TH.Name -> TcM TH.Info -reify th_name - = do { traceTc "reify 1" (text (TH.showName th_name)) - ; thing <- getThing th_name - ; traceTc "reify 2" (ppr thing) - ; reifyThing thing } - -lookupThName :: TH.Name -> TcM Name -lookupThName th_name = do - mb_name <- lookupThName_maybe th_name - case mb_name of - Nothing -> failWithTc (notInScope th_name) - Just name -> return name - -lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -lookupThName_maybe th_name - = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) - -- Pick the first that works - -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A - ; return (listToMaybe names) } - where - lookup rdr_name - = do { -- Repeat much of lookupOccRn, because we want - -- to report errors in a TH-relevant way - ; rdr_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv rdr_env rdr_name of - Just name -> return (Just name) - Nothing -> lookupGlobalOccRn_maybe rdr_name } - -tcLookupTh :: Name -> TcM TcTyThing --- This is a specialised version of TcEnv.tcLookup; specialised mainly in that --- it gives a reify-related error message on failure, whereas in the normal --- tcLookup, failure is a bug. -tcLookupTh name - = do { (gbl_env, lcl_env) <- getEnvs - ; case lookupNameEnv (tcl_env lcl_env) name of { - Just thing -> return thing; - Nothing -> - - case lookupNameEnv (tcg_type_env gbl_env) name of { - Just thing -> return (AGlobal thing); - Nothing -> - - -- EZY: I don't think this choice matters, no TH in signatures! - if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name - then -- It's defined in this module - failWithTc (notInEnv name) - - else - do { mb_thing <- tcLookupImported_maybe name - ; case mb_thing of - Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc msg - }}}} - -notInScope :: TH.Name -> SDoc -notInScope th_name = quotes (text (TH.pprint th_name)) <+> - text "is not in scope at a reify" - -- Ugh! Rather an indirect way to display the name - -notInEnv :: Name -> SDoc -notInEnv name = quotes (ppr name) <+> - text "is not in the type environment at a reify" - ------------------------------- -reifyRoles :: TH.Name -> TcM [TH.Role] -reifyRoles th_name - = do { thing <- getThing th_name - ; case thing of - AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (text "No roles associated with" <+> (ppr thing)) - } - where - reify_role Nominal = TH.NominalR - reify_role Representational = TH.RepresentationalR - reify_role Phantom = TH.PhantomR - ------------------------------- -reifyThing :: TcTyThing -> TcM TH.Info --- The only reason this is monadic is for error reporting, --- which in turn is mainly for the case when TH can't express --- some random GHC extension - -reifyThing (AGlobal (AnId id)) - = do { ty <- reifyType (idType id) - ; let v = reifyName id - ; case idDetails id of - ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls)) - RecSelId{sel_tycon=RecSelData tc} - -> return (TH.VarI (reifySelector id tc) ty Nothing) - _ -> return (TH.VarI v ty Nothing) - } - -reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc -reifyThing (AGlobal (AConLike (RealDataCon dc))) - = do { let name = dataConName dc - ; ty <- reifyType (idType (dataConWrapId dc)) - ; return (TH.DataConI (reifyName name) ty - (reifyName (dataConOrigTyCon dc))) - } - -reifyThing (AGlobal (AConLike (PatSynCon ps))) - = do { let name = reifyName ps - ; ty <- reifyPatSynType (patSynSig ps) - ; return (TH.PatSynI name ty) } - -reifyThing (ATcId {tct_id = id}) - = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even - -- though it may be incomplete - ; ty2 <- reifyType ty1 - ; return (TH.VarI (reifyName id) ty2 Nothing) } - -reifyThing (ATyVar tv tv1) - = do { ty1 <- zonkTcTyVar tv1 - ; ty2 <- reifyType ty1 - ; return (TH.TyVarI (reifyName tv) ty2) } - -reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) - -------------------------------------------- -reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn -reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs - , cab_lhs = lhs - , cab_rhs = rhs }) - -- remove kind patterns (#8884) - = do { tvs' <- reifyTyVarsToMaybe tvs - ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs - ; lhs' <- reifyTypes lhs_types_only - ; annot_th_lhs <- zipWith3M annotThType (tyConArgsPolyKinded fam_tc) - lhs_types_only lhs' - ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs - ; rhs' <- reifyType rhs - ; return (TH.TySynEqn tvs' lhs_type rhs') } - -reifyTyCon :: TyCon -> TcM TH.Info -reifyTyCon tc - | Just cls <- tyConClass_maybe tc - = reifyClass cls - - | isFunTyCon tc - = return (TH.PrimTyConI (reifyName tc) 2 False) - - | isPrimTyCon tc - = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc)) - (isUnliftedTyCon tc)) - - | isTypeFamilyTyCon tc - = do { let tvs = tyConTyVars tc - res_kind = tyConResKind tc - resVar = famTcResVar tc - - ; kind' <- reifyKind res_kind - ; let (resultSig, injectivity) = - case resVar of - Nothing -> (TH.KindSig kind', Nothing) - Just name -> - let thName = reifyName name - injAnnot = tyConInjectivityInfo tc - sig = TH.TyVarSig (TH.KindedTV thName kind') - inj = case injAnnot of - NotInjective -> Nothing - Injective ms -> - Just (TH.InjectivityAnn thName injRHS) - where - injRHS = map (reifyName . tyVarName) - (filterByList ms tvs) - in (sig, inj) - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) - ; let tfHead = - TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity - ; if isOpenTypeFamilyTyCon tc - then do { fam_envs <- tcGetFamInstEnvs - ; instances <- reifyFamilyInstances tc - (familyInstances fam_envs tc) - ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) } - else do { eqns <- - case isClosedSynFamilyTyConWithAxiom_maybe tc of - Just ax -> mapM (reifyAxBranch tc) $ - fromBranches $ coAxiomBranches ax - Nothing -> return [] - ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns) - []) } } - - | isDataFamilyTyCon tc - = do { let res_kind = tyConResKind tc - - ; kind' <- fmap Just (reifyKind res_kind) - - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) - ; fam_envs <- tcGetFamInstEnvs - ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) - ; return (TH.FamilyI - (TH.DataFamilyD (reifyName tc) tvs' kind') instances) } - - | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym - = do { rhs' <- reifyType rhs - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) - ; return (TH.TyConI - (TH.TySynD (reifyName tc) tvs' rhs')) - } - - | otherwise - = do { cxt <- reifyCxt (tyConStupidTheta tc) - ; let tvs = tyConTyVars tc - dataCons = tyConDataCons tc - isGadt = isGadtSyntaxTyCon tc - ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons - ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc) - ; let name = reifyName tc - deriv = [] -- Don't know about deriving - decl | isNewTyCon tc = - TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv - | otherwise = - TH.DataD cxt name r_tvs Nothing cons deriv - ; return (TH.TyConI decl) } - -reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con -reifyDataCon isGadtDataCon tys dc - = do { let -- used for H98 data constructors - (ex_tvs, theta, arg_tys) - = dataConInstSig dc tys - -- used for GADTs data constructors - g_user_tvs' = dataConUserTyVars dc - (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty') - = dataConFullSig dc - (srcUnpks, srcStricts) - = mapAndUnzip reifySourceBang (dataConSrcBangs dc) - dcdBangs = zipWith TH.Bang srcUnpks srcStricts - fields = dataConFieldLabels dc - name = reifyName dc - -- Universal tvs present in eq_spec need to be filtered out, as - -- they will not appear anywhere in the type. - eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec) - - ; (univ_subst, _) - -- See Note [Freshen reified GADT constructors' universal tyvars] - <- freshenTyVarBndrs $ - filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs - ; let (tvb_subst, g_user_tvs) = substTyVarBndrs univ_subst g_user_tvs' - g_theta = substTys tvb_subst g_theta' - g_arg_tys = substTys tvb_subst g_arg_tys' - g_res_ty = substTy tvb_subst g_res_ty' - - ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys) - - ; main_con <- - if | not (null fields) && not isGadtDataCon -> - return $ TH.RecC name (zip3 (map reifyFieldLabel fields) - dcdBangs r_arg_tys) - | not (null fields) -> do - { res_ty <- reifyType g_res_ty - ; return $ TH.RecGadtC [name] - (zip3 (map (reifyName . flSelector) fields) - dcdBangs r_arg_tys) res_ty } - -- We need to check not isGadtDataCon here because GADT - -- constructors can be declared infix. - -- See Note [Infix GADT constructors] in TcTyClsDecls. - | dataConIsInfix dc && not isGadtDataCon -> - ASSERT( r_arg_tys `lengthIs` 2 ) do - { let [r_a1, r_a2] = r_arg_tys - [s1, s2] = dcdBangs - ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) } - | isGadtDataCon -> do - { res_ty <- reifyType g_res_ty - ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty } - | otherwise -> - return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) - - ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta) - | otherwise = ASSERT( all isTyVar ex_tvs ) - -- no covars for haskell syntax - (ex_tvs, theta) - ret_con | null ex_tvs' && null theta' = return main_con - | otherwise = do - { cxt <- reifyCxt theta' - ; ex_tvs'' <- reifyTyVars ex_tvs' - ; return (TH.ForallC ex_tvs'' cxt main_con) } - ; ASSERT( r_arg_tys `equalLength` dcdBangs ) - ret_con } - -{- -Note [Freshen reified GADT constructors' universal tyvars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose one were to reify this GADT: - - data a :~: b where - Refl :: forall a b. (a ~ b) => a :~: b - -We ought to be careful here about the uniques we give to the occurrences of `a` -and `b` in this definition. That is because in the original DataCon, all uses -of `a` and `b` have the same unique, since `a` and `b` are both universally -quantified type variables--that is, they are used in both the (:~:) tycon as -well as in the constructor type signature. But when we turn the DataCon -definition into the reified one, the `a` and `b` in the constructor type -signature becomes differently scoped than the `a` and `b` in `data a :~: b`. - -While it wouldn't technically be *wrong* per se to re-use the same uniques for -`a` and `b` across these two different scopes, it's somewhat annoying for end -users of Template Haskell, since they wouldn't be able to rely on the -assumption that all TH names have globally distinct uniques (#13885). For this -reason, we freshen the universally quantified tyvars that go into the reified -GADT constructor type signature to give them distinct uniques from their -counterparts in the tycon. --} - ------------------------------- -reifyClass :: Class -> TcM TH.Info -reifyClass cls - = do { cxt <- reifyCxt theta - ; inst_envs <- tcGetInstEnvs - ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) - ; assocTys <- concatMapM reifyAT ats - ; ops <- concatMapM reify_op op_stuff - ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls)) - ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops) - ; return (TH.ClassI dec insts) } - where - (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls - fds' = map reifyFunDep fds - reify_op (op, def_meth) - = do { let (_, _, ty) = tcSplitMethodTy (idType op) - -- Use tcSplitMethodTy to get rid of the extraneous class - -- variables and predicates at the beginning of op's type - -- (see #15551). - ; ty' <- reifyType ty - ; let nm' = reifyName op - ; case def_meth of - Just (_, GenericDM gdm_ty) -> - do { gdm_ty' <- reifyType gdm_ty - ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] } - _ -> return [TH.SigD nm' ty'] } - - reifyAT :: ClassATItem -> TcM [TH.Dec] - reifyAT (ATI tycon def) = do - tycon' <- reifyTyCon tycon - case tycon' of - TH.FamilyI dec _ -> do - let (tyName, tyArgs) = tfNames dec - (dec :) <$> maybe (return []) - (fmap (:[]) . reifyDefImpl tyName tyArgs . fst) - def - _ -> pprPanic "reifyAT" (text (show tycon')) - - reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec - reifyDefImpl n args ty = - TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args)) - <$> reifyType ty - - tfNames :: TH.Dec -> (TH.Name, [TH.Name]) - tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _)) - = (n, map bndrName args) - tfNames d = pprPanic "tfNames" (text (show d)) - - bndrName :: TH.TyVarBndr -> TH.Name - bndrName (TH.PlainTV n) = n - bndrName (TH.KindedTV n _) = n - ------------------------------- --- | Annotate (with TH.SigT) a type if the first parameter is True --- and if the type contains a free variable. --- This is used to annotate type patterns for poly-kinded tyvars in --- reifying class and type instances. --- See @Note [Reified instances and explicit kind signatures]@. -annotThType :: Bool -- True <=> annotate - -> TyCoRep.Type -> TH.Type -> TcM TH.Type - -- tiny optimization: if the type is annotated, don't annotate again. -annotThType _ _ th_ty@(TH.SigT {}) = return th_ty -annotThType True ty th_ty - | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty - = do { let ki = tcTypeKind ty - ; th_ki <- reifyKind ki - ; return (TH.SigT th_ty th_ki) } -annotThType _ _ th_ty = return th_ty - --- | For every argument type that a type constructor accepts, --- report whether or not the argument is poly-kinded. This is used to --- eventually feed into 'annotThType'. --- See @Note [Reified instances and explicit kind signatures]@. -tyConArgsPolyKinded :: TyCon -> [Bool] -tyConArgsPolyKinded tc = - map (is_poly_ty . tyVarKind) tc_vis_tvs - -- See "Wrinkle: Oversaturated data family instances" in - -- @Note [Reified instances and explicit kind signatures]@ - ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle - ++ repeat True -- (2) in Wrinkle - where - is_poly_ty :: Type -> Bool - is_poly_ty ty = not $ - isEmptyVarSet $ - filterVarSet isTyVar $ - tyCoVarsOfType ty - - tc_vis_tvs :: [TyVar] - tc_vis_tvs = tyConVisibleTyVars tc - - tc_res_kind_vis_bndrs :: [TyCoBinder] - tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc - -{- -Note [Reified instances and explicit kind signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Reified class instances and type family instances often include extra kind -information to disambiguate instances. Here is one such example that -illustrates this (#8953): - - type family Poly (a :: k) :: Type - type instance Poly (x :: Bool) = Int - type instance Poly (x :: Maybe k) = Double - -If you're not careful, reifying these instances might yield this: - - type instance Poly x = Int - type instance Poly x = Double - -To avoid this, we go through some care to annotate things with extra kind -information. Some functions which accomplish this feat include: - -* annotThType: This annotates a type with a kind signature if the type contains - a free variable. -* tyConArgsPolyKinded: This checks every argument that a type constructor can - accept and reports if the type of the argument is poly-kinded. This - information is ultimately fed into annotThType. - ------ --- Wrinkle: Oversaturated data family instances ------ - -What constitutes an argument to a type constructor in the definition of -tyConArgsPolyKinded? For most type constructors, it's simply the visible -type variable binders (i.e., tyConVisibleTyVars). There is one corner case -we must keep in mind, however: data family instances can appear oversaturated -(#17296). For instance: - - data family Foo :: Type -> Type - data instance Foo x - - data family Bar :: k - data family Bar x - -For these sorts of data family instances, tyConVisibleTyVars isn't enough, -as they won't give you the kinds of the oversaturated arguments. We must -also consult: - -1. The kinds of the arguments in the result kind (i.e., the tyConResKind). - This will tell us, e.g., the kind of `x` in `Foo x` above. -2. If we go beyond the number of arguments in the result kind (like the - `x` in `Bar x`), then we conservatively assume that the argument's - kind is poly-kinded. - ------ --- Wrinkle: data family instances with return kinds ------ - -Another squirrelly corner case is this: - - data family Foo (a :: k) - data instance Foo :: Bool -> Type - data instance Foo :: Char -> Type - -If you're not careful, reifying these instances might yield this: - - data instance Foo - data instance Foo - -We can fix this ambiguity by reifying the instances' explicit return kinds. We -should only do this if necessary (see -Note [When does a tycon application need an explicit kind signature?] in GHC.Core.Type), -but more importantly, we *only* do this if either of the following are true: - -1. The data family instance has no constructors. -2. The data family instance is declared with GADT syntax. - -If neither of these are true, then reifying the return kind would yield -something like this: - - data instance (Bar a :: Type) = MkBar a - -Which is not valid syntax. --} - ------------------------------- -reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] -reifyClassInstances cls insts - = mapM (reifyClassInstance (tyConArgsPolyKinded (classTyCon cls))) insts - -reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded - -- includes only *visible* tvs - -> ClsInst -> TcM TH.Dec -reifyClassInstance is_poly_tvs i - = do { cxt <- reifyCxt theta - ; let vis_types = filterOutInvisibleTypes cls_tc types - ; thtypes <- reifyTypes vis_types - ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes - ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes - ; return $ (TH.InstanceD over cxt head_ty []) } - where - (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) - cls_tc = classTyCon cls - dfun = instanceDFunId i - over = case overlapMode (is_flag i) of - NoOverlap _ -> Nothing - Overlappable _ -> Just TH.Overlappable - Overlapping _ -> Just TH.Overlapping - Overlaps _ -> Just TH.Overlaps - Incoherent _ -> Just TH.Incoherent - ------------------------------- -reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] -reifyFamilyInstances fam_tc fam_insts - = mapM (reifyFamilyInstance (tyConArgsPolyKinded fam_tc)) fam_insts - -reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded - -- includes only *visible* tvs - -> FamInst -> TcM TH.Dec -reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor - , fi_axiom = ax - , fi_fam = fam }) - | let fam_tc = coAxiomTyCon ax - branch = coAxiomSingleBranch ax - , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch - = case flavor of - SynFamilyInst -> - -- remove kind patterns (#8884) - do { th_tvs <- reifyTyVarsToMaybe tvs - ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs - ; th_lhs <- reifyTypes lhs_types_only - ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only - th_lhs - ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs - ; th_rhs <- reifyType rhs - ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) } - - DataFamilyInst rep_tc -> - do { let -- eta-expand lhs types, because sometimes data/newtype - -- instances are eta-reduced; See #9692 - -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom - (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch - fam' = reifyName fam - dataCons = tyConDataCons rep_tc - isGadt = isGadtSyntaxTyCon rep_tc - ; th_tvs <- reifyTyVarsToMaybe ee_tvs - ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons - ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs - ; th_tys <- reifyTypes types_only - ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys - ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys - ; mb_sig <- - -- See "Wrinkle: data family instances with return kinds" in - -- Note [Reified instances and explicit kind signatures] - if (null cons || isGadtSyntaxTyCon rep_tc) - && tyConAppNeedsKindSig False fam_tc (length ee_lhs) - then do { let full_kind = tcTypeKind (mkTyConApp fam_tc ee_lhs) - ; th_full_kind <- reifyKind full_kind - ; pure $ Just th_full_kind } - else pure Nothing - ; return $ - if isNewTyCon rep_tc - then TH.NewtypeInstD [] th_tvs lhs_type mb_sig (head cons) [] - else TH.DataInstD [] th_tvs lhs_type mb_sig cons [] - } - ------------------------------- -reifyType :: TyCoRep.Type -> TcM TH.Type --- Monadic only because of failure -reifyType ty | tcIsLiftedTypeKind ty = return TH.StarT - -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it - -- with Constraint (#14869). -reifyType ty@(ForAllTy (Bndr _ argf) _) - = reify_for_all argf ty -reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } -reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) -reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here -reifyType ty@(AppTy {}) = do - let (ty_head, ty_args) = splitAppTys ty - ty_head' <- reifyType ty_head - ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args) - pure $ mkThAppTs ty_head' ty_args' - where - -- Make sure to filter out any invisible arguments. For instance, if you - -- reify the following: - -- - -- newtype T (f :: forall a. a -> Type) = MkT (f Bool) - -- - -- Then you should receive back `f Bool`, not `f Type Bool`, since the - -- `Type` argument is invisible (#15792). - filter_out_invisible_args :: Type -> [Type] -> [Type] - filter_out_invisible_args ty_head ty_args = - filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) - ty_args -reifyType ty@(FunTy { ft_af = af, ft_arg = t1, ft_res = t2 }) - | InvisArg <- af = reify_for_all Inferred ty -- Types like ((?x::Int) => Char -> Char) - | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } -reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH -reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty) - -reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type --- Arg of reify_for_all is always ForAllTy or a predicate FunTy -reify_for_all argf ty = do - tvs' <- reifyTyVars tvs - case argToForallVisFlag argf of - ForallVis -> do phi' <- reifyType phi - pure $ TH.ForallVisT tvs' phi' - ForallInvis -> do let (cxt, tau) = tcSplitPhiTy phi - cxt' <- reifyCxt cxt - tau' <- reifyType tau - pure $ TH.ForallT tvs' cxt' tau' - where - (tvs, phi) = tcSplitForAllTysSameVis argf ty - -reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit -reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) -reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) - -reifyTypes :: [Type] -> TcM [TH.Type] -reifyTypes = mapM reifyType - -reifyPatSynType - :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type --- reifies a pattern synonym's type and returns its *complete* type --- signature; see NOTE [Pattern synonym signatures and Template --- Haskell] -reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy) - = do { univTyVars' <- reifyTyVars univTyVars - ; req' <- reifyCxt req - ; exTyVars' <- reifyTyVars exTyVars - ; prov' <- reifyCxt prov - ; tau' <- reifyType (mkVisFunTys argTys resTy) - ; return $ TH.ForallT univTyVars' req' - $ TH.ForallT exTyVars' prov' tau' } - -reifyKind :: Kind -> TcM TH.Kind -reifyKind = reifyType - -reifyCxt :: [PredType] -> TcM [TH.Pred] -reifyCxt = mapM reifyType - -reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep -reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) - -reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr] -reifyTyVars tvs = mapM reify_tv tvs - where - -- even if the kind is *, we need to include a kind annotation, - -- in case a poly-kind would be inferred without the annotation. - -- See #8953 or test th/T8953 - reify_tv tv = TH.KindedTV name <$> reifyKind kind - where - kind = tyVarKind tv - name = reifyName tv - -reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr]) -reifyTyVarsToMaybe [] = pure Nothing -reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys - -reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type -reify_tc_app tc tys - = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys) - ; maybe_sig_t (mkThAppTs r_tc tys') } - where - arity = tyConArity tc - - r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2) - | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2) - | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2) - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - | isTupleTyCon tc = if isPromotedDataCon tc - then TH.PromotedTupleT arity - else TH.TupleT arity - | tc `hasKey` constraintKindTyConKey - = TH.ConstraintT - | tc `hasKey` funTyConKey = TH.ArrowT - | tc `hasKey` listTyConKey = TH.ListT - | tc `hasKey` nilDataConKey = TH.PromotedNilT - | tc `hasKey` consDataConKey = TH.PromotedConsT - | tc `hasKey` heqTyConKey = TH.EqualityT - | tc `hasKey` eqPrimTyConKey = TH.EqualityT - | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon) - | isPromotedDataCon tc = TH.PromotedT (reifyName tc) - | otherwise = TH.ConT (reifyName tc) - - -- See Note [When does a tycon application need an explicit kind - -- signature?] in GHC.Core.TyCo.Rep - maybe_sig_t th_type - | tyConAppNeedsKindSig - False -- We don't reify types using visible kind applications, so - -- don't count specified binders as contributing towards - -- injective positions in the kind of the tycon. - tc (length tys) - = do { let full_kind = tcTypeKind (mkTyConApp tc tys) - ; th_full_kind <- reifyKind full_kind - ; return (TH.SigT th_type th_full_kind) } - | otherwise - = return th_type - ------------------------------- -reifyName :: NamedThing n => n -> TH.Name -reifyName thing - | isExternalName name - = mk_varg pkg_str mod_str occ_str - | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name)) - -- Many of the things we reify have local bindings, and - -- NameL's aren't supposed to appear in binding positions, so - -- we use NameU. When/if we start to reify nested things, that - -- have free variables, we may need to generate NameL's for them. - where - name = getName thing - mod = ASSERT( isExternalName name ) nameModule name - pkg_str = unitIdString (moduleUnitId mod) - mod_str = moduleNameString (moduleName mod) - occ_str = occNameString occ - occ = nameOccName name - mk_varg | OccName.isDataOcc occ = TH.mkNameG_d - | OccName.isVarOcc occ = TH.mkNameG_v - | OccName.isTcOcc occ = TH.mkNameG_tc - | otherwise = pprPanic "reifyName" (ppr name) - --- See Note [Reifying field labels] -reifyFieldLabel :: FieldLabel -> TH.Name -reifyFieldLabel fl - | flIsOverloaded fl - = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str)) - | otherwise = TH.mkNameG_v pkg_str mod_str occ_str - where - name = flSelector fl - mod = ASSERT( isExternalName name ) nameModule name - pkg_str = unitIdString (moduleUnitId mod) - mod_str = moduleNameString (moduleName mod) - occ_str = unpackFS (flLabel fl) - -reifySelector :: Id -> TyCon -> TH.Name -reifySelector id tc - = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of - Just fl -> reifyFieldLabel fl - Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc) - ------------------------------- -reifyFixity :: Name -> TcM (Maybe TH.Fixity) -reifyFixity name - = do { (found, fix) <- lookupFixityRn_help name - ; return (if found then Just (conv_fix fix) else Nothing) } - where - conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d) - conv_dir BasicTypes.InfixR = TH.InfixR - conv_dir BasicTypes.InfixL = TH.InfixL - conv_dir BasicTypes.InfixN = TH.InfixN - -reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness -reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness -reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack -reifyUnpackedness SrcUnpack = TH.SourceUnpack - -reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness -reifyStrictness NoSrcStrict = TH.NoSourceStrictness -reifyStrictness SrcStrict = TH.SourceStrict -reifyStrictness SrcLazy = TH.SourceLazy - -reifySourceBang :: DataCon.HsSrcBang - -> (TH.SourceUnpackedness, TH.SourceStrictness) -reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s) - -reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness -reifyDecidedStrictness HsLazy = TH.DecidedLazy -reifyDecidedStrictness HsStrict = TH.DecidedStrict -reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack - -reifyTypeOfThing :: TH.Name -> TcM TH.Type -reifyTypeOfThing th_name = do - thing <- getThing th_name - case thing of - AGlobal (AnId id) -> reifyType (idType id) - AGlobal (ATyCon tc) -> reifyKind (tyConKind tc) - AGlobal (AConLike (RealDataCon dc)) -> - reifyType (idType (dataConWrapId dc)) - AGlobal (AConLike (PatSynCon ps)) -> - reifyPatSynType (patSynSig ps) - ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType - ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType - -- Impossible cases, supposedly: - AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom" - ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon" - APromotionErr _ -> panic "reifyTypeOfThing: APromotionErr" - ------------------------------- -lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget -lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) -lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) - = return $ ModuleTarget $ - mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn) - -reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] -reifyAnnotations th_name - = do { name <- lookupThAnnLookup th_name - ; topEnv <- getTopEnv - ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing - ; tcg <- getGblEnv - ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name - ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name - ; return (selectedEpsHptAnns ++ selectedTcgAnns) } - ------------------------------- -modToTHMod :: Module -> TH.Module -modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId m) - (TH.ModName $ moduleNameString $ moduleName m) - -reifyModule :: TH.Module -> TcM TH.ModuleInfo -reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do - this_mod <- getModule - let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString) - if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod - where - reifyThisModule = do - usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports - return $ TH.ModuleInfo usages - - reifyFromIface reifMod = do - iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod - let usages = [modToTHMod m | usage <- mi_usages iface, - Just m <- [usageToModule (moduleUnitId reifMod) usage] ] - return $ TH.ModuleInfo usages - - usageToModule :: UnitId -> Usage -> Maybe Module - usageToModule _ (UsageFile {}) = Nothing - usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn - usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m - usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m - ------------------------------- -mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type -mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys - -noTH :: PtrString -> SDoc -> TcM a -noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+> - text "in Template Haskell:", - nest 2 d]) - -ppr_th :: TH.Ppr a => a -> SDoc -ppr_th x = text (TH.pprint x) - -{- -Note [Reifying field labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When reifying a datatype declared with DuplicateRecordFields enabled, we want -the reified names of the fields to be labels rather than selector functions. -That is, we want (reify ''T) and (reify 'foo) to produce - - data T = MkT { foo :: Int } - foo :: T -> Int - -rather than - - data T = MkT { $sel:foo:MkT :: Int } - $sel:foo:MkT :: T -> Int - -because otherwise TH code that uses the field names as strings will silently do -the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather -than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the -environment, NameG can't be used to represent such fields. Instead, -reifyFieldLabel uses NameQ. - -However, this means that extracting the field name from the output of reify, and -trying to reify it again, may fail with an ambiguity error if there are multiple -such fields defined in the module (see the test case -overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to -the TH AST to make it able to represent duplicate record fields. --} - -tcGetInterp :: TcM Interp -tcGetInterp = do - hsc_env <- getTopEnv - case hsc_interp hsc_env of - Nothing -> liftIO $ throwIO (InstallationError "Template haskell requires a target code interpreter") - Just i -> pure i diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot deleted file mode 100644 index f6d57a7552..0000000000 --- a/compiler/typecheck/TcSplice.hs-boot +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module TcSplice where - -import GhcPrelude -import GHC.Types.Name -import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) -import TcRnTypes( TcM , SpliceType ) -import TcType ( ExpRhoType ) -import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) -import GHC.Hs.Extension ( GhcTcId, GhcRn, GhcPs, GhcTc ) - -import GHC.Hs ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, - LHsDecl, ThModFinalizers ) -import qualified Language.Haskell.TH as TH - -tcSpliceExpr :: HsSplice GhcRn - -> ExpRhoType - -> TcM (HsExpr GhcTcId) - -tcUntypedBracket :: HsExpr GhcRn - -> HsBracket GhcRn - -> [PendingRnSplice] - -> ExpRhoType - -> TcM (HsExpr GhcTcId) -tcTypedBracket :: HsExpr GhcRn - -> HsBracket GhcRn - -> ExpRhoType - -> TcM (HsExpr GhcTcId) - -runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) - -runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation - -tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId) - -runMetaE :: LHsExpr GhcTcId -> TcM (LHsExpr GhcPs) -runMetaP :: LHsExpr GhcTcId -> TcM (LPat GhcPs) -runMetaT :: LHsExpr GhcTcId -> TcM (LHsType GhcPs) -runMetaD :: LHsExpr GhcTcId -> TcM [LHsDecl GhcPs] - -lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -runQuasi :: TH.Q a -> TcM a -runRemoteModFinalizers :: ThModFinalizers -> TcM () -finishTH :: TcM () diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs deleted file mode 100644 index b69a4654f3..0000000000 --- a/compiler/typecheck/TcTyClsDecls.hs +++ /dev/null @@ -1,4914 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - - -TcTyClsDecls: Typecheck type and class declarations --} - -{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcTyClsDecls ( - tcTyAndClassDecls, - - -- Functions used by TcInstDcls to check - -- data/type family instance declarations - kcConDecls, tcConDecls, dataDeclChecks, checkValidTyCon, - tcFamTyPats, tcTyFamInstEqn, - tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, - unravelFamInstPats, addConsistencyConstraints, - wrongKindOfFamily - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Driver.Types -import BuildTyCl -import TcRnMonad -import TcEnv -import TcValidity -import TcHsSyn -import TcTyDecls -import TcClassDcl -import {-# SOURCE #-} TcInstDcls( tcInstDecls1 ) -import TcDeriv (DerivInfo(..)) -import TcUnify ( checkTvConstraints ) -import TcHsType -import ClsInst( AssocInstInfo(..) ) -import TcMType -import TysWiredIn ( unitTy, makeRecoveryTyCon ) -import TcType -import GHC.Rename.Env( lookupConstructorFields ) -import FamInst -import GHC.Core.FamInstEnv -import GHC.Core.Coercion -import TcOrigin -import GHC.Core.Type -import GHC.Core.TyCo.Rep -- for checkValidRoles -import GHC.Core.TyCo.Ppr( pprTyVars, pprWithExplicitKindsWhen ) -import GHC.Core.Class -import GHC.Core.Coercion.Axiom -import GHC.Core.TyCon -import GHC.Core.DataCon -import GHC.Types.Id -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Module -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import Outputable -import Maybes -import GHC.Core.Unify -import Util -import GHC.Types.SrcLoc -import ListSetOps -import GHC.Driver.Session -import GHC.Types.Unique -import GHC.Core.ConLike( ConLike(..) ) -import GHC.Types.Basic -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable -import Data.Function ( on ) -import Data.Functor.Identity -import Data.List -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.Set as Set -import Data.Tuple( swap ) - -{- -************************************************************************ -* * -\subsection{Type checking for type and class declarations} -* * -************************************************************************ - -Note [Grouping of type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly -connected component of mutually dependent types and classes. We kind check and -type check each group separately to enhance kind polymorphism. Take the -following example: - - type Id a = a - data X = X (Id Int) - -If we were to kind check the two declarations together, we would give Id the -kind * -> *, since we apply it to an Int in the definition of X. But we can do -better than that, since Id really is kind polymorphic, and should get kind -forall (k::*). k -> k. Since it does not depend on anything else, it can be -kind-checked by itself, hence getting the most general kind. We then kind check -X, which works fine because we then know the polymorphic kind of Id, and simply -instantiate k to *. - -Note [Check role annotations in a second pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Role inference potentially depends on the types of all of the datacons declared -in a mutually recursive group. The validity of a role annotation, in turn, -depends on the result of role inference. Because the types of datacons might -be ill-formed (see #7175 and Note [Checking GADT return types]) we must check -*all* the tycons in a group for validity before checking *any* of the roles. -Thus, we take two passes over the resulting tycons, first checking for general -validity and then checking for valid role annotations. --} - -tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in - -- dependency order - -> TcM ( TcGblEnv -- Input env extended by types and - -- classes - -- and their implicit Ids,DataCons - , [InstInfo GhcRn] -- Source-code instance decls info - , [DerivInfo] -- Deriving info - ) --- Fails if there are any errors -tcTyAndClassDecls tyclds_s - -- The code recovers internally, but if anything gave rise to - -- an error we'd better stop now, to avoid a cascade - -- Type check each group in dependency order folding the global env - = checkNoErrs $ fold_env [] [] tyclds_s - where - fold_env :: [InstInfo GhcRn] - -> [DerivInfo] - -> [TyClGroup GhcRn] - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) - fold_env inst_info deriv_info [] - = do { gbl_env <- getGblEnv - ; return (gbl_env, inst_info, deriv_info) } - fold_env inst_info deriv_info (tyclds:tyclds_s) - = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds - ; setGblEnv tcg_env $ - -- remaining groups are typechecked in the extended global env. - fold_env (inst_info' ++ inst_info) - (deriv_info' ++ deriv_info) - tyclds_s } - -tcTyClGroup :: TyClGroup GhcRn - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) --- Typecheck one strongly-connected component of type, class, and instance decls --- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls -tcTyClGroup (TyClGroup { group_tyclds = tyclds - , group_roles = roles - , group_kisigs = kisigs - , group_instds = instds }) - = do { let role_annots = mkRoleAnnotEnv roles - - -- Step 1: Typecheck the standalone kind signatures and type/class declarations - ; traceTc "---- tcTyClGroup ---- {" empty - ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds)) - ; (tyclss, data_deriv_info) <- - tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution] - do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs - ; tcTyClDecls tyclds kisig_env role_annots } - - -- Step 1.5: Make sure we don't have any type synonym cycles - ; traceTc "Starting synonym cycle check" (ppr tyclss) - ; this_uid <- fmap thisPackage getDynFlags - ; checkSynCycles this_uid tyclss tyclds - ; traceTc "Done synonym cycle check" (ppr tyclss) - - -- Step 2: Perform the validity check on those types/classes - -- We can do this now because we are done with the recursive knot - -- Do it before Step 3 (adding implicit things) because the latter - -- expects well-formed TyCons - ; traceTc "Starting validity check" (ppr tyclss) - ; tyclss <- concatMapM checkValidTyCl tyclss - ; traceTc "Done validity check" (ppr tyclss) - ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss - -- See Note [Check role annotations in a second pass] - - ; traceTc "---- end tcTyClGroup ---- }" empty - - -- Step 3: Add the implicit things; - -- we want them in the environment because - -- they may be mentioned in interface files - ; gbl_env <- addTyConsToGblEnv tyclss - - -- Step 4: check instance declarations - ; (gbl_env', inst_info, datafam_deriv_info) <- - setGblEnv gbl_env $ - tcInstDecls1 instds - - ; let deriv_info = datafam_deriv_info ++ data_deriv_info - ; return (gbl_env', inst_info, deriv_info) } - - -tcTyClGroup (XTyClGroup nec) = noExtCon nec - --- Gives the kind for every TyCon that has a standalone kind signature -type KindSigEnv = NameEnv Kind - -tcTyClDecls - :: [LTyClDecl GhcRn] - -> KindSigEnv - -> RoleAnnotEnv - -> TcM ([TyCon], [DerivInfo]) -tcTyClDecls tyclds kisig_env role_annots - = do { -- Step 1: kind-check this group and returns the final - -- (possibly-polymorphic) kind of each TyCon and Class - -- See Note [Kind checking for type and class decls] - tc_tycons <- kcTyClGroup kisig_env tyclds - ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons)) - - -- Step 2: type-check all groups together, returning - -- the final TyCons and Classes - -- - -- NB: We have to be careful here to NOT eagerly unfold - -- type synonyms, as we have not tested for type synonym - -- loops yet and could fall into a black hole. - ; fixM $ \ ~(rec_tyclss, _) -> do - { tcg_env <- getGblEnv - ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss - - -- Populate environment with knot-tied ATyCon for TyCons - -- NB: if the decls mention any ill-staged data cons - -- (see Note [Recursion and promoting data constructors]) - -- we will have failed already in kcTyClGroup, so no worries here - ; (tycons, data_deriv_infos) <- - tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $ - - -- Also extend the local type envt with bindings giving - -- a TcTyCon for each each knot-tied TyCon or Class - -- See Note [Type checking recursive type and class declarations] - -- and Note [Type environment evolution] - tcExtendKindEnvWithTyCons tc_tycons $ - - -- Kind and type check declarations for this group - mapAndUnzipM (tcTyClDecl roles) tyclds - ; return (tycons, concat data_deriv_infos) - } } - where - ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma - , ppr (tyConBinders tc) <> comma - , ppr (tyConResKind tc) - , ppr (isTcTyCon tc) ]) - -zipRecTyClss :: [TcTyCon] - -> [TyCon] -- Knot-tied - -> [(Name,TyThing)] --- Build a name-TyThing mapping for the TyCons bound by decls --- being careful not to look at the knot-tied [TyThing] --- The TyThings in the result list must have a visible ATyCon, --- because typechecking types (in, say, tcTyClDecl) looks at --- this outer constructor -zipRecTyClss tc_tycons rec_tycons - = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ] - where - rec_tc_env :: NameEnv TyCon - rec_tc_env = foldr add_tc emptyNameEnv rec_tycons - - add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon - add_tc tc env = foldr add_one_tc env (tc : tyConATs tc) - - add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon - add_one_tc tc env = extendNameEnv env (tyConName tc) tc - - get name = case lookupNameEnv rec_tc_env name of - Just tc -> tc - other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other) - -{- -************************************************************************ -* * - Kind checking -* * -************************************************************************ - -Note [Kind checking for type and class decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Kind checking is done thus: - - 1. Make up a kind variable for each parameter of the declarations, - and extend the kind environment (which is in the TcLclEnv) - - 2. Kind check the declarations - -We need to kind check all types in the mutually recursive group -before we know the kind of the type variables. For example: - - class C a where - op :: D b => a -> b -> b - - class D c where - bop :: (Monad c) => ... - -Here, the kind of the locally-polymorphic type variable "b" -depends on *all the uses of class D*. For example, the use of -Monad c in bop's type signature means that D must have kind Type->Type. - -Note: we don't treat type synonyms specially (we used to, in the past); -in particular, even if we have a type synonym cycle, we still kind check -it normally, and test for cycles later (checkSynCycles). The reason -we can get away with this is because we have more systematic TYPE r -inference, which means that we can do unification between kinds that -aren't lifted (this historically was not true.) - -The downside of not directly reading off the kinds of the RHS of -type synonyms in topological order is that we don't transparently -support making synonyms of types with higher-rank kinds. But -you can always specify a CUSK directly to make this work out. -See tc269 for an example. - -Note [CUSKs and PolyKinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T (a :: *) = MkT (S a) -- Has CUSK - data S a = MkS (T Int) (S a) -- No CUSK - -Via inferInitialKinds we get - T :: * -> * - S :: kappa -> * - -Then we call kcTyClDecl on each decl in the group, to constrain the -kind unification variables. BUT we /skip/ the RHS of any decl with -a CUSK. Here we skip the RHS of T, so we eventually get - S :: forall k. k -> * - -This gets us more polymorphism than we would otherwise get, similar -(but implemented strangely differently from) the treatment of type -signatures in value declarations. - -However, we only want to do so when we have PolyKinds. -When we have NoPolyKinds, we don't skip those decls, because we have defaulting -(#16609). Skipping won't bring us more polymorphism when we have defaulting. -Consider - - data T1 a = MkT1 T2 -- No CUSK - data T2 = MkT2 (T1 Maybe) -- Has CUSK - -If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved. -With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the -program type-checks. -But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens -in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking -(T1 Maybe) will throw a type error. - -Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip. - -Open type families -~~~~~~~~~~~~~~~~~~ -This treatment of type synonyms only applies to Haskell 98-style synonyms. -General type functions can be recursive, and hence, appear in `alg_decls'. - -The kind of an open type family is solely determinded by its kind signature; -hence, only kind signatures participate in the construction of the initial -kind environment (as constructed by `inferInitialKind'). In fact, we ignore -instances of families altogether in the following. However, we need to include -the kinds of *associated* families into the construction of the initial kind -environment. (This is handled by `allDecls'). - -See also Note [Kind checking recursive type and class declarations] - -Note [How TcTyCons work] -~~~~~~~~~~~~~~~~~~~~~~~~ -TcTyCons are used for two distinct purposes - -1. When recovering from a type error in a type declaration, - we want to put the erroneous TyCon in the environment in a - way that won't lead to more errors. We use a TcTyCon for this; - see makeRecoveryTyCon. - -2. When checking a type/class declaration (in module TcTyClsDecls), we come - upon knowledge of the eventual tycon in bits and pieces. - - S1) First, we use inferInitialKinds to look over the user-provided - kind signature of a tycon (including, for example, the number - of parameters written to the tycon) to get an initial shape of - the tycon's kind. We record that shape in a TcTyCon. - - For CUSK tycons, the TcTyCon has the final, generalised kind. - For non-CUSK tycons, the TcTyCon has as its tyConBinders only - the explicit arguments given -- no kind variables, etc. - - S2) Then, using these initial kinds, we kind-check the body of the - tycon (class methods, data constructors, etc.), filling in the - metavariables in the tycon's initial kind. - - S3) We then generalize to get the (non-CUSK) tycon's final, fixed - kind. Finally, once this has happened for all tycons in a - mutually recursive group, we can desugar the lot. - - For convenience, we store partially-known tycons in TcTyCons, which - might store meta-variables. These TcTyCons are stored in the local - environment in TcTyClsDecls, until the real full TyCons can be created - during desugaring. A desugared program should never have a TcTyCon. - -3. In a TcTyCon, everything is zonked after the kind-checking pass (S2). - -4. tyConScopedTyVars. A challenging piece in all of this is that we - end up taking three separate passes over every declaration: - - one in inferInitialKind (this pass look only at the head, not the body) - - one in kcTyClDecls (to kind-check the body) - - a final one in tcTyClDecls (to desugar) - - In the latter two passes, we need to connect the user-written type - variables in an LHsQTyVars with the variables in the tycon's - inferred kind. Because the tycon might not have a CUSK, this - matching up is, in general, quite hard to do. (Look through the - git history between Dec 2015 and Apr 2016 for - TcHsType.splitTelescopeTvs!) - - Instead of trying, we just store the list of type variables to - bring into scope, in the tyConScopedTyVars field of the TcTyCon. - These tyvars are brought into scope in TcHsType.bindTyClTyVars. - - In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather - than just [TcTyVar]? Consider these mutually-recursive decls - data T (a :: k1) b = MkT (S a b) - data S (c :: k2) d = MkS (T c d) - We start with k1 bound to kappa1, and k2 to kappa2; so initially - in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But - then kappa1 and kappa2 get unified; so after the zonking in - 'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ. - -See also Note [Type checking recursive type and class declarations]. - -Note [Swizzling the tyvars before generaliseTcTyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note only applies when /inferring/ the kind of a TyCon. -If there is a separate kind signature, or a CUSK, we take an entirely -different code path. - -For inference, consider - class C (f :: k) x where - type T f - op :: D f => blah - class D (g :: j) y where - op :: C g => y -> blah - -Here C and D are considered mutually recursive. Neither has a CUSK. -Just before generalisation we have the (un-quantified) kinds - C :: k1 -> k2 -> Constraint - T :: k1 -> Type - D :: k1 -> Type -> Constraint -Notice that f's kind and g's kind have been unified to 'k1'. We say -that k1 is the "representative" of k in C's decl, and of j in D's decl. - -Now when quantifying, we'd like to end up with - C :: forall {k2}. forall k. k -> k2 -> Constraint - T :: forall k. k -> Type - D :: forall j. j -> Type -> Constraint - -That is, we want to swizzle the representative to have the Name given -by the user. Partly this is to improve error messages and the output of -:info in GHCi. But it is /also/ important because the code for a -default method may mention the class variable(s), but at that point -(tcClassDecl2), we only have the final class tyvars available. -(Alternatively, we could record the scoped type variables in the -TyCon, but it's a nuisance to do so.) - -Notes: - -* On the input to generaliseTyClDecl, the mapping between the - user-specified Name and the representative TyVar is recorded in the - tyConScopedTyVars of the TcTyCon. NB: you first need to zonk to see - this representative TyVar. - -* The swizzling is actually performed by swizzleTcTyConBndrs - -* We must do the swizzling across the whole class decl. Consider - class C f where - type S (f :: k) - type T f - Here f's kind k is a parameter of C, and its identity is shared - with S and T. So if we swizzle the representative k at all, we - must do so consistently for the entire declaration. - - Hence the call to check_duplicate_tc_binders is in generaliseTyClDecl, - rather than in generaliseTcTyCon. - -There are errors to catch here. Suppose we had - class E (f :: j) (g :: k) where - op :: SameKind f g -> blah - -Then, just before generalisation we will have the (unquantified) - E :: k1 -> k1 -> Constraint - -That's bad! Two distinctly-named tyvars (j and k) have ended up with -the same representative k1. So when swizzling, we check (in -check_duplicate_tc_binders) that two distinct source names map -to the same representative. - -Here's an interesting case: - class C1 f where - type S (f :: k1) - type T (f :: k2) -Here k1 and k2 are different Names, but they end up mapped to the -same representative TyVar. To make the swizzling consistent (remember -we must have a single k across C1, S and T) we reject the program. - -Another interesting case - class C2 f where - type S (f :: k) (p::Type) - type T (f :: k) (p::Type->Type) - -Here the two k's (and the two p's) get distinct Uniques, because they -are seen by the renamer as locally bound in S and T resp. But again -the two (distinct) k's end up bound to the same representative TyVar. -You might argue that this should be accepted, but it's definitely -rejected (via an entirely different code path) if you add a kind sig: - type C2' :: j -> Constraint - class C2' f where - type S (f :: k) (p::Type) -We get - • Expected kind ‘j’, but ‘f’ has kind ‘k’ - • In the associated type family declaration for ‘S’ - -So we reject C2 too, even without the kind signature. We have -to do a bit of work to get a good error message, since both k's -look the same to the user. - -Another case - class C3 (f :: k1) where - type S (f :: k2) - -This will be rejected too. - - -Note [Type environment evolution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As we typecheck a group of declarations the type environment evolves. -Consider for example: - data B (a :: Type) = MkB (Proxy 'MkB) - -We do the following steps: - - 1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the - type env with promotion errors - B :-> TyConPE - MkB :-> DataConPE - - 2. kcTyCLGroup - - Do inferInitialKinds, which will signal a promotion - error if B is used in any of the kinds needed to initialise - B's kind (e.g. (a :: Type)) here - - - Extend the type env with these initial kinds (monomorphic for - decls that lack a CUSK) - B :-> TcTyCon <initial kind> - (thereby overriding the B :-> TyConPE binding) - and do kcLTyClDecl on each decl to get equality constraints on - all those initial kinds - - - Generalise the initial kind, making a poly-kinded TcTyCon - - 3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded - TcTyCons, again overriding the promotion-error bindings. - - But note that the data constructor promotion errors are still in place - so that (in our example) a use of MkB will still be signalled as - an error. - - 4. Typecheck the decls. - - 5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons - - -Note [Missed opportunity to retain higher-rank kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In 'kcTyClGroup', there is a missed opportunity to make kind -inference work in a few more cases. The idea is analogous -to Note [Single function non-recursive binding special-case]: - - * If we have an SCC with a single decl, which is non-recursive, - instead of creating a unification variable representing the - kind of the decl and unifying it with the rhs, we can just - read the type directly of the rhs. - - * Furthermore, we can update our SCC analysis to ignore - dependencies on declarations which have CUSKs: we don't - have to kind-check these all at once, since we can use - the CUSK to initialize the kind environment. - -Unfortunately this requires reworking a bit of the code in -'kcLTyClDecl' so I've decided to punt unless someone shouts about it. - -Note [Don't process associated types in getInitialKind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously, we processed associated types in the thing_inside in getInitialKind, -but this was wrong -- we want to do ATs sepearately. -The consequence for not doing it this way is #15142: - - class ListTuple (tuple :: Type) (as :: [(k, Type)]) where - type ListToTuple as :: Type - -We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify -kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring -`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't -unified with Type. And then, when we generalize the kind of ListToTuple (which -indeed has a CUSK, according to the rules), we skolemize the free metavariable -kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple, -because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1] -will unify with Type. - -Bottom line: as associated types should have no effect on a CUSK enclosing class, -we move processing them to a separate action, run after the outer kind has -been generalized. - --} - -kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM [TcTyCon] - --- Kind check this group, kind generalize, and return the resulting local env --- This binds the TyCons and Classes of the group, but not the DataCons --- See Note [Kind checking for type and class decls] --- and Note [Inferring kinds for type declarations] -kcTyClGroup kisig_env decls - = do { mod <- getModule - ; traceTc "---- kcTyClGroup ---- {" - (text "module" <+> ppr mod $$ vcat (map ppr decls)) - - -- Kind checking; - -- 1. Bind kind variables for decls - -- 2. Kind-check decls - -- 3. Generalise the inferred kinds - -- See Note [Kind checking for type and class decls] - - ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds - -- See Note [CUSKs and PolyKinds] - ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls - - get_kind d - | Just ki <- lookupNameEnv kisig_env (tcdName (unLoc d)) - = Right (d, SAKS ki) - - | cusks_enabled && hsDeclHasCusk (unLoc d) - = Right (d, CUSK) - - | otherwise = Left d - - ; checked_tcs <- checkInitialKinds kinded_decls - ; inferred_tcs - <- tcExtendKindEnvWithTyCons checked_tcs $ - pushTcLevelM_ $ -- We are going to kind-generalise, so - -- unification variables in here must - -- be one level in - solveEqualities $ - do { -- Step 1: Bind kind variables for all decls - mono_tcs <- inferInitialKinds kindless_decls - - ; traceTc "kcTyClGroup: initial kinds" $ - ppr_tc_kinds mono_tcs - - -- Step 2: Set extended envt, kind-check the decls - -- NB: the environment extension overrides the tycon - -- promotion-errors bindings - -- See Note [Type environment evolution] - ; tcExtendKindEnvWithTyCons mono_tcs $ - mapM_ kcLTyClDecl kindless_decls - - ; return mono_tcs } - - -- Step 3: generalisation - -- Finally, go through each tycon and give it its final kind, - -- with all the required, specified, and inferred variables - -- in order. - ; let inferred_tc_env = mkNameEnv $ - map (\tc -> (tyConName tc, tc)) inferred_tcs - ; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env) - kindless_decls - - ; let poly_tcs = checked_tcs ++ generalized_tcs - ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs) - ; return poly_tcs } - where - ppr_tc_kinds tcs = vcat (map pp_tc tcs) - pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc) - -type ScopedPairs = [(Name, TcTyVar)] - -- The ScopedPairs for a TcTyCon are precisely - -- specified-tvs ++ required-tvs - -- You can distinguish them because there are tyConArity required-tvs - -generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon] --- See Note [Swizzling the tyvars before generaliseTcTyCon] -generaliseTyClDecl inferred_tc_env (L _ decl) - = do { let names_in_this_decl :: [Name] - names_in_this_decl = tycld_names decl - - -- Extract the specified/required binders and skolemise them - ; tc_with_tvs <- mapM skolemise_tc_tycon names_in_this_decl - - -- Zonk, to manifest the side-effects of skolemisation to the swizzler - -- NB: it's important to skolemise them all before this step. E.g. - -- class C f where { type T (f :: k) } - -- We only skolemise k when looking at T's binders, - -- but k appears in f's kind in C's binders. - ; tc_infos <- mapM zonk_tc_tycon tc_with_tvs - - -- Swizzle - ; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos) - - -- And finally generalise - ; mapAndReportM generaliseTcTyCon swizzled_infos } - where - tycld_names :: TyClDecl GhcRn -> [Name] - tycld_names decl = tcdName decl : at_names decl - - at_names :: TyClDecl GhcRn -> [Name] - at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats - at_names _ = [] -- Only class decls have associated types - - skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs) - -- Zonk and skolemise the Specified and Required binders - skolemise_tc_tycon tc_name - = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name - -- This lookup should not fail - ; scoped_prs <- mapSndM zonkAndSkolemise (tcTyConScopedTyVars tc) - ; return (tc, scoped_prs) } - - zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind) - zonk_tc_tycon (tc, scoped_prs) - = do { scoped_prs <- mapSndM zonkTcTyVarToTyVar scoped_prs - -- We really have to do this again, even though - -- we have just done zonkAndSkolemise - ; res_kind <- zonkTcType (tyConResKind tc) - ; return (tc, scoped_prs, res_kind) } - -swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)] - -> TcM [(TcTyCon, ScopedPairs, TcKind)] -swizzleTcTyConBndrs tc_infos - | all no_swizzle swizzle_prs - -- This fast path happens almost all the time - -- See Note [Non-cloning for tyvar binders] in TcHsType - = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr (map fstOf3 tc_infos)) - ; return tc_infos } - - | otherwise - = do { check_duplicate_tc_binders - - ; traceTc "swizzleTcTyConBndrs" $ - vcat [ text "before" <+> ppr_infos tc_infos - , text "swizzle_prs" <+> ppr swizzle_prs - , text "after" <+> ppr_infos swizzled_infos ] - - ; return swizzled_infos } - - where - swizzled_infos = [ (tc, mapSnd swizzle_var scoped_prs, swizzle_ty kind) - | (tc, scoped_prs, kind) <- tc_infos ] - - swizzle_prs :: [(Name,TyVar)] - -- Pairs the user-specifed Name with its representative TyVar - -- See Note [Swizzling the tyvars before generaliseTcTyCon] - swizzle_prs = [ pr | (_, prs, _) <- tc_infos, pr <- prs ] - - no_swizzle :: (Name,TyVar) -> Bool - no_swizzle (nm, tv) = nm == tyVarName tv - - ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs) - | (tc, prs, _) <- infos ] - - -- Check for duplicates - -- E.g. data SameKind (a::k) (b::k) - -- data T (a::k1) (b::k2) = MkT (SameKind a b) - -- Here k1 and k2 start as TyVarTvs, and get unified with each other - -- If this happens, things get very confused later, so fail fast - check_duplicate_tc_binders :: TcM () - check_duplicate_tc_binders = unless (null err_prs) $ - do { mapM_ report_dup err_prs; failM } - - -------------- Error reporting ------------ - err_prs :: [(Name,Name)] - err_prs = [ (n1,n2) - | pr :| prs <- findDupsEq ((==) `on` snd) swizzle_prs - , (n1,_):(n2,_):_ <- [nubBy ((==) `on` fst) (pr:prs)] ] - -- This nubBy avoids bogus error reports when we have - -- [("f", f), ..., ("f",f)....] in swizzle_prs - -- which happens with class C f where { type T f } - - report_dup :: (Name,Name) -> TcM () - report_dup (n1,n2) - = setSrcSpan (getSrcSpan n2) $ addErrTc $ - hang (text "Different names for the same type variable:") 2 info - where - info | nameOccName n1 /= nameOccName n2 - = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2) - | otherwise -- Same OccNames! See C2 in - -- Note [Swizzling the tyvars before generaliseTcTyCon] - = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1) - , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ] - - -------------- The swizzler ------------ - -- This does a deep traverse, simply doing a - -- Name-to-Name change, governed by swizzle_env - -- The 'swap' is what gets from the representative TyVar - -- back to the original user-specified Name - swizzle_env = mkVarEnv (map swap swizzle_prs) - - swizzleMapper :: TyCoMapper () Identity - swizzleMapper = TyCoMapper { tcm_tyvar = swizzle_tv - , tcm_covar = swizzle_cv - , tcm_hole = swizzle_hole - , tcm_tycobinder = swizzle_bndr - , tcm_tycon = swizzle_tycon } - swizzle_hole _ hole = pprPanic "swizzle_hole" (ppr hole) - -- These types are pre-zonked - swizzle_tycon tc = pprPanic "swizzle_tc" (ppr tc) - -- TcTyCons can't appear in kinds (yet) - swizzle_tv _ tv = return (mkTyVarTy (swizzle_var tv)) - swizzle_cv _ cv = return (mkCoVarCo (swizzle_var cv)) - - swizzle_bndr _ tcv _ - = return ((), swizzle_var tcv) - - swizzle_var :: Var -> Var - swizzle_var v - | Just nm <- lookupVarEnv swizzle_env v - = updateVarType swizzle_ty (v `setVarName` nm) - | otherwise - = updateVarType swizzle_ty v - - (map_type, _, _, _) = mapTyCo swizzleMapper - swizzle_ty ty = runIdentity (map_type ty) - - -generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon -generaliseTcTyCon (tc, scoped_prs, tc_res_kind) - -- See Note [Required, Specified, and Inferred for types] - = setSrcSpan (getSrcSpan tc) $ - addTyConCtxt tc $ - do { -- Step 1: Separate Specified from Required variables - -- NB: spec_req_tvs = spec_tvs ++ req_tvs - -- And req_tvs is 1-1 with tyConTyVars - -- See Note [Scoped tyvars in a TcTyCon] in GHC.Core.TyCon - ; let spec_req_tvs = map snd scoped_prs - n_spec = length spec_req_tvs - tyConArity tc - (spec_tvs, req_tvs) = splitAt n_spec spec_req_tvs - sorted_spec_tvs = scopedSort spec_tvs - -- NB: We can't do the sort until we've zonked - -- Maintain the L-R order of scoped_tvs - - -- Step 2a: find all the Inferred variables we want to quantify over - ; dvs1 <- candidateQTyVarsOfKinds $ - (tc_res_kind : map tyVarKind spec_req_tvs) - ; let dvs2 = dvs1 `delCandidates` spec_req_tvs - - -- Step 2b: quantify, mainly meaning skolemise the free variables - -- Returned 'inferred' are scope-sorted and skolemised - ; inferred <- quantifyTyVars dvs2 - - ; traceTc "generaliseTcTyCon: pre zonk" - (vcat [ text "tycon =" <+> ppr tc - , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs - , text "tc_res_kind =" <+> ppr tc_res_kind - , text "dvs1 =" <+> ppr dvs1 - , text "inferred =" <+> pprTyVars inferred ]) - - -- Step 3: Final zonk (following kind generalisation) - -- See Note [Swizzling the tyvars before generaliseTcTyCon] - ; ze <- emptyZonkEnv - ; (ze, inferred) <- zonkTyBndrsX ze inferred - ; (ze, sorted_spec_tvs) <- zonkTyBndrsX ze sorted_spec_tvs - ; (ze, req_tvs) <- zonkTyBndrsX ze req_tvs - ; tc_res_kind <- zonkTcTypeToTypeX ze tc_res_kind - - ; traceTc "generaliseTcTyCon: post zonk" $ - vcat [ text "tycon =" <+> ppr tc - , text "inferred =" <+> pprTyVars inferred - , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs - , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs - , text "req_tvs =" <+> ppr req_tvs - , text "zonk-env =" <+> ppr ze ] - - -- Step 4: Make the TyConBinders. - ; let dep_fv_set = candidateKindVars dvs1 - inferred_tcbs = mkNamedTyConBinders Inferred inferred - specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs - required_tcbs = map (mkRequiredTyConBinder dep_fv_set) req_tvs - - -- Step 5: Assemble the final list. - final_tcbs = concat [ inferred_tcbs - , specified_tcbs - , required_tcbs ] - - -- Step 6: Make the result TcTyCon - tycon = mkTcTyCon (tyConName tc) final_tcbs tc_res_kind - (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs)) - True {- it's generalised now -} - (tyConFlavour tc) - - ; traceTc "generaliseTcTyCon done" $ - vcat [ text "tycon =" <+> ppr tc - , text "tc_res_kind =" <+> ppr tc_res_kind - , text "dep_fv_set =" <+> ppr dep_fv_set - , text "inferred_tcbs =" <+> ppr inferred_tcbs - , text "specified_tcbs =" <+> ppr specified_tcbs - , text "required_tcbs =" <+> ppr required_tcbs - , text "final_tcbs =" <+> ppr final_tcbs ] - - -- Step 7: Check for validity. - -- We do this here because we're about to put the tycon into the - -- the environment, and we don't want anything malformed there - ; checkTyConTelescope tycon - - ; return tycon } - -{- Note [Required, Specified, and Inferred for types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Each forall'd type variable in a type or kind is one of - - * Required: an argument must be provided at every call site - - * Specified: the argument can be inferred at call sites, but - may be instantiated with visible type/kind application - - * Inferred: the must be inferred at call sites; it - is unavailable for use with visible type/kind application. - -Why have Inferred at all? Because we just can't make user-facing -promises about the ordering of some variables. These might swizzle -around even between minor released. By forbidding visible type -application, we ensure users aren't caught unawares. - -Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. - -The question for this Note is this: - given a TyClDecl, how are its quantified type variables classified? -Much of the debate is memorialized in #15743. - -Here is our design choice. When inferring the ordering of variables -for a TyCl declaration (that is, for those variables that he user -has not specified the order with an explicit `forall`), we use the -following order: - - 1. Inferred variables - 2. Specified variables; in the left-to-right order in which - the user wrote them, modified by scopedSort (see below) - to put them in depdendency order. - 3. Required variables before a top-level :: - 4. All variables after a top-level :: - -If this ordering does not make a valid telescope, we reject the definition. - -Example: - data SameKind :: k -> k -> * - data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) - -For Bad: - - a, c, d, x are Required; they are explicitly listed by the user - as the positional arguments of Bad - - b is Specified; it appears explicitly in a kind signature - - k, the kind of a, is Inferred; it is not mentioned explicitly at all - -Putting variables in the order Inferred, Specified, Required -gives us this telescope: - Inferred: k - Specified: b : Proxy a - Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d) - -But this order is ill-scoped, because b's kind mentions a, which occurs -after b in the telescope. So we reject Bad. - -Associated types -~~~~~~~~~~~~~~~~ -For associated types everything above is determined by the -associated-type declaration alone, ignoring the class header. -Here is an example (#15592) - class C (a :: k) b where - type F (x :: b a) - -In the kind of C, 'k' is Specified. But what about F? -In the kind of F, - - * Should k be Inferred or Specified? It's Specified for C, - but not mentioned in F's declaration. - - * In which order should the Specified variables a and b occur? - It's clearly 'a' then 'b' in C's declaration, but the L-R ordering - in F's declaration is 'b' then 'a'. - -In both cases we make the choice by looking at F's declaration alone, -so it gets the kind - F :: forall {k}. forall b a. b a -> Type - -How it works -~~~~~~~~~~~~ -These design choices are implemented by two completely different code -paths for - - * Declarations with a standalone kind signature or a complete user-specified - kind signature (CUSK). Handled by the kcCheckDeclHeader. - - * Declarations without a kind signature (standalone or CUSK) are handled by - kcInferDeclHeader; see Note [Inferring kinds for type declarations]. - -Note that neither code path worries about point (4) above, as this -is nicely handled by not mangling the res_kind. (Mangling res_kinds is done -*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.) - -We can tell Inferred apart from Specified by looking at the scoped -tyvars; Specified are always included there. - -Design alternatives -~~~~~~~~~~~~~~~~~~~ -* For associated types we considered putting the class variables - before the local variables, in a nod to the treatment for class - methods. But it got too compilicated; see #15592, comment:21ff. - -* We rigidly require the ordering above, even though we could be much more - permissive. Relevant musings are at - https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623 - The bottom line conclusion is that, if the user wants a different ordering, - then can specify it themselves, and it is better to be predictable and dumb - than clever and capricious. - - I (Richard) conjecture we could be fully permissive, allowing all classes - of variables to intermix. We would have to augment ScopedSort to refuse to - reorder Required variables (or check that it wouldn't have). But this would - allow more programs. See #15743 for examples. Interestingly, Idris seems - to allow this intermixing. The intermixing would be fully specified, in that - we can be sure that inference wouldn't change between versions. However, - would users be able to predict it? That I cannot answer. - -Test cases (and tickets) relevant to these design decisions -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - T15591* - T15592* - T15743* - -Note [Inferring kinds for type declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This note deals with /inference/ for type declarations -that do not have a CUSK. Consider - data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x) - data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y) - -We do kind inference as follows: - -* Step 1: inferInitialKinds, and in particular kcInferDeclHeader. - Make a unification variable for each of the Required and Specified - type variables in the header. - - Record the connection between the Names the user wrote and the - fresh unification variables in the tcTyConScopedTyVars field - of the TcTyCon we are making - [ (a, aa) - , (k1, kk1) - , (k2, kk2) - , (x, xx) ] - (I'm using the convention that double letter like 'aa' or 'kk' - mean a unification variable.) - - These unification variables - - Are TyVarTvs: that is, unification variables that can - unify only with other type variables. - See Note [Signature skolems] in TcType - - - Have complete fresh Names; see TcMType - Note [Unification variables need fresh Names] - - Assign initial monomorphic kinds to S, T - T :: kk1 -> * -> kk2 -> * - S :: kk3 -> * -> kk4 -> * - -* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and - T, with these monomorphic kinds. Now kind-check the declarations, - and solve the resulting equalities. The goal here is to discover - constraints on all these unification variables. - - Here we find that kk1 := kk3, and kk2 := kk4. - - This is why we can't use skolems for kk1 etc; they have to - unify with each other. - -* Step 3: generaliseTcTyCon. Generalise each TyCon in turn. - We find the free variables of the kind, skolemise them, - sort them out into Inferred/Required/Specified (see the above - Note [Required, Specified, and Inferred for types]), - and perform some validity checks. - - This makes the utterly-final TyConBinders for the TyCon. - - All this is very similar at the level of terms: see TcBinds - Note [Quantified variables in partial type signatures] - - But there some tricky corners: Note [Tricky scoping in generaliseTcTyCon] - -* Step 4. Extend the type environment with a TcTyCon for S and T, now - with their utterly-final polymorphic kinds (needed for recursive - occurrences of S, T). Now typecheck the declarations, and build the - final AlgTyCon for S and T resp. - -The first three steps are in kcTyClGroup; the fourth is in -tcTyClDecls. - -There are some wrinkles - -* Do not default TyVarTvs. We always want to kind-generalise over - TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is - not allowed to unify with a type; it must stand for a type - variable. Hence the check in TcSimplify.defaultTyVarTcS, and - TcMType.defaultTyVar. Here's another example (#14555): - data Exp :: [TYPE rep] -> TYPE rep -> Type where - Lam :: Exp (a:xs) b -> Exp xs (a -> b) - We want to kind-generalise over the 'rep' variable. - #14563 is another example. - -* Duplicate type variables. Consider #11203 - data SameKind :: k -> k -> * - data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) - Here we will unify k1 with k2, but this time doing so is an error, - because k1 and k2 are bound in the same declaration. - - We spot this during validity checking (findDupTyVarTvs), - in generaliseTcTyCon. - -* Required arguments. Even the Required arguments should be made - into TyVarTvs, not skolems. Consider - data T k (a :: k) - Here, k is a Required, dependent variable. For uniformity, it is helpful - to have k be a TyVarTv, in parallel with other dependent variables. - -* Duplicate skolemisation is expected. When generalising in Step 3, - we may find that one of the variables we want to quantify has - already been skolemised. For example, suppose we have already - generalise S. When we come to T we'll find that kk1 (now the same as - kk3) has already been skolemised. - - That's fine -- but it means that - a) when collecting quantification candidates, in - candidateQTyVarsOfKind, we must collect skolems - b) quantifyTyVars should be a no-op on such a skolem - -Note [Tricky scoping in generaliseTcTyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider #16342 - class C (a::ka) x where - cop :: D a x => x -> Proxy a -> Proxy a - cop _ x = x :: Proxy (a::ka) - - class D (b::kb) y where - dop :: C b y => y -> Proxy b -> Proxy b - dop _ x = x :: Proxy (b::kb) - -C and D are mutually recursive, by the time we get to -generaliseTcTyCon we'll have unified kka := kkb. - -But when typechecking the default declarations for 'cop' and 'dop' in -tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope. -But at that point all we have is the utterly-final Class itself. - -Conclusion: the classTyVars of a class must have the same Name as -that originally assigned by the user. In our example, C must have -classTyVars {a, ka, x} while D has classTyVars {a, kb, y}. Despite -the fact that kka and kkb got unified! - -We achieve this sleight of hand in generaliseTcTyCon, using -the specialised function zonkRecTyVarBndrs. We make the call - zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx] -where the [ka,a,x] are the Names originally assigned by the user, and -[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars. -zonkRecTyVarBndrs builds a recursive ZonkEnv that binds - kkb :-> (ka :: <zonked kind of kkb>) - aa :-> (a :: <konked kind of aa>) - etc -That is, it maps each skolemised TcTyVars to the utterly-final -TyVar to put in the class, with its correct user-specified name. -When generalising D we'll do the same thing, but the ZonkEnv will map - kkb :-> (kb :: <zonked kind of kkb>) - bb :-> (b :: <konked kind of bb>) - etc -Note that 'kkb' again appears in the domain of the mapping, but this -time mapped to 'kb'. That's how C and D end up with differently-named -final TyVars despite the fact that we unified kka:=kkb - -zonkRecTyVarBndrs we need to do knot-tying because of the need to -apply this same substitution to the kind of each. - -Note [Inferring visible dependent quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T k :: k -> Type where - MkT1 :: T Type Int - MkT2 :: T (Type -> Type) Maybe - -This looks like it should work. However, it is polymorphically recursive, -as the uses of T in the constructor types specialize the k in the kind -of T. This trips up our dear users (#17131, #17541), and so we add -a "landmark" context (which cannot be suppressed) whenever we -spot inferred visible dependent quantification (VDQ). - -It's hard to know when we've actually been tripped up by polymorphic recursion -specifically, so we just include a note to users whenever we infer VDQ. The -testsuite did not show up a single spurious inclusion of this message. - -The context is added in addVDQNote, which looks for a visible TyConBinder -that also appears in the TyCon's kind. (I first looked at the kind for -a visible, dependent quantifier, but Note [No polymorphic recursion] in -TcHsType defeats that approach.) addVDQNote is used in kcTyClDecl, -which is used only when inferring the kind of a tycon (never with a CUSK or -SAK). - -Once upon a time, I (Richard E) thought that the tycon-kind could -not be a forall-type. But this is wrong: data T :: forall k. k -> Type -(with -XNoCUSKs) could end up here. And this is all OK. - - --} - --------------- -tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a -tcExtendKindEnvWithTyCons tcs - = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ] - --------------- -mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv --- Maps each tycon/datacon to a suitable promotion error --- tc :-> APromotionErr TyConPE --- dc :-> APromotionErr RecDataConPE --- See Note [Recursion and promoting data constructors] - -mkPromotionErrorEnv decls - = foldr (plusNameEnv . mk_prom_err_env . unLoc) - emptyNameEnv decls - -mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv -mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) - = unitNameEnv nm (APromotionErr ClassPE) - `plusNameEnv` - mkNameEnv [ (familyDeclName at, APromotionErr TyConPE) - | L _ at <- ats ] - -mk_prom_err_env (DataDecl { tcdLName = L _ name - , tcdDataDefn = HsDataDefn { dd_cons = cons } }) - = unitNameEnv name (APromotionErr TyConPE) - `plusNameEnv` - mkNameEnv [ (con, APromotionErr RecDataConPE) - | L _ con' <- cons - , L _ con <- getConNames con' ] - -mk_prom_err_env decl - = unitNameEnv (tcdName decl) (APromotionErr TyConPE) - -- Works for family declarations too - --------------- -inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon] --- Returns a TcTyCon for each TyCon bound by the decls, --- each with its initial kind - -inferInitialKinds decls - = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls) - ; tcs <- concatMapM infer_initial_kind decls - ; traceTc "inferInitialKinds done }" empty - ; return tcs } - where - infer_initial_kind = addLocM (getInitialKind InitialKindInfer) - --- Check type/class declarations against their standalone kind signatures or --- CUSKs, producing a generalized TcTyCon for each. -checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon] -checkInitialKinds decls - = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls) - ; tcs <- concatMapM check_initial_kind decls - ; traceTc "checkInitialKinds done }" empty - ; return tcs } - where - check_initial_kind (ldecl, msig) = - addLocM (getInitialKind (InitialKindCheck msig)) ldecl - --- | Get the initial kind of a TyClDecl, either generalized or non-generalized, --- depending on the 'InitialKindStrategy'. -getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon] - --- Allocate a fresh kind variable for each TyCon and Class --- For each tycon, return a TcTyCon with kind k --- where k is the kind of tc, derived from the LHS --- of the definition (and probably including --- kind unification variables) --- Example: data T a b = ... --- return (T, kv1 -> kv2 -> kv3) --- --- This pass deals with (ie incorporates into the kind it produces) --- * The kind signatures on type-variable binders --- * The result kinds signature on a TyClDecl --- --- No family instances are passed to checkInitialKinds/inferInitialKinds -getInitialKind strategy - (ClassDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdATs = ats }) - = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $ - return (TheKind constraintKind) - ; let parent_tv_prs = tcTyConScopedTyVars cls - -- See Note [Don't process associated types in getInitialKind] - ; inner_tcs <- - tcExtendNameTyVarEnv parent_tv_prs $ - mapM (addLocM (getAssocFamInitialKind cls)) ats - ; return (cls : inner_tcs) } - where - getAssocFamInitialKind cls = - case strategy of - InitialKindInfer -> get_fam_decl_initial_kind (Just cls) - InitialKindCheck _ -> check_initial_kind_assoc_fam cls - -getInitialKind strategy - (DataDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig - , dd_ND = new_or_data } }) - = do { let flav = newOrDataToFlavour new_or_data - ctxt = DataKindCtxt name - ; tc <- kcDeclHeader strategy name flav ktvs $ - case m_sig of - Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> return $ dataDeclDefaultResultKind new_or_data - ; return [tc] } - -getInitialKind InitialKindInfer (FamDecl { tcdFam = decl }) - = do { tc <- get_fam_decl_initial_kind Nothing decl - ; return [tc] } - -getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = - FamilyDecl { fdLName = unLoc -> name - , fdTyVars = ktvs - , fdResultSig = unLoc -> resultSig - , fdInfo = info } } ) - = do { let flav = getFamFlav Nothing info - ctxt = TyFamResKindCtxt name - ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $ - case famResultKindSignature resultSig of - Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> - case msig of - CUSK -> return (TheKind liftedTypeKind) - SAKS _ -> return AnyKind - ; return [tc] } - -getInitialKind strategy - (SynDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdRhs = rhs }) - = do { let ctxt = TySynKindCtxt name - ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $ - case hsTyKindSig rhs of - Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig - Nothing -> return AnyKind - ; return [tc] } - -getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec -getInitialKind _ (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec -getInitialKind _ (XTyClDecl nec) = noExtCon nec - -get_fam_decl_initial_kind - :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls - -> FamilyDecl GhcRn - -> TcM TcTyCon -get_fam_decl_initial_kind mb_parent_tycon - FamilyDecl { fdLName = L _ name - , fdTyVars = ktvs - , fdResultSig = L _ resultSig - , fdInfo = info } - = kcDeclHeader InitialKindInfer name flav ktvs $ - case resultSig of - KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki - TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki - _ -- open type families have * return kind by default - | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) - -- closed type families have their return kind inferred - -- by default - | otherwise -> return AnyKind - where - flav = getFamFlav mb_parent_tycon info - ctxt = TyFamResKindCtxt name -get_fam_decl_initial_kind _ (XFamilyDecl nec) = noExtCon nec - --- See Note [Standalone kind signatures for associated types] -check_initial_kind_assoc_fam - :: TcTyCon -- parent class - -> FamilyDecl GhcRn - -> TcM TcTyCon -check_initial_kind_assoc_fam cls - FamilyDecl - { fdLName = unLoc -> name - , fdTyVars = ktvs - , fdResultSig = unLoc -> resultSig - , fdInfo = info } - = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $ - case famResultKindSignature resultSig of - Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> return (TheKind liftedTypeKind) - where - ctxt = TyFamResKindCtxt name - flav = getFamFlav (Just cls) info -check_initial_kind_assoc_fam _ (XFamilyDecl nec) = noExtCon nec - -{- Note [Standalone kind signatures for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -If associated types had standalone kind signatures, would they wear them - ----------------------------+------------------------------ - like this? (OUT) | or like this? (IN) ----------------------------+------------------------------ - type T :: Type -> Type | class C a where - class C a where | type T :: Type -> Type - type T a | type T a - -The (IN) variant is syntactically ambiguous: - - class C a where - type T :: a -- standalone kind signature? - type T :: a -- declaration header? - -The (OUT) variant does not suffer from this issue, but it might not be the -direction in which we want to take Haskell: we seek to unify type families and -functions, and, by extension, associated types with class methods. And yet we -give class methods their signatures inside the class, not outside. Neither do -we have the counterpart of InstanceSigs for StandaloneKindSignatures. - -For now, we dodge the question by using CUSKs for associated types instead of -standalone kind signatures. This is a simple addition to the rule we used to -have before standalone kind signatures: - - old rule: associated type has a CUSK iff its parent class has a CUSK - new rule: associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature - --} - --- See Note [Data declaration default result kind] -dataDeclDefaultResultKind :: NewOrData -> ContextKind -dataDeclDefaultResultKind NewType = OpenKind - -- See Note [Implementation of UnliftedNewtypes], point <Error Messages>. -dataDeclDefaultResultKind DataType = TheKind liftedTypeKind - -{- Note [Data declaration default result kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When the user has not written an inline result kind annotation on a data -declaration, we assume it to be 'Type'. That is, the following declarations -D1 and D2 are considered equivalent: - - data D1 where ... - data D2 :: Type where ... - -The consequence of this assumption is that we reject D3 even though we -accept D4: - - data D3 where - MkD3 :: ... -> D3 param - - data D4 :: Type -> Type where - MkD4 :: ... -> D4 param - -However, there's a twist: for newtypes, we must relax -the assumed result kind to (TYPE r): - - newtype D5 where - MkD5 :: Int# -> D5 - -See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note -<Error Messages>. --} - ---------------------------------- -getFamFlav - :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls - -> FamilyInfo pass - -> TyConFlavour -getFamFlav mb_parent_tycon info = - case info of - DataFamily -> DataFamilyFlavour mb_parent_tycon - OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon - ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon] - ClosedTypeFamilyFlavour - -{- Note [Closed type family mb_parent_tycon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's no way to write a closed type family inside a class declaration: - - class C a where - type family F a where -- error: parse error on input ‘where’ - -In fact, it is not clear what the meaning of such a declaration would be. -Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing. --} - ------------------------------------------------------------------------- -kcLTyClDecl :: LTyClDecl GhcRn -> TcM () - -- See Note [Kind checking for type and class decls] - -- Called only for declarations without a signature (no CUSKs or SAKs here) -kcLTyClDecl (L loc decl) - = setSrcSpan loc $ - do { tycon <- tcLookupTcTyCon tc_name - ; traceTc "kcTyClDecl {" (ppr tc_name) - ; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification] - addErrCtxt (tcMkDeclCtxt decl) $ - kcTyClDecl decl tycon - ; traceTc "kcTyClDecl done }" (ppr tc_name) } - where - tc_name = tcdName decl - -kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM () --- This function is used solely for its side effect on kind variables --- NB kind signatures on the type variables and --- result kind signature have already been dealt with --- by inferInitialKind, so we can ignore them here. - -kcTyClDecl (DataDecl { tcdLName = (L _ name) - , tcdDataDefn = defn }) tyCon - | HsDataDefn { dd_cons = cons@((L _ (ConDeclGADT {})) : _) - , dd_ctxt = (L _ []) - , dd_ND = new_or_data } <- defn - = -- See Note [Implementation of UnliftedNewtypes] STEP 2 - kcConDecls new_or_data (tyConResKind tyCon) cons - - -- hs_tvs and dd_kindSig already dealt with in inferInitialKind - -- This must be a GADT-style decl, - -- (see invariants of DataDefn declaration) - -- so (a) we don't need to bring the hs_tvs into scope, because the - -- ConDecls bind all their own variables - -- (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it - - | HsDataDefn { dd_ctxt = ctxt - , dd_cons = cons - , dd_ND = new_or_data } <- defn - = bindTyClTyVars name $ \ _ _ _ -> - do { _ <- tcHsContext ctxt - ; kcConDecls new_or_data (tyConResKind tyCon) cons - } - -kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon - = bindTyClTyVars name $ \ _ _ res_kind -> - discardResult $ tcCheckLHsType rhs (TheKind res_kind) - -- NB: check against the result kind that we allocated - -- in inferInitialKinds. - -kcTyClDecl (ClassDecl { tcdLName = L _ name - , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon - = bindTyClTyVars name $ \ _ _ _ -> - do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM_ kc_sig) sigs } - where - kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty - kc_sig _ = return () - - skol_info = TyConSkol ClassFlavour name - -kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc --- closed type families look at their equations, but other families don't --- do anything here - = case fd_info of - ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns - _ -> return () -kcTyClDecl (FamDecl _ (XFamilyDecl nec)) _ = noExtCon nec -kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) _ = noExtCon nec -kcTyClDecl (XTyClDecl nec) _ = noExtCon nec - -------------------- - --- Type check the types of the arguments to a data constructor. --- This includes doing kind unification if the type is a newtype. --- See Note [Implementation of UnliftedNewtypes] for why we need --- the first two arguments. -kcConArgTys :: NewOrData -> Kind -> [LHsType GhcRn] -> TcM () -kcConArgTys new_or_data res_kind arg_tys = do - { let exp_kind = getArgExpKind new_or_data res_kind - ; mapM_ (flip tcCheckLHsType exp_kind . getBangType) arg_tys - -- See Note [Implementation of UnliftedNewtypes], STEP 2 - } - -kcConDecls :: NewOrData - -> Kind -- The result kind signature - -> [LConDecl GhcRn] -- The data constructors - -> TcM () -kcConDecls new_or_data res_kind cons - = mapM_ (wrapLocM_ (kcConDecl new_or_data final_res_kind)) cons - where - (_, final_res_kind) = splitPiTys res_kind - -- See Note [kcConDecls result kind] - --- Kind check a data constructor. In additional to the data constructor, --- we also need to know about whether or not its corresponding type was --- declared with data or newtype, and we need to know the result kind of --- this type. See Note [Implementation of UnliftedNewtypes] for why --- we need the first two arguments. -kcConDecl :: NewOrData - -> Kind -- Result kind of the type constructor - -- Usually Type but can be TYPE UnliftedRep - -- or even TYPE r, in the case of unlifted newtype - -> ConDecl GhcRn - -> TcM () -kcConDecl new_or_data res_kind (ConDeclH98 - { con_name = name, con_ex_tvs = ex_tvs - , con_mb_cxt = ex_ctxt, con_args = args }) - = addErrCtxt (dataConCtxtName [name]) $ - discardResult $ - bindExplicitTKBndrs_Tv ex_tvs $ - do { _ <- tcHsMbContext ex_ctxt - ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) - -- We don't need to check the telescope here, - -- because that's done in tcConDecl - } - -kcConDecl new_or_data res_kind (ConDeclGADT - { con_names = names, con_qvars = qtvs, con_mb_cxt = cxt - , con_args = args, con_res_ty = res_ty }) - | HsQTvs { hsq_ext = implicit_tkv_nms - , hsq_explicit = explicit_tkv_nms } <- qtvs - = -- Even though the GADT-style data constructor's type is closed, - -- we must still kind-check the type, because that may influence - -- the inferred kind of the /type/ constructor. Example: - -- data T f a where - -- MkT :: f a -> T f a - -- If we don't look at MkT we won't get the correct kind - -- for the type constructor T - addErrCtxt (dataConCtxtName names) $ - discardResult $ - bindImplicitTKBndrs_Tv implicit_tkv_nms $ - bindExplicitTKBndrs_Tv explicit_tkv_nms $ - -- Why "_Tv"? See Note [Kind-checking for GADTs] - do { _ <- tcHsMbContext cxt - ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) - ; _ <- tcHsOpenType res_ty - ; return () } -kcConDecl _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _) = noExtCon nec -kcConDecl _ _ (XConDecl nec) = noExtCon nec - -{- Note [kcConDecls result kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We might have e.g. - data T a :: Type -> Type where ... -or - newtype instance N a :: Type -> Type where .. -in which case, the 'res_kind' passed to kcConDecls will be - Type->Type - -We must look past those arrows, or even foralls, to the Type in the -corner, to pass to kcConDecl c.f. #16828. Hence the splitPiTys here. - -I am a bit concerned about tycons with a declaration like - data T a :: Type -> forall k. k -> Type where ... - -It does not have a CUSK, so kcInferDeclHeader will make a TcTyCon -with tyConResKind of Type -> forall k. k -> Type. Even that is fine: -the splitPiTys will look past the forall. But I'm bothered about -what if the type "in the corner" mentions k? This is incredibly -obscure but something like this could be bad: - data T a :: Type -> foral k. k -> TYPE (F k) where ... - -I bet we are not quite right here, but my brain suffered a buffer -overflow and I thought it best to nail the common cases right now. - -Note [Recursion and promoting data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't want to allow promotion in a strongly connected component -when kind checking. - -Consider: - data T f = K (f (K Any)) - -When kind checking the `data T' declaration the local env contains the -mappings: - T -> ATcTyCon <some initial kind> - K -> APromotionErr - -APromotionErr is only used for DataCons, and only used during type checking -in tcTyClGroup. - -Note [Kind-checking for GADTs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data Proxy a where - MkProxy1 :: forall k (b :: k). Proxy b - MkProxy2 :: forall j (c :: j). Proxy c - -It seems reasonable that this should be accepted. But something very strange -is going on here: when we're kind-checking this declaration, we need to unify -the kind of `a` with k and j -- even though k and j's scopes are local to the type of -MkProxy{1,2}. The best approach we've come up with is to use TyVarTvs during -the kind-checking pass. First off, note that it's OK if the kind-checking pass -is too permissive: we'll snag the problems in the type-checking pass later. -(This extra permissiveness might happen with something like - - data SameKind :: k -> k -> Type - data Bad a where - MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b) - -which would be accepted if k1 and k2 were TyVarTvs. This is correctly rejected -in the second pass, though. Test case: polykinds/TyVarTvKinds3) -Recall that the kind-checking pass exists solely to collect constraints -on the kinds and to power unification. - -To achieve the use of TyVarTvs, we must be careful to use specialized functions -that produce TyVarTvs, not ordinary skolems. This is why we need -kcExplicitTKBndrs and kcImplicitTKBndrs in TcHsType, separate from their -tc... variants. - -The drawback of this approach is sometimes it will accept a definition that -a (hypothetical) declarative specification would likely reject. As a general -rule, we don't want to allow polymorphic recursion without a CUSK. Indeed, -the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs -approach allows a limited form of polymorphic recursion *without* a CUSK. - -To wit: - data T a = forall k (b :: k). MkT (T b) Int - (test case: dependent/should_compile/T14066a) - -Note that this is polymorphically recursive, with the recursive occurrence -of T used at a kind other than a's kind. The approach outlined here accepts -this definition, because this kind is still a kind variable (and so the -TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a -way to describe exactly what declarations will be accepted and which will -be rejected (without a CUSK). However, the accepted definitions are indeed -well-kinded and any rejected definitions would be accepted with a CUSK, -and so this wrinkle need not cause anyone to lose sleep. - -************************************************************************ -* * -\subsection{Type checking} -* * -************************************************************************ - -Note [Type checking recursive type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At this point we have completed *kind-checking* of a mutually -recursive group of type/class decls (done in kcTyClGroup). However, -we discarded the kind-checked types (eg RHSs of data type decls); -note that kcTyClDecl returns (). There are two reasons: - - * It's convenient, because we don't have to rebuild a - kinded HsDecl (a fairly elaborate type) - - * It's necessary, because after kind-generalisation, the - TyCons/Classes may now be kind-polymorphic, and hence need - to be given kind arguments. - -Example: - data T f a = MkT (f a) (T f a) -During kind-checking, we give T the kind T :: k1 -> k2 -> * -and figure out constraints on k1, k2 etc. Then we generalise -to get T :: forall k. (k->*) -> k -> * -So now the (T f a) in the RHS must be elaborated to (T k f a). - -However, during tcTyClDecl of T (above) we will be in a recursive -"knot". So we aren't allowed to look at the TyCon T itself; we are only -allowed to put it (lazily) in the returned structures. But when -kind-checking the RHS of T's decl, we *do* need to know T's kind (so -that we can correctly elaboarate (T k f a). How can we get T's kind -without looking at T? Delicate answer: during tcTyClDecl, we extend - - *Global* env with T -> ATyCon (the (not yet built) final TyCon for T) - *Local* env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T) - -Then: - - * During TcHsType.tcTyVar we look in the *local* env, to get the - fully-known, not knot-tied TcTyCon for T. - - * Then, in TcHsSyn.zonkTcTypeToType (and zonkTcTyCon in particular) - we look in the *global* env to get the TyCon. - -This fancy footwork (with two bindings for T) is only necessary for the -TyCons or Classes of this recursive group. Earlier, finished groups, -live in the global env only. - -See also Note [Kind checking recursive type and class declarations] - -Note [Kind checking recursive type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before we can type-check the decls, we must kind check them. This -is done by establishing an "initial kind", which is a rather uninformed -guess at a tycon's kind (by counting arguments, mainly) and then -using this initial kind for recursive occurrences. - -The initial kind is stored in exactly the same way during -kind-checking as it is during type-checking (Note [Type checking -recursive type and class declarations]): in the *local* environment, -with ATcTyCon. But we still must store *something* in the *global* -environment. Even though we discard the result of kind-checking, we -sometimes need to produce error messages. These error messages will -want to refer to the tycons being checked, except that they don't -exist yet, and it would be Terribly Annoying to get the error messages -to refer back to HsSyn. So we create a TcTyCon and put it in the -global env. This tycon can print out its name and knows its kind, but -any other action taken on it will panic. Note that TcTyCons are *not* -knot-tied, unlike the rather valid but knot-tied ones that occur -during type-checking. - -Note [Declarations for wired-in things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For wired-in things we simply ignore the declaration -and take the wired-in information. That avoids complications. -e.g. the need to make the data constructor worker name for - a constraint tuple match the wired-in one - -Note [Implementation of UnliftedNewtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Expected behavior of UnliftedNewtypes: - -* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst -* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98 - -What follows is a high-level overview of the implementation of the -proposal. - -STEP 1: Getting the initial kind, as done by inferInitialKind. We have -two sub-cases: - -* With a SAK/CUSK: no change in kind-checking; the tycon is given the kind - the user writes, whatever it may be. - -* Without a SAK/CUSK: If there is no kind signature, the tycon is given - a kind `TYPE r`, for a fresh unification variable `r`. We do this even - when -XUnliftedNewtypes is not on; see <Error Messages>, below. - -STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs. -The key function here is kcConDecl, which looks at an individual constructor -declaration. When we are processing a newtype (but whether or not -XUnliftedNewtypes -is enabled; see <Error Messages>, below), we generate a correct ContextKind -for the checking argument types: see getArgExpKind. - -Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is -enabled (we use r0 to denote a unification variable): - -newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) -+ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0) - is the kind that inferInitialKind invented for (Foo rep). - -data Color = Red | Blue -type family Interpret (x :: Color) :: RuntimeRep where - Interpret 'Red = 'IntRep - Interpret 'Blue = 'WordRep -data family Foo (x :: Color) :: TYPE (Interpret x) -newtype instance Foo 'Red = FooRedC Int# -+ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep - -Note that, in the GADT case, we might have a kind signature with arrows -(newtype XYZ a b :: Type -> Type where ...). We want only the final -component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon -in kcTyClDecl. - -STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function -here is tcConDecl. Once again, we must use getArgExpKind to ensure that the -representation type's kind matches that of the newtype, for two reasons: - - A. It is possible that a GADT has a CUSK. (Note that this is *not* - possible for H98 types.) Recall that CUSK types don't go through - kcTyClDecl, so we might not have done this kind check. - B. We need to produce the coercion to put on the argument type - if the kinds are different (for both H98 and GADT). - -Example of (B): - -type family F a where - F Int = LiftedRep - -newtype N :: TYPE (F Int) where - MkN :: Int -> N - -We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where -axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the -newtype kind, which is the principal correctness condition for newtypes. - -Wrinkle: Consider (#17021, typecheck/should_fail/T17021) - - type family Id (x :: a) :: a where - Id x = x - - newtype T :: TYPE (Id LiftedRep) where - MkT :: Int -> T - - In the type of MkT, we must end with (Int |> TYPE (sym axId)) -> T, never Int -> (T |> - TYPE axId); otherwise, the result type of the constructor wouldn't match the - datatype. However, type-checking the HsType T might reasonably result in - (T |> hole). We thus must ensure that this cast is dropped, forcing the - type-checker to add one to the Int instead. - - Why is it always safe to drop the cast? This result type is type-checked by - tcHsOpenType, so its kind definitely looks like TYPE r, for some r. It is - important that even after dropping the cast, the type's kind has the form - TYPE r. This is guaranteed by restrictions on the kinds of datatypes. - For example, a declaration like `newtype T :: Id Type` is rejected: a - newtype's final kind always has the form TYPE r, just as we want. - -Note that this is possible in the H98 case only for a data family, because -the H98 syntax doesn't permit a kind signature on the newtype itself. - -There are also some changes for deailng with families: - -1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if - UnliftedNewtypes is on. This allows us to write things like: - data family Foo :: TYPE 'IntRep - -2. In a newtype instance (with -XUnliftedNewtypes), if the user does - not write a kind signature, we want to allow the possibility that - the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind. - This is done in tcDataFamInstHeader in TcInstDcls. Example: - - data family Bar (a :: RuntimeRep) :: TYPE a - newtype instance Bar 'IntRep = BarIntC Int# - newtype instance Bar 'WordRep :: TYPE 'WordRep where - BarWordC :: Word# -> Bar 'WordRep - - The data instance corresponding to IntRep does not specify a kind signature, - so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable). - The data instance corresponding to WordRep does have a kind signature, so - we use that kind signature. - -3. A data family and its newtype instance may be declared with slightly - different kinds. See point 7 in Note [Datatype return kinds]. - -There's also a change in the renamer: - -* In GHC.RenameSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means - for a newtype to have a CUSK. This is necessary since UnliftedNewtypes - means that, for newtypes without kind signatures, we must use the field - inside the data constructor to determine the result kind. - See Note [Unlifted Newtypes and CUSKs] for more detail. - -For completeness, it was also necessary to make coerce work on -unlifted types, resolving #13595. - -<Error Messages>: It's tempting to think that the expected kind for a newtype -constructor argument when -XUnliftedNewtypes is *not* enabled should just be Type. -But this leads to difficulty in suggesting to enable UnliftedNewtypes. Here is -an example: - - newtype A = MkA Int# - -If we expect the argument to MkA to have kind Type, then we get a kind-mismatch -error. The problem is that there is no way to connect this mismatch error to --XUnliftedNewtypes, and suggest enabling the extension. So, instead, we allow -the A to type-check, but then find the problem when doing validity checking (and -where we get make a suitable error message). One potential worry is - - {-# LANGUAGE PolyKinds #-} - newtype B a = MkB a - -This turns out OK, because unconstrained RuntimeReps default to LiftedRep, just -as we would like. Another potential problem comes in a case like - - -- no UnliftedNewtypes - - data family D :: k - newtype instance D = MkD Any - -Here, we want inference to tell us that k should be instantiated to Type in -the instance. With the approach described here (checking for Type only in -the validity checker), that will not happen. But I cannot think of a non-contrived -example that will notice this lack of inference, so it seems better to improve -error messages than be able to infer this instantiation. - --} - -tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) -tcTyClDecl roles_info (L loc decl) - | Just thing <- wiredInNameTyThing_maybe (tcdName decl) - = case thing of -- See Note [Declarations for wired-in things] - ATyCon tc -> return (tc, wiredInDerivInfo tc decl) - _ -> pprPanic "tcTyClDecl" (ppr thing) - - | otherwise - = setSrcSpan loc $ tcAddDeclCtxt decl $ - do { traceTc "---- tcTyClDecl ---- {" (ppr decl) - ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl - ; traceTc "---- tcTyClDecl end ---- }" (ppr tc) - ; return (tc, deriv_infos) } - -noDerivInfos :: a -> (a, [DerivInfo]) -noDerivInfos a = (a, []) - -wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo] -wiredInDerivInfo tycon decl - | DataDecl { tcdDataDefn = dataDefn } <- decl - , HsDataDefn { dd_derivs = derivs } <- dataDefn - = [ DerivInfo { di_rep_tc = tycon - , di_scoped_tvs = - if isFunTyCon tycon || isPrimTyCon tycon - then [] -- no tyConTyVars - else mkTyVarNamePairs (tyConTyVars tycon) - , di_clauses = unLoc derivs - , di_ctxt = tcMkDeclCtxt decl } ] -wiredInDerivInfo _ _ = [] - - -- "type family" declarations -tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) -tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) - = fmap noDerivInfos $ - tcFamDecl1 parent fd - - -- "type" synonym declaration -tcTyClDecl1 _parent roles_info - (SynDecl { tcdLName = L _ tc_name - , tcdRhs = rhs }) - = ASSERT( isNothing _parent ) - fmap noDerivInfos $ - tcTySynRhs roles_info tc_name rhs - - -- "data/newtype" declaration -tcTyClDecl1 _parent roles_info - decl@(DataDecl { tcdLName = L _ tc_name - , tcdDataDefn = defn }) - = ASSERT( isNothing _parent ) - tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn - -tcTyClDecl1 _parent roles_info - (ClassDecl { tcdLName = L _ class_name - , tcdCtxt = hs_ctxt - , tcdMeths = meths - , tcdFDs = fundeps - , tcdSigs = sigs - , tcdATs = ats - , tcdATDefs = at_defs }) - = ASSERT( isNothing _parent ) - do { clas <- tcClassDecl1 roles_info class_name hs_ctxt - meths fundeps sigs ats at_defs - ; return (noDerivInfos (classTyCon clas)) } - -tcTyClDecl1 _ _ (XTyClDecl nec) = noExtCon nec - - -{- ********************************************************************* -* * - Class declarations -* * -********************************************************************* -} - -tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn - -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn] - -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn] - -> TcM Class -tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs - = fixM $ \ clas -> - -- We need the knot because 'clas' is passed into tcClassATs - bindTyClTyVars class_name $ \ _ binders res_kind -> - do { checkClassKindSig res_kind - ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders) - ; let tycon_name = class_name -- We use the same name - roles = roles_info tycon_name -- for TyCon and Class - - ; (ctxt, fds, sig_stuff, at_stuff) - <- pushTcLevelM_ $ - solveEqualities $ - checkTvConstraints skol_info (binderVars binders) $ - -- The checkTvConstraints is needed bring into scope the - -- skolems bound by the class decl header (#17841) - do { ctxt <- tcHsContext hs_ctxt - ; fds <- mapM (addLocM tc_fundep) fundeps - ; sig_stuff <- tcClassSigs class_name sigs meths - ; at_stuff <- tcClassATs class_name clas ats at_defs - ; return (ctxt, fds, sig_stuff, at_stuff) } - - -- The solveEqualities will report errors for any - -- unsolved equalities, so these zonks should not encounter - -- any unfilled coercion variables unless there is such an error - -- The zonk also squeeze out the TcTyCons, and converts - -- Skolems to tyvars. - ; ze <- emptyZonkEnv - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff - -- ToDo: do we need to zonk at_stuff? - - -- TODO: Allow us to distinguish between abstract class, - -- and concrete class with no methods (maybe by - -- specifying a trailing where or not - - ; mindef <- tcClassMinimalDef class_name sigs sig_stuff - ; is_boot <- tcIsHsBootOrSig - ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff - = Nothing - | otherwise - = Just (ctxt, at_stuff, sig_stuff, mindef) - - ; clas <- buildClass class_name binders roles fds body - ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$ - ppr fds) - ; return clas } - where - skol_info = TyConSkol ClassFlavour class_name - tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; - ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; - ; return (tvs1', tvs2') } - - -{- Note [Associated type defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The following is an example of associated type defaults: - class C a where - data D a - - type F a b :: * - type F a b = [a] -- Default - -Note that we can get default definitions only for type families, not data -families. --} - -tcClassATs :: Name -- The class name (not knot-tied) - -> Class -- The class parent of this associated type - -> [LFamilyDecl GhcRn] -- Associated types. - -> [LTyFamDefltDecl GhcRn] -- Associated type defaults. - -> TcM [ClassATItem] -tcClassATs class_name cls ats at_defs - = do { -- Complain about associated type defaults for non associated-types - sequence_ [ failWithTc (badATErr class_name n) - | n <- map at_def_tycon at_defs - , not (n `elemNameSet` at_names) ] - ; mapM tc_at ats } - where - at_def_tycon :: LTyFamDefltDecl GhcRn -> Name - at_def_tycon = tyFamInstDeclName . unLoc - - at_fam_name :: LFamilyDecl GhcRn -> Name - at_fam_name = familyDeclName . unLoc - - at_names = mkNameSet (map at_fam_name ats) - - at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn] - -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' - at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv - (at_def_tycon at_def) [at_def]) - emptyNameEnv at_defs - - tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at - ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) - `orElse` [] - ; atd <- tcDefaultAssocDecl fam_tc at_defs - ; return (ATI fam_tc atd) } - -------------------------- -tcDefaultAssocDecl :: - TyCon -- ^ Family TyCon (not knot-tied) - -> [LTyFamDefltDecl GhcRn] -- ^ Defaults - -> TcM (Maybe (KnotTied Type, SrcSpan)) -- ^ Type checked RHS -tcDefaultAssocDecl _ [] - = return Nothing -- No default declaration - -tcDefaultAssocDecl _ (d1:_:_) - = failWithTc (text "More than one default declaration for" - <+> ppr (tyFamInstDeclName (unLoc d1))) - -tcDefaultAssocDecl fam_tc - [L loc (TyFamInstDecl { tfid_eqn = - HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = L _ tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }}})] - = -- See Note [Type-checking default assoc decls] - setSrcSpan loc $ - tcAddFamInstCtxt (text "default type instance") tc_name $ - do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name) - ; let fam_tc_name = tyConName fam_tc - vis_arity = length (tyConVisibleTyVars fam_tc) - vis_pats = numVisibleArgs hs_pats - - -- Kind of family check - ; ASSERT( fam_tc_name == tc_name ) - checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - - -- Arity check - ; checkTc (vis_pats == vis_arity) - (wrongNumberOfParmsErr vis_arity) - - -- Typecheck RHS - -- - -- You might think we should pass in some AssocInstInfo, as we're looking - -- at an associated type. But this would be wrong, because an associated - -- type default LHS can mention *different* type variables than the - -- enclosing class. So it's treated more as a freestanding beast. - ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated - imp_vars (mb_expl_bndrs `orElse` []) - hs_pats hs_rhs_ty - - ; let fam_tvs = tyConTyVars fam_tc - ppr_eqn = ppr_default_eqn pats rhs_ty - pats_vis = tyConArgFlags fam_tc pats - ; traceTc "tcDefaultAssocDecl 2" (vcat - [ text "fam_tvs" <+> ppr fam_tvs - , text "qtvs" <+> ppr qtvs - , text "pats" <+> ppr pats - , text "rhs_ty" <+> ppr rhs_ty - ]) - ; pat_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis - ; check_all_distinct_tvs ppr_eqn $ zip pat_tvs pats_vis - ; let subst = zipTvSubst pat_tvs (mkTyVarTys fam_tvs) - ; pure $ Just (substTyUnchecked subst rhs_ty, loc) - -- We also perform other checks for well-formedness and validity - -- later, in checkValidClass - } - where - -- Checks that a pattern on the LHS of a default is a type - -- variable. If so, return the underlying type variable, and if - -- not, throw an error. - -- See Note [Type-checking default assoc decls] - extract_tv :: SDoc -- The pretty-printed default equation - -- (only used for error message purposes) - -> Type -- The particular type pattern from which to extract - -- its underlying type variable - -> ArgFlag -- The visibility of the type pattern - -- (only used for error message purposes) - -> TcM TyVar - extract_tv ppr_eqn pat pat_vis = - case getTyVar_maybe pat of - Just tv -> pure tv - Nothing -> failWithTc $ - pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ - hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") - 2 (vcat [ppr_eqn, suggestion]) - - - -- Checks that no type variables in an associated default declaration are - -- duplicated. If that is the case, throw an error. - -- See Note [Type-checking default assoc decls] - check_all_distinct_tvs :: - SDoc -- The pretty-printed default equation (only used - -- for error message purposes) - -> [(TyVar, ArgFlag)] -- The type variable arguments in the associated - -- default declaration, along with their respective - -- visibilities (the latter are only used for error - -- message purposes) - -> TcM () - check_all_distinct_tvs ppr_eqn pat_tvs_vis = - let dups = findDupsEq ((==) `on` fst) pat_tvs_vis in - traverse_ - (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $ - pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ - hang (text "Illegal duplicate variable" - <+> quotes (ppr pat_tv) <+> text "in:") - 2 (vcat [ppr_eqn, suggestion])) - dups - - ppr_default_eqn :: [Type] -> Type -> SDoc - ppr_default_eqn pats rhs_ty = - quotes (text "type" <+> ppr (mkTyConApp fam_tc pats) - <+> equals <+> ppr rhs_ty) - - suggestion :: SDoc - suggestion = text "The arguments to" <+> quotes (ppr fam_tc) - <+> text "must all be distinct type variables" - -tcDefaultAssocDecl _ [L _ (TyFamInstDecl (HsIB _ (XFamEqn x)))] = noExtCon x -tcDefaultAssocDecl _ [L _ (TyFamInstDecl (XHsImplicitBndrs x))] = noExtCon x - - -{- Note [Type-checking default assoc decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this default declaration for an associated type - - class C a where - type F (a :: k) b :: Type - type F (x :: j) y = Proxy x -> y - -Note that the class variable 'a' doesn't scope over the default assoc -decl (rather oddly I think), and (less oddly) neither does the second -argument 'b' of the associated type 'F', or the kind variable 'k'. -Instead, the default decl is treated more like a top-level type -instance. - -However we store the default rhs (Proxy x -> y) in F's TyCon, using -F's own type variables, so we need to convert it to (Proxy a -> b). -We do this by creating a substitution [j |-> k, x |-> a, b |-> y] and -applying this substitution to the RHS. - -In order to create this substitution, we must first ensure that all of -the arguments in the default instance consist of distinct type variables. -One might think that this is a simple task that could be implemented earlier -in the compiler, perhaps in the parser or the renamer. However, there are some -tricky corner cases that really do require the full power of typechecking to -weed out, as the examples below should illustrate. - -First, we must check that all arguments are type variables. As a motivating -example, consider this erroneous program (inspired by #11361): - - class C a where - type F (a :: k) b :: Type - type F x b = x - -If you squint, you'll notice that the kind of `x` is actually Type. However, -we cannot substitute from [Type |-> k], so we reject this default. - -Next, we must check that all arguments are distinct. Here is another offending -example, this time taken from #13971: - - class C2 (a :: j) where - type F2 (a :: j) (b :: k) - type F2 (x :: z) y = SameKind x y - data SameKind :: k -> k -> Type - -All of the arguments in the default equation for `F2` are type variables, so -that passes the first check. However, if we were to build this substitution, -then both `j` and `k` map to `z`! In terms of visible kind application, it's as -if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear -that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is -also rejected. - -Since the LHS of an associated type family default is always just variables, -it won't contain any tycons. Accordingly, the patterns used in the substitution -won't actually be knot-tied, even though we're in the knot. This is too -delicate for my taste, but it works. - -Note [Datatype return kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several poorly lit corners around datatype/newtype return kinds. -This Note explains these. Within this note, always understand "instance" -to mean data or newtype instance, and understand "family" to mean data -family. No type families or classes here. Some examples: - -data T a :: <kind> where ... -- See Point 4 -newtype T a :: <kind> where ... -- See Point 5 - -data family T a :: <kind> -- See Point 6 - -data instance T [a] :: <kind> where ... -- See Point 4 -newtype instance T [a] :: <kind> where ... -- See Point 5 - -1. Where this applies: Only GADT syntax for data/newtype/instance declarations - can have declared return kinds. This Note does not apply to Haskell98 - syntax. - -2. Where these kinds come from: Return kinds are processed through several - different code paths: - - data/newtypes: The return kind is part of the TyCon kind, gotten either - by checkInitialKind (standalone kind signature / CUSK) or - inferInitialKind. It is extracted by bindTyClTyVars in tcTyClDecl1. It is - then passed to tcDataDefn. - - families: The return kind is either written in a standalone signature - or extracted from a family declaration in getInitialKind. - If a family declaration is missing a result kind, it is assumed to be - Type. This assumption is in getInitialKind for CUSKs or - get_fam_decl_initial_kind for non-signature & non-CUSK cases. - - instances: The data family already has a known kind. The return kind - of an instance is then calculated by applying the data family tycon - to the patterns provided, as computed by the typeKind lhs_ty in the - end of tcDataFamInstHeader. In the case of an instance written in GADT - syntax, there are potentially *two* return kinds: the one computed from - applying the data family tycon to the patterns, and the one given by - the user. This second kind is checked by the tc_kind_sig function within - tcDataFamInstHeader. - -3. Eta-expansion: Any forall-bound variables and function arguments in a result kind - become parameters to the type. That is, when we say - - data T a :: Type -> Type where ... - - we really mean for T to have two parameters. The second parameter - is produced by processing the return kind in etaExpandAlgTyCon, - called in tcDataDefn for data/newtypes and in tcDataFamInstDecl - for instances. This is true for data families as well, though their - arity only matters for pretty-printing. - - See also Note [TyConBinders for the result kind signatures of a data type] - in TcHsType. - -4. Datatype return kind restriction: A data/data-instance return kind must end - in a type that, after type-synonym expansion, yields `TYPE LiftedRep`. By - "end in", we mean we strip any foralls and function arguments off before - checking: this remaining part of the type is returned from - etaExpandAlgTyCon. Note that we do *not* do type family reduction here. - Examples: - - data T1 :: Type -- good - data T2 :: Bool -> Type -- good - data T3 :: Bool -> forall k. Type -- strange, but still accepted - data T4 :: forall k. k -> Type -- good - data T5 :: Bool -- bad - data T6 :: Type -> Bool -- bad - - type Arrow = (->) - data T7 :: Arrow Bool Type -- good - - type family ARROW where - ARROW = (->) - data T8 :: ARROW Bool Type -- bad - - type Star = Type - data T9 :: Bool -> Star -- good - - type family F a where - F Int = Bool - F Bool = Type - data T10 :: Bool -> F Bool -- bad - - This check is done in checkDataKindSig. For data declarations, this - call is in tcDataDefn; for data instances, this call is in tcDataFamInstDecl. - - However, because data instances in GADT syntax can have two return kinds (see - point (2) above), we must check both return kinds. The user-written return - kind is checked in tc_kind_sig within tcDataFamInstHeader. Examples: - - data family D (a :: Nat) :: k -- good (see Point 6) - - data instance D 1 :: Type -- good - data instance D 2 :: F Bool -- bad - -5. Newtype return kind restriction: If -XUnliftedNewtypes is on, then - a newtype/newtype-instance return kind must end in TYPE xyz, for some - xyz (after type synonym expansion). The "xyz" may include type families, - but the TYPE part must be visible with expanding type families (only synonyms). - This kind is unified with the kind of the representation type (the type - of the one argument to the one constructor). See also steps (2) and (3) - of Note [Implementation of UnliftedNewtypes]. - - If -XUnliftedNewtypes is not on, then newtypes are treated just like datatypes. - - The checks are done in the same places as for datatypes. - Examples (assume -XUnliftedNewtypes): - - newtype N1 :: Type -- good - newtype N2 :: Bool -> Type -- good - newtype N3 :: forall r. Bool -> TYPE r -- good - - type family F (t :: Type) :: RuntimeRep - newtype N4 :: forall t -> TYPE (F t) -- good - - type family STAR where - STAR = Type - newtype N5 :: Bool -> STAR -- bad - -6. Family return kind restrictions: The return kind of a data family must - be either TYPE xyz (for some xyz) or a kind variable. The idea is that - instances may specialise the kind variable to fit one of the restrictions - above. This is checked by the call to checkDataKindSig in tcFamDecl1. - Examples: - - data family D1 :: Type -- good - data family D2 :: Bool -> Type -- good - data family D3 k :: k -- good - data family D4 :: forall k -> k -- good - data family D5 :: forall k. k -> k -- good - data family D6 :: forall r. TYPE r -- good - data family D7 :: Bool -> STAR -- bad (see STAR from point 5) - -7. Two return kinds for instances: If an instance has two return kinds, - one from the family declaration and one from the instance declaration - (see point (2) above), they are unified. More accurately, we make sure - that the kind of the applied data family is a subkind of the user-written - kind. TcHsType.checkExpectedKind normally does this check for types, but - that's overkill for our needs here. Instead, we just instantiate any - invisible binders in the (instantiated) kind of the data family - (called lhs_kind in tcDataFamInstHeader) with tcInstInvisibleTyBinders - and then unify the resulting kind with the kind written by the user. - This unification naturally produces a coercion, which we can drop, as - the kind annotation on the instance is redundant (except perhaps for - effects of unification). - - Example: - - data Color = Red | Blue - type family Interpret (x :: Color) :: RuntimeRep where - Interpret 'Red = 'IntRep - Interpret 'Blue = 'WordRep - data family Foo (x :: Color) :: TYPE (Interpret x) - newtype instance Foo 'Red :: TYPE IntRep where - FooRedC :: Int# -> Foo 'Red - - Here we get that Foo 'Red :: TYPE (Interpret Red) and we have to - unify the kind with TYPE IntRep. - - Example requiring subkinding: - - data family D :: forall k. k - data instance D :: Type -- forall k. k <: Type - data instance D :: Type -> Type -- forall k. k <: Type -> Type - -- NB: these do not overlap - - This all is Wrinkle (3) in Note [Implementation of UnliftedNewtypes]. - --} - -{- ********************************************************************* -* * - Type family declarations -* * -********************************************************************* -} - -tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon -tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info - , fdLName = tc_lname@(L _ tc_name) - , fdResultSig = L _ sig - , fdInjectivityAnn = inj }) - | DataFamily <- fam_info - = bindTyClTyVars tc_name $ \ _ binders res_kind -> do - { traceTc "data family:" (ppr tc_name) - ; checkFamFlag tc_name - - -- Check that the result kind is OK - -- We allow things like - -- data family T (a :: Type) :: forall k. k -> Type - -- We treat T as having arity 1, but result kind forall k. k -> Type - -- But we want to check that the result kind finishes in - -- Type or a kind-variable - -- For the latter, consider - -- data family D a :: forall k. Type -> k - -- When UnliftedNewtypes is enabled, we loosen this restriction - -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1). - -- See also Note [Datatype return kinds] - ; let (_, final_res_kind) = splitPiTys res_kind - ; checkDataKindSig DataFamilySort final_res_kind - ; tc_rep_name <- newTyConRepName tc_name - ; let inj = Injective $ replicate (length binders) True - tycon = mkFamilyTyCon tc_name binders - res_kind - (resultVariableName sig) - (DataFamilyTyCon tc_rep_name) - parent inj - ; return tycon } - - | OpenTypeFamily <- fam_info - = bindTyClTyVars tc_name $ \ _ binders res_kind -> do - { traceTc "open type family:" (ppr tc_name) - ; checkFamFlag tc_name - ; inj' <- tcInjectivity binders inj - ; checkResultSigFlag tc_name sig -- check after injectivity for better errors - ; let tycon = mkFamilyTyCon tc_name binders res_kind - (resultVariableName sig) OpenSynFamilyTyCon - parent inj' - ; return tycon } - - | ClosedTypeFamily mb_eqns <- fam_info - = -- Closed type families are a little tricky, because they contain the definition - -- of both the type family and the equations for a CoAxiom. - do { traceTc "Closed type family:" (ppr tc_name) - -- the variables in the header scope only over the injectivity - -- declaration but this is not involved here - ; (inj', binders, res_kind) - <- bindTyClTyVars tc_name $ \ _ binders res_kind -> - do { inj' <- tcInjectivity binders inj - ; return (inj', binders, res_kind) } - - ; checkFamFlag tc_name -- make sure we have -XTypeFamilies - ; checkResultSigFlag tc_name sig - - -- If Nothing, this is an abstract family in a hs-boot file; - -- but eqns might be empty in the Just case as well - ; case mb_eqns of - Nothing -> - return $ mkFamilyTyCon tc_name binders res_kind - (resultVariableName sig) - AbstractClosedSynFamilyTyCon parent - inj' - Just eqns -> do { - - -- Process the equations, creating CoAxBranches - ; let tc_fam_tc = mkTcTyCon tc_name binders res_kind - noTcTyConScopedTyVars - False {- this doesn't matter here -} - ClosedTypeFamilyFlavour - - ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns - -- Do not attempt to drop equations dominated by earlier - -- ones here; in the case of mutual recursion with a data - -- type, we get a knot-tying failure. Instead we check - -- for this afterwards, in TcValidity.checkValidCoAxiom - -- Example: tc265 - - -- Create a CoAxiom, with the correct src location. - ; co_ax_name <- newFamInstAxiomName tc_lname [] - - ; let mb_co_ax - | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list - | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) - - fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig) - (ClosedSynFamilyTyCon mb_co_ax) parent inj' - - -- We check for instance validity later, when doing validity - -- checking for the tycon. Exception: checking equations - -- overlap done by dropDominatedAxioms - ; return fam_tc } } - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker -#endif -tcFamDecl1 _ (XFamilyDecl nec) = noExtCon nec - --- | Maybe return a list of Bools that say whether a type family was declared --- injective in the corresponding type arguments. Length of the list is equal to --- the number of arguments (including implicit kind/coercion arguments). --- True on position --- N means that a function is injective in its Nth argument. False means it is --- not. -tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) - -> TcM Injectivity -tcInjectivity _ Nothing - = return NotInjective - - -- User provided an injectivity annotation, so for each tyvar argument we - -- check whether a type family was declared injective in that argument. We - -- return a list of Bools, where True means that corresponding type variable - -- was mentioned in lInjNames (type family is injective in that argument) and - -- False means that it was not mentioned in lInjNames (type family is not - -- injective in that type variable). We also extend injectivity information to - -- kind variables, so if a user declares: - -- - -- type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a - -- - -- then we mark both `a` and `k1` as injective. - -- NB: the return kind is considered to be *input* argument to a type family. - -- Since injectivity allows to infer input arguments from the result in theory - -- we should always mark the result kind variable (`k3` in this example) as - -- injective. The reason is that result type has always an assigned kind and - -- therefore we can always infer the result kind if we know the result type. - -- But this does not seem to be useful in any way so we don't do it. (Another - -- reason is that the implementation would not be straightforward.) -tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) - = setSrcSpan loc $ - do { let tvs = binderVars tcbs - ; dflags <- getDynFlags - ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) - (text "Illegal injectivity annotation" $$ - text "Use TypeFamilyDependencies to allow this") - ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames - ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds - ; let inj_ktvs = filterVarSet isTyVar $ -- no injective coercion vars - closeOverKinds (mkVarSet inj_tvs) - ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs - ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs - , ppr inj_ktvs, ppr inj_bools ]) - ; return $ Injective inj_bools } - -tcTySynRhs :: RolesInfo -> Name - -> LHsType GhcRn -> TcM TyCon -tcTySynRhs roles_info tc_name hs_ty - = bindTyClTyVars tc_name $ \ _ binders res_kind -> - do { env <- getLclEnv - ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) - ; rhs_ty <- pushTcLevelM_ $ - solveEqualities $ - tcCheckLHsType hs_ty (TheKind res_kind) - ; rhs_ty <- zonkTcTypeToType rhs_ty - ; let roles = roles_info tc_name - tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty - ; return tycon } - -tcDataDefn :: SDoc -> RolesInfo -> Name - -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo]) - -- NB: not used for newtype/data instances (whether associated or not) -tcDataDefn err_ctxt roles_info tc_name - (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = ctxt - , dd_kindSig = mb_ksig -- Already in tc's kind - -- via inferInitialKinds - , dd_cons = cons - , dd_derivs = derivs }) - = bindTyClTyVars tc_name $ \ tctc tycon_binders res_kind -> - -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need - -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon' - -- - -- The TyCon tyvars must scope over - -- - the stupid theta (dd_ctxt) - -- - for H98 constructors only, the ConDecl - -- But it does no harm to bring them into scope - -- over GADT ConDecls as well; and it's awkward not to - do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons - -- see Note [Datatype return kinds] - ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind - - ; tcg_env <- getGblEnv - ; let hsc_src = tcg_src tcg_env - ; unless (mk_permissive_kind hsc_src cons) $ - checkDataKindSig (DataDeclSort new_or_data) final_res_kind - - ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt - ; stupid_theta <- zonkTcTypesToTypes stupid_tc_theta - ; kind_signatures <- xoptM LangExt.KindSignatures - - -- Check that we don't use kind signatures without Glasgow extensions - ; when (isJust mb_ksig) $ - checkTc (kind_signatures) (badSigTyDecl tc_name) - - ; tycon <- fixM $ \ tycon -> do - { let final_bndrs = tycon_binders `chkAppend` extra_bndrs - res_ty = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs)) - roles = roles_info tc_name - ; data_cons <- tcConDecls - tycon - new_or_data - final_bndrs - final_res_kind - res_ty - cons - ; tc_rhs <- mk_tc_rhs hsc_src tycon data_cons - ; tc_rep_nm <- newTyConRepName tc_name - ; return (mkAlgTyCon tc_name - final_bndrs - final_res_kind - roles - (fmap unLoc cType) - stupid_theta tc_rhs - (VanillaAlgTyCon tc_rep_nm) - gadt_syntax) } - ; let deriv_info = DerivInfo { di_rep_tc = tycon - , di_scoped_tvs = tcTyConScopedTyVars tctc - , di_clauses = unLoc derivs - , di_ctxt = err_ctxt } - ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs) - ; return (tycon, [deriv_info]) } - where - -- Abstract data types in hsig files can have arbitrary kinds, - -- because they may be implemented by type synonyms - -- (which themselves can have arbitrary kinds, not just *). See #13955. - -- - -- Note that this is only a property that data type declarations possess, - -- so one could not have, say, a data family instance in an hsig file that - -- has kind `Bool`. Therefore, this check need only occur in the code that - -- typechecks data type declarations. - mk_permissive_kind HsigFile [] = True - mk_permissive_kind _ _ = False - - -- In hs-boot, a 'data' declaration with no constructors - -- indicates a nominally distinct abstract data type. - mk_tc_rhs HsBootFile _ [] - = return AbstractTyCon - - mk_tc_rhs HsigFile _ [] -- ditto - = return AbstractTyCon - - mk_tc_rhs _ tycon data_cons - = case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs tc_name tycon (head data_cons) -tcDataDefn _ _ _ (XHsDataDefn nec) = noExtCon nec - - -------------------------- -kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () --- Used for the equations of a closed type family only --- Not used for data/type instances -kcTyFamInstEqn tc_fam_tc - (L loc (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }})) - = setSrcSpan loc $ - do { traceTc "kcTyFamInstEqn" (vcat - [ text "tc_name =" <+> ppr eqn_tc_name - , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc) - , text "hsib_vars =" <+> ppr imp_vars - , text "feqn_bndrs =" <+> ppr mb_expl_bndrs - , text "feqn_pats =" <+> ppr hs_pats ]) - -- this check reports an arity error instead of a kind error; easier for user - ; let vis_pats = numVisibleArgs hs_pats - ; checkTc (vis_pats == vis_arity) $ - wrongNumberOfParmsErr vis_arity - ; discardResult $ - bindImplicitTKBndrs_Q_Tv imp_vars $ - bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $ - do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats - ; tcCheckLHsType hs_rhs_ty (TheKind res_kind) } - -- Why "_Tv" here? Consider (#14066 - -- type family Bar x y where - -- Bar (x :: a) (y :: b) = Int - -- Bar (x :: c) (y :: d) = Bool - -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately - } - where - vis_arity = length (tyConVisibleTyVars tc_fam_tc) - -kcTyFamInstEqn _ (L _ (XHsImplicitBndrs nec)) = noExtCon nec -kcTyFamInstEqn _ (L _ (HsIB _ (XFamEqn nec))) = noExtCon nec - - --------------------------- -tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn - -> TcM (KnotTied CoAxBranch) --- Needs to be here, not in TcInstDcls, because closed families --- (typechecked here) have TyFamInstEqns - -tcTyFamInstEqn fam_tc mb_clsinfo - (L loc (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }})) - = ASSERT( getName fam_tc == eqn_tc_name ) - setSrcSpan loc $ - do { traceTc "tcTyFamInstEqn" $ - vcat [ ppr fam_tc <+> ppr hs_pats - , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc) - , case mb_clsinfo of - NotAssociated -> empty - InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ] - - -- First, check the arity of visible arguments - -- If we wait until validity checking, we'll get kind errors - -- below when an arity error will be much easier to understand. - ; let vis_arity = length (tyConVisibleTyVars fam_tc) - vis_pats = numVisibleArgs hs_pats - ; checkTc (vis_pats == vis_arity) $ - wrongNumberOfParmsErr vis_arity - ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo - imp_vars (mb_expl_bndrs `orElse` []) - hs_pats hs_rhs_ty - -- Don't print results they may be knot-tied - -- (tcFamInstEqnGuts zonks to Type) - ; return (mkCoAxBranch qtvs [] [] fam_tc pats rhs_ty - (map (const Nominal) qtvs) - loc) } - -tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn" - -{- -Kind check type patterns and kind annotate the embedded type variables. - type instance F [a] = rhs - - * Here we check that a type instance matches its kind signature, but we do - not check whether there is a pattern for each type index; the latter - check is only required for type synonym instances. - -Note [Instantiating a family tycon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's possible that kind-checking the result of a family tycon applied to -its patterns will instantiate the tycon further. For example, we might -have - - type family F :: k where - F = Int - F = Maybe - -After checking (F :: forall k. k) (with no visible patterns), we still need -to instantiate the k. With data family instances, this problem can be even -more intricate, due to Note [Arity of data families] in GHC.Core.FamInstEnv. See -indexed-types/should_compile/T12369 for an example. - -So, the kind-checker must return the new skolems and args (that is, Type -or (Type -> Type) for the equations above) and the instantiated kind. - -Note [Generalising in tcTyFamInstEqnGuts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have something like - type instance forall (a::k) b. F t1 t2 = rhs - -Then imp_vars = [k], exp_bndrs = [a::k, b] - -We want to quantify over - * k, a, and b (all user-specified) - * and any inferred free kind vars from - - the kinds of k, a, b - - the types t1, t2 - -However, unlike a type signature like - f :: forall (a::k). blah - -we do /not/ care about the Inferred/Specified designation -or order for the final quantified tyvars. Type-family -instances are not invoked directly in Haskell source code, -so visible type application etc plays no role. - -So, the simple thing is - - gather candidates from [k, a, b] and pats - - quantify over them - -Hence the slightly mysterious call: - candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs) - -Simple, neat, but a little non-obvious! - -See also Note [Re-quantify type variables in rules] in TcRules, which explains -a very similar design when generalising over the type of a rewrite rule. --} - --------------------------- -tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo - -> [Name] -> [LHsTyVarBndr GhcRn] -- Implicit and explicicit binder - -> HsTyPats GhcRn -- Patterns - -> LHsType GhcRn -- RHS - -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs) --- Used only for type families, not data families -tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty - = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc) - - -- By now, for type families (but not data families) we should - -- have checked that the number of patterns matches tyConArity - - -- This code is closely related to the code - -- in TcHsType.kcCheckDeclHeader_cusk - ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty))) - <- pushTcLevelM_ $ - solveEqualities $ - bindImplicitTKBndrs_Q_Skol imp_vars $ - bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ - do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats - -- Ensure that the instance is consistent with its - -- parent class (#16008) - ; addConsistencyConstraints mb_clsinfo lhs_ty - ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind) - ; return (lhs_ty, rhs_ty) } - - -- See Note [Generalising in tcTyFamInstEqnGuts] - -- This code (and the stuff immediately above) is very similar - -- to that in tcDataFamInstHeader. Maybe we should abstract the - -- common code; but for the moment I concluded that it's - -- clearer to duplicate it. Still, if you fix a bug here, - -- check there too! - ; let scoped_tvs = imp_tvs ++ exp_tvs - ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) - ; qtvs <- quantifyTyVars dvs - - ; traceTc "tcTyFamInstEqnGuts 2" $ - vcat [ ppr fam_tc - , text "scoped_tvs" <+> pprTyVars scoped_tvs - , text "lhs_ty" <+> ppr lhs_ty - , text "dvs" <+> ppr dvs - , text "qtvs" <+> pprTyVars qtvs ] - - ; (ze, qtvs) <- zonkTyBndrs qtvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty - - ; let pats = unravelFamInstPats lhs_ty - -- Note that we do this after solveEqualities - -- so that any strange coercions inside lhs_ty - -- have been solved before we attempt to unravel it - ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs) - ; return (qtvs, pats, rhs_ty) } - ------------------ -tcFamTyPats :: TyCon - -> HsTyPats GhcRn -- Patterns - -> TcM (TcType, TcKind) -- (lhs_type, lhs_kind) --- Used for both type and data families -tcFamTyPats fam_tc hs_pats - = do { traceTc "tcFamTyPats {" $ - vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ] - - ; let fun_ty = mkTyConApp fam_tc [] - - ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $ - setXOptM LangExt.PartialTypeSignatures $ - -- See Note [Wildcards in family instances] in - -- GHC.Rename.Source - tcInferApps typeLevelMode lhs_fun fun_ty hs_pats - - ; traceTc "End tcFamTyPats }" $ - vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ] - - ; return (fam_app, res_kind) } - where - fam_name = tyConName fam_tc - fam_arity = tyConArity fam_tc - lhs_fun = noLoc (HsTyVar noExtField NotPromoted (noLoc fam_name)) - -unravelFamInstPats :: TcType -> [TcType] --- Decompose fam_app to get the argument patterns --- --- We expect fam_app to look like (F t1 .. tn) --- tcInferApps is capable of returning ((F ty1 |> co) ty2), --- but that can't happen here because we already checked the --- arity of F matches the number of pattern -unravelFamInstPats fam_app - = case splitTyConApp_maybe fam_app of - Just (_, pats) -> pats - Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance" - -- The Nothing case cannot happen for type families, because - -- we don't call unravelFamInstPats until we've solved the - -- equalities. For data families, it shouldn't happen either, - -- we need to fail hard and early if it does. See trac issue #15905 - -- for an example of this happening. - -addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM () --- In the corresponding positions of the class and type-family, --- ensure the the family argument is the same as the class argument --- E.g class C a b c d where --- F c x y a :: Type --- Here the first arg of F should be the same as the third of C --- and the fourth arg of F should be the same as the first of C --- --- We emit /Derived/ constraints (a bit like fundeps) to encourage --- unification to happen, but without actually reporting errors. --- If, despite the efforts, corresponding positions do not match, --- checkConsistentFamInst will complain -addConsistencyConstraints mb_clsinfo fam_app - | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo - , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app - = do { let eqs = [ (cls_ty, pat) - | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats - , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ] - ; traceTc "addConsistencyConstraints" (ppr eqs) - ; emitDerivedEqs AssocFamPatOrigin eqs } - -- Improve inference - -- Any mis-match is reports by checkConsistentFamInst - | otherwise - = return () - -{- Note [Constraints in patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: This isn't the whole story. See comment in tcFamTyPats. - -At first glance, it seems there is a complicated story to tell in tcFamTyPats -around constraint solving. After all, type family patterns can now do -GADT pattern-matching, which is jolly complicated. But, there's a key fact -which makes this all simple: everything is at top level! There cannot -be untouchable type variables. There can't be weird interaction between -case branches. There can't be global skolems. - -This means that the semantics of type-level GADT matching is a little -different than term level. If we have - - data G a where - MkGBool :: G Bool - -And then - - type family F (a :: G k) :: k - type instance F MkGBool = True - -we get - - axF : F Bool (MkGBool <Bool>) ~ True - -Simple! No casting on the RHS, because we can affect the kind parameter -to F. - -If we ever introduce local type families, this all gets a lot more -complicated, and will end up looking awfully like term-level GADT -pattern-matching. - - -** The new story ** - -Here is really what we want: - -The matcher really can't deal with covars in arbitrary spots in coercions. -But it can deal with covars that are arguments to GADT data constructors. -So we somehow want to allow covars only in precisely those spots, then use -them as givens when checking the RHS. TODO (RAE): Implement plan. - -Note [Quantified kind variables of a family pattern] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider type family KindFam (p :: k1) (q :: k1) - data T :: Maybe k1 -> k2 -> * - type instance KindFam (a :: Maybe k) b = T a b -> Int -The HsBSig for the family patterns will be ([k], [a]) - -Then in the family instance we want to - * Bring into scope [ "k" -> k:*, "a" -> a:k ] - * Kind-check the RHS - * Quantify the type instance over k and k', as well as a,b, thus - type instance [k, k', a:Maybe k, b:k'] - KindFam (Maybe k) k' a b = T k k' a b -> Int - -Notice that in the third step we quantify over all the visibly-mentioned -type variables (a,b), but also over the implicitly mentioned kind variables -(k, k'). In this case one is bound explicitly but often there will be -none. The role of the kind signature (a :: Maybe k) is to add a constraint -that 'a' must have that kind, and to bring 'k' into scope. - - - -************************************************************************ -* * - Data types -* * -************************************************************************ --} - -dataDeclChecks :: Name -> NewOrData - -> LHsContext GhcRn -> [LConDecl GhcRn] - -> TcM Bool -dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons - = do { -- Check that we don't use GADT syntax in H98 world - gadtSyntax_ok <- xoptM LangExt.GADTSyntax - ; let gadt_syntax = consUseGadtSyntax cons - ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) - - -- Check that the stupid theta is empty for a GADT-style declaration - ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name) - - -- Check that a newtype has exactly one constructor - -- Do this before checking for empty data decls, so that - -- we don't suggest -XEmptyDataDecls for newtypes - ; checkTc (new_or_data == DataType || isSingleton cons) - (newtypeConError tc_name (length cons)) - - -- Check that there's at least one condecl, - -- or else we're reading an hs-boot file, or -XEmptyDataDecls - ; empty_data_decls <- xoptM LangExt.EmptyDataDecls - ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? - ; checkTc (not (null cons) || empty_data_decls || is_boot) - (emptyConDeclsErr tc_name) - ; return gadt_syntax } - - ------------------------------------ -consUseGadtSyntax :: [LConDecl a] -> Bool -consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True -consUseGadtSyntax _ = False - -- All constructors have same shape - ------------------------------------ -tcConDecls :: KnotTied TyCon -> NewOrData - -> [TyConBinder] -> TcKind -- binders and result kind of tycon - -> KnotTied Type -> [LConDecl GhcRn] -> TcM [DataCon] -tcConDecls rep_tycon new_or_data tmpl_bndrs res_kind res_tmpl - = concatMapM $ addLocM $ - tcConDecl rep_tycon (mkTyConTagMap rep_tycon) - tmpl_bndrs res_kind res_tmpl new_or_data - -- It's important that we pay for tag allocation here, once per TyCon, - -- See Note [Constructor tag allocation], fixes #14657 - -tcConDecl :: KnotTied TyCon -- Representation tycon. Knot-tied! - -> NameEnv ConTag - -> [TyConBinder] -> TcKind -- tycon binders and result kind - -> KnotTied Type - -- Return type template (T tys), where T is the family TyCon - -> NewOrData - -> ConDecl GhcRn - -> TcM [DataCon] - -tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data - (ConDeclH98 { con_name = name - , con_ex_tvs = explicit_tkv_nms - , con_mb_cxt = hs_ctxt - , con_args = hs_args }) - = addErrCtxt (dataConCtxtName [name]) $ - do { -- NB: the tyvars from the declaration header are in scope - - -- Get hold of the existential type variables - -- e.g. data T a = forall k (b::k) f. MkT a (f b) - -- Here tmpl_bndrs = {a} - -- hs_qvars = HsQTvs { hsq_implicit = {k} - -- , hsq_explicit = {f,b} } - - ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) - - ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts)) - <- pushTcLevelM_ $ - solveEqualities $ - bindExplicitTKBndrs_Skol explicit_tkv_nms $ - do { ctxt <- tcHsMbContext hs_ctxt - ; let exp_kind = getArgExpKind new_or_data res_kind - ; btys <- tcConArgs exp_kind hs_args - ; field_lbls <- lookupConstructorFields (unLoc name) - ; let (arg_tys, stricts) = unzip btys - ; return (ctxt, arg_tys, field_lbls, stricts) - } - - -- exp_tvs have explicit, user-written binding sites - -- the kvs below are those kind variables entirely unmentioned by the user - -- and discovered only by generalization - - ; kvs <- kindGeneralizeAll (mkSpecForAllTys (binderVars tmpl_bndrs) $ - mkSpecForAllTys exp_tvs $ - mkPhiTy ctxt $ - mkVisFunTys arg_tys $ - unitTy) - -- That type is a lie, of course. (It shouldn't end in ()!) - -- And we could construct a proper result type from the info - -- at hand. But the result would mention only the tmpl_tvs, - -- and so it just creates more work to do it right. Really, - -- we're only doing this to find the right kind variables to - -- quantify over, and this type is fine for that purpose. - - -- Zonk to Types - ; (ze, qkvs) <- zonkTyBndrs kvs - ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt - - ; fam_envs <- tcGetFamInstEnvs - - -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here - ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) - ; let - univ_tvbs = tyConTyVarBinders tmpl_bndrs - univ_tvs = binderVars univ_tvbs - ex_tvbs = mkTyVarBinders Inferred qkvs ++ - mkTyVarBinders Specified user_qtvs - ex_tvs = qkvs ++ user_qtvs - -- For H98 datatypes, the user-written tyvar binders are precisely - -- the universals followed by the existentials. - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - user_tvbs = univ_tvbs ++ ex_tvbs - buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixH98 name hs_args - ; rep_nm <- newTyConRepName name - - ; buildDataCon fam_envs name is_infix rep_nm - stricts Nothing field_lbls - univ_tvs ex_tvs user_tvbs - [{- no eq_preds -}] ctxt arg_tys - res_tmpl rep_tycon tag_map - -- NB: we put data_tc, the type constructor gotten from the - -- constructor type signature into the data constructor; - -- that way checkValidDataCon can complain if it's wrong. - } - ; traceTc "tcConDecl 2" (ppr name) - ; mapM buildOneDataCon [name] - } - -tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data - -- NB: don't use res_kind here, as it's ill-scoped. Instead, we get - -- the res_kind by typechecking the result type. - (ConDeclGADT { con_names = names - , con_qvars = qtvs - , con_mb_cxt = cxt, con_args = hs_args - , con_res_ty = hs_res_ty }) - | HsQTvs { hsq_ext = implicit_tkv_nms - , hsq_explicit = explicit_tkv_nms } <- qtvs - = addErrCtxt (dataConCtxtName names) $ - do { traceTc "tcConDecl 1 gadt" (ppr names) - ; let (L _ name : _) = names - - ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) - <- pushTcLevelM_ $ -- We are going to generalise - solveEqualities $ -- We won't get another crack, and we don't - -- want an error cascade - bindImplicitTKBndrs_Skol implicit_tkv_nms $ - bindExplicitTKBndrs_Skol explicit_tkv_nms $ - do { ctxt <- tcHsMbContext cxt - ; casted_res_ty <- tcHsOpenType hs_res_ty - ; res_ty <- if not debugIsOn then return $ discardCast casted_res_ty - else case splitCastTy_maybe casted_res_ty of - Just (ty, _) -> do unlifted_nts <- xoptM LangExt.UnliftedNewtypes - MASSERT( unlifted_nts ) - MASSERT( new_or_data == NewType ) - return ty - _ -> return casted_res_ty - -- See Note [Datatype return kinds] - ; let exp_kind = getArgExpKind new_or_data (typeKind res_ty) - ; btys <- tcConArgs exp_kind hs_args - ; let (arg_tys, stricts) = unzip btys - ; field_lbls <- lookupConstructorFields name - ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) - } - ; imp_tvs <- zonkAndScopedSort imp_tvs - ; let user_tvs = imp_tvs ++ exp_tvs - - ; tkvs <- kindGeneralizeAll (mkSpecForAllTys user_tvs $ - mkPhiTy ctxt $ - mkVisFunTys arg_tys $ - res_ty) - - -- Zonk to Types - ; (ze, tkvs) <- zonkTyBndrs tkvs - ; (ze, user_tvs) <- zonkTyBndrsX ze user_tvs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; res_ty <- zonkTcTypeToTypeX ze res_ty - - ; let (univ_tvs, ex_tvs, tkvs', user_tvs', eq_preds, arg_subst) - = rejigConRes tmpl_bndrs res_tmpl tkvs user_tvs res_ty - -- NB: this is a /lazy/ binding, so we pass six thunks to - -- buildDataCon without yet forcing the guards in rejigConRes - -- See Note [Checking GADT return types] - - -- Compute the user-written tyvar binders. These have the same - -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order. - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - tkv_bndrs = mkTyVarBinders Inferred tkvs' - user_tv_bndrs = mkTyVarBinders Specified user_tvs' - all_user_bndrs = tkv_bndrs ++ user_tv_bndrs - - ctxt' = substTys arg_subst ctxt - arg_tys' = substTys arg_subst arg_tys - res_ty' = substTy arg_subst res_ty - - - ; fam_envs <- tcGetFamInstEnvs - - -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here - ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) - ; let - buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixGADT name hs_args - ; rep_nm <- newTyConRepName name - - ; buildDataCon fam_envs name is_infix - rep_nm - stricts Nothing field_lbls - univ_tvs ex_tvs all_user_bndrs eq_preds - ctxt' arg_tys' res_ty' rep_tycon tag_map - -- NB: we put data_tc, the type constructor gotten from the - -- constructor type signature into the data constructor; - -- that way checkValidDataCon can complain if it's wrong. - } - ; traceTc "tcConDecl 2" (ppr names) - ; mapM buildOneDataCon names - } -tcConDecl _ _ _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _) - = noExtCon nec -tcConDecl _ _ _ _ _ _ (XConDecl nec) = noExtCon nec - --- | Produce an "expected kind" for the arguments of a data/newtype. --- If the declaration is indeed for a newtype, --- then this expected kind will be the kind provided. Otherwise, --- it is OpenKind for datatypes and liftedTypeKind. --- Why do we not check for -XUnliftedNewtypes? See point <Error Messages> --- in Note [Implementation of UnliftedNewtypes] -getArgExpKind :: NewOrData -> Kind -> ContextKind -getArgExpKind NewType res_ki = TheKind res_ki -getArgExpKind DataType _ = OpenKind - -tcConIsInfixH98 :: Name - -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) - -> TcM Bool -tcConIsInfixH98 _ details - = case details of - InfixCon {} -> return True - _ -> return False - -tcConIsInfixGADT :: Name - -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) - -> TcM Bool -tcConIsInfixGADT con details - = case details of - InfixCon {} -> return True - RecCon {} -> return False - PrefixCon arg_tys -- See Note [Infix GADT constructors] - | isSymOcc (getOccName con) - , [_ty1,_ty2] <- arg_tys - -> do { fix_env <- getFixityEnv - ; return (con `elemNameEnv` fix_env) } - | otherwise -> return False - -tcConArgs :: ContextKind -- expected kind of arguments - -- always OpenKind for datatypes, but unlifted newtypes - -- might have a specific kind - -> HsConDeclDetails GhcRn - -> TcM [(TcType, HsSrcBang)] -tcConArgs exp_kind (PrefixCon btys) - = mapM (tcConArg exp_kind) btys -tcConArgs exp_kind (InfixCon bty1 bty2) - = do { bty1' <- tcConArg exp_kind bty1 - ; bty2' <- tcConArg exp_kind bty2 - ; return [bty1', bty2'] } -tcConArgs exp_kind (RecCon fields) - = mapM (tcConArg exp_kind) btys - where - -- We need a one-to-one mapping from field_names to btys - combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) - (unLoc fields) - explode (ns,ty) = zip ns (repeat ty) - exploded = concatMap explode combined - (_,btys) = unzip exploded - - -tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes, - -- but might be an unlifted type with UnliftedNewtypes - -> LHsType GhcRn -> TcM (TcType, HsSrcBang) -tcConArg exp_kind bty - = do { traceTc "tcConArg 1" (ppr bty) - ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind - ; traceTc "tcConArg 2" (ppr bty) - ; return (arg_ty, getBangStrictness bty) } - -{- -Note [Infix GADT constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not currently have syntax to declare an infix constructor in GADT syntax, -but it makes a (small) difference to the Show instance. So as a slightly -ad-hoc solution, we regard a GADT data constructor as infix if - a) it is an operator symbol - b) it has two arguments - c) there is a fixity declaration for it -For example: - infix 6 (:--:) - data T a where - (:--:) :: t1 -> t2 -> T Int - - -Note [Checking GADT return types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is a delicacy around checking the return types of a datacon. The -central problem is dealing with a declaration like - - data T a where - MkT :: T a -> Q a - -Note that the return type of MkT is totally bogus. When creating the T -tycon, we also need to create the MkT datacon, which must have a "rejigged" -return type. That is, the MkT datacon's type must be transformed to have -a uniform return type with explicit coercions for GADT-like type parameters. -This rejigging is what rejigConRes does. The problem is, though, that checking -that the return type is appropriate is much easier when done over *Type*, -not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully -defined yet. - -So, we want to make rejigConRes lazy and then check the validity of -the return type in checkValidDataCon. To do this we /always/ return a -6-tuple from rejigConRes (so that we can compute the return type from it, which -checkValidDataCon needs), but the first three fields may be bogus if -the return type isn't valid (the last equation for rejigConRes). - -This is better than an earlier solution which reduced the number of -errors reported in one pass. See #7175, and #10836. --} - --- Example --- data instance T (b,c) where --- TI :: forall e. e -> T (e,e) --- --- The representation tycon looks like this: --- data :R7T b c where --- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 --- In this case orig_res_ty = T (e,e) - -rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type -- Template for result type; e.g. - -- data instance T [a] b c ... - -- gives template ([a,b,c], T [a] b c) - -> [TyVar] -- The constructor's inferred type variables - -> [TyVar] -- The constructor's user-written, specified - -- type variables - -> KnotTied Type -- res_ty - -> ([TyVar], -- Universal - [TyVar], -- Existential (distinct OccNames from univs) - [TyVar], -- The constructor's rejigged, user-written, - -- inferred type variables - [TyVar], -- The constructor's rejigged, user-written, - -- specified type variables - [EqSpec], -- Equality predicates - TCvSubst) -- Substitution to apply to argument types - -- We don't check that the TyCon given in the ResTy is - -- the same as the parent tycon, because checkValidDataCon will do it --- NB: All arguments may potentially be knot-tied -rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty - -- E.g. data T [a] b c where - -- MkT :: forall x y z. T [(x,y)] z z - -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs - -- (NB: unlike the H98 case, the dc_tvs are not all existential) - -- Then we generate - -- Univ tyvars Eq-spec - -- a a~(x,y) - -- b b~z - -- z - -- Existentials are the leftover type vars: [x,y] - -- The user-written type variables are what is listed in the forall: - -- [x, y, z] (all specified). We must rejig these as well. - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - -- So we return ( [a,b,z], [x,y] - -- , [], [x,y,z] - -- , [a~(x,y),b~z], <arg-subst> ) - | Just subst <- tcMatchTy res_tmpl res_ty - = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst - raw_ex_tvs = dc_tvs `minusList` univ_tvs - (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs - - -- After rejigging the existential tyvars, the resulting substitution - -- gives us exactly what we need to rejig the user-written tyvars, - -- since the dcUserTyVarBinders invariant guarantees that the - -- substitution has *all* the tyvars in its domain. - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst) - substed_inferred_tvs = subst_user_tvs dc_inferred_tvs - substed_specified_tvs = subst_user_tvs dc_specified_tvs - - substed_eqs = map (substEqSpec arg_subst) raw_eqs - in - (univ_tvs, substed_ex_tvs, substed_inferred_tvs, substed_specified_tvs, - substed_eqs, arg_subst) - - | otherwise - -- If the return type of the data constructor doesn't match the parent - -- type constructor, or the arity is wrong, the tcMatchTy will fail - -- e.g data T a b where - -- T1 :: Maybe a -- Wrong tycon - -- T2 :: T [a] -- Wrong arity - -- We are detect that later, in checkValidDataCon, but meanwhile - -- we must do *something*, not just crash. So we do something simple - -- albeit bogus, relying on checkValidDataCon to check the - -- bad-result-type error before seeing that the other fields look odd - -- See Note [Checking GADT return types] - = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_inferred_tvs, dc_specified_tvs, - [], emptyTCvSubst) - where - dc_tvs = dc_inferred_tvs ++ dc_specified_tvs - tmpl_tvs = binderVars tmpl_bndrs - -{- Note [mkGADTVars] -~~~~~~~~~~~~~~~~~~~~ -Running example: - -data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where - MkT :: forall (x1 : *) (y :: x1) (z :: *). - T x1 * (Proxy (y :: x1), z) z - -We need the rejigged type to be - - MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2). - forall (y :: x1) (z :: *). - (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z) - => T x1 k2 a b - -You might naively expect that z should become a universal tyvar, -not an existential. (After all, x1 becomes a universal tyvar.) -But z has kind * while b has kind k2, so the return type - T x1 k2 a z -is ill-kinded. Another way to say it is this: the universal -tyvars must have exactly the same kinds as the tyConTyVars. - -So we need an existential tyvar and a heterogeneous equality -constraint. (The b ~ z is a bit redundant with the k2 ~ * that -comes before in that b ~ z implies k2 ~ *. I'm sure we could do -some analysis that could eliminate k2 ~ *. But we don't do this -yet.) - -The data con signature has already been fully kind-checked. -The return type - - T x1 * (Proxy (y :: x1), z) z -becomes - qtkvs = [x1 :: *, y :: x1, z :: *] - res_tmpl = T x1 * (Proxy x1 y, z) z - -We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We -know this match will succeed because of the validity check (actually done -later, but laziness saves us -- see Note [Checking GADT return types]). -Thus, we get - - subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z } - -Now, we need to figure out what the GADT equalities should be. In this case, -we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a -renaming. The others should be GADT equalities. We also need to make -sure that the universally-quantified variables of the datacon match up -with the tyvars of the tycon, as required for Core context well-formedness. -(This last bit is why we have to rejig at all!) - -`choose` walks down the tycon tyvars, figuring out what to do with each one. -It carries two substitutions: - - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables - mentioned in the datacon signature. - - r_sub's domain is *result* tyvars, names written by the programmer in - the datacon signature. The final rejigged type will use these names, but - the subst is still needed because sometimes the printed name of these variables - is different. (See choose_tv_name, below.) - -Before explaining the details of `choose`, let's just look at its operation -on our example: - - choose [] [] {} {} [k1, k2, a, b] - --> -- first branch of `case` statement - choose - univs: [x1 :: *] - eq_spec: [] - t_sub: {k1 |-> x1} - r_sub: {x1 |-> x1} - t_tvs: [k2, a, b] - --> -- second branch of `case` statement - choose - univs: [k2 :: *, x1 :: *] - eq_spec: [k2 ~ *] - t_sub: {k1 |-> x1, k2 |-> k2} - r_sub: {x1 |-> x1} - t_tvs: [a, b] - --> -- second branch of `case` statement - choose - univs: [a :: k2, k2 :: *, x1 :: *] - eq_spec: [ a ~ (Proxy x1 y, z) - , k2 ~ * ] - t_sub: {k1 |-> x1, k2 |-> k2, a |-> a} - r_sub: {x1 |-> x1} - t_tvs: [b] - --> -- second branch of `case` statement - choose - univs: [b :: k2, a :: k2, k2 :: *, x1 :: *] - eq_spec: [ b ~ z - , a ~ (Proxy x1 y, z) - , k2 ~ * ] - t_sub: {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z} - r_sub: {x1 |-> x1} - t_tvs: [] - --> -- end of recursion - ( [x1 :: *, k2 :: *, a :: k2, b :: k2] - , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z] - , {x1 |-> x1} ) - -`choose` looks up each tycon tyvar in the matching (it *must* be matched!). - -* If it finds a bare result tyvar (the first branch of the `case` - statement), it checks to make sure that the result tyvar isn't yet - in the list of univ_tvs. If it is in that list, then we have a - repeated variable in the return type, and we in fact need a GADT - equality. - -* It then checks to make sure that the kind of the result tyvar - matches the kind of the template tyvar. This check is what forces - `z` to be existential, as it should be, explained above. - -* Assuming no repeated variables or kind-changing, we wish to use the - variable name given in the datacon signature (that is, `x1` not - `k1`), not the tycon signature (which may have been made up by - GHC). So, we add a mapping from the tycon tyvar to the result tyvar - to t_sub. - -* If we discover that a mapping in `subst` gives us a non-tyvar (the - second branch of the `case` statement), then we have a GADT equality - to create. We create a fresh equality, but we don't extend any - substitutions. The template variable substitution is meant for use - in universal tyvar kinds, and these shouldn't be affected by any - GADT equalities. - -This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways -of simplifying it: - -1) The first branch of the `case` statement is really an optimization, used -in order to get fewer GADT equalities. It might be possible to make a GADT -equality for *every* univ. tyvar, even if the equality is trivial, and then -either deal with the bigger type or somehow reduce it later. - -2) This algorithm strives to use the names for type variables as specified -by the user in the datacon signature. If we always used the tycon tyvar -names, for example, this would be simplified. This change would almost -certainly degrade error messages a bit, though. --} - --- ^ From information about a source datacon definition, extract out --- what the universal variables and the GADT equalities should be. --- See Note [mkGADTVars]. -mkGADTVars :: [TyVar] -- ^ The tycon vars - -> [TyVar] -- ^ The datacon vars - -> TCvSubst -- ^ The matching between the template result type - -- and the actual result type - -> ( [TyVar] - , [EqSpec] - , TCvSubst ) -- ^ The univ. variables, the GADT equalities, - -- and a subst to apply to the GADT equalities - -- and existentials. -mkGADTVars tmpl_tvs dc_tvs subst - = choose [] [] empty_subst empty_subst tmpl_tvs - where - in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs) - `unionInScope` getTCvInScope subst - empty_subst = mkEmptyTCvSubst in_scope - - choose :: [TyVar] -- accumulator of univ tvs, reversed - -> [EqSpec] -- accumulator of GADT equalities, reversed - -> TCvSubst -- template substitution - -> TCvSubst -- res. substitution - -> [TyVar] -- template tvs (the univ tvs passed in) - -> ( [TyVar] -- the univ_tvs - , [EqSpec] -- GADT equalities - , TCvSubst ) -- a substitution to fix kinds in ex_tvs - - choose univs eqs _t_sub r_sub [] - = (reverse univs, reverse eqs, r_sub) - choose univs eqs t_sub r_sub (t_tv:t_tvs) - | Just r_ty <- lookupTyVar subst t_tv - = case getTyVar_maybe r_ty of - Just r_tv - | not (r_tv `elem` univs) - , tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv)) - -> -- simple, well-kinded variable substitution. - choose (r_tv:univs) eqs - (extendTvSubst t_sub t_tv r_ty') - (extendTvSubst r_sub r_tv r_ty') - t_tvs - where - r_tv1 = setTyVarName r_tv (choose_tv_name r_tv t_tv) - r_ty' = mkTyVarTy r_tv1 - - -- Not a simple substitution: make an equality predicate - _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs) - (extendTvSubst t_sub t_tv (mkTyVarTy t_tv')) - -- We've updated the kind of t_tv, - -- so add it to t_sub (#14162) - r_sub t_tvs - where - t_tv' = updateTyVarKind (substTy t_sub) t_tv - - | otherwise - = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst) - - -- choose an appropriate name for a univ tyvar. - -- This *must* preserve the Unique of the result tv, so that we - -- can detect repeated variables. It prefers user-specified names - -- over system names. A result variable with a system name can - -- happen with GHC-generated implicit kind variables. - choose_tv_name :: TyVar -> TyVar -> Name - choose_tv_name r_tv t_tv - | isSystemName r_tv_name - = setNameUnique t_tv_name (getUnique r_tv_name) - - | otherwise - = r_tv_name - - where - r_tv_name = getName r_tv - t_tv_name = getName t_tv - -{- -Note [Substitution in template variables kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -data G (a :: Maybe k) where - MkG :: G Nothing - -With explicit kind variables - -data G k (a :: Maybe k) where - MkG :: G k1 (Nothing k1) - -Note how k1 is distinct from k. So, when we match the template -`G k a` against `G k1 (Nothing k1)`, we get a subst -[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two -mappings, we surely don't want to add (k, k1) to the list of -GADT equalities -- that would be overly complex and would create -more untouchable variables than we need. So, when figuring out -which tyvars are GADT-like and which aren't (the fundamental -job of `choose`), we want to treat `k` as *not* GADT-like. -Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1) -instead of (a :: Maybe k). This is the reason for dealing -with a substitution in here. - -However, we do not *always* want to substitute. Consider - -data H (a :: k) where - MkH :: H Int - -With explicit kind variables: - -data H k (a :: k) where - MkH :: H * Int - -Here, we have a kind-indexed GADT. The subst in question is -[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s -kind, because that would give a constructor with the type - -MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a - -The problem here is that a's kind is wrong -- it needs to be k, not *! -So, if the matching for a variable is anything but another bare variable, -we drop the mapping from the substitution before proceeding. This -was not an issue before kind-indexed GADTs because this case could -never happen. - -************************************************************************ -* * - Validity checking -* * -************************************************************************ - -Validity checking is done once the mutually-recursive knot has been -tied, so we can look at things freely. --} - -checkValidTyCl :: TyCon -> TcM [TyCon] --- The returned list is either a singleton (if valid) --- or a list of "fake tycons" (if not); the fake tycons --- include any implicits, like promoted data constructors --- See Note [Recover from validity error] -checkValidTyCl tc - = setSrcSpan (getSrcSpan tc) $ - addTyConCtxt tc $ - recoverM recovery_code $ - do { traceTc "Starting validity for tycon" (ppr tc) - ; checkValidTyCon tc - ; traceTc "Done validity for tycon" (ppr tc) - ; return [tc] } - where - recovery_code -- See Note [Recover from validity error] - = do { traceTc "Aborted validity for tycon" (ppr tc) - ; return (concatMap mk_fake_tc $ - ATyCon tc : implicitTyConThings tc) } - - mk_fake_tc (ATyCon tc) - | isClassTyCon tc = [tc] -- Ugh! Note [Recover from validity error] - | otherwise = [makeRecoveryTyCon tc] - mk_fake_tc (AConLike (RealDataCon dc)) - = [makeRecoveryTyCon (promoteDataCon dc)] - mk_fake_tc _ = [] - -{- Note [Recover from validity error] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We recover from a validity error in a type or class, which allows us -to report multiple validity errors. In the failure case we return a -TyCon of the right kind, but with no interesting behaviour -(makeRecoveryTyCon). Why? Suppose we have - type T a = Fun -where Fun is a type family of arity 1. The RHS is invalid, but we -want to go on checking validity of subsequent type declarations. -So we replace T with an abstract TyCon which will do no harm. -See indexed-types/should_fail/BadSock and #10896 - -Some notes: - -* We must make fakes for promoted DataCons too. Consider (#15215) - data T a = MkT ... - data S a = ...T...MkT.... - If there is an error in the definition of 'T' we add a "fake type - constructor" to the type environment, so that we can continue to - typecheck 'S'. But we /were not/ adding a fake anything for 'MkT' - and so there was an internal error when we met 'MkT' in the body of - 'S'. - -* Painfully, we *don't* want to do this for classes. - Consider tcfail041: - class (?x::Int) => C a where ... - instance C Int - The class is invalid because of the superclass constraint. But - we still want it to look like a /class/, else the instance bleats - that the instance is mal-formed because it hasn't got a class in - the head. - - This is really bogus; now we have in scope a Class that is invalid - in some way, with unknown downstream consequences. A better - alternative might be to make a fake class TyCon. A job for another day. --} - -------------------------- --- For data types declared with record syntax, we require --- that each constructor that has a field 'f' --- (a) has the same result type --- (b) has the same type for 'f' --- module alpha conversion of the quantified type variables --- of the constructor. --- --- Note that we allow existentials to match because the --- fields can never meet. E.g --- data T where --- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T --- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T --- Here we do not complain about f1,f2 because they are existential - -checkValidTyCon :: TyCon -> TcM () -checkValidTyCon tc - | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim - = return () - - | isWiredIn tc -- validity-checking wired-in tycons is a waste of - -- time. More importantly, a wired-in tycon might - -- violate assumptions. Example: (~) has a superclass - -- mentioning (~#), which is ill-kinded in source Haskell - = traceTc "Skipping validity check for wired-in" (ppr tc) - - | otherwise - = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc)) - ; if | Just cl <- tyConClass_maybe tc - -> checkValidClass cl - - | Just syn_rhs <- synTyConRhs_maybe tc - -> do { checkValidType syn_ctxt syn_rhs - ; checkTySynRhs syn_ctxt syn_rhs } - - | Just fam_flav <- famTyConFlav_maybe tc - -> case fam_flav of - { ClosedSynFamilyTyCon (Just ax) - -> tcAddClosedTypeFamilyDeclCtxt tc $ - checkValidCoAxiom ax - ; ClosedSynFamilyTyCon Nothing -> return () - ; AbstractClosedSynFamilyTyCon -> - do { hsBoot <- tcIsHsBootOrSig - ; checkTc hsBoot $ - text "You may define an abstract closed type family" $$ - text "only in a .hs-boot file" } - ; DataFamilyTyCon {} -> return () - ; OpenSynFamilyTyCon -> return () - ; BuiltInSynFamTyCon _ -> return () } - - | otherwise -> do - { -- Check the context on the data decl - traceTc "cvtc1" (ppr tc) - ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) - - ; traceTc "cvtc2" (ppr tc) - - ; dflags <- getDynFlags - ; existential_ok <- xoptM LangExt.ExistentialQuantification - ; gadt_ok <- xoptM LangExt.GADTs - ; let ex_ok = existential_ok || gadt_ok - -- Data cons can have existential context - ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons - ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc) - - -- Check that fields with the same name share a type - ; mapM_ check_fields groups }} - where - syn_ctxt = TySynCtxt name - name = tyConName tc - data_cons = tyConDataCons tc - - groups = equivClasses cmp_fld (concatMap get_fields data_cons) - cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2 - get_fields con = dataConFieldLabels con `zip` repeat con - -- dataConFieldLabels may return the empty list, which is fine - - -- See Note [GADT record selectors] in TcTyDecls - -- We must check (a) that the named field has the same - -- type in each constructor - -- (b) that those constructors have the same result type - -- - -- However, the constructors may have differently named type variable - -- and (worse) we don't know how the correspond to each other. E.g. - -- C1 :: forall a b. { f :: a, g :: b } -> T a b - -- C2 :: forall d c. { f :: c, g :: c } -> T c d - -- - -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's - -- result type against other candidates' types BOTH WAYS ROUND. - -- If they magically agrees, take the substitution and - -- apply them to the latter ones, and see if they match perfectly. - check_fields ((label, con1) :| other_fields) - -- These fields all have the same name, but are from - -- different constructors in the data type - = recoverM (return ()) $ mapM_ checkOne other_fields - -- Check that all the fields in the group have the same type - -- NB: this check assumes that all the constructors of a given - -- data type use the same type variables - where - res1 = dataConOrigResTy con1 - fty1 = dataConFieldType con1 lbl - lbl = flLabel label - - checkOne (_, con2) -- Do it both ways to ensure they are structurally identical - = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2 - ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 } - where - res2 = dataConOrigResTy con2 - fty2 = dataConFieldType con2 lbl - -checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM () --- Checks the partial record field selector, and warns. --- See Note [Checking partial record field] -checkPartialRecordField all_cons fld - = setSrcSpan loc $ - warnIfFlag Opt_WarnPartialFields - (not is_exhaustive && not (startsWithUnderscore occ_name)) - (sep [text "Use of partial record field selector" <> colon, - nest 2 $ quotes (ppr occ_name)]) - where - sel_name = flSelector fld - loc = getSrcSpan sel_name - occ_name = getOccName sel_name - - (cons_with_field, cons_without_field) = partition has_field all_cons - has_field con = fld `elem` (dataConFieldLabels con) - is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field - - con1 = ASSERT( not (null cons_with_field) ) head cons_with_field - (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1 - eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) - inst_tys = substTyVars eq_subst univ_tvs - -checkFieldCompat :: FieldLabelString -> DataCon -> DataCon - -> Type -> Type -> Type -> Type -> TcM () -checkFieldCompat fld con1 con2 res1 res2 fty1 fty2 - = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2) - ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } - where - mb_subst1 = tcMatchTy res1 res2 - mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 - -------------------------------- -checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () -checkValidDataCon dflags existential_ok tc con - = setSrcSpan (getSrcSpan con) $ - addErrCtxt (dataConCtxt con) $ - do { -- Check that the return type of the data constructor - -- matches the type constructor; eg reject this: - -- data T a where { MkT :: Bogus a } - -- It's important to do this first: - -- see Note [Checking GADT return types] - -- and c.f. Note [Check role annotations in a second pass] - let tc_tvs = tyConTyVars tc - res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) - orig_res_ty = dataConOrigResTy con - ; traceTc "checkValidDataCon" (vcat - [ ppr con, ppr tc, ppr tc_tvs - , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl) - , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)]) - - - ; checkTc (isJust (tcMatchTy res_ty_tmpl orig_res_ty)) - (badDataConTyCon con res_ty_tmpl) - -- Note that checkTc aborts if it finds an error. This is - -- critical to avoid panicking when we call dataConUserType - -- on an un-rejiggable datacon! - - ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con)) - - -- Check that the result type is a *monotype* - -- e.g. reject this: MkT :: T (forall a. a->a) - -- Reason: it's really the argument of an equality constraint - ; checkValidMonoType orig_res_ty - - -- If we are dealing with a newtype, we allow levity polymorphism - -- regardless of whether or not UnliftedNewtypes is enabled. A - -- later check in checkNewDataCon handles this, producing a - -- better error message than checkForLevPoly would. - ; unless (isNewTyCon tc) - (mapM_ (checkForLevPoly empty) (dataConOrigArgTys con)) - - -- Extra checks for newtype data constructors. Importantly, these - -- checks /must/ come before the call to checkValidType below. This - -- is because checkValidType invokes the constraint solver, and - -- invoking the solver on an ill formed newtype constructor can - -- confuse GHC to the point of panicking. See #17955 for an example. - ; when (isNewTyCon tc) (checkNewDataCon con) - - -- Check all argument types for validity - ; checkValidType ctxt (dataConUserType con) - - -- Check that existentials are allowed if they are used - ; checkTc (existential_ok || isVanillaDataCon con) - (badExistential con) - - -- Check that UNPACK pragmas and bangs work out - -- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!" - -- data T = MkT {-# UNPACK #-} !a -- Can't unpack - ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..] - - -- Check the dcUserTyVarBinders invariant - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon - -- checked here because we sometimes build invalid DataCons before - -- erroring above here - ; when debugIsOn $ - do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con - user_tvs = dataConUserTyVars con - user_tvbs_invariant - = Set.fromList (filterEqSpec eq_spec univs ++ exs) - == Set.fromList user_tvs - ; MASSERT2( user_tvbs_invariant - , vcat ([ ppr con - , ppr univs - , ppr exs - , ppr eq_spec - , ppr user_tvs ])) } - - ; traceTc "Done validity of data con" $ - vcat [ ppr con - , text "Datacon user type:" <+> ppr (dataConUserType con) - , text "Datacon rep type:" <+> ppr (dataConRepType con) - , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con)) - , case tyConFamInst_maybe (dataConTyCon con) of - Nothing -> text "not family" - Just (f, _) -> ppr (tyConBinders f) ] - } - where - ctxt = ConArgCtxt (dataConName con) - - check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM () - check_bang (HsSrcBang _ _ SrcLazy) _ n - | not (xopt LangExt.StrictData dflags) - = addErrTc - (bad_bang n (text "Lazy annotation (~) without StrictData")) - check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n - | isSrcUnpacked want_unpack, not is_strict - = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'")) - | isSrcUnpacked want_unpack - , case rep_bang of { HsUnpack {} -> False; _ -> True } - -- If not optimising, we don't unpack (rep_bang is never - -- HsUnpack), so don't complain! This happens, e.g., in Haddock. - -- See dataConSrcToImplBang. - , not (gopt Opt_OmitInterfacePragmas dflags) - -- When typechecking an indefinite package in Backpack, we - -- may attempt to UNPACK an abstract type. The test here will - -- conclude that this is unusable, but it might become usable - -- when we actually fill in the abstract type. As such, don't - -- warn in this case (it gives users the wrong idea about whether - -- or not UNPACK on abstract types is supported; it is!) - , unitIdIsDefinite (thisPackage dflags) - = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma")) - where - is_strict = case strict_mark of - NoSrcStrict -> xopt LangExt.StrictData dflags - bang -> isSrcStrict bang - - check_bang _ _ _ - = return () - - bad_bang n herald - = hang herald 2 (text "on the" <+> speakNth n - <+> text "argument of" <+> quotes (ppr con)) -------------------------------- -checkNewDataCon :: DataCon -> TcM () --- Further checks for the data constructor of a newtype -checkNewDataCon con - = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) - -- One argument - - ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; let allowedArgType = - unlifted_newtypes || isLiftedType_maybe arg_ty1 == Just True - ; checkTc allowedArgType $ vcat - [ text "A newtype cannot have an unlifted argument type" - , text "Perhaps you intended to use UnliftedNewtypes" - ] - - ; check_con (null eq_spec) $ - text "A newtype constructor must have a return type of form T a1 ... an" - -- Return type is (T a b c) - - ; check_con (null theta) $ - text "A newtype constructor cannot have a context in its type" - - ; check_con (null ex_tvs) $ - text "A newtype constructor cannot have existential type variables" - -- No existentials - - ; checkTc (all ok_bang (dataConSrcBangs con)) - (newtypeStrictError con) - -- No strictness annotations - } - where - (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig con - check_con what msg - = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con)) - - (arg_ty1 : _) = arg_tys - - ok_bang (HsSrcBang _ _ SrcStrict) = False - ok_bang (HsSrcBang _ _ SrcLazy) = False - ok_bang _ = True - -------------------------------- -checkValidClass :: Class -> TcM () -checkValidClass cls - = do { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods - ; multi_param_type_classes <- xoptM LangExt.MultiParamTypeClasses - ; nullary_type_classes <- xoptM LangExt.NullaryTypeClasses - ; fundep_classes <- xoptM LangExt.FunctionalDependencies - ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses - - -- Check that the class is unary, unless multiparameter type classes - -- are enabled; also recognize deprecated nullary type classes - -- extension (subsumed by multiparameter type classes, #8993) - ; checkTc (multi_param_type_classes || cls_arity == 1 || - (nullary_type_classes && cls_arity == 0)) - (classArityErr cls_arity cls) - ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls) - - -- Check the super-classes - ; checkValidTheta (ClassSCCtxt (className cls)) theta - - -- Now check for cyclic superclasses - -- If there are superclass cycles, checkClassCycleErrs bails. - ; unless undecidable_super_classes $ - case checkClassCycles cls of - Just err -> setSrcSpan (getSrcSpan cls) $ - addErrTc err - Nothing -> return () - - -- Check the class operations. - -- But only if there have been no earlier errors - -- See Note [Abort when superclass cycle is detected] - ; whenNoErrs $ - mapM_ (check_op constrained_class_methods) op_stuff - - -- Check the associated type defaults are well-formed and instantiated - ; mapM_ check_at at_stuff } - where - (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls - cls_arity = length (tyConVisibleTyVars (classTyCon cls)) - -- Ignore invisible variables - cls_tv_set = mkVarSet tyvars - - check_op constrained_class_methods (sel_id, dm) - = setSrcSpan (getSrcSpan sel_id) $ - addErrCtxt (classOpCtxt sel_id op_ty) $ do - { traceTc "class op type" (ppr op_ty) - ; checkValidType ctxt op_ty - -- This implements the ambiguity check, among other things - -- Example: tc223 - -- class Error e => Game b mv e | b -> mv e where - -- newBoard :: MonadState b m => m () - -- Here, MonadState has a fundep m->b, so newBoard is fine - - -- a method cannot be levity polymorphic, as we have to store the - -- method in a dictionary - -- example of what this prevents: - -- class BoundedX (a :: TYPE r) where minBound :: a - -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad - ; checkForLevPoly empty tau1 - - ; unless constrained_class_methods $ - mapM_ check_constraint (tail (cls_pred:op_theta)) - - ; check_dm ctxt sel_id cls_pred tau2 dm - } - where - ctxt = FunSigCtxt op_name True -- Report redundant class constraints - op_name = idName sel_id - op_ty = idType sel_id - (_,cls_pred,tau1) = tcSplitMethodTy op_ty - -- See Note [Splitting nested sigma types in class type signatures] - (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1 - - check_constraint :: TcPredType -> TcM () - check_constraint pred -- See Note [Class method constraints] - = when (not (isEmptyVarSet pred_tvs) && - pred_tvs `subVarSet` cls_tv_set) - (addErrTc (badMethPred sel_id pred)) - where - pred_tvs = tyCoVarsOfType pred - - check_at (ATI fam_tc m_dflt_rhs) - = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) - (noClassTyVarErr cls fam_tc) - -- Check that the associated type mentions at least - -- one of the class type variables - -- The check is disabled for nullary type classes, - -- since there is no possible ambiguity (#10020) - - -- Check that any default declarations for associated types are valid - ; whenIsJust m_dflt_rhs $ \ (rhs, loc) -> - setSrcSpan loc $ - tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $ - checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs } - where - fam_tvs = tyConTyVars fam_tc - - check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM () - -- Check validity of the /top-level/ generic-default type - -- E.g for class C a where - -- default op :: forall b. (a~b) => blah - -- we do not want to do an ambiguity check on a type with - -- a free TyVar 'a' (#11608). See TcType - -- Note [TyVars and TcTyVars during type checking] in TcType - -- Hence the mkDefaultMethodType to close the type. - check_dm ctxt sel_id vanilla_cls_pred vanilla_tau - (Just (dm_name, dm_spec@(GenericDM dm_ty))) - = setSrcSpan (getSrcSpan dm_name) $ do - -- We have carefully set the SrcSpan on the generic - -- default-method Name to be that of the generic - -- default type signature - - -- First, we check that that the method's default type signature - -- aligns with the non-default type signature. - -- See Note [Default method type signatures must align] - let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls - -- Note that the second field of this tuple contains the context - -- of the default type signature, making it apparent that we - -- ignore method contexts completely when validity-checking - -- default type signatures. See the end of - -- Note [Default method type signatures must align] - -- to learn why this is OK. - -- - -- See also - -- Note [Splitting nested sigma types in class type signatures] - -- for an explanation of why we don't use tcSplitSigmaTy here. - (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty - - -- Given this class definition: - -- - -- class C a b where - -- op :: forall p q. (Ord a, D p q) - -- => a -> b -> p -> (a, b) - -- default op :: forall r s. E r - -- => a -> b -> s -> (a, b) - -- - -- We want to match up two types of the form: - -- - -- Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb) - -- Default type sig: C a b => a -> b -> s -> (a, b) - -- - -- Notice that the two type signatures can be quantified over - -- different class type variables! Therefore, it's important that - -- we include the class predicate parts to match up a with aa and - -- b with bb. - vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau - dm_phi_ty = mkPhiTy [cls_pred] dm_tau - - traceTc "check_dm" $ vcat - [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty - , text "dm_phi_ty" <+> ppr dm_phi_ty ] - - -- Actually checking that the types align is done with a call to - -- tcMatchTys. We need to get a match in both directions to rule - -- out degenerate cases like these: - -- - -- class Foo a where - -- foo1 :: a -> b - -- default foo1 :: a -> Int - -- - -- foo2 :: a -> Int - -- default foo2 :: a -> b - unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] - [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ - hang (text "The default type signature for" - <+> ppr sel_id <> colon) - 2 (ppr dm_ty) - $$ (text "does not match its corresponding" - <+> text "non-default type signature") - - -- Now do an ambiguity check on the default type signature. - checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec) - check_dm _ _ _ _ _ = return () - -checkFamFlag :: Name -> TcM () --- Check that we don't use families without -XTypeFamilies --- The parser won't even parse them, but I suppose a GHC API --- client might have a go! -checkFamFlag tc_name - = do { idx_tys <- xoptM LangExt.TypeFamilies - ; checkTc idx_tys err_msg } - where - err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) - 2 (text "Enable TypeFamilies to allow indexed type families") - -checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () -checkResultSigFlag tc_name (TyVarSig _ tvb) - = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies - ; checkTc ty_fam_deps $ - hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name)) - 2 (text "Enable TypeFamilyDependencies to allow result variable names") } -checkResultSigFlag _ _ = return () -- other cases OK - -{- Note [Class method constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Haskell 2010 is supposed to reject - class C a where - op :: Eq a => a -> a -where the method type constrains only the class variable(s). (The extension --XConstrainedClassMethods switches off this check.) But regardless -we should not reject - class C a where - op :: (?x::Int) => a -> a -as pointed out in #11793. So the test here rejects the program if - * -XConstrainedClassMethods is off - * the tyvars of the constraint are non-empty - * all the tyvars are class tyvars, none are locally quantified - -Note [Abort when superclass cycle is detected] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must avoid doing the ambiguity check for the methods (in -checkValidClass.check_op) when there are already errors accumulated. -This is because one of the errors may be a superclass cycle, and -superclass cycles cause canonicalization to loop. Here is a -representative example: - - class D a => C a where - meth :: D a => () - class C a => D a - -This fixes #9415, #9739 - -Note [Default method type signatures must align] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC enforces the invariant that a class method's default type signature -must "align" with that of the method's non-default type signature, as per -GHC #12918. For instance, if you have: - - class Foo a where - bar :: forall b. Context => a -> b - -Then a default type signature for bar must be alpha equivalent to -(forall b. a -> b). That is, the types must be the same modulo differences in -contexts. So the following would be acceptable default type signatures: - - default bar :: forall b. Context1 => a -> b - default bar :: forall x. Context2 => a -> x - -But the following are NOT acceptable default type signatures: - - default bar :: forall b. b -> a - default bar :: forall x. x - default bar :: a -> Int - -Note that a is bound by the class declaration for Foo itself, so it is -not allowed to differ in the default type signature. - -The default type signature (default bar :: a -> Int) deserves special mention, -since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To -write this, you need to declare the default type signature like so: - - default bar :: forall b. (b ~ Int). a -> b - -As noted in #12918, there are several reasons to do this: - -1. It would make no sense to have a type that was flat-out incompatible with - the non-default type signature. For instance, if you had: - - class Foo a where - bar :: a -> Int - default bar :: a -> Bool - - Then that would always fail in an instance declaration. So this check - nips such cases in the bud before they have the chance to produce - confusing error messages. - -2. Internally, GHC uses TypeApplications to instantiate the default method in - an instance. See Note [Default methods in instances] in TcInstDcls. - Thus, GHC needs to know exactly what the universally quantified type - variables are, and when instantiated that way, the default method's type - must match the expected type. - -3. Aesthetically, by only allowing the default type signature to differ in its - context, we are making it more explicit the ways in which the default type - signature is less polymorphic than the non-default type signature. - -You might be wondering: why are the contexts allowed to be different, but not -the rest of the type signature? That's because default implementations often -rely on assumptions that the more general, non-default type signatures do not. -For instance, in the Enum class declaration: - - class Enum a where - enum :: [a] - default enum :: (Generic a, GEnum (Rep a)) => [a] - enum = map to genum - - class GEnum f where - genum :: [f a] - -The default implementation for enum only works for types that are instances of -Generic, and for which their generic Rep type is an instance of GEnum. But -clearly enum doesn't _have_ to use this implementation, so naturally, the -context for enum is allowed to be different to accommodate this. As a result, -when we validity-check default type signatures, we ignore contexts completely. - -Note that when checking whether two type signatures match, we must take care to -split as many foralls as it takes to retrieve the tau types we which to check. -See Note [Splitting nested sigma types in class type signatures]. - -Note [Splitting nested sigma types in class type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this type synonym and class definition: - - type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t - - class Each s t a b where - each :: Traversal s t a b - default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b - -It might seem obvious that the tau types in both type signatures for `each` -are the same, but actually getting GHC to conclude this is surprisingly tricky. -That is because in general, the form of a class method's non-default type -signature is: - - forall a. C a => forall d. D d => E a b - -And the general form of a default type signature is: - - forall f. F f => E a f -- The variable `a` comes from the class - -So it you want to get the tau types in each type signature, you might find it -reasonable to call tcSplitSigmaTy twice on the non-default type signature, and -call it once on the default type signature. For most classes and methods, this -will work, but Each is a bit of an exceptional case. The way `each` is written, -it doesn't quantify any additional type variables besides those of the Each -class itself, so the non-default type signature for `each` is actually this: - - forall s t a b. Each s t a b => Traversal s t a b - -Notice that there _appears_ to only be one forall. But there's actually another -forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy -twice, you'll also go under the forall in Traversal! That is, you'll end up -with: - - (a -> f b) -> s -> f t - -A problem arises because you only call tcSplitSigmaTy once on the default type -signature for `each`, which gives you - - Traversal s t a b - -Or, equivalently: - - forall f. Applicative f => (a -> f b) -> s -> f t - -This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will -say that the tau types for `each` are not equal. - -A solution to this problem is to use tcSplitNestedSigmaTys instead of -tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it -sees until it can't go any further, so if you called it on the default type -signature for `each`, it would return (a -> f b) -> s -> f t like we desired. - -Note [Checking partial record field] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This check checks the partial record field selector, and warns (#7169). - -For example: - - data T a = A { m1 :: a, m2 :: a } | B { m1 :: a } - -The function 'm2' is partial record field, and will fail when it is applied to -'B'. The warning identifies such partial fields. The check is performed at the -declaration of T, not at the call-sites of m2. - -The warning can be suppressed by prefixing the field-name with an underscore. -For example: - - data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a } - -************************************************************************ -* * - Checking role validity -* * -************************************************************************ --} - -checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM () -checkValidRoleAnnots role_annots tc - | isTypeSynonymTyCon tc = check_no_roles - | isFamilyTyCon tc = check_no_roles - | isAlgTyCon tc = check_roles - | otherwise = return () - where - -- Role annotations are given only on *explicit* variables, - -- but a tycon stores roles for all variables. - -- So, we drop the implicit roles (which are all Nominal, anyway). - name = tyConName tc - roles = tyConRoles tc - (vis_roles, vis_vars) = unzip $ mapMaybe pick_vis $ - zip roles (tyConBinders tc) - role_annot_decl_maybe = lookupRoleAnnot role_annots name - - pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar) - pick_vis (role, tvb) - | isVisibleTyConBinder tvb = Just (role, binderVar tvb) - | otherwise = Nothing - - check_roles - = whenIsJust role_annot_decl_maybe $ - \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> - addRoleAnnotCtxt name $ - setSrcSpan loc $ do - { role_annots_ok <- xoptM LangExt.RoleAnnotations - ; checkTc role_annots_ok $ needXRoleAnnotations tc - ; checkTc (vis_vars `equalLength` the_role_annots) - (wrongNumberOfRoles vis_vars decl) - ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles - -- Representational or phantom roles for class parameters - -- quickly lead to incoherence. So, we require - -- IncoherentInstances to have them. See #8773, #14292 - ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances - ; checkTc ( incoherent_roles_ok - || (not $ isClassTyCon tc) - || (all (== Nominal) vis_roles)) - incoherentRoles - - ; lint <- goptM Opt_DoCoreLinting - ; when lint $ checkValidRoles tc } - - check_no_roles - = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl - -checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM () -checkRoleAnnot _ (L _ Nothing) _ = return () -checkRoleAnnot tv (L _ (Just r1)) r2 - = when (r1 /= r2) $ - addErrTc $ badRoleAnnot (tyVarName tv) r1 r2 - --- This is a double-check on the role inference algorithm. It is only run when --- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls -checkValidRoles :: TyCon -> TcM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint -checkValidRoles tc - | isAlgTyCon tc - -- tyConDataCons returns an empty list for data families - = mapM_ check_dc_roles (tyConDataCons tc) - | Just rhs <- synTyConRhs_maybe tc - = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs - | otherwise - = return () - where - check_dc_roles datacon - = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) - ; mapM_ (check_ty_roles role_env Representational) $ - eqSpecPreds eq_spec ++ theta ++ arg_tys } - -- See Note [Role-checking data constructor arguments] in TcTyDecls - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig datacon - univ_roles = zipVarEnv univ_tvs (tyConRoles tc) - -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs - ex_roles = mkVarEnv (map (, Nominal) ex_tvs) - role_env = univ_roles `plusVarEnv` ex_roles - - check_ty_roles env role ty - | Just ty' <- coreView ty -- #14101 - = check_ty_roles env role ty' - - check_ty_roles env role (TyVarTy tv) - = case lookupVarEnv env tv of - Just role' -> unless (role' `ltRole` role || role' == role) $ - report_error $ text "type variable" <+> quotes (ppr tv) <+> - text "cannot have role" <+> ppr role <+> - text "because it was assigned role" <+> ppr role' - Nothing -> report_error $ text "type variable" <+> quotes (ppr tv) <+> - text "missing in environment" - - check_ty_roles env Representational (TyConApp tc tys) - = let roles' = tyConRoles tc in - zipWithM_ (maybe_check_ty_roles env) roles' tys - - check_ty_roles env Nominal (TyConApp _ tys) - = mapM_ (check_ty_roles env Nominal) tys - - check_ty_roles _ Phantom ty@(TyConApp {}) - = pprPanic "check_ty_roles" (ppr ty) - - check_ty_roles env role (AppTy ty1 ty2) - = check_ty_roles env role ty1 - >> check_ty_roles env Nominal ty2 - - check_ty_roles env role (FunTy _ ty1 ty2) - = check_ty_roles env role ty1 - >> check_ty_roles env role ty2 - - check_ty_roles env role (ForAllTy (Bndr tv _) ty) - = check_ty_roles env Nominal (tyVarKind tv) - >> check_ty_roles (extendVarEnv env tv Nominal) role ty - - check_ty_roles _ _ (LitTy {}) = return () - - check_ty_roles env role (CastTy t _) - = check_ty_roles env role t - - check_ty_roles _ role (CoercionTy co) - = unless (role == Phantom) $ - report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role - - maybe_check_ty_roles env role ty - = when (role == Nominal || role == Representational) $ - check_ty_roles env role ty - - report_error doc - = addErrTc $ vcat [text "Internal error in role inference:", - doc, - text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] - -{- -************************************************************************ -* * - Error messages -* * -************************************************************************ --} - -tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc -tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl, - text "declaration for", quotes (ppr (tcdName decl))] - -addVDQNote :: TcTyCon -> TcM a -> TcM a --- See Note [Inferring visible dependent quantification] --- Only types without a signature (CUSK or SAK) here -addVDQNote tycon thing_inside - | ASSERT2( isTcTyCon tycon, ppr tycon ) - ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind ) - has_vdq - = addLandmarkErrCtxt vdq_warning thing_inside - | otherwise - = thing_inside - where - -- Check whether a tycon has visible dependent quantification. - -- This will *always* be a TcTyCon. Furthermore, it will *always* - -- be an ungeneralised TcTyCon, straight out of kcInferDeclHeader. - -- Thus, all the TyConBinders will be anonymous. Thus, the - -- free variables of the tycon's kind will be the same as the free - -- variables from all the binders. - has_vdq = any is_vdq_tcb (tyConBinders tycon) - tc_kind = tyConKind tycon - kind_fvs = tyCoVarsOfType tc_kind - - is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) && - isVisibleTyConBinder tcb - - vdq_warning = vcat - [ text "NB: Type" <+> quotes (ppr tycon) <+> - text "was inferred to use visible dependent quantification." - , text "Most types with visible dependent quantification are" - , text "polymorphically recursive and need a standalone kind" - , text "signature. Perhaps supply one, with StandaloneKindSignatures." - ] - -tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a -tcAddDeclCtxt decl thing_inside - = addErrCtxt (tcMkDeclCtxt decl) thing_inside - -tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a -tcAddTyFamInstCtxt decl - = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl) - -tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc -tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn = - HsIB { hsib_body = eqn }}) - = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance") - (unLoc (feqn_tycon eqn)) -tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs nec)) - = noExtCon nec - -tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a -tcAddDataFamInstCtxt decl - = addErrCtxt (tcMkDataFamInstCtxt decl) - -tcMkFamInstCtxt :: SDoc -> Name -> SDoc -tcMkFamInstCtxt flavour tycon - = hsep [ text "In the" <+> flavour <+> text "declaration for" - , quotes (ppr tycon) ] - -tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a -tcAddFamInstCtxt flavour tycon thing_inside - = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside - -tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a -tcAddClosedTypeFamilyDeclCtxt tc - = addErrCtxt ctxt - where - ctxt = text "In the equations for closed type family" <+> - quotes (ppr tc) - -resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc -resultTypeMisMatch field_name con1 con2 - = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, - text "have a common field" <+> quotes (ppr field_name) <> comma], - nest 2 $ text "but have different result types"] - -fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc -fieldTypeMisMatch field_name con1 con2 - = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, - text "give different types for field", quotes (ppr field_name)] - -dataConCtxtName :: [Located Name] -> SDoc -dataConCtxtName [con] - = text "In the definition of data constructor" <+> quotes (ppr con) -dataConCtxtName con - = text "In the definition of data constructors" <+> interpp'SP con - -dataConCtxt :: Outputable a => a -> SDoc -dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con) - -classOpCtxt :: Var -> Type -> SDoc -classOpCtxt sel_id tau = sep [text "When checking the class method:", - nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] - -classArityErr :: Int -> Class -> SDoc -classArityErr n cls - | n == 0 = mkErr "No" "no-parameter" - | otherwise = mkErr "Too many" "multi-parameter" - where - mkErr howMany allowWhat = - vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), - parens (text ("Enable MultiParamTypeClasses to allow " - ++ allowWhat ++ " classes"))] - -classFunDepsErr :: Class -> SDoc -classFunDepsErr cls - = vcat [text "Fundeps in class" <+> quotes (ppr cls), - parens (text "Enable FunctionalDependencies to allow fundeps")] - -badMethPred :: Id -> TcPredType -> SDoc -badMethPred sel_id pred - = vcat [ hang (text "Constraint" <+> quotes (ppr pred) - <+> text "in the type of" <+> quotes (ppr sel_id)) - 2 (text "constrains only the class type variables") - , text "Enable ConstrainedClassMethods to allow it" ] - -noClassTyVarErr :: Class -> TyCon -> SDoc -noClassTyVarErr clas fam_tc - = sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc))) - , text "mentions none of the type or kind variables of the class" <+> - quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] - -badDataConTyCon :: DataCon -> Type -> SDoc -badDataConTyCon data_con res_ty_tmpl - | ASSERT( all isTyVar tvs ) - tcIsForAllTy actual_res_ty - = nested_foralls_contexts_suggestion - | isJust (tcSplitPredFunTy_maybe actual_res_ty) - = nested_foralls_contexts_suggestion - | otherwise - = hang (text "Data constructor" <+> quotes (ppr data_con) <+> - text "returns type" <+> quotes (ppr actual_res_ty)) - 2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl)) - where - actual_res_ty = dataConOrigResTy data_con - - -- This suggestion is useful for suggesting how to correct code like what - -- was reported in #12087: - -- - -- data F a where - -- MkF :: Ord a => Eq a => a -> F a - -- - -- Although nested foralls or contexts are allowed in function type - -- signatures, it is much more difficult to engineer GADT constructor type - -- signatures to allow something similar, so we error in the latter case. - -- Nevertheless, we can at least suggest how a user might reshuffle their - -- exotic GADT constructor type signature so that GHC will accept. - nested_foralls_contexts_suggestion = - text "GADT constructor type signature cannot contain nested" - <+> quotes forAllLit <> text "s or contexts" - $+$ hang (text "Suggestion: instead use this type signature:") - 2 (ppr (dataConName data_con) <+> dcolon <+> ppr suggested_ty) - - -- To construct a type that GHC would accept (suggested_ty), we: - -- - -- 1) Find the existentially quantified type variables and the class - -- predicates from the datacon. (NB: We don't need the universally - -- quantified type variables, since rejigConRes won't substitute them in - -- the result type if it fails, as in this scenario.) - -- 2) Split apart the return type (which is headed by a forall or a - -- context) using tcSplitNestedSigmaTys, collecting the type variables - -- and class predicates we find, as well as the rho type lurking - -- underneath the nested foralls and contexts. - -- 3) Smash together the type variables and class predicates from 1) and - -- 2), and prepend them to the rho type from 2). - (tvs, theta, rho) = tcSplitNestedSigmaTys (dataConUserType data_con) - suggested_ty = mkSpecSigmaTy tvs theta rho - -badGadtDecl :: Name -> SDoc -badGadtDecl tc_name - = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) - , nest 2 (parens $ text "Enable the GADTs extension to allow this") ] - -badExistential :: DataCon -> SDoc -badExistential con - = hang (text "Data constructor" <+> quotes (ppr con) <+> - text "has existential type variables, a context, or a specialised result type") - 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con) - , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ]) - -badStupidTheta :: Name -> SDoc -badStupidTheta tc_name - = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) - -newtypeConError :: Name -> Int -> SDoc -newtypeConError tycon n - = sep [text "A newtype must have exactly one constructor,", - nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] - -newtypeStrictError :: DataCon -> SDoc -newtypeStrictError con - = sep [text "A newtype constructor cannot have a strictness annotation,", - nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] - -newtypeFieldErr :: DataCon -> Int -> SDoc -newtypeFieldErr con_name n_flds - = sep [text "The constructor of a newtype must have exactly one field", - nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] - -badSigTyDecl :: Name -> SDoc -badSigTyDecl tc_name - = vcat [ text "Illegal kind signature" <+> - quotes (ppr tc_name) - , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] - -emptyConDeclsErr :: Name -> SDoc -emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> text "has no constructors", - nest 2 $ text "(EmptyDataDecls permits this)"] - -wrongKindOfFamily :: TyCon -> SDoc -wrongKindOfFamily family - = text "Wrong category of family instance; declaration was for a" - <+> kindOfFamily - where - kindOfFamily | isTypeFamilyTyCon family = text "type family" - | isDataFamilyTyCon family = text "data family" - | otherwise = pprPanic "wrongKindOfFamily" (ppr family) - --- | Produce an error for oversaturated type family equations with too many --- required arguments. --- See Note [Oversaturated type family equations] in TcValidity. -wrongNumberOfParmsErr :: Arity -> SDoc -wrongNumberOfParmsErr max_args - = text "Number of parameters must match family declaration; expected" - <+> ppr max_args - -badRoleAnnot :: Name -> Role -> Role -> SDoc -badRoleAnnot var annot inferred - = hang (text "Role mismatch on variable" <+> ppr var <> colon) - 2 (sep [ text "Annotation says", ppr annot - , text "but role", ppr inferred - , text "is required" ]) - -wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc -wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) - = hang (text "Wrong number of roles listed in role annotation;" $$ - text "Expected" <+> (ppr $ length tyvars) <> comma <+> - text "got" <+> (ppr $ length annots) <> colon) - 2 (ppr d) -wrongNumberOfRoles _ (L _ (XRoleAnnotDecl nec)) = noExtCon nec - - -illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () -illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) - = setErrCtxt [] $ - setSrcSpan loc $ - addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ - text "they are allowed only for datatypes and classes.") -illegalRoleAnnotDecl (L _ (XRoleAnnotDecl nec)) = noExtCon nec - -needXRoleAnnotations :: TyCon -> SDoc -needXRoleAnnotations tc - = text "Illegal role annotation for" <+> ppr tc <> char ';' $$ - text "did you intend to use RoleAnnotations?" - -incoherentRoles :: SDoc -incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+> - text "for class parameters can lead to incoherence.") $$ - (text "Use IncoherentInstances to allow this; bad role found") - -addTyConCtxt :: TyCon -> TcM a -> TcM a -addTyConCtxt tc = addTyConFlavCtxt name flav - where - name = getName tc - flav = tyConFlavour tc - -addRoleAnnotCtxt :: Name -> TcM a -> TcM a -addRoleAnnotCtxt name - = addErrCtxt $ - text "while checking a role annotation for" <+> quotes (ppr name) diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs deleted file mode 100644 index cff4f3ed00..0000000000 --- a/compiler/typecheck/TcTyDecls.hs +++ /dev/null @@ -1,1060 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 - - -Analysis functions over data types. Specifically, detecting recursive types. - -This stuff is only used for source-code decls; it's recorded in interface -files for imported data types. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcTyDecls( - RolesInfo, - inferRoles, - checkSynCycles, - checkClassCycles, - - -- * Implicits - addTyConsToGblEnv, mkDefaultMethodType, - - -- * Record selectors - tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import TcRnMonad -import TcEnv -import TcBinds( tcValBinds ) -import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) -import TcType -import GHC.Core.Predicate -import TysWiredIn( unitTy ) -import GHC.Core.Make( rEC_SEL_ERROR_ID ) -import GHC.Hs -import GHC.Core.Class -import GHC.Core.Type -import GHC.Driver.Types -import GHC.Core.TyCon -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set hiding (unitFV) -import GHC.Types.Name.Reader ( mkVarUnqual ) -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Core.Coercion ( ltRole ) -import GHC.Types.Basic -import GHC.Types.SrcLoc -import GHC.Types.Unique ( mkBuiltinUnique ) -import Outputable -import Util -import Maybes -import Bag -import FastString -import FV -import GHC.Types.Module -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad - -{- -************************************************************************ -* * - Cycles in type synonym declarations -* * -************************************************************************ --} - -synonymTyConsOfType :: Type -> [TyCon] --- Does not look through type synonyms at all --- Return a list of synonym tycons --- Keep this synchronized with 'expandTypeSynonyms' -synonymTyConsOfType ty - = nameEnvElts (go ty) - where - go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim - go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys - go (LitTy _) = emptyNameEnv - go (TyVarTy _) = emptyNameEnv - go (AppTy a b) = go a `plusNameEnv` go b - go (FunTy _ a b) = go a `plusNameEnv` go b - go (ForAllTy _ ty) = go ty - go (CastTy ty co) = go ty `plusNameEnv` go_co co - go (CoercionTy co) = go_co co - - -- Note [TyCon cycles through coercions?!] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Although, in principle, it's possible for a type synonym loop - -- could go through a coercion (since a coercion can refer to - -- a TyCon or Type), it doesn't seem possible to actually construct - -- a Haskell program which tickles this case. Here is an example - -- program which causes a coercion: - -- - -- type family Star where - -- Star = Type - -- - -- data T :: Star -> Type - -- data S :: forall (a :: Type). T a -> Type - -- - -- Here, the application 'T a' must first coerce a :: Type to a :: Star, - -- witnessed by the type family. But if we now try to make Type refer - -- to a type synonym which in turn refers to Star, we'll run into - -- trouble: we're trying to define and use the type constructor - -- in the same recursive group. Possibly this restriction will be - -- lifted in the future but for now, this code is "just for completeness - -- sake". - go_mco MRefl = emptyNameEnv - go_mco (MCo co) = go_co co - - go_co (Refl ty) = go ty - go_co (GRefl _ ty mco) = go ty `plusNameEnv` go_mco mco - go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs - go_co (AppCo co co') = go_co co `plusNameEnv` go_co co' - go_co (ForAllCo _ co co') = go_co co `plusNameEnv` go_co co' - go_co (FunCo _ co co') = go_co co `plusNameEnv` go_co co' - go_co (CoVarCo _) = emptyNameEnv - go_co (HoleCo {}) = emptyNameEnv - go_co (AxiomInstCo _ _ cs) = go_co_s cs - go_co (UnivCo p _ ty ty') = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty' - go_co (SymCo co) = go_co co - go_co (TransCo co co') = go_co co `plusNameEnv` go_co co' - go_co (NthCo _ _ co) = go_co co - go_co (LRCo _ co) = go_co co - go_co (InstCo co co') = go_co co `plusNameEnv` go_co co' - go_co (KindCo co) = go_co co - go_co (SubCo co) = go_co co - go_co (AxiomRuleCo _ cs) = go_co_s cs - - go_prov (PhantomProv co) = go_co co - go_prov (ProofIrrelProv co) = go_co co - go_prov (PluginProv _) = emptyNameEnv - - go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc - | otherwise = emptyNameEnv - go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys - go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos - --- | A monad for type synonym cycle checking, which keeps --- track of the TyCons which are known to be acyclic, or --- a failure message reporting that a cycle was found. -newtype SynCycleM a = SynCycleM { - runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) } - deriving (Functor) - -type SynCycleState = NameSet - -instance Applicative SynCycleM where - pure x = SynCycleM $ \state -> Right (x, state) - (<*>) = ap - -instance Monad SynCycleM where - m >>= f = SynCycleM $ \state -> - case runSynCycleM m state of - Right (x, state') -> - runSynCycleM (f x) state' - Left err -> Left err - -failSynCycleM :: SrcSpan -> SDoc -> SynCycleM () -failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err) - --- | Test if a 'Name' is acyclic, short-circuiting if we've --- seen it already. -checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM () -checkNameIsAcyclic n m = SynCycleM $ \s -> - if n `elemNameSet` s - then Right ((), s) -- short circuit - else case runSynCycleM m s of - Right ((), s') -> Right ((), extendNameSet s' n) - Left err -> Left err - --- | Checks if any of the passed in 'TyCon's have cycles. --- Takes the 'UnitId' of the home package (as we can avoid --- checking those TyCons: cycles never go through foreign packages) and --- the corresponding @LTyClDecl Name@ for each 'TyCon', so we --- can give better error messages. -checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () -checkSynCycles this_uid tcs tyclds = do - case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of - Left (loc, err) -> setSrcSpan loc $ failWithTc err - Right _ -> return () - where - -- Try our best to print the LTyClDecl for locally defined things - lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds) - - -- Short circuit if we've already seen this Name and concluded - -- it was acyclic. - go :: NameSet -> [TyCon] -> TyCon -> SynCycleM () - go so_far seen_tcs tc = - checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc - - -- Expand type synonyms, complaining if you find the same - -- type synonym a second time. - go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM () - go' so_far seen_tcs tc - | n `elemNameSet` so_far - = failSynCycleM (getSrcSpan (head seen_tcs)) $ - sep [ text "Cycle in type synonym declarations:" - , nest 2 (vcat (map ppr_decl seen_tcs)) ] - -- Optimization: we don't allow cycles through external packages, - -- so once we find a non-local name we are guaranteed to not - -- have a cycle. - -- - -- This won't hold once we get recursive packages with Backpack, - -- but for now it's fine. - | not (isHoleModule mod || - moduleUnitId mod == this_uid || - isInteractiveModule mod) - = return () - | Just ty <- synTyConRhs_maybe tc = - go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty - | otherwise = return () - where - n = tyConName tc - mod = nameModule n - ppr_decl tc = - case lookupNameEnv lcl_decls n of - Just (L loc decl) -> ppr loc <> colon <+> ppr decl - Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n - <+> text "from external module" - where - n = tyConName tc - - go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM () - go_ty so_far seen_tcs ty = - mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty) - -{- Note [Superclass cycle check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The superclass cycle check for C decides if we can statically -guarantee that expanding C's superclass cycles transitively is -guaranteed to terminate. This is a Haskell98 requirement, -but one that we lift with -XUndecidableSuperClasses. - -The worry is that a superclass cycle could make the type checker loop. -More precisely, with a constraint (Given or Wanted) - C ty1 .. tyn -one approach is to instantiate all of C's superclasses, transitively. -We can only do so if that set is finite. - -This potential loop occurs only through superclasses. This, for -example, is fine - class C a where - op :: C b => a -> b -> b -even though C's full definition uses C. - -Making the check static also makes it conservative. Eg - type family F a - class F a => C a -Here an instance of (F a) might mention C: - type instance F [a] = C a -and now we'd have a loop. - -The static check works like this, starting with C - * Look at C's superclass predicates - * If any is a type-function application, - or is headed by a type variable, fail - * If any has C at the head, fail - * If any has a type class D at the head, - make the same test with D - -A tricky point is: what if there is a type variable at the head? -Consider this: - class f (C f) => C f - class c => Id c -and now expand superclasses for constraint (C Id): - C Id - --> Id (C Id) - --> C Id - --> .... -Each step expands superclasses one layer, and clearly does not terminate. --} - -checkClassCycles :: Class -> Maybe SDoc --- Nothing <=> ok --- Just err <=> possible cycle error -checkClassCycles cls - = do { (definite_cycle, err) <- go (unitNameSet (getName cls)) - cls (mkTyVarTys (classTyVars cls)) - ; let herald | definite_cycle = text "Superclass cycle for" - | otherwise = text "Potential superclass cycle for" - ; return (vcat [ herald <+> quotes (ppr cls) - , nest 2 err, hint]) } - where - hint = text "Use UndecidableSuperClasses to accept this" - - -- Expand superclasses starting with (C a b), complaining - -- if you find the same class a second time, or a type function - -- or predicate headed by a type variable - -- - -- NB: this code duplicates TcType.transSuperClasses, but - -- with more error message generation clobber - -- Make sure the two stay in sync. - go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) - go so_far cls tys = firstJusts $ - map (go_pred so_far) $ - immSuperClasses cls tys - - go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc) - -- Nothing <=> ok - -- Just (True, err) <=> definite cycle - -- Just (False, err) <=> possible cycle - go_pred so_far pred -- NB: tcSplitTyConApp looks through synonyms - | Just (tc, tys) <- tcSplitTyConApp_maybe pred - = go_tc so_far pred tc tys - | hasTyVarHead pred - = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:") - 2 (quotes (ppr pred))) - | otherwise - = Nothing - - go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc) - go_tc so_far pred tc tys - | isFamilyTyCon tc - = Just (False, hang (text "one of whose superclass constraints is headed by a type family:") - 2 (quotes (ppr pred))) - | Just cls <- tyConClass_maybe tc - = go_cls so_far cls tys - | otherwise -- Equality predicate, for example - = Nothing - - go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) - go_cls so_far cls tys - | cls_nm `elemNameSet` so_far - = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls)) - | isCTupleClass cls - = go so_far cls tys - | otherwise - = do { (b,err) <- go (so_far `extendNameSet` cls_nm) cls tys - ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls) - $$ err) } - where - cls_nm = getName cls - -{- -************************************************************************ -* * - Role inference -* * -************************************************************************ - -Note [Role inference] -~~~~~~~~~~~~~~~~~~~~~ -The role inference algorithm datatype definitions to infer the roles on the -parameters. Although these roles are stored in the tycons, we can perform this -algorithm on the built tycons, as long as we don't peek at an as-yet-unknown -roles field! Ah, the magic of laziness. - -First, we choose appropriate initial roles. For families and classes, roles -(including initial roles) are N. For datatypes, we start with the role in the -role annotation (if any), or otherwise use Phantom. This is done in -initialRoleEnv1. - -The function irGroup then propagates role information until it reaches a -fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a -monad RoleM, which is a combination reader and state monad. In its state are -the current RoleEnv, which gets updated by role propagation, and an update -bit, which we use to know whether or not we've reached the fixpoint. The -environment of RoleM contains the tycon whose parameters we are inferring, and -a VarEnv from parameters to their positions, so we can update the RoleEnv. -Between tycons, this reader information is missing; it is added by -addRoleInferenceInfo. - -There are two kinds of tycons to consider: algebraic ones (excluding classes) -and type synonyms. (Remember, families don't participate -- all their parameters -are N.) An algebraic tycon processes each of its datacons, in turn. Note that -a datacon's universally quantified parameters might be different from the parent -tycon's parameters, so we use the datacon's univ parameters in the mapping from -vars to positions. Note also that we don't want to infer roles for existentials -(they're all at N, too), so we put them in the set of local variables. As an -optimisation, we skip any tycons whose roles are already all Nominal, as there -nowhere else for them to go. For synonyms, we just analyse their right-hand sides. - -irType walks through a type, looking for uses of a variable of interest and -propagating role information. Because anything used under a phantom position -is at phantom and anything used under a nominal position is at nominal, the -irType function can assume that anything it sees is at representational. (The -other possibilities are pruned when they're encountered.) - -The rest of the code is just plumbing. - -How do we know that this algorithm is correct? It should meet the following -specification: - -Let Z be a role context -- a mapping from variables to roles. The following -rules define the property (Z |- t : r), where t is a type and r is a role: - -Z(a) = r' r' <= r -------------------------- RCVar -Z |- a : r - ----------- RCConst -Z |- T : r -- T is a type constructor - -Z |- t1 : r -Z |- t2 : N --------------- RCApp -Z |- t1 t2 : r - -forall i<=n. (r_i is R or N) implies Z |- t_i : r_i -roles(T) = r_1 .. r_n ----------------------------------------------------- RCDApp -Z |- T t_1 .. t_n : R - -Z, a:N |- t : r ----------------------- RCAll -Z |- forall a:k.t : r - - -We also have the following rules: - -For all datacon_i in type T, where a_1 .. a_n are universally quantified -and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p, -then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R, -then roles(T) = r_1 .. r_n - -roles(->) = R, R -roles(~#) = N, N - -With -dcore-lint on, the output of this algorithm is checked in checkValidRoles, -called from checkValidTycon. - -Note [Role-checking data constructor arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a where - MkT :: Eq b => F a -> (a->a) -> T (G a) - -Then we want to check the roles at which 'a' is used -in MkT's type. We want to work on the user-written type, -so we need to take into account - * the arguments: (F a) and (a->a) - * the context: C a b - * the result type: (G a) -- this is in the eq_spec - - -Note [Coercions in role inference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing -the kind of a type is totally irrelevant to the representation of that type. So, -we want to totally ignore coercions when doing role inference. This includes omitting -any type variables that appear in nominal positions but only within coercions. --} - -type RolesInfo = Name -> [Role] - -type RoleEnv = NameEnv [Role] -- from tycon names to roles - --- This, and any of the functions it calls, must *not* look at the roles --- field of a tycon we are inferring roles about! --- See Note [Role inference] -inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role] -inferRoles hsc_src annots tycons - = let role_env = initialRoleEnv hsc_src annots tycons - role_env' = irGroup role_env tycons in - \name -> case lookupNameEnv role_env' name of - Just roles -> roles - Nothing -> pprPanic "inferRoles" (ppr name) - -initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv -initialRoleEnv hsc_src annots = extendNameEnvList emptyNameEnv . - map (initialRoleEnv1 hsc_src annots) - -initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role]) -initialRoleEnv1 hsc_src annots_env tc - | isFamilyTyCon tc = (name, map (const Nominal) bndrs) - | isAlgTyCon tc = (name, default_roles) - | isTypeSynonymTyCon tc = (name, default_roles) - | otherwise = pprPanic "initialRoleEnv1" (ppr tc) - where name = tyConName tc - bndrs = tyConBinders tc - argflags = map tyConBinderArgFlag bndrs - num_exps = count isVisibleArgFlag argflags - - -- if the number of annotations in the role annotation decl - -- is wrong, just ignore it. We check this in the validity check. - role_annots - = case lookupRoleAnnot annots_env name of - Just (L _ (RoleAnnotDecl _ _ annots)) - | annots `lengthIs` num_exps -> map unLoc annots - _ -> replicate num_exps Nothing - default_roles = build_default_roles argflags role_annots - - build_default_roles (argf : argfs) (m_annot : ras) - | isVisibleArgFlag argf - = (m_annot `orElse` default_role) : build_default_roles argfs ras - build_default_roles (_argf : argfs) ras - = Nominal : build_default_roles argfs ras - build_default_roles [] [] = [] - build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)" - (vcat [ppr tc, ppr role_annots]) - - default_role - | isClassTyCon tc = Nominal - -- Note [Default roles for abstract TyCons in hs-boot/hsig] - | HsBootFile <- hsc_src - , isAbstractTyCon tc = Representational - | HsigFile <- hsc_src - , isAbstractTyCon tc = Nominal - | otherwise = Phantom - --- Note [Default roles for abstract TyCons in hs-boot/hsig] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- What should the default role for an abstract TyCon be? --- --- Originally, we inferred phantom role for abstract TyCons --- in hs-boot files, because the type variables were never used. --- --- This was silly, because the role of the abstract TyCon --- was required to match the implementation, and the roles of --- data types are almost never phantom. Thus, in ticket #9204, --- the default was changed so be representational (the most common case). If --- the implementing data type was actually nominal, you'd get an easy --- to understand error, and add the role annotation yourself. --- --- Then Backpack was added, and with it we added role *subtyping* --- the matching judgment: if an abstract TyCon has a nominal --- parameter, it's OK to implement it with a representational --- parameter. But now, the representational default is not a good --- one, because you should *only* request representational if --- you're planning to do coercions. To be maximally flexible --- with what data types you will accept, you want the default --- for hsig files is nominal. We don't allow role subtyping --- with hs-boot files (it's good practice to give an exactly --- accurate role here, because any types that use the abstract --- type will propagate the role information.) - -irGroup :: RoleEnv -> [TyCon] -> RoleEnv -irGroup env tcs - = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in - if update - then irGroup env' tcs - else env' - -irTyCon :: TyCon -> RoleM () -irTyCon tc - | isAlgTyCon tc - = do { old_roles <- lookupRoles tc - ; unless (all (== Nominal) old_roles) $ -- also catches data families, - -- which don't want or need role inference - irTcTyVars tc $ - do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958 - ; whenIsJust (tyConClass_maybe tc) irClass - ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }} - - | Just ty <- synTyConRhs_maybe tc - = irTcTyVars tc $ - irType emptyVarSet ty - - | otherwise - = return () - --- any type variable used in an associated type must be Nominal -irClass :: Class -> RoleM () -irClass cls - = mapM_ ir_at (classATs cls) - where - cls_tvs = classTyVars cls - cls_tv_set = mkVarSet cls_tvs - - ir_at at_tc - = mapM_ (updateRole Nominal) nvars - where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc - --- See Note [Role inference] -irDataCon :: DataCon -> RoleM () -irDataCon datacon - = setRoleInferenceVars univ_tvs $ - irExTyVars ex_tvs $ \ ex_var_set -> - mapM_ (irType ex_var_set) - (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ arg_tys) - -- See Note [Role-checking data constructor arguments] - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig datacon - -irType :: VarSet -> Type -> RoleM () -irType = go - where - go lcls ty | Just ty' <- coreView ty -- #14101 - = go lcls ty' - go lcls (TyVarTy tv) = unless (tv `elemVarSet` lcls) $ - updateRole Representational tv - go lcls (AppTy t1 t2) = go lcls t1 >> markNominal lcls t2 - go lcls (TyConApp tc tys) = do { roles <- lookupRolesX tc - ; zipWithM_ (go_app lcls) roles tys } - go lcls (ForAllTy tvb ty) = do { let tv = binderVar tvb - lcls' = extendVarSet lcls tv - ; markNominal lcls (tyVarKind tv) - ; go lcls' ty } - go lcls (FunTy _ arg res) = go lcls arg >> go lcls res - go _ (LitTy {}) = return () - -- See Note [Coercions in role inference] - go lcls (CastTy ty _) = go lcls ty - go _ (CoercionTy _) = return () - - go_app _ Phantom _ = return () -- nothing to do here - go_app lcls Nominal ty = markNominal lcls ty -- all vars below here are N - go_app lcls Representational ty = go lcls ty - -irTcTyVars :: TyCon -> RoleM a -> RoleM a -irTcTyVars tc thing - = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc) - where - go [] = thing - go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv) - ; addRoleInferenceVar tv $ go tvs } - -irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a -irExTyVars orig_tvs thing = go emptyVarSet orig_tvs - where - go lcls [] = thing lcls - go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv) - ; go (extendVarSet lcls tv) tvs } - -markNominal :: TyVarSet -- local variables - -> Type -> RoleM () -markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in - mapM_ (updateRole Nominal) nvars - where - -- get_ty_vars gets all the tyvars (no covars!) from a type *without* - -- recurring into coercions. Recall: coercions are totally ignored during - -- role inference. See [Coercions in role inference] - get_ty_vars :: Type -> FV - get_ty_vars (TyVarTy tv) = unitFV tv - get_ty_vars (AppTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 - get_ty_vars (FunTy _ t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 - get_ty_vars (TyConApp _ tys) = mapUnionFV get_ty_vars tys - get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty) - get_ty_vars (LitTy {}) = emptyFV - get_ty_vars (CastTy ty _) = get_ty_vars ty - get_ty_vars (CoercionTy _) = emptyFV - --- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps -lookupRolesX :: TyCon -> RoleM [Role] -lookupRolesX tc - = do { roles <- lookupRoles tc - ; return $ roles ++ repeat Nominal } - --- gets the roles either from the environment or the tycon -lookupRoles :: TyCon -> RoleM [Role] -lookupRoles tc - = do { env <- getRoleEnv - ; case lookupNameEnv env (tyConName tc) of - Just roles -> return roles - Nothing -> return $ tyConRoles tc } - --- tries to update a role; won't ever update a role "downwards" -updateRole :: Role -> TyVar -> RoleM () -updateRole role tv - = do { var_ns <- getVarNs - ; name <- getTyConName - ; case lookupVarEnv var_ns tv of - Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns) - Just n -> updateRoleEnv name n role } - --- the state in the RoleM monad -data RoleInferenceState = RIS { role_env :: RoleEnv - , update :: Bool } - --- the environment in the RoleM monad -type VarPositions = VarEnv Int - --- See [Role inference] -newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon - -> VarPositions - -> Int -- size of VarPositions - -> RoleInferenceState - -> (a, RoleInferenceState) } - deriving (Functor) - -instance Applicative RoleM where - pure x = RM $ \_ _ _ state -> (x, state) - (<*>) = ap - -instance Monad RoleM where - a >>= f = RM $ \m_info vps nvps state -> - let (a', state') = unRM a m_info vps nvps state in - unRM (f a') m_info vps nvps state' - -runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool) -runRoleM env thing = (env', update) - where RIS { role_env = env', update = update } - = snd $ unRM thing Nothing emptyVarEnv 0 state - state = RIS { role_env = env - , update = False } - -setRoleInferenceTc :: Name -> RoleM a -> RoleM a -setRoleInferenceTc name thing = RM $ \m_name vps nvps state -> - ASSERT( isNothing m_name ) - ASSERT( isEmptyVarEnv vps ) - ASSERT( nvps == 0 ) - unRM thing (Just name) vps nvps state - -addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a -addRoleInferenceVar tv thing - = RM $ \m_name vps nvps state -> - ASSERT( isJust m_name ) - unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state - -setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a -setRoleInferenceVars tvs thing - = RM $ \m_name _vps _nvps state -> - ASSERT( isJust m_name ) - unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars") - state - -getRoleEnv :: RoleM RoleEnv -getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state) - -getVarNs :: RoleM VarPositions -getVarNs = RM $ \_ vps _ state -> (vps, state) - -getTyConName :: RoleM Name -getTyConName = RM $ \m_name _ _ state -> - case m_name of - Nothing -> panic "getTyConName" - Just name -> (name, state) - -updateRoleEnv :: Name -> Int -> Role -> RoleM () -updateRoleEnv name n role - = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((), - case lookupNameEnv role_env name of - Nothing -> pprPanic "updateRoleEnv" (ppr name) - Just roles -> let (before, old_role : after) = splitAt n roles in - if role `ltRole` old_role - then let roles' = before ++ role : after - role_env' = extendNameEnv role_env name roles' in - RIS { role_env = role_env', update = True } - else state ) - - -{- ********************************************************************* -* * - Building implicits -* * -********************************************************************* -} - -addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv --- Given a [TyCon], add to the TcGblEnv --- * extend the TypeEnv with the tycons --- * extend the TypeEnv with their implicitTyThings --- * extend the TypeEnv with any default method Ids --- * add bindings for record selectors -addTyConsToGblEnv tyclss - = tcExtendTyConEnv tyclss $ - tcExtendGlobalEnvImplicit implicit_things $ - tcExtendGlobalValEnv def_meth_ids $ - do { traceTc "tcAddTyCons" $ vcat - [ text "tycons" <+> ppr tyclss - , text "implicits" <+> ppr implicit_things ] - ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss) - ; return gbl_env } - where - implicit_things = concatMap implicitTyConThings tyclss - def_meth_ids = mkDefaultMethodIds tyclss - -mkDefaultMethodIds :: [TyCon] -> [Id] --- We want to put the default-method Ids (both vanilla and generic) --- into the type environment so that they are found when we typecheck --- the filled-in default methods of each instance declaration --- See Note [Default method Ids and Template Haskell] -mkDefaultMethodIds tycons - = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec) - | tc <- tycons - , Just cls <- [tyConClass_maybe tc] - , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ] - -mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type --- Returns the top-level type of the default method -mkDefaultMethodType _ sel_id VanillaDM = idType sel_id -mkDefaultMethodType cls _ (GenericDM dm_ty) = mkSigmaTy tv_bndrs [pred] dm_ty - where - pred = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs)) - cls_bndrs = tyConBinders (classTyCon cls) - tv_bndrs = tyConTyVarBinders cls_bndrs - -- NB: the Class doesn't have TyConBinders; we reach into its - -- TyCon to get those. We /do/ need the TyConBinders because - -- we need the correct visibility: these default methods are - -- used in code generated by the fill-in for missing - -- methods in instances (TcInstDcls.mkDefMethBind), and - -- then typechecked. So we need the right visibility info - -- (#13998) - -{- -************************************************************************ -* * - Building record selectors -* * -************************************************************************ --} - -{- -Note [Default method Ids and Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#4169): - class Numeric a where - fromIntegerNum :: a - fromIntegerNum = ... - - ast :: Q [Dec] - ast = [d| instance Numeric Int |] - -When we typecheck 'ast' we have done the first pass over the class decl -(in tcTyClDecls), but we have not yet typechecked the default-method -declarations (because they can mention value declarations). So we -must bring the default method Ids into scope first (so they can be seen -when typechecking the [d| .. |] quote, and typecheck them later. --} - -{- -************************************************************************ -* * - Building record selectors -* * -************************************************************************ --} - -tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv -tcRecSelBinds sel_bind_prs - = tcExtendGlobalValEnv [sel_id | (L _ (IdSig _ sel_id)) <- sigs] $ - do { (rec_sel_binds, tcg_env) <- discardWarnings $ - -- See Note [Impredicative record selectors] - setXOptM LangExt.ImpredicativeTypes $ - tcValBinds TopLevel binds sigs getGblEnv - ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } - where - sigs = [ L loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs - , let loc = getSrcSpan sel_id ] - binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] - -mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] --- NB We produce *un-typechecked* bindings, rather like 'deriving' --- This makes life easier, because the later type checking will add --- all necessary type abstractions and applications -mkRecSelBinds tycons - = map mkRecSelBind [ (tc,fld) | tc <- tycons - , fld <- tyConFieldLabels tc ] - -mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn) -mkRecSelBind (tycon, fl) - = mkOneRecordSelector all_cons (RecSelData tycon) fl - where - all_cons = map RealDataCon (tyConDataCons tycon) - -mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel - -> (Id, LHsBind GhcRn) -mkOneRecordSelector all_cons idDetails fl - = (sel_id, L loc sel_bind) - where - loc = getSrcSpan sel_name - lbl = flLabel fl - sel_name = flSelector fl - - sel_id = mkExportedLocalId rec_details sel_name sel_ty - rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty } - - -- Find a representative constructor, con1 - cons_w_field = conLikesWithFields all_cons [lbl] - con1 = ASSERT( not (null cons_w_field) ) head cons_w_field - - -- Selector type; Note [Polymorphic selectors] - field_ty = conLikeFieldType con1 lbl - data_tvs = tyCoVarsOfTypesWellScoped inst_tys - data_tv_set= mkVarSet data_tvs - is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set) - (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty - sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] - | otherwise = mkSpecForAllTys data_tvs $ - mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! - mkVisFunTy data_ty $ - mkSpecForAllTys field_tvs $ - mkPhiTy field_theta $ - -- req_theta is empty for normal DataCon - mkPhiTy req_theta $ - field_tau - - -- Make the binding: sel (C2 { fld = x }) = x - -- sel (C7 { fld = x }) = x - -- where cons_w_field = [C2,C7] - sel_bind = mkTopFunBind Generated sel_lname alts - where - alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname) - [] unit_rhs] - | otherwise = map mk_match cons_w_field ++ deflt - mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) - [L loc (mk_sel_pat con)] - (L loc (HsVar noExtField (L loc field_var))) - mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) - rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } - rec_field = noLoc (HsRecField - { hsRecFieldLbl - = L loc (FieldOcc sel_name - (L loc $ mkVarUnqual lbl)) - , hsRecFieldArg - = L loc (VarPat noExtField (L loc field_var)) - , hsRecPun = False }) - sel_lname = L loc sel_name - field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc - - -- Add catch-all default case unless the case is exhaustive - -- We do this explicitly so that we get a nice error message that - -- mentions this particular record selector - deflt | all dealt_with all_cons = [] - | otherwise = [mkSimpleMatch CaseAlt - [L loc (WildPat noExtField)] - (mkHsApp (L loc (HsVar noExtField - (L loc (getName rEC_SEL_ERROR_ID)))) - (L loc (HsLit noExtField msg_lit)))] - - -- Do not add a default case unless there are unmatched - -- constructors. We must take account of GADTs, else we - -- get overlap warning messages from the pattern-match checker - -- NB: we need to pass type args for the *representation* TyCon - -- to dataConCannotMatch, hence the calculation of inst_tys - -- This matters in data families - -- data instance T Int a where - -- A :: { fld :: Int } -> T Int Bool - -- B :: { fld :: Int } -> T Int Char - dealt_with :: ConLike -> Bool - dealt_with (PatSynCon _) = False -- We can't predict overlap - dealt_with con@(RealDataCon dc) = - con `elem` cons_w_field || dataConCannotMatch inst_tys dc - - (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1 - - eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) - inst_tys = substTyVars eq_subst univ_tvs - - unit_rhs = mkLHsTupleExpr [] - msg_lit = HsStringPrim NoSourceText (bytesFS lbl) - -{- -Note [Polymorphic selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We take care to build the type of a polymorphic selector in the right -order, so that visible type application works. - - data Ord a => T a = MkT { field :: forall b. (Num a, Show b) => (a, b) } - -We want - - field :: forall a. Ord a => T a -> forall b. (Num a, Show b) => (a, b) - -Note [Naughty record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "naughty" field is one for which we can't define a record -selector, because an existential type variable would escape. For example: - data T = forall a. MkT { x,y::a } -We obviously can't define - x (MkT v _) = v -Nevertheless we *do* put a RecSelId into the type environment -so that if the user tries to use 'x' as a selector we can bleat -helpfully, rather than saying unhelpfully that 'x' is not in scope. -Hence the sel_naughty flag, to identify record selectors that don't really exist. - -In general, a field is "naughty" if its type mentions a type variable that -isn't in the result type of the constructor. Note that this *allows* -GADT record selectors (Note [GADT record selectors]) whose types may look -like sel :: T [a] -> a - -For naughty selectors we make a dummy binding - sel = () -so that the later type-check will add them to the environment, and they'll be -exported. The function is never called, because the typechecker spots the -sel_naughty field. - -Note [GADT record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For GADTs, we require that all constructors with a common field 'f' have the same -result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] -E.g. - data T where - T1 { f :: Maybe a } :: T [a] - T2 { f :: Maybe a, y :: b } :: T [a] - T3 :: T Int - -and now the selector takes that result type as its argument: - f :: forall a. T [a] -> Maybe a - -Details: the "real" types of T1,T2 are: - T1 :: forall r a. (r~[a]) => a -> T r - T2 :: forall r a b. (r~[a]) => a -> b -> T r - -So the selector loooks like this: - f :: forall a. T [a] -> Maybe a - f (a:*) (t:T [a]) - = case t of - T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) - T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) - T3 -> error "T3 does not have field f" - -Note the forall'd tyvars of the selector are just the free tyvars -of the result type; there may be other tyvars in the constructor's -type (e.g. 'b' in T2). - -Note the need for casts in the result! - -Note [Selector running example] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's OK to combine GADTs and type families. Here's a running example: - - data instance T [a] where - T1 { fld :: b } :: T [Maybe b] - -The representation type looks like this - data :R7T a where - T1 { fld :: b } :: :R7T (Maybe b) - -and there's coercion from the family type to the representation type - :CoR7T a :: T [a] ~ :R7T a - -The selector we want for fld looks like this: - - fld :: forall b. T [Maybe b] -> b - fld = /\b. \(d::T [Maybe b]). - case d `cast` :CoR7T (Maybe b) of - T1 (x::b) -> x - -The scrutinee of the case has type :R7T (Maybe b), which can be -gotten by applying the eq_spec to the univ_tvs of the data con. - -Note [Impredicative record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are situations where generating code for record selectors requires the -use of ImpredicativeTypes. Here is one example (adapted from #18005): - - type S = (forall b. b -> b) -> Int - data T = MkT {unT :: S} - | Dummy - -We want to generate HsBinds for unT that look something like this: - - unT :: S - unT (MkT x) = x - unT _ = recSelError "unT"# - -Note that the type of recSelError is `forall r (a :: TYPE r). Addr# -> a`. -Therefore, when used in the right-hand side of `unT`, GHC attempts to -instantiate `a` with `(forall b. b -> b) -> Int`, which is impredicative. -To make sure that GHC is OK with this, we enable ImpredicativeTypes interally -when typechecking these HsBinds so that the user does not have to. - -Although ImpredicativeTypes is somewhat fragile and unpredictable in GHC right -now, it will become robust when Quick Look impredicativity is implemented. In -the meantime, using ImpredicativeTypes to instantiate the `a` type variable in -recSelError's type does actually work, so its use here is benign. --} diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs deleted file mode 100644 index bc575cef66..0000000000 --- a/compiler/typecheck/TcType.hs +++ /dev/null @@ -1,2491 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[TcType]{Types used in the typechecker} - -This module provides the Type interface for front-end parts of the -compiler. These parts - - * treat "source types" as opaque: - newtypes, and predicates are meaningful. - * look through usage types - -The "tc" prefix is for "TypeChecker", because the type checker -is the principal client. --} - -{-# LANGUAGE CPP, ScopedTypeVariables, MultiWayIf, FlexibleContexts #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcType ( - -------------------------------- - -- Types - TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, - TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, - TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcTyCon, - KnotTied, - - ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType, - - SyntaxOpType(..), synKnownType, mkSynFunTys, - - -- TcLevel - TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, - strictlyDeeperThan, sameDepthAs, - tcTypeLevel, tcTyVarLevel, maxTcLevel, - promoteSkolem, promoteSkolemX, promoteSkolemsX, - -------------------------------- - -- MetaDetails - TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, - MetaDetails(Flexi, Indirect), MetaInfo(..), - isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, - tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar, - isFskTyVar, isFmvTyVar, isFlattenTyVar, - isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo, - isFlexi, isIndirect, isRuntimeUnkSkol, - metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, - isTouchableMetaTyVar, - isFloatedTouchableMetaTyVar, - findDupTyVarTvs, mkTyVarNamePairs, - - -------------------------------- - -- Builders - mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, - mkTcAppTy, mkTcAppTys, mkTcCastTy, - - -------------------------------- - -- Splitters - -- These are important because they do not look through newtypes - getTyVar, - tcSplitForAllTy_maybe, - tcSplitForAllTys, tcSplitForAllTysSameVis, - tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllVarBndrs, - tcSplitPhiTy, tcSplitPredFunTy_maybe, - tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN, - tcSplitFunTysN, - tcSplitTyConApp, tcSplitTyConApp_maybe, - tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, - tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe, - tcRepGetNumAppTys, - tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, - tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe, - - --------------------------------- - -- Predicates. - -- Again, newtypes are opaque - eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, - pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, - isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, - isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, - isIntegerTy, isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred, - hasIPPred, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, - isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck, - checkValidClsArgs, hasTyVarHead, - isRigidTy, isAlmostFunctionFree, - - --------------------------------- - -- Misc type manipulators - - deNoteType, - orphNamesOfType, orphNamesOfCo, - orphNamesOfTypes, orphNamesOfCoCon, - getDFunTyKey, evVarPred, - - --------------------------------- - -- Predicate types - mkMinimalBySCs, transSuperClasses, - pickQuantifiablePreds, pickCapturedPreds, - immSuperClasses, boxEqPred, - isImprovementPred, - - -- * Finding type instances - tcTyFamInsts, tcTyFamInstsAndVis, tcTyConAppTyFamInstsAndVis, isTyFamFree, - - -- * Finding "exact" (non-dead) type variables - exactTyCoVarsOfType, exactTyCoVarsOfTypes, - anyRewritableTyVar, - - --------------------------------- - -- Foreign import and export - isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool - isFFIImportResultTy, -- :: DynFlags -> Type -> Bool - isFFIExportResultTy, -- :: Type -> Bool - isFFIExternalTy, -- :: Type -> Bool - isFFIDynTy, -- :: Type -> Type -> Bool - isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool - isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool - isFFILabelTy, -- :: Type -> Bool - isFFITy, -- :: Type -> Bool - isFunPtrTy, -- :: Type -> Bool - tcSplitIOType_maybe, -- :: Type -> Maybe Type - - -------------------------------- - -- Reexported from Kind - Kind, tcTypeKind, - liftedTypeKind, - constraintKind, - isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues, - - -------------------------------- - -- Reexported from Type - Type, PredType, ThetaType, TyCoBinder, - ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), - - mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy, - mkInvForAllTy, mkInvForAllTys, - mkVisFunTy, mkVisFunTys, mkInvisFunTy, mkInvisFunTys, - mkTyConApp, mkAppTy, mkAppTys, - mkTyConTy, mkTyVarTy, mkTyVarTys, - mkTyCoVarTy, mkTyCoVarTys, - - isClassPred, isEqPrimPred, isIPPred, isEqPred, isEqPredClass, - mkClassPred, - tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, - isRuntimeRepVar, isKindLevPoly, - isVisibleBinder, isInvisibleBinder, - - -- Type substitutions - TCvSubst(..), -- Representation visible to a few friends - TvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, - zipTvSubst, - mkTvSubstPrs, notElemTCvSubst, unionTCvSubst, - getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope, - extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope, - Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, - Type.extendTvSubst, - isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, - Type.substTy, substTys, substTyWith, substTyWithCoVars, - substTyAddInScope, - substTyUnchecked, substTysUnchecked, substThetaUnchecked, - substTyWithUnchecked, - substCoUnchecked, substCoWithUnchecked, - substTheta, - - isUnliftedType, -- Source types are always lifted - isUnboxedTupleType, -- Ditto - isPrimitiveType, - - tcView, coreView, - - tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, - tyCoFVsOfType, tyCoFVsOfTypes, - tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet, - tyCoVarsOfTypeList, tyCoVarsOfTypesList, - noFreeVarsOfType, - - -------------------------------- - pprKind, pprParendKind, pprSigmaType, - pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory, - pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred, - pprTCvBndr, pprTCvBndrs, - - TypeSize, sizeType, sizeTypes, scopedSort, - - --------------------------------- - -- argument visibility - tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible - - ) where - -#include "HsVersions.h" - --- friends: -import GhcPrelude - -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars ) -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Ppr -import GHC.Core.Class -import GHC.Types.Var -import GHC.Types.ForeignCall -import GHC.Types.Var.Set -import GHC.Core.Coercion -import GHC.Core.Type as Type -import GHC.Core.Predicate -import GHC.Types.RepType -import GHC.Core.TyCon - --- others: -import GHC.Driver.Session -import GHC.Core.FVs -import GHC.Types.Name as Name - -- We use this to make dictionaries for type literals. - -- Perhaps there's a better way to do this? -import GHC.Types.Name.Set -import GHC.Types.Var.Env -import PrelNames -import TysWiredIn( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey - , listTyCon, constraintKind ) -import GHC.Types.Basic -import Util -import Maybes -import ListSetOps ( getNth, findDupsEq ) -import Outputable -import FastString -import ErrUtils( Validity(..), MsgDoc, isValid ) -import qualified GHC.LanguageExtensions as LangExt - -import Data.List ( mapAccumL ) --- import Data.Functor.Identity( Identity(..) ) -import Data.IORef -import Data.List.NonEmpty( NonEmpty(..) ) - -{- -************************************************************************ -* * - Types -* * -************************************************************************ - -The type checker divides the generic Type world into the -following more structured beasts: - -sigma ::= forall tyvars. phi - -- A sigma type is a qualified type - -- - -- Note that even if 'tyvars' is empty, theta - -- may not be: e.g. (?x::Int) => Int - - -- Note that 'sigma' is in prenex form: - -- all the foralls are at the front. - -- A 'phi' type has no foralls to the right of - -- an arrow - -phi :: theta => rho - -rho ::= sigma -> rho - | tau - --- A 'tau' type has no quantification anywhere --- Note that the args of a type constructor must be taus -tau ::= tyvar - | tycon tau_1 .. tau_n - | tau_1 tau_2 - | tau_1 -> tau_2 - --- In all cases, a (saturated) type synonym application is legal, --- provided it expands to the required form. - -Note [TcTyVars and TyVars in the typechecker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker uses a lot of type variables with special properties, -notably being a unification variable with a mutable reference. These -use the 'TcTyVar' variant of Var.Var. - -Note, though, that a /bound/ type variable can (and probably should) -be a TyVar. E.g - forall a. a -> a -Here 'a' is really just a deBruijn-number; it certainly does not have -a significant TcLevel (as every TcTyVar does). So a forall-bound type -variable should be TyVars; and hence a TyVar can appear free in a TcType. - -The type checker and constraint solver can also encounter /free/ type -variables that use the 'TyVar' variant of Var.Var, for a couple of -reasons: - - - When typechecking a class decl, say - class C (a :: k) where - foo :: T a -> Int - We have first kind-check the header; fix k and (a:k) to be - TyVars, bring 'k' and 'a' into scope, and kind check the - signature for 'foo'. In doing so we call solveEqualities to - solve any kind equalities in foo's signature. So the solver - may see free occurrences of 'k'. - - See calls to tcExtendTyVarEnv for other places that ordinary - TyVars are bought into scope, and hence may show up in the types - and kinds generated by TcHsType. - - - The pattern-match overlap checker calls the constraint solver, - long after TcTyVars have been zonked away - -It's convenient to simply treat these TyVars as skolem constants, -which of course they are. We give them a level number of "outermost", -so they behave as global constants. Specifically: - -* Var.tcTyVarDetails succeeds on a TyVar, returning - vanillaSkolemTv, as well as on a TcTyVar. - -* tcIsTcTyVar returns True for both TyVar and TcTyVar variants - of Var.Var. The "tc" prefix means "a type variable that can be - encountered by the typechecker". - -This is a bit of a change from an earlier era when we remoselessly -insisted on real TcTyVars in the type checker. But that seems -unnecessary (for skolems, TyVars are fine) and it's now very hard -to guarantee, with the advent of kind equalities. - -Note [Coercion variables in free variable lists] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several places in the GHC codebase where functions like -tyCoVarsOfType, tyCoVarsOfCt, et al. are used to compute the free type -variables of a type. The "Co" part of these functions' names shouldn't be -dismissed, as it is entirely possible that they will include coercion variables -in addition to type variables! As a result, there are some places in TcType -where we must take care to check that a variable is a _type_ variable (using -isTyVar) before calling tcTyVarDetails--a partial function that is not defined -for coercion variables--on the variable. Failing to do so led to -GHC #12785. --} - --- See Note [TcTyVars and TyVars in the typechecker] -type TcCoVar = CoVar -- Used only during type inference -type TcType = Type -- A TcType can have mutable type variables -type TcTyCoVar = Var -- Either a TcTyVar or a CoVar - -- Invariant on ForAllTy in TcTypes: - -- forall a. T - -- a cannot occur inside a MutTyVar in T; that is, - -- T is "flattened" before quantifying over a - -type TcTyVarBinder = TyVarBinder -type TcTyCon = TyCon -- these can be the TcTyCon constructor - --- These types do not have boxy type variables in them -type TcPredType = PredType -type TcThetaType = ThetaType -type TcSigmaType = TcType -type TcRhoType = TcType -- Note [TcRhoType] -type TcTauType = TcType -type TcKind = Kind -type TcTyVarSet = TyVarSet -type TcTyCoVarSet = TyCoVarSet -type TcDTyVarSet = DTyVarSet -type TcDTyCoVarSet = DTyCoVarSet - -{- ********************************************************************* -* * - ExpType: an "expected type" in the type checker -* * -********************************************************************* -} - --- | An expected type to check against during type-checking. --- See Note [ExpType] in TcMType, where you'll also find manipulators. -data ExpType = Check TcType - | Infer !InferResult - -data InferResult - = IR { ir_uniq :: Unique -- For debugging only - - , ir_lvl :: TcLevel -- See Note [TcLevel of ExpType] in TcMType - - , ir_inst :: Bool - -- True <=> deeply instantiate before returning - -- i.e. return a RhoType - -- False <=> do not instantiate before returning - -- i.e. return a SigmaType - -- See Note [Deep instantiation of InferResult] in TcUnify - - , ir_ref :: IORef (Maybe TcType) } - -- The type that fills in this hole should be a Type, - -- that is, its kind should be (TYPE rr) for some rr - -type ExpSigmaType = ExpType -type ExpRhoType = ExpType - -instance Outputable ExpType where - ppr (Check ty) = text "Check" <> braces (ppr ty) - ppr (Infer ir) = ppr ir - -instance Outputable InferResult where - ppr (IR { ir_uniq = u, ir_lvl = lvl - , ir_inst = inst }) - = text "Infer" <> braces (ppr u <> comma <> ppr lvl <+> ppr inst) - --- | Make an 'ExpType' suitable for checking. -mkCheckExpType :: TcType -> ExpType -mkCheckExpType = Check - - -{- ********************************************************************* -* * - SyntaxOpType -* * -********************************************************************* -} - --- | What to expect for an argument to a rebindable-syntax operator. --- Quite like 'Type', but allows for holes to be filled in by tcSyntaxOp. --- The callback called from tcSyntaxOp gets a list of types; the meaning --- of these types is determined by a left-to-right depth-first traversal --- of the 'SyntaxOpType' tree. So if you pass in --- --- > SynAny `SynFun` (SynList `SynFun` SynType Int) `SynFun` SynAny --- --- you'll get three types back: one for the first 'SynAny', the /element/ --- type of the list, and one for the last 'SynAny'. You don't get anything --- for the 'SynType', because you've said positively that it should be an --- Int, and so it shall be. --- --- This is defined here to avoid defining it in TcExpr.hs-boot. -data SyntaxOpType - = SynAny -- ^ Any type - | SynRho -- ^ A rho type, deeply skolemised or instantiated as appropriate - | SynList -- ^ A list type. You get back the element type of the list - | SynFun SyntaxOpType SyntaxOpType - -- ^ A function. - | SynType ExpType -- ^ A known type. -infixr 0 `SynFun` - --- | Like 'SynType' but accepts a regular TcType -synKnownType :: TcType -> SyntaxOpType -synKnownType = SynType . mkCheckExpType - --- | Like 'mkFunTys' but for 'SyntaxOpType' -mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType -mkSynFunTys arg_tys res_ty = foldr SynFun (SynType res_ty) arg_tys - - -{- -Note [TcRhoType] -~~~~~~~~~~~~~~~~ -A TcRhoType has no foralls or contexts at the top, or to the right of an arrow - YES (forall a. a->a) -> Int - NO forall a. a -> Int - NO Eq a => a -> a - NO Int -> forall a. a -> Int - - -************************************************************************ -* * - TyVarDetails, MetaDetails, MetaInfo -* * -************************************************************************ - -TyVarDetails gives extra info about type variables, used during type -checking. It's attached to mutable type variables only. -It's knot-tied back to Var.hs. There is no reason in principle -why Var.hs shouldn't actually have the definition, but it "belongs" here. - -Note [Signature skolems] -~~~~~~~~~~~~~~~~~~~~~~~~ -A TyVarTv is a specialised variant of TauTv, with the following invariants: - - * A TyVarTv can be unified only with a TyVar, - not with any other type - - * Its MetaDetails, if filled in, will always be another TyVarTv - or a SkolemTv - -TyVarTvs are only distinguished to improve error messages. -Consider this - - data T (a:k1) = MkT (S a) - data S (b:k2) = MkS (T b) - -When doing kind inference on {S,T} we don't want *skolems* for k1,k2, -because they end up unifying; we want those TyVarTvs again. - - -Note [TyVars and TcTyVars during type checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Var type has constructors TyVar and TcTyVar. They are used -as follows: - -* TcTyVar: used /only/ during type checking. Should never appear - afterwards. May contain a mutable field, in the MetaTv case. - -* TyVar: is never seen by the constraint solver, except locally - inside a type like (forall a. [a] ->[a]), where 'a' is a TyVar. - We instantiate these with TcTyVars before exposing the type - to the constraint solver. - -I have swithered about the latter invariant, excluding TyVars from the -constraint solver. It's not strictly essential, and indeed -(historically but still there) Var.tcTyVarDetails returns -vanillaSkolemTv for a TyVar. - -But ultimately I want to seeparate Type from TcType, and in that case -we would need to enforce the separation. --} - --- A TyVarDetails is inside a TyVar --- See Note [TyVars and TcTyVars] -data TcTyVarDetails - = SkolemTv -- A skolem - TcLevel -- Level of the implication that binds it - -- See TcUnify Note [Deeper level on the left] for - -- how this level number is used - Bool -- True <=> this skolem type variable can be overlapped - -- when looking up instances - -- See Note [Binding when looking up instances] in GHC.Core.InstEnv - - | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi - -- interactive context - - | MetaTv { mtv_info :: MetaInfo - , mtv_ref :: IORef MetaDetails - , mtv_tclvl :: TcLevel } -- See Note [TcLevel and untouchable type variables] - -vanillaSkolemTv, superSkolemTv :: TcTyVarDetails --- See Note [Binding when looking up instances] in GHC.Core.InstEnv -vanillaSkolemTv = SkolemTv topTcLevel False -- Might be instantiated -superSkolemTv = SkolemTv topTcLevel True -- Treat this as a completely distinct type - -- The choice of level number here is a bit dodgy, but - -- topTcLevel works in the places that vanillaSkolemTv is used - -instance Outputable TcTyVarDetails where - ppr = pprTcTyVarDetails - -pprTcTyVarDetails :: TcTyVarDetails -> SDoc --- For debugging -pprTcTyVarDetails (RuntimeUnk {}) = text "rt" -pprTcTyVarDetails (SkolemTv lvl True) = text "ssk" <> colon <> ppr lvl -pprTcTyVarDetails (SkolemTv lvl False) = text "sk" <> colon <> ppr lvl -pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) - = ppr info <> colon <> ppr tclvl - ------------------------------ -data MetaDetails - = Flexi -- Flexi type variables unify to become Indirects - | Indirect TcType - -data MetaInfo - = TauTv -- This MetaTv is an ordinary unification variable - -- A TauTv is always filled in with a tau-type, which - -- never contains any ForAlls. - - | TyVarTv -- A variant of TauTv, except that it should not be - -- unified with a type, only with a type variable - -- See Note [Signature skolems] - - | FlatMetaTv -- A flatten meta-tyvar - -- It is a meta-tyvar, but it is always untouchable, with level 0 - -- See Note [The flattening story] in TcFlatten - - | FlatSkolTv -- A flatten skolem tyvar - -- Just like FlatMetaTv, but is completely "owned" by - -- its Given CFunEqCan. - -- It is filled in /only/ by unflattenGivens - -- See Note [The flattening story] in TcFlatten - -instance Outputable MetaDetails where - ppr Flexi = text "Flexi" - ppr (Indirect ty) = text "Indirect" <+> ppr ty - -instance Outputable MetaInfo where - ppr TauTv = text "tau" - ppr TyVarTv = text "tyv" - ppr FlatMetaTv = text "fmv" - ppr FlatSkolTv = text "fsk" - -{- ********************************************************************* -* * - Untouchable type variables -* * -********************************************************************* -} - -newtype TcLevel = TcLevel Int deriving( Eq, Ord ) - -- See Note [TcLevel and untouchable type variables] for what this Int is - -- See also Note [TcLevel assignment] - -{- -Note [TcLevel and untouchable type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Each unification variable (MetaTv) - and each Implication - has a level number (of type TcLevel) - -* INVARIANTS. In a tree of Implications, - - (ImplicInv) The level number (ic_tclvl) of an Implication is - STRICTLY GREATER THAN that of its parent - - (SkolInv) The level number of the skolems (ic_skols) of an - Implication is equal to the level of the implication - itself (ic_tclvl) - - (GivenInv) The level number of a unification variable appearing - in the 'ic_given' of an implication I should be - STRICTLY LESS THAN the ic_tclvl of I - - (WantedInv) The level number of a unification variable appearing - in the 'ic_wanted' of an implication I should be - LESS THAN OR EQUAL TO the ic_tclvl of I - See Note [WantedInv] - -* A unification variable is *touchable* if its level number - is EQUAL TO that of its immediate parent implication, - and it is a TauTv or TyVarTv (but /not/ FlatMetaTv or FlatSkolTv) - -Note [WantedInv] -~~~~~~~~~~~~~~~~ -Why is WantedInv important? Consider this implication, where -the constraint (C alpha[3]) disobeys WantedInv: - - forall[2] a. blah => (C alpha[3]) - (forall[3] b. alpha[3] ~ b) - -We can unify alpha:=b in the inner implication, because 'alpha' is -touchable; but then 'b' has excaped its scope into the outer implication. - -Note [Skolem escape prevention] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only unify touchable unification variables. Because of -(WantedInv), there can be no occurrences of the variable further out, -so the unification can't cause the skolems to escape. Example: - data T = forall a. MkT a (a->Int) - f x (MkT v f) = length [v,x] -We decide (x::alpha), and generate an implication like - [1]forall a. (a ~ alpha[0]) -But we must not unify alpha:=a, because the skolem would escape. - -For the cases where we DO want to unify, we rely on floating the -equality. Example (with same T) - g x (MkT v f) = x && True -We decide (x::alpha), and generate an implication like - [1]forall a. (Bool ~ alpha[0]) -We do NOT unify directly, bur rather float out (if the constraint -does not mention 'a') to get - (Bool ~ alpha[0]) /\ [1]forall a.() -and NOW we can unify alpha. - -The same idea of only unifying touchables solves another problem. -Suppose we had - (F Int ~ uf[0]) /\ [1](forall a. C a => F Int ~ beta[1]) -In this example, beta is touchable inside the implication. The -first solveSimpleWanteds step leaves 'uf' un-unified. Then we move inside -the implication where a new constraint - uf ~ beta -emerges. If we (wrongly) spontaneously solved it to get uf := beta, -the whole implication disappears but when we pop out again we are left with -(F Int ~ uf) which will be unified by our final zonking stage and -uf will get unified *once more* to (F Int). - -Note [TcLevel assignment] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We arrange the TcLevels like this - - 0 Top level - 1 First-level implication constraints - 2 Second-level implication constraints - ...etc... --} - -maxTcLevel :: TcLevel -> TcLevel -> TcLevel -maxTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `max` b) - -topTcLevel :: TcLevel --- See Note [TcLevel assignment] -topTcLevel = TcLevel 0 -- 0 = outermost level - -isTopTcLevel :: TcLevel -> Bool -isTopTcLevel (TcLevel 0) = True -isTopTcLevel _ = False - -pushTcLevel :: TcLevel -> TcLevel --- See Note [TcLevel assignment] -pushTcLevel (TcLevel us) = TcLevel (us + 1) - -strictlyDeeperThan :: TcLevel -> TcLevel -> Bool -strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl) - = tv_tclvl > ctxt_tclvl - -sameDepthAs :: TcLevel -> TcLevel -> Bool -sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) - = ctxt_tclvl == tv_tclvl -- NB: invariant ctxt_tclvl >= tv_tclvl - -- So <= would be equivalent - -checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool --- Checks (WantedInv) from Note [TcLevel and untouchable type variables] -checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) - = ctxt_tclvl >= tv_tclvl - --- Returns topTcLevel for non-TcTyVars -tcTyVarLevel :: TcTyVar -> TcLevel -tcTyVarLevel tv - = case tcTyVarDetails tv of - MetaTv { mtv_tclvl = tv_lvl } -> tv_lvl - SkolemTv tv_lvl _ -> tv_lvl - RuntimeUnk -> topTcLevel - - -tcTypeLevel :: TcType -> TcLevel --- Max level of any free var of the type -tcTypeLevel ty - = foldDVarSet add topTcLevel (tyCoVarsOfTypeDSet ty) - where - add v lvl - | isTcTyVar v = lvl `maxTcLevel` tcTyVarLevel v - | otherwise = lvl - -instance Outputable TcLevel where - ppr (TcLevel us) = ppr us - -promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar -promoteSkolem tclvl skol - | tclvl < tcTyVarLevel skol - = ASSERT( isTcTyVar skol && isSkolemTyVar skol ) - setTcTyVarDetails skol (SkolemTv tclvl (isOverlappableTyVar skol)) - - | otherwise - = skol - --- | Change the TcLevel in a skolem, extending a substitution -promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar) -promoteSkolemX tclvl subst skol - = ASSERT( isTcTyVar skol && isSkolemTyVar skol ) - (new_subst, new_skol) - where - new_skol - | tclvl < tcTyVarLevel skol - = setTcTyVarDetails (updateTyVarKind (substTy subst) skol) - (SkolemTv tclvl (isOverlappableTyVar skol)) - | otherwise - = updateTyVarKind (substTy subst) skol - new_subst = extendTvSubstWithClone subst skol new_skol - -promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar]) -promoteSkolemsX tclvl = mapAccumL (promoteSkolemX tclvl) - -{- ********************************************************************* -* * - Finding type family instances -* * -************************************************************************ --} - --- | Finds outermost type-family applications occurring in a type, --- after expanding synonyms. In the list (F, tys) that is returned --- we guarantee that tys matches F's arity. For example, given --- type family F a :: * -> * (arity 1) --- calling tcTyFamInsts on (Maybe (F Int Bool) will return --- (F, [Int]), not (F, [Int,Bool]) --- --- This is important for its use in deciding termination of type --- instances (see #11581). E.g. --- type instance G [Int] = ...(F Int <big type>)... --- we don't need to take <big type> into account when asking if --- the calls on the RHS are smaller than the LHS -tcTyFamInsts :: Type -> [(TyCon, [Type])] -tcTyFamInsts = map (\(_,b,c) -> (b,c)) . tcTyFamInstsAndVis - --- | Like 'tcTyFamInsts', except that the output records whether the --- type family and its arguments occur as an /invisible/ argument in --- some type application. This information is useful because it helps GHC know --- when to turn on @-fprint-explicit-kinds@ during error reporting so that --- users can actually see the type family being mentioned. --- --- As an example, consider: --- --- @ --- class C a --- data T (a :: k) --- type family F a :: k --- instance C (T @(F Int) (F Bool)) --- @ --- --- There are two occurrences of the type family `F` in that `C` instance, so --- @'tcTyFamInstsAndVis' (C (T \@(F Int) (F Bool)))@ will return: --- --- @ --- [ ('True', F, [Int]) --- , ('False', F, [Bool]) ] --- @ --- --- @F Int@ is paired with 'True' since it appears as an /invisible/ argument --- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a --- /visible/ argument to @C@. --- --- See also @Note [Kind arguments in error messages]@ in "TcErrors". -tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])] -tcTyFamInstsAndVis = tcTyFamInstsAndVisX False - -tcTyFamInstsAndVisX - :: Bool -- ^ Is this an invisible argument to some type application? - -> Type -> [(Bool, TyCon, [Type])] -tcTyFamInstsAndVisX = go - where - go is_invis_arg ty - | Just exp_ty <- tcView ty = go is_invis_arg exp_ty - go _ (TyVarTy _) = [] - go is_invis_arg (TyConApp tc tys) - | isTypeFamilyTyCon tc - = [(is_invis_arg, tc, take (tyConArity tc) tys)] - | otherwise - = tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys - go _ (LitTy {}) = [] - go is_invis_arg (ForAllTy bndr ty) = go is_invis_arg (binderType bndr) - ++ go is_invis_arg ty - go is_invis_arg (FunTy _ ty1 ty2) = go is_invis_arg ty1 - ++ go is_invis_arg ty2 - go is_invis_arg ty@(AppTy _ _) = - let (ty_head, ty_args) = splitAppTys ty - ty_arg_flags = appTyArgFlags ty_head ty_args - in go is_invis_arg ty_head - ++ concat (zipWith (\flag -> go (isInvisibleArgFlag flag)) - ty_arg_flags ty_args) - go is_invis_arg (CastTy ty _) = go is_invis_arg ty - go _ (CoercionTy _) = [] -- don't count tyfams in coercions, - -- as they never get normalized, - -- anyway - --- | In an application of a 'TyCon' to some arguments, find the outermost --- occurrences of type family applications within the arguments. This function --- will not consider the 'TyCon' itself when checking for type family --- applications. --- --- See 'tcTyFamInstsAndVis' for more details on how this works (as this --- function is called inside of 'tcTyFamInstsAndVis'). -tcTyConAppTyFamInstsAndVis :: TyCon -> [Type] -> [(Bool, TyCon, [Type])] -tcTyConAppTyFamInstsAndVis = tcTyConAppTyFamInstsAndVisX False - -tcTyConAppTyFamInstsAndVisX - :: Bool -- ^ Is this an invisible argument to some type application? - -> TyCon -> [Type] -> [(Bool, TyCon, [Type])] -tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys = - let (invis_tys, vis_tys) = partitionInvisibleTypes tc tys - in concat $ map (tcTyFamInstsAndVisX True) invis_tys - ++ map (tcTyFamInstsAndVisX is_invis_arg) vis_tys - -isTyFamFree :: Type -> Bool --- ^ Check that a type does not contain any type family applications. -isTyFamFree = null . tcTyFamInsts - -anyRewritableTyVar :: Bool -- Ignore casts and coercions - -> EqRel -- Ambient role - -> (EqRel -> TcTyVar -> Bool) - -> TcType -> Bool --- (anyRewritableTyVar ignore_cos pred ty) returns True --- if the 'pred' returns True of any free TyVar in 'ty' --- Do not look inside casts and coercions if 'ignore_cos' is True --- See Note [anyRewritableTyVar must be role-aware] -anyRewritableTyVar ignore_cos role pred ty - = go role emptyVarSet ty - where - -- NB: No need to expand synonyms, because we can find - -- all free variables of a synonym by looking at its - -- arguments - - go_tv rl bvs tv | tv `elemVarSet` bvs = False - | otherwise = pred rl tv - - go rl bvs (TyVarTy tv) = go_tv rl bvs tv - go _ _ (LitTy {}) = False - go rl bvs (TyConApp tc tys) = go_tc rl bvs tc tys - go rl bvs (AppTy fun arg) = go rl bvs fun || go NomEq bvs arg - go rl bvs (FunTy _ arg res) = go NomEq bvs arg_rep || go NomEq bvs res_rep || - go rl bvs arg || go rl bvs res - where arg_rep = getRuntimeRep arg -- forgetting these causes #17024 - res_rep = getRuntimeRep res - go rl bvs (ForAllTy tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty - go rl bvs (CastTy ty co) = go rl bvs ty || go_co rl bvs co - go rl bvs (CoercionTy co) = go_co rl bvs co -- ToDo: check - - go_tc NomEq bvs _ tys = any (go NomEq bvs) tys - go_tc ReprEq bvs tc tys = any (go_arg bvs) - (tyConRolesRepresentational tc `zip` tys) - - go_arg bvs (Nominal, ty) = go NomEq bvs ty - go_arg bvs (Representational, ty) = go ReprEq bvs ty - go_arg _ (Phantom, _) = False -- We never rewrite with phantoms - - go_co rl bvs co - | ignore_cos = False - | otherwise = anyVarSet (go_tv rl bvs) (tyCoVarsOfCo co) - -- We don't have an equivalent of anyRewritableTyVar for coercions - -- (at least not yet) so take the free vars and test them - -{- Note [anyRewritableTyVar must be role-aware] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -anyRewritableTyVar is used during kick-out from the inert set, -to decide if, given a new equality (a ~ ty), we should kick out -a constraint C. Rather than gather free variables and see if 'a' -is among them, we instead pass in a predicate; this is just efficiency. - -Moreover, consider - work item: [G] a ~R f b - inert item: [G] b ~R f a -We use anyRewritableTyVar to decide whether to kick out the inert item, -on the grounds that the work item might rewrite it. Well, 'a' is certainly -free in [G] b ~R f a. But because the role of a type variable ('f' in -this case) is nominal, the work item can't actually rewrite the inert item. -Moreover, if we were to kick out the inert item the exact same situation -would re-occur and we end up with an infinite loop in which each kicks -out the other (#14363). --} - -{- ********************************************************************* -* * - The "exact" free variables of a type -* * -********************************************************************* -} - -{- Note [Silly type synonym] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type T a = Int -What are the free tyvars of (T x)? Empty, of course! - -exactTyCoVarsOfType is used by the type checker to figure out exactly -which type variables are mentioned in a type. It only matters -occasionally -- see the calls to exactTyCoVarsOfType. - -We place this function here in TcType, not in GHC.Core.TyCo.FVs, -because we want to "see" tcView (efficiency issue only). --} - -exactTyCoVarsOfType :: Type -> TyCoVarSet -exactTyCoVarsOfTypes :: [Type] -> TyCoVarSet --- Find the free type variables (of any kind) --- but *expand* type synonyms. See Note [Silly type synonym] above. - -exactTyCoVarsOfType ty = runTyCoVars (exact_ty ty) -exactTyCoVarsOfTypes tys = runTyCoVars (exact_tys tys) - -exact_ty :: Type -> Endo TyCoVarSet -exact_tys :: [Type] -> Endo TyCoVarSet -(exact_ty, exact_tys, _, _) = foldTyCo exactTcvFolder emptyVarSet - -exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) -exactTcvFolder = deepTcvFolder { tcf_view = tcView } - -- This is the key line - -{- -************************************************************************ -* * - Predicates -* * -************************************************************************ --} - -tcIsTcTyVar :: TcTyVar -> Bool --- See Note [TcTyVars and TyVars in the typechecker] -tcIsTcTyVar tv = isTyVar tv - -isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool -isTouchableMetaTyVar ctxt_tclvl tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv - , not (isFlattenInfo info) - = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl, - ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl ) - tv_tclvl `sameDepthAs` ctxt_tclvl - - | otherwise = False - -isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool -isFloatedTouchableMetaTyVar ctxt_tclvl tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv - , not (isFlattenInfo info) - = tv_tclvl `strictlyDeeperThan` ctxt_tclvl - - | otherwise = False - -isImmutableTyVar :: TyVar -> Bool -isImmutableTyVar tv = isSkolemTyVar tv - -isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, - isMetaTyVar, isAmbiguousTyVar, - isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool - -isTyConableTyVar tv - -- True of a meta-type variable that can be filled in - -- with a type constructor application; in particular, - -- not a TyVarTv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = case tcTyVarDetails tv of - MetaTv { mtv_info = TyVarTv } -> False - _ -> True - | otherwise = True - -isFmvTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_info = FlatMetaTv } -> True - _ -> False - -isFskTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_info = FlatSkolTv } -> True - _ -> False - --- | True of both given and wanted flatten-skolems (fmv and fsk) -isFlattenTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv { mtv_info = info } -> isFlattenInfo info - _ -> False - -isSkolemTyVar tv - = ASSERT2( tcIsTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv {} -> False - _other -> True - -isOverlappableTyVar tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = case tcTyVarDetails tv of - SkolemTv _ overlappable -> overlappable - _ -> False - | otherwise = False - -isMetaTyVar tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = case tcTyVarDetails tv of - MetaTv {} -> True - _ -> False - | otherwise = False - --- isAmbiguousTyVar is used only when reporting type errors --- It picks out variables that are unbound, namely meta --- type variables and the RuntimUnk variables created by --- GHC.Runtime.Heap.Inspect.zonkRTTIType. These are "ambiguous" in --- the sense that they stand for an as-yet-unknown type -isAmbiguousTyVar tv - | isTyVar tv -- See Note [Coercion variables in free variable lists] - = case tcTyVarDetails tv of - MetaTv {} -> True - RuntimeUnk {} -> True - _ -> False - | otherwise = False - -isMetaTyVarTy :: TcType -> Bool -isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv -isMetaTyVarTy _ = False - -metaTyVarInfo :: TcTyVar -> MetaInfo -metaTyVarInfo tv - = case tcTyVarDetails tv of - MetaTv { mtv_info = info } -> info - _ -> pprPanic "metaTyVarInfo" (ppr tv) - -isFlattenInfo :: MetaInfo -> Bool -isFlattenInfo FlatMetaTv = True -isFlattenInfo FlatSkolTv = True -isFlattenInfo _ = False - -metaTyVarTcLevel :: TcTyVar -> TcLevel -metaTyVarTcLevel tv - = case tcTyVarDetails tv of - MetaTv { mtv_tclvl = tclvl } -> tclvl - _ -> pprPanic "metaTyVarTcLevel" (ppr tv) - -metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel -metaTyVarTcLevel_maybe tv - = case tcTyVarDetails tv of - MetaTv { mtv_tclvl = tclvl } -> Just tclvl - _ -> Nothing - -metaTyVarRef :: TyVar -> IORef MetaDetails -metaTyVarRef tv - = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } -> ref - _ -> pprPanic "metaTyVarRef" (ppr tv) - -setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar -setMetaTyVarTcLevel tv tclvl - = case tcTyVarDetails tv of - details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl }) - _ -> pprPanic "metaTyVarTcLevel" (ppr tv) - -isTyVarTyVar :: Var -> Bool -isTyVarTyVar tv - = case tcTyVarDetails tv of - MetaTv { mtv_info = TyVarTv } -> True - _ -> False - -isFlexi, isIndirect :: MetaDetails -> Bool -isFlexi Flexi = True -isFlexi _ = False - -isIndirect (Indirect _) = True -isIndirect _ = False - -isRuntimeUnkSkol :: TyVar -> Bool --- Called only in TcErrors; see Note [Runtime skolems] there -isRuntimeUnkSkol x - | RuntimeUnk <- tcTyVarDetails x = True - | otherwise = False - -mkTyVarNamePairs :: [TyVar] -> [(Name,TyVar)] --- Just pair each TyVar with its own name -mkTyVarNamePairs tvs = [(tyVarName tv, tv) | tv <- tvs] - -findDupTyVarTvs :: [(Name,TcTyVar)] -> [(Name,Name)] --- If we have [...(x1,tv)...(x2,tv)...] --- return (x1,x2) in the result list -findDupTyVarTvs prs - = concatMap mk_result_prs $ - findDupsEq eq_snd prs - where - eq_snd (_,tv1) (_,tv2) = tv1 == tv2 - mk_result_prs ((n1,_) :| xs) = map (\(n2,_) -> (n1,n2)) xs - -{- -************************************************************************ -* * -\subsection{Tau, sigma and rho} -* * -************************************************************************ --} - -mkSigmaTy :: [TyCoVarBinder] -> [PredType] -> Type -> Type -mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) - --- | Make a sigma ty where all type variables are 'Inferred'. That is, --- they cannot be used with visible type application. -mkInfSigmaTy :: [TyCoVar] -> [PredType] -> Type -> Type -mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkTyCoVarBinders Inferred tyvars) theta ty - --- | Make a sigma ty where all type variables are "specified". That is, --- they can be used with visible type application -mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type -mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyCoVarBinders Specified tyvars) preds ty - -mkPhiTy :: [PredType] -> Type -> Type -mkPhiTy = mkInvisFunTys - ---------------- -getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to - -- construct a dictionary function name -getDFunTyKey ty | Just ty' <- coreView ty = getDFunTyKey ty' -getDFunTyKey (TyVarTy tv) = getOccName tv -getDFunTyKey (TyConApp tc _) = getOccName tc -getDFunTyKey (LitTy x) = getDFunTyLitKey x -getDFunTyKey (AppTy fun _) = getDFunTyKey fun -getDFunTyKey (FunTy {}) = getOccName funTyCon -getDFunTyKey (ForAllTy _ t) = getDFunTyKey t -getDFunTyKey (CastTy ty _) = getDFunTyKey ty -getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) - -getDFunTyLitKey :: TyLit -> OccName -getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) -getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm - -{- ********************************************************************* -* * - Building types -* * -********************************************************************* -} - --- ToDo: I think we need Tc versions of these --- Reason: mkCastTy checks isReflexiveCastTy, which checks --- for equality; and that has a different answer --- depending on whether or not Type = Constraint - -mkTcAppTys :: Type -> [Type] -> Type -mkTcAppTys = mkAppTys - -mkTcAppTy :: Type -> Type -> Type -mkTcAppTy = mkAppTy - -mkTcCastTy :: Type -> Coercion -> Type -mkTcCastTy = mkCastTy -- Do we need a tc version of mkCastTy? - -{- -************************************************************************ -* * -\subsection{Expanding and splitting} -* * -************************************************************************ - -These tcSplit functions are like their non-Tc analogues, but - *) they do not look through newtypes - -However, they are non-monadic and do not follow through mutable type -variables. It's up to you to make sure this doesn't matter. --} - --- | Splits a forall type into a list of 'TyBinder's and the inner type. --- Always succeeds, even if it returns an empty list. -tcSplitPiTys :: Type -> ([TyBinder], Type) -tcSplitPiTys ty - = ASSERT( all isTyBinder (fst sty) ) sty - where sty = splitPiTys ty - --- | Splits a type into a TyBinder and a body, if possible. Panics otherwise -tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type) -tcSplitPiTy_maybe ty - = ASSERT( isMaybeTyBinder sty ) sty - where - sty = splitPiTy_maybe ty - isMaybeTyBinder (Just (t,_)) = isTyBinder t - isMaybeTyBinder _ = True - -tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type) -tcSplitForAllTy_maybe ty | Just ty' <- tcView ty = tcSplitForAllTy_maybe ty' -tcSplitForAllTy_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty) -tcSplitForAllTy_maybe _ = Nothing - --- | Like 'tcSplitPiTys', but splits off only named binders, --- returning just the tycovars. -tcSplitForAllTys :: Type -> ([TyVar], Type) -tcSplitForAllTys ty - = ASSERT( all isTyVar (fst sty) ) sty - where sty = splitForAllTys ty - --- | Like 'tcSplitForAllTys', but only splits a 'ForAllTy' if --- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility --- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided --- as an argument to this function. -tcSplitForAllTysSameVis :: ArgFlag -> Type -> ([TyVar], Type) -tcSplitForAllTysSameVis supplied_argf ty = ASSERT( all isTyVar (fst sty) ) sty - where sty = splitForAllTysSameVis supplied_argf ty - --- | Like 'tcSplitForAllTys', but splits off only named binders. -tcSplitForAllVarBndrs :: Type -> ([TyVarBinder], Type) -tcSplitForAllVarBndrs ty = ASSERT( all isTyVarBinder (fst sty)) sty - where sty = splitForAllVarBndrs ty - --- | Is this a ForAllTy with a named binder? -tcIsForAllTy :: Type -> Bool -tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy {}) = True -tcIsForAllTy _ = False - -tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) --- Split off the first predicate argument from a type -tcSplitPredFunTy_maybe ty - | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' -tcSplitPredFunTy_maybe (FunTy { ft_af = InvisArg - , ft_arg = arg, ft_res = res }) - = Just (arg, res) -tcSplitPredFunTy_maybe _ - = Nothing - -tcSplitPhiTy :: Type -> (ThetaType, Type) -tcSplitPhiTy ty - = split ty [] - where - split ty ts - = case tcSplitPredFunTy_maybe ty of - Just (pred, ty) -> split ty (pred:ts) - Nothing -> (reverse ts, ty) - --- | Split a sigma type into its parts. -tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) -tcSplitSigmaTy ty = case tcSplitForAllTys ty of - (tvs, rho) -> case tcSplitPhiTy rho of - (theta, tau) -> (tvs, theta, tau) - --- | Split a sigma type into its parts, going underneath as many @ForAllTy@s --- as possible. For example, given this type synonym: --- --- @ --- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t --- @ --- --- if you called @tcSplitSigmaTy@ on this type: --- --- @ --- forall s t a b. Each s t a b => Traversal s t a b --- @ --- --- then it would return @([s,t,a,b], [Each s t a b], Traversal s t a b)@. But --- if you instead called @tcSplitNestedSigmaTys@ on the type, it would return --- @([s,t,a,b,f], [Each s t a b, Applicative f], (a -> f b) -> s -> f t)@. -tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type) --- NB: This is basically a pure version of deeplyInstantiate (from Inst) that --- doesn't compute an HsWrapper. -tcSplitNestedSigmaTys ty - -- If there's a forall, split it apart and try splitting the rho type - -- underneath it. - | Just (arg_tys, tvs1, theta1, rho1) <- tcDeepSplitSigmaTy_maybe ty - = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1 - in (tvs1 ++ tvs2, theta1 ++ theta2, mkVisFunTys arg_tys rho2) - -- If there's no forall, we're done. - | otherwise = ([], [], ty) - ------------------------ -tcDeepSplitSigmaTy_maybe - :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType) --- Looks for a *non-trivial* quantified type, under zero or more function arrows --- By "non-trivial" we mean either tyvars or constraints are non-empty - -tcDeepSplitSigmaTy_maybe ty - | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty - , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty - = Just (arg_ty:arg_tys, tvs, theta, rho) - - | (tvs, theta, rho) <- tcSplitSigmaTy ty - , not (null tvs && null theta) - = Just ([], tvs, theta, rho) - - | otherwise = Nothing - ------------------------ -tcTyConAppTyCon :: Type -> TyCon -tcTyConAppTyCon ty - = case tcTyConAppTyCon_maybe ty of - Just tc -> tc - Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty) - --- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'. -tcTyConAppTyCon_maybe :: Type -> Maybe TyCon -tcTyConAppTyCon_maybe ty - | Just ty' <- tcView ty = tcTyConAppTyCon_maybe ty' -tcTyConAppTyCon_maybe (TyConApp tc _) - = Just tc -tcTyConAppTyCon_maybe (FunTy { ft_af = VisArg }) - = Just funTyCon -- (=>) is /not/ a TyCon in its own right - -- C.f. tcRepSplitAppTy_maybe -tcTyConAppTyCon_maybe _ - = Nothing - -tcTyConAppArgs :: Type -> [Type] -tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of - Just (_, args) -> args - Nothing -> pprPanic "tcTyConAppArgs" (pprType ty) - -tcSplitTyConApp :: Type -> (TyCon, [Type]) -tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) - ------------------------ -tcSplitFunTys :: Type -> ([Type], Type) -tcSplitFunTys ty = case tcSplitFunTy_maybe ty of - Nothing -> ([], ty) - Just (arg,res) -> (arg:args, res') - where - (args,res') = tcSplitFunTys res - -tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) -tcSplitFunTy_maybe ty - | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' -tcSplitFunTy_maybe (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) - | VisArg <- af = Just (arg, res) -tcSplitFunTy_maybe _ = Nothing - -- Note the VisArg guard - -- Consider (?x::Int) => Bool - -- We don't want to treat this as a function type! - -- A concrete example is test tc230: - -- f :: () -> (?p :: ()) => () -> () - -- - -- g = f () () - -tcSplitFunTysN :: Arity -- n: Number of desired args - -> TcRhoType - -> Either Arity -- Number of missing arrows - ([TcSigmaType], -- Arg types (always N types) - TcSigmaType) -- The rest of the type --- ^ Split off exactly the specified number argument types --- Returns --- (Left m) if there are 'm' missing arrows in the type --- (Right (tys,res)) if the type looks like t1 -> ... -> tn -> res -tcSplitFunTysN n ty - | n == 0 - = Right ([], ty) - | Just (arg,res) <- tcSplitFunTy_maybe ty - = case tcSplitFunTysN (n-1) res of - Left m -> Left m - Right (args,body) -> Right (arg:args, body) - | otherwise - = Left n - -tcSplitFunTy :: Type -> (Type, Type) -tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) - -tcFunArgTy :: Type -> Type -tcFunArgTy ty = fst (tcSplitFunTy ty) - -tcFunResultTy :: Type -> Type -tcFunResultTy ty = snd (tcSplitFunTy ty) - --- | Strips off n *visible* arguments and returns the resulting type -tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type -tcFunResultTyN n ty - | Right (_, res_ty) <- tcSplitFunTysN n ty - = res_ty - | otherwise - = pprPanic "tcFunResultTyN" (ppr n <+> ppr ty) - ------------------------ -tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) -tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty' -tcSplitAppTy_maybe ty = tcRepSplitAppTy_maybe ty - -tcSplitAppTy :: Type -> (Type, Type) -tcSplitAppTy ty = case tcSplitAppTy_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "tcSplitAppTy" (pprType ty) - -tcSplitAppTys :: Type -> (Type, [Type]) -tcSplitAppTys ty - = go ty [] - where - go ty args = case tcSplitAppTy_maybe ty of - Just (ty', arg) -> go ty' (arg:args) - Nothing -> (ty,args) - --- | Returns the number of arguments in the given type, without --- looking through synonyms. This is used only for error reporting. --- We don't look through synonyms because of #11313. -tcRepGetNumAppTys :: Type -> Arity -tcRepGetNumAppTys = length . snd . repSplitAppTys - ------------------------ --- | If the type is a tyvar, possibly under a cast, returns it, along --- with the coercion. Thus, the co is :: kind tv ~N kind type -tcGetCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) -tcGetCastedTyVar_maybe ty | Just ty' <- tcView ty = tcGetCastedTyVar_maybe ty' -tcGetCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) -tcGetCastedTyVar_maybe (TyVarTy tv) = Just (tv, mkNomReflCo (tyVarKind tv)) -tcGetCastedTyVar_maybe _ = Nothing - -tcGetTyVar_maybe :: Type -> Maybe TyVar -tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty' -tcGetTyVar_maybe (TyVarTy tv) = Just tv -tcGetTyVar_maybe _ = Nothing - -tcGetTyVar :: String -> Type -> TyVar -tcGetTyVar msg ty - = case tcGetTyVar_maybe ty of - Just tv -> tv - Nothing -> pprPanic msg (ppr ty) - -tcIsTyVarTy :: Type -> Bool -tcIsTyVarTy ty | Just ty' <- tcView ty = tcIsTyVarTy ty' -tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as - -- this is only used for - -- e.g., FlexibleContexts -tcIsTyVarTy (TyVarTy _) = True -tcIsTyVarTy _ = False - ------------------------ -tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) --- Split the type of a dictionary function --- We don't use tcSplitSigmaTy, because a DFun may (with NDP) --- have non-Pred arguments, such as --- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m --- --- Also NB splitFunTys, not tcSplitFunTys; --- the latter specifically stops at PredTy arguments, --- and we don't want to do that here -tcSplitDFunTy ty - = case tcSplitForAllTys ty of { (tvs, rho) -> - case splitFunTys rho of { (theta, tau) -> - case tcSplitDFunHead tau of { (clas, tys) -> - (tvs, theta, clas, tys) }}} - -tcSplitDFunHead :: Type -> (Class, [Type]) -tcSplitDFunHead = getClassPredTys - -tcSplitMethodTy :: Type -> ([TyVar], PredType, Type) --- A class method (selector) always has a type like --- forall as. C as => blah --- So if the class looks like --- class C a where --- op :: forall b. (Eq a, Ix b) => a -> b --- the class method type looks like --- op :: forall a. C a => forall b. (Eq a, Ix b) => a -> b --- --- tcSplitMethodTy just peels off the outer forall and --- that first predicate -tcSplitMethodTy ty - | (sel_tyvars,sel_rho) <- tcSplitForAllTys ty - , Just (first_pred, local_meth_ty) <- tcSplitPredFunTy_maybe sel_rho - = (sel_tyvars, first_pred, local_meth_ty) - | otherwise - = pprPanic "tcSplitMethodTy" (ppr ty) - - -{- ********************************************************************* -* * - Type equalities -* * -********************************************************************* -} - -tcEqKind :: HasDebugCallStack => TcKind -> TcKind -> Bool -tcEqKind = tcEqType - -tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool --- tcEqType is a proper implements the same Note [Non-trivial definitional --- equality] (in GHC.Core.TyCo.Rep) as `eqType`, but Type.eqType believes (* == --- Constraint), and that is NOT what we want in the type checker! -tcEqType ty1 ty2 - = tc_eq_type False False ki1 ki2 - && tc_eq_type False False ty1 ty2 - where - ki1 = tcTypeKind ty1 - ki2 = tcTypeKind ty2 - --- | Just like 'tcEqType', but will return True for types of different kinds --- as long as their non-coercion structure is identical. -tcEqTypeNoKindCheck :: TcType -> TcType -> Bool -tcEqTypeNoKindCheck ty1 ty2 - = tc_eq_type False False ty1 ty2 - --- | Like 'tcEqType', but returns True if the /visible/ part of the types --- are equal, even if they are really unequal (in the invisible bits) -tcEqTypeVis :: TcType -> TcType -> Bool -tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2 - --- | Like 'pickyEqTypeVis', but returns a Bool for convenience -pickyEqType :: TcType -> TcType -> Bool --- Check when two types _look_ the same, _including_ synonyms. --- So (pickyEqType String [Char]) returns False --- This ignores kinds and coercions, because this is used only for printing. -pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 - - - --- | Real worker for 'tcEqType'. No kind check! -tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms - -> Bool -- ^ True <=> compare visible args only - -> Type -> Type - -> Bool --- Flags False, False is the usual setting for tc_eq_type -tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 - = go orig_env orig_ty1 orig_ty2 - where - go :: RnEnv2 -> Type -> Type -> Bool - go env t1 t2 | not keep_syns, Just t1' <- tcView t1 = go env t1' t2 - go env t1 t2 | not keep_syns, Just t2' <- tcView t2 = go env t1 t2' - - go env (TyVarTy tv1) (TyVarTy tv2) - = rnOccL env tv1 == rnOccR env tv2 - - go _ (LitTy lit1) (LitTy lit2) - = lit1 == lit2 - - go env (ForAllTy (Bndr tv1 vis1) ty1) - (ForAllTy (Bndr tv2 vis2) ty2) - = vis1 == vis2 - && (vis_only || go env (varType tv1) (varType tv2)) - && go (rnBndr2 env tv1 tv2) ty1 ty2 - - -- Make sure we handle all FunTy cases since falling through to the - -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked - -- kind variable, which causes things to blow up. - go env (FunTy _ arg1 res1) (FunTy _ arg2 res2) - = go env arg1 arg2 && go env res1 res2 - go env ty (FunTy _ arg res) = eqFunTy env arg res ty - go env (FunTy _ arg res) ty = eqFunTy env arg res ty - - -- See Note [Equality on AppTys] in GHC.Core.Type - go env (AppTy s1 t1) ty2 - | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2 - = go env s1 s2 && go env t1 t2 - go env ty1 (AppTy s2 t2) - | Just (s1, t1) <- tcRepSplitAppTy_maybe ty1 - = go env s1 s2 && go env t1 t2 - - go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) - = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2 - - go env (CastTy t1 _) t2 = go env t1 t2 - go env t1 (CastTy t2 _) = go env t1 t2 - go _ (CoercionTy {}) (CoercionTy {}) = True - - go _ _ _ = False - - gos _ _ [] [] = True - gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2) - && gos env igs ts1 ts2 - gos _ _ _ _ = False - - tc_vis :: TyCon -> [Bool] -- True for the fields we should ignore - tc_vis tc | vis_only = inviss ++ repeat False -- Ignore invisibles - | otherwise = repeat False -- Ignore nothing - -- The repeat False is necessary because tycons - -- can legitimately be oversaturated - where - bndrs = tyConBinders tc - inviss = map isInvisibleTyConBinder bndrs - - orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] - - -- @eqFunTy arg res ty@ is True when @ty@ equals @FunTy arg res@. This is - -- sometimes hard to know directly because @ty@ might have some casts - -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't - -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or - -- res is unzonked/unflattened. Thus this function, which handles this - -- corner case. - eqFunTy :: RnEnv2 -> Type -> Type -> Type -> Bool - -- Last arg is /not/ FunTy - eqFunTy env arg res ty@(AppTy{}) = get_args ty [] - where - get_args :: Type -> [Type] -> Bool - get_args (AppTy f x) args = get_args f (x:args) - get_args (CastTy t _) args = get_args t args - get_args (TyConApp tc tys) args - | tc == funTyCon - , [_, _, arg', res'] <- tys ++ args - = go env arg arg' && go env res res' - get_args _ _ = False - eqFunTy _ _ _ _ = False - -{- ********************************************************************* -* * - Predicate types -* * -************************************************************************ - -Deconstructors and tests on predicate types - -Note [Kind polymorphic type classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - class C f where... -- C :: forall k. k -> Constraint - g :: forall (f::*). C f => f -> f - -Here the (C f) in the signature is really (C * f), and we -don't want to complain that the * isn't a type variable! --} - -isTyVarClassPred :: PredType -> Bool -isTyVarClassPred ty = case getClassPredTys_maybe ty of - Just (_, tys) -> all isTyVarTy tys - _ -> False - -------------------------- -checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool --- If the Bool is True (flexible contexts), return True (i.e. ok) --- Otherwise, check that the type (not kind) args are all headed by a tyvar --- E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected --- This function is here rather than in TcValidity because it is --- called from TcSimplify, which itself is imported by TcValidity -checkValidClsArgs flexible_contexts cls kts - | flexible_contexts = True - | otherwise = all hasTyVarHead tys - where - tys = filterOutInvisibleTypes (classTyCon cls) kts - -hasTyVarHead :: Type -> Bool --- Returns true of (a t1 .. tn), where 'a' is a type variable -hasTyVarHead ty -- Haskell 98 allows predicates of form - | tcIsTyVarTy ty = True -- C (a ty1 .. tyn) - | otherwise -- where a is a type variable - = case tcSplitAppTy_maybe ty of - Just (ty, _) -> hasTyVarHead ty - Nothing -> False - -evVarPred :: EvVar -> PredType -evVarPred var = varType var - -- Historical note: I used to have an ASSERT here, - -- checking (isEvVarType (varType var)). But with something like - -- f :: c => _ -> _ - -- we end up with (c :: kappa), and (kappa ~ Constraint). Until - -- we solve and zonk (which there is no particular reason to do for - -- partial signatures, (isEvVarType kappa) will return False. But - -- nothing is wrong. So I just removed the ASSERT. - ------------------- --- | When inferring types, should we quantify over a given predicate? --- Generally true of classes; generally false of equality constraints. --- Equality constraints that mention quantified type variables and --- implicit variables complicate the story. See Notes --- [Inheriting implicit parameters] and [Quantifying over equality constraints] -pickQuantifiablePreds - :: TyVarSet -- Quantifying over these - -> TcThetaType -- Proposed constraints to quantify - -> TcThetaType -- A subset that we can actually quantify --- This function decides whether a particular constraint should be --- quantified over, given the type variables that are being quantified -pickQuantifiablePreds qtvs theta - = let flex_ctxt = True in -- Quantify over non-tyvar constraints, even without - -- -XFlexibleContexts: see #10608, #10351 - -- flex_ctxt <- xoptM Opt_FlexibleContexts - mapMaybe (pick_me flex_ctxt) theta - where - pick_me flex_ctxt pred - = case classifyPredType pred of - - ClassPred cls tys - | Just {} <- isCallStackPred cls tys - -- NEVER infer a CallStack constraint. Otherwise we let - -- the constraints bubble up to be solved from the outer - -- context, or be defaulted when we reach the top-level. - -- See Note [Overview of implicit CallStacks] - -> Nothing - - | isIPClass cls - -> Just pred -- See note [Inheriting implicit parameters] - - | pick_cls_pred flex_ctxt cls tys - -> Just pred - - EqPred eq_rel ty1 ty2 - | quantify_equality eq_rel ty1 ty2 - , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 - -- boxEqPred: See Note [Lift equality constraints when quantifying] - , pick_cls_pred flex_ctxt cls tys - -> Just (mkClassPred cls tys) - - IrredPred ty - | tyCoVarsOfType ty `intersectsVarSet` qtvs - -> Just pred - - _ -> Nothing - - - pick_cls_pred flex_ctxt cls tys - = tyCoVarsOfTypes tys `intersectsVarSet` qtvs - && (checkValidClsArgs flex_ctxt cls tys) - -- Only quantify over predicates that checkValidType - -- will pass! See #10351. - - -- See Note [Quantifying over equality constraints] - quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 - quantify_equality ReprEq _ _ = True - - quant_fun ty - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) | isTypeFamilyTyCon tc - -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs - _ -> False - -boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type]) --- Given (t1 ~# t2) or (t1 ~R# t2) return the boxed version --- (t1 ~ t2) or (t1 `Coercible` t2) -boxEqPred eq_rel ty1 ty2 - = case eq_rel of - NomEq | homo_kind -> Just (eqClass, [k1, ty1, ty2]) - | otherwise -> Just (heqClass, [k1, k2, ty1, ty2]) - ReprEq | homo_kind -> Just (coercibleClass, [k1, ty1, ty2]) - | otherwise -> Nothing -- Sigh: we do not have hererogeneous Coercible - -- so we can't abstract over it - -- Nothing fundamental: we could add it - where - k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 - homo_kind = k1 `tcEqType` k2 - -pickCapturedPreds - :: TyVarSet -- Quantifying over these - -> TcThetaType -- Proposed constraints to quantify - -> TcThetaType -- A subset that we can actually quantify --- A simpler version of pickQuantifiablePreds, used to winnow down --- the inferred constraints of a group of bindings, into those for --- one particular identifier -pickCapturedPreds qtvs theta - = filter captured theta - where - captured pred = isIPPred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) - - --- Superclasses - -type PredWithSCs a = (PredType, [PredType], a) - -mkMinimalBySCs :: forall a. (a -> PredType) -> [a] -> [a] --- Remove predicates that --- --- - are the same as another predicate --- --- - can be deduced from another by superclasses, --- --- - are a reflexive equality (e.g * ~ *) --- (see Note [Remove redundant provided dicts] in TcPatSyn) --- --- The result is a subset of the input. --- The 'a' is just paired up with the PredType; --- typically it might be a dictionary Id -mkMinimalBySCs get_pred xs = go preds_with_scs [] - where - preds_with_scs :: [PredWithSCs a] - preds_with_scs = [ (pred, pred : transSuperClasses pred, x) - | x <- xs - , let pred = get_pred x ] - - go :: [PredWithSCs a] -- Work list - -> [PredWithSCs a] -- Accumulating result - -> [a] - go [] min_preds - = reverse (map thdOf3 min_preds) - -- The 'reverse' isn't strictly necessary, but it - -- means that the results are returned in the same - -- order as the input, which is generally saner - go (work_item@(p,_,_) : work_list) min_preds - | EqPred _ t1 t2 <- classifyPredType p - , t1 `tcEqType` t2 -- See TcPatSyn - -- Note [Remove redundant provided dicts] - = go work_list min_preds - | p `in_cloud` work_list || p `in_cloud` min_preds - = go work_list min_preds - | otherwise - = go work_list (work_item : min_preds) - - in_cloud :: PredType -> [PredWithSCs a] -> Bool - in_cloud p ps = or [ p `tcEqType` p' | (_, scs, _) <- ps, p' <- scs ] - -transSuperClasses :: PredType -> [PredType] --- (transSuperClasses p) returns (p's superclasses) not including p --- Stop if you encounter the same class again --- See Note [Expanding superclasses] -transSuperClasses p - = go emptyNameSet p - where - go :: NameSet -> PredType -> [PredType] - go rec_clss p - | ClassPred cls tys <- classifyPredType p - , let cls_nm = className cls - , not (cls_nm `elemNameSet` rec_clss) - , let rec_clss' | isCTupleClass cls = rec_clss - | otherwise = rec_clss `extendNameSet` cls_nm - = [ p' | sc <- immSuperClasses cls tys - , p' <- sc : go rec_clss' sc ] - | otherwise - = [] - -immSuperClasses :: Class -> [Type] -> [PredType] -immSuperClasses cls tys - = substTheta (zipTvSubst tyvars tys) sc_theta - where - (tyvars,sc_theta,_,_) = classBigSig cls - -isImprovementPred :: PredType -> Bool --- Either it's an equality, or has some functional dependency -isImprovementPred ty - = case classifyPredType ty of - EqPred NomEq t1 t2 -> not (t1 `tcEqType` t2) - EqPred ReprEq _ _ -> False - ClassPred cls _ -> classHasFds cls - IrredPred {} -> True -- Might have equalities after reduction? - ForAllPred {} -> False - --- | Is the equality --- a ~r ...a.... --- definitely insoluble or not? --- a ~r Maybe a -- Definitely insoluble --- a ~N ...(F a)... -- Not definitely insoluble --- -- Perhaps (F a) reduces to Int --- a ~R ...(N a)... -- Not definitely insoluble --- -- Perhaps newtype N a = MkN Int --- See Note [Occurs check error] in --- TcCanonical for the motivation for this function. -isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool -isInsolubleOccursCheck eq_rel tv ty - = go ty - where - go ty | Just ty' <- tcView ty = go ty' - go (TyVarTy tv') = tv == tv' || go (tyVarKind tv') - go (LitTy {}) = False - go (AppTy t1 t2) = case eq_rel of -- See Note [AppTy and ReprEq] - NomEq -> go t1 || go t2 - ReprEq -> go t1 - go (FunTy _ t1 t2) = go t1 || go t2 - go (ForAllTy (Bndr tv' _) inner_ty) - | tv' == tv = False - | otherwise = go (varType tv') || go inner_ty - go (CastTy ty _) = go ty -- ToDo: what about the coercion - go (CoercionTy _) = False -- ToDo: what about the coercion - go (TyConApp tc tys) - | isGenerativeTyCon tc role = any go tys - | otherwise = any go (drop (tyConArity tc) tys) - -- (a ~ F b a), where F has arity 1, - -- has an insoluble occurs check - - role = eqRelRole eq_rel - -{- Note [Expanding superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we expand superclasses, we use the following algorithm: - -transSuperClasses( C tys ) returns the transitive superclasses - of (C tys), not including C itself - -For example - class C a b => D a b - class D b a => C a b - -Then - transSuperClasses( Ord ty ) = [Eq ty] - transSuperClasses( C ta tb ) = [D tb ta, C tb ta] - -Notice that in the recursive-superclass case we include C again at -the end of the chain. One could exclude C in this case, but -the code is more awkward and there seems no good reason to do so. -(However C.f. TcCanonical.mk_strict_superclasses, which /does/ -appear to do so.) - -The algorithm is expand( so_far, pred ): - - 1. If pred is not a class constraint, return empty set - Otherwise pred = C ts - 2. If C is in so_far, return empty set (breaks loops) - 3. Find the immediate superclasses constraints of (C ts) - 4. For each such sc_pred, return (sc_pred : expand( so_far+C, D ss ) - -Notice that - - * With normal Haskell-98 classes, the loop-detector will never bite, - so we'll get all the superclasses. - - * We need the loop-breaker in case we have UndecidableSuperClasses on - - * Since there is only a finite number of distinct classes, expansion - must terminate. - - * The loop breaking is a bit conservative. Notably, a tuple class - could contain many times without threatening termination: - (Eq a, (Ord a, Ix a)) - And this is try of any class that we can statically guarantee - as non-recursive (in some sense). For now, we just make a special - case for tuples. Something better would be cool. - -See also TcTyDecls.checkClassCycles. - -Note [Lift equality constraints when quantifying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can't quantify over a constraint (t1 ~# t2) because that isn't a -predicate type; see Note [Types for coercions, predicates, and evidence] -in GHC.Core.TyCo.Rep. - -So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted -to Coercible. - -This tiresome lifting is the reason that pick_me (in -pickQuantifiablePreds) returns a Maybe rather than a Bool. - -Note [Quantifying over equality constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should we quantify over an equality constraint (s ~ t)? In general, we don't. -Doing so may simply postpone a type error from the function definition site to -its call site. (At worst, imagine (Int ~ Bool)). - -However, consider this - forall a. (F [a] ~ Int) => blah -Should we quantify over the (F [a] ~ Int)? Perhaps yes, because at the call -site we will know 'a', and perhaps we have instance F [Bool] = Int. -So we *do* quantify over a type-family equality where the arguments mention -the quantified variables. - -Note [Inheriting implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f x = (x::Int) + ?y - -where f is *not* a top-level binding. -From the RHS of f we'll get the constraint (?y::Int). -There are two types we might infer for f: - - f :: Int -> Int - -(so we get ?y from the context of f's definition), or - - f :: (?y::Int) => Int -> Int - -At first you might think the first was better, because then -?y behaves like a free variable of the definition, rather than -having to be passed at each call site. But of course, the WHOLE -IDEA is that ?y should be passed at each call site (that's what -dynamic binding means) so we'd better infer the second. - -BOTTOM LINE: when *inferring types* you must quantify over implicit -parameters, *even if* they don't mention the bound type variables. -Reason: because implicit parameters, uniquely, have local instance -declarations. See pickQuantifiablePreds. - -Note [Quantifying over equality constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should we quantify over an equality constraint (s ~ t)? In general, we don't. -Doing so may simply postpone a type error from the function definition site to -its call site. (At worst, imagine (Int ~ Bool)). - -However, consider this - forall a. (F [a] ~ Int) => blah -Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call -site we will know 'a', and perhaps we have instance F [Bool] = Int. -So we *do* quantify over a type-family equality where the arguments mention -the quantified variables. - -************************************************************************ -* * - Classifying types -* * -************************************************************************ --} - -isSigmaTy :: TcType -> Bool --- isSigmaTy returns true of any qualified type. It doesn't --- *necessarily* have any foralls. E.g --- f :: (?x::Int) => Int -> Int -isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty' -isSigmaTy (ForAllTy {}) = True -isSigmaTy (FunTy { ft_af = InvisArg }) = True -isSigmaTy _ = False - -isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] -isRhoTy ty | Just ty' <- tcView ty = isRhoTy ty' -isRhoTy (ForAllTy {}) = False -isRhoTy (FunTy { ft_af = VisArg, ft_res = r }) = isRhoTy r -isRhoTy _ = True - --- | Like 'isRhoTy', but also says 'True' for 'Infer' types -isRhoExpTy :: ExpType -> Bool -isRhoExpTy (Check ty) = isRhoTy ty -isRhoExpTy (Infer {}) = True - -isOverloadedTy :: Type -> Bool --- Yes for a type of a function that might require evidence-passing --- Used only by bindLocalMethods -isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' -isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty -isOverloadedTy (FunTy { ft_af = InvisArg }) = True -isOverloadedTy _ = False - -isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, - isUnitTy, isCharTy, isAnyTy :: Type -> Bool -isFloatTy = is_tc floatTyConKey -isDoubleTy = is_tc doubleTyConKey -isIntegerTy = is_tc integerTyConKey -isIntTy = is_tc intTyConKey -isWordTy = is_tc wordTyConKey -isBoolTy = is_tc boolTyConKey -isUnitTy = is_tc unitTyConKey -isCharTy = is_tc charTyConKey -isAnyTy = is_tc anyTyConKey - --- | Does a type represent a floating-point number? -isFloatingTy :: Type -> Bool -isFloatingTy ty = isFloatTy ty || isDoubleTy ty - --- | Is a type 'String'? -isStringTy :: Type -> Bool -isStringTy ty - = case tcSplitTyConApp_maybe ty of - Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty - _ -> False - --- | Is a type a 'CallStack'? -isCallStackTy :: Type -> Bool -isCallStackTy ty - | Just tc <- tyConAppTyCon_maybe ty - = tc `hasKey` callStackTyConKey - | otherwise - = False - --- | Is a 'PredType' a 'CallStack' implicit parameter? --- --- If so, return the name of the parameter. -isCallStackPred :: Class -> [Type] -> Maybe FastString -isCallStackPred cls tys - | [ty1, ty2] <- tys - , isIPClass cls - , isCallStackTy ty2 - = isStrLitTy ty1 - | otherwise - = Nothing - -is_tc :: Unique -> Type -> Bool --- Newtypes are opaque to this -is_tc uniq ty = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> uniq == getUnique tc - Nothing -> False - --- | Does the given tyvar appear at the head of a chain of applications --- (a t1 ... tn) -isTyVarHead :: TcTyVar -> TcType -> Bool -isTyVarHead tv (TyVarTy tv') = tv == tv' -isTyVarHead tv (AppTy fun _) = isTyVarHead tv fun -isTyVarHead tv (CastTy ty _) = isTyVarHead tv ty -isTyVarHead _ (TyConApp {}) = False -isTyVarHead _ (LitTy {}) = False -isTyVarHead _ (ForAllTy {}) = False -isTyVarHead _ (FunTy {}) = False -isTyVarHead _ (CoercionTy {}) = False - - -{- Note [AppTy and ReprEq] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a ~R# b a - a ~R# a b - -The former is /not/ a definite error; we might instantiate 'b' with Id - newtype Id a = MkId a -but the latter /is/ a definite error. - -On the other hand, with nominal equality, both are definite errors --} - -isRigidTy :: TcType -> Bool -isRigidTy ty - | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal - | Just {} <- tcSplitAppTy_maybe ty = True - | isForAllTy ty = True - | otherwise = False - - --- | Is this type *almost function-free*? See Note [Almost function-free] --- in TcRnTypes -isAlmostFunctionFree :: TcType -> Bool -isAlmostFunctionFree ty | Just ty' <- tcView ty = isAlmostFunctionFree ty' -isAlmostFunctionFree (TyVarTy {}) = True -isAlmostFunctionFree (AppTy ty1 ty2) = isAlmostFunctionFree ty1 && - isAlmostFunctionFree ty2 -isAlmostFunctionFree (TyConApp tc args) - | isTypeFamilyTyCon tc = False - | otherwise = all isAlmostFunctionFree args -isAlmostFunctionFree (ForAllTy bndr _) = isAlmostFunctionFree (binderType bndr) -isAlmostFunctionFree (FunTy _ ty1 ty2) = isAlmostFunctionFree ty1 && - isAlmostFunctionFree ty2 -isAlmostFunctionFree (LitTy {}) = True -isAlmostFunctionFree (CastTy ty _) = isAlmostFunctionFree ty -isAlmostFunctionFree (CoercionTy {}) = True - -{- -************************************************************************ -* * -\subsection{Misc} -* * -************************************************************************ - -Note [Visible type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC implements a generalisation of the algorithm described in the -"Visible Type Application" paper (available from -http://www.cis.upenn.edu/~sweirich/publications.html). A key part -of that algorithm is to distinguish user-specified variables from inferred -variables. For example, the following should typecheck: - - f :: forall a b. a -> b -> b - f = const id - - g = const id - - x = f @Int @Bool 5 False - y = g 5 @Bool False - -The idea is that we wish to allow visible type application when we are -instantiating a specified, fixed variable. In practice, specified, fixed -variables are either written in a type signature (or -annotation), OR are imported from another module. (We could do better here, -for example by doing SCC analysis on parts of a module and considering any -type from outside one's SCC to be fully specified, but this is very confusing to -users. The simple rule above is much more straightforward and predictable.) - -So, both of f's quantified variables are specified and may be instantiated. -But g has no type signature, so only id's variable is specified (because id -is imported). We write the type of g as forall {a}. a -> forall b. b -> b. -Note that the a is in braces, meaning it cannot be instantiated with -visible type application. - -Tracking specified vs. inferred variables is done conveniently by a field -in TyBinder. - --} - -deNoteType :: Type -> Type --- Remove all *outermost* type synonyms and other notes -deNoteType ty | Just ty' <- coreView ty = deNoteType ty' -deNoteType ty = ty - -{- -Find the free tycons and classes of a type. This is used in the front -end of the compiler. --} - -{- -************************************************************************ -* * -\subsection[TysWiredIn-ext-type]{External types} -* * -************************************************************************ - -The compiler's foreign function interface supports the passing of a -restricted set of types as arguments and results (the restricting factor -being the ) --} - -tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) --- (tcSplitIOType_maybe t) returns Just (IO,t',co) --- if co : t ~ IO t' --- returns Nothing otherwise -tcSplitIOType_maybe ty - = case tcSplitTyConApp_maybe ty of - Just (io_tycon, [io_res_ty]) - | io_tycon `hasKey` ioTyConKey -> - Just (io_tycon, io_res_ty) - _ -> - Nothing - -isFFITy :: Type -> Bool --- True for any TyCon that can possibly be an arg or result of an FFI call -isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty) - -isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity --- Checks for valid argument type for a 'foreign import' -isFFIArgumentTy dflags safety ty - = checkRepTyCon (legalOutgoingTyCon dflags safety) ty - -isFFIExternalTy :: Type -> Validity --- Types that are allowed as arguments of a 'foreign export' -isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty - -isFFIImportResultTy :: DynFlags -> Type -> Validity -isFFIImportResultTy dflags ty - = checkRepTyCon (legalFIResultTyCon dflags) ty - -isFFIExportResultTy :: Type -> Validity -isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty - -isFFIDynTy :: Type -> Type -> Validity --- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of --- either, and the wrapped function type must be equal to the given type. --- We assume that all types have been run through normaliseFfiType, so we don't --- need to worry about expanding newtypes here. -isFFIDynTy expected ty - -- Note [Foreign import dynamic] - -- In the example below, expected would be 'CInt -> IO ()', while ty would - -- be 'FunPtr (CDouble -> IO ())'. - | Just (tc, [ty']) <- splitTyConApp_maybe ty - , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] - , eqType ty' expected - = IsValid - | otherwise - = NotValid (vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma - , text " Actual:" <+> ppr ty ]) - -isFFILabelTy :: Type -> Validity --- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. -isFFILabelTy ty = checkRepTyCon ok ty - where - ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey - = IsValid - | otherwise - = NotValid (text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") - -isFFIPrimArgumentTy :: DynFlags -> Type -> Validity --- Checks for valid argument type for a 'foreign import prim' --- Currently they must all be simple unlifted types, or the well-known type --- Any, which can be used to pass the address to a Haskell object on the heap to --- the foreign function. -isFFIPrimArgumentTy dflags ty - | isAnyTy ty = IsValid - | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty - -isFFIPrimResultTy :: DynFlags -> Type -> Validity --- Checks for valid result type for a 'foreign import prim' Currently --- it must be an unlifted type, including unboxed tuples, unboxed --- sums, or the well-known type Any. -isFFIPrimResultTy dflags ty - | isAnyTy ty = IsValid - | otherwise = checkRepTyCon (legalFIPrimResultTyCon dflags) ty - -isFunPtrTy :: Type -> Bool -isFunPtrTy ty - | Just (tc, [_]) <- splitTyConApp_maybe ty - = tc `hasKey` funPtrTyConKey - | otherwise - = False - --- normaliseFfiType gets run before checkRepTyCon, so we don't --- need to worry about looking through newtypes or type functions --- here; that's already been taken care of. -checkRepTyCon :: (TyCon -> Validity) -> Type -> Validity -checkRepTyCon check_tc ty - = case splitTyConApp_maybe ty of - Just (tc, tys) - | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix)) - | otherwise -> case check_tc tc of - IsValid -> IsValid - NotValid extra -> NotValid (msg $$ extra) - Nothing -> NotValid (quotes (ppr ty) <+> text "is not a data type") - where - msg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" - mk_nt_reason tc tys - | null tys = text "because its data constructor is not in scope" - | otherwise = text "because the data constructor for" - <+> quotes (ppr tc) <+> text "is not in scope" - nt_fix = text "Possible fix: import the data constructor to bring it into scope" - -{- -Note [Foreign import dynamic] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign -type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. - -We use isFFIDynTy to check whether a signature is well-formed. For example, -given a (illegal) declaration like: - -foreign import ccall "dynamic" - foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () - -isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried -result type 'CInt -> IO ()', and return False, as they are not equal. - - ----------------------------------------------- -These chaps do the work; they are not exported ----------------------------------------------- --} - -legalFEArgTyCon :: TyCon -> Validity -legalFEArgTyCon tc - -- It's illegal to make foreign exports that take unboxed - -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 - = boxedMarshalableTyCon tc - -legalFIResultTyCon :: DynFlags -> TyCon -> Validity -legalFIResultTyCon dflags tc - | tc == unitTyCon = IsValid - | otherwise = marshalableTyCon dflags tc - -legalFEResultTyCon :: TyCon -> Validity -legalFEResultTyCon tc - | tc == unitTyCon = IsValid - | otherwise = boxedMarshalableTyCon tc - -legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity --- Checks validity of types going from Haskell -> external world -legalOutgoingTyCon dflags _ tc - = marshalableTyCon dflags tc - -legalFFITyCon :: TyCon -> Validity --- True for any TyCon that can possibly be an arg or result of an FFI call -legalFFITyCon tc - | isUnliftedTyCon tc = IsValid - | tc == unitTyCon = IsValid - | otherwise = boxedMarshalableTyCon tc - -marshalableTyCon :: DynFlags -> TyCon -> Validity -marshalableTyCon dflags tc - | isUnliftedTyCon tc - , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) - , not (null (tyConPrimRep tc)) -- Note [Marshalling void] - = validIfUnliftedFFITypes dflags - | otherwise - = boxedMarshalableTyCon tc - -boxedMarshalableTyCon :: TyCon -> Validity -boxedMarshalableTyCon tc - | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey - , int32TyConKey, int64TyConKey - , wordTyConKey, word8TyConKey, word16TyConKey - , word32TyConKey, word64TyConKey - , floatTyConKey, doubleTyConKey - , ptrTyConKey, funPtrTyConKey - , charTyConKey - , stablePtrTyConKey - , boolTyConKey - ] - = IsValid - - | otherwise = NotValid empty - -legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity --- Check args of 'foreign import prim', only allow simple unlifted types. --- Strictly speaking it is unnecessary to ban unboxed tuples and sums here since --- currently they're of the wrong kind to use in function args anyway. -legalFIPrimArgTyCon dflags tc - | isUnliftedTyCon tc - , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) - = validIfUnliftedFFITypes dflags - | otherwise - = NotValid unlifted_only - -legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity --- Check result type of 'foreign import prim'. Allow simple unlifted --- types and also unboxed tuple and sum result types. -legalFIPrimResultTyCon dflags tc - | isUnliftedTyCon tc - , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc - || not (null (tyConPrimRep tc)) -- Note [Marshalling void] - = validIfUnliftedFFITypes dflags - - | otherwise - = NotValid unlifted_only - -unlifted_only :: MsgDoc -unlifted_only = text "foreign import prim only accepts simple unlifted types" - -validIfUnliftedFFITypes :: DynFlags -> Validity -validIfUnliftedFFITypes dflags - | xopt LangExt.UnliftedFFITypes dflags = IsValid - | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes") - -{- -Note [Marshalling void] -~~~~~~~~~~~~~~~~~~~~~~~ -We don't treat State# (whose PrimRep is VoidRep) as marshalable. -In turn that means you can't write - foreign import foo :: Int -> State# RealWorld - -Reason: the back end falls over with panic "primRepHint:VoidRep"; - and there is no compelling reason to permit it --} - -{- -************************************************************************ -* * - The "Paterson size" of a type -* * -************************************************************************ --} - -{- -Note [Paterson conditions on PredTypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are considering whether *class* constraints terminate -(see Note [Paterson conditions]). Precisely, the Paterson conditions -would have us check that "the constraint has fewer constructors and variables -(taken together and counting repetitions) than the head.". - -However, we can be a bit more refined by looking at which kind of constraint -this actually is. There are two main tricks: - - 1. It seems like it should be OK not to count the tuple type constructor - for a PredType like (Show a, Eq a) :: Constraint, since we don't - count the "implicit" tuple in the ThetaType itself. - - In fact, the Paterson test just checks *each component* of the top level - ThetaType against the size bound, one at a time. By analogy, it should be - OK to return the size of the *largest* tuple component as the size of the - whole tuple. - - 2. Once we get into an implicit parameter or equality we - can't get back to a class constraint, so it's safe - to say "size 0". See #4200. - -NB: we don't want to detect PredTypes in sizeType (and then call -sizePred on them), or we might get an infinite loop if that PredType -is irreducible. See #5581. --} - -type TypeSize = IntWithInf - -sizeType :: Type -> TypeSize --- Size of a type: the number of variables and constructors --- Ignore kinds altogether -sizeType = go - where - go ty | Just exp_ty <- tcView ty = go exp_ty - go (TyVarTy {}) = 1 - go (TyConApp tc tys) - | isTypeFamilyTyCon tc = infinity -- Type-family applications can - -- expand to any arbitrary size - | otherwise = sizeTypes (filterOutInvisibleTypes tc tys) + 1 - -- Why filter out invisible args? I suppose any - -- size ordering is sound, but why is this better? - -- I came across this when investigating #14010. - go (LitTy {}) = 1 - go (FunTy _ arg res) = go arg + go res + 1 - go (AppTy fun arg) = go fun + go arg - go (ForAllTy (Bndr tv vis) ty) - | isVisibleArgFlag vis = go (tyVarKind tv) + go ty + 1 - | otherwise = go ty + 1 - go (CastTy ty _) = go ty - go (CoercionTy {}) = 0 - -sizeTypes :: [Type] -> TypeSize -sizeTypes tys = sum (map sizeType tys) - ------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------ ------------------------ --- | For every arg a tycon can take, the returned list says True if the argument --- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to --- allow for oversaturation. -tcTyConVisibilities :: TyCon -> [Bool] -tcTyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True - where - tc_binder_viss = map isVisibleTyConBinder (tyConBinders tc) - tc_return_kind_viss = map isVisibleBinder (fst $ tcSplitPiTys (tyConResKind tc)) - --- | If the tycon is applied to the types, is the next argument visible? -isNextTyConArgVisible :: TyCon -> [Type] -> Bool -isNextTyConArgVisible tc tys - = tcTyConVisibilities tc `getNth` length tys - --- | Should this type be applied to a visible argument? -isNextArgVisible :: TcType -> Bool -isNextArgVisible ty - | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisibleBinder bndr - | otherwise = True - -- this second case might happen if, say, we have an unzonked TauTv. - -- But TauTvs can't range over types that take invisible arguments diff --git a/compiler/typecheck/TcType.hs-boot b/compiler/typecheck/TcType.hs-boot deleted file mode 100644 index 2bc14735f1..0000000000 --- a/compiler/typecheck/TcType.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ -module TcType where -import Outputable( SDoc ) - -data MetaDetails - -data TcTyVarDetails -pprTcTyVarDetails :: TcTyVarDetails -> SDoc -vanillaSkolemTv :: TcTyVarDetails diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index 9dc1176cf2..12ec08f89f 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -25,11 +25,11 @@ import GhcPrelude import GHC.Core.Type import Pair -import TcType ( TcType, tcEqType ) +import GHC.Tc.Utils.TcType ( TcType, tcEqType ) import GHC.Core.TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon , Injectivity(..) ) import GHC.Core.Coercion ( Role(..) ) -import Constraint ( Xi ) +import GHC.Tc.Types.Constraint ( Xi ) import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn ) import GHC.Types.Name ( Name, BuiltInSyntax(..) ) import TysWiredIn diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs deleted file mode 100644 index 4de6e7a6d7..0000000000 --- a/compiler/typecheck/TcTypeable.hs +++ /dev/null @@ -1,759 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -module TcTypeable(mkTypeableBinds, tyConIsTypeable) where - -#include "HsVersions.h" - -import GhcPrelude -import GHC.Platform - -import GHC.Types.Basic ( Boxity(..), neverInlinePragma, SourceText(..) ) -import GHC.Iface.Env( newGlobalBinder ) -import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) -import TcEnv -import TcEvidence ( mkWpTyApps ) -import TcRnMonad -import TcType -import GHC.Driver.Types ( lookupId ) -import PrelNames -import TysPrim ( primTyCons ) -import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon - , vecCountTyCon, vecElemTyCon - , nilDataCon, consDataCon ) -import GHC.Types.Name -import GHC.Types.Id -import GHC.Core.Type -import GHC.Core.TyCon -import GHC.Core.DataCon -import GHC.Types.Module -import GHC.Hs -import GHC.Driver.Session -import Bag -import GHC.Types.Var ( VarBndr(..) ) -import GHC.Core.Map -import Constants -import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) -import Outputable -import FastString ( FastString, mkFastString, fsLit ) - -import Control.Monad.Trans.State -import Control.Monad.Trans.Class (lift) -import Data.Maybe ( isJust ) -import Data.Word( Word64 ) - -{- Note [Grand plan for Typeable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The overall plan is this: - -1. Generate a binding for each module p:M - (done in TcTypeable by mkModIdBindings) - M.$trModule :: GHC.Types.Module - M.$trModule = Module "p" "M" - ("tr" is short for "type representation"; see GHC.Types) - - We might want to add the filename too. - This can be used for the lightweight stack-tracing stuff too - - Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv - -2. Generate a binding for every data type declaration T in module M, - M.$tcT :: GHC.Types.TyCon - M.$tcT = TyCon ...fingerprint info... - $trModule - "T" - 0# - kind_rep - - Here 0# is the number of arguments expected by the tycon to fully determine - its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a - recipe for computing the kind of an instantiation of the tycon (see - Note [Representing TyCon kinds: KindRep] later in this file for details). - - We define (in GHC.Core.TyCon) - - type TyConRepName = Name - - to use for these M.$tcT "tycon rep names". Note that these must be - treated as "never exported" names by Backpack (see - Note [Handling never-exported TyThings under Backpack]). Consequently - they get slightly special treatment in GHC.Iface.Rename.rnIfaceDecl. - -3. Record the TyConRepName in T's TyCon, including for promoted - data and type constructors, and kinds like * and #. - - The TyConRepName is not an "implicit Id". It's more like a record - selector: the TyCon knows its name but you have to go to the - interface file to find its type, value, etc - -4. Solve Typeable constraints. This is done by a custom Typeable solver, - currently in TcInteract, that use M.$tcT so solve (Typeable T). - -There are many wrinkles: - -* The timing of when we produce this bindings is rather important: they must be - defined after the rest of the module has been typechecked since we need to be - able to lookup Module and TyCon in the type environment and we may be - currently compiling GHC.Types (where they are defined). - -* GHC.Prim doesn't have any associated object code, so we need to put the - representations for types defined in this module elsewhere. We chose this - place to be GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for - injecting the bindings for the GHC.Prim representions when compiling - GHC.Types. - -* TyCon.tyConRepModOcc is responsible for determining where to find - the representation binding for a given type. This is where we handle - the special case for GHC.Prim. - -* To save space and reduce dependencies, we need use quite low-level - representations for TyCon and Module. See GHC.Types - Note [Runtime representation of modules and tycons] - -* The KindReps can unfortunately get quite large. Moreover, the simplifier will - float out various pieces of them, resulting in numerous top-level bindings. - Consequently we mark the KindRep bindings as noinline, ensuring that the - float-outs don't make it into the interface file. This is important since - there is generally little benefit to inlining KindReps and they would - otherwise strongly affect compiler performance. - -* In general there are lots of things of kind *, * -> *, and * -> * -> *. To - reduce the number of bindings we need to produce, we generate their KindReps - once in GHC.Types. These are referred to as "built-in" KindReps below. - -* Even though KindReps aren't inlined, this scheme still has more of an effect on - compilation time than I'd like. This is especially true in the case of - families of type constructors (e.g. tuples and unboxed sums). The problem is - particularly bad in the case of sums, since each arity-N tycon brings with it - N promoted datacons, each with a KindRep whose size also scales with N. - Consequently we currently simply don't allow sums to be Typeable. - - In general we might consider moving some or all of this generation logic back - to the solver since the performance hit we take in doing this at - type-definition time is non-trivial and Typeable isn't very widely used. This - is discussed in #13261. - --} - --- | Generate the Typeable bindings for a module. This is the only --- entry-point of this module and is invoked by the typechecker driver in --- 'tcRnSrcDecls'. --- --- See Note [Grand plan for Typeable] in TcTypeable. -mkTypeableBinds :: TcM TcGblEnv -mkTypeableBinds - = do { dflags <- getDynFlags - ; if gopt Opt_NoTypeableBinds dflags then getGblEnv else do - { -- Create a binding for $trModule. - -- Do this before processing any data type declarations, - -- which need tcg_tr_module to be initialised - ; tcg_env <- mkModIdBindings - -- Now we can generate the TyCon representations... - -- First we handle the primitive TyCons if we are compiling GHC.Types - ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos - - -- Then we produce bindings for the user-defined types in this module. - ; setGblEnv tcg_env $ - do { mod <- getModule - ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env) - mod_id = case tcg_tr_module tcg_env of -- Should be set by now - Just mod_id -> mod_id - Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons) - ; traceTc "mkTypeableBinds" (ppr tycons) - ; this_mod_todos <- todoForTyCons mod mod_id tycons - ; mkTypeRepTodoBinds (this_mod_todos : prim_todos) - } } } - where - needs_typeable_binds tc - | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon] - = False - | otherwise = - isAlgTyCon tc - || isDataFamilyTyCon tc - || isClassTyCon tc - - -{- ********************************************************************* -* * - Building top-level binding for $trModule -* * -********************************************************************* -} - -mkModIdBindings :: TcM TcGblEnv -mkModIdBindings - = do { mod <- getModule - ; loc <- getSrcSpanM - ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc - ; trModuleTyCon <- tcLookupTyCon trModuleTyConName - ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon []) - ; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod - - ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv - ; return (tcg_env { tcg_tr_module = Just mod_id } - `addTypecheckedBinds` [unitBag mod_bind]) } - -mkModIdRHS :: Module -> TcM (LHsExpr GhcTc) -mkModIdRHS mod - = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName - ; trNameLit <- mkTrNameLit - ; return $ nlHsDataCon trModuleDataCon - `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod)) - `nlHsApp` trNameLit (moduleNameFS (moduleName mod)) - } - -{- ********************************************************************* -* * - Building type-representation bindings -* * -********************************************************************* -} - --- | Information we need about a 'TyCon' to generate its representation. We --- carry the 'Id' in order to share it between the generation of the @TyCon@ and --- @KindRep@ bindings. -data TypeableTyCon - = TypeableTyCon - { tycon :: !TyCon - , tycon_rep_id :: !Id - } - --- | A group of 'TyCon's in need of type-rep bindings. -data TypeRepTodo - = TypeRepTodo - { mod_rep_expr :: LHsExpr GhcTc -- ^ Module's typerep binding - , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint - , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint - , todo_tycons :: [TypeableTyCon] - -- ^ The 'TyCon's in need of bindings kinds - } - | ExportedKindRepsTodo [(Kind, Id)] - -- ^ Build exported 'KindRep' bindings for the given set of kinds. - -todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo -todoForTyCons mod mod_id tycons = do - trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName - let mk_rep_id :: TyConRepName -> Id - mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy - - let typeable_tycons :: [TypeableTyCon] - typeable_tycons = - [ TypeableTyCon { tycon = tc'' - , tycon_rep_id = mk_rep_id rep_name - } - | tc <- tycons - , tc' <- tc : tyConATs tc - -- We need type representations for any associated types - , let promoted = map promoteDataCon (tyConDataCons tc') - , tc'' <- tc' : promoted - -- Don't make bindings for data-family instance tycons. - -- Do, however, make them for their promoted datacon (see #13915). - , not $ isFamInstTyCon tc'' - , Just rep_name <- pure $ tyConRepName_maybe tc'' - , tyConIsTypeable tc'' - ] - return TypeRepTodo { mod_rep_expr = nlHsVar mod_id - , pkg_fingerprint = pkg_fpr - , mod_fingerprint = mod_fpr - , todo_tycons = typeable_tycons - } - where - mod_fpr = fingerprintString $ moduleNameString $ moduleName mod - pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod - -todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo -todoForExportedKindReps kinds = do - trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName - let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy) - return $ ExportedKindRepsTodo $ map mkId kinds - --- | Generate TyCon bindings for a set of type constructors -mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv -mkTypeRepTodoBinds [] = getGblEnv -mkTypeRepTodoBinds todos - = do { stuff <- collect_stuff - - -- First extend the type environment with all of the bindings - -- which we are going to produce since we may need to refer to them - -- while generating kind representations (namely, when we want to - -- represent a TyConApp in a kind, we must be able to look up the - -- TyCon associated with the applied type constructor). - ; let produced_bndrs :: [Id] - produced_bndrs = [ tycon_rep_id - | todo@(TypeRepTodo{}) <- todos - , TypeableTyCon {..} <- todo_tycons todo - ] ++ - [ rep_id - | ExportedKindRepsTodo kinds <- todos - , (_, rep_id) <- kinds - ] - ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv - - ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc] - mk_binds todo@(TypeRepTodo {}) = - mapM (mkTyConRepBinds stuff todo) (todo_tycons todo) - mk_binds (ExportedKindRepsTodo kinds) = - mkExportedKindReps stuff kinds >> return [] - - ; (gbl_env, binds) <- setGblEnv gbl_env - $ runKindRepM (mapM mk_binds todos) - ; return $ gbl_env `addTypecheckedBinds` concat binds } - --- | Generate bindings for the type representation of a wired-in 'TyCon's --- defined by the virtual "GHC.Prim" module. This is where we inject the --- representation bindings for these primitive types into "GHC.Types" --- --- See Note [Grand plan for Typeable] in this module. -mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo]) -mkPrimTypeableTodos - = do { mod <- getModule - ; if mod == gHC_TYPES - then do { -- Build Module binding for GHC.Prim - trModuleTyCon <- tcLookupTyCon trModuleTyConName - ; let ghc_prim_module_id = - mkExportedVanillaId trGhcPrimModuleName - (mkTyConTy trModuleTyCon) - - ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id - <$> mkModIdRHS gHC_PRIM - - -- Extend our environment with above - ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id] - getGblEnv - ; let gbl_env' = gbl_env `addTypecheckedBinds` - [unitBag ghc_prim_module_bind] - - -- Build TypeRepTodos for built-in KindReps - ; todo1 <- todoForExportedKindReps builtInKindReps - -- Build TypeRepTodos for types in GHC.Prim - ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id - ghcPrimTypeableTyCons - ; return ( gbl_env' , [todo1, todo2]) - } - else do gbl_env <- getGblEnv - return (gbl_env, []) - } - --- | This is the list of primitive 'TyCon's for which we must generate bindings --- in "GHC.Types". This should include all types defined in "GHC.Prim". --- --- The majority of the types we need here are contained in 'primTyCons'. --- However, not all of them: in particular unboxed tuples are absent since we --- don't want to include them in the original name cache. See --- Note [Built-in syntax and the OrigNameCache] in GHC.Iface.Env for more. -ghcPrimTypeableTyCons :: [TyCon] -ghcPrimTypeableTyCons = concat - [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ] - , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE] - , map sumTyCon [2..mAX_SUM_SIZE] - , primTyCons - ] - -data TypeableStuff - = Stuff { platform :: Platform -- ^ Target platform - , trTyConDataCon :: DataCon -- ^ of @TyCon@ - , trNameLit :: FastString -> LHsExpr GhcTc - -- ^ To construct @TrName@s - -- The various TyCon and DataCons of KindRep - , kindRepTyCon :: TyCon - , kindRepTyConAppDataCon :: DataCon - , kindRepVarDataCon :: DataCon - , kindRepAppDataCon :: DataCon - , kindRepFunDataCon :: DataCon - , kindRepTYPEDataCon :: DataCon - , kindRepTypeLitSDataCon :: DataCon - , typeLitSymbolDataCon :: DataCon - , typeLitNatDataCon :: DataCon - } - --- | Collect various tidbits which we'll need to generate TyCon representations. -collect_stuff :: TcM TypeableStuff -collect_stuff = do - platform <- targetPlatform <$> getDynFlags - trTyConDataCon <- tcLookupDataCon trTyConDataConName - kindRepTyCon <- tcLookupTyCon kindRepTyConName - kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName - kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName - kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName - kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName - kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName - kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName - typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName - typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName - trNameLit <- mkTrNameLit - return Stuff {..} - --- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we --- can save the work of repeating lookups when constructing many TyCon --- representations. -mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc) -mkTrNameLit = do - trNameSDataCon <- tcLookupDataCon trNameSDataConName - let trNameLit :: FastString -> LHsExpr GhcTc - trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon - `nlHsApp` nlHsLit (mkHsStringPrimLit fs) - return trNameLit - --- | Make Typeable bindings for the given 'TyCon'. -mkTyConRepBinds :: TypeableStuff -> TypeRepTodo - -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) -mkTyConRepBinds stuff todo (TypeableTyCon {..}) - = do -- Make a KindRep - let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon) - liftTc $ traceTc "mkTyConKindRepBinds" - (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind) - let ctx = mkDeBruijnContext (map binderVar bndrs) - kind_rep <- getKindRep stuff ctx kind - - -- Make the TyCon binding - let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep - tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs - return $ unitBag tycon_rep_bind - --- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type --- families and polytypes. -tyConIsTypeable :: TyCon -> Bool -tyConIsTypeable tc = - isJust (tyConRepName_maybe tc) - && kindIsTypeable (dropForAlls $ tyConKind tc) - --- | Is a particular 'Kind' representable by @Typeable@? Here we look for --- polytypes and types containing casts (which may be, for instance, a type --- family). -kindIsTypeable :: Kind -> Bool --- We handle types of the form (TYPE LiftedRep) specifically to avoid --- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr) --- to be typeable without inspecting rr, but this exhibits bad behavior --- when rr is a type family. -kindIsTypeable ty - | Just ty' <- coreView ty = kindIsTypeable ty' -kindIsTypeable ty - | isLiftedTypeKind ty = True -kindIsTypeable (TyVarTy _) = True -kindIsTypeable (AppTy a b) = kindIsTypeable a && kindIsTypeable b -kindIsTypeable (FunTy _ a b) = kindIsTypeable a && kindIsTypeable b -kindIsTypeable (TyConApp tc args) = tyConIsTypeable tc - && all kindIsTypeable args -kindIsTypeable (ForAllTy{}) = False -kindIsTypeable (LitTy _) = True -kindIsTypeable (CastTy{}) = False - -- See Note [Typeable instances for casted types] -kindIsTypeable (CoercionTy{}) = False - --- | Maps kinds to 'KindRep' bindings. This binding may either be defined in --- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing') --- or a binding which we generated in the current module (in which case it will --- be 'Just' the RHS of the binding). -type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc)) - --- | A monad within which we will generate 'KindRep's. Here we keep an --- environment containing 'KindRep's which we've already generated so we can --- re-use them opportunistically. -newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a } - deriving (Functor, Applicative, Monad) - -liftTc :: TcRn a -> KindRepM a -liftTc = KindRepM . lift - --- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they --- can be reused across modules. -builtInKindReps :: [(Kind, Name)] -builtInKindReps = - [ (star, starKindRepName) - , (mkVisFunTy star star, starArrStarKindRepName) - , (mkVisFunTys [star, star] star, starArrStarArrStarKindRepName) - ] - where - star = liftedTypeKind - -initialKindRepEnv :: TcRn KindRepEnv -initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps - where - add_kind_rep acc (k,n) = do - id <- tcLookupId n - return $! extendTypeMap acc k (id, Nothing) - --- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's. -mkExportedKindReps :: TypeableStuff - -> [(Kind, Id)] -- ^ the kinds to generate bindings for - -> KindRepM () -mkExportedKindReps stuff = mapM_ kindrep_binding - where - empty_scope = mkDeBruijnContext [] - - kindrep_binding :: (Kind, Id) -> KindRepM () - kindrep_binding (kind, rep_bndr) = do - -- We build the binding manually here instead of using mkKindRepRhs - -- since the latter would find the built-in 'KindRep's in the - -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv'). - rhs <- mkKindRepRhs stuff empty_scope kind - addKindRepBind empty_scope kind rep_bndr rhs - -addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM () -addKindRepBind in_scope k bndr rhs = - KindRepM $ modify' $ - \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs) - --- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking --- environment. -runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a) -runKindRepM (KindRepM action) = do - kindRepEnv <- initialKindRepEnv - (res, reps_env) <- runStateT action kindRepEnv - let rep_binds = foldTypeMap to_bind_pair [] reps_env - to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest - to_bind_pair (_, Nothing) rest = rest - tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv - let binds = map (uncurry mkVarBind) rep_binds - tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds] - return (tcg_env', res) - --- | Produce or find a 'KindRep' for the given kind. -getKindRep :: TypeableStuff -> CmEnv -- ^ in-scope kind variables - -> Kind -- ^ the kind we want a 'KindRep' for - -> KindRepM (LHsExpr GhcTc) -getKindRep stuff@(Stuff {..}) in_scope = go - where - go :: Kind -> KindRepM (LHsExpr GhcTc) - go = KindRepM . StateT . go' - - go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv) - go' k env - -- Look through type synonyms - | Just k' <- tcView k = go' k' env - - -- We've already generated the needed KindRep - | Just (id, _) <- lookupTypeMapWithScope env in_scope k - = return (nlHsVar id, env) - - -- We need to construct a new KindRep binding - | otherwise - = do -- Place a NOINLINE pragma on KindReps since they tend to be quite - -- large and bloat interface files. - rep_bndr <- (`setInlinePragma` neverInlinePragma) - <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon) - - -- do we need to tie a knot here? - flip runStateT env $ unKindRepM $ do - rhs <- mkKindRepRhs stuff in_scope k - addKindRepBind in_scope k rep_bndr rhs - return $ nlHsVar rep_bndr - --- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and --- in-scope kind variable set. -mkKindRepRhs :: TypeableStuff - -> CmEnv -- ^ in-scope kind variables - -> Kind -- ^ the kind we want a 'KindRep' for - -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression -mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep - where - new_kind_rep k - -- We handle (TYPE LiftedRep) etc separately to make it - -- clear to consumers (e.g. serializers) that there is - -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep) - | not (tcIsConstraintKind k) - -- Typeable respects the Constraint/Type distinction - -- so do not follow the special case here - , Just arg <- kindRep_maybe k - , Just (tc, []) <- splitTyConApp_maybe arg - , Just dc <- isPromotedDataCon_maybe tc - = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc - - new_kind_rep (TyVarTy v) - | Just idx <- lookupCME in_scope v - = return $ nlHsDataCon kindRepVarDataCon - `nlHsApp` nlHsIntLit (fromIntegral idx) - | otherwise - = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v) - - new_kind_rep (AppTy t1 t2) - = do rep1 <- getKindRep stuff in_scope t1 - rep2 <- getKindRep stuff in_scope t2 - return $ nlHsDataCon kindRepAppDataCon - `nlHsApp` rep1 `nlHsApp` rep2 - - new_kind_rep k@(TyConApp tc tys) - | Just rep_name <- tyConRepName_maybe tc - = do rep_id <- liftTc $ lookupId rep_name - tys' <- mapM (getKindRep stuff in_scope) tys - return $ nlHsDataCon kindRepTyConAppDataCon - `nlHsApp` nlHsVar rep_id - `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys' - | otherwise - = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k) - - new_kind_rep (ForAllTy (Bndr var _) ty) - = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty) - - new_kind_rep (FunTy _ t1 t2) - = do rep1 <- getKindRep stuff in_scope t1 - rep2 <- getKindRep stuff in_scope t2 - return $ nlHsDataCon kindRepFunDataCon - `nlHsApp` rep1 `nlHsApp` rep2 - - new_kind_rep (LitTy (NumTyLit n)) - = return $ nlHsDataCon kindRepTypeLitSDataCon - `nlHsApp` nlHsDataCon typeLitNatDataCon - `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n) - - new_kind_rep (LitTy (StrTyLit s)) - = return $ nlHsDataCon kindRepTypeLitSDataCon - `nlHsApp` nlHsDataCon typeLitSymbolDataCon - `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s) - - -- See Note [Typeable instances for casted types] - new_kind_rep (CastTy ty co) - = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co) - - new_kind_rep (CoercionTy co) - = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co) - --- | Produce the right-hand-side of a @TyCon@ representation. -mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo - -> TyCon -- ^ the 'TyCon' we are producing a binding for - -> LHsExpr GhcTc -- ^ its 'KindRep' - -> LHsExpr GhcTc -mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep - = nlHsDataCon trTyConDataCon - `nlHsApp` nlHsLit (word64 platform high) - `nlHsApp` nlHsLit (word64 platform low) - `nlHsApp` mod_rep_expr todo - `nlHsApp` trNameLit (mkFastString tycon_str) - `nlHsApp` nlHsLit (int n_kind_vars) - `nlHsApp` kind_rep - where - n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon) - tycon_str = add_tick (occNameString (getOccName tycon)) - add_tick s | isPromotedDataCon tycon = '\'' : s - | otherwise = s - - -- This must match the computation done in - -- Data.Typeable.Internal.mkTyConFingerprint. - Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo - , mod_fingerprint todo - , fingerprintString tycon_str - ] - - int :: Int -> HsLit GhcTc - int n = HsIntPrim (SourceText $ show n) (toInteger n) - -word64 :: Platform -> Word64 -> HsLit GhcTc -word64 platform n = case platformWordSize platform of - PW4 -> HsWord64Prim NoSourceText (toInteger n) - PW8 -> HsWordPrim NoSourceText (toInteger n) - -{- -Note [Representing TyCon kinds: KindRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One of the operations supported by Typeable is typeRepKind, - - typeRepKind :: TypeRep (a :: k) -> TypeRep k - -Implementing this is a bit tricky for poly-kinded types like - - data Proxy (a :: k) :: Type - -- Proxy :: forall k. k -> Type - -The TypeRep encoding of `Proxy Type Int` looks like this: - - $tcProxy :: GHC.Types.TyCon - $trInt :: TypeRep Int - TrType :: TypeRep Type - - $trProxyType :: TypeRep (Proxy Type :: Type -> Type) - $trProxyType = TrTyCon $tcProxy - [TrType] -- kind variable instantiation - (tyConKind $tcProxy [TrType]) -- The TypeRep of - -- Type -> Type - - $trProxy :: TypeRep (Proxy Type Int) - $trProxy = TrApp $trProxyType $trInt TrType - - $tkProxy :: GHC.Types.KindRep - $tkProxy = KindRepFun (KindRepVar 0) - (KindRepTyConApp (KindRepTYPE LiftedRep) []) - -Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent -polymorphic types. So instead - - * $trProxyType uses 'TrTyCon' to apply Proxy to (the representations) - of all its kind arguments. We can't represent a tycon that is - applied to only some of its kind arguments. - - * In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a - GHC.Types.KindRep, which represents the polymorphic kind of Proxy - Proxy :: forall k. k->Type - - * A KindRep is just a recipe that we can instantiate with the - argument kinds, using Data.Typeable.Internal.tyConKind and - store in the relevant 'TypeRep' constructor. - - Data.Typeable.Internal.typeRepKind looks up the stored kinds. - - * In a KindRep, the kind variables are represented by 0-indexed - de Bruijn numbers: - - type KindBndr = Int -- de Bruijn index - - data KindRep = KindRepTyConApp TyCon [KindRep] - | KindRepVar !KindBndr - | KindRepApp KindRep KindRep - | KindRepFun KindRep KindRep - ... - -Note [Typeable instances for casted types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At present, GHC does not manufacture TypeReps for types containing casts -(#16835). In theory, GHC could do so today, but it might be dangerous tomorrow. - -In today's GHC, we normalize all types before computing their TypeRep. -For example: - - type family F a - type instance F Int = Type - - data D = forall (a :: F Int). MkD a - - tr :: TypeRep (MkD Bool) - tr = typeRep - -When computing the TypeRep for `MkD Bool` (or rather, -`MkD (Bool |> Sym (FInt[0]))`), we simply discard the cast to obtain the -TypeRep for `MkD Bool`. - -Why does this work? If we have a type definition with casts, then the -only coercions that those casts can mention are either Refl, type family -axioms, built-in axioms, and coercions built from those roots. Therefore, -type family (and built-in) axioms will apply precisely when type normalization -succeeds (i.e, the type family applications are reducible). Therefore, it -is safe to ignore the cast entirely when constructing the TypeRep. - -This approach would be fragile in a future where GHC permits other forms of -coercions to appear in casts (e.g., coercion quantification as described -in #15710). If GHC permits local assumptions to appear in casts that cannot be -reduced with conventional normalization, then discarding casts would become -unsafe. It would be unfortunate for the Typeable solver to become a roadblock -obstructing such a future, so we deliberately do not implement the ability -for TypeReps to represent types with casts at the moment. - -If we do wish to allow this in the future, it will likely require modeling -casts and coercions in TypeReps themselves. --} - -mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc -mkList ty = foldr consApp (nilExpr ty) - where - cons = consExpr ty - consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc - consApp x xs = cons `nlHsApp` x `nlHsApp` xs - - nilExpr :: Type -> LHsExpr GhcTc - nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon) - - consExpr :: Type -> LHsExpr GhcTc - consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon) diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs deleted file mode 100644 index ae55f7b36c..0000000000 --- a/compiler/typecheck/TcUnify.hs +++ /dev/null @@ -1,2332 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Type subsumption and unification --} - -{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections, - ScopedTypeVariables #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module TcUnify ( - -- Full-blown subsumption - tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET, - tcSubTypeHR, tcSubTypeO, tcSubType_NC, tcSubTypeDS, - tcSubTypeDS_NC_O, tcSubTypeET, - checkConstraints, checkTvConstraints, - buildImplicationFor, emitResidualTvConstraint, - - -- Various unifications - unifyType, unifyKind, - uType, promoteTcType, - swapOverTyVars, canSolveByUnification, - - -------------------------------- - -- Holes - tcInferInst, tcInferNoInst, - matchExpectedListTy, - matchExpectedTyConApp, - matchExpectedAppTy, - matchExpectedFunTys, - matchActualFunTys, matchActualFunTysPart, - matchExpectedFunKind, - - metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..) - - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHC.Hs -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr( debugPprType ) -import TcMType -import TcRnMonad -import TcType -import GHC.Core.Type -import GHC.Core.Coercion -import TcEvidence -import Constraint -import GHC.Core.Predicate -import TcOrigin -import GHC.Types.Name( isSystemName ) -import Inst -import GHC.Core.TyCon -import TysWiredIn -import TysPrim( tYPE ) -import GHC.Types.Var as Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import ErrUtils -import GHC.Driver.Session -import GHC.Types.Basic -import Bag -import Util -import qualified GHC.LanguageExtensions as LangExt -import Outputable - -import Data.Maybe( isNothing ) -import Control.Monad -import Control.Arrow ( second ) - -{- -************************************************************************ -* * - matchExpected functions -* * -************************************************************************ - -Note [Herald for matchExpectedFunTys] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The 'herald' always looks like: - "The equation(s) for 'f' have" - "The abstraction (\x.e) takes" - "The section (+ x) expects" - "The function 'f' is applied to" - -This is used to construct a message of form - - The abstraction `\Just 1 -> ...' takes two arguments - but its type `Maybe a -> a' has only one - - The equation(s) for `f' have two arguments - but its type `Maybe a -> a' has only one - - The section `(f 3)' requires 'f' to take two arguments - but its type `Int -> Int' has only one - - The function 'f' is applied to two arguments - but its type `Int -> Int' has only one - -When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the -picture, we have a choice in deciding whether to count the type applications as -proper arguments: - - The function 'f' is applied to one visible type argument - and two value arguments - but its type `forall a. a -> a` has only one visible type argument - and one value argument - -Or whether to include the type applications as part of the herald itself: - - The expression 'f @Int' is applied to two arguments - but its type `Int -> Int` has only one - -The latter is easier to implement and is arguably easier to understand, so we -choose to implement that option. - -Note [matchExpectedFunTys] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -matchExpectedFunTys checks that a sigma has the form -of an n-ary function. It passes the decomposed type to the -thing_inside, and returns a wrapper to coerce between the two types - -It's used wherever a language construct must have a functional type, -namely: - A lambda expression - A function definition - An operator section - -This function must be written CPS'd because it needs to fill in the -ExpTypes produced for arguments before it can fill in the ExpType -passed in. - --} - --- Use this one when you have an "expected" type. -matchExpectedFunTys :: forall a. - SDoc -- See Note [Herald for matchExpectedFunTys] - -> Arity - -> ExpRhoType -- deeply skolemised - -> ([ExpSigmaType] -> ExpRhoType -> TcM a) - -- must fill in these ExpTypes here - -> TcM (a, HsWrapper) --- If matchExpectedFunTys n ty = (_, wrap) --- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, --- where [t1, ..., tn], ty_r are passed to the thing_inside -matchExpectedFunTys herald arity orig_ty thing_inside - = case orig_ty of - Check ty -> go [] arity ty - _ -> defer [] arity orig_ty - where - go acc_arg_tys 0 ty - = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType ty) - ; return (result, idHsWrapper) } - - go acc_arg_tys n ty - | Just ty' <- tcView ty = go acc_arg_tys n ty' - - go acc_arg_tys n (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) - = ASSERT( af == VisArg ) - do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys) - (n-1) res_ty - ; return ( result - , mkWpFun idHsWrapper wrap_res arg_ty res_ty doc ) } - where - doc = text "When inferring the argument type of a function with type" <+> - quotes (ppr orig_ty) - - go acc_arg_tys n ty@(TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty' -> go acc_arg_tys n ty' - Flexi -> defer acc_arg_tys n (mkCheckExpType ty) } - - -- In all other cases we bale out into ordinary unification - -- However unlike the meta-tyvar case, we are sure that the - -- number of arguments doesn't match arity of the original - -- type, so we can add a bit more context to the error message - -- (cf #7869). - -- - -- It is not always an error, because specialized type may have - -- different arity, for example: - -- - -- > f1 = f2 'a' - -- > f2 :: Monad m => m Bool - -- > f2 = undefined - -- - -- But in that case we add specialized type into error context - -- anyway, because it may be useful. See also #9605. - go acc_arg_tys n ty = addErrCtxtM mk_ctxt $ - defer acc_arg_tys n (mkCheckExpType ty) - - ------------ - defer :: [ExpSigmaType] -> Arity -> ExpRhoType -> TcM (a, HsWrapper) - defer acc_arg_tys n fun_ty - = do { more_arg_tys <- replicateM n newInferExpTypeNoInst - ; res_ty <- newInferExpTypeInst - ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty - ; more_arg_tys <- mapM readExpType more_arg_tys - ; res_ty <- readExpType res_ty - ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty - ; wrap <- tcSubTypeDS AppOrigin GenSigCtxt unif_fun_ty fun_ty - -- Not a good origin at all :-( - ; return (result, wrap) } - - ------------ - mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc) - mk_ctxt env = do { (env', ty) <- zonkTidyTcType env orig_tc_ty - ; let (args, _) = tcSplitFunTys ty - n_actual = length args - (env'', orig_ty') = tidyOpenType env' orig_tc_ty - ; return ( env'' - , mk_fun_tys_msg orig_ty' ty n_actual arity herald) } - where - orig_tc_ty = checkingExpType "matchExpectedFunTys" orig_ty - -- this is safe b/c we're called from "go" - --- Like 'matchExpectedFunTys', but used when you have an "actual" type, --- for example in function application -matchActualFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys] - -> CtOrigin - -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType - -> Arity - -> TcSigmaType - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) --- If matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r) --- then wrap : ty ~> (t1 -> ... -> tn -> ty_r) -matchActualFunTys herald ct_orig mb_thing arity ty - = matchActualFunTysPart herald ct_orig mb_thing arity ty [] arity - --- | Variant of 'matchActualFunTys' that works when supplied only part --- (that is, to the right of some arrows) of the full function type -matchActualFunTysPart :: SDoc -- See Note [Herald for matchExpectedFunTys] - -> CtOrigin - -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType - -> Arity - -> TcSigmaType - -> [TcSigmaType] -- reversed args. See (*) below. - -> Arity -- overall arity of the function, for errs - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) -matchActualFunTysPart herald ct_orig mb_thing arity orig_ty - orig_old_args full_arity - = go arity orig_old_args orig_ty --- Does not allocate unnecessary meta variables: if the input already is --- a function, we just take it apart. Not only is this efficient, --- it's important for higher rank: the argument might be of form --- (forall a. ty) -> other --- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd --- hide the forall inside a meta-variable - --- (*) Sometimes it's necessary to call matchActualFunTys with only part --- (that is, to the right of some arrows) of the type of the function in --- question. (See TcExpr.tcArgs.) This argument is the reversed list of --- arguments already seen (that is, not part of the TcSigmaType passed --- in elsewhere). - - where - -- This function has a bizarre mechanic: it accumulates arguments on - -- the way down and also builds an argument list on the way up. Why: - -- 1. The returns args list and the accumulated args list might be different. - -- The accumulated args include all the arg types for the function, - -- including those from before this function was called. The returned - -- list should include only those arguments produced by this call of - -- matchActualFunTys - -- - -- 2. The HsWrapper can be built only on the way up. It seems (more) - -- bizarre to build the HsWrapper but not the arg_tys. - -- - -- Refactoring is welcome. - go :: Arity - -> [TcSigmaType] -- accumulator of arguments (reversed) - -> TcSigmaType -- the remainder of the type as we're processing - -> TcM (HsWrapper, [TcSigmaType], TcSigmaType) - go 0 _ ty = return (idHsWrapper, [], ty) - - go n acc_args ty - | not (null tvs && null theta) - = do { (wrap1, rho) <- topInstantiate ct_orig ty - ; (wrap2, arg_tys, res_ty) <- go n acc_args rho - ; return (wrap2 <.> wrap1, arg_tys, res_ty) } - where - (tvs, theta, _) = tcSplitSigmaTy ty - - go n acc_args ty - | Just ty' <- tcView ty = go n acc_args ty' - - go n acc_args (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) - = ASSERT( af == VisArg ) - do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty - ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r doc - , arg_ty : tys, ty_r ) } - where - doc = text "When inferring the argument type of a function with type" <+> - quotes (ppr orig_ty) - - go n acc_args ty@(TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty' -> go n acc_args ty' - Flexi -> defer n ty } - - -- In all other cases we bale out into ordinary unification - -- However unlike the meta-tyvar case, we are sure that the - -- number of arguments doesn't match arity of the original - -- type, so we can add a bit more context to the error message - -- (cf #7869). - -- - -- It is not always an error, because specialized type may have - -- different arity, for example: - -- - -- > f1 = f2 'a' - -- > f2 :: Monad m => m Bool - -- > f2 = undefined - -- - -- But in that case we add specialized type into error context - -- anyway, because it may be useful. See also #9605. - go n acc_args ty = addErrCtxtM (mk_ctxt (reverse acc_args) ty) $ - defer n ty - - ------------ - defer n fun_ty - = do { arg_tys <- replicateM n newOpenFlexiTyVarTy - ; res_ty <- newOpenFlexiTyVarTy - ; let unif_fun_ty = mkVisFunTys arg_tys res_ty - ; co <- unifyType mb_thing fun_ty unif_fun_ty - ; return (mkWpCastN co, arg_tys, res_ty) } - - ------------ - mk_ctxt :: [TcSigmaType] -> TcSigmaType -> TidyEnv -> TcM (TidyEnv, MsgDoc) - mk_ctxt arg_tys res_ty env - = do { let ty = mkVisFunTys arg_tys res_ty - ; (env1, zonked) <- zonkTidyTcType env ty - -- zonking might change # of args - ; let (zonked_args, _) = tcSplitFunTys zonked - n_actual = length zonked_args - (env2, unzonked) = tidyOpenType env1 ty - ; return ( env2 - , mk_fun_tys_msg unzonked zonked n_actual full_arity herald) } - -mk_fun_tys_msg :: TcType -- the full type passed in (unzonked) - -> TcType -- the full type passed in (zonked) - -> Arity -- the # of args found - -> Arity -- the # of args wanted - -> SDoc -- overall herald - -> SDoc -mk_fun_tys_msg full_ty ty n_args full_arity herald - = herald <+> speakNOf full_arity (text "argument") <> comma $$ - if n_args == full_arity - then text "its type is" <+> quotes (pprType full_ty) <> - comma $$ - text "it is specialized to" <+> quotes (pprType ty) - else sep [text "but its type" <+> quotes (pprType ty), - if n_args == 0 then text "has none" - else text "has only" <+> speakN n_args] - ----------------------- -matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) --- Special case for lists -matchExpectedListTy exp_ty - = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty - ; return (co, elt_ty) } - ---------------------- -matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> * - -> TcRhoType -- orig_ty - -> TcM (TcCoercionN, -- T k1 k2 k3 a b c ~N orig_ty - [TcSigmaType]) -- Element types, k1 k2 k3 a b c - --- It's used for wired-in tycons, so we call checkWiredInTyCon --- Precondition: never called with FunTyCon --- Precondition: input type :: * --- Postcondition: (T k1 k2 k3 a b c) is well-kinded - -matchExpectedTyConApp tc orig_ty - = ASSERT(tc /= funTyCon) go orig_ty - where - go ty - | Just ty' <- tcView ty - = go ty' - - go ty@(TyConApp tycon args) - | tc == tycon -- Common case - = return (mkTcNomReflCo ty, args) - - go (TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty -> go ty - Flexi -> defer } - - go _ = defer - - -- If the common case does not occur, instantiate a template - -- T k1 .. kn t1 .. tm, and unify with the original type - -- Doing it this way ensures that the types we return are - -- kind-compatible with T. For example, suppose we have - -- matchExpectedTyConApp T (f Maybe) - -- where data T a = MkT a - -- Then we don't want to instantiate T's data constructors with - -- (a::*) ~ Maybe - -- because that'll make types that are utterly ill-kinded. - -- This happened in #7368 - defer - = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc) - ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs) - ; let args = mkTyVarTys arg_tvs - tc_template = mkTyConApp tc args - ; co <- unifyType Nothing tc_template orig_ty - ; return (co, args) } - ----------------------- -matchExpectedAppTy :: TcRhoType -- orig_ty - -> TcM (TcCoercion, -- m a ~N orig_ty - (TcSigmaType, TcSigmaType)) -- Returns m, a --- If the incoming type is a mutable type variable of kind k, then --- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. - -matchExpectedAppTy orig_ty - = go orig_ty - where - go ty - | Just ty' <- tcView ty = go ty' - - | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty - = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty)) - - go (TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty -> go ty - Flexi -> defer } - - go _ = defer - - -- Defer splitting by generating an equality constraint - defer - = do { ty1 <- newFlexiTyVarTy kind1 - ; ty2 <- newFlexiTyVarTy kind2 - ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty - ; return (co, (ty1, ty2)) } - - orig_kind = tcTypeKind orig_ty - kind1 = mkVisFunTy liftedTypeKind orig_kind - kind2 = liftedTypeKind -- m :: * -> k - -- arg type :: * - -{- -************************************************************************ -* * - Subsumption checking -* * -************************************************************************ - -Note [Subsumption checking: tcSubType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All the tcSubType calls have the form - tcSubType actual_ty expected_ty -which checks - actual_ty <= expected_ty - -That is, that a value of type actual_ty is acceptable in -a place expecting a value of type expected_ty. I.e. that - - actual ty is more polymorphic than expected_ty - -It returns a coercion function - co_fn :: actual_ty ~ expected_ty -which takes an HsExpr of type actual_ty into one of type -expected_ty. - -These functions do not actually check for subsumption. They check if -expected_ty is an appropriate annotation to use for something of type -actual_ty. This difference matters when thinking about visible type -application. For example, - - forall a. a -> forall b. b -> b - DOES NOT SUBSUME - forall a b. a -> b -> b - -because the type arguments appear in a different order. (Neither does -it work the other way around.) BUT, these types are appropriate annotations -for one another. Because the user directs annotations, it's OK if some -arguments shuffle around -- after all, it's what the user wants. -Bottom line: none of this changes with visible type application. - -There are a number of wrinkles (below). - -Notice that Wrinkle 1 and 2 both require eta-expansion, which technically -may increase termination. We just put up with this, in exchange for getting -more predictable type inference. - -Wrinkle 1: Note [Deep skolemisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want (forall a. Int -> a -> a) <= (Int -> forall a. a->a) -(see section 4.6 of "Practical type inference for higher rank types") -So we must deeply-skolemise the RHS before we instantiate the LHS. - -That is why tc_sub_type starts with a call to tcSkolemise (which does the -deep skolemisation), and then calls the DS variant (which assumes -that expected_ty is deeply skolemised) - -Wrinkle 2: Note [Co/contra-variance of subsumption checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider g :: (Int -> Int) -> Int - f1 :: (forall a. a -> a) -> Int - f1 = g - - f2 :: (forall a. a -> a) -> Int - f2 x = g x -f2 will typecheck, and it would be odd/fragile if f1 did not. -But f1 will only typecheck if we have that - (Int->Int) -> Int <= (forall a. a->a) -> Int -And that is only true if we do the full co/contravariant thing -in the subsumption check. That happens in the FunTy case of -tcSubTypeDS_NC_O, and is the sole reason for the WpFun form of -HsWrapper. - -Another powerful reason for doing this co/contra stuff is visible -in #9569, involving instantiation of constraint variables, -and again involving eta-expansion. - -Wrinkle 3: Note [Higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider tc150: - f y = \ (x::forall a. a->a). blah -The following happens: -* We will infer the type of the RHS, ie with a res_ty = alpha. -* Then the lambda will split alpha := beta -> gamma. -* And then we'll check tcSubType IsSwapped beta (forall a. a->a) - -So it's important that we unify beta := forall a. a->a, rather than -skolemising the type. --} - - --- | Call this variant when you are in a higher-rank situation and --- you know the right-hand type is deeply skolemised. -tcSubTypeHR :: CtOrigin -- ^ of the actual type - -> Maybe (HsExpr GhcRn) -- ^ If present, it has type ty_actual - -> TcSigmaType -> ExpRhoType -> TcM HsWrapper -tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt - ------------------------- -tcSubTypeET :: CtOrigin -> UserTypeCtxt - -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper --- If wrap = tc_sub_type_et t1 t2 --- => wrap :: t1 ~> t2 -tcSubTypeET orig ctxt (Check ty_actual) ty_expected - = tc_sub_tc_type eq_orig orig ctxt ty_actual ty_expected - where - eq_orig = TypeEqOrigin { uo_actual = ty_expected - , uo_expected = ty_actual - , uo_thing = Nothing - , uo_visible = True } - -tcSubTypeET _ _ (Infer inf_res) ty_expected - = ASSERT2( not (ir_inst inf_res), ppr inf_res $$ ppr ty_expected ) - -- An (Infer inf_res) ExpSigmaType passed into tcSubTypeET never - -- has the ir_inst field set. Reason: in patterns (which is what - -- tcSubTypeET is used for) do not aggressively instantiate - do { co <- fill_infer_result ty_expected inf_res - -- Since ir_inst is false, we can skip fillInferResult - -- and go straight to fill_infer_result - - ; return (mkWpCastN (mkTcSymCo co)) } - ------------------------- -tcSubTypeO :: CtOrigin -- ^ of the actual type - -> UserTypeCtxt -- ^ of the expected type - -> TcSigmaType - -> ExpRhoType - -> TcM HsWrapper -tcSubTypeO orig ctxt ty_actual ty_expected - = addSubTypeCtxt ty_actual ty_expected $ - do { traceTc "tcSubTypeDS_O" (vcat [ pprCtOrigin orig - , pprUserTypeCtxt ctxt - , ppr ty_actual - , ppr ty_expected ]) - ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected } - -addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a -addSubTypeCtxt ty_actual ty_expected thing_inside - | isRhoTy ty_actual -- If there is no polymorphism involved, the - , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) - = thing_inside -- gives enough context by itself - | otherwise - = addErrCtxtM mk_msg thing_inside - where - mk_msg tidy_env - = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual - -- might not be filled if we're debugging. ugh. - ; mb_ty_expected <- readExpType_maybe ty_expected - ; (tidy_env, ty_expected) <- case mb_ty_expected of - Just ty -> second mkCheckExpType <$> - zonkTidyTcType tidy_env ty - Nothing -> return (tidy_env, ty_expected) - ; ty_expected <- readExpType ty_expected - ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected - ; let msg = vcat [ hang (text "When checking that:") - 4 (ppr ty_actual) - , nest 2 (hang (text "is more polymorphic than:") - 2 (ppr ty_expected)) ] - ; return (tidy_env, msg) } - ---------------- --- The "_NC" variants do not add a typechecker-error context; --- the caller is assumed to do that - -tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper --- Checks that actual <= expected --- Returns HsWrapper :: actual ~ expected -tcSubType_NC ctxt ty_actual ty_expected - = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) - ; tc_sub_tc_type origin origin ctxt ty_actual ty_expected } - where - origin = TypeEqOrigin { uo_actual = ty_actual - , uo_expected = ty_expected - , uo_thing = Nothing - , uo_visible = True } - -tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWrapper --- Just like tcSubType, but with the additional precondition that --- ty_expected is deeply skolemised (hence "DS") -tcSubTypeDS orig ctxt ty_actual ty_expected - = addSubTypeCtxt ty_actual ty_expected $ - do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) - ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected } - -tcSubTypeDS_NC_O :: CtOrigin -- origin used for instantiation only - -> UserTypeCtxt - -> Maybe (HsExpr GhcRn) - -> TcSigmaType -> ExpRhoType -> TcM HsWrapper --- Just like tcSubType, but with the additional precondition that --- ty_expected is deeply skolemised -tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected - = case ty_expected of - Infer inf_res -> fillInferResult inst_orig ty_actual inf_res - Check ty -> tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty - where - eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty - , uo_thing = ppr <$> m_thing - , uo_visible = True } - ---------------- -tc_sub_tc_type :: CtOrigin -- used when calling uType - -> CtOrigin -- used when instantiating - -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper --- If wrap = tc_sub_type t1 t2 --- => wrap :: t1 ~> t2 -tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected - | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] - , not (possibly_poly ty_actual) - = do { traceTc "tc_sub_tc_type (drop to equality)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; mkWpCastN <$> - uType TypeLevel eq_orig ty_actual ty_expected } - - | otherwise -- This is the general case - = do { traceTc "tc_sub_tc_type (general case)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; (sk_wrap, inner_wrap) <- tcSkolemise ctxt ty_expected $ - \ _ sk_rho -> - tc_sub_type_ds eq_orig inst_orig ctxt - ty_actual sk_rho - ; return (sk_wrap <.> inner_wrap) } - where - possibly_poly ty - | isForAllTy ty = True - | Just (_, res) <- splitFunTy_maybe ty = possibly_poly res - | otherwise = False - -- NB *not* tcSplitFunTy, because here we want - -- to decompose type-class arguments too - - definitely_poly ty - | (tvs, theta, tau) <- tcSplitSigmaTy ty - , (tv:_) <- tvs - , null theta - , isInsolubleOccursCheck NomEq tv tau - = True - | otherwise - = False - -{- Note [Don't skolemise unnecessarily] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are trying to solve - (Char->Char) <= (forall a. a->a) -We could skolemise the 'forall a', and then complain -that (Char ~ a) is insoluble; but that's a pretty obscure -error. It's better to say that - (Char->Char) ~ (forall a. a->a) -fails. - -So roughly: - * if the ty_expected has an outermost forall - (i.e. skolemisation is the next thing we'd do) - * and the ty_actual has no top-level polymorphism (but looking deeply) -then we can revert to simple equality. But we need to be careful. -These examples are all fine: - - * (Char -> forall a. a->a) <= (forall a. Char -> a -> a) - Polymorphism is buried in ty_actual - - * (Char->Char) <= (forall a. Char -> Char) - ty_expected isn't really polymorphic - - * (Char->Char) <= (forall a. (a~Char) => a -> a) - ty_expected isn't really polymorphic - - * (Char->Char) <= (forall a. F [a] Char -> Char) - where type instance F [x] t = t - ty_expected isn't really polymorphic - -If we prematurely go to equality we'll reject a program we should -accept (e.g. #13752). So the test (which is only to improve -error message) is very conservative: - * ty_actual is /definitely/ monomorphic - * ty_expected is /definitely/ polymorphic --} - ---------------- -tc_sub_type_ds :: CtOrigin -- used when calling uType - -> CtOrigin -- used when instantiating - -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper --- If wrap = tc_sub_type_ds t1 t2 --- => wrap :: t1 ~> t2 --- Here is where the work actually happens! --- Precondition: ty_expected is deeply skolemised -tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected - = do { traceTc "tc_sub_type_ds" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; go ty_actual ty_expected } - where - go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e - | Just ty_e' <- tcView ty_e = go ty_a ty_e' - - go (TyVarTy tv_a) ty_e - = do { lookup_res <- lookupTcTyVar tv_a - ; case lookup_res of - Filled ty_a' -> - do { traceTc "tcSubTypeDS_NC_O following filled act meta-tyvar:" - (ppr tv_a <+> text "-->" <+> ppr ty_a') - ; tc_sub_type_ds eq_orig inst_orig ctxt ty_a' ty_e } - Unfilled _ -> unify } - - -- Historical note (Sept 16): there was a case here for - -- go ty_a (TyVarTy alpha) - -- which, in the impredicative case unified alpha := ty_a - -- where th_a is a polytype. Not only is this probably bogus (we - -- simply do not have decent story for impredicative types), but it - -- caused #12616 because (also bizarrely) 'deriving' code had - -- -XImpredicativeTypes on. I deleted the entire case. - - go (FunTy { ft_af = VisArg, ft_arg = act_arg, ft_res = act_res }) - (FunTy { ft_af = VisArg, ft_arg = exp_arg, ft_res = exp_res }) - = -- See Note [Co/contra-variance of subsumption checking] - do { res_wrap <- tc_sub_type_ds eq_orig inst_orig ctxt act_res exp_res - ; arg_wrap <- tc_sub_tc_type eq_orig given_orig GenSigCtxt exp_arg act_arg - -- GenSigCtxt: See Note [Setting the argument context] - ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res doc) } - -- arg_wrap :: exp_arg ~> act_arg - -- res_wrap :: act-res ~> exp_res - where - given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) - doc = text "When checking that" <+> quotes (ppr ty_actual) <+> - text "is more polymorphic than" <+> quotes (ppr ty_expected) - - go ty_a ty_e - | let (tvs, theta, _) = tcSplitSigmaTy ty_a - , not (null tvs && null theta) - = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a - ; body_wrap <- tc_sub_type_ds - (eq_orig { uo_actual = in_rho - , uo_expected = ty_expected }) - inst_orig ctxt in_rho ty_e - ; return (body_wrap <.> in_wrap) } - - | otherwise -- Revert to unification - = inst_and_unify - -- It's still possible that ty_actual has nested foralls. Instantiate - -- these, as there's no way unification will succeed with them in. - -- See typecheck/should_compile/T11305 for an example of when this - -- is important. The problem is that we're checking something like - -- a -> forall b. b -> b <= alpha beta gamma - -- where we end up with alpha := (->) - - inst_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual - - -- If we haven't recurred through an arrow, then - -- the eq_orig will list ty_actual. In this case, - -- we want to update the origin to reflect the - -- instantiation. If we *have* recurred through - -- an arrow, it's better not to update. - ; let eq_orig' = case eq_orig of - TypeEqOrigin { uo_actual = orig_ty_actual } - | orig_ty_actual `tcEqType` ty_actual - , not (isIdHsWrapper wrap) - -> eq_orig { uo_actual = rho_a } - _ -> eq_orig - - ; cow <- uType TypeLevel eq_orig' rho_a ty_expected - ; return (mkWpCastN cow <.> wrap) } - - - -- use versions without synonyms expanded - unify = mkWpCastN <$> uType TypeLevel eq_orig ty_actual ty_expected - -{- Note [Settting the argument context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider we are doing the ambiguity check for the (bogus) - f :: (forall a b. C b => a -> a) -> Int - -We'll call - tcSubType ((forall a b. C b => a->a) -> Int ) - ((forall a b. C b => a->a) -> Int ) - -with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing -on the argument type of the (->) -- and at that point we want to switch -to a UserTypeCtxt of GenSigCtxt. Why? - -* Error messages. If we stick with FunSigCtxt we get errors like - * Could not deduce: C b - from the context: C b0 - bound by the type signature for: - f :: forall a b. C b => a->a - But of course f does not have that type signature! - Example tests: T10508, T7220a, Simple14 - -* Implications. We may decide to build an implication for the whole - ambiguity check, but we don't need one for each level within it, - and TcUnify.alwaysBuildImplication checks the UserTypeCtxt. - See Note [When to build an implication] --} - ------------------ --- needs both un-type-checked (for origins) and type-checked (for wrapping) --- expressions -tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr GhcTcId) -tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr - --- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more --- convenient. -tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr GhcTcId) -tcWrapResultO orig rn_expr expr actual_ty res_ty - = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty - , text "Expected:" <+> ppr res_ty ]) - ; cow <- tcSubTypeDS_NC_O orig GenSigCtxt - (Just rn_expr) actual_ty res_ty - ; return (mkHsWrap cow expr) } - - -{- ********************************************************************** -%* * - ExpType functions: tcInfer, fillInferResult -%* * -%********************************************************************* -} - --- | Infer a type using a fresh ExpType --- See also Note [ExpType] in TcMType --- Does not attempt to instantiate the inferred type -tcInferNoInst :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tcInferNoInst = tcInfer False - -tcInferInst :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType) -tcInferInst = tcInfer True - -tcInfer :: Bool -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tcInfer instantiate tc_check - = do { res_ty <- newInferExpType instantiate - ; result <- tc_check res_ty - ; res_ty <- readExpType res_ty - ; return (result, res_ty) } - -fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper --- If wrap = fillInferResult t1 t2 --- => wrap :: t1 ~> t2 --- See Note [Deep instantiation of InferResult] -fillInferResult orig ty inf_res@(IR { ir_inst = instantiate_me }) - | instantiate_me - = do { (wrap, rho) <- deeplyInstantiate orig ty - ; co <- fill_infer_result rho inf_res - ; return (mkWpCastN co <.> wrap) } - - | otherwise - = do { co <- fill_infer_result ty inf_res - ; return (mkWpCastN co) } - -fill_infer_result :: TcType -> InferResult -> TcM TcCoercionN --- If wrap = fill_infer_result t1 t2 --- => wrap :: t1 ~> t2 -fill_infer_result orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl - , ir_ref = ref }) - = do { (ty_co, ty_to_fill_with) <- promoteTcType res_lvl orig_ty - - ; traceTc "Filling ExpType" $ - ppr u <+> text ":=" <+> ppr ty_to_fill_with - - ; when debugIsOn (check_hole ty_to_fill_with) - - ; writeTcRef ref (Just ty_to_fill_with) - - ; return ty_co } - where - check_hole ty -- Debug check only - = do { let ty_lvl = tcTypeLevel ty - ; MASSERT2( not (ty_lvl `strictlyDeeperThan` res_lvl), - ppr u $$ ppr res_lvl $$ ppr ty_lvl $$ - ppr ty <+> dcolon <+> ppr (tcTypeKind ty) $$ ppr orig_ty ) - ; cts <- readTcRef ref - ; case cts of - Just already_there -> pprPanic "writeExpType" - (vcat [ ppr u - , ppr ty - , ppr already_there ]) - Nothing -> return () } - -{- Note [Deep instantiation of InferResult] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some cases we want to deeply instantiate before filling in -an InferResult, and in some cases not. That's why InferReult -has the ir_inst flag. - -ir_inst = True: deeply instantiate ----------------------------------- - -1. Consider - f x = (*) - We want to instantiate the type of (*) before returning, else we - will infer the type - f :: forall {a}. a -> forall b. Num b => b -> b -> b - This is surely confusing for users. - - And worse, the monomorphism restriction won't work properly. The MR is - dealt with in simplifyInfer, and simplifyInfer has no way of - instantiating. This could perhaps be worked around, but it may be - hard to know even when instantiation should happen. - -2. Another reason. Consider - f :: (?x :: Int) => a -> a - g y = let ?x = 3::Int in f - Here want to instantiate f's type so that the ?x::Int constraint - gets discharged by the enclosing implicit-parameter binding. - -ir_inst = False: do not instantiate ------------------------------------ - -1. Consider this (which uses visible type application): - - (let { f :: forall a. a -> a; f x = x } in f) @Int - - We'll call TcExpr.tcInferFun to infer the type of the (let .. in f) - And we don't want to instantiate the type of 'f' when we reach it, - else the outer visible type application won't work - -2. :type +v. When we say - - :type +v const @Int - - we really want `forall b. Int -> b -> Int`. Note that this is *not* - instantiated. - -3. Pattern bindings. For example: - - foo x - | blah <- const @Int - = (blah x False, blah x 'z') - - Note that `blah` is polymorphic. (This isn't a terribly compelling - reason, but the choice of ir_inst does matter here.) - -Discussion ----------- -We thought that we should just remove the ir_inst flag, in favor of -always instantiating. Essentially: motivations (1) and (3) for ir_inst = False -are not terribly exciting. However, motivation (2) is quite important. -Furthermore, there really was not much of a simplification of the code -in removing ir_inst, and working around it to enable flows like what we -see in (2) is annoying. This was done in #17173. - --} - -{- ********************************************************************* -* * - Promoting types -* * -********************************************************************* -} - -promoteTcType :: TcLevel -> TcType -> TcM (TcCoercion, TcType) --- See Note [Promoting a type] --- promoteTcType level ty = (co, ty') --- * Returns ty' whose max level is just 'level' --- and whose kind is ~# to the kind of 'ty' --- and whose kind has form TYPE rr --- * and co :: ty ~ ty' --- * and emits constraints to justify the coercion -promoteTcType dest_lvl ty - = do { cur_lvl <- getTcLevel - ; if (cur_lvl `sameDepthAs` dest_lvl) - then dont_promote_it - else promote_it } - where - promote_it :: TcM (TcCoercion, TcType) - promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty - -- where alpha and rr are fresh and from level dest_lvl - = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy - ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr) - ; let eq_orig = TypeEqOrigin { uo_actual = ty - , uo_expected = prom_ty - , uo_thing = Nothing - , uo_visible = False } - - ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty - ; return (co, prom_ty) } - - dont_promote_it :: TcM (TcCoercion, TcType) - dont_promote_it -- Check that ty :: TYPE rr, for some (fresh) rr - = do { res_kind <- newOpenTypeKind - ; let ty_kind = tcTypeKind ty - kind_orig = TypeEqOrigin { uo_actual = ty_kind - , uo_expected = res_kind - , uo_thing = Nothing - , uo_visible = False } - ; ki_co <- uType KindLevel kind_orig (tcTypeKind ty) res_kind - ; let co = mkTcGReflRightCo Nominal ty ki_co - ; return (co, ty `mkCastTy` ki_co) } - -{- Note [Promoting a type] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12427) - - data T where - MkT :: (Int -> Int) -> a -> T - - h y = case y of MkT v w -> v - -We'll infer the RHS type with an expected type ExpType of - (IR { ir_lvl = l, ir_ref = ref, ... ) -where 'l' is the TcLevel of the RHS of 'h'. Then the MkT pattern -match will increase the level, so we'll end up in tcSubType, trying to -unify the type of v, - v :: Int -> Int -with the expected type. But this attempt takes place at level (l+1), -rightly so, since v's type could have mentioned existential variables, -(like w's does) and we want to catch that. - -So we - - create a new meta-var alpha[l+1] - - fill in the InferRes ref cell 'ref' with alpha - - emit an equality constraint, thus - [W] alpha[l+1] ~ (Int -> Int) - -That constraint will float outwards, as it should, unless v's -type mentions a skolem-captured variable. - -This approach fails if v has a higher rank type; see -Note [Promotion and higher rank types] - - -Note [Promotion and higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If v had a higher-rank type, say v :: (forall a. a->a) -> Int, -then we'd emit an equality - [W] alpha[l+1] ~ ((forall a. a->a) -> Int) -which will sadly fail because we can't unify a unification variable -with a polytype. But there is nothing really wrong with the program -here. - -We could just about solve this by "promote the type" of v, to expose -its polymorphic "shape" while still leaving constraints that will -prevent existential escape. But we must be careful! Exposing -the "shape" of the type is precisely what we must NOT do under -a GADT pattern match! So in this case we might promote the type -to - (forall a. a->a) -> alpha[l+1] -and emit the constraint - [W] alpha[l+1] ~ Int -Now the promoted type can fill the ref cell, while the emitted -equality can float or not, according to the usual rules. - -But that's not quite right! We are exposing the arrow! We could -deal with that too: - (forall a. mu[l+1] a a) -> alpha[l+1] -with constraints - [W] alpha[l+1] ~ Int - [W] mu[l+1] ~ (->) -Here we abstract over the '->' inside the forall, in case that -is subject to an equality constraint from a GADT match. - -Note that we kept the outer (->) because that's part of -the polymorphic "shape". And because of impredicativity, -GADT matches can't give equalities that affect polymorphic -shape. - -This reasoning just seems too complicated, so I decided not -to do it. These higher-rank notes are just here to record -the thinking. --} - -{- ********************************************************************* -* * - Generalisation -* * -********************************************************************* -} - --- | Take an "expected type" and strip off quantifiers to expose the --- type underneath, binding the new skolems for the @thing_inside@. --- The returned 'HsWrapper' has type @specific_ty -> expected_ty@. -tcSkolemise :: UserTypeCtxt -> TcSigmaType - -> ([TcTyVar] -> TcType -> TcM result) - -- ^ These are only ever used for scoped type variables. - -> TcM (HsWrapper, result) - -- ^ The expression has type: spec_ty -> expected_ty - -tcSkolemise ctxt expected_ty thing_inside - -- We expect expected_ty to be a forall-type - -- If not, the call is a no-op - = do { traceTc "tcSkolemise" Outputable.empty - ; (wrap, tv_prs, given, rho') <- deeplySkolemise expected_ty - - ; lvl <- getTcLevel - ; when debugIsOn $ - traceTc "tcSkolemise" $ vcat [ - ppr lvl, - text "expected_ty" <+> ppr expected_ty, - text "inst tyvars" <+> ppr tv_prs, - text "given" <+> ppr given, - text "inst type" <+> ppr rho' ] - - -- Generally we must check that the "forall_tvs" haven't been constrained - -- The interesting bit here is that we must include the free variables - -- of the expected_ty. Here's an example: - -- runST (newVar True) - -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool)) - -- for (newVar True), with s fresh. Then we unify with the runST's arg type - -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool. - -- So now s' isn't unconstrained because it's linked to a. - -- - -- However [Oct 10] now that the untouchables are a range of - -- TcTyVars, all this is handled automatically with no need for - -- extra faffing around - - ; let tvs' = map snd tv_prs - skol_info = SigSkol ctxt expected_ty tv_prs - - ; (ev_binds, result) <- checkConstraints skol_info tvs' given $ - thing_inside tvs' rho' - - ; return (wrap <.> mkWpLet ev_binds, result) } - -- The ev_binds returned by checkConstraints is very - -- often empty, in which case mkWpLet is a no-op - --- | Variant of 'tcSkolemise' that takes an ExpType -tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType - -> (ExpRhoType -> TcM result) - -> TcM (HsWrapper, result) -tcSkolemiseET _ et@(Infer {}) thing_inside - = (idHsWrapper, ) <$> thing_inside et -tcSkolemiseET ctxt (Check ty) thing_inside - = tcSkolemise ctxt ty $ \_ -> thing_inside . mkCheckExpType - -checkConstraints :: SkolemInfo - -> [TcTyVar] -- Skolems - -> [EvVar] -- Given - -> TcM result - -> TcM (TcEvBinds, result) - -checkConstraints skol_info skol_tvs given thing_inside - = do { implication_needed <- implicationNeeded skol_info skol_tvs given - - ; if implication_needed - then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside - ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted - ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs) - ; emitImplications implics - ; return (ev_binds, result) } - - else -- Fast path. We check every function argument with - -- tcPolyExpr, which uses tcSkolemise and hence checkConstraints. - -- So this fast path is well-exercised - do { res <- thing_inside - ; return (emptyTcEvBinds, res) } } - -checkTvConstraints :: SkolemInfo - -> [TcTyVar] -- Skolem tyvars - -> TcM result - -> TcM result - -checkTvConstraints skol_info skol_tvs thing_inside - = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside - ; emitResidualTvConstraint skol_info Nothing skol_tvs tclvl wanted - ; return result } - -emitResidualTvConstraint :: SkolemInfo -> Maybe SDoc -> [TcTyVar] - -> TcLevel -> WantedConstraints -> TcM () -emitResidualTvConstraint skol_info m_telescope skol_tvs tclvl wanted - | isEmptyWC wanted - , isNothing m_telescope || skol_tvs `lengthAtMost` 1 - -- If m_telescope is (Just d), we must do the bad-telescope check, - -- so we must /not/ discard the implication even if there are no - -- wanted constraints. See Note [Checking telescopes] in Constraint. - -- Lacking this check led to #16247 - = return () - - | otherwise - = do { ev_binds <- newNoTcEvBinds - ; implic <- newImplication - ; let status | insolubleWC wanted = IC_Insoluble - | otherwise = IC_Unsolved - -- If the inner constraints are insoluble, - -- we should mark the outer one similarly, - -- so that insolubleWC works on the outer one - - ; emitImplication $ - implic { ic_status = status - , ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_no_eqs = True - , ic_telescope = m_telescope - , ic_wanted = wanted - , ic_binds = ev_binds - , ic_info = skol_info } } - -implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool --- See Note [When to build an implication] -implicationNeeded skol_info skol_tvs given - | null skol_tvs - , null given - , not (alwaysBuildImplication skol_info) - = -- Empty skolems and givens - do { tc_lvl <- getTcLevel - ; if not (isTopTcLevel tc_lvl) -- No implication needed if we are - then return False -- already inside an implication - else - do { dflags <- getDynFlags -- If any deferral can happen, - -- we must build an implication - ; return (gopt Opt_DeferTypeErrors dflags || - gopt Opt_DeferTypedHoles dflags || - gopt Opt_DeferOutOfScopeVariables dflags) } } - - | otherwise -- Non-empty skolems or givens - = return True -- Definitely need an implication - -alwaysBuildImplication :: SkolemInfo -> Bool --- See Note [When to build an implication] -alwaysBuildImplication _ = False - -{- Commmented out for now while I figure out about error messages. - See #14185 - -alwaysBuildImplication (SigSkol ctxt _ _) - = case ctxt of - FunSigCtxt {} -> True -- RHS of a binding with a signature - _ -> False -alwaysBuildImplication (RuleSkol {}) = True -alwaysBuildImplication (InstSkol {}) = True -alwaysBuildImplication (FamInstSkol {}) = True -alwaysBuildImplication _ = False --} - -buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar] - -> [EvVar] -> WantedConstraints - -> TcM (Bag Implication, TcEvBinds) -buildImplicationFor tclvl skol_info skol_tvs given wanted - | isEmptyWC wanted && null given - -- Optimisation : if there are no wanteds, and no givens - -- don't generate an implication at all. - -- Reason for the (null given): we don't want to lose - -- the "inaccessible alternative" error check - = return (emptyBag, emptyTcEvBinds) - - | otherwise - = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs ) - -- Why allow TyVarTvs? Because implicitly declared kind variables in - -- non-CUSK type declarations are TyVarTvs, and we need to bring them - -- into scope as a skolem in an implication. This is OK, though, - -- because TyVarTvs will always remain tyvars, even after unification. - do { ev_binds_var <- newTcEvBinds - ; implic <- newImplication - ; let implic' = implic { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_given = given - , ic_wanted = wanted - , ic_binds = ev_binds_var - , ic_info = skol_info } - - ; return (unitBag implic', TcEvBinds ev_binds_var) } - -{- Note [When to build an implication] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have some 'skolems' and some 'givens', and we are -considering whether to wrap the constraints in their scope into an -implication. We must /always/ so if either 'skolems' or 'givens' are -non-empty. But what if both are empty? You might think we could -always drop the implication. Other things being equal, the fewer -implications the better. Less clutter and overhead. But we must -take care: - -* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors, - we'll make a /term-level/ evidence binding for 'g = error "blah"'. - We must have an EvBindsVar those bindings!, otherwise they end up as - top-level unlifted bindings, which are verboten. This only matters - at top level, so we check for that - See also Note [Deferred errors for coercion holes] in TcErrors. - cf #14149 for an example of what goes wrong. - -* If you have - f :: Int; f = f_blah - g :: Bool; g = g_blah - If we don't build an implication for f or g (no tyvars, no givens), - the constraints for f_blah and g_blah are solved together. And that - can yield /very/ confusing error messages, because we can get - [W] C Int b1 -- from f_blah - [W] C Int b2 -- from g_blan - and fundpes can yield [D] b1 ~ b2, even though the two functions have - literally nothing to do with each other. #14185 is an example. - Building an implication keeps them separage. --} - -{- -************************************************************************ -* * - Boxy unification -* * -************************************************************************ - -The exported functions are all defined as versions of some -non-exported generic functions. --} - -unifyType :: Maybe (HsExpr GhcRn) -- ^ If present, has type 'ty1' - -> TcTauType -> TcTauType -> TcM TcCoercionN --- Actual and expected types --- Returns a coercion : ty1 ~ ty2 -unifyType thing ty1 ty2 = traceTc "utype" (ppr ty1 $$ ppr ty2 $$ ppr thing) >> - uType TypeLevel origin ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 - , uo_thing = ppr <$> thing - , uo_visible = True } -- always called from a visible context - -unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN -unifyKind thing ty1 ty2 = traceTc "ukind" (ppr ty1 $$ ppr ty2 $$ ppr thing) >> - uType KindLevel origin ty1 ty2 - where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 - , uo_thing = ppr <$> thing - , uo_visible = True } -- also always from a visible context - ---------------- - -{- -%************************************************************************ -%* * - uType and friends -%* * -%************************************************************************ - -uType is the heart of the unifier. --} - -uType, uType_defer - :: TypeOrKind - -> CtOrigin - -> TcType -- ty1 is the *actual* type - -> TcType -- ty2 is the *expected* type - -> TcM CoercionN - --------------- --- It is always safe to defer unification to the main constraint solver --- See Note [Deferred unification] -uType_defer t_or_k origin ty1 ty2 - = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2 - - -- Error trace only - -- NB. do *not* call mkErrInfo unless tracing is on, - -- because it is hugely expensive (#5631) - ; whenDOptM Opt_D_dump_tc_trace $ do - { ctxt <- getErrCtxt - ; doc <- mkErrInfo emptyTidyEnv ctxt - ; traceTc "utype_defer" (vcat [ debugPprType ty1 - , debugPprType ty2 - , pprCtOrigin origin - , doc]) - ; traceTc "utype_defer2" (ppr co) - } - ; return co } - --------------- -uType t_or_k origin orig_ty1 orig_ty2 - = do { tclvl <- getTcLevel - ; traceTc "u_tys" $ vcat - [ text "tclvl" <+> ppr tclvl - , sep [ ppr orig_ty1, text "~", ppr orig_ty2] - , pprCtOrigin origin] - ; co <- go orig_ty1 orig_ty2 - ; if isReflCo co - then traceTc "u_tys yields no coercion" Outputable.empty - else traceTc "u_tys yields coercion:" (ppr co) - ; return co } - where - go :: TcType -> TcType -> TcM CoercionN - -- The arguments to 'go' are always semantically identical - -- to orig_ty{1,2} except for looking through type synonyms - - -- Unwrap casts before looking for variables. This way, we can easily - -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we - -- didn't do it this way, and then the unification above was deferred. - go (CastTy t1 co1) t2 - = do { co_tys <- uType t_or_k origin t1 t2 - ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) } - - go t1 (CastTy t2 co2) - = do { co_tys <- uType t_or_k origin t1 t2 - ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) } - - -- Variables; go for uUnfilledVar - -- Note that we pass in *original* (before synonym expansion), - -- so that type variables tend to get filled in with - -- the most informative version of the type - go (TyVarTy tv1) ty2 - = do { lookup_res <- lookupTcTyVar tv1 - ; case lookup_res of - Filled ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1) - ; go ty1 ty2 } - Unfilled _ -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 } - go ty1 (TyVarTy tv2) - = do { lookup_res <- lookupTcTyVar tv2 - ; case lookup_res of - Filled ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2) - ; go ty1 ty2 } - Unfilled _ -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 } - - -- See Note [Expanding synonyms during unification] - go ty1@(TyConApp tc1 []) (TyConApp tc2 []) - | tc1 == tc2 - = return $ mkNomReflCo ty1 - - -- See Note [Expanding synonyms during unification] - -- - -- Also NB that we recurse to 'go' so that we don't push a - -- new item on the origin stack. As a result if we have - -- type Foo = Int - -- and we try to unify Foo ~ Bool - -- we'll end up saying "can't match Foo with Bool" - -- rather than "can't match "Int with Bool". See #4535. - go ty1 ty2 - | Just ty1' <- tcView ty1 = go ty1' ty2 - | Just ty2' <- tcView ty2 = go ty1 ty2' - - -- Functions (or predicate functions) just check the two parts - go (FunTy _ fun1 arg1) (FunTy _ fun2 arg2) - = do { co_l <- uType t_or_k origin fun1 fun2 - ; co_r <- uType t_or_k origin arg1 arg2 - ; return $ mkFunCo Nominal co_l co_r } - - -- Always defer if a type synonym family (type function) - -- is involved. (Data families behave rigidly.) - go ty1@(TyConApp tc1 _) ty2 - | isTypeFamilyTyCon tc1 = defer ty1 ty2 - go ty1 ty2@(TyConApp tc2 _) - | isTypeFamilyTyCon tc2 = defer ty1 ty2 - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - -- See Note [Mismatched type lists and application decomposition] - | tc1 == tc2, equalLength tys1 tys2 - = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 ) - do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2 - ; return $ mkTyConAppCo Nominal tc1 cos } - where - origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin) - (tcTyConVisibilities tc1) - - go (LitTy m) ty@(LitTy n) - | m == n - = return $ mkNomReflCo ty - - -- See Note [Care with type applications] - -- Do not decompose FunTy against App; - -- it's often a type error, so leave it for the constraint solver - go (AppTy s1 t1) (AppTy s2 t2) - = go_app (isNextArgVisible s1) s1 t1 s2 t2 - - go (AppTy s1 t1) (TyConApp tc2 ts2) - | Just (ts2', t2') <- snocView ts2 - = ASSERT( not (mustBeSaturated tc2) ) - go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2' - - go (TyConApp tc1 ts1) (AppTy s2 t2) - | Just (ts1', t1') <- snocView ts1 - = ASSERT( not (mustBeSaturated tc1) ) - go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2 - - go (CoercionTy co1) (CoercionTy co2) - = do { let ty1 = coercionType co1 - ty2 = coercionType co2 - ; kco <- uType KindLevel - (KindEqOrigin orig_ty1 (Just orig_ty2) origin - (Just t_or_k)) - ty1 ty2 - ; return $ mkProofIrrelCo Nominal kco co1 co2 } - - -- Anything else fails - -- E.g. unifying for-all types, which is relative unusual - go ty1 ty2 = defer ty1 ty2 - - ------------------ - defer ty1 ty2 -- See Note [Check for equality before deferring] - | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1) - | otherwise = uType_defer t_or_k origin ty1 ty2 - - ------------------ - go_app vis s1 t1 s2 t2 - = do { co_s <- uType t_or_k origin s1 s2 - ; let arg_origin - | vis = origin - | otherwise = toInvisibleOrigin origin - ; co_t <- uType t_or_k arg_origin t1 t2 - ; return $ mkAppCo co_s co_t } - -{- Note [Check for equality before deferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Particularly in ambiguity checks we can get equalities like (ty ~ ty). -If ty involves a type function we may defer, which isn't very sensible. -An egregious example of this was in test T9872a, which has a type signature - Proxy :: Proxy (Solutions Cubes) -Doing the ambiguity check on this signature generates the equality - Solutions Cubes ~ Solutions Cubes -and currently the constraint solver normalises both sides at vast cost. -This little short-cut in 'defer' helps quite a bit. - -Note [Care with type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note: type 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, -so if one type is an App the other one jolly well better be too - -Note [Mismatched type lists and application decomposition] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we find two TyConApps, you might think that the argument lists -are guaranteed equal length. But they aren't. Consider matching - w (T x) ~ Foo (T x y) -We do match (w ~ Foo) first, but in some circumstances we simply create -a deferred constraint; and then go ahead and match (T x ~ T x y). -This came up in #3950. - -So either - (a) either we must check for identical argument kinds - when decomposing applications, - - (b) or we must be prepared for ill-kinded unification sub-problems - -Currently we adopt (b) since it seems more robust -- no need to maintain -a global invariant. - -Note [Expanding synonyms during unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We expand synonyms during unification, but: - * We expand *after* the variable case so that we tend to unify - variables with un-expanded type synonym. This just makes it - more likely that the inferred types will mention type synonyms - understandable to the user - - * Similarly, we expand *after* the CastTy case, just in case the - CastTy wraps a variable. - - * We expand *before* the TyConApp case. For example, if we have - type Phantom a = Int - and are unifying - Phantom Int ~ Phantom Char - it is *wrong* to unify Int and Char. - - * The problem case immediately above can happen only with arguments - to the tycon. So we check for nullary tycons *before* expanding. - This is particularly helpful when checking (* ~ *), because * is - now a type synonym. - -Note [Deferred Unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically, -and yet its consistency is undetermined. Previously, there was no way to still -make it consistent. So a mismatch error was issued. - -Now these unifications are deferred until constraint simplification, where type -family instances and given equations may (or may not) establish the consistency. -Deferred unifications are of the form - F ... ~ ... -or x ~ ... -where F is a type function and x is a type variable. -E.g. - id :: x ~ y => x -> y - id e = e - -involves the unification x = y. It is deferred until we bring into account the -context x ~ y to establish that it holds. - -If available, we defer original types (rather than those where closed type -synonyms have already been expanded via tcCoreView). This is, as usual, to -improve error messages. - - -************************************************************************ -* * - uUnfilledVar and friends -* * -************************************************************************ - -@uunfilledVar@ is called when at least one of the types being unified is a -variable. It does {\em not} assume that the variable is a fixed point -of the substitution; rather, notice that @uVar@ (defined below) nips -back into @uTys@ if it turns out that the variable is already bound. --} - ----------- -uUnfilledVar :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2 - -> TcM Coercion --- "Unfilled" means that the variable is definitely not a filled-in meta tyvar --- It might be a skolem, or untouchable, or meta - -uUnfilledVar origin t_or_k swapped tv1 ty2 - = do { ty2 <- zonkTcType ty2 - -- Zonk to expose things to the - -- occurs check, and so that if ty2 - -- looks like a type variable then it - -- /is/ a type variable - ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 } - ----------- -uUnfilledVar1 :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2, zonked - -> TcM Coercion -uUnfilledVar1 origin t_or_k swapped tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 - = go tv2 - - | otherwise - = uUnfilledVar2 origin t_or_k swapped tv1 ty2 - - where - -- 'go' handles the case where both are - -- tyvars so we might want to swap - -- E.g. maybe tv2 is a meta-tyvar and tv1 is not - go tv2 | tv1 == tv2 -- Same type variable => no-op - = return (mkNomReflCo (mkTyVarTy tv1)) - - | swapOverTyVars tv1 tv2 -- Distinct type variables - -- Swap meta tyvar to the left if poss - = do { tv1 <- zonkTyCoVarKind tv1 - -- We must zonk tv1's kind because that might - -- not have happened yet, and it's an invariant of - -- uUnfilledTyVar2 that ty2 is fully zonked - -- Omitting this caused #16902 - ; uUnfilledVar2 origin t_or_k (flipSwap swapped) - tv2 (mkTyVarTy tv1) } - - | otherwise - = uUnfilledVar2 origin t_or_k swapped tv1 ty2 - ----------- -uUnfilledVar2 :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2, zonked - -> TcM Coercion -uUnfilledVar2 origin t_or_k swapped tv1 ty2 - = do { dflags <- getDynFlags - ; cur_lvl <- getTcLevel - ; go dflags cur_lvl } - where - go dflags cur_lvl - | canSolveByUnification cur_lvl tv1 ty2 - , MTVU_OK ty2' <- metaTyVarUpdateOK dflags tv1 ty2 - = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1) - ; traceTc "uUnfilledVar2 ok" $ - vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) - , ppr ty2 <+> dcolon <+> ppr (tcTypeKind ty2) - , ppr (isTcReflCo co_k), ppr co_k ] - - ; if isTcReflCo co_k - -- Only proceed if the kinds match - -- NB: tv1 should still be unfilled, despite the kind unification - -- because tv1 is not free in ty2 (or, hence, in its kind) - then do { writeMetaTyVar tv1 ty2' - ; return (mkTcNomReflCo ty2') } - - else defer } -- This cannot be solved now. See TcCanonical - -- Note [Equalities with incompatible kinds] - - | otherwise - = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2) - -- Occurs check or an untouchable: just defer - -- NB: occurs check isn't necessarily fatal: - -- eg tv1 occurred in type family parameter - ; defer } - - ty1 = mkTyVarTy tv1 - kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k) - - defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2 - -swapOverTyVars :: TcTyVar -> TcTyVar -> Bool -swapOverTyVars tv1 tv2 - -- Level comparison: see Note [TyVar/TyVar orientation] - | lvl1 `strictlyDeeperThan` lvl2 = False - | lvl2 `strictlyDeeperThan` lvl1 = True - - -- Priority: see Note [TyVar/TyVar orientation] - | pri1 > pri2 = False - | pri2 > pri1 = True - - -- Names: see Note [TyVar/TyVar orientation] - | isSystemName tv2_name, not (isSystemName tv1_name) = True - - | otherwise = False - - where - lvl1 = tcTyVarLevel tv1 - lvl2 = tcTyVarLevel tv2 - pri1 = lhsPriority tv1 - pri2 = lhsPriority tv2 - tv1_name = Var.varName tv1 - tv2_name = Var.varName tv2 - - -lhsPriority :: TcTyVar -> Int --- Higher => more important to be on the LHS --- See Note [TyVar/TyVar orientation] -lhsPriority tv - = ASSERT2( isTyVar tv, ppr tv) - case tcTyVarDetails tv of - RuntimeUnk -> 0 - SkolemTv {} -> 0 - MetaTv { mtv_info = info } -> case info of - FlatSkolTv -> 1 - TyVarTv -> 2 - TauTv -> 3 - FlatMetaTv -> 4 -{- Note [TyVar/TyVar orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)? -This is a surprisingly tricky question! This is invariant (TyEq:TV). - -The question is answered by swapOverTyVars, which is use - - in the eager unifier, in TcUnify.uUnfilledVar1 - - in the constraint solver, in TcCanonical.canEqTyVarHomo - -First note: only swap if you have to! - See Note [Avoid unnecessary swaps] - -So we look for a positive reason to swap, using a three-step test: - -* Level comparison. If 'a' has deeper level than 'b', - put 'a' on the left. See Note [Deeper level on the left] - -* Priority. If the levels are the same, look at what kind of - type variable it is, using 'lhsPriority'. - - Generally speaking we always try to put a MetaTv on the left - in preference to SkolemTv or RuntimeUnkTv: - a) Because the MetaTv may be touchable and can be unified - b) Even if it's not touchable, TcSimplify.floatEqualities - looks for meta tyvars on the left - - Tie-breaking rules for MetaTvs: - - FlatMetaTv = 4: always put on the left. - See Note [Fmv Orientation Invariant] - - NB: FlatMetaTvs always have the current level, never an - outer one. So nothing can be deeper than a FlatMetaTv. - - - TauTv = 3: if we have tyv_tv ~ tau_tv, - put tau_tv on the left because there are fewer - restrictions on updating TauTvs. Or to say it another - way, then we won't lose the TyVarTv flag - - - TyVarTv = 2: remember, flat-skols are *only* updated by - the unflattener, never unified, so TyVarTvs come next - - - FlatSkolTv = 1: put on the left in preference to a SkolemTv. - See Note [Eliminate flat-skols] - -* Names. If the level and priority comparisons are all - equal, try to eliminate a TyVars with a System Name in - favour of ones with a Name derived from a user type signature - -* Age. At one point in the past we tried to break any remaining - ties by eliminating the younger type variable, based on their - Uniques. See Note [Eliminate younger unification variables] - (which also explains why we don't do this any more) - -Note [Deeper level on the left] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The most important thing is that we want to put tyvars with -the deepest level on the left. The reason to do so differs for -Wanteds and Givens, but either way, deepest wins! Simple. - -* Wanteds. Putting the deepest variable on the left maximise the - chances that it's a touchable meta-tyvar which can be solved. - -* Givens. Suppose we have something like - forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2] - - If we orient the Given a[2] on the left, we'll rewrite the Wanted to - (beta[1] ~ b[1]), and that can float out of the implication. - Otherwise it can't. By putting the deepest variable on the left - we maximise our changes of eliminating skolem capture. - - See also TcSMonad Note [Let-bound skolems] for another reason - to orient with the deepest skolem on the left. - - IMPORTANT NOTE: this test does a level-number comparison on - skolems, so it's important that skolems have (accurate) level - numbers. - -See #15009 for an further analysis of why "deepest on the left" -is a good plan. - -Note [Fmv Orientation Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * We always orient a constraint - fmv ~ alpha - with fmv on the left, even if alpha is - a touchable unification variable - -Reason: doing it the other way round would unify alpha:=fmv, but that -really doesn't add any info to alpha. But a later constraint alpha ~ -Int might unlock everything. Comment:9 of #12526 gives a detailed -example. - -WARNING: I've gone to and fro on this one several times. -I'm now pretty sure that unifying alpha:=fmv is a bad idea! -So orienting with fmvs on the left is a good thing. - -This example comes from IndTypesPerfMerge. (Others include -T10226, T10009.) - From the ambiguity check for - f :: (F a ~ a) => a - we get: - [G] F a ~ a - [WD] F alpha ~ alpha, alpha ~ a - - From Givens we get - [G] F a ~ fsk, fsk ~ a - - Now if we flatten we get - [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a - - Now, if we unified alpha := fmv, we'd get - [WD] F fmv ~ fmv, [WD] fmv ~ a - And now we are stuck. - -So instead the Fmv Orientation Invariant puts the fmv on the -left, giving - [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a - - Now we get alpha:=a, and everything works out - -Note [Eliminate flat-skols] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have [G] Num (F [a]) -then we flatten to - [G] Num fsk - [G] F [a] ~ fsk -where fsk is a flatten-skolem (FlatSkolTv). Suppose we have - type instance F [a] = a -then we'll reduce the second constraint to - [G] a ~ fsk -and then replace all uses of 'a' with fsk. That's bad because -in error messages instead of saying 'a' we'll say (F [a]). In all -places, including those where the programmer wrote 'a' in the first -place. Very confusing! See #7862. - -Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate -the fsk. - -Note [Avoid unnecessary swaps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we swap without actually improving matters, we can get an infinite loop. -Consider - work item: a ~ b - inert item: b ~ c -We canonicalise the work-item to (a ~ c). If we then swap it before -adding to the inert set, we'll add (c ~ a), and therefore kick out the -inert guy, so we get - new work item: b ~ c - inert item: c ~ a -And now the cycle just repeats - -Note [Eliminate younger unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a choice of unifying - alpha := beta or beta := alpha -we try, if possible, to eliminate the "younger" one, as determined -by `ltUnique`. Reason: the younger one is less likely to appear free in -an existing inert constraint, and hence we are less likely to be forced -into kicking out and rewriting inert constraints. - -This is a performance optimisation only. It turns out to fix -#14723 all by itself, but clearly not reliably so! - -It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars). -But, to my surprise, it didn't seem to make any significant difference -to the compiler's performance, so I didn't take it any further. Still -it seemed to too nice to discard altogether, so I'm leaving these -notes. SLPJ Jan 18. --} - --- @trySpontaneousSolve wi@ solves equalities where one side is a --- touchable unification variable. --- Returns True <=> spontaneous solve happened -canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool -canSolveByUnification tclvl tv xi - | isTouchableMetaTyVar tclvl tv - = case metaTyVarInfo tv of - TyVarTv -> is_tyvar xi - _ -> True - - | otherwise -- Untouchable - = False - where - is_tyvar xi - = case tcGetTyVar_maybe xi of - Nothing -> False - Just tv -> case tcTyVarDetails tv of - MetaTv { mtv_info = info } - -> case info of - TyVarTv -> True - _ -> False - SkolemTv {} -> True - RuntimeUnk -> True - -{- Note [Prevent unification with type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We prevent unification with type families because of an uneasy compromise. -It's perfectly sound to unify with type families, and it even improves the -error messages in the testsuite. It also modestly improves performance, at -least in some cases. But it's disastrous for test case perf/compiler/T3064. -Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a. -What do we do? Do we reduce F? Or do we use the given? Hard to know what's -best. GHC reduces. This is a disaster for T3064, where the type's size -spirals out of control during reduction. (We're not helped by the fact that -the flattener re-flattens all the arguments every time around.) If we prevent -unification with type families, then the solver happens to use the equality -before expanding the type family. - -It would be lovely in the future to revisit this problem and remove this -extra, unnecessary check. But we retain it for now as it seems to work -better in practice. - -Note [Refactoring hazard: checkTauTvUpdate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I (Richard E.) have a sad story about refactoring this code, retained here -to prevent others (or a future me!) from falling into the same traps. - -It all started with #11407, which was caused by the fact that the TyVarTy -case of defer_me didn't look in the kind. But it seemed reasonable to -simply remove the defer_me check instead. - -It referred to two Notes (since removed) that were out of date, and the -fast_check code in occurCheckExpand seemed to do just about the same thing as -defer_me. The one piece that defer_me did that wasn't repeated by -occurCheckExpand was the type-family check. (See Note [Prevent unification -with type families].) So I checked the result of occurCheckExpand for any -type family occurrences and deferred if there were any. This was done -in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 . - -This approach turned out not to be performant, because the expanded -type was bigger than the original type, and tyConsOfType (needed to -see if there are any type family occurrences) looks through type -synonyms. So it then struck me that we could dispense with the -defer_me check entirely. This simplified the code nicely, and it cut -the allocations in T5030 by half. But, as documented in Note [Prevent -unification with type families], this destroyed performance in -T3064. Regardless, I missed this regression and the change was -committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d . - -Bottom lines: - * defer_me is back, but now fixed w.r.t. #11407. - * Tread carefully before you start to refactor here. There can be - lots of hard-to-predict consequences. - -Note [Type synonyms and the occur check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking we try to update a variable with type synonyms not -expanded, which improves later error messages, unless looking -inside a type synonym may help resolve a spurious occurs check -error. Consider: - type A a = () - - f :: (A a -> a -> ()) -> () - f = \ _ -> () - - x :: () - x = f (\ x p -> p x) - -We will eventually get a constraint of the form t ~ A t. The ok function above will -properly expand the type (A t) to just (), which is ok to be unified with t. If we had -unified with the original type A t, we would lead the type checker into an infinite loop. - -Hence, if the occurs check fails for a type synonym application, then (and *only* then), -the ok function expands the synonym to detect opportunities for occurs check success using -the underlying definition of the type synonym. - -The same applies later on in the constraint interaction code; see TcInteract, -function @occ_check_ok@. - -Note [Non-TcTyVars in TcUnify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because the same code is now shared between unifying types and unifying -kinds, we sometimes will see proper TyVars floating around the unifier. -Example (from test case polykinds/PolyKinds12): - - type family Apply (f :: k1 -> k2) (x :: k1) :: k2 - type instance Apply g y = g y - -When checking the instance declaration, we first *kind-check* the LHS -and RHS, discovering that the instance really should be - - type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y - -During this kind-checking, all the tyvars will be TcTyVars. Then, however, -as a second pass, we desugar the RHS (which is done in functions prefixed -with "tc" in TcTyClsDecls"). By this time, all the kind-vars are proper -TyVars, not TcTyVars, get some kind unification must happen. - -Thus, we always check if a TyVar is a TcTyVar before asking if it's a -meta-tyvar. - -This used to not be necessary for type-checking (that is, before * :: *) -because expressions get desugared via an algorithm separate from -type-checking (with wrappers, etc.). Types get desugared very differently, -causing this wibble in behavior seen here. --} - -data LookupTyVarResult -- The result of a lookupTcTyVar call - = Unfilled TcTyVarDetails -- SkolemTv or virgin MetaTv - | Filled TcType - -lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult -lookupTcTyVar tyvar - | MetaTv { mtv_ref = ref } <- details - = do { meta_details <- readMutVar ref - ; case meta_details of - Indirect ty -> return (Filled ty) - Flexi -> do { is_touchable <- isTouchableTcM tyvar - -- Note [Unifying untouchables] - ; if is_touchable then - return (Unfilled details) - else - return (Unfilled vanillaSkolemTv) } } - | otherwise - = return (Unfilled details) - where - details = tcTyVarDetails tyvar - -{- -Note [Unifying untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat an untouchable type variable as if it was a skolem. That -ensures it won't unify with anything. It's a slight hack, because -we return a made-up TcTyVarDetails, but I think it works smoothly. --} - --- | Breaks apart a function kind into its pieces. -matchExpectedFunKind - :: Outputable fun - => fun -- ^ type, only for errors - -> Arity -- ^ n: number of desired arrows - -> TcKind -- ^ fun_ kind - -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res) - -matchExpectedFunKind hs_ty n k = go n k - where - go 0 k = return (mkNomReflCo k) - - go n k | Just k' <- tcView k = go n k' - - go n k@(TyVarTy kvar) - | isMetaTyVar kvar - = do { maybe_kind <- readMetaTyVar kvar - ; case maybe_kind of - Indirect fun_kind -> go n fun_kind - Flexi -> defer n k } - - go n (FunTy _ arg res) - = do { co <- go (n-1) res - ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) } - - go n other - = defer n other - - defer n k - = do { arg_kinds <- newMetaKindVars n - ; res_kind <- newMetaKindVar - ; let new_fun = mkVisFunTys arg_kinds res_kind - origin = TypeEqOrigin { uo_actual = k - , uo_expected = new_fun - , uo_thing = Just (ppr hs_ty) - , uo_visible = True - } - ; uType KindLevel origin k new_fun } - -{- ********************************************************************* -* * - Occurrence checking -* * -********************************************************************* -} - - -{- Note [Occurrence checking: look inside kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are considering unifying - (alpha :: *) ~ Int -> (beta :: alpha -> alpha) -This may be an error (what is that alpha doing inside beta's kind?), -but we must not make the mistake of actually unifying or we'll -build an infinite data structure. So when looking for occurrences -of alpha in the rhs, we must look in the kinds of type variables -that occur there. - -NB: we may be able to remove the problem via expansion; see - Note [Occurs check expansion]. So we have to try that. - -Note [Checking for foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unless we have -XImpredicativeTypes (which is a totally unsupported -feature), we do not want to unify - alpha ~ (forall a. a->a) -> Int -So we look for foralls hidden inside the type, and it's convenient -to do that at the same time as the occurs check (which looks for -occurrences of alpha). - -However, it's not just a question of looking for foralls /anywhere/! -Consider - (alpha :: forall k. k->*) ~ (beta :: forall k. k->*) -This is legal; e.g. dependent/should_compile/T11635. - -We don't want to reject it because of the forall in beta's kind, -but (see Note [Occurrence checking: look inside kinds]) we do -need to look in beta's kind. So we carry a flag saying if a 'forall' -is OK, and switch the flag on when stepping inside a kind. - -Why is it OK? Why does it not count as impredicative polymorphism? -The reason foralls are bad is because we reply on "seeing" foralls -when doing implicit instantiation. But the forall inside the kind is -fine. We'll generate a kind equality constraint - (forall k. k->*) ~ (forall k. k->*) -to check that the kinds of lhs and rhs are compatible. If alpha's -kind had instead been - (alpha :: kappa) -then this kind equality would rightly complain about unifying kappa -with (forall k. k->*) - --} - -data MetaTyVarUpdateResult a - = MTVU_OK a - | MTVU_Bad -- Forall, predicate, or type family - | MTVU_HoleBlocker -- Blocking coercion hole - -- See Note [Equalities with incompatible kinds] in TcCanonical - | MTVU_Occurs - deriving (Functor) - -instance Applicative MetaTyVarUpdateResult where - pure = MTVU_OK - (<*>) = ap - -instance Monad MetaTyVarUpdateResult where - MTVU_OK x >>= k = k x - MTVU_Bad >>= _ = MTVU_Bad - MTVU_HoleBlocker >>= _ = MTVU_HoleBlocker - MTVU_Occurs >>= _ = MTVU_Occurs - -instance Outputable a => Outputable (MetaTyVarUpdateResult a) where - ppr (MTVU_OK a) = text "MTVU_OK" <+> ppr a - ppr MTVU_Bad = text "MTVU_Bad" - ppr MTVU_HoleBlocker = text "MTVU_HoleBlocker" - ppr MTVU_Occurs = text "MTVU_Occurs" - -occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult () --- Just for error-message generation; so we return MetaTyVarUpdateResult --- so the caller can report the right kind of error --- Check whether --- a) the given variable occurs in the given type. --- b) there is a forall in the type (unless we have -XImpredicativeTypes) -occCheckForErrors dflags tv ty - = case preCheck dflags True tv ty of - MTVU_OK _ -> MTVU_OK () - MTVU_Bad -> MTVU_Bad - MTVU_HoleBlocker -> MTVU_HoleBlocker - MTVU_Occurs -> case occCheckExpand [tv] ty of - Nothing -> MTVU_Occurs - Just _ -> MTVU_OK () - ----------------- -metaTyVarUpdateOK :: DynFlags - -> TcTyVar -- tv :: k1 - -> TcType -- ty :: k2 - -> MetaTyVarUpdateResult TcType -- possibly-expanded ty --- (metaTyVarUpdateOK tv ty) --- We are about to update the meta-tyvar tv with ty --- Check (a) that tv doesn't occur in ty (occurs check) --- (b) that ty does not have any foralls --- (in the impredicative case), or type functions --- (c) that ty does not have any blocking coercion holes --- See Note [Equalities with incompatible kinds] in TcCanonical --- --- We have two possible outcomes: --- (1) Return the type to update the type variable with, --- [we know the update is ok] --- (2) Return Nothing, --- [the update might be dodgy] --- --- Note that "Nothing" does not mean "definite error". For example --- type family F a --- type instance F Int = Int --- consider --- a ~ F a --- This is perfectly reasonable, if we later get a ~ Int. For now, though, --- we return Nothing, leaving it to the later constraint simplifier to --- sort matters out. --- --- See Note [Refactoring hazard: checkTauTvUpdate] - -metaTyVarUpdateOK dflags tv ty - = case preCheck dflags False tv ty of - -- False <=> type families not ok - -- See Note [Prevent unification with type families] - MTVU_OK _ -> MTVU_OK ty - MTVU_Bad -> MTVU_Bad -- forall, predicate, type function - MTVU_HoleBlocker -> MTVU_HoleBlocker -- coercion hole - MTVU_Occurs -> case occCheckExpand [tv] ty of - Just expanded_ty -> MTVU_OK expanded_ty - Nothing -> MTVU_Occurs - -preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult () --- A quick check for --- (a) a forall type (unless -XImpredicativeTypes) --- (b) a predicate type (unless -XImpredicativeTypes) --- (c) a type family --- (d) a blocking coercion hole --- (e) an occurrence of the type variable (occurs check) --- --- For (a), (b), and (c) we check only the top level of the type, NOT --- inside the kinds of variables it mentions. For (d) we look deeply --- in coercions, and for (e) we do look in the kinds of course. - -preCheck dflags ty_fam_ok tv ty - = fast_check ty - where - details = tcTyVarDetails tv - impredicative_ok = canUnifyWithPolyType dflags details - - ok :: MetaTyVarUpdateResult () - ok = MTVU_OK () - - fast_check :: TcType -> MetaTyVarUpdateResult () - fast_check (TyVarTy tv') - | tv == tv' = MTVU_Occurs - | otherwise = fast_check_occ (tyVarKind tv') - -- See Note [Occurrence checking: look inside kinds] - - fast_check (TyConApp tc tys) - | bad_tc tc = MTVU_Bad - | otherwise = mapM fast_check tys >> ok - fast_check (LitTy {}) = ok - fast_check (FunTy{ft_af = af, ft_arg = a, ft_res = r}) - | InvisArg <- af - , not impredicative_ok = MTVU_Bad - | otherwise = fast_check a >> fast_check r - fast_check (AppTy fun arg) = fast_check fun >> fast_check arg - fast_check (CastTy ty co) = fast_check ty >> fast_check_co co - fast_check (CoercionTy co) = fast_check_co co - fast_check (ForAllTy (Bndr tv' _) ty) - | not impredicative_ok = MTVU_Bad - | tv == tv' = ok - | otherwise = do { fast_check_occ (tyVarKind tv') - ; fast_check_occ ty } - -- Under a forall we look only for occurrences of - -- the type variable - - -- For kinds, we only do an occurs check; we do not worry - -- about type families or foralls - -- See Note [Checking for foralls] - fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs - | otherwise = ok - - -- no bother about impredicativity in coercions, as they're - -- inferred - fast_check_co co | not (gopt Opt_DeferTypeErrors dflags) - , badCoercionHoleCo co = MTVU_HoleBlocker - -- Wrinkle (4b) in TcCanonical Note [Equalities with incompatible kinds] - - | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs - | otherwise = ok - - bad_tc :: TyCon -> Bool - bad_tc tc - | not (impredicative_ok || isTauTyCon tc) = True - | not (ty_fam_ok || isFamFreeTyCon tc) = True - | otherwise = False - -canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool -canUnifyWithPolyType dflags details - = case details of - MetaTv { mtv_info = TyVarTv } -> False - MetaTv { mtv_info = TauTv } -> xopt LangExt.ImpredicativeTypes dflags - _other -> True - -- We can have non-meta tyvars in given constraints diff --git a/compiler/typecheck/TcUnify.hs-boot b/compiler/typecheck/TcUnify.hs-boot deleted file mode 100644 index 3b12153704..0000000000 --- a/compiler/typecheck/TcUnify.hs-boot +++ /dev/null @@ -1,15 +0,0 @@ -module TcUnify where - -import GhcPrelude -import TcType ( TcTauType ) -import TcRnTypes ( TcM ) -import TcEvidence ( TcCoercion ) -import GHC.Hs.Expr ( HsExpr ) -import GHC.Hs.Types ( HsType ) -import GHC.Hs.Extension ( GhcRn ) - --- This boot file exists only to tie the knot between --- TcUnify and Inst - -unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion -unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs deleted file mode 100644 index 289cf83225..0000000000 --- a/compiler/typecheck/TcValidity.hs +++ /dev/null @@ -1,2907 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, TupleSections, ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module TcValidity ( - Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, - checkValidTheta, - checkValidInstance, checkValidInstHead, validDerivPred, - checkTySynRhs, - checkValidCoAxiom, checkValidCoAxBranch, - checkValidTyFamEqn, checkConsistentFamInst, - badATErr, arityErr, - checkTyConTelescope, - allDistinctTyVars - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Maybes - --- friends: -import TcUnify ( tcSubType_NC ) -import TcSimplify ( simplifyAmbiguityCheck ) -import ClsInst ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import TcType hiding ( sizeType, sizeTypes ) -import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName ) -import PrelNames -import GHC.Core.Type -import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) ) -import GHC.Core.Coercion -import GHC.Core.Coercion.Axiom -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.Predicate -import TcOrigin - --- others: -import GHC.Iface.Type ( pprIfaceType, pprIfaceTypeApp ) -import GHC.CoreToIface ( toIfaceTyCon, toIfaceTcArgs, toIfaceType ) -import GHC.Hs -- HsType -import TcRnMonad -- TcType, amongst others -import TcEnv ( tcInitTidyEnv, tcInitOpenTidyEnv ) -import FunDeps -import GHC.Core.FamInstEnv - ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) ) -import FamInst -import GHC.Types.Name -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Var ( VarBndr(..), mkTyVar ) -import FV -import ErrUtils -import GHC.Driver.Session -import Util -import ListSetOps -import GHC.Types.SrcLoc -import Outputable -import GHC.Types.Unique ( mkAlphaTyVarUnique ) -import Bag ( emptyBag ) -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable -import Data.List ( (\\), nub ) -import qualified Data.List.NonEmpty as NE - -{- -************************************************************************ -* * - Checking for ambiguity -* * -************************************************************************ - -Note [The ambiguity check for type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -checkAmbiguity is a check on *user-supplied type signatures*. It is -*purely* there to report functions that cannot possibly be called. So for -example we want to reject: - f :: C a => Int -The idea is there can be no legal calls to 'f' because every call will -give rise to an ambiguous constraint. We could soundly omit the -ambiguity check on type signatures entirely, at the expense of -delaying ambiguity errors to call sites. Indeed, the flag --XAllowAmbiguousTypes switches off the ambiguity check. - -What about things like this: - class D a b | a -> b where .. - h :: D Int b => Int -The Int may well fix 'b' at the call site, so that signature should -not be rejected. Moreover, using *visible* fundeps is too -conservative. Consider - class X a b where ... - class D a b | a -> b where ... - instance D a b => X [a] b where... - h :: X a b => a -> a -Here h's type looks ambiguous in 'b', but here's a legal call: - ...(h [True])... -That gives rise to a (X [Bool] beta) constraint, and using the -instance means we need (D Bool beta) and that fixes 'beta' via D's -fundep! - -Behind all these special cases there is a simple guiding principle. -Consider - - f :: <type> - f = ...blah... - - g :: <type> - g = f - -You would think that the definition of g would surely typecheck! -After all f has exactly the same type, and g=f. But in fact f's type -is instantiated and the instantiated constraints are solved against -the originals, so in the case an ambiguous type it won't work. -Consider our earlier example f :: C a => Int. Then in g's definition, -we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a), -and fail. - -So in fact we use this as our *definition* of ambiguity. We use a -very similar test for *inferred* types, to ensure that they are -unambiguous. See Note [Impedance matching] in TcBinds. - -This test is very conveniently implemented by calling - tcSubType <type> <type> -This neatly takes account of the functional dependency stuff above, -and implicit parameter (see Note [Implicit parameters and ambiguity]). -And this is what checkAmbiguity does. - -What about this, though? - g :: C [a] => Int -Is every call to 'g' ambiguous? After all, we might have - instance C [a] where ... -at the call site. So maybe that type is ok! Indeed even f's -quintessentially ambiguous type might, just possibly be callable: -with -XFlexibleInstances we could have - instance C a where ... -and now a call could be legal after all! Well, we'll reject this -unless the instance is available *here*. - -Note [When to call checkAmbiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We call checkAmbiguity - (a) on user-specified type signatures - (b) in checkValidType - -Conncerning (b), you might wonder about nested foralls. What about - f :: forall b. (forall a. Eq a => b) -> b -The nested forall is ambiguous. Originally we called checkAmbiguity -in the forall case of check_type, but that had two bad consequences: - * We got two error messages about (Eq b) in a nested forall like this: - g :: forall a. Eq a => forall b. Eq b => a -> a - * If we try to check for ambiguity of a nested forall like - (forall a. Eq a => b), the implication constraint doesn't bind - all the skolems, which results in "No skolem info" in error - messages (see #10432). - -To avoid this, we call checkAmbiguity once, at the top, in checkValidType. -(I'm still a bit worried about unbound skolems when the type mentions -in-scope type variables.) - -In fact, because of the co/contra-variance implemented in tcSubType, -this *does* catch function f above. too. - -Concerning (a) the ambiguity check is only used for *user* types, not -for types coming from interface files. The latter can legitimately -have ambiguous types. Example - - class S a where s :: a -> (Int,Int) - instance S Char where s _ = (1,1) - f:: S a => [a] -> Int -> (Int,Int) - f (_::[a]) x = (a*x,b) - where (a,b) = s (undefined::a) - -Here the worker for f gets the type - fw :: forall a. S a => Int -> (# Int, Int #) - - -Note [Implicit parameters and ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Only a *class* predicate can give rise to ambiguity -An *implicit parameter* cannot. For example: - foo :: (?x :: [a]) => Int - foo = length ?x -is fine. The call site will supply a particular 'x' - -Furthermore, the type variables fixed by an implicit parameter -propagate to the others. E.g. - foo :: (Show a, ?x::[a]) => Int - foo = show (?x++?x) -The type of foo looks ambiguous. But it isn't, because at a call site -we might have - let ?x = 5::Int in foo -and all is well. In effect, implicit parameters are, well, parameters, -so we can take their type variables into account as part of the -"tau-tvs" stuff. This is done in the function 'FunDeps.grow'. --} - -checkAmbiguity :: UserTypeCtxt -> Type -> TcM () -checkAmbiguity ctxt ty - | wantAmbiguityCheck ctxt - = do { traceTc "Ambiguity check for" (ppr ty) - -- Solve the constraints eagerly because an ambiguous type - -- can cause a cascade of further errors. Since the free - -- tyvars are skolemised, we can safely use tcSimplifyTop - ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes - ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ - captureConstraints $ - tcSubType_NC ctxt ty ty - ; simplifyAmbiguityCheck ty wanted - - ; traceTc "Done ambiguity check for" (ppr ty) } - - | otherwise - = return () - where - mk_msg allow_ambiguous - = vcat [ text "In the ambiguity check for" <+> what - , ppUnless allow_ambiguous ambig_msg ] - ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes" - what | Just n <- isSigMaybe ctxt = quotes (ppr n) - | otherwise = pprUserTypeCtxt ctxt - -wantAmbiguityCheck :: UserTypeCtxt -> Bool -wantAmbiguityCheck ctxt - = case ctxt of -- See Note [When we don't check for ambiguity] - GhciCtxt {} -> False - TySynCtxt {} -> False - TypeAppCtxt -> False - StandaloneKindSigCtxt{} -> False - _ -> True - -checkUserTypeError :: Type -> TcM () --- Check to see if the type signature mentions "TypeError blah" --- anywhere in it, and fail if so. --- --- Very unsatisfactorily (#11144) we need to tidy the type --- because it may have come from an /inferred/ signature, not a --- user-supplied one. This is really only a half-baked fix; --- the other errors in checkValidType don't do tidying, and so --- may give bad error messages when given an inferred type. -checkUserTypeError = check - where - check ty - | Just msg <- userTypeError_maybe ty = fail_with msg - | Just (_,ts) <- splitTyConApp_maybe ty = mapM_ check ts - | Just (t1,t2) <- splitAppTy_maybe ty = check t1 >> check t2 - | Just (_,t1) <- splitForAllTy_maybe ty = check t1 - | otherwise = return () - - fail_with msg = do { env0 <- tcInitTidyEnv - ; let (env1, tidy_msg) = tidyOpenType env0 msg - ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) } - - -{- Note [When we don't check for ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a few places we do not want to check a user-specified type for ambiguity - -* GhciCtxt: Allow ambiguous types in GHCi's :kind command - E.g. type family T a :: * -- T :: forall k. k -> * - Then :k T should work in GHCi, not complain that - (T k) is ambiguous! - -* TySynCtxt: type T a b = C a b => blah - It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow - cure the ambiguity. So we defer the ambiguity check to the use site. - - There is also an implementation reason (#11608). In the RHS of - a type synonym we don't (currently) instantiate 'a' and 'b' with - TcTyVars before calling checkValidType, so we get assertion failures - from doing an ambiguity check on a type with TyVars in it. Fixing this - would not be hard, but let's wait till there's a reason. - -* TypeAppCtxt: visible type application - f @ty - No need to check ty for ambiguity - -* StandaloneKindSigCtxt: type T :: ksig - Kinds need a different ambiguity check than types, and the currently - implemented check is only good for types. See #14419, in particular - https://gitlab.haskell.org/ghc/ghc/issues/14419#note_160844 - -************************************************************************ -* * - Checking validity of a user-defined type -* * -************************************************************************ - -When dealing with a user-written type, we first translate it from an HsType -to a Type, performing kind checking, and then check various things that should -be true about it. We don't want to perform these checks at the same time -as the initial translation because (a) they are unnecessary for interface-file -types and (b) when checking a mutually recursive group of type and class decls, -we can't "look" at the tycons/classes yet. Also, the checks are rather -diverse, and used to really mess up the other code. - -One thing we check for is 'rank'. - - Rank 0: monotypes (no foralls) - Rank 1: foralls at the front only, Rank 0 inside - Rank 2: foralls at the front, Rank 1 on left of fn arrow, - - basic ::= tyvar | T basic ... basic - - r2 ::= forall tvs. cxt => r2a - r2a ::= r1 -> r2a | basic - r1 ::= forall tvs. cxt => r0 - r0 ::= r0 -> r0 | basic - -Another thing is to check that type synonyms are saturated. -This might not necessarily show up in kind checking. - type A i = i - data T k = MkT (k Int) - f :: T A -- BAD! --} - -checkValidType :: UserTypeCtxt -> Type -> TcM () --- Checks that a user-written type is valid for the given context --- Assumes argument is fully zonked --- Not used for instance decls; checkValidInstance instead -checkValidType ctxt ty - = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) - ; rankn_flag <- xoptM LangExt.RankNTypes - ; impred_flag <- xoptM LangExt.ImpredicativeTypes - ; let gen_rank :: Rank -> Rank - gen_rank r | rankn_flag = ArbitraryRank - | otherwise = r - - rank1 = gen_rank r1 - rank0 = gen_rank r0 - - r0 = rankZeroMonoType - r1 = LimitedRank True r0 - - rank - = case ctxt of - DefaultDeclCtxt-> MustBeMonoType - ResSigCtxt -> MustBeMonoType - PatSigCtxt -> rank0 - RuleSigCtxt _ -> rank1 - TySynCtxt _ -> rank0 - - ExprSigCtxt -> rank1 - KindSigCtxt -> rank1 - StandaloneKindSigCtxt{} -> rank1 - TypeAppCtxt | impred_flag -> ArbitraryRank - | otherwise -> tyConArgMonoType - -- Normally, ImpredicativeTypes is handled in check_arg_type, - -- but visible type applications don't go through there. - -- So we do this check here. - - FunSigCtxt {} -> rank1 - InfSigCtxt {} -> rank1 -- Inferred types should obey the - -- same rules as declared ones - - ConArgCtxt _ -> rank1 -- We are given the type of the entire - -- constructor, hence rank 1 - PatSynCtxt _ -> rank1 - - ForSigCtxt _ -> rank1 - SpecInstCtxt -> rank1 - ThBrackCtxt -> rank1 - GhciCtxt {} -> ArbitraryRank - - TyVarBndrKindCtxt _ -> rank0 - DataKindCtxt _ -> rank1 - TySynKindCtxt _ -> rank1 - TyFamResKindCtxt _ -> rank1 - - _ -> panic "checkValidType" - -- Can't happen; not used for *user* sigs - - ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) - ; expand <- initialExpandMode - ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt - , ve_rank = rank, ve_expand = expand } - - -- Check the internal validity of the type itself - -- Fail if bad things happen, else we misleading - -- (and more complicated) errors in checkAmbiguity - ; checkNoErrs $ - do { check_type ve ty - ; checkUserTypeError ty - ; traceTc "done ct" (ppr ty) } - - -- Check for ambiguous types. See Note [When to call checkAmbiguity] - -- NB: this will happen even for monotypes, but that should be cheap; - -- and there may be nested foralls for the subtype test to examine - ; checkAmbiguity ctxt ty - - ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) } - -checkValidMonoType :: Type -> TcM () --- Assumes argument is fully zonked -checkValidMonoType ty - = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) - ; expand <- initialExpandMode - ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = SigmaCtxt - , ve_rank = MustBeMonoType, ve_expand = expand } - ; check_type ve ty } - -checkTySynRhs :: UserTypeCtxt -> TcType -> TcM () -checkTySynRhs ctxt ty - | tcReturnsConstraintKind actual_kind - = do { ck <- xoptM LangExt.ConstraintKinds - ; if ck - then when (tcIsConstraintKind actual_kind) - (do { dflags <- getDynFlags - ; expand <- initialExpandMode - ; check_pred_ty emptyTidyEnv dflags ctxt expand ty }) - else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) } - - | otherwise - = return () - where - actual_kind = tcTypeKind ty - -{- -Note [Higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~ -Technically - Int -> forall a. a->a -is still a rank-1 type, but it's not Haskell 98 (#5957). So the -validity checker allow a forall after an arrow only if we allow it -before -- that is, with Rank2Types or RankNTypes --} - -data Rank = ArbitraryRank -- Any rank ok - - | LimitedRank -- Note [Higher rank types] - Bool -- Forall ok at top - Rank -- Use for function arguments - - | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype - - | MustBeMonoType -- Monotype regardless of flags - -instance Outputable Rank where - ppr ArbitraryRank = text "ArbitraryRank" - ppr (LimitedRank top_forall_ok r) - = text "LimitedRank" <+> ppr top_forall_ok - <+> parens (ppr r) - ppr (MonoType msg) = text "MonoType" <+> parens msg - ppr MustBeMonoType = text "MustBeMonoType" - -rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank -rankZeroMonoType = MonoType (text "Perhaps you intended to use RankNTypes") -tyConArgMonoType = MonoType (text "GHC doesn't yet support impredicative polymorphism") -synArgMonoType = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms") -constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype" - , text "Perhaps you intended to use QuantifiedConstraints" ]) - -funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result -funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) -funArgResRank other_rank = (other_rank, other_rank) - -forAllAllowed :: Rank -> Bool -forAllAllowed ArbitraryRank = True -forAllAllowed (LimitedRank forall_ok _) = forall_ok -forAllAllowed _ = False - -allConstraintsAllowed :: UserTypeCtxt -> Bool --- We don't allow arbitrary constraints in kinds -allConstraintsAllowed (TyVarBndrKindCtxt {}) = False -allConstraintsAllowed (DataKindCtxt {}) = False -allConstraintsAllowed (TySynKindCtxt {}) = False -allConstraintsAllowed (TyFamResKindCtxt {}) = False -allConstraintsAllowed (StandaloneKindSigCtxt {}) = False -allConstraintsAllowed _ = True - --- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the --- context for the type of a term, where visible, dependent quantification is --- currently disallowed. --- --- An example of something that is unambiguously the type of a term is the --- @forall a -> a -> a@ in @foo :: forall a -> a -> a@. On the other hand, the --- same type in @type family Foo :: forall a -> a -> a@ is unambiguously the --- kind of a type, not the type of a term, so it is permitted. --- --- For more examples, see --- @testsuite/tests/dependent/should_compile/T16326_Compile*.hs@ (for places --- where VDQ is permitted) and --- @testsuite/tests/dependent/should_fail/T16326_Fail*.hs@ (for places where --- VDQ is disallowed). -vdqAllowed :: UserTypeCtxt -> Bool --- Currently allowed in the kinds of types... -vdqAllowed (KindSigCtxt {}) = True -vdqAllowed (StandaloneKindSigCtxt {}) = True -vdqAllowed (TySynCtxt {}) = True -vdqAllowed (ThBrackCtxt {}) = True -vdqAllowed (GhciCtxt {}) = True -vdqAllowed (TyVarBndrKindCtxt {}) = True -vdqAllowed (DataKindCtxt {}) = True -vdqAllowed (TySynKindCtxt {}) = True -vdqAllowed (TyFamResKindCtxt {}) = True --- ...but not in the types of terms. -vdqAllowed (ConArgCtxt {}) = False - -- We could envision allowing VDQ in data constructor types so long as the - -- constructor is only ever used at the type level, but for now, GHC adopts - -- the stance that VDQ is never allowed in data constructor types. -vdqAllowed (FunSigCtxt {}) = False -vdqAllowed (InfSigCtxt {}) = False -vdqAllowed (ExprSigCtxt {}) = False -vdqAllowed (TypeAppCtxt {}) = False -vdqAllowed (PatSynCtxt {}) = False -vdqAllowed (PatSigCtxt {}) = False -vdqAllowed (RuleSigCtxt {}) = False -vdqAllowed (ResSigCtxt {}) = False -vdqAllowed (ForSigCtxt {}) = False -vdqAllowed (DefaultDeclCtxt {}) = False --- We count class constraints as "types of terms". All of the cases below deal --- with class constraints. -vdqAllowed (InstDeclCtxt {}) = False -vdqAllowed (SpecInstCtxt {}) = False -vdqAllowed (GenSigCtxt {}) = False -vdqAllowed (ClassSCCtxt {}) = False -vdqAllowed (SigmaCtxt {}) = False -vdqAllowed (DataTyCtxt {}) = False -vdqAllowed (DerivClauseCtxt {}) = False - -{- -Note [Correctness and performance of type synonym validity checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the type A arg1 arg2, where A is a type synonym. How should we check -this type for validity? We have three distinct choices, corresponding to the -three constructors of ExpandMode: - -1. Expand the application of A, and check the resulting type (`Expand`). -2. Don't expand the application of A. Only check the arguments (`NoExpand`). -3. Check the arguments *and* check the expanded type (`Both`). - -It's tempting to think that we could always just pick choice (3), but this -results in serious performance issues when checking a type like in the -signature for `f` below: - - type S = ... - f :: S (S (S (S (S (S ....(S Int)...)))) - -When checking the type of `f`, we'll check the outer `S` application with and -without expansion, and in *each* of those checks, we'll check the next `S` -application with and without expansion... the result is exponential blowup! So -clearly we don't want to use `Both` 100% of the time. - -On the other hand, neither is it correct to use exclusively `Expand` or -exclusively `NoExpand` 100% of the time: - -* If one always expands, then one can miss erroneous programs like the one in - the `tcfail129` test case: - - type Foo a = String -> Maybe a - type Bar m = m Int - blah = undefined :: Bar Foo - - If we expand `Bar Foo` immediately, we'll miss the fact that the `Foo` type - synonyms is unsaturated. -* If one never expands and only checks the arguments, then one can miss - erroneous programs like the one in #16059: - - type Foo b = Eq b => b - f :: forall b (a :: Foo b). Int - - The kind of `a` contains a constraint, which is illegal, but this will only - be caught if `Foo b` is expanded. - -Therefore, it's impossible to have these validity checks be simultaneously -correct and performant if one sticks exclusively to a single `ExpandMode`. In -that case, the solution is to vary the `ExpandMode`s! In more detail: - -1. When we start validity checking, we start with `Expand` if - LiberalTypeSynonyms is enabled (see Note [Liberal type synonyms] for why we - do this), and we start with `Both` otherwise. The `initialExpandMode` - function is responsible for this. -2. When expanding an application of a type synonym (in `check_syn_tc_app`), we - determine which things to check based on the current `ExpandMode` argument. - Importantly, if the current mode is `Both`, then we check the arguments in - `NoExpand` mode and check the expanded type in `Both` mode. - - Switching to `NoExpand` when checking the arguments is vital to avoid - exponential blowup. One consequence of this choice is that if you have - the following type synonym in one module (with RankNTypes enabled): - - {-# LANGUAGE RankNTypes #-} - module A where - type A = forall a. a - - And you define the following in a separate module *without* RankNTypes - enabled: - - module B where - - import A - - type Const a b = a - f :: Const Int A -> Int - - Then `f` will be accepted, even though `A` (which is technically a rank-n - type) appears in its type. We view this as an acceptable compromise, since - `A` never appears in the type of `f` post-expansion. If `A` _did_ appear in - a type post-expansion, such as in the following variant: - - g :: Const A A -> Int - - Then that would be rejected unless RankNTypes were enabled. --} - --- | When validity-checking an application of a type synonym, should we --- check the arguments, check the expanded type, or both? --- See Note [Correctness and performance of type synonym validity checking] -data ExpandMode - = Expand -- ^ Only check the expanded type. - | NoExpand -- ^ Only check the arguments. - | Both -- ^ Check both the arguments and the expanded type. - -instance Outputable ExpandMode where - ppr e = text $ case e of - Expand -> "Expand" - NoExpand -> "NoExpand" - Both -> "Both" - --- | If @LiberalTypeSynonyms@ is enabled, we start in 'Expand' mode for the --- reasons explained in @Note [Liberal type synonyms]@. Otherwise, we start --- in 'Both' mode. -initialExpandMode :: TcM ExpandMode -initialExpandMode = do - liberal_flag <- xoptM LangExt.LiberalTypeSynonyms - pure $ if liberal_flag then Expand else Both - --- | Information about a type being validity-checked. -data ValidityEnv = ValidityEnv - { ve_tidy_env :: TidyEnv - , ve_ctxt :: UserTypeCtxt - , ve_rank :: Rank - , ve_expand :: ExpandMode } - -instance Outputable ValidityEnv where - ppr (ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt - , ve_rank = rank, ve_expand = expand }) = - hang (text "ValidityEnv") - 2 (vcat [ text "ve_tidy_env" <+> ppr env - , text "ve_ctxt" <+> pprUserTypeCtxt ctxt - , text "ve_rank" <+> ppr rank - , text "ve_expand" <+> ppr expand ]) - ----------------------------------------- -check_type :: ValidityEnv -> Type -> TcM () --- The args say what the *type context* requires, independent --- of *flag* settings. You test the flag settings at usage sites. --- --- Rank is allowed rank for function args --- Rank 0 means no for-alls anywhere - -check_type _ (TyVarTy _) = return () - -check_type ve (AppTy ty1 ty2) - = do { check_type ve ty1 - ; check_arg_type False ve ty2 } - -check_type ve ty@(TyConApp tc tys) - | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc - = check_syn_tc_app ve ty tc tys - | isUnboxedTupleTyCon tc = check_ubx_tuple ve ty tys - | otherwise = mapM_ (check_arg_type False ve) tys - -check_type _ (LitTy {}) = return () - -check_type ve (CastTy ty _) = check_type ve ty - --- Check for rank-n types, such as (forall x. x -> x) or (Show x => x). --- --- Critically, this case must come *after* the case for TyConApp. --- See Note [Liberal type synonyms]. -check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt - , ve_rank = rank, ve_expand = expand }) ty - | not (null tvbs && null theta) - = do { traceTc "check_type" (ppr ty $$ ppr rank) - ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty) - -- Reject e.g. (Maybe (?x::Int => Int)), - -- with a decent error message - - ; checkConstraintsOK ve theta ty - -- Reject forall (a :: Eq b => b). blah - -- In a kind signature we don't allow constraints - - ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs - || vdqAllowed ctxt) - (illegalVDQTyErr env ty) - -- Reject visible, dependent quantification in the type of a - -- term (e.g., `f :: forall a -> a -> Maybe a`) - - ; check_valid_theta env' SigmaCtxt expand theta - -- Allow type T = ?x::Int => Int -> Int - -- but not type T = ?x::Int - - ; check_type (ve{ve_tidy_env = env'}) tau - -- Allow foralls to right of arrow - - ; checkEscapingKind env' tvbs' theta tau } - where - (tvbs, phi) = tcSplitForAllVarBndrs ty - (theta, tau) = tcSplitPhiTy phi - (env', tvbs') = tidyTyCoVarBinders env tvbs - -check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ arg_ty res_ty) - = do { check_type (ve{ve_rank = arg_rank}) arg_ty - ; check_type (ve{ve_rank = res_rank}) res_ty } - where - (arg_rank, res_rank) = funArgResRank rank - -check_type _ ty = pprPanic "check_type" (ppr ty) - ----------------------------------------- -check_syn_tc_app :: ValidityEnv - -> KindOrType -> TyCon -> [KindOrType] -> TcM () --- Used for type synonyms and type synonym families, --- which must be saturated, --- but not data families, which need not be saturated -check_syn_tc_app (ve@ValidityEnv{ ve_ctxt = ctxt, ve_expand = expand }) - ty tc tys - | tys `lengthAtLeast` tc_arity -- Saturated - -- Check that the synonym has enough args - -- This applies equally to open and closed synonyms - -- It's OK to have an *over-applied* type synonym - -- data Tree a b = ... - -- type Foo a = Tree [a] - -- f :: Foo a b -> ... - = case expand of - _ | isTypeFamilyTyCon tc - -> check_args_only expand - -- See Note [Correctness and performance of type synonym validity - -- checking] - Expand -> check_expansion_only expand - NoExpand -> check_args_only expand - Both -> check_args_only NoExpand *> check_expansion_only Both - - | GhciCtxt True <- ctxt -- Accept outermost under-saturated type synonym or - -- type family constructors in GHCi :kind commands. - -- See Note [Unsaturated type synonyms in GHCi] - = check_args_only expand - - | otherwise - = failWithTc (tyConArityErr tc tys) - where - tc_arity = tyConArity tc - - check_arg :: ExpandMode -> KindOrType -> TcM () - check_arg expand = - check_arg_type (isTypeSynonymTyCon tc) (ve{ve_expand = expand}) - - check_args_only, check_expansion_only :: ExpandMode -> TcM () - check_args_only expand = mapM_ (check_arg expand) tys - - check_expansion_only expand - = ASSERT2( isTypeSynonymTyCon tc, ppr tc ) - case tcView ty of - Just ty' -> let err_ctxt = text "In the expansion of type synonym" - <+> quotes (ppr tc) - in addErrCtxt err_ctxt $ - check_type (ve{ve_expand = expand}) ty' - Nothing -> pprPanic "check_syn_tc_app" (ppr ty) - -{- -Note [Unsaturated type synonyms in GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking, GHC disallows unsaturated uses of type synonyms or type -families. For instance, if one defines `type Const a b = a`, then GHC will not -permit using `Const` unless it is applied to (at least) two arguments. There is -an exception to this rule, however: GHCi's :kind command. For instance, it -is quite common to look up the kind of a type constructor like so: - - λ> :kind Const - Const :: j -> k -> j - λ> :kind Const Int - Const Int :: k -> Type - -Strictly speaking, the two uses of `Const` above are unsaturated, but this -is an extremely benign (and useful) example of unsaturation, so we allow it -here as a special case. - -That being said, we do not allow unsaturation carte blanche in GHCi. Otherwise, -this GHCi interaction would be possible: - - λ> newtype Fix f = MkFix (f (Fix f)) - λ> type Id a = a - λ> :kind Fix Id - Fix Id :: Type - -This is rather dodgy, so we move to disallow this. We only permit unsaturated -synonyms in GHCi if they are *top-level*—that is, if the synonym is the -outermost type being applied. This allows `Const` and `Const Int` in the -first example, but not `Fix Id` in the second example, as `Id` is not the -outermost type being applied (`Fix` is). - -We track this outermost property in the GhciCtxt constructor of UserTypeCtxt. -A field of True in GhciCtxt indicates that we're in an outermost position. Any -time we invoke `check_arg` to check the validity of an argument, we switch the -field to False. --} - ----------------------------------------- -check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM () -check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys - = do { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples - ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty) - - ; impred <- xoptM LangExt.ImpredicativeTypes - ; let rank' = if impred then ArbitraryRank else tyConArgMonoType - -- c.f. check_arg_type - -- However, args are allowed to be unlifted, or - -- more unboxed tuples, so can't use check_arg_ty - ; mapM_ (check_type (ve{ve_rank = rank'})) tys } - ----------------------------------------- -check_arg_type - :: Bool -- ^ Is this the argument to a type synonym? - -> ValidityEnv -> KindOrType -> TcM () --- The sort of type that can instantiate a type variable, --- or be the argument of a type constructor. --- Not an unboxed tuple, but now *can* be a forall (since impredicativity) --- Other unboxed types are very occasionally allowed as type --- arguments depending on the kind of the type constructor --- --- For example, we want to reject things like: --- --- instance Ord a => Ord (forall s. T s a) --- and --- g :: T s (forall b.b) --- --- NB: unboxed tuples can have polymorphic or unboxed args. --- This happens in the workers for functions returning --- product types with polymorphic components. --- But not in user code. --- Anyway, they are dealt with by a special case in check_tau_type - -check_arg_type _ _ (CoercionTy {}) = return () - -check_arg_type type_syn (ve@ValidityEnv{ve_ctxt = ctxt, ve_rank = rank}) ty - = do { impred <- xoptM LangExt.ImpredicativeTypes - ; let rank' = case rank of -- Predictive => must be monotype - -- Rank-n arguments to type synonyms are OK, provided - -- that LiberalTypeSynonyms is enabled. - _ | type_syn -> synArgMonoType - MustBeMonoType -> MustBeMonoType -- Monotype, regardless - _other | impred -> ArbitraryRank - | otherwise -> tyConArgMonoType - -- Make sure that MustBeMonoType is propagated, - -- so that we don't suggest -XImpredicativeTypes in - -- (Ord (forall a.a)) => a -> a - -- and so that if it Must be a monotype, we check that it is! - ctxt' :: UserTypeCtxt - ctxt' - | GhciCtxt _ <- ctxt = GhciCtxt False - -- When checking an argument, set the field of GhciCtxt to - -- False to indicate that we are no longer in an outermost - -- position (and thus unsaturated synonyms are no longer - -- allowed). - -- See Note [Unsaturated type synonyms in GHCi] - | otherwise = ctxt - - ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty } - ----------------------------------------- -forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc) -forAllTyErr env rank ty - = ( env - , vcat [ hang herald 2 (ppr_tidy env ty) - , suggestion ] ) - where - (tvs, _theta, _tau) = tcSplitSigmaTy ty - herald | null tvs = text "Illegal qualified type:" - | otherwise = text "Illegal polymorphic type:" - suggestion = case rank of - LimitedRank {} -> text "Perhaps you intended to use RankNTypes" - MonoType d -> d - _ -> Outputable.empty -- Polytype is always illegal - --- | Reject type variables that would escape their escape through a kind. --- See @Note [Type variables escaping through kinds]@. -checkEscapingKind :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> TcM () -checkEscapingKind env tvbs theta tau = - case occCheckExpand (binderVars tvbs) phi_kind of - -- Ensure that none of the tvs occur in the kind of the forall - -- /after/ expanding type synonyms. - -- See Note [Phantom type variables in kinds] in GHC.Core.Type - Nothing -> failWithTcM $ forAllEscapeErr env tvbs theta tau tau_kind - Just _ -> pure () - where - tau_kind = tcTypeKind tau - phi_kind | null theta = tau_kind - | otherwise = liftedTypeKind - -- If there are any constraints, the kind is *. (#11405) - -forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind - -> (TidyEnv, SDoc) -forAllEscapeErr env tvbs theta tau tau_kind - = ( env - , vcat [ hang (text "Quantified type's kind mentions quantified type variable") - 2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau))) - -- NB: Don't tidy this type since the tvbs were already tidied - -- previously, and re-tidying them will make the names of type - -- variables different from tau_kind. - , hang (text "where the body of the forall has this kind:") - 2 (quotes (ppr_tidy env tau_kind)) ] ) - -{- -Note [Type variables escaping through kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - - type family T (r :: RuntimeRep) :: TYPE r - foo :: forall r. T r - -Something smells funny about the type of `foo`. If you spell out the kind -explicitly, it becomes clearer from where the smell originates: - - foo :: ((forall r. T r) :: TYPE r) - -The type variable `r` appears in the result kind, which escapes the scope of -its binding site! This is not desirable, so we establish a validity check -(`checkEscapingKind`) to catch any type variables that might escape through -kinds in this way. --} - -ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -ubxArgTyErr env ty - = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:" - , ppr_tidy env ty ] - , text "Perhaps you intended to use UnboxedTuples" ] ) - -checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM () -checkConstraintsOK ve theta ty - | null theta = return () - | allConstraintsAllowed (ve_ctxt ve) = return () - | otherwise - = -- We are in a kind, where we allow only equality predicates - -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and #16263 - checkTcM (all isEqPred theta) $ - constraintTyErr (ve_tidy_env ve) ty - -constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -constraintTyErr env ty - = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty) - --- | Reject a use of visible, dependent quantification in the type of a term. -illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -illegalVDQTyErr env ty = - (env, vcat - [ hang (text "Illegal visible, dependent quantification" <+> - text "in the type of a term:") - 2 (ppr_tidy env ty) - , text "(GHC does not yet support this)" ] ) - -{- -Note [Liberal type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If -XLiberalTypeSynonyms is on, expand closed type synonyms *before* -doing validity checking. This allows us to instantiate a synonym defn -with a for-all type, or with a partially-applied type synonym. - e.g. type T a b = a - type S m = m () - f :: S (T Int) -Here, T is partially applied, so it's illegal in H98. But if you -expand S first, then T we get just - f :: Int -which is fine. - -IMPORTANT: suppose T is a type synonym. Then we must do validity -checking on an application (T ty1 ty2) - - *either* before expansion (i.e. check ty1, ty2) - *or* after expansion (i.e. expand T ty1 ty2, and then check) - BUT NOT BOTH - -If we do both, we get exponential behaviour!! - - data TIACons1 i r c = c i ::: r c - type TIACons2 t x = TIACons1 t (TIACons1 t x) - type TIACons3 t x = TIACons2 t (TIACons1 t x) - type TIACons4 t x = TIACons2 t (TIACons2 t x) - type TIACons7 t x = TIACons4 t (TIACons3 t x) - -The order in which you do validity checking is also somewhat delicate. Consider -the `check_type` function, which drives the validity checking for unsaturated -uses of type synonyms. There is a special case for rank-n types, such as -(forall x. x -> x) or (Show x => x), since those require at least one language -extension to use. It used to be the case that this case came before every other -case, but this can lead to bugs. Imagine you have this scenario (from #15954): - - type A a = Int - type B (a :: Type -> Type) = forall x. x -> x - type C = B A - -If the rank-n case came first, then in the process of checking for `forall`s -or contexts, we would expand away `B A` to `forall x. x -> x`. This is because -the functions that split apart `forall`s/contexts -(tcSplitForAllVarBndrs/tcSplitPhiTy) expand type synonyms! If `B A` is expanded -away to `forall x. x -> x` before the actually validity checks occur, we will -have completely obfuscated the fact that we had an unsaturated application of -the `A` type synonym. - -We have since learned from our mistakes and now put this rank-n case /after/ -the case for TyConApp, which ensures that an unsaturated `A` TyConApp will be -caught properly. But be careful! We can't make the rank-n case /last/ either, -as the FunTy case must came after the rank-n case. Otherwise, something like -(Eq a => Int) would be treated as a function type (FunTy), which just -wouldn't do. - -************************************************************************ -* * -\subsection{Checking a theta or source type} -* * -************************************************************************ - -Note [Implicit parameters in instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Implicit parameters _only_ allowed in type signatures; not in instance -decls, superclasses etc. The reason for not allowing implicit params in -instances is a bit subtle. If we allowed - instance (?x::Int, Eq a) => Foo [a] where ... -then when we saw - (e :: (?x::Int) => t) -it would be unclear how to discharge all the potential uses of the ?x -in e. For example, a constraint Foo [Int] might come out of e, and -applying the instance decl would show up two uses of ?x. #8912. --} - -checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () --- Assumes argument is fully zonked -checkValidTheta ctxt theta - = addErrCtxtM (checkThetaCtxt ctxt theta) $ - do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta) - ; expand <- initialExpandMode - ; check_valid_theta env ctxt expand theta } - -------------------------- -check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode - -> [PredType] -> TcM () -check_valid_theta _ _ _ [] - = return () -check_valid_theta env ctxt expand theta - = do { dflags <- getDynFlags - ; warnTcM (Reason Opt_WarnDuplicateConstraints) - (wopt Opt_WarnDuplicateConstraints dflags && notNull dups) - (dupPredWarn env dups) - ; traceTc "check_valid_theta" (ppr theta) - ; mapM_ (check_pred_ty env dflags ctxt expand) theta } - where - (_,dups) = removeDups nonDetCmpType theta - -- It's OK to use nonDetCmpType because dups only appears in the - -- warning - -------------------------- -{- Note [Validity checking for constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We look through constraint synonyms so that we can see the underlying -constraint(s). For example - type Foo = ?x::Int - instance Foo => C T -We should reject the instance because it has an implicit parameter in -the context. - -But we record, in 'under_syn', whether we have looked under a synonym -to avoid requiring language extensions at the use site. Main example -(#9838): - - {-# LANGUAGE ConstraintKinds #-} - module A where - type EqShow a = (Eq a, Show a) - - module B where - import A - foo :: EqShow a => a -> String - -We don't want to require ConstraintKinds in module B. --} - -check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode - -> PredType -> TcM () --- Check the validity of a predicate in a signature --- See Note [Validity checking for constraints] -check_pred_ty env dflags ctxt expand pred - = do { check_type ve pred - ; check_pred_help False env dflags ctxt pred } - where - rank | xopt LangExt.QuantifiedConstraints dflags - = ArbitraryRank - | otherwise - = constraintMonoType - - ve :: ValidityEnv - ve = ValidityEnv{ ve_tidy_env = env - , ve_ctxt = SigmaCtxt - , ve_rank = rank - , ve_expand = expand } - -check_pred_help :: Bool -- True <=> under a type synonym - -> TidyEnv - -> DynFlags -> UserTypeCtxt - -> PredType -> TcM () -check_pred_help under_syn env dflags ctxt pred - | Just pred' <- tcView pred -- Switch on under_syn when going under a - -- synonym (#9838, yuk) - = check_pred_help True env dflags ctxt pred' - - | otherwise -- A bit like classifyPredType, but not the same - -- E.g. we treat (~) like (~#); and we look inside tuples - = case classifyPredType pred of - ClassPred cls tys - | isCTupleClass cls -> check_tuple_pred under_syn env dflags ctxt pred tys - | otherwise -> check_class_pred env dflags ctxt pred cls tys - - EqPred _ _ _ -> pprPanic "check_pred_help" (ppr pred) - -- EqPreds, such as (t1 ~ #t2) or (t1 ~R# t2), don't even have kind Constraint - -- and should never appear before the '=>' of a type. Thus - -- f :: (a ~# b) => blah - -- is wrong. For user written signatures, it'll be rejected by kind-checking - -- well before we get to validity checking. For inferred types we are careful - -- to box such constraints in TcType.pickQuantifiablePreds, as described - -- in Note [Lift equality constraints when quantifying] in TcType - - ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head - IrredPred {} -> check_irred_pred under_syn env dflags ctxt pred - -check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM () -check_eq_pred env dflags pred - = -- Equational constraints are valid in all contexts if type - -- families are permitted - checkTcM (xopt LangExt.TypeFamilies dflags - || xopt LangExt.GADTs dflags) - (eqPredTyErr env pred) - -check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt - -> PredType -> ThetaType -> PredType -> TcM () -check_quant_pred env dflags ctxt pred theta head_pred - = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $ - do { -- Check the instance head - case classifyPredType head_pred of - -- SigmaCtxt tells checkValidInstHead that - -- this is the head of a quantified constraint - ClassPred cls tys -> do { checkValidInstHead SigmaCtxt cls tys - ; check_pred_help False env dflags ctxt head_pred } - -- need check_pred_help to do extra pred-only validity - -- checks, such as for (~). Otherwise, we get #17563 - -- NB: checks for the context are covered by the check_type - -- in check_pred_ty - IrredPred {} | hasTyVarHead head_pred - -> return () - _ -> failWithTcM (badQuantHeadErr env pred) - - -- Check for termination - ; unless (xopt LangExt.UndecidableInstances dflags) $ - checkInstTermination theta head_pred - } - -check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM () -check_tuple_pred under_syn env dflags ctxt pred ts - = do { -- See Note [ConstraintKinds in predicates] - checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags) - (predTupleErr env pred) - ; mapM_ (check_pred_help under_syn env dflags ctxt) ts } - -- This case will not normally be executed because without - -- -XConstraintKinds tuple types are only kind-checked as * - -check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM () -check_irred_pred under_syn env dflags ctxt pred - -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint - -- where X is a type function - = do { -- If it looks like (x t1 t2), require ConstraintKinds - -- see Note [ConstraintKinds in predicates] - -- But (X t1 t2) is always ok because we just require ConstraintKinds - -- at the definition site (#9838) - failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags) - && hasTyVarHead pred) - (predIrredErr env pred) - - -- Make sure it is OK to have an irred pred in this context - -- See Note [Irreducible predicates in superclasses] - ; failIfTcM (is_superclass ctxt - && not (xopt LangExt.UndecidableInstances dflags) - && has_tyfun_head pred) - (predSuperClassErr env pred) } - where - is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False } - has_tyfun_head ty - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isTypeFamilyTyCon tc - Nothing -> False - -{- Note [ConstraintKinds in predicates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Don't check for -XConstraintKinds under a type synonym, because that -was done at the type synonym definition site; see #9838 -e.g. module A where - type C a = (Eq a, Ix a) -- Needs -XConstraintKinds - module B where - import A - f :: C a => a -> a -- Does *not* need -XConstraintKinds - -Note [Irreducible predicates in superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Allowing type-family calls in class superclasses is somewhat dangerous -because we can write: - - type family Fooish x :: * -> Constraint - type instance Fooish () = Foo - class Fooish () a => Foo a where - -This will cause the constraint simplifier to loop because every time we canonicalise a -(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately -solved to add+canonicalise another (Foo a) constraint. -} - -------------------------- -check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt - -> PredType -> Class -> [TcType] -> TcM () -check_class_pred env dflags ctxt pred cls tys - | isEqPredClass cls -- (~) and (~~) are classified as classes, - -- but here we want to treat them as equalities - = check_eq_pred env dflags pred - - | isIPClass cls - = do { check_arity - ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) } - - | otherwise -- Includes Coercible - = do { check_arity - ; checkSimplifiableClassConstraint env dflags ctxt cls tys - ; checkTcM arg_tys_ok (predTyVarErr env pred) } - where - check_arity = checkTc (tys `lengthIs` classArity cls) - (tyConArityErr (classTyCon cls) tys) - - -- Check the arguments of a class constraint - flexible_contexts = xopt LangExt.FlexibleContexts dflags - undecidable_ok = xopt LangExt.UndecidableInstances dflags - arg_tys_ok = case ctxt of - SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine - InstDeclCtxt {} -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys - -- Further checks on head and theta - -- in checkInstTermination - _ -> checkValidClsArgs flexible_contexts cls tys - -checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt - -> Class -> [TcType] -> TcM () --- See Note [Simplifiable given constraints] -checkSimplifiableClassConstraint env dflags ctxt cls tys - | not (wopt Opt_WarnSimplifiableClassConstraints dflags) - = return () - | xopt LangExt.MonoLocalBinds dflags - = return () - - | DataTyCtxt {} <- ctxt -- Don't do this check for the "stupid theta" - = return () -- of a data type declaration - - | cls `hasKey` coercibleTyConKey - = return () -- Oddly, we treat (Coercible t1 t2) as unconditionally OK - -- matchGlobalInst will reply "yes" because we can reduce - -- (Coercible a b) to (a ~R# b) - - | otherwise - = do { result <- matchGlobalInst dflags False cls tys - ; case result of - OneInst { cir_what = what } - -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints) - (simplifiable_constraint_warn what) - _ -> return () } - where - pred = mkClassPred cls tys - - simplifiable_constraint_warn :: InstanceWhat -> SDoc - simplifiable_constraint_warn what - = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred)) - <+> text "matches") - 2 (ppr what) - , hang (text "This makes type inference for inner bindings fragile;") - 2 (text "either use MonoLocalBinds, or simplify it using the instance") ] - -{- Note [Simplifiable given constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A type signature like - f :: Eq [(a,b)] => a -> b -is very fragile, for reasons described at length in TcInteract -Note [Instance and Given overlap]. As that Note discusses, for the -most part the clever stuff in TcInteract means that we don't use a -top-level instance if a local Given might fire, so there is no -fragility. But if we /infer/ the type of a local let-binding, things -can go wrong (#11948 is an example, discussed in the Note). - -So this warning is switched on only if we have NoMonoLocalBinds; in -that case the warning discourages users from writing simplifiable -class constraints. - -The warning only fires if the constraint in the signature -matches the top-level instances in only one way, and with no -unifiers -- that is, under the same circumstances that -TcInteract.matchInstEnv fires an interaction with the top -level instances. For example (#13526), consider - - instance {-# OVERLAPPABLE #-} Eq (T a) where ... - instance Eq (T Char) where .. - f :: Eq (T a) => ... - -We don't want to complain about this, even though the context -(Eq (T a)) matches an instance, because the user may be -deliberately deferring the choice so that the Eq (T Char) -has a chance to fire when 'f' is called. And the fragility -only matters when there's a risk that the instance might -fire instead of the local 'given'; and there is no such -risk in this case. Just use the same rules as for instance -firing! --} - -------------------------- -okIPCtxt :: UserTypeCtxt -> Bool - -- See Note [Implicit parameters in instance decls] -okIPCtxt (FunSigCtxt {}) = True -okIPCtxt (InfSigCtxt {}) = True -okIPCtxt ExprSigCtxt = True -okIPCtxt TypeAppCtxt = True -okIPCtxt PatSigCtxt = True -okIPCtxt ResSigCtxt = True -okIPCtxt GenSigCtxt = True -okIPCtxt (ConArgCtxt {}) = True -okIPCtxt (ForSigCtxt {}) = True -- ?? -okIPCtxt ThBrackCtxt = True -okIPCtxt (GhciCtxt {}) = True -okIPCtxt SigmaCtxt = True -okIPCtxt (DataTyCtxt {}) = True -okIPCtxt (PatSynCtxt {}) = True -okIPCtxt (TySynCtxt {}) = True -- e.g. type Blah = ?x::Int - -- #11466 - -okIPCtxt (KindSigCtxt {}) = False -okIPCtxt (StandaloneKindSigCtxt {}) = False -okIPCtxt (ClassSCCtxt {}) = False -okIPCtxt (InstDeclCtxt {}) = False -okIPCtxt (SpecInstCtxt {}) = False -okIPCtxt (RuleSigCtxt {}) = False -okIPCtxt DefaultDeclCtxt = False -okIPCtxt DerivClauseCtxt = False -okIPCtxt (TyVarBndrKindCtxt {}) = False -okIPCtxt (DataKindCtxt {}) = False -okIPCtxt (TySynKindCtxt {}) = False -okIPCtxt (TyFamResKindCtxt {}) = False - -{- -Note [Kind polymorphic type classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -MultiParam check: - - class C f where... -- C :: forall k. k -> Constraint - instance C Maybe where... - - The dictionary gets type [C * Maybe] even if it's not a MultiParam - type class. - -Flexibility check: - - class C f where... -- C :: forall k. k -> Constraint - data D a = D a - instance C D where - - The dictionary gets type [C * (D *)]. IA0_TODO it should be - generalized actually. --} - -checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc) -checkThetaCtxt ctxt theta env - = return ( env - , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta) - , text "While checking" <+> pprUserTypeCtxt ctxt ] ) - -eqPredTyErr, predTupleErr, predIrredErr, - predSuperClassErr, badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) -badQuantHeadErr env pred - = ( env - , hang (text "Quantified predicate must have a class or type variable head:") - 2 (ppr_tidy env pred) ) -eqPredTyErr env pred - = ( env - , text "Illegal equational constraint" <+> ppr_tidy env pred $$ - parens (text "Use GADTs or TypeFamilies to permit this") ) -predTupleErr env pred - = ( env - , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred) - 2 (parens constraintKindsMsg) ) -predIrredErr env pred - = ( env - , hang (text "Illegal constraint:" <+> ppr_tidy env pred) - 2 (parens constraintKindsMsg) ) -predSuperClassErr env pred - = ( env - , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred) - <+> text "in a superclass context") - 2 (parens undecidableMsg) ) - -predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) -predTyVarErr env pred - = (env - , vcat [ hang (text "Non type-variable argument") - 2 (text "in the constraint:" <+> ppr_tidy env pred) - , parens (text "Use FlexibleContexts to permit this") ]) - -badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc) -badIPPred env pred - = ( env - , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) ) - -constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -constraintSynErr env kind - = ( env - , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind)) - 2 (parens constraintKindsMsg) ) - -dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc) -dupPredWarn env dups - = ( env - , text "Duplicate constraint" <> plural primaryDups <> text ":" - <+> pprWithCommas (ppr_tidy env) primaryDups ) - where - primaryDups = map NE.head dups - -tyConArityErr :: TyCon -> [TcType] -> SDoc --- For type-constructor arity errors, be careful to report --- the number of /visible/ arguments required and supplied, --- ignoring the /invisible/ arguments, which the user does not see. --- (e.g. #10516) -tyConArityErr tc tks - = arityErr (ppr (tyConFlavour tc)) (tyConName tc) - tc_type_arity tc_type_args - where - vis_tks = filterOutInvisibleTypes tc tks - - -- tc_type_arity = number of *type* args expected - -- tc_type_args = number of *type* args encountered - tc_type_arity = count isVisibleTyConBinder (tyConBinders tc) - tc_type_args = length vis_tks - -arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc -arityErr what name n m - = hsep [ text "The" <+> what, quotes (ppr name), text "should have", - n_arguments <> comma, text "but has been given", - if m==0 then text "none" else int m] - where - n_arguments | n == 0 = text "no arguments" - | n == 1 = text "1 argument" - | True = hsep [int n, text "arguments"] - -{- -************************************************************************ -* * -\subsection{Checking for a decent instance head type} -* * -************************************************************************ - -@checkValidInstHead@ checks the type {\em and} its syntactic constraints: -it must normally look like: @instance Foo (Tycon a b c ...) ...@ - -The exceptions to this syntactic checking: (1)~if the @GlasgowExts@ -flag is on, or (2)~the instance is imported (they must have been -compiled elsewhere). In these cases, we let them go through anyway. - -We can also have instances for functions: @instance Foo (a -> b) ...@. --} - -checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () -checkValidInstHead ctxt clas cls_args - = do { dflags <- getDynFlags - ; is_boot <- tcIsHsBootOrSig - ; is_sig <- tcIsHsig - ; check_special_inst_head dflags is_boot is_sig ctxt clas cls_args - ; checkValidTypePats (classTyCon clas) cls_args - } - -{- - -Note [Instances of built-in classes in signature files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -User defined instances for KnownNat, KnownSymbol and Typeable are -disallowed -- they are generated when needed by GHC itself on-the-fly. - -However, if they occur in a Backpack signature file, they have an -entirely different meaning. Suppose in M.hsig we see - - signature M where - data T :: Nat - instance KnownNat T - -That says that any module satisfying M.hsig must provide a KnownNat -instance for T. We absolultely need that instance when compiling a -module that imports M.hsig: see #15379 and -Note [Fabricating Evidence for Literals in Backpack] in ClsInst. - -Hence, checkValidInstHead accepts a user-written instance declaration -in hsig files, where `is_sig` is True. - --} - -check_special_inst_head :: DynFlags -> Bool -> Bool - -> UserTypeCtxt -> Class -> [Type] -> TcM () --- Wow! There are a surprising number of ad-hoc special cases here. -check_special_inst_head dflags is_boot is_sig ctxt clas cls_args - - -- If not in an hs-boot file, abstract classes cannot have instances - | isAbstractClass clas - , not is_boot - = failWithTc abstract_class_msg - - -- For Typeable, don't complain about instances for - -- standalone deriving; they are no-ops, and we warn about - -- it in TcDeriv.deriveStandalone. - | clas_nm == typeableClassName - , not is_sig - -- Note [Instances of built-in classes in signature files] - , hand_written_bindings - = failWithTc rejected_class_msg - - -- Handwritten instances of KnownNat/KnownSymbol class - -- are always forbidden (#12837) - | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ] - , not is_sig - -- Note [Instances of built-in classes in signature files] - , hand_written_bindings - = failWithTc rejected_class_msg - - -- For the most part we don't allow - -- instances for (~), (~~), or Coercible; - -- but we DO want to allow them in quantified constraints: - -- f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m... - | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName ] - , not quantified_constraint - = failWithTc rejected_class_msg - - -- Check for hand-written Generic instances (disallowed in Safe Haskell) - | clas_nm `elem` genericClassNames - , hand_written_bindings - = do { failIfTc (safeLanguageOn dflags) gen_inst_err - ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } - - | clas_nm == hasFieldClassName - = checkHasFieldInst clas cls_args - - | isCTupleClass clas - = failWithTc tuple_class_msg - - -- Check language restrictions on the args to the class - | check_h98_arg_shape - , Just msg <- mb_ty_args_msg - = failWithTc (instTypeErr clas cls_args msg) - - | otherwise - = pure () - where - clas_nm = getName clas - ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args - - hand_written_bindings - = case ctxt of - InstDeclCtxt stand_alone -> not stand_alone - SpecInstCtxt -> False - DerivClauseCtxt -> False - _ -> True - - check_h98_arg_shape = case ctxt of - SpecInstCtxt -> False - DerivClauseCtxt -> False - SigmaCtxt -> False - _ -> True - -- SigmaCtxt: once we are in quantified-constraint land, we - -- aren't so picky about enforcing H98-language restrictions - -- E.g. we want to allow a head like Coercible (m a) (m b) - - - -- When we are looking at the head of a quantified constraint, - -- check_quant_pred sets ctxt to SigmaCtxt - quantified_constraint = case ctxt of - SigmaCtxt -> True - _ -> False - - head_type_synonym_msg = parens ( - text "All instance types must be of the form (T t1 ... tn)" $$ - text "where T is not a synonym." $$ - text "Use TypeSynonymInstances if you want to disable this.") - - head_type_args_tyvars_msg = parens (vcat [ - text "All instance types must be of the form (T a1 ... an)", - text "where a1 ... an are *distinct type variables*,", - text "and each type variable appears at most once in the instance head.", - text "Use FlexibleInstances if you want to disable this."]) - - head_one_type_msg = parens $ - text "Only one type can be given in an instance head." $$ - text "Use MultiParamTypeClasses if you want to allow more, or zero." - - rejected_class_msg = text "Class" <+> quotes (ppr clas_nm) - <+> text "does not support user-specified instances" - tuple_class_msg = text "You can't specify an instance for a tuple constraint" - - gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)") - - abstract_class_msg = text "Cannot define instance for abstract class" - <+> quotes (ppr clas_nm) - - mb_ty_args_msg - | not (xopt LangExt.TypeSynonymInstances dflags) - , not (all tcInstHeadTyNotSynonym ty_args) - = Just head_type_synonym_msg - - | not (xopt LangExt.FlexibleInstances dflags) - , not (all tcInstHeadTyAppAllTyVars ty_args) - = Just head_type_args_tyvars_msg - - | length ty_args /= 1 - , not (xopt LangExt.MultiParamTypeClasses dflags) - , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args) - = Just head_one_type_msg - - | otherwise - = Nothing - -tcInstHeadTyNotSynonym :: Type -> Bool --- Used in Haskell-98 mode, for the argument types of an instance head --- These must not be type synonyms, but everywhere else type synonyms --- are transparent, so we need a special function here -tcInstHeadTyNotSynonym ty - = case ty of -- Do not use splitTyConApp, - -- because that expands synonyms! - TyConApp tc _ -> not (isTypeSynonymTyCon tc) - _ -> True - -tcInstHeadTyAppAllTyVars :: Type -> Bool --- Used in Haskell-98 mode, for the argument types of an instance head --- These must be a constructor applied to type variable arguments --- or a type-level literal. --- But we allow kind instantiations. -tcInstHeadTyAppAllTyVars ty - | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty) - = ok (filterOutInvisibleTypes tc tys) -- avoid kinds - | LitTy _ <- ty = True -- accept type literals (#13833) - | otherwise - = False - where - -- Check that all the types are type variables, - -- and that each is distinct - ok tys = equalLength tvs tys && hasNoDups tvs - where - tvs = mapMaybe tcGetTyVar_maybe tys - -dropCasts :: Type -> Type --- See Note [Casts during validity checking] --- This function can turn a well-kinded type into an ill-kinded --- one, so I've kept it local to this module --- To consider: drop only HoleCo casts -dropCasts (CastTy ty _) = dropCasts ty -dropCasts (AppTy t1 t2) = mkAppTy (dropCasts t1) (dropCasts t2) -dropCasts ty@(FunTy _ t1 t2) = ty { ft_arg = dropCasts t1, ft_res = dropCasts t2 } -dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys) -dropCasts (ForAllTy b ty) = ForAllTy (dropCastsB b) (dropCasts ty) -dropCasts ty = ty -- LitTy, TyVarTy, CoercionTy - -dropCastsB :: TyVarBinder -> TyVarBinder -dropCastsB b = b -- Don't bother in the kind of a forall - -instTypeErr :: Class -> [Type] -> SDoc -> SDoc -instTypeErr cls tys msg - = hang (hang (text "Illegal instance declaration for") - 2 (quotes (pprClassPred cls tys))) - 2 msg - --- | See Note [Validity checking of HasField instances] -checkHasFieldInst :: Class -> [Type] -> TcM () -checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] = - case splitTyConApp_maybe r_ty of - Nothing -> whoops (text "Record data type must be specified") - Just (tc, _) - | isFamilyTyCon tc - -> whoops (text "Record data type may not be a data family") - | otherwise -> case isStrLitTy x_ty of - Just lbl - | isJust (lookupTyConFieldLabel lbl tc) - -> whoops (ppr tc <+> text "already has a field" - <+> quotes (ppr lbl)) - | otherwise -> return () - Nothing - | null (tyConFieldLabels tc) -> return () - | otherwise -> whoops (ppr tc <+> text "has fields") - where - whoops = addErrTc . instTypeErr cls tys -checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys) - -{- Note [Casts during validity checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the (bogus) - instance Eq Char# -We elaborate to 'Eq (Char# |> UnivCo(hole))' where the hole is an -insoluble equality constraint for * ~ #. We'll report the insoluble -constraint separately, but we don't want to *also* complain that Eq is -not applied to a type constructor. So we look gaily look through -CastTys here. - -Another example: Eq (Either a). Then we actually get a cast in -the middle: - Eq ((Either |> g) a) - - -Note [Validity checking of HasField instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The HasField class has magic constraint solving behaviour (see Note -[HasField instances] in TcInteract). However, we permit users to -declare their own instances, provided they do not clash with the -built-in behaviour. In particular, we forbid: - - 1. `HasField _ r _` where r is a variable - - 2. `HasField _ (T ...) _` if T is a data family - (because it might have fields introduced later) - - 3. `HasField x (T ...) _` where x is a variable, - if T has any fields at all - - 4. `HasField "foo" (T ...) _` if T has a "foo" field - -The usual functional dependency checks also apply. - - -Note [Valid 'deriving' predicate] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -validDerivPred checks for OK 'deriving' context. See Note [Exotic -derived instance contexts] in TcDeriv. However the predicate is -here because it uses sizeTypes, fvTypes. - -It checks for three things - - * No repeated variables (hasNoDups fvs) - - * No type constructors. This is done by comparing - sizeTypes tys == length (fvTypes tys) - sizeTypes counts variables and constructors; fvTypes returns variables. - So if they are the same, there must be no constructors. But there - might be applications thus (f (g x)). - - Note that tys only includes the visible arguments of the class type - constructor. Including the non-visible arguments can cause the following, - perfectly valid instance to be rejected: - class Category (cat :: k -> k -> *) where ... - newtype T (c :: * -> * -> *) a b = MkT (c a b) - instance Category c => Category (T c) where ... - since the first argument to Category is a non-visible *, which sizeTypes - would count as a constructor! See #11833. - - * Also check for a bizarre corner case, when the derived instance decl - would look like - instance C a b => D (T a) where ... - Note that 'b' isn't a parameter of T. This gives rise to all sorts of - problems; in particular, it's hard to compare solutions for equality - when finding the fixpoint, and that means the inferContext loop does - not converge. See #5287. - -Note [Equality class instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can't have users writing instances for the equality classes. But we -still need to be able to write instances for them ourselves. So we allow -instances only in the defining module. - --} - -validDerivPred :: TyVarSet -> PredType -> Bool --- See Note [Valid 'deriving' predicate] -validDerivPred tv_set pred - = case classifyPredType pred of - ClassPred cls tys -> cls `hasKey` typeableClassKey - -- Typeable constraints are bigger than they appear due - -- to kind polymorphism, but that's OK - || check_tys cls tys - EqPred {} -> False -- reject equality constraints - _ -> True -- Non-class predicates are ok - where - check_tys cls tys - = hasNoDups fvs - -- use sizePred to ignore implicit args - && lengthIs fvs (sizePred pred) - && all (`elemVarSet` tv_set) fvs - where tys' = filterOutInvisibleTypes (classTyCon cls) tys - fvs = fvTypes tys' - -{- -************************************************************************ -* * -\subsection{Checking instance for termination} -* * -************************************************************************ --} - -{- Note [Instances and constraint synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Currently, we don't allow instances for constraint synonyms at all. -Consider these (#13267): - type C1 a = Show (a -> Bool) - instance C1 Int where -- I1 - show _ = "ur" - -This elicits "show is not a (visible) method of class C1", which isn't -a great message. But it comes from the renamer, so it's hard to improve. - -This needs a bit more care: - type C2 a = (Show a, Show Int) - instance C2 Int -- I2 - -If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose -the instance head, we'll expand the synonym on fly, and it'll look like - instance (%,%) (Show Int, Show Int) -and we /really/ don't want that. So we carefully do /not/ expand -synonyms, by matching on TyConApp directly. --} - -checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () -checkValidInstance ctxt hs_type ty - | not is_tc_app - = failWithTc (hang (text "Instance head is not headed by a class:") - 2 ( ppr tau)) - - | isNothing mb_cls - = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc) - , text "A class instance must be for a class" ]) - - | not arity_ok - = failWithTc (text "Arity mis-match in instance head") - - | otherwise - = do { setSrcSpan head_loc $ - checkValidInstHead ctxt clas inst_tys - - ; traceTc "checkValidInstance {" (ppr ty) - - ; env0 <- tcInitTidyEnv - ; expand <- initialExpandMode - ; check_valid_theta env0 ctxt expand theta - - -- The Termination and Coverate Conditions - -- Check that instance inference will terminate (if we care) - -- For Haskell 98 this will already have been done by checkValidTheta, - -- but as we may be using other extensions we need to check. - -- - -- Note that the Termination Condition is *more conservative* than - -- the checkAmbiguity test we do on other type signatures - -- e.g. Bar a => Bar Int is ambiguous, but it also fails - -- the termination condition, because 'a' appears more often - -- in the constraint than in the head - ; undecidable_ok <- xoptM LangExt.UndecidableInstances - ; if undecidable_ok - then checkAmbiguity ctxt ty - else checkInstTermination theta tau - - ; traceTc "cvi 2" (ppr ty) - - ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of - IsValid -> return () -- Check succeeded - NotValid msg -> addErrTc (instTypeErr clas inst_tys msg) - - ; traceTc "End checkValidInstance }" empty - - ; return () } - where - (_tvs, theta, tau) = tcSplitSigmaTy ty - is_tc_app = case tau of { TyConApp {} -> True; _ -> False } - TyConApp tc inst_tys = tau -- See Note [Instances and constraint synonyms] - mb_cls = tyConClass_maybe tc - Just clas = mb_cls - arity_ok = inst_tys `lengthIs` classArity clas - - -- The location of the "head" of the instance - head_loc = getLoc (getLHsInstDeclHead hs_type) - -{- -Note [Paterson conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Termination test: the so-called "Paterson conditions" (see Section 5 of -"Understanding functional dependencies via Constraint Handling Rules, -JFP Jan 2007). - -We check that each assertion in the context satisfies: - (1) no variable has more occurrences in the assertion than in the head, and - (2) the assertion has fewer constructors and variables (taken together - and counting repetitions) than the head. -This is only needed with -fglasgow-exts, as Haskell 98 restrictions -(which have already been checked) guarantee termination. - -The underlying idea is that - - for any ground substitution, each assertion in the - context has fewer type constructors than the head. --} - -checkInstTermination :: ThetaType -> TcPredType -> TcM () --- See Note [Paterson conditions] -checkInstTermination theta head_pred - = check_preds emptyVarSet theta - where - head_fvs = fvType head_pred - head_size = sizeType head_pred - - check_preds :: VarSet -> [PredType] -> TcM () - check_preds foralld_tvs preds = mapM_ (check foralld_tvs) preds - - check :: VarSet -> PredType -> TcM () - check foralld_tvs pred - = case classifyPredType pred of - EqPred {} -> return () -- See #4200. - IrredPred {} -> check2 foralld_tvs pred (sizeType pred) - ClassPred cls tys - | isTerminatingClass cls - -> return () - - | isCTupleClass cls -- Look inside tuple predicates; #8359 - -> check_preds foralld_tvs tys - - | otherwise -- Other ClassPreds - -> check2 foralld_tvs pred bogus_size - where - bogus_size = 1 + sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys) - -- See Note [Invisible arguments and termination] - - ForAllPred tvs _ head_pred' - -> check (foralld_tvs `extendVarSetList` tvs) head_pred' - -- Termination of the quantified predicate itself is checked - -- when the predicates are individually checked for validity - - check2 foralld_tvs pred pred_size - | not (null bad_tvs) = failWithTc (noMoreMsg bad_tvs what (ppr head_pred)) - | not (isTyFamFree pred) = failWithTc (nestedMsg what) - | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred)) - | otherwise = return () - -- isTyFamFree: see Note [Type families in instance contexts] - where - what = text "constraint" <+> quotes (ppr pred) - bad_tvs = filterOut (`elemVarSet` foralld_tvs) (fvType pred) - \\ head_fvs - -smallerMsg :: SDoc -> SDoc -> SDoc -smallerMsg what inst_head - = vcat [ hang (text "The" <+> what) - 2 (sep [ text "is no smaller than" - , text "the instance head" <+> quotes inst_head ]) - , parens undecidableMsg ] - -noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc -noMoreMsg tvs what inst_head - = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1) - <+> occurs <+> text "more often") - 2 (sep [ text "in the" <+> what - , text "than in the instance head" <+> quotes inst_head ]) - , parens undecidableMsg ] - where - tvs1 = nub tvs - occurs = if isSingleton tvs1 then text "occurs" - else text "occur" - -undecidableMsg, constraintKindsMsg :: SDoc -undecidableMsg = text "Use UndecidableInstances to permit this" -constraintKindsMsg = text "Use ConstraintKinds to permit this" - -{- Note [Type families in instance contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Are these OK? - type family F a - instance F a => C (Maybe [a]) where ... - instance C (F a) => C [[[a]]] where ... - -No: the type family in the instance head might blow up to an -arbitrarily large type, depending on how 'a' is instantiated. -So we require UndecidableInstances if we have a type family -in the instance head. #15172. - -Note [Invisible arguments and termination] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When checking the Paterson conditions for termination an instance -declaration, we check for the number of "constructors and variables" -in the instance head and constraints. Question: Do we look at - - * All the arguments, visible or invisible? - * Just the visible arguments? - -I think both will ensure termination, provided we are consistent. -Currently we are /not/ consistent, which is really a bug. It's -described in #15177, which contains a number of examples. -The suspicious bits are the calls to filterOutInvisibleTypes. --} - - -{- -************************************************************************ -* * - Checking type instance well-formedness and termination -* * -************************************************************************ --} - -checkValidCoAxiom :: CoAxiom Branched -> TcM () -checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) - = do { mapM_ (checkValidCoAxBranch fam_tc) branch_list - ; foldlM_ check_branch_compat [] branch_list } - where - branch_list = fromBranches branches - injectivity = tyConInjectivityInfo fam_tc - - check_branch_compat :: [CoAxBranch] -- previous branches in reverse order - -> CoAxBranch -- current branch - -> TcM [CoAxBranch]-- current branch : previous branches - -- Check for - -- (a) this branch is dominated by previous ones - -- (b) failure of injectivity - check_branch_compat prev_branches cur_branch - | cur_branch `isDominatedBy` prev_branches - = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $ - inaccessibleCoAxBranch fam_tc cur_branch - ; return prev_branches } - | otherwise - = do { check_injectivity prev_branches cur_branch - ; return (cur_branch : prev_branches) } - - -- Injectivity check: check whether a new (CoAxBranch) can extend - -- already checked equations without violating injectivity - -- annotation supplied by the user. - -- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv - check_injectivity prev_branches cur_branch - | Injective inj <- injectivity - = do { dflags <- getDynFlags - ; let conflicts = - fst $ foldl' (gather_conflicts inj prev_branches cur_branch) - ([], 0) prev_branches - ; reportConflictingInjectivityErrs fam_tc conflicts cur_branch - ; reportInjectivityErrors dflags ax cur_branch inj } - | otherwise - = return () - - gather_conflicts inj prev_branches cur_branch (acc, n) branch - -- n is 0-based index of branch in prev_branches - = case injectiveBranches inj cur_branch branch of - -- Case 1B2 in Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv - InjectivityUnified ax1 ax2 - | ax1 `isDominatedBy` (replace_br prev_branches n ax2) - -> (acc, n + 1) - | otherwise - -> (branch : acc, n + 1) - InjectivityAccepted -> (acc, n + 1) - - -- Replace n-th element in the list. Assumes 0-based indexing. - replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch] - replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs - - --- Check that a "type instance" is well-formed (which includes decidability --- unless -XUndecidableInstances is given). --- -checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM () -checkValidCoAxBranch fam_tc - (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_lhs = typats - , cab_rhs = rhs, cab_loc = loc }) - = setSrcSpan loc $ - checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs - --- | Do validity checks on a type family equation, including consistency --- with any enclosing class instance head, termination, and lack of --- polytypes. -checkValidTyFamEqn :: TyCon -- ^ of the type family - -> [Var] -- ^ Bound variables in the equation - -> [Type] -- ^ Type patterns - -> Type -- ^ Rhs - -> TcM () -checkValidTyFamEqn fam_tc qvs typats rhs - = do { checkValidTypePats fam_tc typats - - -- Check for things used on the right but not bound on the left - ; checkFamPatBinders fam_tc qvs typats rhs - - -- Check for oversaturated visible kind arguments in a type family - -- equation. - -- See Note [Oversaturated type family equations] - ; when (isTypeFamilyTyCon fam_tc) $ - case drop (tyConArity fam_tc) typats of - [] -> pure () - spec_arg:_ -> - addErr $ text "Illegal oversaturated visible kind argument:" - <+> quotes (char '@' <> pprParendType spec_arg) - - -- The argument patterns, and RHS, are all boxed tau types - -- E.g Reject type family F (a :: k1) :: k2 - -- type instance F (forall a. a->a) = ... - -- type instance F Int# = ... - -- type instance F Int = forall a. a->a - -- type instance F Int = Int# - -- See #9357 - ; checkValidMonoType rhs - - -- We have a decidable instance unless otherwise permitted - ; undecidable_ok <- xoptM LangExt.UndecidableInstances - ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs)) - ; unless undecidable_ok $ - mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) } - --- Make sure that each type family application is --- (1) strictly smaller than the lhs, --- (2) mentions no type variable more often than the lhs, and --- (3) does not contain any further type family instances. --- -checkFamInstRhs :: TyCon -> [Type] -- LHS - -> [(TyCon, [Type])] -- type family calls in RHS - -> [MsgDoc] -checkFamInstRhs lhs_tc lhs_tys famInsts - = mapMaybe check famInsts - where - lhs_size = sizeTyConAppArgs lhs_tc lhs_tys - inst_head = pprType (TyConApp lhs_tc lhs_tys) - lhs_fvs = fvTypes lhs_tys - check (tc, tys) - | not (all isTyFamFree tys) = Just (nestedMsg what) - | not (null bad_tvs) = Just (noMoreMsg bad_tvs what inst_head) - | lhs_size <= fam_app_size = Just (smallerMsg what inst_head) - | otherwise = Nothing - where - what = text "type family application" - <+> quotes (pprType (TyConApp tc tys)) - fam_app_size = sizeTyConAppArgs tc tys - bad_tvs = fvTypes tys \\ lhs_fvs - -- The (\\) is list difference; e.g. - -- [a,b,a,a] \\ [a,a] = [b,a] - -- So we are counting repetitions - ------------------ -checkFamPatBinders :: TyCon - -> [TcTyVar] -- Bound on LHS of family instance - -> [TcType] -- LHS patterns - -> Type -- RHS - -> TcM () --- We do these binder checks now, in tcFamTyPatsAndGen, rather --- than later, in checkValidFamEqn, for two reasons: --- - We have the implicitly and explicitly --- bound type variables conveniently to hand --- - If implicit variables are out of scope it may --- cause a crash; notably in tcConDecl in tcDataFamInstDecl -checkFamPatBinders fam_tc qtvs pats rhs - = do { traceTc "checkFamPatBinders" $ - vcat [ debugPprType (mkTyConApp fam_tc pats) - , ppr (mkTyConApp fam_tc pats) - , text "qtvs:" <+> ppr qtvs - , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs) - , text "pat_tvs:" <+> ppr pat_tvs - , text "inj_pat_tvs:" <+> ppr inj_pat_tvs ] - - -- Check for implicitly-bound tyvars, mentioned on the - -- RHS but not bound on the LHS - -- data T = MkT (forall (a::k). blah) - -- data family D Int = MkD (forall (a::k). blah) - -- In both cases, 'k' is not bound on the LHS, but is used on the RHS - -- We catch the former in kcDeclHeader, and the latter right here - -- See Note [Check type-family instance binders] - ; check_tvs bad_rhs_tvs (text "mentioned in the RHS") - (text "bound on the LHS of") - - -- Check for explicitly forall'd variable that is not bound on LHS - -- data instance forall a. T Int = MkT Int - -- See Note [Unused explicitly bound variables in a family pattern] - -- See Note [Check type-family instance binders] - ; check_tvs bad_qtvs (text "bound by a forall") - (text "used in") - } - where - pat_tvs = tyCoVarsOfTypes pats - inj_pat_tvs = fvVarSet $ injectiveVarsOfTypes False pats - -- The type variables that are in injective positions. - -- See Note [Dodgy binding sites in type family instances] - -- NB: The False above is irrelevant, as we never have type families in - -- patterns. - -- - -- NB: It's OK to use the nondeterministic `fvVarSet` function here, - -- since the order of `inj_pat_tvs` is never revealed in an error - -- message. - rhs_fvs = tyCoFVsOfType rhs - used_tvs = pat_tvs `unionVarSet` fvVarSet rhs_fvs - bad_qtvs = filterOut (`elemVarSet` used_tvs) qtvs - -- Bound but not used at all - bad_rhs_tvs = filterOut (`elemVarSet` inj_pat_tvs) (fvVarList rhs_fvs) - -- Used on RHS but not bound on LHS - dodgy_tvs = pat_tvs `minusVarSet` inj_pat_tvs - - check_tvs tvs what what2 - = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ - hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs - <+> isOrAre tvs <+> what <> comma) - 2 (vcat [ text "but not" <+> what2 <+> text "the family instance" - , mk_extra tvs ]) - - -- mk_extra: #7536: give a decent error message for - -- type T a = Int - -- type instance F (T a) = a - mk_extra tvs = ppWhen (any (`elemVarSet` dodgy_tvs) tvs) $ - hang (text "The real LHS (expanding synonyms) is:") - 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats)) - - --- | Checks that a list of type patterns is valid in a matching (LHS) --- position of a class instances or type/data family instance. --- --- Specifically: --- * All monotypes --- * No type-family applications -checkValidTypePats :: TyCon -> [Type] -> TcM () -checkValidTypePats tc pat_ty_args - = do { -- Check that each of pat_ty_args is a monotype. - -- One could imagine generalising to allow - -- instance C (forall a. a->a) - -- but we don't know what all the consequences might be. - traverse_ checkValidMonoType pat_ty_args - - -- Ensure that no type family applications occur a type pattern - ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of - [] -> pure () - ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ - ty_fam_inst_illegal_err tf_is_invis_arg - (mkTyConApp tf_tc tf_args) } - where - inst_ty = mkTyConApp tc pat_ty_args - - ty_fam_inst_illegal_err :: Bool -> Type -> SDoc - ty_fam_inst_illegal_err invis_arg ty - = pprWithExplicitKindsWhen invis_arg $ - hang (text "Illegal type synonym family application" - <+> quotes (ppr ty) <+> text "in instance" <> colon) - 2 (ppr inst_ty) - --- Error messages - -inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc -inaccessibleCoAxBranch fam_tc cur_branch - = text "Type family instance equation is overlapped:" $$ - nest 2 (pprCoAxBranchUser fam_tc cur_branch) - -nestedMsg :: SDoc -> SDoc -nestedMsg what - = sep [ text "Illegal nested" <+> what - , parens undecidableMsg ] - -badATErr :: Name -> Name -> SDoc -badATErr clas op - = hsep [text "Class", quotes (ppr clas), - text "does not have an associated type", quotes (ppr op)] - - -------------------------- -checkConsistentFamInst :: AssocInstInfo - -> TyCon -- ^ Family tycon - -> CoAxBranch - -> TcM () --- See Note [Checking consistent instantiation] - -checkConsistentFamInst NotAssociated _ _ - = return () - -checkConsistentFamInst (InClsInst { ai_class = clas - , ai_tyvars = inst_tvs - , ai_inst_env = mini_env }) - fam_tc branch - = do { traceTc "checkConsistentFamInst" (vcat [ ppr inst_tvs - , ppr arg_triples - , ppr mini_env - , ppr ax_tvs - , ppr ax_arg_tys - , ppr arg_triples ]) - -- Check that the associated type indeed comes from this class - -- See [Mismatched class methods and associated type families] - -- in TcInstDecls. - ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc) - (badATErr (className clas) (tyConName fam_tc)) - - ; check_match arg_triples - } - where - (ax_tvs, ax_arg_tys, _) = etaExpandCoAxBranch branch - - arg_triples :: [(Type,Type, ArgFlag)] - arg_triples = [ (cls_arg_ty, at_arg_ty, vis) - | (fam_tc_tv, vis, at_arg_ty) - <- zip3 (tyConTyVars fam_tc) - (tyConArgFlags fam_tc ax_arg_tys) - ax_arg_tys - , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ] - - pp_wrong_at_arg vis - = pprWithExplicitKindsWhen (isInvisibleArgFlag vis) $ - vcat [ text "Type indexes must match class instance head" - , text "Expected:" <+> pp_expected_ty - , text " Actual:" <+> pp_actual_ty ] - - -- Fiddling around to arrange that wildcards unconditionally print as "_" - -- We only need to print the LHS, not the RHS at all - -- See Note [Printing conflicts with class header] - (tidy_env1, _) = tidyVarBndrs emptyTidyEnv inst_tvs - (tidy_env2, _) = tidyCoAxBndrsForUser tidy_env1 (ax_tvs \\ inst_tvs) - - pp_expected_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ - toIfaceTcArgs fam_tc $ - [ case lookupVarEnv mini_env at_tv of - Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty - Nothing -> mk_wildcard at_tv - | at_tv <- tyConTyVars fam_tc ] - - pp_actual_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ - toIfaceTcArgs fam_tc $ - tidyTypes tidy_env2 ax_arg_tys - - mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv)) - tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "_") noSrcSpan - - -- For check_match, bind_me, see - -- Note [Matching in the consistent-instantiation check] - check_match :: [(Type,Type,ArgFlag)] -> TcM () - check_match triples = go emptyTCvSubst emptyTCvSubst triples - - go _ _ [] = return () - go lr_subst rl_subst ((ty1,ty2,vis):triples) - | Just lr_subst1 <- tcMatchTyX_BM bind_me lr_subst ty1 ty2 - , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 - = go lr_subst1 rl_subst1 triples - | otherwise - = addErrTc (pp_wrong_at_arg vis) - - -- The /scoped/ type variables from the class-instance header - -- should not be alpha-renamed. Inferred ones can be. - no_bind_set = mkVarSet inst_tvs - bind_me tv | tv `elemVarSet` no_bind_set = Skolem - | otherwise = BindMe - - -{- Note [Check type-family instance binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a type family instance, we require (of course), type variables -used on the RHS are matched on the LHS. This is checked by -checkFamPatBinders. Here is an interesting example: - - type family T :: k - type instance T = (Nothing :: Maybe a) - -Upon a cursory glance, it may appear that the kind variable `a` is unbound -since there are no (visible) LHS patterns in `T`. However, there is an -*invisible* pattern due to the return kind, so inside of GHC, the instance -looks closer to this: - - type family T @k :: k - type instance T @(Maybe a) = (Nothing :: Maybe a) - -Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in -fact not unbound. Contrast that with this example (#13985) - - type instance T = Proxy (Nothing :: Maybe a) - -This would looks like this inside of GHC: - - type instance T @(*) = Proxy (Nothing :: Maybe a) - -So this time, `a` is neither bound by a visible nor invisible type pattern on -the LHS, so `a` would be reported as not in scope. - -Finally, here's one more brain-teaser (from #9574). In the example below: - - class Funct f where - type Codomain f :: * - instance Funct ('KProxy :: KProxy o) where - type Codomain 'KProxy = NatTr (Proxy :: o -> *) - -As it turns out, `o` is in scope in this example. That is because `o` is -bound by the kind signature of the LHS type pattern 'KProxy. To make this more -obvious, one can also write the instance like so: - - instance Funct ('KProxy :: KProxy o) where - type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *) - -Note [Dodgy binding sites in type family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example (from #7536): - - type T a = Int - type instance F (T a) = a - -This `F` instance is extremely fishy, since the RHS, `a`, purports to be -"bound" by the LHS pattern `T a`. "Bound" has scare quotes around it because -`T a` expands to `Int`, which doesn't mention at all, so it's as if one had -actually written: - - type instance F Int = a - -That is clearly bogus, so to reject this, we check that every type variable -that is mentioned on the RHS is /actually/ bound on the LHS. In other words, -we need to do something slightly more sophisticated that just compute the free -variables of the LHS patterns. - -It's tempting to just expand all type synonyms on the LHS and then compute -their free variables, but even that isn't sophisticated enough. After all, -an impish user could write the following (#17008): - - type family ConstType (a :: Type) :: Type where - ConstType _ = Type - - type family F (x :: ConstType a) :: Type where - F (x :: ConstType a) = a - -Just like in the previous example, the `a` on the RHS isn't actually bound -on the LHS, but this time a type family is responsible for the deception, not -a type synonym. - -We avoid both issues by requiring that all RHS type variables are mentioned -in injective positions on the left-hand side (by way of -`injectiveVarsOfTypes`). For instance, the `a` in `T a` is not in an injective -position, as `T` is not an injective type constructor, so we do not count that. -Similarly for the `a` in `ConstType a`. - -Note [Matching in the consistent-instantiation check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Matching the class-instance header to family-instance tyvars is -tricker than it sounds. Consider (#13972) - class C (a :: k) where - type T k :: Type - instance C Left where - type T (a -> Either a b) = Int - -Here there are no lexically-scoped variables from (C Left). -Yet the real class-instance header is C @(p -> Either @p @q)) (Left @p @q) -while the type-family instance is T (a -> Either @a @b) -So we allow alpha-renaming of variables that don't come -from the class-instance header. - -We track the lexically-scoped type variables from the -class-instance header in ai_tyvars. - -Here's another example (#14045a) - class C (a :: k) where - data S (a :: k) - instance C (z :: Bool) where - data S :: Bool -> Type where - -Again, there is no lexical connection, but we will get - class-instance header: C @Bool (z::Bool) - family instance S @Bool (a::Bool) - -When looking for mis-matches, we check left-to-right, -kinds first. If we look at types first, we'll fail to -suggest -fprint-explicit-kinds for a mis-match with - T @k vs T @Type -somewhere deep inside the type - -Note [Checking consistent instantiation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #11450 for background discussion on this check. - - class C a b where - type T a x b - -With this class decl, if we have an instance decl - instance C ty1 ty2 where ... -then the type instance must look like - type T ty1 v ty2 = ... -with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'. -For example: - - instance C [p] Int - type T [p] y Int = (p,y,y) - -Note that - -* We used to allow completely different bound variables in the - associated type instance; e.g. - instance C [p] Int - type T [q] y Int = ... - But from GHC 8.2 onwards, we don't. It's much simpler this way. - See #11450. - -* When the class variable isn't used on the RHS of the type instance, - it's tempting to allow wildcards, thus - instance C [p] Int - type T [_] y Int = (y,y) - But it's awkward to do the test, and it doesn't work if the - variable is repeated: - instance C (p,p) Int - type T (_,_) y Int = (y,y) - Even though 'p' is not used on the RHS, we still need to use 'p' - on the LHS to establish the repeated pattern. So to keep it simple - we just require equality. - -* For variables in associated type families that are not bound by the class - itself, we do _not_ check if they are over-specific. In other words, - it's perfectly acceptable to have an instance like this: - - instance C [p] Int where - type T [p] (Maybe x) Int = x - - While the first and third arguments to T are required to be exactly [p] and - Int, respectively, since they are bound by C, the second argument is allowed - to be more specific than just a type variable. Furthermore, it is permissible - to define multiple equations for T that differ only in the non-class-bound - argument: - - instance C [p] Int where - type T [p] (Maybe x) Int = x - type T [p] (Either x y) Int = x -> y - - We once considered requiring that non-class-bound variables in associated - type family instances be instantiated with distinct type variables. However, - that requirement proved too restrictive in practice, as there were examples - of extremely simple associated type family instances that this check would - reject, and fixing them required tiresome boilerplate in the form of - auxiliary type families. For instance, you would have to define the above - example as: - - instance C [p] Int where - type T [p] x Int = CAux x - - type family CAux x where - CAux (Maybe x) = x - CAux (Either x y) = x -> y - - We decided that this restriction wasn't buying us much, so we opted not - to pursue that design (see also GHC #13398). - -Implementation - * Form the mini-envt from the class type variables a,b - to the instance decl types [p],Int: [a->[p], b->Int] - - * Look at the tyvars a,x,b of the type family constructor T - (it shares tyvars with the class C) - - * Apply the mini-evnt to them, and check that the result is - consistent with the instance types [p] y Int. (where y can be any type, as - it is not scoped over the class type variables. - -We make all the instance type variables scope over the -type instances, of course, which picks up non-obvious kinds. Eg - class Foo (a :: k) where - type F a - instance Foo (b :: k -> k) where - type F b = Int -Here the instance is kind-indexed and really looks like - type F (k->k) (b::k->k) = Int -But if the 'b' didn't scope, we would make F's instance too -poly-kinded. - -Note [Printing conflicts with class header] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's remarkably painful to give a decent error message for conflicts -with the class header. Consider - clase C b where - type F a b c - instance C [b] where - type F x Int _ _ = ... - -Here we want to report a conflict between - Expected: F _ [b] _ - Actual: F x Int _ _ - -But if the type instance shadows the class variable like this -(rename/should_fail/T15828): - instance C [b] where - type forall b. F x (Tree b) _ _ = ... - -then we must use a fresh variable name - Expected: F _ [b] _ - Actual: F x [b1] _ _ - -Notice that: - - We want to print an underscore in the "Expected" type in - positions where the class header has no influence over the - parameter. Hence the fancy footwork in pp_expected_ty - - - Although the binders in the axiom are already tidy, we must - re-tidy them to get a fresh variable name when we shadow - - - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the - class-instance variables a second time, from 'a' to 'a1' say. - Remember, the ax_tvs of the axiom share identity with the - class-instance variables, inst_tvs.. - - - We use tidyCoAxBndrsForUser to get underscores rather than - _1, _2, etc in the axiom tyvars; see the definition of - tidyCoAxBndrsForUser - -This all seems absurdly complicated. - -Note [Unused explicitly bound variables in a family pattern] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Why is 'unusedExplicitForAllErr' not just a warning? - -Consider the following examples: - - type instance F a = Maybe b - type instance forall b. F a = Bool - type instance forall b. F a = Maybe b - -In every case, b is a type variable not determined by the LHS pattern. The -first is caught by the renamer, but we catch the last two here. Perhaps one -could argue that the second should be accepted, albeit with a warning, but -consider the fact that in a type family instance, there is no way to interact -with such a varable. At least with @x :: forall a. Int@ we can use visibile -type application, like @x \@Bool 1@. (Of course it does nothing, but it is -permissible.) In the type family case, the only sensible explanation is that -the user has made a mistake -- thus we throw an error. - -Note [Oversaturated type family equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type family tycons have very rigid arities. We want to reject something like -this: - - type family Foo :: Type -> Type where - Foo x = ... - -Because Foo has arity zero (i.e., it doesn't bind anything to the left of the -double colon), we want to disallow any equation for Foo that has more than zero -arguments, such as `Foo x = ...`. The algorithm here is pretty simple: if an -equation has more arguments than the arity of the type family, reject. - -Things get trickier when visible kind application enters the picture. Consider -the following example: - - type family Bar (x :: j) :: forall k. Either j k where - Bar 5 @Symbol = ... - -The arity of Bar is two, since it binds two variables, `j` and `x`. But even -though Bar's equation has two arguments, it's still invalid. Imagine the same -equation in Core: - - Bar Nat 5 Symbol = ... - -Here, it becomes apparent that Bar is actually taking /three/ arguments! So -we can't just rely on a simple counting argument to reject -`Bar 5 @Symbol = ...`, since it only has two user-written arguments. -Moreover, there's one explicit argument (5) and one visible kind argument -(@Symbol), which matches up perfectly with the fact that Bar has one required -binder (x) and one specified binder (j), so that's not a valid way to detect -oversaturation either. - -To solve this problem in a robust way, we do the following: - -1. When kind-checking, we count the number of user-written *required* - arguments and check if there is an equal number of required tycon binders. - If not, reject. (See `wrongNumberOfParmsErr` in TcTyClsDecls.) - - We perform this step during kind-checking, not during validity checking, - since we can give better error messages if we catch it early. -2. When validity checking, take all of the (Core) type patterns from on - equation, drop the first n of them (where n is the arity of the type family - tycon), and check if there are any types leftover. If so, reject. - - Why does this work? We know that after dropping the first n type patterns, - none of the leftover types can be required arguments, since step (1) would - have already caught that. Moreover, the only places where visible kind - applications should be allowed are in the first n types, since those are the - only arguments that can correspond to binding forms. Therefore, the - remaining arguments must correspond to oversaturated uses of visible kind - applications, which are precisely what we want to reject. - -Note that we only perform this check for type families, and not for data -families. This is because it is perfectly acceptable to oversaturate data -family instance equations: see Note [Arity of data families] in GHC.Core.FamInstEnv. - -************************************************************************ -* * - Telescope checking -* * -************************************************************************ - -Note [Bad TyCon telescopes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Now that we can mix type and kind variables, there are an awful lot of -ways to shoot yourself in the foot. Here are some. - - data SameKind :: k -> k -> * -- just to force unification - -1. data T1 a k (b :: k) (x :: SameKind a b) - -The problem here is that we discover that a and b should have the same -kind. But this kind mentions k, which is bound *after* a. -(Testcase: dependent/should_fail/BadTelescope) - -2. data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) - -Note that b is not bound. Yet its kind mentions a. Because we have -a nice rule that all implicitly bound variables come before others, -this is bogus. - -To catch these errors, we call checkTyConTelescope during kind-checking -datatype declarations. This checks for - -* Ill-scoped binders. From (1) and (2) above we can get putative - kinds like - T1 :: forall (a:k) (k:*) (b:k). SameKind a b -> * - where 'k' is mentioned a's kind before k is bound - - This is easy to check for: just look for - out-of-scope variables in the kind - -* We should arguably also check for ambiguous binders - but we don't. See Note [Ambiguous kind vars]. - -See also - * Note [Required, Specified, and Inferred for types] in TcTyClsDecls. - * Note [Checking telescopes] in Constraint discusses how - this check works for `forall x y z.` written in a type. - -Note [Ambiguous kind vars] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to be concerned about ambiguous binders. Suppose we have the kind - S1 :: forall k -> * -> * - S2 :: forall k. * -> * -Here S1 is OK, because k is Required, and at a use of S1 we will -see (S1 *) or (S1 (*->*)) or whatever. - -But S2 is /not/ OK because 'k' is Specfied (and hence invisible) and -we have no way (ever) to figure out how 'k' should be instantiated. -For example if we see (S2 Int), that tells us nothing about k's -instantiation. (In this case we'll instantiate it to Any, but that -seems wrong.) This is really the same test as we make for ambiguous -type in term type signatures. - -Now, it's impossible for a Specified variable not to occur -at all in the kind -- after all, it is Specified so it must have -occurred. (It /used/ to be possible; see tests T13983 and T7873. But -with the advent of the forall-or-nothing rule for kind variables, -those strange cases went away.) - -But one might worry about - type v k = * - S3 :: forall k. V k -> * -which appears to mention 'k' but doesn't really. Or - S4 :: forall k. F k -> * -where F is a type function. But we simply don't check for -those cases of ambiguity, yet anyway. The worst that can happen -is ambiguity at the call sites. - -Historical note: this test used to be called reportFloatingKvs. --} - --- | Check a list of binders to see if they make a valid telescope. --- See Note [Bad TyCon telescopes] -type TelescopeAcc - = ( TyVarSet -- Bound earlier in the telescope - , Bool -- At least one binder occurred (in a kind) before - -- it was bound in the telescope. E.g. - ) -- T :: forall (a::k) k. blah - -checkTyConTelescope :: TyCon -> TcM () -checkTyConTelescope tc - | bad_scope - = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes] - addErr $ - vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped") - 2 pp_tc_kind - , extra - , hang (text "Perhaps try this order instead:") - 2 (pprTyVars sorted_tvs) ] - - | otherwise - = return () - where - tcbs = tyConBinders tc - tvs = binderVars tcbs - sorted_tvs = scopedSort tvs - - (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs - - add_one :: TelescopeAcc -> TyConBinder -> TelescopeAcc - add_one (bound, bad_scope) tcb - = ( bound `extendVarSet` tv - , bad_scope || not (isEmptyVarSet (fkvs `minusVarSet` bound)) ) - where - tv = binderVar tcb - fkvs = tyCoVarsOfType (tyVarKind tv) - - inferred_tvs = [ binderVar tcb - | tcb <- tcbs, Inferred == tyConBinderArgFlag tcb ] - specified_tvs = [ binderVar tcb - | tcb <- tcbs, Specified == tyConBinderArgFlag tcb ] - - pp_inf = parens (text "namely:" <+> pprTyVars inferred_tvs) - pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs) - - pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc) - ppr_untidy ty = pprIfaceType (toIfaceType ty) - -- We need ppr_untidy here because pprType will tidy the type, which - -- will turn the bogus kind we are trying to report - -- T :: forall (a::k) k (b::k) -> blah - -- into a misleadingly sanitised version - -- T :: forall (a::k) k1 (b::k1) -> blah - - extra - | null inferred_tvs && null specified_tvs - = empty - | null inferred_tvs - = hang (text "NB: Specified variables") - 2 (sep [pp_spec, text "always come first"]) - | null specified_tvs - = hang (text "NB: Inferred variables") - 2 (sep [pp_inf, text "always come first"]) - | otherwise - = hang (text "NB: Inferred variables") - 2 (vcat [ sep [ pp_inf, text "always come first"] - , sep [text "then Specified variables", pp_spec]]) - -{- -************************************************************************ -* * -\subsection{Auxiliary functions} -* * -************************************************************************ --} - --- Free variables of a type, retaining repetitions, and expanding synonyms --- This ignores coercions, as coercions aren't user-written -fvType :: Type -> [TyCoVar] -fvType ty | Just exp_ty <- tcView ty = fvType exp_ty -fvType (TyVarTy tv) = [tv] -fvType (TyConApp _ tys) = fvTypes tys -fvType (LitTy {}) = [] -fvType (AppTy fun arg) = fvType fun ++ fvType arg -fvType (FunTy _ arg res) = fvType arg ++ fvType res -fvType (ForAllTy (Bndr tv _) ty) - = fvType (tyVarKind tv) ++ - filter (/= tv) (fvType ty) -fvType (CastTy ty _) = fvType ty -fvType (CoercionTy {}) = [] - -fvTypes :: [Type] -> [TyVar] -fvTypes tys = concatMap fvType tys - -sizeType :: Type -> Int --- Size of a type: the number of variables and constructors -sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty -sizeType (TyVarTy {}) = 1 -sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys -sizeType (LitTy {}) = 1 -sizeType (AppTy fun arg) = sizeType fun + sizeType arg -sizeType (FunTy _ arg res) = sizeType arg + sizeType res + 1 -sizeType (ForAllTy _ ty) = sizeType ty -sizeType (CastTy ty _) = sizeType ty -sizeType (CoercionTy _) = 0 - -sizeTypes :: [Type] -> Int -sizeTypes = foldr ((+) . sizeType) 0 - -sizeTyConAppArgs :: TyCon -> [Type] -> Int -sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys) - -- See Note [Invisible arguments and termination] - --- Size of a predicate --- --- We are considering whether class constraints terminate. --- Equality constraints and constraints for the implicit --- parameter class always terminate so it is safe to say "size 0". --- See #4200. -sizePred :: PredType -> Int -sizePred ty = goClass ty - where - goClass p = go (classifyPredType p) - - go (ClassPred cls tys') - | isTerminatingClass cls = 0 - | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys') - -- The filtering looks bogus - -- See Note [Invisible arguments and termination] - go (EqPred {}) = 0 - go (IrredPred ty) = sizeType ty - go (ForAllPred _ _ pred) = goClass pred - --- | When this says "True", ignore this class constraint during --- a termination check -isTerminatingClass :: Class -> Bool -isTerminatingClass cls - = isIPClass cls -- Implicit parameter constraints always terminate because - -- there are no instances for them --- they are only solved - -- by "local instances" in expressions - || isEqPredClass cls - || cls `hasKey` typeableClassKey - || cls `hasKey` coercibleTyConKey - --- | Tidy before printing a type -ppr_tidy :: TidyEnv -> Type -> SDoc -ppr_tidy env ty = pprType (tidyType env ty) - -allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool --- (allDistinctTyVars tvs tys) returns True if tys are --- a) all tyvars --- b) all distinct --- c) disjoint from tvs -allDistinctTyVars _ [] = True -allDistinctTyVars tkvs (ty : tys) - = case getTyVar_maybe ty of - Nothing -> False - Just tv | tv `elemVarSet` tkvs -> False - | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys |