diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Hs/Decls.hs | 198 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Instances.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Type.hs | 40 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Utils.hs | 25 | ||||
| -rw-r--r-- | compiler/GHC/Parser.y | 5 | ||||
| -rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 60 | ||||
| -rw-r--r-- | compiler/GHC/Parser/PostProcess/Haddock.hs | 16 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Module.hs | 75 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl.hs | 40 | ||||
| -rw-r--r-- | compiler/GHC/ThToHs.hs | 39 |
10 files changed, 342 insertions, 158 deletions
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 9edd0ff871..f800d934b6 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -70,7 +71,7 @@ module GHC.Hs.Decls ( ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), CImportSpec(..), -- ** Data-constructor declarations - ConDecl(..), LConDecl, + ConDecl(..), LConDecl, ConDeclGADTPrefixPs(..), HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta, getConNames, getConArgs, -- ** Document comments @@ -109,6 +110,7 @@ import GHC.Core.Coercion import GHC.Types.ForeignCall import GHC.Hs.Extension import GHC.Types.Name +import GHC.Types.Name.Reader import GHC.Types.Name.Set -- others: @@ -1422,54 +1424,144 @@ type instance XConDeclGADT GhcRn = [Name] -- Implicitly bound type variables type instance XConDeclGADT GhcTc = NoExtField type instance XConDeclH98 (GhcPass _) = NoExtField -type instance XXConDecl (GhcPass _) = NoExtCon + +type instance XXConDecl GhcPs = ConDeclGADTPrefixPs +type instance XXConDecl GhcRn = NoExtCon +type instance XXConDecl GhcTc = NoExtCon + +-- | Stores the types of prefix GADT constructors in the parser. This is used +-- in lieu of ConDeclGADT, which requires knowing the specific argument and +-- result types, as this is difficult to determine in general in the parser. +-- See @Note [GADT abstract syntax]@. +data ConDeclGADTPrefixPs = ConDeclGADTPrefixPs + { con_gp_names :: [Located RdrName] + -- ^ The GADT constructor declaration's names. + , con_gp_ty :: LHsSigType GhcPs + -- ^ The type after the @::@. + , con_gp_doc :: Maybe LHsDocString + -- ^ A possible Haddock comment. + } {- Note [GADT abstract syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's a wrinkle in ConDeclGADT - -* For record syntax, it's all uniform. Given: - data T a where - K :: forall a. Ord a => { x :: [a], ... } -> T a - we make the a ConDeclGADT for K with - con_qvars = {a} - con_mb_cxt = Just [Ord a] - con_args = RecCon <the record fields> - con_res_ty = T a - - We need the RecCon before the reanmer, so we can find the record field - binders in GHC.Hs.Utils.hsConDeclsBinders. - -* However for a GADT constr declaration which is not a record, it can - be hard parse until we know operator fixities. Consider for example - C :: a :*: b -> a :*: b -> a :+: b - Initially this type will parse as - a :*: (b -> (a :*: (b -> (a :+: b)))) - so it's hard to split up the arguments until we've done the precedence - resolution (in the renamer). - - So: - In the parser (GHC.Parser.PostProcess.mkGadtDecl), we put the whole constr - type into the res_ty for a ConDeclGADT for now, and use - PrefixCon [] - con_args = PrefixCon [] - con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b)))) - - - In the renamer (GHC.Rename.Module.rnConDecl), we unravel it after - operator fixities are sorted. So we generate. So we end - up with - con_args = PrefixCon [ a :*: b, a :*: b ] - con_res_ty = a :+: b +There are two broad ways to classify GADT constructors: + +* Record-syntax constructors. For example: + + data T a where + K :: forall a. Ord a => { x :: [a], ... } -> T a + +* Prefix constructors, which do not use record syntax. For example: + + data T a where + K :: forall a. Ord a => [a] -> ... -> T a + +Initially, both forms of GADT constructors are initially parsed as a single +LHsType. However, GADTs have a certain structure, requiring distinct argument +and result types, as well as imposing restrictions on where `forall`s and +contexts can be (see "Wrinkle: No nested foralls or contexts" below). As a +result, it is convenient to split up the LHsType into its individual +components, which are stored in the ConDeclGADT constructor of ConDecl. + +Where should this splitting occur? For GADT constructors with record syntax, +we split in the parser (in GHC.Parser.PostProcess.mkGadtDecl). We must do this +splitting before the renamer, as we need the record field names for use in +GHC.Hs.Utils.hsConDeclsBinders. + +For prefix GADT constructors, however, the situation is more complicated. It +can be difficult to split a prefix GADT type until we know type operator +fixities. Consider this, for example: + + C :: a :*: b -> a :*: b -> a :+: b + +Initially, the type of C will parse as: + + a :*: (b -> (a :*: (b -> (a :+: b)))) + +So it's hard to split up the arguments until we've done the precedence +resolution (in the renamer). (Unlike prefix GADT types, record GADT types +do not have this problem because of their uniform syntax.) + +As a result, we deliberately avoid splitting prefix GADT types in the parser. +Instead, we store the entire LHsType in ConDeclGADTPrefixPs, a GHC-specific +extension constructor to ConDecl. Later, in the renamer +(in GHC.Rename.Module.rnConDecl), we resolve the fixities of all type operators +in the LHsType, which facilitates splitting it into argument and result types +accurately. We finish renaming a ConDeclGADTPrefixPs by putting the split +components into a ConDeclGADT. This is why ConDeclGADTPrefixPs has the suffix +-Ps, as it is only used by the parser. + +Note that the existence of ConDeclGADTPrefixPs does not imply that ConDeclGADT +goes completely unused by the parser. Other consumers of GHC's abstract syntax +are still free to use ConDeclGADT. Indeed, both Haddock and Template Haskell +construct values of type `ConDecl GhcPs` by way of ConDeclGADT, as neither of +them have the same difficulties with operator precedence that GHC's parser +does. As an example, see GHC.ThToHs.cvtConstr, which converts Template Haskell +syntax into GHC syntax. + +----- +-- Wrinkle: No nested foralls or contexts +----- + +GADT constructors provide some freedom to change the order of foralls in their +types (see Note [DataCon user type variable binders] in GHC.Core.DataCon), but +this freedom is still limited. GADTs still require that all quantification +occurs "prenex". That is, any explicitly quantified type variables must occur +at the front of the GADT type, followed by any contexts, followed by the body of +the GADT type, in precisely that order. For instance: + + data T where + MkT1 :: forall a b. (Eq a, Eq b) => a -> b -> T + -- OK + MkT2 :: forall a. Eq a => forall b. a -> b -> T + -- Rejected, `forall b` is nested + MkT3 :: forall a b. Eq a => Eq b => a -> b -> T + -- Rejected, `Eq b` is nested + MkT4 :: Int -> forall a. a -> T + -- Rejected, `forall a` is nested + MkT5 :: forall a. Int -> Eq a => a -> T + -- Rejected, `Eq a` is nested + MkT6 :: (forall a. a -> T) + -- Rejected, `forall a` is nested due to the surrounding parentheses + MkT7 :: (Eq a => a -> t) + -- Rejected, `Eq a` is nested due to the surrounding parentheses + +For the full details, see the "Formal syntax for GADTs" section of the GHC +User's Guide. GHC enforces that GADT constructors do not have nested `forall`s +or contexts in two parts: + +1. GHC, in the process of splitting apart a GADT's type, + extracts out the leading `forall` and context (if they are provided). To + accomplish this splitting, the renamer uses the + GHC.Hs.Type.splitLHsGADTPrefixTy function, which is careful not to remove + parentheses surrounding the leading `forall` or context (as these + parentheses can be syntactically significant). If the third result returned + by splitLHsGADTPrefixTy contains any `forall`s or contexts, then they must + be nested, so they will be rejected. + + Note that this step applies to both prefix and record GADTs alike, as they + both have syntax which permits `forall`s and contexts. The difference is + where this step happens: + + * For prefix GADTs, this happens in the renamer (in rnConDecl), as we cannot + split until after the type operator fixities have been resolved. + * For record GADTs, this happens in the parser (in mkGadtDecl). +2. If the GADT type is prefix, the renamer (in the ConDeclGADTPrefixPs case of + rnConDecl) will then check for nested `forall`s/contexts in the body of a + prefix GADT type, after it has determined what all of the argument types are. + This step is necessary to catch examples like MkT4 above, where the nested + quantification occurs after a visible argument type. -} -- | Haskell data Constructor Declaration Details type HsConDeclDetails pass = HsConDetails (LBangType pass) (Located [LConDeclField pass]) -getConNames :: ConDecl (GhcPass p) -> [Located (IdP (GhcPass p))] +getConNames :: ConDecl GhcRn -> [Located Name] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names -getConArgs :: ConDecl pass -> HsConDeclDetails pass +getConArgs :: ConDecl GhcRn -> HsConDeclDetails GhcRn getConArgs d = con_args d hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass] @@ -1518,16 +1610,30 @@ instance Outputable NewOrData where ppr NewType = text "newtype" ppr DataType = text "data" -pp_condecls :: (OutputableBndrId p) => [LConDecl (GhcPass p)] -> SDoc -pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax +pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc +pp_condecls cs + | gadt_syntax -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) -pp_condecls cs -- In H98 syntax + | otherwise -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) + where + gadt_syntax = case cs of + [] -> False + (L _ ConDeclH98{} : _) -> False + (L _ ConDeclGADT{} : _) -> True + (L _ (XConDecl x) : _) -> + case ghcPass @p of + GhcPs | ConDeclGADTPrefixPs{} <- x + -> True +#if __GLASGOW_HASKELL__ < 811 + GhcRn -> noExtCon x + GhcTc -> noExtCon x +#endif instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where ppr = pprConDecl -pprConDecl :: (OutputableBndrId p) => ConDecl (GhcPass p) -> SDoc +pprConDecl :: forall p. OutputableBndrId p => ConDecl (GhcPass p) -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con , con_ex_tvs = ex_tvs , con_mb_cxt = mcxt @@ -1558,6 +1664,16 @@ pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) ppr_arrow_chain [] = empty +pprConDecl (XConDecl x) = + case ghcPass @p of + GhcPs | ConDeclGADTPrefixPs { con_gp_names = cons, con_gp_ty = ty + , con_gp_doc = doc } <- x + -> ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+> ppr ty +#if __GLASGOW_HASKELL__ < 811 + GhcRn -> noExtCon x + GhcTc -> noExtCon x +#endif + ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 61cb81006b..99d627965d 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -166,6 +166,8 @@ deriving instance Data (ConDecl GhcPs) deriving instance Data (ConDecl GhcRn) deriving instance Data (ConDecl GhcTc) +deriving instance Data ConDeclGADTPrefixPs + -- deriving instance DataIdLR p p => Data (TyFamInstDecl p) deriving instance Data (TyFamInstDecl GhcPs) deriving instance Data (TyFamInstDecl GhcRn) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 8dfc317cd9..ef935cc59f 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -58,7 +58,8 @@ module GHC.Hs.Type ( hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames, splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, splitLHsPatSynTy, - splitLHsForAllTyInvis, splitLHsQualTy, splitLHsSigmaTyInvis, + splitLHsForAllTyInvis, splitLHsQualTy, + splitLHsSigmaTyInvis, splitLHsGADTPrefixTy, splitHsFunType, hsTyGetAppHead_maybe, mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, ignoreParens, hsSigType, hsSigWcType, hsPatSigType, @@ -1348,6 +1349,43 @@ splitLHsSigmaTyInvis ty , (ctxt, ty2) <- splitLHsQualTy ty1 = (tvs, ctxt, ty2) +-- | Decompose a prefix GADT type into its constituent parts. +-- Returns @(mb_tvbs, mb_ctxt, body)@, where: +-- +-- * @mb_tvbs@ are @Just@ the leading @forall@s, if they are provided. +-- Otherwise, they are @Nothing@. +-- +-- * @mb_ctxt@ is @Just@ the context, if it is provided. +-- Otherwise, it is @Nothing@. +-- +-- * @body@ is the body of the type after the optional @forall@s and context. +-- +-- 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. +splitLHsGADTPrefixTy :: + LHsType pass + -> (Maybe [LHsTyVarBndr Specificity pass], Maybe (LHsContext pass), LHsType pass) +splitLHsGADTPrefixTy ty + | (mb_tvbs, rho) <- split_forall ty + , (mb_ctxt, tau) <- split_ctxt rho + = (mb_tvbs, mb_ctxt, tau) + where + -- NB: We do not use splitLHsForAllTyInvis below, since that looks through + -- parentheses... + split_forall (L _ (HsForAllTy { hst_fvf = ForallInvis, hst_bndrs = bndrs + , hst_body = rho })) + = (Just bndrs, rho) + split_forall sigma + = (Nothing, sigma) + + -- ...similarly, we do not use splitLHsQualTy below, since that also looks + -- through parentheses. + split_ctxt (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) + = (Just cxt, tau) + split_ctxt tau + = (Nothing, tau) + -- | Decompose a type of the form @forall <tvs>. body@ into its constituent -- parts. Only splits type variable binders that -- were quantified invisibly (e.g., @forall a.@, with a dot). diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index cbb21b1ad0..f8199b3332 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -1242,7 +1242,8 @@ hsTyClForeignBinders tycl_decls foreign_decls getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs ------------------- -hsLTyClDeclBinders :: Located (TyClDecl (GhcPass p)) +hsLTyClDeclBinders :: IsPass p + => Located (TyClDecl (GhcPass p)) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -- ^ Returns all the /binding/ names of the decl. The first one is -- guaranteed to be the name of the decl. The first component @@ -1304,7 +1305,8 @@ getPatSynBinds binds , L _ (PatSynBind _ psb) <- bagToList lbinds ] ------------------- -hsLInstDeclBinders :: LInstDecl (GhcPass p) +hsLInstDeclBinders :: IsPass p + => LInstDecl (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl @@ -1316,7 +1318,8 @@ hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty ------------------- -- | the 'SrcLoc' returned are for the whole declarations, not just the names -hsDataFamInstBinders :: DataFamInstDecl (GhcPass p) +hsDataFamInstBinders :: IsPass p + => DataFamInstDecl (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = defn }}}) @@ -1325,7 +1328,8 @@ hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = ------------------- -- | the 'SrcLoc' returned are for the whole declarations, not just the names -hsDataDefnBinders :: HsDataDefn (GhcPass p) +hsDataDefnBinders :: IsPass p + => HsDataDefn (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons @@ -1335,7 +1339,8 @@ hsDataDefnBinders (HsDataDefn { dd_cons = cons }) type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)] -- Filters out ones that have already been seen -hsConDeclsBinders :: [LConDecl (GhcPass p)] +hsConDeclsBinders :: forall p. IsPass p + => [LConDecl (GhcPass p)] -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -- See hsLTyClDeclBinders for what this does -- The function is boringly complicated because of the records @@ -1365,6 +1370,16 @@ hsConDeclsBinders cons (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs + XConDecl x -> case ghcPass @p of + GhcPs | ConDeclGADTPrefixPs { con_gp_names = names } <- x + -> (map (L loc . unLoc) names ++ ns, fs) +#if __GLASGOW_HASKELL__ < 811 + GhcRn -> noExtCon x + GhcTc -> noExtCon x +#endif + where + (ns, fs) = go remSeen rs + get_flds :: Seen p -> HsConDeclDetails (GhcPass p) -> (Seen p, [LFieldOcc (GhcPass p)]) get_flds remSeen (RecCon flds) diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 50459c673e..a081205033 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -2250,9 +2250,8 @@ gadt_constr :: { LConDecl GhcPs } -- see Note [Difference in parsing GADT and data constructors] -- Returns a list because of: C,D :: ty : con_list '::' sigtypedoc - {% let (gadt,anns) = mkGadtDecl (unLoc $1) $3 - in ams (sLL $1 $> gadt) - (mu AnnDcolon $2:anns) } + {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) $3)) + [mu AnnDcolon $2] } {- Note [Difference in parsing GADT and data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 273fa0d704..645f56fc54 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -685,43 +685,35 @@ mkConDeclH98 name mb_forall mb_cxt args , con_args = args , con_doc = Nothing } +-- | Construct a GADT-style data constructor from the constructor names and +-- their type. This will return different AST forms for record syntax +-- constructors and prefix constructors, as the latter must be handled +-- specially in the renamer. See @Note [GADT abstract syntax]@ in +-- "GHC.Hs.Decls" for the full story. mkGadtDecl :: [Located RdrName] - -> LHsType GhcPs -- Always a HsForAllTy - -> (ConDecl GhcPs, [AddAnn]) + -> LHsType GhcPs + -> ConDecl GhcPs mkGadtDecl names ty - = (ConDeclGADT { con_g_ext = noExtField - , con_names = names - , con_forall = L l $ isLHsForAllTy ty' - , con_qvars = tvs - , con_mb_cxt = mcxt - , con_args = args - , con_res_ty = res_ty - , con_doc = Nothing } - , anns1 ++ anns2) + | Just (mtvs, mcxt, args, res_ty) <- mb_record_gadt ty + = ConDeclGADT { con_g_ext = noExtField + , con_names = names + , con_forall = L (getLoc ty) $ isJust mtvs + , con_qvars = fromMaybe [] mtvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty + , con_doc = Nothing } + | otherwise + = XConDecl $ ConDeclGADTPrefixPs { con_gp_names = names + , con_gp_ty = mkLHsSigType ty + , con_gp_doc = Nothing } where - (ty'@(L l _),anns1) = peel_parens ty [] - (tvs, rho) = splitLHsForAllTyInvis ty' - (mcxt, tau, anns2) = split_rho rho [] - - split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann - = (Just cxt, tau, ann) - split_rho (L l (HsParTy _ ty)) ann - = split_rho ty (ann++mkParensApiAnn l) - split_rho tau ann - = (Nothing, tau, ann) - - (args, res_ty) = split_tau tau - - -- See Note [GADT abstract syntax] in GHC.Hs.Decls - split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty)) - = (RecCon (L loc rf), res_ty) - split_tau tau - = (PrefixCon [], tau) - - peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty - (ann++mkParensApiAnn l) - peel_parens ty ann = (ty, ann) - + mb_record_gadt ty + | (mtvs, mcxt, body_ty) <- splitLHsGADTPrefixTy ty + , L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty) <- body_ty + = Just (mtvs, mcxt, RecCon (L loc rf), res_ty) + | otherwise + = Nothing setRdrNameSpace :: RdrName -> NameSpace -> RdrName -- ^ This rather gruesome function is used mainly by the parser. diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index f232113c2e..409b0c120f 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -12,24 +12,28 @@ import Control.Monad -- ----------------------------------------------------------------------------- -- Adding documentation to record fields (used in parsing). -addFieldDoc :: LConDeclField a -> Maybe LHsDocString -> LConDeclField a +addFieldDoc :: LConDeclField GhcPs -> Maybe LHsDocString -> LConDeclField GhcPs addFieldDoc (L l fld) doc = L l (fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }) -addFieldDocs :: [LConDeclField a] -> Maybe LHsDocString -> [LConDeclField a] +addFieldDocs :: [LConDeclField GhcPs] -> Maybe LHsDocString -> [LConDeclField GhcPs] addFieldDocs [] _ = [] addFieldDocs (x:xs) doc = addFieldDoc x doc : xs -addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a +addConDoc :: LConDecl GhcPs -> Maybe LHsDocString -> LConDecl GhcPs addConDoc decl Nothing = decl -addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } ) +addConDoc (L p c) doc = L p $ case c of + ConDeclH98 { con_doc = old_doc } -> c { con_doc = old_doc `mplus` doc } + ConDeclGADT { con_doc = old_doc } -> c { con_doc = old_doc `mplus` doc } + XConDecl x@(ConDeclGADTPrefixPs { con_gp_doc = old_doc }) -> + XConDecl (x { con_gp_doc = old_doc `mplus` doc }) -addConDocs :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] +addConDocs :: [LConDecl GhcPs] -> Maybe LHsDocString -> [LConDecl GhcPs] addConDocs [] _ = [] addConDocs [x] doc = [addConDoc x doc] addConDocs (x:xs) doc = x : addConDocs xs doc -addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] +addConDocFirst :: [LConDecl GhcPs] -> Maybe LHsDocString -> [LConDecl GhcPs] addConDocFirst [] _ = [] addConDocFirst (x:xs) doc = addConDoc x doc : xs diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 5e9d4dec64..0a355b01ee 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -1746,8 +1746,9 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType } where h98_style = case condecls of -- Note [Stupid theta] - (L _ (ConDeclGADT {})) : _ -> False - _ -> True + (L _ (ConDeclGADT {})) : _ -> False + (L _ (XConDecl (ConDeclGADTPrefixPs {}))) : _ -> False + _ -> True rn_derivs (L loc ds) = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies @@ -2084,7 +2085,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs do { (new_context, fvs1) <- rnMbContext ctxt mcxt ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args ; let all_fvs = fvs1 `plusFV` fvs2 - ; traceRn "rnConDecl" (ppr name <+> vcat + ; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat [ text "ex_tvs:" <+> ppr ex_tvs , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) @@ -2127,22 +2128,68 @@ rnConDecl decl@(ConDeclGADT { con_names = names ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 - (args', res_ty') - = case args of - InfixCon {} -> pprPanic "rnConDecl" (ppr names) - RecCon {} -> (new_args, new_res_ty) - PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty - -> ASSERT( null as ) - -- See Note [GADT abstract syntax] in GHC.Hs.Decls - (PrefixCon arg_tys, final_res_ty) - - ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) + + ; traceRn "rnConDecl (ConDeclGADT)" + (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) ; return (decl { con_g_ext = implicit_tkvs, con_names = new_names , con_qvars = explicit_tkvs, con_mb_cxt = new_cxt - , con_args = args', con_res_ty = res_ty' + , con_args = new_args, con_res_ty = new_res_ty , con_doc = mb_doc' }, all_fvs) } } +-- This case is only used for prefix GADT constructors generated by GHC's +-- parser, where we do not know the argument types until type operator +-- precedence has been resolved. See Note [GADT abstract syntax] in +-- GHC.Hs.Decls for the full story. +rnConDecl (XConDecl (ConDeclGADTPrefixPs { con_gp_names = names, con_gp_ty = ty + , con_gp_doc = mb_doc })) + = do { mapM_ (addLocM checkConName) names + ; new_names <- mapM lookupLocatedTopBndrRn names + ; mb_doc' <- rnMbLHsDoc mb_doc + + ; let ctxt = ConDeclCtx new_names + ; (ty', fvs) <- rnHsSigType ctxt TypeLevel Nothing ty + + -- Now that operator precedence has been resolved, we can split the + -- GADT type into its individual components below. + ; let HsIB { hsib_ext = implicit_tkvs, hsib_body = body } = ty' + (mb_explicit_tkvs, mb_cxt, tau) = splitLHsGADTPrefixTy body + lhas_forall = L (getLoc body) $ isJust mb_explicit_tkvs + explicit_tkvs = fromMaybe [] mb_explicit_tkvs + (arg_tys, res_ty) = splitHsFunType tau + arg_details = PrefixCon arg_tys + -- NB: The only possibility here is PrefixCon. RecCon is handled + -- separately, through ConDeclGADT, from the parser onwards. + + -- Ensure that there are no nested `forall`s or contexts, per + -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts) + -- in GHC.Hs.Type. + ; case res_ty of + L l (HsForAllTy { hst_fvf = fvf }) + | ForallVis <- fvf + -> setSrcSpan l $ addErr $ withHsDocContext ctxt $ vcat + [ text "Illegal visible, dependent quantification" <+> + text "in the type of a term" + , text "(GHC does not yet support this)" ] + | ForallInvis <- fvf + -> nested_foralls_contexts_err l ctxt + L l (HsQualTy {}) + -> nested_foralls_contexts_err l ctxt + _ -> pure () + + ; traceRn "rnConDecl (ConDeclGADTPrefixPs)" + (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) + ; pure (ConDeclGADT { con_g_ext = implicit_tkvs, con_names = new_names + , con_forall = lhas_forall, con_qvars = explicit_tkvs + , con_mb_cxt = mb_cxt, con_args = arg_details + , con_res_ty = res_ty, con_doc = mb_doc' }, + fvs) } + where + nested_foralls_contexts_err :: SrcSpan -> HsDocContext -> RnM () + nested_foralls_contexts_err l ctxt = + setSrcSpan l $ addErr $ withHsDocContext ctxt $ + text "GADT constructor type signature cannot contain nested" + <+> quotes forAllLit <> text "s or contexts" rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) -> RnM (Maybe (LHsContext GhcRn), FreeVars) diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 98550132c5..8ff9ad0d3e 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -3058,7 +3058,7 @@ dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons ----------------------------------- -consUseGadtSyntax :: [LConDecl a] -> Bool +consUseGadtSyntax :: [LConDecl GhcRn] -> Bool consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True consUseGadtSyntax _ = False -- All constructors have same shape @@ -4705,50 +4705,12 @@ noClassTyVarErr clas fam_tc badDataConTyCon :: DataCon -> Type -> SDoc badDataConTyCon data_con res_ty_tmpl - | ASSERT( all isTyVar tvs ) - tcIsForAllTy actual_res_ty - = nested_foralls_contexts_suggestion - | isJust (tcSplitPredFunTy_maybe actual_res_ty) - = nested_foralls_contexts_suggestion - | otherwise = hang (text "Data constructor" <+> quotes (ppr data_con) <+> text "returns type" <+> quotes (ppr actual_res_ty)) 2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl)) where actual_res_ty = dataConOrigResTy data_con - -- This suggestion is useful for suggesting how to correct code like what - -- was reported in #12087: - -- - -- data F a where - -- MkF :: Ord a => Eq a => a -> F a - -- - -- Although nested foralls or contexts are allowed in function type - -- signatures, it is much more difficult to engineer GADT constructor type - -- signatures to allow something similar, so we error in the latter case. - -- Nevertheless, we can at least suggest how a user might reshuffle their - -- exotic GADT constructor type signature so that GHC will accept. - nested_foralls_contexts_suggestion = - text "GADT constructor type signature cannot contain nested" - <+> quotes forAllLit <> text "s or contexts" - $+$ hang (text "Suggestion: instead use this type signature:") - 2 (ppr (dataConName data_con) <+> dcolon <+> ppr suggested_ty) - - -- To construct a type that GHC would accept (suggested_ty), we - -- simply drag all the foralls and (=>) contexts to the front - -- of the type. - suggested_ty = mkSpecSigmaTy tvs theta rho - (tvs, theta, rho) = go (dataConUserType data_con) - - go :: Type -> ([TyVar],ThetaType,Type) - -- The returned Type has no foralls or =>, even to the right of an (->) - go ty | null arg_tys = (tvs1, theta1, rho1) - | otherwise = (tvs1 ++ tvs2, theta1 ++ theta2, mkVisFunTys arg_tys rho2) - where - (tvs1, theta1, rho1) = tcSplitNestedSigmaTys ty - (arg_tys, ty2) = tcSplitFunTys rho1 - (tvs2, theta2, rho2) = go ty2 - badGadtDecl :: Name -> SDoc badGadtDecl tc_name = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index d5b4ef28f1..219072e824 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -50,7 +50,6 @@ import GHC.Utils.Lexeme import GHC.Utils.Misc import GHC.Data.FastString import GHC.Utils.Outputable as Outputable -import GHC.Utils.Monad ( foldrM ) import qualified Data.ByteString as BS import Control.Monad( unless, ap ) @@ -595,6 +594,8 @@ cvtConstr (ForallC tvs ctxt con) add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2)) + add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs + -> ConDecl GhcPs -> ConDecl GhcPs add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) = con { con_forall = noLoc $ not (null all_tvs) , con_qvars = all_tvs @@ -609,7 +610,13 @@ cvtConstr (ForallC tvs ctxt con) where all_tvs = tvs' ++ ex_tvs - add_forall _ _ (XConDecl nec) = noExtCon nec + -- The GadtC and RecGadtC cases of cvtConstr will always return a + -- ConDeclGADT, not a ConDeclGADTPrefixPs, so this case is unreachable. + -- See Note [GADT abstract syntax] in GHC.Hs.Decls for more on the + -- distinction between ConDeclGADT and ConDeclGADTPrefixPs. + add_forall _ _ con@(XConDecl (ConDeclGADTPrefixPs {})) = + pprPanic "cvtConstr.add_forall: Unexpected ConDeclGADTPrefixPs" + (Outputable.ppr con) cvtConstr (GadtC [] _strtys _ty) = failWith (text "GadtC must have at least one constructor name") @@ -617,9 +624,8 @@ cvtConstr (GadtC [] _strtys _ty) cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys - ; L _ ty' <- cvtType ty - ; c_ty <- mk_arr_apps args ty' - ; returnL $ fst $ mkGadtDecl c' c_ty} + ; ty' <- cvtType ty + ; returnL $ mk_gadt_decl c' (PrefixCon args) ty'} cvtConstr (RecGadtC [] _varstrtys _ty) = failWith (text "RecGadtC must have at least one constructor name") @@ -628,9 +634,19 @@ cvtConstr (RecGadtC c varstrtys ty) = do { c' <- mapM cNameL c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys - ; let rec_ty = noLoc (HsFunTy noExtField - (noLoc $ HsRecTy noExtField rec_flds) ty') - ; returnL $ fst $ mkGadtDecl c' rec_ty } + ; returnL $ mk_gadt_decl c' (RecCon $ noLoc rec_flds) ty' } + +mk_gadt_decl :: [Located RdrName] -> HsConDeclDetails GhcPs -> LHsType GhcPs + -> ConDecl GhcPs +mk_gadt_decl names args res_ty + = ConDeclGADT { con_g_ext = noExtField + , con_names = names + , con_forall = noLoc False + , con_qvars = [] + , con_mb_cxt = Nothing + , con_args = args + , con_res_ty = res_ty + , con_doc = Nothing } cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack @@ -1647,13 +1663,6 @@ See (among other closed issued) https://gitlab.haskell.org/ghc/ghc/issues/14289 -} -- --------------------------------------------------------------------- --- | Constructs an arrow type with a specified return type -mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs) -mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL - where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs) - go arg ret_ty = do { ret_ty_l <- returnL ret_ty - ; return (HsFunTy noExtField arg ret_ty_l) } - split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs]) split_ty_app ty = go ty [] where |