[Git][ghc/ghc][wip/T16762] WIP: T16762 (part 2)
Ryan Scott
gitlab at gitlab.haskell.org
Mon Sep 7 22:13:57 UTC 2020
Ryan Scott pushed to branch wip/T16762 at Glasgow Haskell Compiler / GHC
Commits:
8767ff95 by Ryan Scott at 2020-09-07T18:12:59-04:00
WIP: T16762 (part 2)
[ci skip]
- - - - -
30 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/ThToHs.hs
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/patsyn/should_fail/T11039.stderr
- testsuite/tests/patsyn/should_fail/T11667.stderr
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -894,7 +894,7 @@ data Sig pass
TypeSig
(XTypeSig pass)
[XRec pass (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah
- (LHsSigWcType pass) -- RHS of the signature; can have wildcards
+ (LHsSigWcType pass) -- RHS of the signature; can have wildcards
-- | A pattern synonym type signature
--
@@ -905,7 +905,7 @@ data Sig pass
-- 'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
- | PatSynSig (XPatSynSig pass) [XRec pass (IdP pass)] (LHsSigType pass)
+ | PatSynSig (XPatSynSig pass) [XRec pass (IdP pass)] (LHsSigType' pass)
-- P :: forall a b. Req => Prov => ty
-- | A signature for a class method
@@ -918,7 +918,7 @@ data Sig pass
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDefault',
-- 'GHC.Parser.Annotation.AnnDcolon'
- | ClassOpSig (XClassOpSig pass) Bool [XRec pass (IdP pass)] (LHsSigType pass)
+ | ClassOpSig (XClassOpSig pass) Bool [XRec pass (IdP pass)] (LHsSigType' pass)
-- | A type signature in generated code, notably the code
-- generated for record selectors. We simply record
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1450,7 +1450,7 @@ data ConDecl pass
-- Whether or not there is an /explicit/ forall, we still
-- need to capture the implicitly-bound type/kind variables
-}
- , con_bndrs :: Located (HsOuterGadtTyVarBndrs pass) -- ^ TODO RGS: Docs
+ , con_bndrs :: Located (HsOuterSigTyVarBndrs pass) -- ^ TODO RGS: Docs
, con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
, con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon
@@ -1702,7 +1702,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty, con_doc = doc })
= ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
- <+> (sep [pprHsOuterGadtTyVarBndrs outer_bndrs <+> pprLHsContext cxt,
+ <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext cxt,
ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
where
get_args (PrefixCon args) = map ppr args
@@ -1873,7 +1873,7 @@ type LClsInstDecl pass = XRec pass (ClsInstDecl pass)
data ClsInstDecl pass
= ClsInstDecl
{ cid_ext :: XCClsInstDecl pass
- , cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type
+ , cid_poly_ty :: LHsSigType' pass -- Context => Class Instance-type
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
, cid_binds :: LHsBinds pass -- Class methods
@@ -2062,7 +2062,7 @@ type LDerivDecl pass = XRec pass (DerivDecl pass)
-- | Stand-alone 'deriving instance' declaration
data DerivDecl pass = DerivDecl
{ deriv_ext :: XCDerivDecl pass
- , deriv_type :: LHsSigWcType pass
+ , deriv_type :: LHsSigWcType' pass
-- ^ The instance type to derive.
--
-- It uses an 'LHsSigWcType' because the context is allowed to be a
@@ -2123,8 +2123,8 @@ data DerivStrategy pass
| ViaStrategy (XViaStrategy pass)
-- ^ @-XDerivingVia@
-type instance XViaStrategy GhcPs = LHsSigType GhcPs
-type instance XViaStrategy GhcRn = LHsSigType GhcRn
+type instance XViaStrategy GhcPs = LHsSigType' GhcPs
+type instance XViaStrategy GhcRn = LHsSigType' GhcRn
type instance XViaStrategy GhcTc = Type
instance OutputableBndrId p
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -393,10 +393,10 @@ deriving instance Data (LHsQTyVars GhcPs)
deriving instance Data (LHsQTyVars GhcRn)
deriving instance Data (LHsQTyVars GhcTc)
--- deriving instance (DataIdLR p p, Data expBndrs) => Data (HsOuterTyVarBndrs p expBndrs)
-deriving instance Data expBndrs => Data (HsOuterTyVarBndrs GhcPs expBndrs)
-deriving instance Data expBndrs => Data (HsOuterTyVarBndrs GhcRn expBndrs)
-deriving instance Data expBndrs => Data (HsOuterTyVarBndrs GhcTc expBndrs)
+-- deriving instance (DataIdLR p p, Data flag) => Data (HsOuterTyVarBndrs flag p)
+deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcPs)
+deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcRn)
+deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcTc)
-- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing)
deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing)
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -30,11 +30,10 @@ module GHC.Hs.Type (
HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,
HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr,
LHsQTyVars(..),
- HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs,
- HsOuterGadtTyVarBndrs, HsOuterSigTyVarBndrs,
+ HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,
HsImplicitBndrs(..), HsWildCardBndrs(..),
HsPatSigType(..), HsPSRn(..),
- LHsSigType, HsSigType(..), LHsSigType', LHsSigWcType, LHsWcType,
+ LHsSigType, HsSigType(..), LHsSigType', LHsSigWcType, LHsSigWcType', LHsWcType,
HsTupleSort(..),
HsContext, LHsContext, noLHsContext,
HsTyLit(..),
@@ -61,28 +60,29 @@ module GHC.Hs.Type (
mkHsOuterImplicit, mkHsOuterExplicit, mapXHsOuterImplicit,
mkHsImplicitSigType, mkHsExplicitSigType,
+ hsSigTypeToHsType, hsTypeToHsSigType, hsTypeToHsSigWcType,
mkHsImplicitBndrs, mkHsWildCardBndrs, mkHsPatSigType, hsImplicitBody,
mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
mkHsForAllVisTele, mkHsForAllInvisTele,
mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,
isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,
- hsScopedTvs, hsScopedTvs', hsWcScopedTvs, dropWildCards,
+ hsScopedTvs, hsScopedTvs', hsWcScopedTvs, hsWcScopedTvs', dropWildCards, dropWildCards',
hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,
- splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclHead', getLHsInstDeclClass_maybe,
- splitLHsPatSynTy,
+ splitLHsInstDeclTy, splitLHsInstDeclTy', getLHsInstDeclHead, getLHsInstDeclHead', getLHsInstDeclClass_maybe, getLHsInstDeclClass_maybe',
+ splitLHsPatSynTy, splitLHsPatSynTy',
splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy,
splitLHsSigmaTyInvis, splitLHsGadtTy,
splitHsFunType, hsTyGetAppHead_maybe,
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
- ignoreParens, hsSigType, hsSigWcType, hsPatSigType,
+ ignoreParens, hsSigType, hsSigWcType, hsSigWcTypeBody, hsPatSigType,
hsTyKindSig,
hsConDetailsArgs,
setHsTyVarBndrFlag, hsTyVarBndrFlag,
-- Printing
pprHsType, pprHsForAll,
- pprHsOuterFamEqnTyVarBndrs, pprHsOuterGadtTyVarBndrs,
+ pprHsOuterFamEqnTyVarBndrs, pprHsOuterSigTyVarBndrs,
pprLHsContext,
hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext
) where
@@ -415,25 +415,20 @@ emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] }
-- * Patterns in a type/data family instance (HsTyPats)
-- | TODO RGS: Docs
-data HsOuterTyVarBndrs pass expBndrs
+data HsOuterTyVarBndrs flag pass
= HsOuterImplicit
{ hso_ximplicit :: XHsOuterImplicit pass
}
| HsOuterExplicit
{ hso_xexplicit :: XHsOuterExplicit pass
- , hso_bndrs :: expBndrs
+ , hso_bndrs :: [LHsTyVarBndr flag pass]
}
| XHsOuterTyVarBndrs !(XXHsOuterTyVarBndrs pass)
-- | TODO RGS: Docs
-type HsOuterFamEqnTyVarBndrs pass =
- HsOuterTyVarBndrs pass [LHsTyVarBndr () pass]
+type HsOuterFamEqnTyVarBndrs = HsOuterTyVarBndrs ()
-- | TODO RGS: Docs
-type HsOuterGadtTyVarBndrs pass =
- HsOuterTyVarBndrs pass [LHsTyVarBndr Specificity pass]
--- | TODO RGS: Docs
-type HsOuterSigTyVarBndrs pass =
- HsOuterTyVarBndrs pass (HsForAllTelescope pass)
+type HsOuterSigTyVarBndrs = HsOuterTyVarBndrs Specificity
type instance XHsOuterImplicit GhcPs = NoExtField
type instance XHsOuterImplicit GhcRn = [Name]
@@ -536,17 +531,27 @@ type LHsWcType pass = HsWildCardBndrs pass (LHsType pass) -- Wildcard only
-- | Located Haskell Signature Wildcard Type
type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both
+-- | TODO RGS: This is the REAL LHsSigWcType. Delete the one above when ready.
+type LHsSigWcType' pass = HsWildCardBndrs pass (LHsSigType' pass) -- Both
+
-- See Note [Representing type signatures]
+-- TODO RGS: Delete this
hsImplicitBody :: HsImplicitBndrs (GhcPass p) thing -> thing
hsImplicitBody (HsIB { hsib_body = body }) = body
+-- TODO RGS: Delete this
hsSigType :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)
hsSigType = hsImplicitBody
+-- TODO RGS: Delete this?
hsSigWcType :: LHsSigWcType pass -> LHsType pass
hsSigWcType sig_ty = hsib_body (hswc_body sig_ty)
+-- TODO RGS: This is the REAL hsSigWcType. Delete the one above when ready.
+hsSigWcTypeBody :: LHsSigWcType' pass -> LHsType pass
+hsSigWcTypeBody = sig_body . unLoc . hswc_body
+
hsPatSigType :: HsPatSigType pass -> LHsType pass
hsPatSigType = hsps_body
@@ -554,6 +559,11 @@ dropWildCards :: LHsSigWcType pass -> LHsSigType pass
-- Drop the wildcard part of a LHsSigWcType
dropWildCards sig_ty = hswc_body sig_ty
+-- TODO RGS: This is the REAL dropWildCards. Delete the one above when ready.
+dropWildCards' :: LHsSigWcType' pass -> LHsSigType' pass
+-- Drop the wildcard part of a LHsSigWcType
+dropWildCards' sig_ty = hswc_body sig_ty
+
{- Note [Representing type signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
HsSigType is used to represent an explicit user type signature
@@ -639,16 +649,16 @@ variables so that they can be brought into scope during renaming and
typechecking.
-}
-mkHsOuterImplicit :: HsOuterTyVarBndrs GhcPs expBndrs
+mkHsOuterImplicit :: HsOuterTyVarBndrs flag GhcPs
mkHsOuterImplicit = HsOuterImplicit { hso_ximplicit = noExtField }
-mkHsOuterExplicit :: expBndrs -> HsOuterTyVarBndrs GhcPs expBndrs
+mkHsOuterExplicit :: [LHsTyVarBndr flag GhcPs] -> HsOuterTyVarBndrs flag GhcPs
mkHsOuterExplicit exp_bndrs = HsOuterExplicit { hso_xexplicit = noExtField
, hso_bndrs = exp_bndrs }
mapXHsOuterImplicit ::
(XHsOuterImplicit pass -> XHsOuterImplicit pass)
- -> HsOuterTyVarBndrs pass expBndrs -> HsOuterTyVarBndrs pass expBndrs
+ -> HsOuterTyVarBndrs flag pass -> HsOuterTyVarBndrs flag pass
mapXHsOuterImplicit f (HsOuterImplicit { hso_ximplicit = ximplicit }) =
HsOuterImplicit { hso_ximplicit = f ximplicit }
mapXHsOuterImplicit _ hso at HsOuterExplicit{} = hso
@@ -659,11 +669,36 @@ mkHsImplicitSigType body =
HsSig { sig_ext = noExtField
, sig_bndrs = mkHsOuterImplicit, sig_body = body }
-mkHsExplicitSigType :: HsForAllTelescope GhcPs -> LHsType GhcPs
+mkHsExplicitSigType :: [LHsTyVarBndr Specificity GhcPs] -> LHsType GhcPs
-> HsSigType GhcPs
-mkHsExplicitSigType tele body =
+mkHsExplicitSigType bndrs body =
HsSig { sig_ext = noExtField
- , sig_bndrs = mkHsOuterExplicit tele, sig_body = body }
+ , sig_bndrs = mkHsOuterExplicit bndrs, sig_body = body }
+
+-- TODO RGS: Delete this crap
+hsSigTypeToHsType :: LHsSigType' GhcPs -> LHsType GhcPs
+hsSigTypeToHsType (L l (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =
+ case outer_bndrs of
+ HsOuterImplicit{} -> body
+ HsOuterExplicit{hso_bndrs = exp_bndrs} ->
+ L l $ HsForAllTy { hst_xforall = noExtField
+ , hst_tele = mkHsForAllInvisTele exp_bndrs, hst_body = body }
+
+-- TODO RGS: Docs
+-- TODO RGS: Consider moving this to GHC.Hs.Utils instead, as it is somewhat analogous
+-- to mkLHsSigType
+hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType' GhcPs
+hsTypeToHsSigType lty@(L loc ty) = L loc $ case ty of
+ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }
+ , hst_body = body }
+ -> mkHsExplicitSigType bndrs body
+ _ -> mkHsImplicitSigType lty
+
+-- TODO RGS: Docs
+-- TODO RGS: Consider moving this to GHC.Hs.Utils instead, as it is somewhat analogous
+-- to mkLHsSigWcType
+hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType' GhcPs
+hsTypeToHsSigWcType = mkHsWildCardBndrs . hsTypeToHsSigType
mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs x = HsIB { hsib_ext = noExtField
@@ -1241,6 +1276,21 @@ hsWcScopedTvs sig_ty
vars ++ nwcs ++ hsLTyVarNames tvs
_ -> nwcs
+-- TODO RGS: This is the REAL hsWcScopedTvs. Delete the one above when ready.
+hsWcScopedTvs' :: LHsSigWcType' GhcRn -> [Name]
+-- Get the lexically-scoped type variables of a HsSigType
+-- - the explicitly-given forall'd type variables
+-- - the named wildcards; see Note [Scoping of named wildcards]
+-- because they scope in the same way
+hsWcScopedTvs' sig_wc_ty
+ | HsWC { hswc_ext = nwcs, hswc_body = sig_ty } <- sig_wc_ty
+ , L _ (HsSig{sig_bndrs = outer_bndrs}) <- sig_ty
+ = case outer_bndrs of
+ HsOuterImplicit{} ->
+ nwcs
+ HsOuterExplicit{hso_bndrs = tvs} ->
+ nwcs ++ hsLTyVarNames tvs -- See Note [hsScopedTvs vis_flag]
+
-- TODO RGS: Delete this
hsScopedTvs :: LHsSigType GhcRn -> [Name]
-- Same as hsWcScopedTvs, but for a LHsSigType
@@ -1257,13 +1307,10 @@ hsScopedTvs sig_ty
hsScopedTvs' :: LHsSigType' GhcRn -> [Name]
-- Same as hsWcScopedTvs, but for a LHsSigType
hsScopedTvs' (L _ (HsSig{sig_bndrs = outer_bndrs})) = case outer_bndrs of
- HsOuterImplicit{hso_ximplicit = vars}
- -> vars
- HsOuterExplicit{hso_bndrs = exp_bndrs} -> case exp_bndrs of
- HsForAllInvis{hsf_invis_bndrs = invis_bndrs}
- -> hsLTyVarNames invis_bndrs -- See Note [hsScopedTvs vis_flag]
- HsForAllVis{}
- -> []
+ HsOuterImplicit{} ->
+ []
+ HsOuterExplicit{hso_bndrs = tvs} ->
+ hsLTyVarNames tvs -- See Note [hsScopedTvs vis_flag]
{- Note [Scoping of named wildcards]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1513,6 +1560,28 @@ splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
(exis, ty3) = splitLHsForAllTyInvis ty2
(provs, ty4) = splitLHsQualTy ty3
+-- TODO RGS: This is the REAL splitLHsPatSynTy. Delete the one above when ready.
+splitLHsPatSynTy' :: LHsSigType' (GhcPass p)
+ -> ( [LHsTyVarBndr Specificity (GhcPass p)] -- universals
+ , LHsContext (GhcPass p) -- required constraints
+ , [LHsTyVarBndr Specificity (GhcPass p)] -- existentials
+ , 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 p)], LHsType (GhcPass p))
+ split_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =
+ case outer_bndrs of
+ HsOuterImplicit{} -> ([], ignoreParens body)
+ -- TODO RGS: Sigh. Explain why ignoreParens is necessary here.
+ HsOuterExplicit{hso_bndrs = exp_bndrs} -> (exp_bndrs, body)
+
+ (univs, ty1) = split_sig_ty ty
+ (reqs, ty2) = splitLHsQualTy ty1
+ (exis, ty3) = splitLHsForAllTyInvis ty2
+ (provs, ty4) = splitLHsQualTy ty3
+
-- | Decompose a sigma type (of the form @forall <tvs>. context => body@)
-- into its constituent parts.
-- Only splits type variable binders that were
@@ -1568,44 +1637,19 @@ splitLHsSigmaTyInvis_KP ty
-- This function is careful not to look through parentheses.
-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@
-- "GHC.Hs.Decls" for why this is important.
-{-
--- TODO RGS: Delete me?
-
-splitLHsGadtTy ::
- LHsType (GhcPass pass)
- -> (Maybe [LHsTyVarBndr Specificity (GhcPass pass)], Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
-splitLHsGadtTy = splitLHsSigmaTyInvis_KP
--}
--- TODO RGS: Delete me?
-
splitLHsGadtTy ::
-- TODO RGS: Delete me?
LHsSigType' GhcPs
- -> (HsOuterGadtTyVarBndrs GhcPs, Maybe (LHsContext GhcPs), LHsType GhcPs)
-{-
--- TODO RGS: Delete me?
-
- LHsSigType' (GhcPass pass)
- -> (HsOuterGadtTyVarBndrs (GhcPass pass), Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
--}
-splitLHsGadtTy (L l sig_ty)
+ -> (HsOuterSigTyVarBndrs GhcPs, Maybe (LHsContext GhcPs), LHsType GhcPs)
+splitLHsGadtTy (L _ sig_ty)
| (outer_bndrs, rho_ty) <- split_bndrs sig_ty
, (mb_ctxt, tau_ty) <- splitLHsQualTy_KP rho_ty
= (outer_bndrs, mb_ctxt, tau_ty)
where
- split_bndrs (HsSig { sig_bndrs = outer_bndrs, sig_body = body_ty}) = case outer_bndrs of
- HsOuterImplicit{} ->
- (mkHsOuterImplicit, body_ty)
- HsOuterExplicit{hso_bndrs = tele} -> case tele of
- HsForAllInvis{hsf_invis_bndrs = bndrs} ->
- (mkHsOuterExplicit bndrs, body_ty)
- -- TODO RGS: Say more here. In particular, rather than throwing an
- -- error here, we let addNoNestedForallsContextsErr catch this later.
- HsForAllVis{} ->
- ( mkHsOuterImplicit
- , L l $ HsForAllTy { hst_xforall = noExtField
- , hst_tele = tele, hst_body = body_ty })
+ split_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
+ split_bndrs (HsSig { sig_bndrs = outer_bndrs, sig_body = body_ty}) =
+ (outer_bndrs, body_ty)
-- | Decompose a type of the form @forall <tvs>. body@ into its constituent
-- parts. Only splits type variable binders that
@@ -1694,6 +1738,19 @@ splitLHsInstDeclTy (HsIB { hsib_ext = itkvs
-- the other into scope over the bodies of the instance methods, so we
-- simply combine them into a single list.
+-- TODO RGS: This is the REAL splitLHsInstDeclTy. Delete the one above when ready.
+splitLHsInstDeclTy' :: LHsSigType' GhcRn
+ -> ([Name], LHsContext GhcRn, LHsType GhcRn)
+splitLHsInstDeclTy' (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = inst_ty})) =
+ case outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = imp_tkvs} ->
+ (imp_tkvs, ctxt, body_ty)
+ HsOuterExplicit{hso_bndrs = exp_bndrs} ->
+ (hsLTyVarNames exp_bndrs, ctxt, body_ty)
+ where
+ (mb_cxt, body_ty) = splitLHsQualTy_KP inst_ty
+ ctxt = fromMaybe noLHsContext mb_cxt
+
-- | Decompose a type class instance type (of the form
-- @forall <tvs>. context => instance_head@) into the @instance_head at .
getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)
@@ -1718,6 +1775,15 @@ getLHsInstDeclClass_maybe inst_ty
; cls <- hsTyGetAppHead_maybe head_ty
; return cls }
+-- TODO RGS: This the REAL getLHsInstDeclClass_maybe. Delete the one above when ready.
+getLHsInstDeclClass_maybe' :: LHsSigType' (GhcPass p)
+ -> Maybe (Located (IdP (GhcPass p)))
+-- Works on (LHsSigType GhcPs)
+getLHsInstDeclClass_maybe' inst_ty
+ = do { let head_ty = getLHsInstDeclHead' inst_ty
+ ; cls <- hsTyGetAppHead_maybe head_ty
+ ; return cls }
+
{-
Note [No nested foralls or contexts in instance types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1927,8 +1993,8 @@ instance OutputableBndrId p
=> Outputable (LHsQTyVars (GhcPass p)) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
-instance forall p expBndrs. (OutputableBndrId p, Outputable expBndrs)
- => Outputable (HsOuterTyVarBndrs (GhcPass p) expBndrs) where
+instance forall flag p. (OutputableBndrFlag flag, OutputableBndrId p)
+ => Outputable (HsOuterTyVarBndrs flag (GhcPass p)) where
ppr (HsOuterImplicit { hso_ximplicit = implicit_vars }) =
text "HsOuterImplicit" <> case ghcPass @p of
GhcPs -> empty
@@ -1972,21 +2038,14 @@ pprHsOuterFamEqnTyVarBndrs (HsOuterImplicit{}) = empty
pprHsOuterFamEqnTyVarBndrs (HsOuterExplicit{hso_bndrs = qtvs}) =
forAllLit <+> interppSP qtvs <> dot
--- | TODO RGS: Docs
-pprHsOuterGadtTyVarBndrs :: OutputableBndrId p
- => HsOuterGadtTyVarBndrs (GhcPass p) -> SDoc
-pprHsOuterGadtTyVarBndrs (HsOuterImplicit{}) = empty
-pprHsOuterGadtTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) =
- pprHsForAll (mkHsForAllInvisTele bndrs) noLHsContext
- -- TODO RGS: The use of mkHsForAllInvisTele above is a mite bit fishy.
- -- Consider carefully if this is the best design.
-
-- | TODO RGS: Docs
pprHsOuterSigTyVarBndrs :: OutputableBndrId p
=> HsOuterSigTyVarBndrs (GhcPass p) -> SDoc
pprHsOuterSigTyVarBndrs (HsOuterImplicit{}) = empty
-pprHsOuterSigTyVarBndrs (HsOuterExplicit{hso_bndrs = tele}) =
- pprHsForAll tele noLHsContext
+pprHsOuterSigTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) =
+ pprHsForAll (mkHsForAllInvisTele bndrs) noLHsContext
+ -- TODO RGS: The use of mkHsForAllInvisTele above is a mite bit fishy.
+ -- Consider carefully if this is the best design.
-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@
-- only when @-dppr-debug@ is enabled.
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -657,6 +657,7 @@ chunkify xs
mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType ty = mkHsImplicitBndrs ty
+-- TODO RGS: DELETE THIS
mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
@@ -694,7 +695,7 @@ mkClassOpSigs sigs
= map fiddle sigs
where
fiddle (L loc (TypeSig _ nms ty))
- = L loc (ClassOpSig noExtField False nms (dropWildCards ty))
+ = L loc (ClassOpSig noExtField False nms (hsTypeToHsSigType (hsSigWcType ty)))
fiddle sig = sig
{- *********************************************************************
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -141,7 +141,7 @@ sigNameNoLoc _ = []
-- instanceMap.
getInstLoc :: InstDecl (GhcPass p) -> SrcSpan
getInstLoc = \case
- ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)
+ ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc ty
-- The Names of data and type family instances have their SrcSpan's attached
-- to the *type constructor*. For example, the Name "D:R:Foo:Int" would have
-- its SrcSpan attached here:
@@ -246,8 +246,8 @@ classDecls class_ = filterDecls . collectDocs . sortLocated $ decls
declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)
declTypeDocs = \case
SigD _ (TypeSig _ _ ty) -> typeDocs (unLoc (hsSigWcType ty))
- SigD _ (ClassOpSig _ _ _ ty) -> typeDocs (unLoc (hsSigType ty))
- SigD _ (PatSynSig _ _ ty) -> typeDocs (unLoc (hsSigType ty))
+ SigD _ (ClassOpSig _ _ _ ty) -> sigTypeDocs (unLoc ty)
+ SigD _ (PatSynSig _ _ ty) -> sigTypeDocs (unLoc ty)
ForD _ (ForeignImport _ _ ty _) -> sigTypeDocs (unLoc ty)
TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
_ -> M.empty
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -346,9 +346,9 @@ get_scoped_tvs (L _ signature)
| TypeSig _ _ sig <- signature
= get_scoped_tvs_from_sig (hswc_body sig)
| ClassOpSig _ _ _ sig <- signature
- = get_scoped_tvs_from_sig sig
+ = get_scoped_tvs_from_sig' sig
| PatSynSig _ _ sig <- signature
- = get_scoped_tvs_from_sig sig
+ = get_scoped_tvs_from_sig' sig
| otherwise
= []
@@ -367,6 +367,20 @@ get_scoped_tvs_from_sig sig
, (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty
= implicit_vars ++ hsLTyVarNames explicit_vars
+-- TODO RGS: This is the REAL get_scoped_tvs_from_sig'. Delete the one above when ready.
+get_scoped_tvs_from_sig' :: LHsSigType' GhcRn -> [Name]
+ -- Collect both implicit and explicit quantified variables, since
+ -- the types in instance heads, as well as `via` types in DerivingVia, can
+ -- bring implicitly quantified type variables into scope, e.g.,
+ --
+ -- instance Foo [a] where
+ -- m = n @a
+ --
+ -- See also Note [Scoped type variables in quotes]
+get_scoped_tvs_from_sig' (L _ (HsSig{sig_bndrs = outer_bndrs})) = case outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = imp_tv_names} -> imp_tv_names
+ HsOuterExplicit{hso_bndrs = exp_tvs} -> hsLTyVarNames exp_tvs
+
{- Notes
Note [Scoped type variables in quotes]
@@ -669,7 +683,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
; decls2 <- repInst rOver cxt1 inst_ty1 decls1
; wrapGenSyms ss decls2 }
where
- (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
+ (tvs, cxt, inst_ty) = splitLHsInstDeclTy' ty
repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
@@ -681,7 +695,7 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
; repDeriv strat' cxt' inst_ty' }
; return (loc, dec) }
where
- (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
+ (tvs, cxt, inst_ty) = splitLHsInstDeclTy' (dropWildCards' ty)
repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
@@ -695,13 +709,6 @@ repTyFamEqn (FamEqn { feqn_tycon = tc_name
, feqn_fixity = fixity
, feqn_rhs = rhs })
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
- {-
- TODO RGS: Delete me
-
- ; let hs_tvs = HsQTvs { hsq_ext = var_names
- , hsq_explicit = fromMaybe [] mb_bndrs }
- ; addTyClTyVarBinds hs_tvs $ \ _ ->
- -}
; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
do { tys1 <- case fixity of
Prefix -> repTyArgs (repNamedTyCon tc) tys
@@ -733,13 +740,6 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn =
, feqn_fixity = fixity
, feqn_rhs = defn }})
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
- {-
- TODO RGS: Delete
-
- ; let hs_tvs = HsQTvs { hsq_ext = var_names
- , hsq_explicit = fromMaybe [] mb_bndrs }
- ; addTyClTyVarBinds hs_tvs $ \ _ ->
- -}
; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
do { tys1 <- case fixity of
Prefix -> repTyArgs (repNamedTyCon tc) tys
@@ -907,26 +907,16 @@ repC (L _ (ConDeclGADT { con_names = cons
= repGadtDataCons cons args res_ty
| otherwise
- = addHsOuterGadtTyVarBinds outer_bndrs $ \ th_outer_bndrs ->
+ = addHsOuterSigTyVarBinds outer_bndrs $ \ outer_bndrs' ->
-- See Note [Don't quantify implicit type variables in quotes]
- do { ex_bndrs <- case th_outer_bndrs of
- Nothing -> coreListM tyVarBndrSpecTyConName []
- Just invis_bndrs -> pure invis_bndrs
- ; c' <- repGadtDataCons cons args res_ty
+ do { c' <- repGadtDataCons cons args res_ty
; ctxt' <- repMbContext mcxt
; if null_outer_exp_tvs && isNothing mcxt
then return c'
- else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
+ else rep2 forallCName ([unC outer_bndrs', unC ctxt', unC c']) }
where
- null_outer_imp_tvs = case outer_bndrs of
- HsOuterImplicit{hso_ximplicit = imp_bndrs} -> null imp_bndrs
- HsOuterExplicit{} -> True
- -- Vacuously true, as there is no implicit quantification
-
- null_outer_exp_tvs = case outer_bndrs of
- HsOuterExplicit{hso_bndrs = exp_bndrs} -> null exp_bndrs
- HsOuterImplicit{} -> True
- -- Vacuously true, as there is no outermost explicit quantification
+ null_outer_imp_tvs = nullOuterImplicit outer_bndrs
+ null_outer_exp_tvs = nullOuterExplicit outer_bndrs
repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))
repMbContext Nothing = repContext []
@@ -1002,10 +992,10 @@ rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_sig (L loc (TypeSig _ nms ty))
= mapM (rep_wc_ty_sig sigDName loc ty) nms
rep_sig (L loc (PatSynSig _ nms ty))
- = mapM (rep_patsyn_ty_sig loc ty) nms
+ = mapM (rep_patsyn_ty_sig' loc ty) nms
rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
- | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
- | otherwise = mapM (rep_ty_sig sigDName loc ty) nms
+ | is_deflt = mapM (rep_ty_sig_ defaultSigDName loc ty) nms
+ | otherwise = mapM (rep_ty_sig_ sigDName loc ty) nms
rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d loc fix_sig
rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
@@ -1029,6 +1019,16 @@ rep_ty_sig_tvs explicit_tvs
-- NB: Don't pass any implicit type variables to repList above
-- See Note [Don't quantify implicit type variables in quotes]
+-- TODO RGS: This is the REAL rep_ty_sig_tvs. Delete the one above when ready.
+rep_ty_sig_tvs' :: HsOuterSigTyVarBndrs GhcRn
+ -> MetaM (Core [M TH.TyVarBndrSpec])
+rep_ty_sig_tvs' (HsOuterImplicit{}) =
+ coreListM tyVarBndrSpecTyConName []
+ -- See Note [Don't quantify implicit type variables in quotes]
+rep_ty_sig_tvs' (HsOuterExplicit{hso_bndrs = explicit_tvs}) =
+ repListM tyVarBndrSpecTyConName repTyVarBndr
+ explicit_tvs
+
-- Desugar a top-level type signature. Unlike 'repHsSigType', this
-- deliberately avoids gensymming the type variables.
-- See Note [Scoped type variables in quotes]
@@ -1057,6 +1057,27 @@ rep_ty_sig' sig_ty
then return th_ty
else repTForall th_explicit_tvs th_ctxt th_ty }
+-- TODO RGS: This is the REAL rep_ty_sig. Delete the one above when ready.
+rep_ty_sig_ :: Name -> SrcSpan -> LHsSigType' GhcRn -> Located Name
+ -> MetaM (SrcSpan, Core (M TH.Dec))
+rep_ty_sig_ mk_sig loc sig_ty nm
+ = do { nm1 <- lookupLOcc nm
+ ; ty1 <- rep_ty_sig'_ sig_ty
+ ; sig <- repProto mk_sig nm1 ty1
+ ; return (loc, sig) }
+
+-- TODO RGS: This is the REAL rep_ty_sig'. Delete the one above when ready.
+rep_ty_sig'_ :: LHsSigType' GhcRn
+ -> MetaM (Core (M TH.Type))
+rep_ty_sig'_ (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body}))
+ | (ctxt, tau) <- splitLHsQualTy body
+ = do { th_explicit_tvs <- rep_ty_sig_tvs' outer_bndrs
+ ; th_ctxt <- repLContext ctxt
+ ; th_tau <- repLTy tau
+ ; if nullOuterExplicit outer_bndrs && null (unLoc ctxt)
+ then return th_tau
+ else repTForall th_explicit_tvs th_ctxt th_tau }
+
rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
-> MetaM (SrcSpan, Core (M TH.Dec))
-- represents a pattern synonym type signature;
@@ -1080,11 +1101,40 @@ rep_patsyn_ty_sig loc sig_ty nm
; sig <- repProto patSynSigDName nm1 ty1
; return (loc, sig) }
+-- TODO RGS: This is the REAL rep_patsyn_ty_sig. Delete the one above when ready.
+rep_patsyn_ty_sig' :: SrcSpan -> LHsSigType' GhcRn -> Located Name
+ -> MetaM (SrcSpan, Core (M TH.Dec))
+-- represents a pattern synonym type signature;
+-- see Note [Pattern synonym type signatures and Template Haskell] in "GHC.ThToHs"
+--
+-- Don't create the implicit and explicit variables when desugaring signatures,
+-- see Note [Scoped type variables in quotes]
+-- and Note [Don't quantify implicit type variables in quotes]
+rep_patsyn_ty_sig' loc sig_ty nm
+ | (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy' sig_ty
+ = do { nm1 <- lookupLOcc nm
+ ; th_univs <- rep_ty_sig_tvs univs
+ ; th_exis <- rep_ty_sig_tvs exis
+
+ ; th_reqs <- repLContext reqs
+ ; th_provs <- repLContext provs
+ ; th_ty <- repLTy ty
+ ; ty1 <- repTForall th_univs th_reqs =<<
+ repTForall th_exis th_provs th_ty
+ ; sig <- repProto patSynSigDName nm1 ty1
+ ; return (loc, sig) }
+
rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
-> MetaM (SrcSpan, Core (M TH.Dec))
rep_wc_ty_sig mk_sig loc sig_ty nm
= rep_ty_sig mk_sig loc (hswc_body sig_ty) nm
+-- TODO RGS: This is the REAL rep_wc_ty_sig. Delete the one above when ready.
+rep_wc_ty_sig' :: Name -> SrcSpan -> LHsSigWcType' GhcRn -> Located Name
+ -> MetaM (SrcSpan, Core (M TH.Dec))
+rep_wc_ty_sig' mk_sig loc sig_ty nm
+ = rep_ty_sig_ mk_sig loc (hswc_body sig_ty) nm
+
rep_inline :: Located Name
-> InlinePragma -- Never defaultInlinePragma
-> SrcSpan
@@ -1192,17 +1242,28 @@ addHsOuterFamEqnTyVarBinds outer_bndrs thing_inside = do
mk_qtvs imp_tvs exp_tvs = HsQTvs { hsq_ext = imp_tvs
, hsq_explicit = exp_tvs }
-addHsOuterGadtTyVarBinds ::
- HsOuterGadtTyVarBndrs GhcRn
- -- TODO RGS: Turn that argument into type Core [M TH.TyVarBndrSpec]. It's easier that way,
- -- and more consistent with what addHsOuterFamEqnTyVarBinds does.
- -> (Maybe (Core [M TH.TyVarBndrSpec]) -> MetaM (Core (M a)))
+addHsOuterSigTyVarBinds ::
+ HsOuterSigTyVarBndrs GhcRn
+ -> (Core [M TH.TyVarBndrSpec] -> MetaM (Core (M a)))
-> MetaM (Core (M a))
-addHsOuterGadtTyVarBinds outer_bndrs thing_inside = case outer_bndrs of
- HsOuterImplicit{hso_ximplicit = imp_tvs} ->
- addSimpleTyVarBinds imp_tvs $ thing_inside Nothing
+addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = imp_tvs} -> do
+ th_nil <- coreListM tyVarBndrSpecTyConName []
+ addSimpleTyVarBinds imp_tvs $ thing_inside th_nil
HsOuterExplicit{hso_bndrs = exp_bndrs} ->
- addHsTyVarBinds exp_bndrs $ thing_inside . Just
+ addHsTyVarBinds exp_bndrs thing_inside
+
+-- TODO RGS: Docs
+nullOuterImplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool
+nullOuterImplicit (HsOuterImplicit{hso_ximplicit = imp_bndrs}) = null imp_bndrs
+nullOuterImplicit (HsOuterExplicit{}) = True
+ -- Vacuously true, as there is no implicit quantification
+
+-- TODO RGS: Docs
+nullOuterExplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool
+nullOuterExplicit (HsOuterExplicit{hso_bndrs = exp_bndrs}) = null exp_bndrs
+nullOuterExplicit (HsOuterImplicit{}) = True
+ -- Vacuously true, as there is no outermost explicit quantification
addSimpleTyVarBinds :: [Name] -- the binders to be added
-> MetaM (Core (M a)) -- action in the ext env
@@ -1307,25 +1368,14 @@ repLHsSigType lsig_ty = repHsSigType' (unLoc lsig_ty)
-- TODO RGS: This is the REAL repHsSigType. Delete the one above when ready
repHsSigType' :: HsSigType GhcRn -> MetaM (Core (M TH.Type))
-repHsSigType' (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) =
- case outer_bndrs of
- HsOuterImplicit{hso_ximplicit = implicit_tvs} ->
- addSimpleTyVarBinds implicit_tvs $ repLTy body
- HsOuterExplicit{hso_bndrs = tele} -> case tele of
- HsForAllInvis{hsf_invis_bndrs = invis_bndrs} ->
- addHsTyVarBinds invis_bndrs $ \ th_invis_bndrs ->
- let (ctxt, tau) = splitLHsQualTy body in
- if null invis_bndrs && null (unLoc ctxt)
- then repLTy body
- else do th_ctxt <- repLContext ctxt
- th_tau <- repLTy tau
- repTForall th_invis_bndrs th_ctxt th_tau
- HsForAllVis{hsf_vis_bndrs = vis_bndrs } ->
- addHsTyVarBinds vis_bndrs $ \ th_vis_bndrs -> do
- th_body <- repLTy body
- if null vis_bndrs
- then pure th_body
- else repTForallVis th_vis_bndrs th_body
+repHsSigType' (HsSig { sig_bndrs = outer_bndrs, sig_body = body })
+ | (ctxt, tau) <- splitLHsQualTy body
+ = addHsOuterSigTyVarBinds outer_bndrs $ \ th_outer_bndrs ->
+ do { th_ctxt <- repLContext ctxt
+ ; th_tau <- repLTy tau
+ ; if nullOuterExplicit outer_bndrs && null (unLoc ctxt)
+ then pure th_tau
+ else repTForall th_outer_bndrs th_ctxt th_tau }
-- yield the representation of a list of types
repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]
@@ -2509,8 +2559,8 @@ repDerivStrategy mds thing_inside =
StockStrategy -> thing_inside =<< just =<< repStockStrategy
AnyclassStrategy -> thing_inside =<< just =<< repAnyclassStrategy
NewtypeStrategy -> thing_inside =<< just =<< repNewtypeStrategy
- ViaStrategy ty -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $
- do ty' <- rep_ty_sig' ty
+ ViaStrategy ty -> addSimpleTyVarBinds (get_scoped_tvs_from_sig' ty) $
+ do ty' <- rep_ty_sig'_ ty
via_strat <- repViaStrategy ty'
m_via_strat <- just via_strat
thing_inside m_via_strat
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1128,7 +1128,8 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where
]
ExprWithTySig _ expr sig ->
[ toHie expr
- , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
+ -- TODO RGS: Figure out how to do this correctly
+ -- , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
]
ArithSeq _ _ info ->
[ toHie info
@@ -1522,7 +1523,10 @@ instance ToHie (Located (DerivStrategy GhcRn)) where
StockStrategy -> []
AnyclassStrategy -> []
NewtypeStrategy -> []
- ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
+ ViaStrategy s -> [ {-
+ TODO RGS: Figure out how to do this properly
+
+ toHie $ TS (ResolvedScopes []) s -} ]
instance ToHie (Located OverlapMode) where
toHie (L span _) = locOnly span
@@ -1611,17 +1615,20 @@ instance HiePass p => ToHie (SigContext (Located (Sig (GhcPass p)))) where
HieRn -> concatM $ makeNode sig sp : case sig of
TypeSig _ names typ ->
[ toHie $ map (C TyDecl) names
- , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
+ -- TODO RGS: Figure out how to do this correctly
+ -- , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
]
PatSynSig _ names typ ->
[ toHie $ map (C TyDecl) names
- , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
+ -- TODO RGS: Figure out how to do this correctly
+ -- , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
]
ClassOpSig _ _ names typ ->
[ case styp of
ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
_ -> toHie $ map (C $ TyDecl) names
- , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
+ -- TODO RGS: Figure out how to do this correctly
+ -- , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
]
IdSig _ _ -> []
FixSig _ fsig ->
@@ -1865,8 +1872,11 @@ instance ToHie (Located (InstDecl GhcRn)) where
instance ToHie (Located (ClsInstDecl GhcRn)) where
toHie (L span decl) = concatM
- [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
- , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
+ [ {-
+ TODO RGS: Figure out what to do here
+
+ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
+ , -} toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
, toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
, concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl
, toHie $ cid_tyfam_insts decl
@@ -1891,8 +1901,11 @@ instance ToHie (Context a)
instance ToHie (Located (DerivDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
DerivDecl _ typ strat overlap ->
- [ toHie $ TS (ResolvedScopes []) typ
- , toHie strat
+ [ {-
+ TODO RGS: Figure out what to do here
+
+ toHie $ TS (ResolvedScopes []) typ
+ , -} toHie strat
, toHie overlap
]
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1158,7 +1158,7 @@ sks_vars :: { Located [Located RdrName] } -- Returned in reverse order
| oqtycon { sL1 $1 [$1] }
inst_decl :: { LInstDecl GhcPs }
- : 'instance' overlap_pragma inst_type where_inst
+ : 'instance' overlap_pragma inst_type2 where_inst
{% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)
; let cid = ClsInstDecl { cid_ext = noExtField
, cid_poly_ty = $3, cid_binds = binds
@@ -1166,7 +1166,7 @@ inst_decl :: { LInstDecl GhcPs }
, cid_tyfam_insts = ats
, cid_overlap_mode = $2
, cid_datafam_insts = adts }
- ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))
+ ; ams (L (comb3 $1 $3 $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))
(mj AnnInstance $1 : (fst $ unLoc $4)) } }
-- type instance declarations
@@ -1213,7 +1213,7 @@ deriv_strategy_no_via :: { LDerivStrategy GhcPs }
[mj AnnNewtype $1] }
deriv_strategy_via :: { LDerivStrategy GhcPs }
- : 'via' ktype {% ams (sLL $1 $> (ViaStrategy (mkLHsSigType $2)))
+ : 'via' sigktype2 {% ams (sLL $1 $> (ViaStrategy $2))
[mj AnnVia $1] }
deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }
@@ -1441,10 +1441,10 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}'
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl GhcPs }
- : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type
+ : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type2
{% do { let { err = text "in the stand-alone deriving instance"
<> colon <+> quotes (ppr $5) }
- ; ams (sLL $1 (hsSigType $>)
+ ; ams (sLL $1 $>
(DerivDecl noExtField (mkHsWildCardBndrs $5) $2 $4))
[mj AnnDeriving $1, mj AnnInstance $3] } }
@@ -1516,8 +1516,8 @@ where_decls :: { Located ([AddAnn]
,sL1 $3 (snd $ unLoc $3)) }
pattern_synonym_sig :: { LSig GhcPs }
- : 'pattern' con_list '::' sigtype
- {% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) (mkLHsSigType $4))
+ : 'pattern' con_list '::' sigtype2
+ {% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) $4)
[mj AnnPattern $1, mu AnnDcolon $3] }
-----------------------------------------------------------------------------
@@ -1530,12 +1530,12 @@ decl_cls : at_decl_cls { $1 }
| decl { $1 }
-- A 'default' signature used with the generic-programming extension
- | 'default' infixexp '::' sigtype
+ | 'default' infixexp '::' sigtype2
{% runPV (unECP $2) >>= \ $2 ->
do { v <- checkValSigLhs $2
; let err = text "in default signature" <> colon <+>
quotes (ppr $2)
- ; ams (sLL $1 $> $ SigD noExtField $ ClassOpSig noExtField True [v] $ mkLHsSigType $4)
+ ; ams (sLL $1 $> $ SigD noExtField $ ClassOpSig noExtField True [v] $4)
[mj AnnDefault $1,mu AnnDcolon $3] } }
decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
@@ -1885,21 +1885,8 @@ sigktype2 :: { LHsSigType' GhcPs }
-- TODO RGS: Docs
-- TODO RGS: This is the REAL sigtype production. Delete the one above (and rename this) when ready
sigtype2 :: { LHsSigType' GhcPs }
- : forall_telescope ctype {% let (forall_tok, forall_anns, forall_tele) = unLoc $1 in
- hintExplicitForall LangExt.ScopedTypeVariables forall_tok
- >> ams (sLL $1 $> $
- mkHsExplicitSigType forall_tele $2)
- forall_anns }
- | context '=>' ctype {% do { addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
- ; return $
- sLL $1 $> $ mkHsImplicitSigType $
- sLL $1 $> $ HsQualTy { hst_ctxt = $1
- , hst_xqual = noExtField
- , hst_body = $3 }}}
- | ipvar '::' type {% ams (sLL $1 $> $ mkHsImplicitSigType $
- sLL $1 $> $ HsIParamTy noExtField $1 $3)
- [mu AnnDcolon $2] }
- | type { sL1 $1 $ mkHsImplicitSigType $1 }
+ : ctype_w_ext {% do { ty <- $1 LangExt.ScopedTypeVariables
+ ; pure (hsTypeToHsSigType ty) }}
sig_vars :: { Located [Located RdrName] } -- Returned in reversed order
: sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1)
@@ -1926,40 +1913,51 @@ unpackedness :: { Located UnpackednessPragma }
: '{-# UNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getUNPACK_PRAGs $1) SrcUnpack) }
| '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getNOUNPACK_PRAGs $1) SrcNoUnpack) }
-forall_telescope :: { Located (Located Token, [AddAnn], HsForAllTelescope GhcPs) }
- : 'forall' tv_bndrs '.' { sLL $1 $>
- ( $1
- , [mu AnnForall $1, mu AnnDot $3]
- , mkHsForAllInvisTele $2 ) }
- | 'forall' tv_bndrs '->' {% do { req_tvbs <- fromSpecTyVarBndrs $2
- ; pure $ sLL $1 $> $
- ( $1
- , [mu AnnForall $1, mu AnnRarrow $3]
- , mkHsForAllVisTele req_tvbs ) }}
+-- TODO RGS: Explain the Extension argument
+forall_telescope :: { LangExt.Extension -> P (Located ([AddAnn], HsForAllTelescope GhcPs)) }
+ : 'forall' tv_bndrs '.' { \ext ->
+ do { hintExplicitForall ext $1
+ ; pure $ sLL $1 $>
+ ( [mu AnnForall $1, mu AnnDot $3]
+ , mkHsForAllInvisTele $2 ) }}
+ | 'forall' tv_bndrs '->' { \_ ->
+ do { hintExplicitForall LangExt.RankNTypes $1
+ ; req_tvbs <- fromSpecTyVarBndrs $2
+ ; pure $ sLL $1 $> $
+ ( [mu AnnForall $1, mu AnnRarrow $3]
+ , mkHsForAllVisTele req_tvbs ) }}
-- A ktype is a ctype, possibly with a kind annotation
ktype :: { LHsType GhcPs }
: ctype { $1 }
| ctype '::' kind {% ams (sLL $1 $> $ HsKindSig noExtField $1 $3)
[mu AnnDcolon $2] }
+-- A ctype is a for-all type
+-- TODO RGS: More docs
+ctype :: { LHsType GhcPs }
+ : ctype_w_ext {% $1 LangExt.RankNTypes }
-- A ctype is a for-all type
-ctype :: { LHsType GhcPs }
- : forall_telescope ctype {% let (forall_tok, forall_anns, forall_tele) = unLoc $1 in
- hintExplicitForall LangExt.RankNTypes forall_tok
- >> ams (sLL $1 $> $
- HsForAllTy { hst_tele = forall_tele
- , hst_xforall = noExtField
- , hst_body = $2 })
- forall_anns }
- | context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
- >> return (sLL $1 $> $
- HsQualTy { hst_ctxt = $1
- , hst_xqual = noExtField
- , hst_body = $3 }) }
- | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExtField $1 $3))
- [mu AnnDcolon $2] }
- | type { $1 }
+-- TODO RGS: Explain the Extension argument. Revise the docs.
+ctype_w_ext :: { LangExt.Extension -> P (LHsType GhcPs) }
+ : forall_telescope ctype { \ext ->
+ do { ltele <- $1 ext
+ ; let (forall_anns, forall_tele) = unLoc ltele
+ ; ams (sLL ltele $> $
+ HsForAllTy { hst_tele = forall_tele
+ , hst_xforall = noExtField
+ , hst_body = $2 })
+ forall_anns }}
+ | context '=>' ctype { \_ ->
+ addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
+ >> return (sLL $1 $> $
+ HsQualTy { hst_ctxt = $1
+ , hst_xqual = noExtField
+ , hst_body = $3 }) }
+ | ipvar '::' type { \_ ->
+ ams (sLL $1 $> (HsIParamTy noExtField $1 $3))
+ [mu AnnDcolon $2] }
+ | type { \_ -> pure $1 }
----------------------
-- Notes for 'context'
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1599,6 +1599,7 @@ instance DisambECP (HsExpr GhcPs) where
mkHsLitPV (L l a) = return $ L l (HsLit noExtField a)
mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a)
mkHsWildCardPV l = return $ L l hsHoleExpr
+ -- mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (hsTypeToHsSigWcType sig))
mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (mkLHsSigWcType sig))
mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs)
mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp
=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -925,8 +925,8 @@ instance HasHaddock (Located (HsSigType GhcPs)) where
-- HasHaddock instance for HsType. Is this right? Need Vlad to check.
extendHdkA l $ do
case outer_bndrs of
- HsOuterImplicit{} -> pure ()
- HsOuterExplicit{hso_bndrs = tele} -> registerLocHdkA (getForAllTeleLoc tele)
+ HsOuterImplicit{} -> pure ()
+ HsOuterExplicit{hso_bndrs = bndrs} -> registerLocHdkA (getLHsTyVarBndrsLoc bndrs)
body' <- addHaddock body
pure $ L l $ HsSig noExtField outer_bndrs body'
@@ -1461,10 +1461,12 @@ mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noExtField t doc)
getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan
getForAllTeleLoc tele =
- foldr combineSrcSpans noSrcSpan $
case tele of
- HsForAllVis{ hsf_vis_bndrs } -> map getLoc hsf_vis_bndrs
- HsForAllInvis { hsf_invis_bndrs } -> map getLoc hsf_invis_bndrs
+ HsForAllVis{ hsf_vis_bndrs } -> getLHsTyVarBndrsLoc hsf_vis_bndrs
+ HsForAllInvis { hsf_invis_bndrs } -> getLHsTyVarBndrsLoc hsf_invis_bndrs
+
+getLHsTyVarBndrsLoc :: [LHsTyVarBndr flag GhcPs] -> SrcSpan
+getLHsTyVarBndrsLoc bndrs = foldr combineSrcSpans noSrcSpan $ map getLoc bndrs
-- | The inverse of 'partitionBindsAndSigs' that merges partitioned items back
-- into a flat list. Elements are put back into the order in which they
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -610,11 +610,11 @@ mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` []
get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name])
-- Returns (binders, scoped tvs for those binders)
get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty))
- = Just (names, hsScopedTvs sig_ty)
+ = Just (names, hsScopedTvs' sig_ty)
get_scoped_tvs (L _ (TypeSig _ names sig_ty))
= Just (names, hsWcScopedTvs sig_ty)
get_scoped_tvs (L _ (PatSynSig _ names sig_ty))
- = Just (names, hsScopedTvs sig_ty)
+ = Just (names, hsScopedTvs' sig_ty)
get_scoped_tvs _ = Nothing
-- Process the fixity declarations, making a FastString -> (Located Fixity) map
@@ -965,7 +965,7 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
; when (is_deflt && not defaultSigs_on) $
addErr (defaultSigErr sig)
; new_v <- mapM (lookupSigOccRn ctxt sig) vs
- ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty
+ ; (new_ty, fvs) <- rnLHsSigType ty_ctxt TypeLevel ty
; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) }
where
(v1:_) = vs
@@ -1017,7 +1017,7 @@ renameSig ctxt sig@(MinimalSig _ s (L l bf))
renameSig ctxt sig@(PatSynSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
- ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty
+ ; (ty', fvs) <- rnLHsSigType ty_ctxt TypeLevel ty
; return (PatSynSig noExtField new_vs ty', fvs) }
where
ty_ctxt = GenericCtx (text "a pattern synonym signature for"
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -13,7 +13,7 @@ module GHC.Rename.HsType (
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind, rnLHsTypeArgs,
rnHsSigType, rnLHsSigType, rnHsSigType', rnHsWcType,
- HsSigWcTypeScoping(..), rnHsSigWcType, rnHsPatSigType,
+ HsSigWcTypeScoping(..), rnHsSigWcType, rnLHsSigWcType, rnHsPatSigType,
newTyVarNameRn,
rnConDeclFields,
rnLTyVar,
@@ -25,14 +25,13 @@ module GHC.Rename.HsType (
checkPrecMatch, checkSectionPrec,
-- Binding related stuff
- bindHsOuterFamEqnTyVarBndrs, bindHsOuterGadtTyVarBndrs,
- bindHsForAllTelescope,
+ bindHsOuterTyVarBndrs, bindHsForAllTelescope,
bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),
rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars,
FreeKiTyVars,
extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
extractHsTysRdrTyVars, extractRdrKindSigVars, extractDataDefnKindVars,
- extractHsOuterGadtTvBndrs, extractHsTyArgRdrKiTyVars,
+ extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars,
forAllOrNothing, nubL
) where
@@ -133,6 +132,22 @@ rnHsSigWcType doc (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
wc_ty = HsWC { hswc_ext = nwcs, hswc_body = ib_ty } in
pure (wc_ty, emptyFVs)
+-- TODO RGS: This is the REAL rnHsSigWcType. Delete the one above when ready.
+rnLHsSigWcType :: HsDocContext
+ -> LHsSigWcType' GhcPs
+ -> RnM (LHsSigWcType' GhcRn, FreeVars)
+rnLHsSigWcType doc (HsWC { hswc_body =
+ sig_ty@(L loc (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty })) })
+ = do { free_vars <- filterInScopeM (extract_lhs_sig_ty sig_ty)
+ ; (nwc_rdrs', imp_tv_nms) <- partition_nwcs free_vars
+ ; let nwc_rdrs = nubL nwc_rdrs'
+ ; bindHsOuterTyVarBndrs doc Nothing imp_tv_nms outer_bndrs $ \outer_bndrs' ->
+ do { (wcs, body_ty', fvs) <- rnWcBody doc nwc_rdrs body_ty
+ ; pure ( HsWC { hswc_ext = wcs, hswc_body = L loc $
+ HsSig { sig_ext = noExtField
+ , sig_bndrs = outer_bndrs', sig_body = body_ty' }}
+ , fvs) } }
+
rnHsPatSigType :: HsSigWcTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
@@ -354,7 +369,7 @@ rnHsSigType' ctx level
sig_ty@(HsSig { sig_bndrs = outer_bndrs, sig_body = body })
= do { traceRn "rnHsSigType" (ppr sig_ty)
; imp_vars <- filterInScopeM $ extractHsTyRdrTyVars body
- ; bindHsOuterSigTyVarBndrs ctx imp_vars outer_bndrs $ \outer_bndrs' ->
+ ; bindHsOuterTyVarBndrs ctx Nothing imp_vars outer_bndrs $ \outer_bndrs' ->
do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) body
; return ( HsSig { sig_ext = noExtField
@@ -1071,14 +1086,15 @@ an LHsQTyVars can be semantically significant. As a result, we suppress
-Wunused-foralls warnings in exactly one place: in bindHsQTyVars.
-}
-bindHsOuterFamEqnTyVarBndrs :: HsDocContext
- -> Maybe assoc
- -- ^ @'Just' _@ => an associated type decl
- -> FreeKiTyVars
- -> HsOuterFamEqnTyVarBndrs GhcPs
- -> (HsOuterFamEqnTyVarBndrs GhcRn -> RnM (a, FreeVars))
- -> RnM (a, FreeVars)
-bindHsOuterFamEqnTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside =
+bindHsOuterTyVarBndrs :: OutputableBndrFlag flag
+ => HsDocContext
+ -> Maybe assoc
+ -- ^ @'Just' _@ => an associated type decl
+ -> FreeKiTyVars
+ -> HsOuterTyVarBndrs flag GhcPs
+ -> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+bindHsOuterTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside =
case outer_bndrs of
HsOuterImplicit{} ->
rnImplicitBndrs mb_cls implicit_vars $ \implicit_vars' ->
@@ -1092,36 +1108,6 @@ bindHsOuterFamEqnTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside =
thing_inside $ HsOuterExplicit{ hso_xexplicit = noExtField
, hso_bndrs = exp_bndrs' }
-bindHsOuterGadtTyVarBndrs :: HsDocContext
- -> FreeKiTyVars
- -> HsOuterGadtTyVarBndrs GhcPs
- -> (HsOuterGadtTyVarBndrs GhcRn -> RnM (a, FreeVars))
- -> RnM (a, FreeVars)
-bindHsOuterGadtTyVarBndrs doc implicit_vars outer_bndrs thing_inside =
- case outer_bndrs of
- HsOuterImplicit{} ->
- rnImplicitBndrs Nothing implicit_vars $ \implicit_vars' ->
- thing_inside $ HsOuterImplicit{ hso_ximplicit = implicit_vars' }
- HsOuterExplicit{hso_bndrs = exp_bndrs} ->
- bindLHsTyVarBndrs doc WarnUnusedForalls Nothing exp_bndrs $ \exp_bndrs' ->
- thing_inside $ HsOuterExplicit{ hso_xexplicit = noExtField
- , hso_bndrs = exp_bndrs' }
-
-bindHsOuterSigTyVarBndrs :: HsDocContext
- -> FreeKiTyVars
- -> HsOuterSigTyVarBndrs GhcPs
- -> (HsOuterSigTyVarBndrs GhcRn -> RnM (a, FreeVars))
- -> RnM (a, FreeVars)
-bindHsOuterSigTyVarBndrs doc implicit_vars outer_bndrs thing_inside =
- case outer_bndrs of
- HsOuterImplicit{} ->
- rnImplicitBndrs Nothing implicit_vars $ \implicit_vars' ->
- thing_inside $ HsOuterImplicit{ hso_ximplicit = implicit_vars' }
- HsOuterExplicit{hso_bndrs = tele} ->
- bindHsForAllTelescope doc tele $ \tele' ->
- thing_inside $ HsOuterExplicit{ hso_xexplicit = noExtField
- , hso_bndrs = tele' }
-
bindHsForAllTelescope :: HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
@@ -1917,6 +1903,10 @@ extract_lty (L _ ty) acc
-- We deal with these separately in rnLHsTypeWithWildCards
HsWildCardTy {} -> acc
+extract_lhs_sig_ty :: LHsSigType' GhcPs -> FreeKiTyVars
+extract_lhs_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =
+ extractHsOuterTvBndrs outer_bndrs $ extract_lty body []
+
extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->
FreeKiTyVars
extract_hs_arrow (HsExplicitMult p) acc = extract_lty p acc
@@ -1933,10 +1923,10 @@ extract_hs_for_all_telescope tele acc_vars body_fvs =
HsForAllInvis { hsf_invis_bndrs = bndrs } ->
extract_hs_tv_bndrs bndrs acc_vars body_fvs
-extractHsOuterGadtTvBndrs :: HsOuterGadtTyVarBndrs GhcPs
- -> FreeKiTyVars -- Free in body
- -> FreeKiTyVars -- Free in result
-extractHsOuterGadtTvBndrs outer_bndrs body_fvs =
+extractHsOuterTvBndrs :: HsOuterTyVarBndrs flag GhcPs
+ -> FreeKiTyVars -- Free in body
+ -> FreeKiTyVars -- Free in result
+extractHsOuterTvBndrs outer_bndrs body_fvs =
case outer_bndrs of
HsOuterImplicit{} ->
body_fvs
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -35,7 +35,7 @@ import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames
, checkShadowedRdrNames, warnUnusedTypePatterns
, extendTyVarEnvFVRn, newLocalBndrsRn
, withHsDocContext, noNestedForallsContextsErr
- , addNoNestedForallsContextsErr, checkInferredVars )
+ , addNoNestedForallsContextsErr, checkInferredVars, checkInferredVars' )
import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr )
import GHC.Rename.Names
import GHC.Rename.Doc ( rnHsDoc, rnMbLHsDoc )
@@ -450,7 +450,7 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid })
--
-- See also descriptions of 'checkCanonicalMonadInstances' and
-- 'checkCanonicalMonoidInstances'
-checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
+checkCanonicalInstances :: Name -> LHsSigType' GhcRn -> LHsBinds GhcRn -> RnM ()
checkCanonicalInstances cls poly_ty mbinds = do
whenWOptM Opt_WarnNonCanonicalMonadInstances
checkCanonicalMonadInstances
@@ -589,9 +589,9 @@ checkCanonicalInstances cls poly_ty mbinds = do
]
-- stolen from GHC.Tc.TyCl.Instance
- instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
+ instDeclCtxt1 :: LHsSigType' GhcRn -> SDoc
instDeclCtxt1 hs_inst_ty
- = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
+ = inst_decl_ctxt (ppr (getLHsInstDeclHead' hs_inst_ty))
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt doc = hang (text "in the instance declaration for")
@@ -603,9 +603,9 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
, cid_sigs = uprags, cid_tyfam_insts = ats
, cid_overlap_mode = oflag
, cid_datafam_insts = adts })
- = do { checkInferredVars ctxt inf_err inst_ty
- ; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty
- ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
+ = do { checkInferredVars' ctxt inf_err inst_ty
+ ; (inst_ty', inst_fvs) <- rnLHsSigType ctxt TypeLevel inst_ty
+ ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy' inst_ty'
-- Check if there are any nested `forall`s or contexts, which are
-- illegal in the type of an instance declaration (see
-- Note [No nested foralls or contexts in instance types] in
@@ -724,15 +724,7 @@ rnFamEqn doc atfi rhs_kvars
-- @
; let all_imp_vars = pat_kity_vars_with_dups ++ rhs_kvars
- {-
- TODO RGS: Delete
-
- ; rnImplicitBndrs mb_cls all_imp_vars $ \all_imp_var_names' ->
- bindLHsTyVarBndrs doc WarnUnusedForalls
- Nothing (fromMaybe [] mb_bndrs) $ \bndrs' ->
- -}
- ; bindHsOuterFamEqnTyVarBndrs doc mb_cls all_imp_vars
- outer_bndrs $ \rn_outer_bndrs ->
+ ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->
do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
; (payload', rhs_fvs) <- rn_payload doc payload
@@ -1075,22 +1067,22 @@ rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
rnSrcDerivDecl (DerivDecl _ ty mds overlap)
= do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
; unless standalone_deriv_ok (addErr standaloneDerivErr)
- ; checkInferredVars ctxt inf_err nowc_ty
- ; (mds', ty', fvs) <- rnLDerivStrategy ctxt mds $ rnHsSigWcType ctxt ty
+ ; checkInferredVars' ctxt inf_err nowc_ty
+ ; (mds', ty', fvs) <- rnLDerivStrategy ctxt mds $ rnLHsSigWcType ctxt ty
-- Check if there are any nested `forall`s or contexts, which are
-- illegal in the type of an instance declaration (see
-- Note [No nested foralls or contexts in instance types] in
-- GHC.Hs.Type).
; addNoNestedForallsContextsErr ctxt
(text "Standalone-derived instance head")
- (getLHsInstDeclHead $ dropWildCards ty')
+ (getLHsInstDeclHead' $ dropWildCards' ty')
; warnNoDerivStrat mds' loc
; return (DerivDecl noExtField ty' mds' overlap, fvs) }
where
ctxt = DerivDeclCtx
inf_err = Just (text "Inferred type variables are not allowed")
- loc = getLoc $ hsib_body nowc_ty
- nowc_ty = dropWildCards ty
+ loc = getLoc nowc_ty
+ nowc_ty = dropWildCards' ty
standaloneDerivErr :: SDoc
standaloneDerivErr
@@ -1946,19 +1938,22 @@ rnLDerivStrategy doc mds thing_inside
AnyclassStrategy -> boring_case AnyclassStrategy
NewtypeStrategy -> boring_case NewtypeStrategy
ViaStrategy via_ty ->
- do checkInferredVars doc inf_err via_ty
- (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty
- let HsIB { hsib_ext = via_imp_tvs
- , hsib_body = via_body } = via_ty'
- (via_exp_tv_bndrs, via_rho) = splitLHsForAllTyInvis_KP via_body
- via_exp_tvs = maybe [] hsLTyVarNames via_exp_tv_bndrs
- via_tvs = via_imp_tvs ++ via_exp_tvs
+ do checkInferredVars' doc inf_err via_ty
+ (via_ty', fvs1) <- rnLHsSigType doc TypeLevel via_ty
+ let HsSig { sig_bndrs = via_outer_bndrs
+ , sig_body = via_body } = unLoc via_ty'
+ -- TODO RGS: We also do something like this in splitLHsInstDeclTy.
+ -- Consider factoring this out into its own function in the same
+ -- vein as hsScopedTvs.
+ via_tvs = case via_outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = imp_tvs} -> imp_tvs
+ HsOuterExplicit{hso_bndrs = exp_bndrs} -> hsLTyVarNames exp_bndrs
-- Check if there are any nested `forall`s, which are illegal in a
-- `via` type.
-- See Note [No nested foralls or contexts in instance types]
-- (Wrinkle: Derived instances) in GHC.Hs.Type.
addNoNestedForallsContextsErr doc
- (quotes (text "via") <+> text "type") via_rho
+ (quotes (text "via") <+> text "type") via_body
(thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside
pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2)
@@ -2231,12 +2226,12 @@ rnConDecl (ConDeclGADT { con_names = names
-- variable, and hence the order needed for visible type application
-- See #14808.
implicit_bndrs =
- extractHsOuterGadtTvBndrs outer_bndrs $
+ extractHsOuterTvBndrs outer_bndrs $
extractHsTysRdrTyVars (theta ++ map hsScaledThing arg_tys ++ [res_ty])
; let ctxt = ConDeclCtx new_names
- ; bindHsOuterGadtTyVarBndrs ctxt implicit_bndrs outer_bndrs $ \outer_bndrs' ->
+ ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' ->
do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt
; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args
; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -800,7 +800,7 @@ getLocalNonValBinders fixity_env
-- be Nothing.
mb_cls_nm <- runMaybeT $ do
-- See (1) above
- L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty
+ L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe' inst_ty
-- See (2) above
MaybeT $ setSrcSpan loc $ lookupGlobalOccRn_maybe cls_rdr
-- Assuming the previous step succeeded, process any associated data
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -223,13 +223,8 @@ checkInferredVars' ctxt (Just msg) ty =
where
sig_exp_bndrs :: LHsSigType' GhcPs -> [HsTyVarBndr Specificity GhcPs]
sig_exp_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs})) = case outer_bndrs of
- HsOuterImplicit{}
- -> []
- HsOuterExplicit{hso_bndrs = exp_bndrs} -> case exp_bndrs of
- HsForAllInvis{hsf_invis_bndrs = invis_bndrs}
- -> map unLoc invis_bndrs
- HsForAllVis{}
- -> []
+ HsOuterImplicit{} -> []
+ HsOuterExplicit{hso_bndrs = exp_bndrs} -> map unLoc exp_bndrs
{-
Note [Unobservably inferred type variables]
=====================================
compiler/GHC/Tc/Deriv.hs
=====================================
@@ -628,7 +628,7 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))
; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat
; (cls_tvs, deriv_ctxt, cls, inst_tys)
<- tcExtendTyVarEnv via_tvs $
- tcStandaloneDerivInstType ctxt deriv_ty
+ tcStandaloneDerivInstType' ctxt deriv_ty
; let mb_deriv_strat = fmap unLoc mb_lderiv_strat
tvs = via_tvs ++ cls_tvs
-- See Note [Unify kinds in deriving]
@@ -733,6 +733,27 @@ tcStandaloneDerivInstType ctxt
let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
pure (tvs, SupplyContext theta, cls, inst_tys)
+-- TODO RGS: This is the REAL tcStandaloneDerivInstType. Delete the one above when ready.
+tcStandaloneDerivInstType'
+ :: UserTypeCtxt -> LHsSigWcType' GhcRn
+ -> TcM ([TyVar], DerivContext, Class, [Type])
+tcStandaloneDerivInstType' ctxt
+ (HsWC { hswc_body = deriv_ty@(L loc (HsSig { sig_bndrs = outer_bndrs
+ , sig_body = deriv_ty_body }))})
+ | (theta, rho) <- splitLHsQualTy deriv_ty_body
+ , L _ [wc_pred] <- theta
+ , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred
+ = do dfun_ty <- tcHsClsInstType' ctxt $ L loc $
+ HsSig { sig_ext = noExtField
+ , sig_bndrs = outer_bndrs
+ , sig_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)
+
warnUselessTypeable :: TcM ()
warnUselessTypeable
= do { warn <- woptM Opt_WarnDerivingTypeable
@@ -2296,6 +2317,6 @@ 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 :: LHsSigWcType' GhcRn -> SDoc
standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
2 (quotes (ppr ty))
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -1894,7 +1894,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
--
-- op :: forall c. a -> [T x] -> c -> Int
L loc $ ClassOpSig noExtField False [loc_meth_RDR]
- $ mkLHsSigType $ nlHsCoreTy to_ty
+ $ L loc $ mkHsImplicitSigType $ nlHsCoreTy to_ty
)
where
Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
@@ -1955,6 +1955,7 @@ nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty)
nlExprWithTySig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty
where
+ -- hs_ty = hsTypeToHsSigWcType s
hs_ty = mkLHsSigWcType s
nlHsCoreTy :: Type -> LHsType GhcPs
@@ -2002,8 +2003,6 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
fiddling around.
-}
--- | Generate the full code for an auxiliary binding.
--- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.
genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec
-> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecOriginal dflags loc spec
@@ -2081,8 +2080,8 @@ genAuxBindSpecDup loc original_rdr_name dup_spec
where
dup_rdr_name = auxBindSpecRdrName dup_spec
--- | Generate the type signature of an auxiliary binding.
--- See @Note [Auxiliary binders]@.
+-- | Generate the full code for an auxiliary binding.
+-- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.
genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
genAuxBindSpecSig loc spec = case spec of
DerivCon2Tag tycon _
@@ -2100,6 +2099,26 @@ genAuxBindSpecSig loc spec = case spec of
DerivDataConstr _ _ _
-> mkLHsSigWcType (nlHsTyVar constr_RDR)
+-- TODO RGS: This is the REAL genAuxBindSpecSig. Delete the one above when ready.
+genAuxBindSpecSig' :: SrcSpan -> AuxBindSpec -> LHsSigWcType' GhcPs
+genAuxBindSpecSig' loc spec = case spec of
+ DerivCon2Tag tycon _
+ -> mk_sig $ L loc $ XHsType $ NHsCoreTy $
+ mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
+ mkParentType tycon `mkVisFunTyMany` intPrimTy
+ DerivTag2Con tycon _
+ -> mk_sig $ L loc $
+ XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
+ intTy `mkVisFunTyMany` mkParentType tycon
+ DerivMaxTag _ _
+ -> mk_sig (L loc (XHsType (NHsCoreTy intTy)))
+ DerivDataDataType _ _ _
+ -> mk_sig (nlHsTyVar dataType_RDR)
+ DerivDataConstr _ _ _
+ -> mk_sig (nlHsTyVar constr_RDR)
+ where
+ mk_sig = mkHsWildCardBndrs . L loc . mkHsImplicitSigType
+
type SeparateBagsDerivStuff =
-- DerivAuxBinds
( Bag (LHsBind GhcPs, LSig GhcPs)
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -1749,6 +1749,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn
| TcIdSig (PartialSig { psig_hs_ty = hs_ty })
<- mapMaybe sig_fn (collectHsBindListBinders lbinds)
, let (_, L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ]
+ -- , let (L _ theta, _) = splitLHsQualTy (hsSigWcTypeBody hs_ty) ]
has_partial_sigs = not (null partial_sig_mrs)
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -16,8 +16,8 @@
module GHC.Tc.Gen.HsType (
-- Type signatures
kcClassSigType, tcClassSigType,
- tcHsSigType, tcLHsSigType, tcHsSigWcType,
- tcHsPartialSigType,
+ tcHsSigType, tcLHsSigType, tcHsSigWcType, tcLHsSigWcType,
+ tcHsPartialSigType, tcHsPartialSigType',
tcStandaloneKindSig,
funsSigCtxt, addSigCtxt, pprSigCtxt,
@@ -30,7 +30,7 @@ module GHC.Tc.Gen.HsType (
bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,
bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,
bindOuterFamEqnTKBndrs_Q_Skol, bindOuterFamEqnTKBndrs_Q_Tv,
- bindOuterGadtTKBndrs_Tv, bindOuterGadtTKBndrs_Skol,
+ bindOuterSigTKBndrs_Tv, bindOuterSigTKBndrs_Skol,
ContextKind(..),
-- Type checking type and class decls, and instances thereof
@@ -291,7 +291,14 @@ tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
-- 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 ()
+-- TODO RGS: This is the REAL tcHsSigWcType. Delete the one above when ready.
+tcLHsSigWcType :: 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.
+tcLHsSigWcType ctxt sig_ty = tcLHsSigType 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
@@ -304,22 +311,23 @@ kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()
-- 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, _)))
+kcClassSigType skol_info names
+ sig_ty@(L _ (HsSig { sig_bndrs = outer_bndrs, sig_body = hs_ty }))
+ = addSigCtxt (funsSigCtxt names) sig_ty $
+ do { (tc_lvl, (wanted, (imp_or_exp_tkvs, _)))
<- pushTcLevelM $
solveLocalEqualitiesX "kcClassSigType" $
- bindImplicitTKBndrs_Skol sig_vars $
+ bindOuterSigTKBndrs_Skol outer_bndrs $
tcLHsType hs_ty liftedTypeKind
+ ; let spec_tkvs = either id binderVars imp_or_exp_tkvs
; emitResidualTvConstraint skol_info spec_tkvs tc_lvl wanted }
-tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type
+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) $
- do { (implic, ty) <- tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind)
+ = addSigCtxt (funsSigCtxt names) sig_ty $
+ do { (implic, ty) <- tc_hs_sig_type' skol_info sig_ty (TheKind liftedTypeKind)
; emitImplication implic
; return ty }
-- Do not zonk-to-Type, nor perform a validity check
@@ -445,7 +453,7 @@ tc_hs_sig_type' skol_info (L loc (HsSig { sig_bndrs = outer_bndrs
-- should be in the global tyvars, and therefore won't be quantified
; imp_or_exp_tkvs <- bitraverse zonkAndScopedSort pure imp_or_exp_tkvs
- ; let ty1 = either mkSpecForAllTys mkForAllTys imp_or_exp_tkvs ty
+ ; let ty1 = either mkSpecForAllTys mkInvisForAllTys imp_or_exp_tkvs ty
-- This bit is very much like decideMonoTyVars in GHC.Tc.Solver,
-- but constraints are so much simpler in kinds, it is much
@@ -562,7 +570,7 @@ tc_top_lhs_sig_type mode (L loc sig_ty@(HsSig { sig_bndrs = outer_bndrs
; tc_lhs_type mode body kind }
; imp_or_exp_tkvs <- bitraverse zonkAndScopedSort pure imp_or_exp_tkvs
- ; let ty1 = either mkSpecForAllTys mkForAllTys imp_or_exp_tkvs ty
+ ; let ty1 = either mkSpecForAllTys mkInvisForAllTys imp_or_exp_tkvs ty
; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type
; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1)
; traceTc "tc_top_hs_sig_type }" (vcat [ppr sig_ty, ppr final_ty])
@@ -608,7 +616,7 @@ tcDerivStrategy mb_lds
tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy
tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy
tc_deriv_strategy (ViaStrategy ty) = do
- ty' <- checkNoErrs $ tcTopLHsType ty AnyKind
+ ty' <- checkNoErrs $ tcTopLHsSigType ty AnyKind
let (via_tvs, via_pred) = splitForAllTys ty'
pure (ViaStrategy via_pred, via_tvs)
@@ -3070,8 +3078,9 @@ cloneFlexiKindedTyVarTyVar = newFlexiKindedTyVar cloneTyVarTyVar
-- TODO RGS: Which of these do we actually need?
+{-
-- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope'.
--- TODO RGS: Consolidate with bindExplicitTK_Tele_Tv?
+-- TODO RGS: Consolidate with bindExplicitTK_Skol_M?
bindExplicitTKTele_Skol
:: HsForAllTelescope GhcRn
-> TcM a
@@ -3087,27 +3096,8 @@ bindExplicitTKTele_Skol tele thing_inside = case tele of
-- inv_tv_bndrs :: [VarBndr TyVar Specificity],
-- but we want [VarBndr TyVar ArgFlag]
; return (tyVarSpecToBinders inv_tv_bndrs, thing) }
-
-{-
--- | Clone the 'HsTyVarBndr's in an 'HsForAllTelescope'.
--- TODO RGS: Consolidate with bindExplicitTK_Tele_Skol?
-bindExplicitTKTele_Tv
- :: HsForAllTelescope GhcRn
- -> TcM a
- -> TcM (Either [TcReqTVBinder] [TcInvisTVBinder], a)
-bindExplicitTKTele_Tv tele thing_inside = case tele of
- HsForAllVis { hsf_vis_bndrs = bndrs } -> do
- (req_tv_bndrs, thing) <- bindExplicitTKBndrs_Tv bndrs thing_inside
- pure (Left req_tv_bndrs, thing)
- HsForAllInvis { hsf_invis_bndrs = bndrs } -> do
- (inv_tv_bndrs, thing) <- bindExplicitTKBndrs_Tv bndrs thing_inside
- pure (Right inv_tv_bndrs, thing)
-}
-{-
-TODO RGS: Consider renaming this to bindExplicitTKTele, as the QL patch does,
-if there are no other variants that work over HsForAllTelescopes
--}
-- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied
-- 'TcTyMode'.
bindExplicitTKTele_Skol_M
@@ -3217,52 +3207,38 @@ bindOuterFamEqnTKBndrs_Q_Tv :: ContextKind
-> TcM a
-> TcM ([TcTyVar], a)
bindOuterFamEqnTKBndrs_Q_Tv ctxt_kind outer_bndrs thing_inside = case outer_bndrs of
- HsOuterImplicit{hso_ximplicit = implicit_tkv_nms} -> do
- bindImplicitTKBndrs_Q_Tv implicit_tkv_nms thing_inside
- HsOuterExplicit{hso_bndrs = exp_bndrs} -> do
- bindExplicitTKBndrs_Q_Tv ctxt_kind exp_bndrs thing_inside
-
--- TODO RGS: Docs(?)
--- TODO RGS: Is the return type correct?
--- TODO RGS: Consolidate with bindHsOuter*TKBndrs_Tv?
-bindOuterGadtTKBndrs_Skol :: HsOuterGadtTyVarBndrs GhcRn
- -> TcM a
- -> TcM (Either [TcTyVar] [TcInvisTVBinder], a)
-bindOuterGadtTKBndrs_Skol outer_bndrs thing_inside = case outer_bndrs of
- HsOuterImplicit{hso_ximplicit = implicit_tkv_nms} -> do
- (imp_tvs, thing) <- bindImplicitTKBndrs_Skol implicit_tkv_nms thing_inside
- pure (Left imp_tvs, thing)
- HsOuterExplicit{hso_bndrs = exp_bndrs} -> do
- (exp_bndrs', thing) <- bindExplicitTKBndrs_Skol exp_bndrs thing_inside
- pure (Right exp_bndrs', thing)
-
--- TODO RGS: Docs(?)
--- TODO RGS: Is the return type correct?
--- TODO RGS: Consolidate with bindHsOuter*TKBndrs_Skol?
-bindOuterGadtTKBndrs_Tv :: HsOuterGadtTyVarBndrs GhcRn
- -> TcM a
- -> TcM (Either [TcTyVar] [TcInvisTVBinder], a)
-bindOuterGadtTKBndrs_Tv outer_bndrs thing_inside = case outer_bndrs of
- HsOuterImplicit{hso_ximplicit = implicit_tv_names} -> do
- (imp_tvs, thing) <- bindImplicitTKBndrs_Tv implicit_tv_names thing_inside
- pure (Left imp_tvs, thing)
- HsOuterExplicit{hso_bndrs = exp_bndrs} -> do
- (exp_bndrs', thing) <- bindExplicitTKBndrs_Tv exp_bndrs thing_inside
- pure (Right exp_bndrs', thing)
+ HsOuterImplicit{hso_ximplicit = implicit_tkv_nms}
+ -> bindImplicitTKBndrs_Q_Tv implicit_tkv_nms thing_inside
+ HsOuterExplicit{hso_bndrs = exp_bndrs}
+ -> bindExplicitTKBndrs_Q_Tv ctxt_kind exp_bndrs thing_inside
-- TODO RGS: Docs(?)
-- TODO RGS: Is the return type correct?
-- TODO RGS: Consolidate?
bindOuterSigTKBndrs_Skol :: HsOuterSigTyVarBndrs GhcRn
-> TcM a
- -> TcM (Either [TcTyVar] [TcTyVarBinder], a)
+ -> TcM (Either [TcTyVar] [TcInvisTVBinder], a)
bindOuterSigTKBndrs_Skol outer_bndrs thing_inside = case outer_bndrs of
- HsOuterImplicit{hso_ximplicit = implicit_tkv_nms} -> do
- (imp_tvs, thing) <- bindImplicitTKBndrs_Skol implicit_tkv_nms thing_inside
- pure (Left imp_tvs, thing)
- HsOuterExplicit{hso_bndrs = exp_bndrs} -> do
- (exp_bndrs', thing) <- bindExplicitTKTele_Skol exp_bndrs thing_inside
- pure (Right exp_bndrs', thing)
+ HsOuterImplicit{hso_ximplicit = implicit_tkv_nms}
+ -> do { (imp_tvs, thing) <- bindImplicitTKBndrs_Skol implicit_tkv_nms thing_inside
+ ; pure (Left imp_tvs, thing) }
+ HsOuterExplicit{hso_bndrs = exp_bndrs}
+ -> do { (exp_bndrs', thing) <- bindExplicitTKBndrs_Skol exp_bndrs thing_inside
+ ; pure (Right exp_bndrs', thing) }
+
+-- TODO RGS: Docs(?)
+-- TODO RGS: Is the return type correct?
+-- TODO RGS: Consolidate with bindHsOuter*TKBndrs_Skol?
+bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn
+ -> TcM a
+ -> TcM (Either [TcTyVar] [TcInvisTVBinder], a)
+bindOuterSigTKBndrs_Tv outer_bndrs thing_inside = case outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = implicit_tv_names}
+ -> do { (imp_tvs, thing) <- bindImplicitTKBndrs_Tv implicit_tv_names thing_inside
+ ; pure (Left imp_tvs, thing) }
+ HsOuterExplicit{hso_bndrs = exp_bndrs}
+ -> do { (exp_bndrs', thing) <- bindExplicitTKBndrs_Tv exp_bndrs thing_inside
+ ; pure (Right exp_bndrs', thing) }
-- TODO RGS: Docs(?)
-- TODO RGS: Is the return type correct?
@@ -3270,14 +3246,29 @@ bindOuterSigTKBndrs_Skol outer_bndrs thing_inside = case outer_bndrs of
bindOuterSigTKBndrs_Skol_M :: TcTyMode
-> HsOuterSigTyVarBndrs GhcRn
-> TcM a
- -> TcM (Either [TcTyVar] [TcTyVarBinder], a)
+ -> TcM (Either [TcTyVar] [TcInvisTVBinder], a)
bindOuterSigTKBndrs_Skol_M mode outer_bndrs thing_inside = case outer_bndrs of
- HsOuterImplicit{hso_ximplicit = implicit_tkv_nms} -> do
- (imp_tvs, thing) <- bindImplicitTKBndrs_Skol implicit_tkv_nms thing_inside
- pure (Left imp_tvs, thing)
- HsOuterExplicit{hso_bndrs = exp_bndrs} -> do
- (exp_bndrs', thing) <- bindExplicitTKTele_Skol_M mode exp_bndrs thing_inside
- pure (Right exp_bndrs', thing)
+ HsOuterImplicit{hso_ximplicit = implicit_tkv_nms}
+ -> do { (imp_tvs, thing) <- bindImplicitTKBndrs_Skol implicit_tkv_nms thing_inside
+ ; pure (Left imp_tvs, thing) }
+ HsOuterExplicit{hso_bndrs = exp_bndrs}
+ -> do { (exp_bndrs', thing) <- bindExplicitTKBndrs_Skol_M mode exp_bndrs thing_inside
+ ; pure (Right exp_bndrs', thing) }
+
+-- TODO RGS: Docs(?)
+-- TODO RGS: Is the return type correct?
+-- TODO RGS: Consolidate?
+bindOuterSigTKBndrs_Tv_M :: TcTyMode
+ -> HsOuterSigTyVarBndrs GhcRn
+ -> TcM a
+ -> TcM ([TcInvisTVBinder], a)
+bindOuterSigTKBndrs_Tv_M mode outer_bndrs thing_inside = case outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = implicit_tkv_nms}
+ -> do { (imp_tvs, thing) <- bindImplicitTKBndrs_Tv implicit_tkv_nms thing_inside
+ ; pure (mkTyVarBinders SpecifiedSpec imp_tvs, thing) }
+ HsOuterExplicit{hso_bndrs = exp_bndrs}
+ -> do { (exp_bndrs', thing) <- bindExplicitTKBndrs_Tv_M mode exp_bndrs thing_inside
+ ; pure (exp_bndrs', thing) }
-----------------
tcHsTyVarBndr :: TcTyMode -> (Name -> Kind -> TcM TyVar)
@@ -3732,6 +3723,7 @@ It isn't essential for correctness.
-}
+-- TODO RGS: Delete me
tcHsPartialSigType
:: UserTypeCtxt
-> LHsSigWcType GhcRn -- The type signature
@@ -3799,6 +3791,70 @@ tcHsPartialSigType ctxt sig_ty
; traceTc "tcHsPartialSigType" (ppr tv_prs)
; return (wcs, wcx, tv_prs, theta, tau) }
+-- TODO RGS: This is the REAL tcHsPartialSigType. Delete the one above when ready.
+tcHsPartialSigType'
+ :: UserTypeCtxt
+ -> LHsSigWcType' GhcRn -- The type signature
+ -> TcM ( [(Name, TcTyVar)] -- Wildcards
+ , Maybe TcType -- Extra-constraints wildcard
+ , [(Name,InvisTVBinder)] -- 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 = sig_ty } <- sig_ty
+ , L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) <- sig_ty
+ , (L _ hs_ctxt, hs_tau) <- splitLHsQualTy body_ty
+ = addSigCtxt ctxt sig_ty $
+ do { mode <- mkHoleMode TypeLevel HM_Sig
+ ; (imp_or_exp_tvbndrs, (wcs, wcx, theta, tau))
+ <- solveLocalEqualities "tcHsPartialSigType" $
+ -- See Note [Failure in local type signatures]
+ tcNamedWildCardBinders sig_wcs $ \ wcs ->
+ bindOuterSigTKBndrs_Tv_M mode outer_bndrs $
+ do { -- Instantiate the type-class context; but if there
+ -- is an extra-constraints wildcard, just discard it here
+ (theta, wcx) <- tcPartialContext mode hs_ctxt
+
+ ; ek <- newOpenTypeKind
+ ; tau <- addTypeCtxt hs_tau $
+ tc_lhs_type mode hs_tau ek
+
+ ; return (wcs, wcx, theta, tau) }
+
+ -- No kind-generalization here:
+ ; kindGeneralizeNone (mkInvisForAllTys imp_or_exp_tvbndrs $
+ 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]
+ ; mapM_ emitNamedTypeHole wcs
+
+ -- Zonk, so that any nested foralls can "see" their occurrences
+ -- See Note [Checking partial type signatures], and in particular
+ -- Note [Levels for wildcards]
+ ; imp_or_exp_tvbndrs <- mapM zonkInvisTVBinder imp_or_exp_tvbndrs
+ ; theta <- mapM zonkTcType theta
+ ; tau <- zonkTcType tau
+
+ -- We return a proper (Name,InvisTVBinder) environment, to be sure that
+ -- we bring the right name into scope in the function body.
+ -- Test case: partial-sigs/should_compile/LocalDefinitionBug
+ ; let imp_or_exp_hs_tvs = case outer_bndrs of
+ HsOuterImplicit{hso_ximplicit = imp_tvs} -> imp_tvs
+ HsOuterExplicit{hso_bndrs = exp_tvs} -> hsLTyVarNames exp_tvs
+ tv_prs = imp_or_exp_hs_tvs `zip` imp_or_exp_tvbndrs
+
+ -- 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 type to check
+
+ ; traceTc "tcHsPartialSigType" (ppr tv_prs)
+ ; return (wcs, wcx, tv_prs, theta, tau) }
+
tcPartialContext :: TcTyMode -> HsContext GhcRn -> TcM (TcThetaType, Maybe TcType)
tcPartialContext mode hs_theta
| Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -203,7 +203,7 @@ tcTySig (L loc (TypeSig _ names sig_ty))
tcTySig (L loc (PatSynSig _ names sig_ty))
= setSrcSpan loc $
- do { tpsigs <- sequence [ tcPatSynSig name sig_ty
+ do { tpsigs <- sequence [ tcPatSynSig' name sig_ty
| L _ name <- names ]
; return (map TcPatSynSig tpsigs) }
@@ -266,10 +266,22 @@ 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
-
-no_anon_wc :: LHsType GhcRn -> Bool
-no_anon_wc lty = go lty
+ = null wcs && no_anon_wc_ty hs_ty
+
+-- TODO RGS: This is the REAL isCompleteHsSig. Delete the one above when ready.
+isCompleteHsSig' :: LHsSigWcType' GhcRn -> Bool
+-- ^ If there are no wildcards, return a LHsSigWcType
+isCompleteHsSig' (HsWC { hswc_ext = wcs, hswc_body = hs_sig_ty })
+ = null wcs && no_anon_wc_sig_ty hs_sig_ty
+
+no_anon_wc_sig_ty :: LHsSigType' GhcRn -> Bool
+no_anon_wc_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =
+ case outer_bndrs of
+ HsOuterImplicit{} -> no_anon_wc_ty body
+ HsOuterExplicit{hso_bndrs = ltvs} -> all no_anon_wc_tvb ltvs && no_anon_wc_ty body
+
+no_anon_wc_ty :: LHsType GhcRn -> Bool
+no_anon_wc_ty lty = go lty
where
go (L _ ty) = case ty of
HsWildCardTy _ -> False
@@ -304,11 +316,13 @@ no_anon_wc lty = go lty
no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool
no_anon_wc_tele tele = case tele of
- HsForAllVis { hsf_vis_bndrs = ltvs } -> all (go . unLoc) ltvs
- HsForAllInvis { hsf_invis_bndrs = ltvs } -> all (go . unLoc) ltvs
- where
- go (UserTyVar _ _ _) = True
- go (KindedTyVar _ _ _ ki) = no_anon_wc ki
+ HsForAllVis { hsf_vis_bndrs = ltvs } -> all no_anon_wc_tvb ltvs
+ HsForAllInvis { hsf_invis_bndrs = ltvs } -> all no_anon_wc_tvb ltvs
+
+no_anon_wc_tvb :: LHsTyVarBndr flag GhcRn -> Bool
+no_anon_wc_tvb (L _ tvb) = case tvb of
+ UserTyVar _ _ _ -> True
+ KindedTyVar _ _ _ ki -> no_anon_wc_ty ki
{- Note [Fail eagerly on bad signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -475,6 +489,105 @@ tcPatSynSig name sig_ty
mkPhiTy prov $
body
+-- TODO RGS: This is the REAL tcPatSynSig. Delete the one above when ready.
+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@(L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = hs_ty}))
+ | (hs_req, hs_ty1) <- splitLHsQualTy hs_ty
+ , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1
+ = do { traceTc "tcPatSynSig 1" (ppr sig_ty)
+ ; (implicit_or_univ_tvbndrs, (ex_tvbndrs, (req, prov, body_ty)))
+ <- pushTcLevelM_ $
+ solveEqualities $ -- See Note [solveEqualities in tcPatSynSig]
+ bindOuterSigTKBndrs_Skol outer_bndrs $
+ bindExplicitTKBndrs_Skol ex_hs_tvbndrs $
+ 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) }
+
+ -- TODO RGS: Is this the cleanest way to do this?
+ ; let (implicit_tvs, univ_tvbndrs) = case implicit_or_univ_tvbndrs of
+ Left implicit_tvs' -> (implicit_tvs', [])
+ Right univ_tvbndrs' -> ([], univ_tvbndrs')
+
+ ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvbndrs
+ req ex_tvbndrs 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_tvbndrs <- mapM zonkTyCoVarKindBinder univ_tvbndrs
+ ; ex_tvbndrs <- mapM zonkTyCoVarKindBinder ex_tvbndrs
+ ; 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_tvbndrs' = univ_tvbndrs
+ ex_tvbndrs' = ex_tvbndrs
+ req' = req
+ prov' = prov
+ body_ty' = body_ty
+
+ -- Now do validity checking
+ ; checkValidType ctxt $
+ build_patsyn_type kvs implicit_tvs' univ_tvbndrs' req' ex_tvbndrs' 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 . scaledThing) arg_tys
+
+ ; traceTc "tcTySig }" $
+ vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs'
+ , text "kvs" <+> ppr_tvs kvs
+ , text "univ_tvs" <+> ppr_tvs (binderVars univ_tvbndrs')
+ , text "req" <+> ppr req'
+ , text "ex_tvs" <+> ppr_tvs (binderVars ex_tvbndrs')
+ , text "prov" <+> ppr prov'
+ , text "body_ty" <+> ppr body_ty' ]
+ ; return (TPSI { patsig_name = name
+ , patsig_implicit_bndrs = mkTyVarBinders InferredSpec kvs ++
+ mkTyVarBinders SpecifiedSpec implicit_tvs'
+ , patsig_univ_bndrs = univ_tvbndrs'
+ , patsig_req = req'
+ , patsig_ex_bndrs = ex_tvbndrs'
+ , patsig_prov = prov'
+ , patsig_body_ty = body_ty' }) }
+ where
+ ctxt = PatSynCtxt name
+
+ build_patsyn_type kvs imp univ_bndrs req ex_bndrs prov body
+ = mkInfForAllTys kvs $
+ mkSpecForAllTys imp $
+ mkInvisForAllTys univ_bndrs $
+ mkPhiTy req $
+ mkInvisForAllTys ex_bndrs $
+ mkPhiTy prov $
+ body
+
ppr_tvs :: [TyVar] -> SDoc
ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
| tv <- tvs])
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -2450,6 +2450,16 @@ getGhciStepIO = do
let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
+ {-
+ step_ty :: LHsSigType' GhcRn
+ step_ty = noLoc $ HsSig
+ { sig_bndrs = HsOuterImplicit{hso_ximplicit = [a_tv]}
+ , sig_ext = noExtField
+ , sig_body = nlHsFunTy HsUnrestrictedArrow ghciM ioM }
+
+ stepTy :: LHsSigWcType' GhcRn
+ stepTy = mkEmptyWildCardBndrs step_ty
+ -}
step_ty = noLoc $ HsForAllTy
{ hst_tele = mkHsForAllInvisTele
[noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)]
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -1614,7 +1614,7 @@ kcConDecl new_or_data res_kind (ConDeclGADT
-- for the type constructor T
addErrCtxt (dataConCtxtName names) $
discardResult $
- bindOuterGadtTKBndrs_Tv outer_bndrs $
+ bindOuterSigTKBndrs_Tv outer_bndrs $
-- Why "_Tv"? See Note [Kind-checking for GADTs]
do { _ <- tcHsMbContext cxt
; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)
@@ -3268,7 +3268,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data
<- pushTcLevelM_ $ -- We are going to generalise
solveEqualities $ -- We won't get another crack, and we don't
-- want an error cascade
- bindOuterGadtTKBndrs_Skol outer_bndrs $
+ bindOuterSigTKBndrs_Skol outer_bndrs $
do { ctxt <- tcHsMbContext cxt
; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty
-- See Note [GADT return kinds]
=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -159,7 +159,7 @@ tcClassSigs clas sigs def_methods
skol_info = TyConSkol ClassFlavour clas
- tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn)
+ 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)
@@ -290,7 +290,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
; let local_dm_id = mkLocalId local_dm_name Many local_dm_ty
local_dm_sig = CompleteSig { sig_bndr = local_dm_id
, sig_ctxt = ctxt
- , sig_loc = getLoc (hsSigType hs_ty) }
+ , sig_loc = getLoc hs_ty }
; (ev_binds, (tc_bind, _))
<- checkConstraints skol_info tyvars [this_dict] $
@@ -363,14 +363,14 @@ instantiateMethod clas sel_id inst_tys
---------------------------
-type HsSigFun = Name -> Maybe (LHsSigType GhcRn)
+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 :: LSig GhcRn -> Maybe ([Located Name], LHsSigType' GhcRn)
get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty)
get_classop_sig _ = Nothing
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -480,7 +480,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
, cid_datafam_insts = adts }))
= setSrcSpan loc $
addErrCtxt (instDeclCtxt1 hs_ty) $
- do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty
+ do { dfun_ty <- tcHsClsInstType' (InstDeclCtxt False) hs_ty
; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty
-- NB: tcHsClsInstType does checkValidInstance
@@ -517,7 +517,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
-- 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_name <- newDFunName clas inst_tys (getLoc hs_ty)
-- Dfun location is that of instance *header*
; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name
@@ -1783,10 +1783,10 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
-- There is a signature in the instance
-- See Note [Instance method signatures]
= do { (sig_ty, hs_wrap)
- <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $
+ <- setSrcSpan (getLoc 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 <- tcLHsSigType (FunSigCtxt sel_name False) hs_sig_ty
; let local_meth_ty = idType local_meth_id
ctxt = FunSigCtxt sel_name False
-- False <=> do not report redundant constraints when
@@ -1804,7 +1804,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
inner_meth_id = mkLocalId inner_meth_name Many sig_ty
inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
, sig_ctxt = ctxt
- , sig_loc = getLoc (hsSigType hs_sig_ty) }
+ , sig_loc = getLoc hs_sig_ty }
; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
@@ -1873,7 +1873,7 @@ methSigCtxt sel_name sig_ty meth_ty env0
, text " Class sig:" <+> ppr meth_ty ])
; return (env2, msg) }
-misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc
+misplacedInstSig :: Name -> LHsSigType' GhcRn -> SDoc
misplacedInstSig name hs_ty
= vcat [ hang (text "Illegal type signature in instance declaration:")
2 (hang (pprPrefixName name)
@@ -2206,9 +2206,9 @@ tcSpecInst _ _ = panic "tcSpecInst"
************************************************************************
-}
-instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
+instDeclCtxt1 :: LHsSigType' GhcRn -> SDoc
instDeclCtxt1 hs_inst_ty
- = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
+ = inst_decl_ctxt (ppr (getLHsInstDeclHead' hs_inst_ty))
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 dfun_ty
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -286,9 +286,10 @@ cvtDec (InstanceD o ctxt ty decs)
; unless (null fams') (failWith (mkBadDecMsg doc fams'))
; ctxt' <- cvtContext funPrec ctxt
; (L loc ty') <- cvtType ty
- ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
+ ; let inst_ty' = hsTypeToHsSigType $
+ mkHsQualTy ctxt loc ctxt' $ L loc ty'
; returnJustL $ InstD noExtField $ ClsInstD noExtField $
- ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty'
+ ClsInstDecl { cid_ext = noExtField, cid_poly_ty = inst_ty'
, cid_binds = binds'
, cid_sigs = Hs.mkClassOpSigs sigs'
, cid_tyfam_insts = ats', cid_datafam_insts = adts'
@@ -383,18 +384,19 @@ cvtDec (TH.StandaloneDerivD ds cxt ty)
= do { cxt' <- cvtContext funPrec cxt
; ds' <- traverse cvtDerivStrategy ds
; (L loc ty') <- cvtType ty
- ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
+ ; let inst_ty' = hsTypeToHsSigType $
+ mkHsQualTy cxt loc cxt' $ L loc ty'
; returnJustL $ DerivD noExtField $
DerivDecl { deriv_ext =noExtField
, deriv_strategy = ds'
- , deriv_type = mkLHsSigWcType inst_ty'
+ , deriv_type = mkHsWildCardBndrs inst_ty'
, deriv_overlap_mode = Nothing } }
cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm
- ; ty' <- cvtType typ
+ ; ty' <- cvtSigType typ
; returnJustL $ Hs.SigD noExtField
- $ ClassOpSig noExtField True [nm'] (mkLHsSigType ty')}
+ $ ClassOpSig noExtField True [nm'] ty'}
cvtDec (TH.PatSynD nm args dir pat)
= do { nm' <- cNameL nm
@@ -421,7 +423,7 @@ cvtDec (TH.PatSynD nm args dir pat)
cvtDec (TH.PatSynSigD nm ty)
= do { nm' <- cNameL nm
; ty' <- cvtPatSynSigTy ty
- ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] (mkLHsSigType ty')}
+ ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] ty'}
-- Implicit parameter bindings are handled in cvtLocalDecs and
-- cvtImplicitParamBind. They are not allowed in any other scope, so
@@ -1413,8 +1415,8 @@ cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy
cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy
cvtDerivStrategy TH.NewtypeStrategy = returnL Hs.NewtypeStrategy
cvtDerivStrategy (TH.ViaStrategy ty) = do
- ty' <- cvtType ty
- returnL $ Hs.ViaStrategy (mkLHsSigType ty')
+ ty' <- cvtSigType ty
+ returnL $ Hs.ViaStrategy ty'
cvtType :: TH.Type -> CvtM (LHsType GhcPs)
cvtType = cvtTypeKind "type"
@@ -1426,10 +1428,7 @@ cvtSigType = cvtSigTypeKind "type"
cvtSigTypeKind :: String -> TH.Type -> CvtM (LHsSigType' GhcPs)
cvtSigTypeKind ty_str ty = do
ty' <- cvtTypeKind ty_str ty
- pure $ case ty' of
- L loc (HsForAllTy { hst_tele = tele, hst_body = body })
- -> L loc $ mkHsExplicitSigType tele body
- L loc _ -> L loc $ mkHsImplicitSigType ty'
+ pure $ hsTypeToHsSigType ty'
cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)
cvtTypeKind ty_str ty
@@ -1760,30 +1759,28 @@ cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
; annRHS' <- mapM tNameL annRHS
; returnL (Hs.InjectivityAnn annLHS' annRHS') }
-cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)
+cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType' GhcPs)
-- pattern synonym types are of peculiar shapes, which is why we treat
-- them separately from regular types;
-- see Note [Pattern synonym type signatures and Template Haskell]
cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
- | null exis, null provs = cvtType (ForallT univs reqs ty)
+ | null exis, null provs = cvtSigType (ForallT univs reqs ty)
| null univs, null reqs = do { l <- getL
; ty' <- cvtType (ForallT exis provs ty)
- ; return $ L l (HsQualTy { hst_ctxt = L l []
+ ; return $ L l $ mkHsImplicitSigType
+ $ L l (HsQualTy { hst_ctxt = L l []
, hst_xqual = noExtField
, hst_body = ty' }) }
| null reqs = do { l <- getL
; univs' <- cvtTvs univs
; ty' <- cvtType (ForallT exis provs ty)
- ; let forTy = HsForAllTy
- { hst_tele = mkHsForAllInvisTele univs'
- , hst_xforall = noExtField
- , hst_body = L l cxtTy }
+ ; let forTy = mkHsExplicitSigType univs' $ L l cxtTy
cxtTy = HsQualTy { hst_ctxt = L l []
, hst_xqual = noExtField
, hst_body = ty' }
; return $ L l forTy }
- | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty))
-cvtPatSynSigTy ty = cvtType ty
+ | otherwise = cvtSigType (ForallT univs reqs (ForallT exis provs ty))
+cvtPatSynSigTy ty = cvtSigType ty
-----------------------------------------------------------
cvtFixity :: TH.Fixity -> Hs.Fixity
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
=====================================
@@ -39,32 +39,35 @@
[({ T17544.hs:6:3-4 }
(Unqual
{OccName: f1}))]
- (HsIB
- (NoExtField)
- ({ T17544.hs:6:9-16 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow)
- ({ T17544.hs:6:9 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:6:9 }
- (Unqual
- {OccName: a}))))
- ({ T17544.hs:6:14-16 }
- (HsDocTy
- (NoExtField)
- ({ T17544.hs:6:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:6:14-16 }
- (Unqual
- {OccName: Int}))))
- ({ T17544.hs:7:5-23 }
- (HsDocString
- " comment on Int")))))))))]
+ ({ T17544.hs:6:9-16 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:6:9-16 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow)
+ ({ T17544.hs:6:9 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:6:9 }
+ (Unqual
+ {OccName: a}))))
+ ({ T17544.hs:6:14-16 }
+ (HsDocTy
+ (NoExtField)
+ ({ T17544.hs:6:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:6:14-16 }
+ (Unqual
+ {OccName: Int}))))
+ ({ T17544.hs:7:5-23 }
+ (HsDocString
+ " comment on Int"))))))))))]
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -99,26 +102,29 @@
[({ T17544.hs:10:3-4 }
(Unqual
{OccName: f2}))]
- (HsIB
- (NoExtField)
- ({ T17544.hs:10:9-16 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow)
- ({ T17544.hs:10:9 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:10:9 }
- (Unqual
- {OccName: a}))))
- ({ T17544.hs:10:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:10:14-16 }
- (Unqual
- {OccName: Int})))))))))]
+ ({ T17544.hs:10:9-16 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:10:9-16 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow)
+ ({ T17544.hs:10:9 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:10:9 }
+ (Unqual
+ {OccName: a}))))
+ ({ T17544.hs:10:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:10:14-16 }
+ (Unqual
+ {OccName: Int}))))))))))]
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -156,26 +162,29 @@
[({ T17544.hs:14:3-4 }
(Unqual
{OccName: f3}))]
- (HsIB
- (NoExtField)
- ({ T17544.hs:14:9-16 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow)
- ({ T17544.hs:14:9 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:14:9 }
- (Unqual
- {OccName: a}))))
- ({ T17544.hs:14:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:14:14-16 }
- (Unqual
- {OccName: Int})))))))))]
+ ({ T17544.hs:14:9-16 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:14:9-16 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow)
+ ({ T17544.hs:14:9 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:14:9 }
+ (Unqual
+ {OccName: a}))))
+ ({ T17544.hs:14:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:14:14-16 }
+ (Unqual
+ {OccName: Int}))))))))))]
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -216,26 +225,29 @@
[({ T17544.hs:18:3-4 }
(Unqual
{OccName: f4}))]
- (HsIB
- (NoExtField)
- ({ T17544.hs:18:9-16 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow)
- ({ T17544.hs:18:9 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:18:9 }
- (Unqual
- {OccName: a}))))
- ({ T17544.hs:18:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:18:14-16 }
- (Unqual
- {OccName: Int})))))))))
+ ({ T17544.hs:18:9-16 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:18:9-16 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow)
+ ({ T17544.hs:18:9 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:18:9 }
+ (Unqual
+ {OccName: a}))))
+ ({ T17544.hs:18:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:18:14-16 }
+ (Unqual
+ {OccName: Int}))))))))))
,({ T17544.hs:20:3-16 }
(ClassOpSig
(NoExtField)
@@ -243,26 +255,29 @@
[({ T17544.hs:20:3-4 }
(Unqual
{OccName: g4}))]
- (HsIB
- (NoExtField)
- ({ T17544.hs:20:9-16 }
- (HsFunTy
- (NoExtField)
- (HsUnrestrictedArrow)
- ({ T17544.hs:20:9 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:20:9 }
- (Unqual
- {OccName: a}))))
- ({ T17544.hs:20:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:20:14-16 }
- (Unqual
- {OccName: Int})))))))))]
+ ({ T17544.hs:20:9-16 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:20:9-16 }
+ (HsFunTy
+ (NoExtField)
+ (HsUnrestrictedArrow)
+ ({ T17544.hs:20:9 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:20:9 }
+ (Unqual
+ {OccName: a}))))
+ ({ T17544.hs:20:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:20:14-16 }
+ (Unqual
+ {OccName: Int}))))))))))]
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -322,25 +337,28 @@
(NoExtField)
(ClsInstDecl
(NoExtField)
- (HsIB
- (NoExtField)
- ({ T17544.hs:23:10-15 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:23:10-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:23:10-11 }
- (Unqual
- {OccName: C5}))))
- ({ T17544.hs:23:13-15 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:23:13-15 }
- (Unqual
- {OccName: Int})))))))
+ ({ T17544.hs:23:10-15 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:23:10-15 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:23:10-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:23:10-11 }
+ (Unqual
+ {OccName: C5}))))
+ ({ T17544.hs:23:13-15 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:23:13-15 }
+ (Unqual
+ {OccName: Int}))))))))
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -457,25 +475,28 @@
(NoExtField)
(ClsInstDecl
(NoExtField)
- (HsIB
- (NoExtField)
- ({ T17544.hs:29:10-15 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:29:10-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:29:10-11 }
- (Unqual
- {OccName: C6}))))
- ({ T17544.hs:29:13-15 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:29:13-15 }
- (Unqual
- {OccName: Int})))))))
+ ({ T17544.hs:29:10-15 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:29:10-15 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:29:10-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:29:10-11 }
+ (Unqual
+ {OccName: C6}))))
+ ({ T17544.hs:29:13-15 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:29:13-15 }
+ (Unqual
+ {OccName: Int}))))))))
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -592,25 +613,28 @@
(NoExtField)
(ClsInstDecl
(NoExtField)
- (HsIB
- (NoExtField)
- ({ T17544.hs:35:10-15 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:35:10-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:35:10-11 }
- (Unqual
- {OccName: C7}))))
- ({ T17544.hs:35:13-15 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:35:13-15 }
- (Unqual
- {OccName: Int})))))))
+ ({ T17544.hs:35:10-15 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:35:10-15 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:35:10-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:35:10-11 }
+ (Unqual
+ {OccName: C7}))))
+ ({ T17544.hs:35:13-15 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:35:13-15 }
+ (Unqual
+ {OccName: Int}))))))))
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -727,25 +751,28 @@
(NoExtField)
(ClsInstDecl
(NoExtField)
- (HsIB
- (NoExtField)
- ({ T17544.hs:41:10-15 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:41:10-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:41:10-11 }
- (Unqual
- {OccName: C8}))))
- ({ T17544.hs:41:13-15 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:41:13-15 }
- (Unqual
- {OccName: Int})))))))
+ ({ T17544.hs:41:10-15 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:41:10-15 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:41:10-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:41:10-11 }
+ (Unqual
+ {OccName: C8}))))
+ ({ T17544.hs:41:13-15 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:41:13-15 }
+ (Unqual
+ {OccName: Int}))))))))
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -862,25 +889,28 @@
(NoExtField)
(ClsInstDecl
(NoExtField)
- (HsIB
- (NoExtField)
- ({ T17544.hs:47:10-15 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:47:10-11 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:47:10-11 }
- (Unqual
- {OccName: C9}))))
- ({ T17544.hs:47:13-15 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:47:13-15 }
- (Unqual
- {OccName: Int})))))))
+ ({ T17544.hs:47:10-15 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:47:10-15 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:47:10-11 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:47:10-11 }
+ (Unqual
+ {OccName: C9}))))
+ ({ T17544.hs:47:13-15 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:47:13-15 }
+ (Unqual
+ {OccName: Int}))))))))
{Bag(Located (HsBind GhcPs)):
[]}
[]
@@ -997,25 +1027,28 @@
(NoExtField)
(ClsInstDecl
(NoExtField)
- (HsIB
- (NoExtField)
- ({ T17544.hs:53:10-16 }
- (HsAppTy
- (NoExtField)
- ({ T17544.hs:53:10-12 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:53:10-12 }
- (Unqual
- {OccName: C10}))))
- ({ T17544.hs:53:14-16 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544.hs:53:14-16 }
- (Unqual
- {OccName: Int})))))))
+ ({ T17544.hs:53:10-16 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544.hs:53:10-16 }
+ (HsAppTy
+ (NoExtField)
+ ({ T17544.hs:53:10-12 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:53:10-12 }
+ (Unqual
+ {OccName: C10}))))
+ ({ T17544.hs:53:14-16 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544.hs:53:14-16 }
+ (Unqual
+ {OccName: Int}))))))))
{Bag(Located (HsBind GhcPs)):
[]}
[]
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
=====================================
@@ -133,15 +133,18 @@
[({ T17544_kw.hs:24:5-13 }
(Unqual
{OccName: clsmethod}))]
- (HsIB
- (NoExtField)
- ({ T17544_kw.hs:24:18 }
- (HsTyVar
- (NoExtField)
- (NotPromoted)
- ({ T17544_kw.hs:24:18 }
- (Unqual
- {OccName: a})))))))]
+ ({ T17544_kw.hs:24:18 }
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ ({ T17544_kw.hs:24:18 }
+ (HsTyVar
+ (NoExtField)
+ (NotPromoted)
+ ({ T17544_kw.hs:24:18 }
+ (Unqual
+ {OccName: a}))))))))]
{Bag(Located (HsBind GhcPs)):
[]}
[]
=====================================
testsuite/tests/patsyn/should_fail/T11039.stderr
=====================================
@@ -5,6 +5,6 @@ T11039.hs:8:15: error:
Actual: A a
‘f’ is a rigid type variable bound by
the signature for pattern synonym ‘Q’
- at T11039.hs:7:1-38
+ at T11039.hs:7:14-38
• In the pattern: A a
In the declaration for pattern synonym ‘Q’
=====================================
testsuite/tests/patsyn/should_fail/T11667.stderr
=====================================
@@ -17,7 +17,7 @@ T11667.hs:18:28: error:
the signature of ‘Pat2’
‘b’ is a rigid type variable bound by
the signature for pattern synonym ‘Pat2’
- at T11667.hs:17:1-50
+ at T11667.hs:17:17-50
• In the declaration for pattern synonym ‘Pat2’
• Relevant bindings include y :: b (bound at T11667.hs:18:21)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8767ff95effa4a3d8d8859d3be04a209664d08b1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8767ff95effa4a3d8d8859d3be04a209664d08b1
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200907/5e083fb4/attachment-0001.html>
More information about the ghc-commits
mailing list