diff options
Diffstat (limited to 'compiler/GHC/Tc')
65 files changed, 82661 insertions, 0 deletions
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs new file mode 100644 index 0000000000..9831c841e4 --- /dev/null +++ b/compiler/GHC/Tc/Deriv.hs @@ -0,0 +1,2304 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handles @deriving@ clauses on @data@ declarations. +module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Hs +import GHC.Driver.Session + +import GHC.Tc.Utils.Monad +import GHC.Tc.Instance.Family +import GHC.Tc.Types.Origin +import GHC.Core.Predicate +import GHC.Tc.Deriv.Infer +import GHC.Tc.Deriv.Utils +import GHC.Tc.Validity( allDistinctTyVars ) +import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) +import GHC.Tc.Utils.Env +import GHC.Tc.Deriv.Generate +import GHC.Tc.Validity( checkValidInstHead ) +import GHC.Core.InstEnv +import GHC.Tc.Utils.Instantiate +import GHC.Core.FamInstEnv +import GHC.Tc.Gen.HsType +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr ( pprTyVars ) + +import GHC.Rename.Names ( extendGlobalRdrEnvRn ) +import GHC.Rename.Bind +import GHC.Rename.Env +import GHC.Rename.Module ( 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 GHC.Tc.Utils.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 GHC.Tc.Deriv.Infer + +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 + } + +{- + +************************************************************************ +* * +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 GHC.Tc.Utils.Env + -- 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 GHC.Tc.Deriv.Generate) + 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 = GHC.Tc.Types.Origin.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. GHC.Tc.TyCl.Instance.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 GHC.Tc.Deriv.Infer). +-- +-- 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 "GHC.Tc.Deriv.Utils" 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 "GHC.Tc.Deriv.Utils" 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 "GHC.Tc.Deriv.Utils" 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 GHC.Tc.Deriv.Utils + 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. + +************************************************************************ +* * +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 GHC.Tc.Deriv.Generate + , 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 GHC.Tc.TyCl.Class (which is also used in GHC.Tc.TyCl.Instance 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, GHC.Tc.Deriv.Infer.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, GHC.Tc.Deriv.Utils.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 GHC.Tc.Deriv 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). + +************************************************************************ +* * +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/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs new file mode 100644 index 0000000000..d727d7bb98 --- /dev/null +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -0,0 +1,1443 @@ +{- +(c) The University of Glasgow 2011 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} + +-- | The deriving code for the Functor, Foldable, and Traversable classes +module GHC.Tc.Deriv.Functor + ( 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 GHC.Tc.Deriv.Generate +import GHC.Tc.Utils.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 GHC.Tc.Deriv.Generics. + +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/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs new file mode 100644 index 0000000000..27e73b6330 --- /dev/null +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -0,0 +1,2424 @@ +{- + % +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Generating derived instance declarations +-- +-- This module is nominally ``subordinate'' to @GHC.Tc.Deriv@, which is the +-- ``official'' interface to deriving-related things. +-- +-- This is where we do all the grimy bindings' generation. +module GHC.Tc.Deriv.Generate ( + 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 GHC.Tc.Utils.Monad +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 GHC.Tc.Instance.Family +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 GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType +import GHC.Tc.Validity ( 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 GHC.Tc.Deriv.Infer + = 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 +GHC.Tc.Deriv.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 GHC.Tc.Solver.Interact. + +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 GHC.Tc.Deriv + 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 GHC.Tc.Deriv.Infer +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 GHC.Tc.Deriv.Infer +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/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs new file mode 100644 index 0000000000..d40824e3ea --- /dev/null +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -0,0 +1,1039 @@ +{- +(c) The University of Glasgow 2011 + +-} + +{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | The deriving code for the Generic class +module GHC.Tc.Deriv.Generics + (canDoGenerics + , canDoGenerics1 + , GenericKind(..) + , gen_Generic_binds + , get_gen1_constrained_tys + ) +where + +import GhcPrelude + +import GHC.Hs +import GHC.Core.Type +import GHC.Tc.Utils.TcType +import GHC.Tc.Deriv.Generate +import GHC.Tc.Deriv.Functor +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) +import GHC.Tc.Instance.Family +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 GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +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 GHC.Tc.Deriv.Infer.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 GHC.Tc.Deriv. + +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/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs new file mode 100644 index 0000000000..47257d6b23 --- /dev/null +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -0,0 +1,1074 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Functions for inferring (and simplifying) the context for derived instances. +module GHC.Tc.Deriv.Infer + ( 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 GHC.Tc.Utils.Instantiate +import Outputable +import Pair +import PrelNames +import GHC.Tc.Deriv.Utils +import GHC.Tc.Utils.Env +import GHC.Tc.Deriv.Generate +import GHC.Tc.Deriv.Functor +import GHC.Tc.Deriv.Generics +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Utils.TcType +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr (pprTyVars) +import GHC.Core.Type +import GHC.Tc.Solver +import GHC.Tc.Validity (validDerivPred) +import GHC.Tc.Utils.Unify (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 GHC.Tc.Deriv.Generate.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 GHC.Tc.Solver.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 "GHC.Tc.Deriv" (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/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs new file mode 100644 index 0000000000..5394a09e23 --- /dev/null +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -0,0 +1,1111 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE TypeFamilies #-} + +-- | Error-checking and other utilities for @deriving@ clauses or declarations. +module GHC.Tc.Deriv.Utils ( + 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 GHC.Tc.Utils.Instantiate +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 GHC.Tc.Deriv.Generate +import GHC.Tc.Deriv.Functor +import GHC.Tc.Deriv.Generics +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.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 @GHC.Tc.Deriv@ and @GHC.Tc.Deriv.Infer@, 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 GHC.Tc.Deriv.Infer + , 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 GHC.Tc.Deriv + +{- +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 "GHC.Tc.Deriv". +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 "GHC.Tc.Deriv.Generate". + -- + -- 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 GHC.Tc.Deriv.) 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 + GHC.Tc.Deriv.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 GHC.Tc.Deriv.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 "GHC.Tc.Deriv". +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 "GHC.Tc.Deriv.Infer" 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 GHC.Tc.Deriv 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 GHC.Tc.Deriv 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 GHC.Tc.Deriv.Functor + | 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 GHC.Tc.TyCl.Instance +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 +GHC.Tc.Deriv.Infer 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 GHC.Tc.Deriv.Functor. + +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/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs new file mode 100644 index 0000000000..74eb1cf45a --- /dev/null +++ b/compiler/GHC/Tc/Errors.hs @@ -0,0 +1,2981 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Tc.Errors( + reportUnsolved, reportAllUnsolved, warnAllUnsolved, + warnDefaulting, + + solverDepthErrorTcS + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Unify( occCheckForErrors, MetaTyVarUpdateResult(..) ) +import GHC.Tc.Utils.Env( tcInitTidyEnv ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Origin +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 GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv ( flattenTys ) +import GHC.Tc.Utils.Instantiate +import GHC.Core.InstEnv +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.EvTerm +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 #-} GHC.Tc.Errors.Hole ( 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 GHC.Tc.Utils.Unify, 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 GHC.Tc.Errors. GHC.Tc.Errors.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 GHC.Tc.Solver) +-- 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 +-- GHC.Tc.Solver +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 GHC.Tc.Solver.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 GHC.Tc.Solver +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 GHC.Tc.Utils.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 GHC.Tc.Solver.Canonical + , ("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 GHC.Tc.TyCl.Instance. + = 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 GHC.Tc.Solver.Canonical.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 GHC.Tc.Solver.Canonical + = 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 GHC.Tc.TyCl.PatSyn). +-} + +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 GHC.Tc.Solver.Canonical 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/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs new file mode 100644 index 0000000000..b361ca597d --- /dev/null +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -0,0 +1,1004 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +module GHC.Tc.Errors.Hole + ( findValidHoleFits, tcFilterHoleFits + , tcCheckHoleFit, tcSubsumes + , withoutUnification + , fromPureHFPlugin + -- Re-exports for convenience + , hfIsLcl + , pprHoleFit, debugHoleFitDispConfig + + -- Re-exported from GHC.Tc.Errors.Hole.FitTypes + , TypedHole (..), HoleFit (..), HoleFitCandidate (..) + , CandPlugin, FitPlugin + , HoleFitPlugin (..), HoleFitPluginR (..) + ) +where + +import GhcPrelude + +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.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 GHC.Tc.Utils.Env (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 GHC.Tc.Solver ( simpl_top, runTcSDeriveds ) +import GHC.Tc.Utils.Unify ( 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 GHC.Tc.Errors.Hole.FitTypes + + +{- +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 "GHC.Tc.Errors.Hole 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/GHC/Tc/Errors/Hole.hs-boot b/compiler/GHC/Tc/Errors/Hole.hs-boot new file mode 100644 index 0000000000..bc79c3eed4 --- /dev/null +++ b/compiler/GHC/Tc/Errors/Hole.hs-boot @@ -0,0 +1,13 @@ +-- This boot file is in place to break the loop where: +-- + GHC.Tc.Solver calls 'GHC.Tc.Errors.reportUnsolved', +-- + which calls 'GHC.Tc.Errors.Hole.findValidHoleFits` +-- + which calls 'GHC.Tc.Solver.simpl_top' +module GHC.Tc.Errors.Hole where + +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Constraint ( Ct, Implication ) +import Outputable ( SDoc ) +import GHC.Types.Var.Env ( TidyEnv ) + +findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct + -> TcM (TidyEnv, SDoc) diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs new file mode 100644 index 0000000000..8aabc615ce --- /dev/null +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE ExistentialQuantification #-} +module GHC.Tc.Errors.Hole.FitTypes ( + TypedHole (..), HoleFit (..), HoleFitCandidate (..), + CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..), + hfIsLcl, pprHoleFitCand + ) where + +import GhcPrelude + +import GHC.Tc.Types +import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.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/GHC/Tc/Errors/Hole/FitTypes.hs-boot b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot new file mode 100644 index 0000000000..25d3f81aeb --- /dev/null +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot @@ -0,0 +1,10 @@ +-- This boot file is in place to break the loop where: +-- + GHC.Tc.Types needs 'HoleFitPlugin', +-- + which needs 'GHC.Tc.Errors.Hole.FitTypes' +-- + which needs 'GHC.Tc.Types' +module GHC.Tc.Errors.Hole.FitTypes where + +-- Build ordering +import GHC.Base() + +data HoleFitPlugin diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs new file mode 100644 index 0000000000..00c52ea247 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Annotation.hs @@ -0,0 +1,71 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Typechecking annotations +module GHC.Tc.Gen.Annotation ( tcAnnotations, annCtxt ) where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Tc.Gen.Splice ( 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 GHC.Tc.Utils.Monad +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/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs new file mode 100644 index 0000000000..435bf4d89c --- /dev/null +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -0,0 +1,442 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE RankNTypes, TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typecheck arrow notation +module GHC.Tc.Gen.Arrow ( tcProc ) where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) + +import GHC.Hs +import GHC.Tc.Gen.Match +import GHC.Tc.Utils.Zonk( hsLPatType ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Gen.Bind +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Types.Id( mkLocalId ) +import GHC.Tc.Utils.Instantiate +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 GHC.Tc.Types + 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/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs new file mode 100644 index 0000000000..6750a77500 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -0,0 +1,1737 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Tc.Gen.Bind + ( tcLocalBinds + , tcTopBinds + , tcValBinds + , tcHsBootSigs + , tcPolyCheck + , chooseInferredQuantifiers + , badBootDeclErr + ) +where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcMonoExpr ) +import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) +import GHC.Core (Tickish (..)) +import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) +import GHC.Driver.Session +import FastString +import GHC.Hs +import GHC.Tc.Gen.Sig +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Unify +import GHC.Tc.Solver +import GHC.Tc.Types.Evidence +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.TcMType +import GHC.Core.FamInstEnv( normaliseType ) +import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) +import GHC.Core.TyCon +import GHC.Tc.Utils.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 GHC.Tc.Validity (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.Bind + ; 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 GHC.Tc.Utils.Env.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 GHC.Tc.Solver.Flatten) 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 GHC.Tc.Solver + ; 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 GHC.Tc.Gen.HsType.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 GHC.Tc.Gen.HsType: + -- 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 GHC.Tc.Utils.Unify, + -- Note [Deep instantiation of InferResult] in GHC.Tc.Utils.Unify + 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 + GHC.Tc.Gen.Pat.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 (GHC.Tc.Gen.Pat.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/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs new file mode 100644 index 0000000000..ab3ef76fca --- /dev/null +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -0,0 +1,110 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} +{-# LANGUAGE TypeFamilies #-} + +-- | Typechecking @default@ declarations +module GHC.Tc.Gen.Default ( tcDefaults ) where + +import GhcPrelude + +import GHC.Hs +import GHC.Core.Class +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.Zonk +import GHC.Tc.Solver +import GHC.Tc.Validity +import GHC.Tc.Utils.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/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs new file mode 100644 index 0000000000..283bbce728 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -0,0 +1,855 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Tc.Gen.Export (tcRnExports, exports_from_avail) where + +import GhcPrelude + +import GHC.Hs +import PrelNames +import GHC.Types.Name.Reader +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.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 `GHC.Tc.Module` 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 GHC.Tc.Module.checkMain + 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/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs new file mode 100644 index 0000000000..55f2a105c6 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -0,0 +1,2908 @@ +{- +% +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typecheck an expression +module GHC.Tc.Gen.Expr + ( tcPolyExpr + , tcMonoExpr + , tcMonoExprNC + , tcInferSigma + , tcInferSigmaNC + , tcInferRho + , tcInferRhoNC + , tcSyntaxOp + , tcSyntaxOpGen + , SyntaxOpType(..) + , synKnownType + , tcCheckId + , addExprErrCtxt + , addAmbiguousNameErr + , getFixedTyVars + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) +import THNames( liftStringName, liftName ) + +import GHC.Hs +import GHC.Tc.Types.Constraint ( HoleSort(..) ) +import GHC.Tc.Utils.Zonk +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Unify +import GHC.Types.Basic +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Gen.Bind ( chooseInferredQuantifiers, tcLocalBinds ) +import GHC.Tc.Gen.Sig ( tcUserTypeSig, tcInstSig ) +import GHC.Tc.Solver ( simplifyInfer, InferMode(..) ) +import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst ) +import GHC.Core.FamInstEnv ( FamInstEnvs ) +import GHC.Rename.Env ( addUsedGRE ) +import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr ) +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Arrow +import GHC.Tc.Gen.Match +import GHC.Tc.Gen.HsType +import GHC.Tc.TyCl.PatSyn ( tcPatSynBuilderOcc, nonBidirectionalErr ) +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType as 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 GHC.Tc.Types.Evidence +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 GHC.Tc.Gen.Match (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 GHC.Tc.Gen.Match + -- 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 GHC.Tc.TyCl), 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. GHC.Tc.Utils.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 GHC.Tc.Utils.Unify. + 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 GHC.Tc.Utils.Unify + -- Note [Deep instantiation of InferResult] in GHC.Tc.Utils.Unify + + +---------------- +-- | 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 GHC.Tc.Utils.Unify. + 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 GHC.Tc.Gen.Bind.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 "GHC.Tc.Gen.Expr: 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/GHC/Tc/Gen/Expr.hs-boot b/compiler/GHC/Tc/Gen/Expr.hs-boot new file mode 100644 index 0000000000..27ebefc9a3 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Expr.hs-boot @@ -0,0 +1,42 @@ +module GHC.Tc.Gen.Expr where +import GHC.Types.Name +import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc ) +import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Origin ( 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/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs new file mode 100644 index 0000000000..050f3b5b89 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -0,0 +1,571 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +-- | 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. +module GHC.Tc.Gen.Foreign + ( 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 GHC.Tc.Utils.Monad +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Env + +import GHC.Tc.Instance.Family +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 GHC.Tc.Utils.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 GHC.Tc.Utils.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 GHC.Tc.Module 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 GHC.Tc.Utils.Zonk.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/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs new file mode 100644 index 0000000000..c7a7f298f5 --- /dev/null +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -0,0 +1,3549 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typechecking user-specified @MonoTypes@ +module GHC.Tc.Gen.HsType ( + -- 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 GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Core.Predicate +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Validity +import GHC.Tc.Utils.Unify +import GHC.IfaceToCore +import GHC.Tc.Solver +import GHC.Tc.Utils.Zonk +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Tc.Errors ( reportAllUnsolved ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Instantiate ( 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 GHC.Tc.Validity.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 GHC.Tc.Solver + + ; 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 GHC.Tc.Solver, + -- 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 GHC.Tc.Gen.HsType +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 GHC.Tc.TyCl +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 GHC.Tc.Utils.Zonk. + - 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 GHC.Tc.Utils.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 GHC.Tc.Utils.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 GHC.Tc.TyCl + = 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 GHC.Tc.TyCl + -- 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 GHC.Tc.TyCl + = 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 GHC.Tc.TyCl + <- 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 GHC.Tc.TyCl, + + ; 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 GHC.Tc.TyCl + + 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 GHC.Tc.TyCl + -- + -- 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.HsType, 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 GHC.Tc.Utils.Env +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 GHC.Tc.Utils.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.HsType + ; 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 GHC.Tc.Solver +-- 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 GHC.Tc.TyCl +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 "GHC.Tc.TyCl". +-- +-- 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 GHC.Tc.TyCl +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 GHC.Tc.TyCl. + || 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 GHC.Tc.Solver + -- 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 GHC.Tc.Gen.Sig.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. + +* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar + with the inferred constraints, e.g. (Eq a, Show a) + +* GHC.Tc.Errors.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 + GHC.Tc.Gen.Bind.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 GHC.Tc.Utils. +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 + GHC.Tc.Errors.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 GHC.Tc.Gen.HsType +-- 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/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs new file mode 100644 index 0000000000..314b81faa8 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -0,0 +1,1125 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typecheck some @Matches@ +module GHC.Tc.Gen.Match + ( tcMatchesFun + , tcGRHS + , tcGRHSsPat + , tcMatchesCase + , tcMatchLambda + , TcMatchCtxt(..) + , TcStmtChecker + , TcExprStmtChecker + , TcCmdStmtChecker + , tcStmts + , tcStmtsAndThen + , tcDoStmts + , tcBody + , tcDoStmt + , tcGuardStmt + ) +where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRhoNC, tcInferRho + , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr ) + +import GHC.Types.Basic (LexicalFixity(..)) +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Pat +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Gen.Bind +import GHC.Tc.Utils.Unify +import GHC.Tc.Types.Origin +import GHC.Types.Name +import TysWiredIn +import GHC.Types.Id +import GHC.Core.TyCon +import TysPrim +import GHC.Tc.Types.Evidence +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 GHC.Tc.Gen.Pat. +-} + +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 GHC.Tc.Utils.Unify + -> 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 +-- GHC.Tc.Errors.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/GHC/Tc/Gen/Match.hs-boot b/compiler/GHC/Tc/Gen/Match.hs-boot new file mode 100644 index 0000000000..6b363511c8 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Match.hs-boot @@ -0,0 +1,17 @@ +module GHC.Tc.Gen.Match where +import GHC.Hs ( GRHSs, MatchGroup, LHsExpr ) +import GHC.Tc.Types.Evidence ( HsWrapper ) +import GHC.Types.Name ( Name ) +import GHC.Tc.Utils.TcType( ExpSigmaType, TcRhoType ) +import GHC.Tc.Types ( 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/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs new file mode 100644 index 0000000000..0fa2b74c14 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -0,0 +1,1214 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, RankNTypes, TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typechecking patterns +module GHC.Tc.Gen.Pat + ( tcLetPat + , newLetBndr + , LetBndrSpec(..) + , tcPat + , tcPat_O + , tcPats + , addDataConStupidTheta + , badFieldCon + , polyPatSig + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma ) + +import GHC.Hs +import GHC.Tc.Utils.Zonk +import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Instantiate +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Validity( arityErr ) +import GHC.Core.TyCo.Ppr ( pprTyVars ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Unify +import GHC.Tc.Gen.HsType +import TysWiredIn +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +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 GHC.Tc.Gen.Bind + + | 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 GHC.Tc.Gen.Bind +-- +-- 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 GHC.Tc.Gen.Match. +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 GHC.Tc.Gen.Bind +-} + +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/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs new file mode 100644 index 0000000000..373dd42a83 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -0,0 +1,498 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Typechecking transformation rules +module GHC.Tc.Gen.Rule ( tcRules ) where + +import GhcPrelude + +import GHC.Hs +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Solver +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Unify( buildImplicationFor ) +import GHC.Tc.Types.Evidence( 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 GHC.Tc.Utils.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 GHC.Tc.TyCl, 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. GHC.Tc.Solver.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 GHC.Tc.Utils.Zonk.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 GHC.Tc.Gen.HsType + + -- 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 GHC.Tc.Utils.Unify.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 GHC.Tc.Solver.Interact 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/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs new file mode 100644 index 0000000000..a6dfdcc2f4 --- /dev/null +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -0,0 +1,836 @@ +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-2002 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Gen.Sig( + 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 GHC.Tc.Gen.HsType +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Validity ( checkValidType ) +import GHC.Tc.Utils.Unify( tcSkolemise, unifyType ) +import GHC.Tc.Utils.Instantiate( topInstantiate ) +import GHC.Tc.Utils.Env( tcLookupId ) +import GHC.Tc.Types.Evidence( 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 GHC.Tc.Gen.Bind.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 GHC.Tc.Gen.Bind.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 GHC.Tc.TyCl.PatSyn.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 GHC.Tc.Gen.HsType +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 GHC.Tc.TyCl.PatSyn. + -- 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 GHC.Tc.Gen.HsType + ; 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 GHC.Tc.Gen.Bind.mkExport + +See Note [Signature skolems] in GHC.Tc.Utils.TcType + +None of this applies to a function binding with a complete +signature, which doesn't use tcInstSig. See GHC.Tc.Gen.Bind.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 GHC.Tc.TyCl.Instance.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/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs new file mode 100644 index 0000000000..3de1e2063d --- /dev/null +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -0,0 +1,2384 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# 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 #-} + +-- | Template Haskell splices +module GHC.Tc.Gen.Splice( + 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 GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType + +import Outputable +import GHC.Tc.Gen.Expr +import GHC.Types.SrcLoc +import THNames +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Origin +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 GHC.Tc.Gen.Splice + -- 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.HsType +import GHC.Tc.Utils.Zonk +import GHC.Tc.Solver +import GHC.Core.Type as Type +import GHC.Types.Name.Set +import GHC.Tc.Utils.TcMType +import GHC.Tc.Gen.HsType +import GHC.IfaceToCore +import GHC.Core.TyCo.Rep as TyCoRep +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv as InstEnv +import GHC.Tc.Utils.Instantiate +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 GHC.Tc.Types.Evidence +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 "GHC.Tc.Types". + 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 +`GHC.Tc.Gen.Splice.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 GHC.Tc.Gen.Splice), 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 GHC.Tc.Utils.Env.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 GHC.Tc.TyCl. + | 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/GHC/Tc/Gen/Splice.hs-boot b/compiler/GHC/Tc/Gen/Splice.hs-boot new file mode 100644 index 0000000000..d74edf3f3a --- /dev/null +++ b/compiler/GHC/Tc/Gen/Splice.hs-boot @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Gen.Splice where + +import GhcPrelude +import GHC.Types.Name +import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) +import GHC.Tc.Types( TcM , SpliceType ) +import GHC.Tc.Utils.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/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs new file mode 100644 index 0000000000..81ee5aec71 --- /dev/null +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -0,0 +1,714 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.Instance.Class ( + matchGlobalInst, + ClsInstResult(..), + InstanceWhat(..), safeOverlap, instanceReturnsDictCon, + AssocInstInfo(..), isNotAssociated + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Instance.Typeable +import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.Evidence +import GHC.Core.Predicate +import GHC.Rename.Env( addUsedGRE ) +import GHC.Types.Name.Reader( lookupGRE_FieldLabel ) +import GHC.Core.InstEnv +import GHC.Tc.Utils.Instantiate( instDFunType ) +import GHC.Tc.Instance.Family( 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 + -- GHC.Tc.Validity.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 GHC.Tc.Solver +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +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 + -- GHC.Tc.Solver.Monad 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 GHC.Tc.Solver.Monad +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 GHC.Tc.Solver.Interact) 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 GHC.Tc.Types.Evidence. 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 "GHC.Tc.Solver.Interact.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/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs new file mode 100644 index 0000000000..68c894f2e4 --- /dev/null +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -0,0 +1,1056 @@ +{-# LANGUAGE CPP, GADTs, ViewPatterns #-} + +-- | The @FamInst@ type: family instance heads +module GHC.Tc.Instance.Family ( + 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 GHC.Tc.Types.Evidence +import GHC.Iface.Load +import GHC.Tc.Utils.Monad +import GHC.Types.SrcLoc as SrcLoc +import GHC.Core.TyCon +import GHC.Tc.Utils.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 GHC.Tc.Utils.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 GHC.Tc.TyCl + 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/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs new file mode 100644 index 0000000000..73a1317692 --- /dev/null +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -0,0 +1,682 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 2000 + + +-} + +{-# LANGUAGE CPP #-} + +-- | Functional dependencies +-- +-- It's better to read it as: "if we know these, then we're going to know these" +module GHC.Tc.Instance.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 GHC.Tc.Utils.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/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs new file mode 100644 index 0000000000..842157a3d4 --- /dev/null +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -0,0 +1,759 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Instance.Typeable(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 GHC.Tc.Utils.Env +import GHC.Tc.Types.Evidence ( mkWpTyApps ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.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 GHC.Tc.Instance.Typeable 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 GHC.Tc.Solver.Interact, 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. GHC.Tc.Instance.Typeable.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 GHC.Tc.Instance.Typeable. +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/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs new file mode 100644 index 0000000000..54b663f581 --- /dev/null +++ b/compiler/GHC/Tc/Module.hs @@ -0,0 +1,3078 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking a whole module +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker +module GHC.Tc.Module ( + 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 #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) +import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) +import GHC.Iface.Env ( externaliseName ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Validity( checkValidType ) +import GHC.Tc.Gen.Match +import GHC.Tc.Utils.Instantiate( deeplyInstantiate ) +import GHC.Tc.Utils.Unify( checkConstraints ) +import GHC.Rename.HsType +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 GHC.Tc.Utils.Zonk +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Monad +import GHC.Tc.Gen.Export +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import qualified BooleanFormula as BF +import GHC.Core.Ppr.TyThing ( pprTyThingInContext ) +import GHC.Core.FVs ( orphNamesOfFamInst ) +import GHC.Tc.Instance.Family +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv + ( FamInst, pprFamInst, famInstsRepTyCons + , famInstEnvElts, extendFamInstEnvList, normaliseType ) +import GHC.Tc.Gen.Annotation +import GHC.Tc.Gen.Bind +import GHC.Iface.Make ( coAxiomToIfaceDecl ) +import HeaderInfo ( mkPrelImports ) +import GHC.Tc.Gen.Default +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Rule +import GHC.Tc.Gen.Foreign +import GHC.Tc.TyCl.Instance +import GHC.IfaceToCore +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Solver +import GHC.Tc.TyCl +import GHC.Tc.Instance.Typeable ( mkTypeableBinds ) +import GHC.Tc.Utils.Backpack +import GHC.Iface.Load +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Module +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 GHC.Tc.Utils.Instantiate (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 GHC.Tc.Errors.Hole.FitTypes ( 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 + -- GHC.Tc.Utils.Env.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.Module + + ; (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 ("GHC.Tc.Module.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 "GHC.Tc.Module.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 "GHC.Tc.Module.tcGhciStmts: simplify ctxt" empty + ; const_binds <- checkNoErrs (simplifyInteractive lie) + -- checkNoErrs ensures that the plan fails if context redn fails + + + ; traceTc "GHC.Tc.Module.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 (GHC.Tc.Gen.Bind.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 GHC.Tc.Gen.HsType 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 -> [GHC.Tc.Utils.Monad.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/GHC/Tc/Module.hs-boot b/compiler/GHC/Tc/Module.hs-boot new file mode 100644 index 0000000000..f1f5e31e8a --- /dev/null +++ b/compiler/GHC/Tc/Module.hs-boot @@ -0,0 +1,12 @@ +module GHC.Tc.Module where + +import GhcPrelude +import GHC.Core.Type(TyThing) +import GHC.Tc.Types (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/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs new file mode 100644 index 0000000000..cde159815f --- /dev/null +++ b/compiler/GHC/Tc/Plugin.hs @@ -0,0 +1,190 @@ +{-# 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 GHC.Tc.Plugin ( + -- * 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 GHC.Tc.Utils.Monad as TcM +import qualified GHC.Tc.Solver.Monad as TcS +import qualified GHC.Tc.Utils.Env as TcM +import qualified GHC.Tc.Utils.TcMType as TcM +import qualified GHC.Tc.Instance.Family as TcM +import qualified GHC.Iface.Env as IfaceEnv +import qualified GHC.Driver.Finder as Finder + +import GHC.Core.FamInstEnv ( FamInstEnv ) +import GHC.Tc.Utils.Monad ( TcGblEnv, TcLclEnv, TcPluginM + , unsafeTcPluginTcM, getEvBindsTcPluginM + , liftIO, traceTc ) +import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin ) +import GHC.Tc.Utils.TcMType ( TcTyVar, TcType ) +import GHC.Tc.Utils.Env ( TcTyThing ) +import GHC.Tc.Types.Evidence ( 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 GHC.Tc.Utils.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/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs new file mode 100644 index 0000000000..ad2c7816d2 --- /dev/null +++ b/compiler/GHC/Tc/Solver.hs @@ -0,0 +1,2727 @@ +{-# LANGUAGE CPP #-} + +module GHC.Tc.Solver( + 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 GHC.Tc.Utils.Instantiate +import ListSetOps +import GHC.Types.Name +import Outputable +import PrelInfo +import PrelNames +import GHC.Tc.Errors +import GHC.Tc.Types.Evidence +import GHC.Tc.Solver.Interact +import GHC.Tc.Solver.Canonical ( makeSuperClasses, solveCallStack ) +import GHC.Tc.Utils.TcMType as TcM +import GHC.Tc.Utils.Monad as TcM +import GHC.Tc.Solver.Monad as TcS +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.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 GHC.Tc.Module 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 GHC.Tc.Utils.Monad 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 GHC.Tc.Utils.Monad 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 GHC.Tc.Utils.Monad + -- 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 GHC.Tc.Types.Evidence + 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 GHC.Tc.Types.Evidence +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) `GHC.Tc.Solver.Interact.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) `GHC.Tc.Solver.Interact.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) `GHC.Tc.Solver.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 `GHC.Tc.Errors.reportUnsolved`, + while for resolved but unsafe overlapping dictionary constraints, call + `GHC.Tc.Errors.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 `GHC.Tc.Utils.Monad.recordUnsafeInfer` to + mark the module we are compiling as unsafe, passing the + warning message along as the reason. + + 5) `GHC.Tc.Errors.*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) `GHC.Tc.Utils.Monad.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 GHC.Tc.Gen.Bind.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 GHC.Tc.Module, + -- 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 GHC.Tc.Utils.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 GHC.Tc.Solver.decideMonoTyVars. We + report the error later, in GHC.Tc.Gen.Bind.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 +GHC.Tc.Gen.Bind.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 GHC.Tc.Solver.Monad + + ; (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 GHC.Tc.Utils.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 GHC.Tc.Types.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 GHC.Tc.Solver.Interact.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 + +* GHC.Tc.Errors does the actual warning, in warnRedundantConstraints. + +* We don't report redundant givens for *every* implication; only + for those which reply True to GHC.Tc.Solver.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 + - GHC.Tc.Gen.Bind.tcSpecPrag + - GHC.Tc.Gen.Bind.tcTySig + + This decision is taken in setImplicationStatus, rather than GHC.Tc.Errors + 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 GHC.Tc.Utils.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 GHC.Tc.Utils.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. GHC.Tc.Utils.TcMType.defaultTyVar + -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + = 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 GHC.Tc.Utils.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 +GHC.Tc.Solver 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 GHC.Tc.Solver.Interact. + +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/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs new file mode 100644 index 0000000000..c9d93b063e --- /dev/null +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -0,0 +1,2542 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Tc.Solver.Canonical( + canonicalize, + unifyDerived, + makeSuperClasses, maybeSym, + StopOrContinue(..), stopWith, continueWith, + solveCallStack -- For GHC.Tc.Solver + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Unify( swapOverTyVars, metaTyVarUpdateOK, MetaTyVarUpdateResult(..) ) +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Tc.Solver.Flatten +import GHC.Tc.Solver.Monad +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.EvTerm +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 GHC.Tc.Instance.Family ( 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 GHC.Tc.Types). + +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 GHC.Tc.Types.Evidence + -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad + = 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 GHC.Tc.Solver 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 GHC.Tc.Utils.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 GHC.Tc.Types.Constraint) + try harder: take both the Givens and Wanteds, and expand + superclasses again. See the calls to expandSuperClasses in + GHC.Tc.Solver.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 GHC.Tc.Solver.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 +GHC.Tc.Solver.Interact. 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 GHC.Tc.Solver.Interact. + +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 GHC.Tc.Utils.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 GHC.Tc.TyCl.Instance + -- 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 +GHC.Tc.Solver.Interact.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 GHC.Tc.Solver.Interact.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 + + * GHC.Tc.Solver.Monad.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 + GHC.Tc.Solver.Interact.matchInstEnv, use the InstEnv from inert_insts + so that we include the local Given forall-constraints + in the lookup. (See GHC.Tc.Solver.Monad.getInstEnvs.) + + * GHC.Tc.Solver.Canonical.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 GHC.Tc.Solver.Monad.kick_out_rewritable + +Note that a quantified constraint is never /inferred/ +(by GHC.Tc.Solver.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 GHC.Tc.Utils. + + ; 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 GHC.Tc.Solver.Interact. + +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 GHC.Tc.Solver.Monad. +And if we don't do this there is a bad danger that +GHC.Tc.Solver.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 GHC.Tc.Types.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/GHC/Tc/Solver/Flatten.hs b/compiler/GHC/Tc/Solver/Flatten.hs new file mode 100644 index 0000000000..e1a290fdf9 --- /dev/null +++ b/compiler/GHC/Tc/Solver/Flatten.hs @@ -0,0 +1,1925 @@ +{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns, BangPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Tc.Solver.Flatten( + FlattenMode(..), + flatten, flattenKind, flattenArgsNom, + rewriteTyVar, + + unflattenWanteds + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Tc.Types +import GHC.Core.TyCo.Ppr ( pprTyVar ) +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Tc.Types.Evidence +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 GHC.Tc.Solver.Monad 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 GHC.Tc.Solver.Interact.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 GHC.Tc.Solver.Interact + + +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 GHC.Tc.Solver.Canonical.canEqTyVar. + +See also Note [Conservative unification check] in GHC.Tc.Utils.Unify, 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 GHC.Tc.Types). +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 GHC.Tc.Solver.Monad. +-- 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 GHC.Tc.Utils. + +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 +GHC.Tc.Solver.Canonical.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 GHC.Tc.Types.Evidence. + +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 GHC.Tc.Solver.Monad + | (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 GHC.Tc.Solver.Monad +-- See Note [Stability of flattening] in GHC.Tc.Solver.Monad + +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 GHC.Tc.Solver.Interact.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 GHC.Tc.Solver.Interact + , 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/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs new file mode 100644 index 0000000000..f9e0562c7b --- /dev/null +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -0,0 +1,2700 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.Solver.Interact ( + solveSimpleGivens, -- Solves [Ct] + solveSimpleWanteds, -- Solves Cts + ) where + +#include "HsVersions.h" + +import GhcPrelude +import GHC.Types.Basic ( SwapFlag(..), isSwapped, + infinity, IntWithInf, intGtLimit ) +import GHC.Tc.Solver.Canonical +import GHC.Tc.Solver.Flatten +import GHC.Tc.Utils.Unify( 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 GHC.Tc.Utils.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 GHC.Tc.Instance.FunDeps +import GHC.Tc.Instance.Family +import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap ) +import GHC.Core.FamInstEnv +import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) + +import GHC.Tc.Types.Evidence +import Outputable + +import GHC.Tc.Types +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Solver.Monad +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 GHC.Tc.Solver.Flatten, +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", GHC.Tc.Solver.Canonical.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 GHC.Tc.Solver. + + 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 GHC.Tc.TyCl.Instance + + (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 GHC.Tc.Solver 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 GHC.Tc.Solver.Canonical + +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 GHC.Tc.Types.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 GHC.Tc.Solver.Monad; 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 GHC.Tc.Instance.FunDeps (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 GHC.Tc.Solver.Canonical +-- 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 GHC.Tc.Solver.Canonical + +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 GHC.Tc.Solver.Flatten.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 +-- GHC.Tc.Solver.Canonical.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 GHC.Tc.Solver.Flatten + +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 (GHC.Tc.Solver.Flatten.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 GHC.Tc.Validity 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 GHC.Tc.Solver.Monad + 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/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs new file mode 100644 index 0000000000..0aea474320 --- /dev/null +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -0,0 +1,3643 @@ +{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Type definitions for the constraint solver +module GHC.Tc.Solver.Monad ( + + -- 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 GHC.Tc.Solver. I am wondering + -- if the whole instance matcher simply belongs + -- here +) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Driver.Types + +import qualified GHC.Tc.Utils.Instantiate as TcM +import GHC.Core.InstEnv +import GHC.Tc.Instance.Family as FamInst +import GHC.Core.FamInstEnv + +import qualified GHC.Tc.Utils.Monad as TcM +import qualified GHC.Tc.Utils.TcMType as TcM +import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) ) +import qualified GHC.Tc.Utils.Env as TcM + ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl ) +import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) +import GHC.Tc.Utils.TcType +import GHC.Driver.Session +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Unify + +import ErrUtils +import GHC.Tc.Types.Evidence +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Tc.Errors ( 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 GHC.Tc.Types +import GHC.Tc.Types.Origin +import GHC.Tc.Types.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 GHC.Tc.Solver.Interact.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 GHC.Tc.TyCl.Instance. + + 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 + - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary, + conditional on the kind of instance + + - It is only called when applying an instance decl, + in GHC.Tc.Solver.Interact.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 GHC.Tc.Solver + + , 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 GHC.Tc.Solver.Monad.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 GHC.Tc.Types.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 GHC.Tc.Solver.Canonical + 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 GHC.Tc.Solver (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 GHC.Tc.Solver.Monad.kick_out_rewritable) + + * We rewrite those insolubles in GHC.Tc.Solver.Canonical. + 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 GHC.Tc.Solver +insertSafeOverlapFailureTcS what item + | safeOverlap what = return () + | otherwise = updInertCans (\ics -> addInertSafehask ics item) + +getSafeOverlapFailures :: TcS Cts +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +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 GHC.Tc.Solver.Canonical + +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 GHC.Tc.Solver.Interact. +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 GHC.Tc.Solver.Interact + bind_meta_tv tv | isMetaTyVar tv + , not (isFskTyVar tv) = BindMe + | otherwise = Skolem + +prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool +-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance +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 GHC.Tc.Utils.Unify 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 GHC.Tc.Types.Evidence + +* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.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 "GHC.Tc.Solver.Canonical" 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 GHC.Tc.Utils.Env 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 "GHC.Tc.Solver.Monad.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 GHC.Tc.Solver.Flatten) 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 GHC.Tc.Types) +-- +-- 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 GHC.Tc.Solver.Flatten 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 GHC.Tc.Types.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 GHC.Tc.Solver.Interact.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 GHC.Tc.Solver.Monad.deferTcSForAllEq +-} diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs new file mode 100644 index 0000000000..2a21b8a61c --- /dev/null +++ b/compiler/GHC/Tc/TyCl.hs @@ -0,0 +1,4913 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + +-} + +{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Typecheck type and class declarations +module GHC.Tc.TyCl ( + tcTyAndClassDecls, + + -- Functions used by GHC.Tc.TyCl.Instance 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 GHC.Tc.TyCl.Build +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Validity +import GHC.Tc.Utils.Zonk +import GHC.Tc.TyCl.Utils +import GHC.Tc.TyCl.Class +import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 ) +import GHC.Tc.Deriv (DerivInfo(..)) +import GHC.Tc.Utils.Unify ( checkTvConstraints ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Instance.Class( AssocInstInfo(..) ) +import GHC.Tc.Utils.TcMType +import TysWiredIn ( unitTy, makeRecoveryTyCon ) +import GHC.Tc.Utils.TcType +import GHC.Rename.Env( lookupConstructorFields ) +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Core.Coercion +import GHC.Tc.Types.Origin +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 GHC.Tc.TyCl), 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 GHC.Tc.TyCl, 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 + GHC.Tc.Gen.HsType.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 GHC.Tc.Gen.HsType.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 GHC.Tc.Gen.HsType + = 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 GHC.Tc.Utils.TcType + + - Have complete fresh Names; see GHC.Tc.Utils.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 GHC.Tc.Gen.Bind + 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 GHC.Tc.Solver.defaultTyVarTcS, and + GHC.Tc.Utils.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 +GHC.Tc.Gen.HsType 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 GHC.Tc.Gen.HsType, 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 GHC.Tc.Gen.HsType.tcTyVar we look in the *local* env, to get the + fully-known, not knot-tied TcTyCon for T. + + * Then, in GHC.Tc.Utils.Zonk.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 GHC.Tc.TyCl.Instance. 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 GHC.Tc.Gen.HsType. + +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. GHC.Tc.Gen.HsType.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 GHC.Tc.Validity.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 GHC.Tc.TyCl.Instance, 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 GHC.Tc.Gen.Rule, 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 GHC.Tc.Gen.HsType.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.Module + 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 GHC.Tc.TyCl.Utils + -- 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 GHC.Tc.Utils.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 GHC.Tc.TyCl.Instance. + 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 GHC.Tc.TyCl.Utils +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 GHC.Tc.TyCl.Utils + 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 GHC.Tc.Validity. +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/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs new file mode 100644 index 0000000000..a118630fda --- /dev/null +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -0,0 +1,418 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Tc.TyCl.Build ( + buildDataCon, + buildPatSyn, + TcMethInfo, MethInfo, buildClass, + mkNewTyConRhs, + newImplicitBinder, newTyConRepName + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Iface.Env +import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) +import TysWiredIn( isCTupleTyConName ) +import TysPrim ( voidPrimTy ) +import GHC.Core.DataCon +import GHC.Core.PatSyn +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id.Make +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Types.Id +import GHC.Tc.Utils.TcType + +import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) +import GHC.Driver.Session +import GHC.Tc.Utils.Monad +import GHC.Types.Unique.Supply +import Util +import Outputable + + +mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs +-- ^ Monadic because it makes a Name for the coercion TyCon +-- We pass the Name of the parent TyCon, as well as the TyCon itself, +-- because the latter is part of a knot, whereas the former is not. +mkNewTyConRhs tycon_name tycon con + = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc + ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs + ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax) + ; return (NewTyCon { data_con = con, + nt_rhs = rhs_ty, + nt_etad_rhs = (etad_tvs, etad_rhs), + nt_co = nt_ax, + nt_lev_poly = isKindLevPoly res_kind } ) } + -- Coreview looks through newtypes with a Nothing + -- for nt_co, or uses explicit coercions otherwise + where + tvs = tyConTyVars tycon + roles = tyConRoles tycon + res_kind = tyConResKind tycon + con_arg_ty = case dataConRepArgTys con of + [arg_ty] -> arg_ty + tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys) + rhs_ty = substTyWith (dataConUnivTyVars con) + (mkTyVarTys tvs) con_arg_ty + -- Instantiate the newtype's RHS with the + -- type variables from the tycon + -- NB: a newtype DataCon has a type that must look like + -- forall tvs. <arg-ty> -> T tvs + -- Note that we *can't* use dataConInstOrigArgTys here because + -- the newtype arising from class Foo a => Bar a where {} + -- has a single argument (Foo a) that is a *type class*, so + -- dataConInstOrigArgTys returns []. + + etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can + etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty + etad_rhs :: Type -- See Note [Tricky iface loop] in GHC.Iface.Load + (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty + + eta_reduce :: [TyVar] -- Reversed + -> [Role] -- also reversed + -> Type -- Rhs type + -> ([TyVar], [Role], Type) -- Eta-reduced version + -- (tyvars in normal order) + eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty, + Just tv <- getTyVar_maybe arg, + tv == a, + not (a `elemVarSet` tyCoVarsOfType fun) + = eta_reduce as rs fun + eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty) + +------------------------------------------------------ +buildDataCon :: FamInstEnvs + -> Name + -> Bool -- Declared infix + -> TyConRepName + -> [HsSrcBang] + -> Maybe [HsImplBang] + -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make + -> [FieldLabel] -- Field labels + -> [TyVar] -- Universals + -> [TyCoVar] -- Existentials + -> [TyVarBinder] -- User-written 'TyVarBinder's + -> [EqSpec] -- Equality spec + -> KnotTied ThetaType -- Does not include the "stupid theta" + -- or the GADT equalities + -> [KnotTied Type] -- Arguments + -> KnotTied Type -- Result types + -> KnotTied TyCon -- Rep tycon + -> NameEnv ConTag -- Maps the Name of each DataCon to its + -- ConTag + -> TcRnIf m n DataCon +-- A wrapper for DataCon.mkDataCon that +-- a) makes the worker Id +-- b) makes the wrapper Id if necessary, including +-- allocating its unique (hence monadic) +buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs + field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty + rep_tycon tag_map + = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc + ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc + -- This last one takes the name of the data constructor in the source + -- code, which (for Haskell source anyway) will be in the DataName name + -- space, and puts it into the VarName name space + + ; traceIf (text "buildDataCon 1" <+> ppr src_name) + ; us <- newUniqueSupply + ; dflags <- getDynFlags + ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs + tag = lookupNameEnv_NF tag_map src_name + -- See Note [Constructor tag allocation], fixes #14657 + data_con = mkDataCon src_name declared_infix prom_info + src_bangs field_lbls + univ_tvs ex_tvs user_tvbs eq_spec ctxt + arg_tys res_ty NoRRI rep_tycon tag + stupid_ctxt dc_wrk dc_rep + dc_wrk = mkDataConWorkId work_name data_con + dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name + impl_bangs data_con) + + ; traceIf (text "buildDataCon 2" <+> ppr src_name) + ; return data_con } + + +-- The stupid context for a data constructor should be limited to +-- the type variables mentioned in the arg_tys +-- ToDo: Or functionally dependent on? +-- This whole stupid theta thing is, well, stupid. +mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType] +mkDataConStupidTheta tycon arg_tys univ_tvs + | null stupid_theta = [] -- The common case + | otherwise = filter in_arg_tys stupid_theta + where + tc_subst = zipTvSubst (tyConTyVars tycon) + (mkTyVarTys univ_tvs) + stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) + -- Start by instantiating the master copy of the + -- stupid theta, taken from the TyCon + + arg_tyvars = tyCoVarsOfTypes arg_tys + in_arg_tys pred = not $ isEmptyVarSet $ + tyCoVarsOfType pred `intersectVarSet` arg_tyvars + + +------------------------------------------------------ +buildPatSyn :: Name -> Bool + -> (Id,Bool) -> Maybe (Id, Bool) + -> ([TyVarBinder], ThetaType) -- ^ Univ and req + -> ([TyVarBinder], ThetaType) -- ^ Ex and prov + -> [Type] -- ^ Argument types + -> Type -- ^ Result type + -> [FieldLabel] -- ^ Field labels for + -- a record pattern synonym + -> PatSyn +buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder + (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys + pat_ty field_labels + = -- The assertion checks that the matcher is + -- compatible with the pattern synonym + ASSERT2((and [ univ_tvs `equalLength` univ_tvs1 + , ex_tvs `equalLength` ex_tvs1 + , pat_ty `eqType` substTy subst pat_ty1 + , prov_theta `eqTypes` substTys subst prov_theta1 + , req_theta `eqTypes` substTys subst req_theta1 + , compareArgTys arg_tys (substTys subst arg_tys1) + ]) + , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1 + , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1 + , ppr pat_ty <+> twiddle <+> ppr pat_ty1 + , ppr prov_theta <+> twiddle <+> ppr prov_theta1 + , ppr req_theta <+> twiddle <+> ppr req_theta1 + , ppr arg_tys <+> twiddle <+> ppr arg_tys1])) + mkPatSyn src_name declared_infix + (univ_tvs, req_theta) (ex_tvs, prov_theta) + arg_tys pat_ty + matcher builder field_labels + where + ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id + ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau + (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma + (arg_tys1, _) = (tcSplitFunTys cont_tau) + twiddle = char '~' + subst = zipTvSubst (univ_tvs1 ++ ex_tvs1) + (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs))) + + -- For a nullary pattern synonym we add a single void argument to the + -- matcher to preserve laziness in the case of unlifted types. + -- See #12746 + compareArgTys :: [Type] -> [Type] -> Bool + compareArgTys [] [x] = x `eqType` voidPrimTy + compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys + + +------------------------------------------------------ +type TcMethInfo = MethInfo -- this variant needs zonking +type MethInfo -- A temporary intermediate, to communicate + -- between tcClassSigs and buildClass. + = ( Name -- Name of the class op + , Type -- Type of the class op + , Maybe (DefMethSpec (SrcSpan, Type))) + -- Nothing => no default method + -- + -- Just VanillaDM => There is an ordinary + -- polymorphic default method + -- + -- Just (GenericDM (loc, ty)) => There is a generic default metho + -- Here is its type, and the location + -- of the type signature + -- We need that location /only/ to attach it to the + -- generic default method's Name; and we need /that/ + -- only to give the right location of an ambiguity error + -- for the generic default method, spat out by checkValidClass + +buildClass :: Name -- Name of the class/tycon (they have the same Name) + -> [TyConBinder] -- Of the tycon + -> [Role] + -> [FunDep TyVar] -- Functional dependencies + -- Super classes, associated types, method info, minimal complete def. + -- This is Nothing if the class is abstract. + -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef) + -> TcRnIf m n Class + +buildClass tycon_name binders roles fds Nothing + = fixM $ \ rec_clas -> -- Only name generation inside loop + do { traceIf (text "buildClass") + + ; tc_rep_name <- newTyConRepName tycon_name + ; let univ_tvs = binderVars binders + tycon = mkClassTyCon tycon_name binders roles + AbstractTyCon rec_clas tc_rep_name + result = mkAbstractClass tycon_name univ_tvs fds tycon + ; traceIf (text "buildClass" <+> ppr tycon) + ; return result } + +buildClass tycon_name binders roles fds + (Just (sc_theta, at_items, sig_stuff, mindef)) + = fixM $ \ rec_clas -> -- Only name generation inside loop + do { traceIf (text "buildClass") + + ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc + ; tc_rep_name <- newTyConRepName tycon_name + + ; op_items <- mapM (mk_op_item rec_clas) sig_stuff + -- Build the selector id and default method id + + -- Make selectors for the superclasses + ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc) + (takeList sc_theta [fIRST_TAG..]) + ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas + | sc_name <- sc_sel_names] + -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we + -- can construct names for the selectors. Thus + -- class (C a, C b) => D a b where ... + -- gives superclass selectors + -- D_sc1, D_sc2 + -- (We used to call them D_C, but now we can have two different + -- superclasses both called C!) + + ; let use_newtype = isSingleton arg_tys + -- Use a newtype if the data constructor + -- (a) has exactly one value field + -- i.e. exactly one operation or superclass taken together + -- (b) that value is of lifted type (which they always are, because + -- we box equality superclasses) + -- See note [Class newtypes and equality predicates] + + -- We treat the dictionary superclasses as ordinary arguments. + -- That means that in the case of + -- class C a => D a + -- we don't get a newtype with no arguments! + args = sc_sel_names ++ op_names + op_tys = [ty | (_,ty,_) <- sig_stuff] + op_names = [op | (op,_,_) <- sig_stuff] + arg_tys = sc_theta ++ op_tys + rec_tycon = classTyCon rec_clas + univ_bndrs = tyConTyVarBinders binders + univ_tvs = binderVars univ_bndrs + + ; rep_nm <- newTyConRepName datacon_name + ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs") + datacon_name + False -- Not declared infix + rep_nm + (map (const no_bang) args) + (Just (map (const HsLazy) args)) + [{- No fields -}] + univ_tvs + [{- no existentials -}] + univ_bndrs + [{- No GADT equalities -}] + [{- No theta -}] + arg_tys + (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) + rec_tycon + (mkTyConTagMap rec_tycon) + + ; rhs <- case () of + _ | use_newtype + -> mkNewTyConRhs tycon_name rec_tycon dict_con + | isCTupleTyConName tycon_name + -> return (TupleTyCon { data_con = dict_con + , tup_sort = ConstraintTuple }) + | otherwise + -> return (mkDataTyConRhs [dict_con]) + + ; let { tycon = mkClassTyCon tycon_name binders roles + rhs rec_clas tc_rep_name + -- A class can be recursive, and in the case of newtypes + -- this matters. For example + -- class C a where { op :: C b => a -> b -> Int } + -- Because C has only one operation, it is represented by + -- a newtype, and it should be a *recursive* newtype. + -- [If we don't make it a recursive newtype, we'll expand the + -- newtype like a synonym, but that will lead to an infinite + -- type] + + ; result = mkClass tycon_name univ_tvs fds + sc_theta sc_sel_ids at_items + op_items mindef tycon + } + ; traceIf (text "buildClass" <+> ppr tycon) + ; return result } + where + no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict + + mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem + mk_op_item rec_clas (op_name, _, dm_spec) + = do { dm_info <- mk_dm_info op_name dm_spec + ; return (mkDictSelId op_name rec_clas, dm_info) } + + mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type)) + -> TcRnIf n m (Maybe (Name, DefMethSpec Type)) + mk_dm_info _ Nothing + = return Nothing + mk_dm_info op_name (Just VanillaDM) + = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc + ; return (Just (dm_name, VanillaDM)) } + mk_dm_info op_name (Just (GenericDM (loc, dm_ty))) + = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc + ; return (Just (dm_name, GenericDM dm_ty)) } + +{- +Note [Class newtypes and equality predicates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class (a ~ F b) => C a b where + op :: a -> b + +We cannot represent this by a newtype, even though it's not +existential, because there are two value fields (the equality +predicate and op. See #2238 + +Moreover, + class (a ~ F b) => C a b where {} +Here we can't use a newtype either, even though there is only +one field, because equality predicates are unboxed, and classes +are boxed. +-} + +newImplicitBinder :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> TcRnIf m n Name -- Implicit name +-- Called in GHC.Tc.TyCl.Build to allocate the implicit binders of type/class decls +-- For source type/class decls, this is the first occurrence +-- For iface ones, GHC.Iface.Load has already allocated a suitable name in the cache +newImplicitBinder base_name mk_sys_occ + = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name) + +newImplicitBinderLoc :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> SrcSpan + -> TcRnIf m n Name -- Implicit name +-- Just the same, but lets you specify the SrcSpan +newImplicitBinderLoc base_name mk_sys_occ loc + | Just mod <- nameModule_maybe base_name + = newGlobalBinder mod occ loc + | otherwise -- When typechecking a [d| decl bracket |], + -- TH generates types, classes etc with Internal names, + -- so we follow suit for the implicit binders + = do { uniq <- newUnique + ; return (mkInternalName uniq occ loc) } + where + occ = mk_sys_occ (nameOccName base_name) + +-- | Make the 'TyConRepName' for this 'TyCon' +newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName +newTyConRepName tc_name + | Just mod <- nameModule_maybe tc_name + , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name) + = newGlobalBinder mod occ noSrcSpan + | otherwise + = newImplicitBinder tc_name mkTyConRepOcc diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs new file mode 100644 index 0000000000..55105f84ff --- /dev/null +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -0,0 +1,554 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking class declarations +module GHC.Tc.TyCl.Class + ( tcClassSigs + , tcClassDecl2 + , findMethodBind + , instantiateMethod + , tcClassMinimalDef + , HsSigFun + , mkHsSigFun + , badMethodErr + , instDeclCtxt1 + , instDeclCtxt2 + , instDeclCtxt3 + , tcATDefault + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Hs +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Sig +import GHC.Tc.Types.Evidence ( idHsWrapper ) +import GHC.Tc.Gen.Bind +import GHC.Tc.Utils.Unify +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.TcMType +import GHC.Core.Type ( piResultTys ) +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad +import GHC.Driver.Phases (HscSource(..)) +import GHC.Tc.TyCl.Build( TcMethInfo ) +import GHC.Core.Class +import GHC.Core.Coercion ( pprCoAxiom ) +import GHC.Driver.Session +import GHC.Tc.Instance.Family +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 GHC.Tc.Gen.Bind.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/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs new file mode 100644 index 0000000000..84278082e3 --- /dev/null +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -0,0 +1,2179 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking instance declarations +module GHC.Tc.TyCl.Instance + ( tcInstDecls1 + , tcInstDeclsDeriv + , tcInstDecls2 + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Hs +import GHC.Tc.Gen.Bind +import GHC.Tc.TyCl +import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv ) +import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault, + HsSigFun, mkHsSigFun, badMethodErr, + findMethodBind, instantiateMethod ) +import GHC.Tc.Gen.Sig +import GHC.Tc.Utils.Monad +import GHC.Tc.Validity +import GHC.Tc.Utils.Zonk +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.TyCl.Build +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated ) +import GHC.Core.InstEnv +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Tc.Deriv +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.Unify +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 GHC.Tc.Types.Evidence +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 GHC.Tc.TyCl + ; (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 GHC.Tc.TyCl, 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 GHC.Tc.TyCl 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 GHC.Tc.TyCl, 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 GHC.Tc.Utils.Unify.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 GHC.Tc.TyCl. + +* 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 GHC.Tc.TyCl.Utils.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 GHC.Tc.Solver 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 GHC.Tc.Validity.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 GHC.Tc.Solver.Interact.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 GHC.Tc.Solver.Canonical.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 GHC.Tc.Gen.Bind +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/GHC/Tc/TyCl/Instance.hs-boot b/compiler/GHC/Tc/TyCl/Instance.hs-boot new file mode 100644 index 0000000000..1e47211460 --- /dev/null +++ b/compiler/GHC/Tc/TyCl/Instance.hs-boot @@ -0,0 +1,16 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Tc.TyCl.Instance ( tcInstDecls1 ) where + +import GHC.Hs +import GHC.Tc.Types +import GHC.Tc.Utils.Env( InstInfo ) +import GHC.Tc.Deriv + +-- We need this because of the mutual recursion +-- between GHC.Tc.TyCl and GHC.Tc.TyCl.Instance +tcInstDecls1 :: [LInstDecl GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs new file mode 100644 index 0000000000..01b446c88b --- /dev/null +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -0,0 +1,1154 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking pattern synonym declarations +module GHC.Tc.TyCl.PatSyn + ( tcPatSynDecl + , tcPatSynBuilderBind + , tcPatSynBuilderOcc + , nonBidirectionalErr + ) +where + +import GhcPrelude + +import GHC.Hs +import GHC.Tc.Gen.Pat +import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Gen.Sig( emptyPragEnv, completeSigFromId ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Zonk +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 GHC.Tc.Gen.Bind +import GHC.Types.Basic +import GHC.Tc.Solver +import GHC.Tc.Utils.Unify +import GHC.Core.Predicate +import TysWiredIn +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Tc.TyCl.Build +import GHC.Types.Var.Set +import GHC.Types.Id.Make +import GHC.Tc.TyCl.Utils +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 GHC.Tc.Utils.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 GHC.Tc.Utils.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 GHC.Tc.Gen.Sig + ; 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/GHC/Tc/TyCl/PatSyn.hs-boot b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot new file mode 100644 index 0000000000..44be72781d --- /dev/null +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot @@ -0,0 +1,16 @@ +module GHC.Tc.TyCl.PatSyn where + +import GHC.Hs ( PatSynBind, LHsBinds ) +import GHC.Tc.Types ( TcM, TcSigInfo ) +import GHC.Tc.Utils.Monad ( 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/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs new file mode 100644 index 0000000000..80157caa0d --- /dev/null +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -0,0 +1,1059 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | 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. +module GHC.Tc.TyCl.Utils( + RolesInfo, + inferRoles, + checkSynCycles, + checkClassCycles, + + -- * Implicits + addTyConsToGblEnv, mkDefaultMethodType, + + -- * Record selectors + tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Bind( tcValBinds ) +import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) +import GHC.Tc.Utils.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 (GHC.Tc.TyCl.Instance.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 GHC.Tc.TyCl.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/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs new file mode 100644 index 0000000000..dcf6fc94b6 --- /dev/null +++ b/compiler/GHC/Tc/Types.hs @@ -0,0 +1,1728 @@ +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-2002 + +-} + +{-# LANGUAGE CPP, DeriveFunctor, ExistentialQuantification, GeneralizedNewtypeDeriving, + ViewPatterns #-} + +-- | Various types used during typechecking. +-- +-- Please see GHC.Tc.Utils.Monad 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. +module GHC.Tc.Types( + 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 GHC.Tc.Types.Evidence +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 GHC.Tc.Utils.TcType +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +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 #-} GHC.Tc.Errors.Hole.FitTypes ( 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 GHC.Tc.Utils.Monad +* * +************************************************************************ + +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 GHC.Tc.Utils.Env +-- +-- - 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.Module + + +{- 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 GHC.Tc.Types.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 GHC.Tc.Gen.Splice + +{- 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 GHC.Tc.Gen.Splice + -- 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 "GHC.Tc.Gen.Splice". + + | 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 GHC.Tc.Gen.Splice + -- 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 'GHC.Tc.Utils.Env' 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 GHC.Tc.Utils.Env. + | ConstrainedDataConPE PredType + -- Data constructor with a non-equality context + -- See Note [Don't promote data constructors with + -- non-equality contexts] in GHC.Tc.Gen.HsType + | PatSynPE -- Pattern synonyms + -- See Note [Don't promote pattern synonyms] in GHC.Tc.Utils.Env + + | RecDataConPE -- Data constructor in a recursive loop + -- See Note [Recursion and promoting data constructors] in GHC.Tc.TyCl + | 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 GHC.Tc.Gen.Expr.checkClosedInStaticForm and +-- b) to figure out when a nested binding can be generalised, +-- in GHC.Tc.Gen.Bind.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 GHC.Tc.Gen.Expr.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 +-- GHC.Tc.Solver uses them, and GHC.Tc.Solver 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 GHC.Tc.Gen.Sig + -- + -- 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 GHC.Tc.Gen.HsType.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 GHC.Tc.TyCl.Class. + +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 GHC.Tc.TyCl.PatSyn + 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/GHC/Tc/Types.hs-boot b/compiler/GHC/Tc/Types.hs-boot new file mode 100644 index 0000000000..8b8feac31e --- /dev/null +++ b/compiler/GHC/Tc/Types.hs-boot @@ -0,0 +1,12 @@ +module GHC.Tc.Types where + +import GHC.Tc.Utils.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/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs new file mode 100644 index 0000000000..3f85594c97 --- /dev/null +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -0,0 +1,1814 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | This module defines types and simple operations over constraints, as used +-- in the type-checker and constraint solver. +module GHC.Tc.Types.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 #-} GHC.Tc.Types ( 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 GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin + +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 (GHC.Tc.Solver.Canonical) + +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 GHC.Tc.Solver.Canonical + -- 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 GHC.Tc.Solver.Monad + -- * (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 GHC.Tc.Solver.Canonical + -- * (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 GHC.Tc.Solver.Flatten + } + + | CNonCanonical { -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad + 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 GHC.Tc.Solver.Canonical + = 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 GHC.Tc.Solver.Canonical). + +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 GHC.Tc.Solver.Flatten. + + 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 GHC.Tc.Utils.TcType. +The flattener (in GHC.Tc.Solver.Flatten) 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 GHC.Tc.Solver.Canonical. +-} + +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 GHC.Tc.Solver.Canonical. + +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 GHC.Tc.Types 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 GHC.Tc.Errors), 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 GHC.Tc.Solver.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 GHC.Tc.Utils.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 GHC.Tc.TyCl.Instance + + 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 GHC.Tc.Utils.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 GHC.Tc.Solver + + | 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 GHC.Tc.Solver.floatEqualities or +GHC.Tc.Solver.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 GHC.Tc.Solver.Monad.maybeEmitShadow. + +See Note [The improvement story and derived shadows] in GHC.Tc.Solver.Monad +-} + +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 GHC.Tc.Solver.Monad + 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 GHC.Tc.Solver.Monad +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 +GHC.Tc.Solver.Monad. + +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 GHC.Tc.Solver.Interact. + +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 GHC.Tc.Solver.Monad + 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 GHC.Tc.Solver.Monad. + +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/GHC/Tc/Types/EvTerm.hs b/compiler/GHC/Tc/Types/EvTerm.hs new file mode 100644 index 0000000000..db5c6d1ce1 --- /dev/null +++ b/compiler/GHC/Tc/Types/EvTerm.hs @@ -0,0 +1,71 @@ + +-- (those who have too heavy dependencies for GHC.Tc.Types.Evidence) +module GHC.Tc.Types.EvTerm + ( evDelayedError, evCallStack ) +where + +import GhcPrelude + +import FastString +import GHC.Core.Type +import GHC.Core +import GHC.Core.Make +import GHC.Types.Literal ( Literal(..) ) +import GHC.Tc.Types.Evidence +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 GHC.Tc.Solver +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 GHC.Tc.Types.Evidence +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/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs new file mode 100644 index 0000000000..cf59896f9d --- /dev/null +++ b/compiler/GHC/Tc/Types/Evidence.hs @@ -0,0 +1,1026 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Tc.Types.Evidence ( + + -- * 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 GHC.Tc.Utils.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 GHC.Tc.Solver + } + + | 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 GHC.Tc.Solver + } + +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 GHC.Tc.Types.EvTerm + +-- | 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 GHC.Tc.Types.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 GHC.Tc.Solver.Interact.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 GHC.Tc.Solver.simpl_top and GHC.Tc.Solver.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 GHC.Tc.Solver.Interact.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 GHC.Tc.Solver.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 GHC.Tc.Solver). + 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 GHC.Tc.Gen.Expr. +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/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs new file mode 100644 index 0000000000..139e416012 --- /dev/null +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -0,0 +1,651 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Describes the provenance of types as they flow through the type-checker. +-- The datatypes here are mainly used for error message generation. +module GHC.Tc.Types.Origin ( + -- 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 GHC.Tc.Utils.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 + -- GHC.Tc.Validity. + + | 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 GHC.Tc.TyCl.Instance + + | 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 GHC.Tc.Gen.Arrow) + + | 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 GHC.Tc.Utils.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 GHC.Tc.TyCl.Instance + + | 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 GHC.Tc.Deriv.Infer + | 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 GHC.Tc.Deriv.Infer + | 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/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs new file mode 100644 index 0000000000..93cb63812c --- /dev/null +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -0,0 +1,1011 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Tc.Utils.Backpack ( + findExtraSigImports', + findExtraSigImports, + implicitRequirements', + implicitRequirements, + checkUnitId, + tcRnCheckUnitId, + tcRnMergeSignatures, + mergeSignatures, + tcRnInstantiateSignature, + instantiateSignature, +) where + +import GhcPrelude + +import GHC.Types.Basic (defaultFixity, TypeOrKind(..)) +import GHC.Driver.Packages +import GHC.Tc.Gen.Export +import GHC.Driver.Session +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Tc.Utils.Monad +import GHC.Tc.TyCl.Utils +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Tc.Utils.Instantiate +import GHC.IfaceToCore +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Solver +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +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 GHC.Tc.Utils.Env +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 GHC.Tc.Errors +import GHC.Tc.Utils.Unify +import GHC.Iface.Rename +import Util + +import Control.Monad +import Data.List (find) + +import {-# SOURCE #-} GHC.Tc.Module + +#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 ("GHC.Tc.Module.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 +-- "GHC.Tc.Module". +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 "GHC.Tc.Module". +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/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs new file mode 100644 index 0000000000..0154ed157e --- /dev/null +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -0,0 +1,1110 @@ +-- (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 GHC.Tc.Utils.Env( + 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 GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.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 GHC.Tc.Gen.Expr.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 GHC.Tc.Types +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 GHC.Tc.Gen.HsType.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 GHC.Tc.Gen.Bind +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/GHC/Tc/Utils/Env.hs-boot b/compiler/GHC/Tc/Utils/Env.hs-boot new file mode 100644 index 0000000000..7b1cde3c7d --- /dev/null +++ b/compiler/GHC/Tc/Utils/Env.hs-boot @@ -0,0 +1,10 @@ +module GHC.Tc.Utils.Env where + +import GHC.Tc.Types( TcM ) +import GHC.Types.Var.Env( TidyEnv ) + +-- Annoyingly, there's a recursion between tcInitTidyEnv +-- (which does zonking and hence needs GHC.Tc.Utils.TcMType) and +-- addErrTc etc which live in GHC.Tc.Utils.Monad. Rats. +tcInitTidyEnv :: TcM TidyEnv + diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs new file mode 100644 index 0000000000..74115d15b0 --- /dev/null +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -0,0 +1,852 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, MultiWayIf, TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | The @Inst@ type: dictionaries or method instances +module GHC.Tc.Utils.Instantiate ( + 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 #-} GHC.Tc.Gen.Expr( tcPolyExpr, tcSyntaxOp ) +import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType, unifyKind ) + +import GHC.Types.Basic ( IntegralLit(..), SourceText(..) ) +import FastString +import GHC.Hs +import GHC.Tc.Utils.Zonk +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Evidence +import GHC.Core.InstEnv +import TysWiredIn ( heqDataCon, eqDataCon ) +import GHC.Core ( isOrphan ) +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Utils.TcMType +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr ( debugPprType ) +import GHC.Tc.Utils.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 GHC.Tc.Utils.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 GHC.Tc.Utils.Unify +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 GHC.Tc.Utils.Env.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/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs new file mode 100644 index 0000000000..bd52015c89 --- /dev/null +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -0,0 +1,1998 @@ +{- +(c) The University of Glasgow 2006 + +-} + +{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE ViewPatterns #-} + + +-- | Functions for working with the typechecker environment (setters, +-- getters...). +module GHC.Tc.Utils.Monad( + -- * 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 GHC.Tc.Types, + module IOEnv + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Tc.Types -- Re-export all +import IOEnv -- Re-export all +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin + +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 GHC.Tc.Utils.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 #-} GHC.Tc.Utils.Env ( 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 GHC.Tc.Types.Evidence), 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 GHC.Tc.Utils.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 GHC.Tc.Utils.Unify.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/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs new file mode 100644 index 0000000000..1469170847 --- /dev/null +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -0,0 +1,2419 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, TupleSections, MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Monadic type operations +-- +-- This module contains monadic operations over types that contain mutable type +-- variables. +module GHC.Tc.Utils.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 GHC.Tc.Utils.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 GHC.Tc.Types.Origin + +-- others: +import GHC.Tc.Utils.Monad -- TcType, amongst others +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +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 GHC.Tc.TyCl.Instance. +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 GHC.Tc.Gen.Match. +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 GHC.Tc.Utils.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 GHC.Tc.Instance.Family.newFamInst, and Inst.newClsInst +freshenTyVarBndrs = freshenTyCoVars mkTyVar + +freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar]) +-- ^ Give fresh uniques to a bunch of CoVars +-- Used in GHC.Tc.Instance.Family.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 GHC.Tc.Deriv.Infer 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 + GHC.Tc.TyCl 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 GHC.Tc.Utils.Unify.nicer_to_update_tv1, and +-- GHC.Tc.Solver.Canonical.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 GHC.Tc.Gen.HsType + -- 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 GHC.Tc.Utils.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 GHC.Tc.Gen.HsType). + + * 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 GHC.Tc.Utils.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 GHC.Tc.Solver.decideMonoTyVars and in +GHC.Tc.Gen.HsType.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 GHC.Tc.Utils.TcType. + -- #13343 is an example; #14555 is another + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + = 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 GHC.Tc.Gen.HsType + -- 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 GHC.Tc.Solver.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 GHC.Tc.Module.tcRnSrcDecls calling GHC.Tc.Solver.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 GHC.Tc.TyCl.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 + -- GHC.Tc.Gen.HsType.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 @GHC.Tc.Solver.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 +@GHC.Tc.Solver.Canonical@ 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 GHC.Tc.Utils.Zonk. + +%************************************************************************ +%* * + 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/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs new file mode 100644 index 0000000000..1f076e2101 --- /dev/null +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -0,0 +1,2489 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, ScopedTypeVariables, MultiWayIf, FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | 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 +-- +module GHC.Tc.Utils.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 GHC.Tc.Gen.HsType. + + - 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 GHC.Tc.Utils.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 GHC.Tc.Utils.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 GHC.Tc.Utils.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 GHC.Tc.Utils.Unify + + , 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 GHC.Tc.Gen.Expr boot file. +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 GHC.Tc.Utils.Unify 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 GHC.Tc.Solver.Flatten + + | 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 GHC.Tc.Solver.Flatten + +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 "GHC.Tc.Errors". +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 GHC.Tc.Utils.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 GHC.Tc.Errors; 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 GHC.Tc.Validity because it is +-- called from GHC.Tc.Solver, which itself is imported by GHC.Tc.Validity +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 GHC.Tc.TyCl.PatSyn) +-- +-- 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 GHC.Tc.TyCl.PatSyn + -- 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 +-- GHC.Tc.Solver.Canonical 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. GHC.Tc.Solver.Canonical.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 GHC.Tc.TyCl.Utils.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 GHC.Tc.Types +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/GHC/Tc/Utils/TcType.hs-boot b/compiler/GHC/Tc/Utils/TcType.hs-boot new file mode 100644 index 0000000000..481d261f79 --- /dev/null +++ b/compiler/GHC/Tc/Utils/TcType.hs-boot @@ -0,0 +1,8 @@ +module GHC.Tc.Utils.TcType where +import Outputable( SDoc ) + +data MetaDetails + +data TcTyVarDetails +pprTcTyVarDetails :: TcTyVarDetails -> SDoc +vanillaSkolemTv :: TcTyVarDetails diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs new file mode 100644 index 0000000000..f6d934af9a --- /dev/null +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -0,0 +1,2331 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections, + ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Type subsumption and unification +module GHC.Tc.Utils.Unify ( + -- 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 GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Types.Name( isSystemName ) +import GHC.Tc.Utils.Instantiate +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 GHC.Tc.Gen.Expr.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 GHC.Tc.Utils.Unify.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 GHC.Tc.Utils.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 GHC.Tc.Gen.Expr.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 GHC.Tc.Types.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 GHC.Tc.Errors. + 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 GHC.Tc.Solver.Canonical + -- 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 GHC.Tc.Utils.Unify.uUnfilledVar1 + - in the constraint solver, in GHC.Tc.Solver.Canonical.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, GHC.Tc.Solver.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 GHC.Tc.Solver.Monad 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 GHC.Tc.Solver.Interact, +function @occ_check_ok@. + +Note [Non-TcTyVars in GHC.Tc.Utils.Unify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 GHC.Tc.TyCl"). 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/GHC/Tc/Utils/Unify.hs-boot b/compiler/GHC/Tc/Utils/Unify.hs-boot new file mode 100644 index 0000000000..a281bf136b --- /dev/null +++ b/compiler/GHC/Tc/Utils/Unify.hs-boot @@ -0,0 +1,15 @@ +module GHC.Tc.Utils.Unify where + +import GhcPrelude +import GHC.Tc.Utils.TcType ( TcTauType ) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Evidence ( 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 +-- GHC.Tc.Utils.Unify and Inst + +unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion +unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs new file mode 100644 index 0000000000..057535d65d --- /dev/null +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -0,0 +1,1919 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + +-} + +{-# LANGUAGE CPP, TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Specialisations of the @HsSyn@ syntax for the typechecker +-- +-- This module is an extension of @HsSyn@ syntax, for use in the type checker. +module GHC.Tc.Utils.Zonk ( + -- * 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 GHC.Tc.Utils.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 GHC.Tc.Utils.Monad +import PrelNames +import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) +import GHC.Tc.Types.Evidence +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 #-} GHC.Tc.Gen.Splice (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 GHC.Tc.Utils.TcMType. + +-- | See Note [The ZonkEnv] +-- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.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 GHC.Tc.Utils.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 GHC.Tc.Utils.TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to + (Indirect zty), see Note [Sharing in zonking] in GHC.Tc.Utils.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 + GHC.Tc.TyCl. + + Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow + the same path as Note [Sharing in zonking] in GHC.Tc.Utils.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 GHC.Tc.Utils.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/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs new file mode 100644 index 0000000000..2fe9d16595 --- /dev/null +++ b/compiler/GHC/Tc/Validity.hs @@ -0,0 +1,2907 @@ +{- +(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 GHC.Tc.Validity ( + 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 GHC.Tc.Utils.Unify ( tcSubType_NC ) +import GHC.Tc.Solver ( simplifyAmbiguityCheck ) +import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Tc.Utils.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 GHC.Tc.Types.Origin + +-- others: +import GHC.Iface.Type ( pprIfaceType, pprIfaceTypeApp ) +import GHC.CoreToIface ( toIfaceTyCon, toIfaceTcArgs, toIfaceType ) +import GHC.Hs +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env ( tcInitTidyEnv, tcInitOpenTidyEnv ) +import GHC.Tc.Instance.FunDeps +import GHC.Core.FamInstEnv + ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) ) +import GHC.Tc.Instance.Family +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 GHC.Tc.Gen.Bind. + +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 'GHC.Tc.Instance.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 GHC.Tc.Utils.TcType.pickQuantifiablePreds, as described + -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.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 GHC.Tc.Solver.Interact +Note [Instance and Given overlap]. As that Note discusses, for the +most part the clever stuff in GHC.Tc.Solver.Interact 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 +GHC.Tc.Solver.Interact.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 GHC.Tc.Instance.Class. + +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 GHC.Tc.Deriv.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 GHC.Tc.Solver.Interact). 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 GHC.Tc.Deriv. 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 GHC.Tc.TyCl.) + + 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 GHC.Tc.TyCl. + * Note [Checking telescopes] in GHC.Tc.Types.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 |