From bbb2c6c36b6690c3b3419d9f0859b35b770ee010 Mon Sep 17 00:00:00 2001 From: Artyom Kuznetsov Date: Thu, 25 Feb 2021 11:21:13 +0300 Subject: Remove NoGhcTc from most places (#18758) --- compiler/GHC/Hs/Expr.hs | 4 +- compiler/GHC/Hs/Instances.hs | 2 + compiler/GHC/Hs/Pat.hs | 2 +- compiler/GHC/Hs/Type.hs | 182 +++++++++++++++++++++--------- compiler/GHC/Hs/Utils.hs | 29 +++-- compiler/GHC/HsToCore/Expr.hs | 2 +- compiler/GHC/Iface/Ext/Ast.hs | 36 +++++- compiler/GHC/Tc/Gen/Bind.hs | 5 +- compiler/GHC/Tc/Gen/Foreign.hs | 4 +- compiler/GHC/Tc/Gen/Head.hs | 37 +++--- compiler/GHC/Tc/Gen/HsType.hs | 108 +++++++++++------- compiler/GHC/Tc/Gen/Pat.hs | 10 +- compiler/GHC/Tc/Gen/Rule.hs | 21 ++-- compiler/GHC/Tc/Gen/Sig.hs | 28 +++-- compiler/GHC/Tc/TyCl.hs | 3 +- compiler/GHC/Tc/TyCl/Class.hs | 7 +- compiler/GHC/Tc/TyCl/Instance.hs | 17 +-- compiler/GHC/Tc/Types.hs | 1 - compiler/GHC/Tc/Utils/Zonk.hs | 10 +- compiler/Language/Haskell/Syntax/Decls.hs | 2 +- compiler/Language/Haskell/Syntax/Expr.hs | 4 +- compiler/Language/Haskell/Syntax/Pat.hs | 4 +- compiler/Language/Haskell/Syntax/Type.hs | 14 ++- utils/haddock | 2 +- 24 files changed, 360 insertions(+), 174 deletions(-) diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 9d3e3dcf39..7798e9c6aa 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -253,7 +253,7 @@ type instance XApp (GhcPass _) = ApiAnnCO type instance XAppTypeE GhcPs = SrcSpan -- Where the `@` lives type instance XAppTypeE GhcRn = NoExtField -type instance XAppTypeE GhcTc = Type +type instance XAppTypeE GhcTc = NoExtField -- OpApp not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs] @@ -661,7 +661,7 @@ ppr_infix_expr _ = Nothing ppr_apps :: (OutputableBndrId p) => HsExpr (GhcPass p) - -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] + -> [Either (LHsExpr (GhcPass p)) (LHsWcType (GhcPass p))] -> SDoc ppr_apps (HsApp _ (L _ fun) arg) args = ppr_apps fun (Left arg : args) diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 68b55196ca..ee45252f96 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -475,6 +475,8 @@ deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) +deriving instance Data HsTypeTc + -- deriving instance (DataIdLR p p) => Data (HsArrow p) deriving instance Data (HsArrow GhcPs) deriving instance Data (HsArrow GhcRn) diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index c5cd2ccb78..e13eae4c50 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -145,7 +145,7 @@ type instance XNPlusKPat GhcTc = Type type instance XSigPat GhcPs = ApiAnn type instance XSigPat GhcRn = NoExtField -type instance XSigPat GhcTc = Type +type instance XSigPat GhcTc = NoExtField type instance XXPat GhcPs = NoExtCon type instance XXPat GhcRn = NoExtCon diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 59fcaf9fe1..b65c48d1d2 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -24,9 +24,9 @@ module GHC.Hs.Type ( Mult, HsScaled(..), hsMult, hsScaledThing, HsArrow(..), arrowToHsType, - hsLinear, hsUnrestricted, isUnrestricted, + hsLinear, hsUnrestricted, isUnrestricted, hsTypeTc, hsBndrToBndr, - HsType(..), HsCoreTy, LHsType, HsKind, LHsKind, + HsType(..), HsTypeTc(..), HsCoreTy, LHsType, HsKind, LHsKind, HsForAllTelescope(..), ApiAnnForallTy, HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, @@ -101,7 +101,7 @@ import GHC.Types.Id ( Id ) import GHC.Types.SourceText import GHC.Types.Name( Name, NamedThing(getName) ) import GHC.Types.Name.Reader ( RdrName ) -import GHC.Types.Var ( VarBndr ) +import GHC.Types.Var ( VarBndr(..) ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr ) import GHC.Core.Type @@ -190,7 +190,7 @@ type instance XHsOuterImplicit GhcTc = [TyVar] type instance XHsOuterExplicit GhcPs _ = ApiAnnForallTy type instance XHsOuterExplicit GhcRn _ = NoExtField -type instance XHsOuterExplicit GhcTc flag = [VarBndr TyVar flag] +type instance XHsOuterExplicit GhcTc _ = NoExtField type instance XXHsOuterTyVarBndrs (GhcPass _) = NoExtCon @@ -221,7 +221,7 @@ hsOuterTyVarNames (HsOuterImplicit{hso_ximplicit = imp_tvs}) = imp_tvs hsOuterTyVarNames (HsOuterExplicit{hso_bndrs = bndrs}) = hsLTyVarNames bndrs hsOuterExplicitBndrs :: HsOuterTyVarBndrs flag (GhcPass p) - -> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))] + -> [LHsTyVarBndr flag (GhcPass p)] hsOuterExplicitBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = bndrs hsOuterExplicitBndrs (HsOuterImplicit{}) = [] @@ -283,47 +283,83 @@ instance NamedThing (HsTyVarBndr flag GhcRn) where getName (UserTyVar _ _ v) = unLoc v getName (KindedTyVar _ _ v _) = unLoc v -type instance XForAllTy (GhcPass _) = NoExtField -type instance XQualTy (GhcPass _) = NoExtField -type instance XTyVar (GhcPass _) = ApiAnn -type instance XAppTy (GhcPass _) = NoExtField -type instance XFunTy (GhcPass _) = ApiAnn' TrailingAnn -- For the AnnRarrow or AnnLolly -type instance XListTy (GhcPass _) = ApiAnn' AnnParen -type instance XTupleTy (GhcPass _) = ApiAnn' AnnParen -type instance XSumTy (GhcPass _) = ApiAnn' AnnParen -type instance XOpTy (GhcPass _) = NoExtField -type instance XParTy (GhcPass _) = ApiAnn' AnnParen -type instance XIParamTy (GhcPass _) = ApiAnn -type instance XStarTy (GhcPass _) = NoExtField -type instance XKindSig (GhcPass _) = ApiAnn - -type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives +type instance XForAllTy GhcPs = NoExtField +type instance XForAllTy GhcRn = NoExtField +type instance XForAllTy GhcTc = NoExtCon +type instance XQualTy GhcPs = NoExtField +type instance XQualTy GhcRn = NoExtField +type instance XQualTy GhcTc = NoExtCon +type instance XTyVar GhcPs = ApiAnn +type instance XTyVar GhcRn = ApiAnn +type instance XTyVar GhcTc = NoExtCon +type instance XAppTy GhcPs = NoExtField +type instance XAppTy GhcRn = NoExtField +type instance XAppTy GhcTc = NoExtCon +type instance XFunTy GhcPs = ApiAnn' TrailingAnn -- For the AnnRarrow or AnnLolly +type instance XFunTy GhcRn = ApiAnn' TrailingAnn +type instance XFunTy GhcTc = NoExtCon +type instance XListTy GhcPs = ApiAnn' AnnParen +type instance XListTy GhcRn = ApiAnn' AnnParen +type instance XListTy GhcTc = NoExtCon +type instance XTupleTy GhcPs = ApiAnn' AnnParen +type instance XTupleTy GhcRn = ApiAnn' AnnParen +type instance XTupleTy GhcTc = NoExtCon +type instance XSumTy GhcPs = ApiAnn' AnnParen +type instance XSumTy GhcRn = ApiAnn' AnnParen +type instance XSumTy GhcTc = NoExtCon +type instance XOpTy GhcPs = NoExtField +type instance XOpTy GhcRn = NoExtField +type instance XOpTy GhcTc = NoExtCon +type instance XParTy GhcPs = ApiAnn' AnnParen +type instance XParTy GhcRn = ApiAnn' AnnParen +type instance XParTy GhcTc = NoExtCon +type instance XIParamTy GhcPs = ApiAnn +type instance XIParamTy GhcRn = ApiAnn +type instance XIParamTy GhcTc = NoExtCon +type instance XStarTy GhcPs = NoExtField +type instance XStarTy GhcRn = NoExtField +type instance XStarTy GhcTc = NoExtCon +type instance XKindSig GhcPs = ApiAnn +type instance XKindSig GhcRn = ApiAnn +type instance XKindSig GhcTc = NoExtCon + +type instance XAppKindTy GhcPs = SrcSpan -- Where the `@` lives +type instance XAppKindTy GhcRn = SrcSpan +type instance XAppKindTy GhcTc = NoExtCon type instance XSpliceTy GhcPs = NoExtField type instance XSpliceTy GhcRn = NoExtField -type instance XSpliceTy GhcTc = Kind - -type instance XDocTy (GhcPass _) = ApiAnn -type instance XBangTy (GhcPass _) = ApiAnn - +type instance XSpliceTy GhcTc = NoExtCon + +type instance XDocTy GhcPs = ApiAnn +type instance XDocTy GhcRn = ApiAnn +type instance XDocTy GhcTc = NoExtCon +type instance XBangTy GhcPs = ApiAnn +type instance XBangTy GhcRn = ApiAnn +type instance XBangTy GhcTc = NoExtCon type instance XRecTy GhcPs = ApiAnn' AnnList type instance XRecTy GhcRn = NoExtField -type instance XRecTy GhcTc = NoExtField +type instance XRecTy GhcTc = NoExtCon type instance XExplicitListTy GhcPs = ApiAnn type instance XExplicitListTy GhcRn = NoExtField -type instance XExplicitListTy GhcTc = Kind +type instance XExplicitListTy GhcTc = NoExtCon type instance XExplicitTupleTy GhcPs = ApiAnn type instance XExplicitTupleTy GhcRn = NoExtField -type instance XExplicitTupleTy GhcTc = [Kind] - -type instance XTyLit (GhcPass _) = NoExtField +type instance XExplicitTupleTy GhcTc = NoExtCon -type instance XWildCardTy (GhcPass _) = NoExtField +type instance XTyLit GhcPs = NoExtField +type instance XTyLit GhcRn = NoExtField +type instance XTyLit GhcTc = NoExtCon -type instance XXType (GhcPass _) = HsCoreTy +type instance XWildCardTy GhcPs = NoExtField +type instance XWildCardTy GhcRn = NoExtField +type instance XWildCardTy GhcTc = NoExtCon +type instance XXType GhcPs = HsCoreTy +type instance XXType GhcRn = HsCoreTy +type instance XXType GhcTc = HsTypeTc oneDataConHsTy :: HsType GhcRn oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName) @@ -335,6 +371,36 @@ isUnrestricted :: HsArrow GhcRn -> Bool isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName isUnrestricted _ = False +hsTypeTc :: HsType GhcTc -> HsTypeTc +hsTypeTc t = case t of + HsForAllTy v _ _ -> noExtCon v + HsQualTy v _ _-> noExtCon v + HsTyVar v _ _ -> noExtCon v + HsAppTy v _ _ -> noExtCon v + HsAppKindTy v _ _ -> noExtCon v + HsFunTy v _ _ _ -> noExtCon v + HsListTy v _ -> noExtCon v + HsTupleTy v _ _ -> noExtCon v + HsSumTy v _ -> noExtCon v + HsOpTy v _ _ _ -> noExtCon v + HsParTy v _ -> noExtCon v + HsIParamTy v _ _ -> noExtCon v + HsKindSig v _ _ -> noExtCon v + HsSpliceTy v _ -> noExtCon v + HsDocTy v _ _ -> noExtCon v + HsBangTy v _ _ -> noExtCon v + HsRecTy v _ -> noExtCon v + HsExplicitListTy v _ _ -> noExtCon v + HsExplicitTupleTy v _ -> noExtCon v + HsTyLit v _ -> noExtCon v + HsWildCardTy v -> noExtCon v + HsStarTy v _ -> noExtCon v + XHsType t -> t + +hsBndrToBndr :: HsTyVarBndr flag GhcTc -> VarBndr TyVar flag +hsBndrToBndr (UserTyVar _ flag v) = Bndr (unLoc v) flag +hsBndrToBndr (KindedTyVar _ flag v _) = Bndr (unLoc v) flag + -- | Convert an arrow into its corresponding multiplicity. In essence this -- erases the information of whether the programmer wrote an explicit -- multiplicity or a shorthand. @@ -441,16 +507,16 @@ ignoreParens ty = ty mkAnonWildCardTy :: HsType GhcPs mkAnonWildCardTy = HsWildCardTy noExtField -mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN) +mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN, XOpTy (GhcPass p) ~ NoExtField) => LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p)) -> LHsType (GhcPass p) -> HsType (GhcPass p) mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2 -mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +mkHsAppTy :: (XAppTy (GhcPass p) ~ NoExtField, XParTy (GhcPass p) ~ ApiAnn' AnnParen, IsPass p) => LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) mkHsAppTy t1 t2 = addCLocAA t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2)) -mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] +mkHsAppTys :: (XAppTy (GhcPass p) ~ NoExtField, XParTy (GhcPass p) ~ ApiAnn' AnnParen, IsPass p) => LHsType (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) mkHsAppTys = foldl' mkHsAppTy @@ -472,8 +538,11 @@ mkHsAppKindTy ext ty k -- Breaks up any parens in the result type: -- splitHsFunType (a -> (b -> c)) = ([a,b], c) -- It returns API Annotations for any parens removed -splitHsFunType :: - LHsType (GhcPass p) +splitHsFunType + :: ( XFunTy (GhcPass p) ~ ApiAnn' TrailingAnn + , XParTy (GhcPass p) ~ ApiAnn' AnnParen + ) + => LHsType (GhcPass p) -> ( [AddApiAnn], ApiAnnComments -- The locations of any parens and -- comments discarded , [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p)) @@ -532,17 +601,17 @@ lhsTypeArgSrcSpan arg = case arg of -- type (parentheses and all) from them. splitLHsPatSynTy :: LHsSigType (GhcPass p) - -> ( [LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))] -- universals - , Maybe (LHsContext (GhcPass p)) -- required constraints - , [LHsTyVarBndr Specificity (GhcPass p)] -- existentials - , Maybe (LHsContext (GhcPass p)) -- provided constraints - , LHsType (GhcPass p)) -- body type + -> ( [LHsTyVarBndr Specificity (GhcPass p)] -- universals + , Maybe (LHsContext (GhcPass p)) -- required constraints + , [LHsTyVarBndr Specificity (GhcPass p)] -- existentials + , Maybe (LHsContext (GhcPass p)) -- provided constraints + , LHsType (GhcPass p)) -- body type splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) where -- split_sig_ty :: - -- LHsSigType (GhcPass p) - -- -> ([LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))], LHsType (GhcPass p)) - split_sig_ty (L _ HsSig{sig_bndrs = outer_bndrs, sig_body = body}) = + -- LHsSigType (GhcPass p) + -- -> ([LHsTyVarBndr Specificity (GhcPass p)], LHsType (GhcPass p)) + split_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) = case outer_bndrs of -- NB: Use ignoreParens here in order to be consistent with the use of -- splitLHsForAllTyInvis below, which also looks through parentheses. @@ -1027,7 +1096,7 @@ ppr_mono_lty :: OutputableBndrId p => LHsType (GhcPass p) -> SDoc ppr_mono_lty ty = ppr_mono_ty (unLoc ty) -ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc +ppr_mono_ty :: forall p. (OutputableBndrId p) => HsType (GhcPass p) -> SDoc ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty }) = sep [pprHsForAll tele Nothing, ppr_mono_lty ty] @@ -1093,7 +1162,13 @@ ppr_mono_ty (HsDocTy _ ty doc) -- we pretty print Haddock comments on types as if they were -- postfix operators -ppr_mono_ty (XHsType t) = ppr t +ppr_mono_ty (XHsType thing) = + case ghcPass @p of + GhcPs -> ppr thing + GhcRn -> ppr thing + GhcTc -> ppr thing + -- otherwise GHC is not convinced that 'XXType (GhcPass p)' has an Outputable + -------------------------- ppr_fun_ty :: (OutputableBndrId p) @@ -1108,9 +1183,10 @@ ppr_fun_ty mult ty1 ty2 -------------------------- -- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses -- under precedence @p@. -hsTypeNeedsParens :: PprPrec -> HsType (GhcPass p) -> Bool +hsTypeNeedsParens :: IsPass p => PprPrec -> HsType (GhcPass p) -> Bool hsTypeNeedsParens p = go_hs_ty where + go_hs_ty :: forall p. IsPass p => HsType (GhcPass p) -> Bool go_hs_ty (HsForAllTy{}) = p >= funPrec go_hs_ty (HsQualTy{}) = p >= funPrec go_hs_ty (HsBangTy{}) = p > topPrec @@ -1145,7 +1221,11 @@ hsTypeNeedsParens p = go_hs_ty go_hs_ty (HsOpTy{}) = p >= opPrec go_hs_ty (HsParTy{}) = False go_hs_ty (HsDocTy _ (L _ t) _) = go_hs_ty t - go_hs_ty (XHsType ty) = go_core_ty ty + go_hs_ty (XHsType ty) = + case ghcPass @p of + GhcPs -> go_core_ty ty + GhcRn -> go_core_ty ty + GhcTc -> let (HsTypeTc _ ty') = ty in go_hs_ty ty' go_core_ty (TyVarTy{}) = False go_core_ty (AppTy{}) = p >= appPrec @@ -1202,7 +1282,7 @@ lhsTypeHasLeadingPromotionQuote ty -- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is -- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply -- returns @ty@. -parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) +parenthesizeHsType :: (XParTy (GhcPass p) ~ ApiAnn' AnnParen, IsPass p) => PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) parenthesizeHsType p lty@(L loc ty) | hsTypeNeedsParens p ty = L loc (HsParTy noAnn lty) | otherwise = lty @@ -1211,7 +1291,7 @@ parenthesizeHsType p lty@(L loc ty) -- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@ -- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply -- returns @ctxt@ unchanged. -parenthesizeHsContext :: PprPrec +parenthesizeHsContext :: (XParTy (GhcPass p) ~ ApiAnn' AnnParen, IsPass p) => PprPrec -> LHsContext (GhcPass p) -> LHsContext (GhcPass p) parenthesizeHsContext p lctxt@(L loc ctxt) = case ctxt of diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 7e298b8978..3a2e886ddf 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -604,18 +604,28 @@ nlHsCase expr matches = noLocA (HsCase noAnn expr (mkMatchGroup Generated (noLocA matches))) nlList exprs = noLocA (ExplicitList noAnn exprs) -nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -nlHsTyVar :: IsSrcSpanAnn p a +nlHsAppTy :: (XAppTy (GhcPass p) ~ NoExtField, XParTy (GhcPass p) ~ ApiAnn' AnnParen, IsPass p) + => LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsTyVar :: (XTyVar (GhcPass p) ~ ApiAnn, XParTy (GhcPass p) ~ ApiAnn' AnnParen, IsSrcSpanAnn p a) => IdP (GhcPass p) -> LHsType (GhcPass p) -nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsFunTy :: (XFunTy (GhcPass p) ~ ApiAnn' TrailingAnn, XParTy (GhcPass p) ~ ApiAnn' AnnParen, IsPass p) + => LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsParTy :: (XParTy (GhcPass p) ~ ApiAnn' AnnParen) + => LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsAppTy f t = noLocA (HsAppTy noExtField f (parenthesizeHsType appPrec t)) nlHsTyVar x = noLocA (HsTyVar noAnn NotPromoted (noLocA x)) nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) (parenthesizeHsType funPrec a) b) nlHsParTy t = noLocA (HsParTy noAnn t) -nlHsTyConApp :: IsSrcSpanAnn p a +nlHsTyConApp :: ( IsSrcSpanAnn p a + , XAppTy (GhcPass p) ~ NoExtField + , XParTy (GhcPass p) ~ ApiAnn' AnnParen + , XOpTy (GhcPass p) ~ NoExtField + , XTyVar (GhcPass p) ~ ApiAnn + , XAppKindTy (GhcPass p) ~ SrcSpan + , IsPass p + ) => LexicalFixity -> IdP (GhcPass p) -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p) nlHsTyConApp fixity tycon tys @@ -625,14 +635,19 @@ nlHsTyConApp fixity tycon tys | otherwise = foldl' mk_app (nlHsTyVar tycon) tys where - mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p) + mk_app :: ( XAppTy (GhcPass p) ~ NoExtField + , XParTy (GhcPass p) ~ ApiAnn' AnnParen + , XOpTy (GhcPass p) ~ NoExtField + , XAppKindTy (GhcPass p) ~ SrcSpan + , IsPass p + ) => LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p) mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg -- parenthesize things like `(A + B) C` mk_app fun (HsValArg ty) = noLocA (HsAppTy noExtField fun (parenthesizeHsType appPrec ty)) mk_app fun (HsTypeArg _ ki) = noLocA (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki)) mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun) -nlHsAppKindTy :: +nlHsAppKindTy :: (XAppKindTy (GhcPass p) ~ SrcSpan, XParTy (GhcPass p) ~ ApiAnn' AnnParen, IsPass p) => LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) nlHsAppKindTy f k = noLocA (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k)) diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index cdbf54889e..f858736cc1 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -1161,7 +1161,7 @@ dsHsWrapped orig_hs_expr go (wrap . wrap') hs_e } go wrap (HsConLikeOut _ (RealDataCon dc)) = go_head wrap (dataConWrapId dc) - go wrap (HsAppType ty hs_e _) = go_l (wrap . (\e -> App e (Type ty))) hs_e + go wrap (HsAppType _ hs_e ty) = go_l (wrap . (\e -> App e . Type . hsttc_type . hsTypeTc . unLoc . hswc_body $ ty)) hs_e go wrap (HsPar _ hs_e) = go_l wrap hs_e go wrap (HsVar _ (L _ var)) = go_head wrap var go wrap hs_e = do { e <- dsExpr hs_e; return (wrap e) } diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 6f894dfc1a..c4685a7f12 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -802,8 +802,8 @@ class ( IsPass p , ToHie (Context (Located (IdGhcP p))) , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p)))) , ToHie (RFContext (Located (FieldOcc (GhcPass p)))) - , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p)))) - , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p)))) + , ToHie (TScoped (LHsWcType (GhcPass p))) + , ToHie (TScoped (LHsSigWcType (GhcPass p))) , Anno (IdGhcP p) ~ SrcSpanAnnN ) => HiePass p where @@ -1029,8 +1029,8 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where HieRn -> [] #endif where - contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType (NoGhcTc (GhcPass p))) a (HsRecFields (GhcPass p) a) - -> HsConDetails (TScoped (HsPatSigType (NoGhcTc (GhcPass p)))) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) + contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType (GhcPass p)) a (HsRecFields (GhcPass p) a) + -> HsConDetails (TScoped (HsPatSigType (GhcPass p))) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) contextify (PrefixCon tyargs args) = PrefixCon (tScopes scope argscope tyargs) (patScopes rsp scope pscope args) where argscope = foldr combineScopes NoScope $ map mkLScopeA args contextify (InfixCon a b) = InfixCon a' b' @@ -1051,6 +1051,12 @@ instance ToHie (TScoped (HsPatSigType GhcRn)) where ] -- See Note [Scoping Rules for SigPat] +instance ToHie (TScoped (HsPatSigType GhcTc)) where + toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScopeA span) sc) (wcs++tvs) + , toHie body + ] + instance ( ToHie (LocatedA (body (GhcPass p))) , HiePass p , AnnoBody p body @@ -1658,6 +1664,13 @@ instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsSigType GhcRn)))) wh ] where span = loc a +instance ToHie (TScoped (HsWildCardBndrs GhcTc (LocatedA (HsSigType GhcTc)))) where + toHie (TS sc (HsWC names a)) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names + , toHie $ TS sc a + ] + where span = loc a + instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsType GhcRn)))) where toHie (TS sc (HsWC names a)) = concatM $ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names @@ -1665,6 +1678,13 @@ instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsType GhcRn)))) where ] where span = loc a +instance ToHie (TScoped (HsWildCardBndrs GhcTc (LocatedA (HsType GhcTc)))) where + toHie (TS sc (HsWC names a)) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names + , toHie a + ] + where span = loc a + instance ToHie (LocatedA (StandaloneKindSig GhcRn)) where toHie (L sp sig) = concatM [makeNodeA sig sp, toHie sig] @@ -1727,6 +1747,11 @@ instance ToHie (TScoped (LocatedA (HsSigType GhcRn))) where , toHie body ] +instance ToHie (TScoped (LocatedA (HsSigType GhcTc))) where + toHie (TS _ (L span t@HsSig{sig_body=body})) = concatM $ makeNodeA t span : + [ toHie body + ] + -- Check this instance Data flag => ToHie (TVScoped (HsOuterTyVarBndrs flag GhcRn)) where toHie (TVS tsc sc bndrs) = case bndrs of @@ -1812,6 +1837,9 @@ instance ToHie (LocatedA (HsType GhcRn)) where HsStarTy _ _ -> [] XHsType _ -> [] +instance ToHie (LocatedA (HsType GhcTc)) where + toHie (L l t) = concatM $ [makeNode t (locA l), toHie (L l (hsttc_rn . hsTypeTc $ t))] + instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where toHie (HsValArg tm) = toHie tm toHie (HsTypeArg _ ty) = toHie ty diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 27572b2a65..176401db7f 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -231,7 +231,8 @@ tcHsBootSigs binds sigs where f (L _ name) = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty - ; return (mkVanillaGlobal name sigma_ty) } + ; let ty = hsttc_type . hsTypeTc . unLoc . sig_body . unLoc . hswc_body $ sigma_ty + ; return (mkVanillaGlobal name ty) } -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) @@ -1436,7 +1437,7 @@ lookupMBI name ------------------- tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo tcLhsSigId no_gen (name, sig) - = do { inst_sig <- tcInstSig sig + = do { inst_sig <- fst <$> tcInstSig sig ; mono_id <- newSigLetBndr no_gen name inst_sig ; return (MBI { mbi_poly_name = name , mbi_sig = Just inst_sig diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index ce5b052a94..ac58163e3b 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -236,7 +236,7 @@ tcFImport :: LForeignDecl GhcRn tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty , fd_fi = imp_decl })) = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo) $ - do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + do { sig_ty <- hsttc_type . hsTypeTc . unLoc . sig_body . unLoc <$> tcHsSigType (ForSigCtxt nm) hs_ty ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty ; let -- Drop the foralls before inspecting the @@ -384,7 +384,7 @@ tcFExport :: ForeignDecl GhcRn 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 + sig_ty <- hsttc_type . hsTypeTc . unLoc . sig_body . unLoc <$> tcHsSigType (ForSigCtxt nm) hs_ty rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 2a442b3fd9..e968ebafef 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -289,8 +289,8 @@ rebuildHsApps fun ctxt (arg : args) = case arg of EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' } -> rebuildHsApps (HsApp noAnn lfun arg) ctxt' args - ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' } - -> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args + ETypeArg { eva_hs_ty = (HsWC names (L loc hs_ty)), eva_ty = ty, eva_ctxt = ctxt' } + -> rebuildHsApps (HsAppType noExtField lfun . HsWC names . L loc . XHsType $ HsTypeTc ty hs_ty) ctxt' args EPrag ctxt' p -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args EWrap (EPar ctxt') @@ -592,7 +592,9 @@ tcInferAmbiguousRecSelId lbl args mb_res_ty , EValArg { eva_arg = ValArg (L _ arg) } <- arg1 , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty - ; finish_ambiguous_selector lbl sig_tc_ty } + + ; finish_ambiguous_selector lbl . + hsttc_type . hsTypeTc . unLoc . sig_body . unLoc . hswc_body $ sig_tc_ty } | Just res_ty <- mb_res_ty , Just (arg_ty,_) <- tcSplitFunTy_maybe res_ty @@ -713,33 +715,40 @@ naughtyRecordSel lbl * * ********************************************************************* -} -tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn) +tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) tcExprWithSig expr hs_ty = do { sig_info <- checkNoErrs $ -- Avoid error cascade tcUserTypeSig loc hs_ty Nothing - ; (expr', poly_ty) <- tcExprSig expr sig_info - ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) } + ; (expr', poly_ty, sig_ty) <- tcExprSig expr sig_info + ; return (ExprWithTySig noExtField expr' sig_ty, poly_ty) } where loc = getLocA (dropWildCards hs_ty) -tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType) -tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) +tcExprSig :: LHsExpr GhcRn -> (TcIdSigInfo, Maybe (LHsSigWcType GhcTc)) + -> TcM (LHsExpr GhcTc, TcType, LHsSigWcType GhcTc) +tcExprSig expr (sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }), mty) = setSrcSpan loc $ -- Sets the location for the implication constraint do { let poly_ty = idType poly_id + ; ty <- case mty of + Just ty -> return ty + Nothing -> pprPanic "Got no HsSigWcType with CompleteSig" (ppr sig) ; (wrap, expr') <- tcSkolemiseScoped ExprSigCtxt poly_ty $ \rho_ty -> tcCheckMonoExprNC expr rho_ty - ; return (mkLHsWrap wrap expr', poly_ty) } + ; return (mkLHsWrap wrap expr', poly_ty, ty) } -tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) +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)) + do { (tclvl, wanted, (expr', sig_inst, mty)) <- pushLevelAndCaptureConstraints $ - do { sig_inst <- tcInstSig sig + do { (sig_inst, ty) <- tcInstSig sig ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $ tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ tcCheckPolyExprNC expr (sig_inst_tau sig_inst) - ; return (expr', sig_inst) } + ; return (expr', sig_inst, ty) } + ; ty <- case mty of + Just ty -> return ty + Nothing -> pprPanic "tcInstSig returned Nothing for PartialSig" (ppr sig) -- See Note [Partial expression signatures] ; let tau = sig_inst_tau sig_inst infer_mode | null (sig_inst_theta sig_inst) @@ -768,7 +777,7 @@ tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) <.> mkWpTyLams qtvs <.> mkWpLams givens <.> mkWpLet ev_binds - ; return (mkLHsWrap poly_wrap expr', my_sigma) } + ; return (mkLHsWrap poly_wrap expr', my_sigma, ty) } {- Note [Partial expression signatures] diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index f7ad3a2af6..3814869bbe 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -31,6 +31,7 @@ module GHC.Tc.Gen.HsType ( bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol, + binderVar', binderVars', binderVarWithF, bindOuterFamEqnTKBndrs, bindOuterFamEqnTKBndrs_Q_Tv, tcOuterTKBndrs, scopedSortOuter, @@ -362,11 +363,13 @@ pprSigCtxt ctxt hs_ty = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon) 2 (ppr hs_ty) -tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type +tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM (LHsSigWcType GhcTc) -- 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) +tcHsSigWcType ctxt sig_ty = do + sig_ty' <- tcHsSigType ctxt (dropWildCards sig_ty) + return $ HsWC (hswc_ext sig_ty) sig_ty' kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM () -- This is a special form of tcClassSigType that is used during the @@ -388,7 +391,7 @@ kcClassSigType names tcLHsType hs_ty liftedTypeKind ; return () } -tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type +tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM (LHsSigType GhcTc) -- Does not do validity checking tcClassSigType names sig_ty = addSigCtxt sig_ctxt sig_ty $ @@ -415,7 +418,7 @@ tcClassSigType names sig_ty sig_ctxt = funsSigCtxt names skol_info = SigTypeSkol sig_ctxt -tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type +tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM (LHsSigType GhcTc) -- Does validity checking -- See Note [Recipe for checking a signature] tcHsSigType ctxt sig_ty @@ -423,22 +426,23 @@ tcHsSigType ctxt sig_ty do { traceTc "tcHsSigType {" (ppr sig_ty) -- Generalise here: see Note [Kind generalisation] - ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (expectedKindInCtxt ctxt) + ; (implic, sig_ty') <- tc_lhs_sig_type skol_info sig_ty (expectedKindInCtxt ctxt) -- Float out constraints, failing fast if not possible -- See Note [Failure in local type signatures] in GHC.Tc.Solver ; traceTc "tcHsSigType 2" (ppr implic) ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic)) + ; let (L l (HsSig ext bndrs (L l' (XHsType (HsTypeTc ty hs_ty))))) = sig_ty' ; ty <- zonkTcType ty ; checkValidType ctxt ty ; traceTc "end tcHsSigType }" (ppr ty) - ; return ty } + ; return . L l . HsSig ext bndrs . L l' . XHsType $ HsTypeTc ty hs_ty } where skol_info = SigTypeSkol ctxt tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn - -> ContextKind -> TcM (Implication, TcType) + -> ContextKind -> TcM (Implication, LHsSigType GhcTc) -- Kind-checks/desugars an 'LHsSigType', -- solve equalities, -- and then kind-generalizes. @@ -468,7 +472,12 @@ tc_lhs_sig_type skol_info (L loc (HsSig { sig_bndrs = hs_outer_bndrs -- See Note [Skolem escape in type signatures] ; implic <- buildTvImplication skol_info kvs tc_lvl wanted - ; return (implic, mkInfForAllTys kvs ty1) } + ; let + (L loc' hs_ty') = hs_ty + sig_ty = + L loc . HsSig noExtField outer_bndrs + . L loc' . XHsType $ HsTypeTc (mkInfForAllTys kvs ty1) hs_ty' + ; return (implic, sig_ty) } {- Note [Skolem escape in type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2956,13 +2965,13 @@ tcTKTelescope mode tele thing_inside = case tele of -> do { (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside -- req_tv_bndrs :: [VarBndr TyVar ()], -- but we want [VarBndr TyVar ArgFlag] - ; return (tyVarReqToBinders req_tv_bndrs, thing) } + ; return (tyVarReqToBinders . map hsBndrToBndr . map unLoc $ req_tv_bndrs, thing) } HsForAllInvis { hsf_invis_bndrs = bndrs } -> do { (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside -- inv_tv_bndrs :: [VarBndr TyVar Specificity], -- but we want [VarBndr TyVar ArgFlag] - ; return (tyVarSpecToBinders inv_tv_bndrs, thing) } + ; return (tyVarSpecToBinders . map hsBndrToBndr . map unLoc $ inv_tv_bndrs, thing) } where skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode } @@ -2982,8 +2991,8 @@ bindOuterTKBndrsX skol_mode outer_bndrs thing_inside ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'} , thing) } HsOuterExplicit{hso_bndrs = exp_bndrs} -> - do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside - ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs' + do { (exp_bndrs, thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside + ; return ( HsOuterExplicit { hso_xexplicit = noExtField , hso_bndrs = exp_bndrs } , thing) } @@ -2991,7 +3000,7 @@ getOuterTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar] -- The returned [TcTyVar] is not necessarily in dependency order -- at least for the HsOuterImplicit case getOuterTyVars (HsOuterImplicit { hso_ximplicit = tvs }) = tvs -getOuterTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs +getOuterTyVars (HsOuterExplicit { hso_bndrs = tvbs }) = binderVars' . map unLoc $ tvbs --------------- scopedSortOuter :: HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder] @@ -3001,9 +3010,9 @@ scopedSortOuter :: HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder] scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs}) = do { imp_tvs <- zonkAndScopedSort imp_tvs ; return [Bndr tv SpecifiedSpec | tv <- imp_tvs] } -scopedSortOuter (HsOuterExplicit{hso_xexplicit = exp_tvs}) +scopedSortOuter (HsOuterExplicit{hso_bndrs = exp_tvs}) = -- No need to dependency-sort (or zonk) explicit quantifiers - return exp_tvs + return (map (hsBndrToBndr . unLoc) exp_tvs) --------------- bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn @@ -3062,9 +3071,9 @@ tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'} , thing) } HsOuterExplicit{hso_bndrs = exp_bndrs} -> - do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside - ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs' - , hso_bndrs = exp_bndrs } + do { (exp_bndrs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside + ; return ( HsOuterExplicit { hso_xexplicit = noExtField + , hso_bndrs = exp_bndrs' } , thing) } -------------------------------------- @@ -3074,14 +3083,14 @@ tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed => [LHsTyVarBndr flag GhcRn] -> TcM a - -> TcM ([VarBndr TyVar flag], a) + -> TcM ([LHsTyVarBndr flag GhcTc], a) tcExplicitTKBndrs = tcExplicitTKBndrsX (smVanilla { sm_clone = True }) tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed => SkolemMode -> [LHsTyVarBndr flag GhcRn] -> TcM a - -> TcM ([VarBndr TyVar flag], a) + -> TcM ([LHsTyVarBndr flag GhcTc], a) -- Push level, capture constraints, -- and emit an implication constraint with a ForAllSkol ic_info, -- so that it is subject to a telescope test. @@ -3095,7 +3104,7 @@ tcExplicitTKBndrsX skol_mode bndrs thing_inside -- Notice that we use ForAllSkol here, ignoring the enclosing -- skol_info unlike tc_implicit_tk_bndrs, because the bad-telescope -- test applies only to ForAllSkol - ; emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted + ; emitResidualTvConstraint skol_info (binderVars' . map unLoc $ skol_tvs) tclvl wanted ; return (skol_tvs, res) } @@ -3106,12 +3115,24 @@ bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv :: (OutputableBndrFlag flag 'Renamed) => [LHsTyVarBndr flag GhcRn] -> TcM a - -> TcM ([VarBndr TyVar flag], a) + -> TcM ([LHsTyVarBndr flag GhcTc], a) -- Returned [LHsTyVarBndr GhcTc] are in 1-1 correspondence + -- with the passed-in [LHsTyVarBndr GhcRn] bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (smVanilla { sm_clone = False }) bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True }) -- sm_clone: see Note [Cloning for type variable binders] +binderVar' :: HsTyVarBndr flag GhcTc -> TyVar +binderVar' (UserTyVar _ _ v) = unLoc v +binderVar' (KindedTyVar _ _ v _) = unLoc v + +binderVars' :: [HsTyVarBndr flag GhcTc] -> [TyVar] +binderVars' = map binderVar' + +binderVarWithF :: HsTyVarBndr flag GhcTc -> VarBndr TyVar flag +binderVarWithF (UserTyVar _ flag v) = Bndr (unLoc v) flag +binderVarWithF (KindedTyVar _ flag v _) = Bndr (unLoc v) flag + bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv :: ContextKind -> [LHsTyVarBndr () GhcRn] @@ -3119,14 +3140,14 @@ bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv -> TcM ([TcTyVar], a) -- These do not clone: see Note [Cloning for type variable binders] bindExplicitTKBndrs_Q_Skol ctxt_kind hs_bndrs thing_inside - = liftFstM binderVars $ + = liftFstM (binderVars' . map unLoc) $ bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True , sm_kind = ctxt_kind }) hs_bndrs thing_inside -- sm_clone=False: see Note [Cloning for type variable binders] bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside - = liftFstM binderVars $ + = liftFstM (binderVars' . map unLoc) $ bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True , sm_tvtv = True, sm_kind = ctxt_kind }) hs_bndrs thing_inside @@ -3136,8 +3157,7 @@ bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed) => SkolemMode -> [LHsTyVarBndr flag GhcRn] -> TcM a - -> TcM ([VarBndr TyVar flag], a) -- Returned [TcTyVar] are in 1-1 correspondence - -- with the passed-in [LHsTyVarBndr] + -> TcM ([LHsTyVarBndr flag GhcTc], a) bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind , sm_holes = hole_info }) hs_tvs thing_inside @@ -3149,28 +3169,29 @@ bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_ki go [] = do { res <- thing_inside ; return ([], res) } - go (L _ hs_tv : hs_tvs) + go (L l hs_tv : hs_tvs) = do { lcl_env <- getLclTypeEnv - ; tv <- tc_hs_bndr lcl_env hs_tv + ; (hs_ty, tv') <- tc_hs_bndr lcl_env 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 Note [Cloning for type variable binders] - ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $ + ; (hs_tys,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv')] $ go hs_tvs - ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) } + ; return ((L l hs_ty):hs_tys, res) } - tc_hs_bndr lcl_env (UserTyVar _ _ (L _ name)) + tc_hs_bndr lcl_env (UserTyVar ann flag (L l name)) | check_parent , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name - = return tv + = return (UserTyVar ann flag (L l tv), tv) | otherwise = do { kind <- newExpectedKind ctxt_kind - ; newTyVarBndr skol_mode name kind } + ; var <- newTyVarBndr skol_mode name kind + ; return $ (UserTyVar ann flag (L l var), var)} - tc_hs_bndr lcl_env (KindedTyVar _ _ (L _ name) lhs_kind) + tc_hs_bndr lcl_env (KindedTyVar ann flag (L l name) lhs_kind@(L l' hs_kind)) | check_parent , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind @@ -3179,11 +3200,13 @@ bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_ki -- This unify rejects: -- class C (m :: * -> *) where -- type F (m :: *) = ... - ; return tv } + ; return $ (KindedTyVar ann flag (L l tv) (L l' $ XHsType (HsTypeTc kind hs_kind)), tv) } | otherwise = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind - ; newTyVarBndr skol_mode name kind } + ; var <- newTyVarBndr skol_mode name kind + ; return (KindedTyVar ann flag (L l var) (L l' $ XHsType (HsTypeTc kind hs_kind)), var) + } newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind @@ -3817,11 +3840,12 @@ tcHsPartialSigType , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with -- the implicitly and explicitly bound type variables , TcThetaType -- Theta part - , TcType ) -- Tau part + , TcType -- Tau part + , LHsSigWcType GhcTc ) -- See Note [Checking partial type signatures] tcHsPartialSigType ctxt sig_ty | HsWC { hswc_ext = sig_wcs, hswc_body = sig_ty } <- sig_ty - , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty + , L l (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty , (hs_ctxt, hs_tau) <- splitLHsQualTy body_ty = addSigCtxt ctxt sig_ty $ do { mode <- mkHoleMode TypeLevel HM_Sig @@ -3874,7 +3898,13 @@ tcHsPartialSigType ctxt sig_ty -- here because we don't have a complete type to check ; traceTc "tcHsPartialSigType" (ppr tv_prs) - ; return (wcs, wcx, tv_prs, theta, tau) } + ; let + (L ty_loc body_ty') = body_ty + sig_ty' = + HsWC sig_wcs + . L l . HsSig noExtField outer_bndrs + . L ty_loc . XHsType $ HsTypeTc tau body_ty' + ; return (wcs, wcx, tv_prs, theta, tau, sig_ty') } tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType) tcPartialContext _ Nothing = return ([], Nothing) diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 671955feb7..c652ae73da 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -481,7 +481,10 @@ Fortunately that's what matchExpectedFunTySigma returns anyway. tcExtendNameTyVarEnv tv_binds $ tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) } + ; let + (L l hs_ty) = hsps_body sig_ty + inner_ty' = HsPS { hsps_ext = hsps_ext sig_ty, hsps_body = (L l (XHsType (HsTypeTc inner_ty hs_ty))) } + ; return (mkHsWrapPat wrap (SigPat noExtField pat' inner_ty') pat_ty, res) } ------------------------ -- Lists, tuples, arrays @@ -1223,8 +1226,9 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of -- OK to drop coercions here. These unifications are all about -- guiding inference based on a user-written type annotation -- See Note [Typechecking type applications in patterns] - - ; return (PrefixCon type_args arg_pats', res) } + ; let tc_type_args + = zipWith (\a (HsPS ext (L l b))-> HsPS ext . L l . XHsType $ HsTypeTc a b) type_args' type_args + ; return (PrefixCon tc_type_args arg_pats', res) } where con_arity = conLikeArity con_like no_of_args = length arg_pats diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs index 73dedfbaf5..515b0c157e 100644 --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -125,7 +125,7 @@ tcRule (HsRule { rd_ext = ext generateRuleConstraints ty_bndrs tm_bndrs lhs rhs ; let (id_bndrs, lhs', lhs_wanted - , rhs', rhs_wanted, rule_ty) = stuff + , rhs', rhs_wanted, rule_ty, ty_bndrs') = stuff ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname , ppr lhs_wanted @@ -174,7 +174,7 @@ tcRule (HsRule { rd_ext = ext ; return $ HsRule { rd_ext = ext , rd_name = rname , rd_act = act - , rd_tyvs = ty_bndrs -- preserved for ppr-ing + , rd_tyvs = ty_bndrs' -- preserved for ppr-ing , rd_tmvs = map (noLoc . RuleBndr noAnn . noLocA) (qtkvs ++ tpl_ids) , rd_lhs = mkHsDictLet lhs_binds lhs' @@ -185,9 +185,10 @@ generateRuleConstraints :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] -> TcM ( [TcId] , LHsExpr GhcTc, WantedConstraints , LHsExpr GhcTc, WantedConstraints - , TcType ) + , TcType + , Maybe [LHsTyVarBndr () GhcTc]) generateRuleConstraints ty_bndrs tm_bndrs lhs rhs - = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $ + = do { ((ty_bndrs, 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. @@ -201,19 +202,21 @@ generateRuleConstraints ty_bndrs tm_bndrs lhs rhs ; (rhs', rhs_wanted) <- captureConstraints $ tcCheckMonoExpr rhs rule_ty ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted - ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } + ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty, ty_bndrs) } } -- See Note [TcLevel in type checking rules] tcRuleBndrs :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] - -> TcM ([TcTyVar], [Id]) + -> TcM (Maybe [LHsTyVarBndr () GhcTc], [TcTyVar], [Id]) tcRuleBndrs (Just bndrs) xs = do { (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ tcRuleTmBndrs xs - ; let tys1 = binderVars tybndrs1 - ; return (tys1 ++ tys2, tms) } + ; let tys1 = binderVars' $ map unLoc tybndrs1 + ; return (Just tybndrs1, tys1 ++ tys2, tms) } tcRuleBndrs Nothing xs - = tcRuleTmBndrs xs + = do { (tys, tms) <- tcRuleTmBndrs xs + ; return (Nothing, tys, tms) + } -- See Note [TcLevel in type checking rules] tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id]) diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 1d81b3636b..6b7b6f45de 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -190,7 +190,7 @@ tcTySig (L loc (TypeSig _ names sig_ty)) = setSrcSpanA loc $ do { sigs <- sequence [ tcUserTypeSig (locA loc) sig_ty (Just name) | L _ name <- names ] - ; return (map TcIdSig sigs) } + ; return (map (TcIdSig . fst) sigs) } tcTySig (L loc (PatSynSig _ names sig_ty)) = setSrcSpanA loc $ @@ -202,7 +202,7 @@ tcTySig _ = return [] tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name - -> TcM TcIdSigInfo + -> TcM (TcIdSigInfo, Maybe (LHsSigWcType GhcTc)) -- A function or expression type signature -- Returns a fully quantified type signature; even the wildcards -- are quantified with ordinary skolems that should be instantiated @@ -217,22 +217,23 @@ tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name tcUserTypeSig loc hs_sig_ty mb_name | isCompleteHsSig hs_sig_ty = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty + ; let ty = hsttc_type . hsTypeTc . unLoc . sig_body . unLoc . hswc_body $ sigma_ty ; traceTc "tcuser" (ppr sigma_ty) ; return $ - CompleteSig { sig_bndr = mkLocalId name Many sigma_ty + (CompleteSig { sig_bndr = mkLocalId name Many ty -- We use `Many' as the multiplicity here, -- as if this identifier corresponds to -- anything, it is a top-level -- definition. Which are all unrestricted in -- the current implementation. , sig_ctxt = ctxt_T - , sig_loc = loc } } + , sig_loc = loc}, Just sigma_ty) } -- Location of the in f :: -- Partial sig with wildcards | otherwise = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty - , sig_ctxt = ctxt_F, sig_loc = loc }) + , sig_ctxt = ctxt_F, sig_loc = loc }, Nothing) where name = case mb_name of Just n -> n @@ -380,7 +381,7 @@ tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty = do { traceTc "tcPatSynSig 1" (ppr sig_ty) ; let skol_info = DataConSkol name - ; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty)))) + ; (tclvl, wanted, (outer_bndrs, (ex_bndrs', (req, prov, body_ty)))) <- pushLevelAndSolveEqualitiesX "tcPatSynSig" $ -- See Note [solveEqualities in tcPatSynSig] tcOuterTKBndrs skol_info hs_outer_bndrs $ @@ -392,11 +393,12 @@ tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty -- e.g. pattern Zero <- 0# (#12094) ; return (req, prov, body_ty) } + ; let ex_bndrs = map (hsBndrToBndr . unLoc) ex_bndrs' ; let implicit_tvs :: [TcTyVar] univ_bndrs :: [TcInvisTVBinder] (implicit_tvs, univ_bndrs) = case outer_bndrs of HsOuterImplicit{hso_ximplicit = implicit_tvs} -> (implicit_tvs, []) - HsOuterExplicit{hso_xexplicit = univ_bndrs} -> ([], univ_bndrs) + HsOuterExplicit{hso_bndrs = univ_bndrs} -> ([], map (hsBndrToBndr . unLoc) univ_bndrs) ; implicit_tvs <- zonkAndScopedSort implicit_tvs ; let implicit_bndrs = mkTyVarBinders SpecifiedSpec implicit_tvs @@ -468,7 +470,7 @@ ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) ********************************************************************* -} -tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst +tcInstSig :: TcIdSigInfo -> TcM (TcIdSigInst, Maybe (LHsSigWcType GhcTc)) -- 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 @@ -480,14 +482,14 @@ tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) , sig_inst_wcs = [] , sig_inst_wcx = Nothing , sig_inst_theta = theta - , sig_inst_tau = tau }) } + , sig_inst_tau = tau }, Nothing) } 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 + ; (wcs, wcx, tv_prs, theta, tau, ty) <- 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 @@ -496,7 +498,7 @@ tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty , sig_inst_theta = theta , sig_inst_tau = tau } ; traceTc "End partial sig }" (ppr inst_sig) - ; return inst_sig } + ; return (inst_sig, Just ty) } {- Note [Pattern bindings and complete signatures] @@ -758,7 +760,9 @@ tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) tc_one hs_ty = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty - ; wrap <- tcSpecWrapper (FunSigCtxt name True) poly_ty spec_ty + ; let (HsSig _ _ (L _ ty')) = unLoc spec_ty + ty = hsttc_type . hsTypeTc $ ty' + ; wrap <- tcSpecWrapper (FunSigCtxt name True) poly_ty ty ; return (SpecPrag poly_id wrap inl) } tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag) diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index d4b25806bf..931bfcf617 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -3364,7 +3364,7 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) - ; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts))) + ; (tclvl, wanted, (exp_tvbndrs', (ctxt, arg_tys, field_lbls, stricts))) <- pushLevelAndSolveEqualitiesX "tcConDecl:H98" $ tcExplicitTKBndrs explicit_tkv_nms $ do { ctxt <- tcHsContext hs_ctxt @@ -3375,6 +3375,7 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map ; return (ctxt, arg_tys, field_lbls, stricts) } + ; let exp_tvbndrs = map binderVarWithF $ map unLoc exp_tvbndrs' ; let tc_tvs = binderVars tc_bndrs fake_ty = mkSpecForAllTys tc_tvs $ diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index 80804ecaea..667d140119 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -163,7 +163,7 @@ tcClassSigs clas sigs def_methods -> TcM [TcMethInfo] tc_sig gen_dm_env (op_names, op_hs_ty) = do { traceTc "ClsSig 1" (ppr op_names) - ; op_ty <- tcClassSigType op_names op_hs_ty + ; op_ty <- hsttc_type . hsTypeTc . unLoc . sig_body . unLoc <$> tcClassSigType op_names op_hs_ty -- Class tyvars already in scope ; traceTc "ClsSig 2" (ppr op_names $$ ppr op_ty) @@ -176,9 +176,8 @@ tcClassSigs clas sigs def_methods tc_gen_sig :: ([LocatedN Name], LHsSigType GhcRn) -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))] -- AZ temp tc_gen_sig (op_names, gen_hs_ty) - = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty - ; return [ (op_name, (locA loc, gen_op_ty)) - | L loc op_name <- op_names ] } + = do { gen_op_ty <- hsttc_type . hsTypeTc . unLoc . sig_body . unLoc <$> tcClassSigType op_names gen_hs_ty + ; return [ (op_name, (locA loc, gen_op_ty)) | L loc op_name <- op_names ] } {- ************************************************************************ diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index ec05dffaae..f2b1c87ad6 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -1889,30 +1889,31 @@ 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 { (sig_ty, hs_wrap) + = do { (ty, hs_wrap) <- setSrcSpan (getLocA 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 + ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty ; let local_meth_ty = idType local_meth_id + ty = hsttc_type . hsTypeTc . unLoc . sig_body . unLoc $ sig_ty ctxt = FunSigCtxt sel_name False -- False <=> do not report redundant constraints when -- checking instance-sig <= class-meth-sig -- The instance-sig is the focus here; the class-meth-sig -- is fixed (#18036) - ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $ - tcSubTypeSigma ctxt sig_ty local_meth_ty - ; return (sig_ty, hs_wrap) } + ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name ty local_meth_ty) $ + tcSubTypeSigma ctxt ty local_meth_ty + ; return (ty, hs_wrap) } ; inner_meth_name <- newName (nameOccName sel_name) ; let ctxt = FunSigCtxt sel_name True -- True <=> check for redundant constraints in the -- user-specified instance signature - inner_meth_id = mkLocalId inner_meth_name Many sig_ty + inner_meth_id = mkLocalId inner_meth_name Many ty inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id , sig_ctxt = ctxt - , sig_loc = getLocA hs_sig_ty } - + , sig_loc = getLocA hs_sig_ty + } ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index dbed564efc..2cb05b99a9 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -1491,7 +1491,6 @@ data TcIdSigInfo -- See Note [Complete and partial type signatures] , 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 diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 0e34d97c46..12d5918463 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -131,7 +131,7 @@ hsPatType (ConPat { pat_con = lcon } }) = conLikeResTy (unLoc lcon) tys -hsPatType (SigPat ty _ _) = ty +hsPatType (SigPat _ _ (HsPS _ (L _ ty))) = hsttc_type . hsTypeTc $ ty hsPatType (NPat ty _ _ _) = ty hsPatType (NPlusKPat ty _ _ _ _ _) = ty hsPatType (XPat (CoPat _ _ ty)) = ty @@ -841,10 +841,10 @@ zonkExpr env (HsApp x e1 e2) new_e2 <- zonkLExpr env e2 return (HsApp x new_e1 new_e2) -zonkExpr env (HsAppType ty e t) +zonkExpr env (HsAppType _ e (HsWC field (L l (XHsType (HsTypeTc ty t))))) = do new_e <- zonkLExpr env e new_ty <- zonkTcTypeToTypeX env ty - return (HsAppType new_ty new_e t) + return (HsAppType noExtField new_e (HsWC field (L l (XHsType (HsTypeTc new_ty t))))) -- NB: the type is an HsType; can't zonk that! zonkExpr _ e@(HsRnBracketOut _ _ _) @@ -1510,10 +1510,10 @@ zonk_pat env p@(ConPat { pat_con = L _ con zonk_pat env (LitPat x lit) = return (env, LitPat x lit) -zonk_pat env (SigPat ty pat hs_ty) +zonk_pat env (SigPat _ pat (HsPS ext (L l (XHsType (HsTypeTc ty hs_ty))))) = do { ty' <- zonkTcTypeToTypeX env ty ; (env', pat') <- zonkPat env pat - ; return (env', SigPat ty' pat' hs_ty) } + ; return (env', SigPat noExtField pat' (HsPS ext (L l (XHsType (HsTypeTc ty' hs_ty))))) } zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index 0b93e4b265..e07fe7f416 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -1655,7 +1655,7 @@ data RuleDecl pass , rd_name :: XRec pass (SourceText,RuleName) -- ^ Note [Pragma source text] in "GHC.Types.Basic" , rd_act :: Activation - , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)] + , rd_tyvs :: Maybe [LHsTyVarBndr () pass] -- ^ Forall'd type vars , rd_tmvs :: [LRuleBndr pass] -- ^ Forall'd term vars, before typechecking; after typechecking diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index 2362ea8373..ce4d1202ac 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -324,7 +324,7 @@ data HsExpr p | HsAppType (XAppTypeE p) -- After typechecking: the type argument (LHsExpr p) - (LHsWcType (NoGhcTc p)) -- ^ Visible type application + (LHsWcType p) -- ^ Visible type application -- -- Explicit type argument; e.g f @Int x y -- NB: Has wildcards, but no implicit quantification @@ -517,7 +517,7 @@ data HsExpr p (XExprWithTySig p) (LHsExpr p) - (LHsSigWcType (NoGhcTc p)) + (LHsSigWcType p) -- | Arithmetic sequence -- diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs index 86f56f7ad8..14e2504110 100644 --- a/compiler/Language/Haskell/Syntax/Pat.hs +++ b/compiler/Language/Haskell/Syntax/Pat.hs @@ -205,7 +205,7 @@ data Pat p -- For details on above see note [Api annotations] in GHC.Parser.Annotation | SigPat (XSigPat p) -- After typechecker: Type (LPat p) -- Pattern with a type signature - (HsPatSigType (NoGhcTc p)) -- Signature can bind both + (HsPatSigType p) -- Signature can bind both -- kind and type vars -- ^ Pattern with a type signature @@ -221,7 +221,7 @@ type family ConLikeP x -- | Haskell Constructor Pattern Details -type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p)) +type HsConPatDetails p = HsConDetails (HsPatSigType p) (LPat p) (HsRecFields p (LPat p)) hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p] hsConPatArgs (PrefixCon _ ps) = ps diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index d91a2f3267..6e77210d50 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -23,7 +23,7 @@ module Language.Haskell.Syntax.Type ( HsArrow(..), hsLinear, hsUnrestricted, - HsType(..), HsCoreTy, LHsType, HsKind, LHsKind, + HsType(..), HsTypeTc(..), HsCoreTy, LHsType, HsKind, LHsKind, HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, @@ -62,6 +62,8 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsSplice ) import Language.Haskell.Syntax.Extension +import GHC.Hs.Extension + import GHC.Types.SourceText import GHC.Types.Name( Name ) import GHC.Types.Name.Reader ( RdrName ) @@ -368,7 +370,7 @@ data HsOuterTyVarBndrs flag pass | HsOuterExplicit -- ^ Explicit forall, e.g., -- @f :: forall a b. a -> b -> b@ { hso_xexplicit :: XHsOuterExplicit pass flag - , hso_bndrs :: [LHsTyVarBndr flag (NoGhcTc pass)] + , hso_bndrs :: [LHsTyVarBndr flag pass] } | XHsOuterTyVarBndrs !(XXHsOuterTyVarBndrs pass) @@ -893,6 +895,14 @@ data HsType pass | XHsType !(XXType pass) +data HsTypeTc = HsTypeTc + { hsttc_type :: Type + , hsttc_rn :: HsType GhcRn + } + +instance Outputable HsTypeTc where + ppr (HsTypeTc p _) = ppr p + -- An escape hatch for tunnelling a Core 'Type' through 'HsType'. -- For more details on how this works, see: -- diff --git a/utils/haddock b/utils/haddock index 3699d74aac..eb5aba1494 160000 --- a/utils/haddock +++ b/utils/haddock @@ -1 +1 @@ -Subproject commit 3699d74aac686c1e071ab050456698ff2ea8c7df +Subproject commit eb5aba14948900841d96f4307a82a1524927c37e -- cgit v1.2.1