Vladislav Zavialov pushed to branch wip/int-index/curried-ctxts at Glasgow Haskell Compiler / GHC Commits: bb2c9f35 by Vladislav Zavialov at 2026-10-14T20:05:35+02:00 Curried contexts in prefix GADT constructors Prefix GADT constructor declarations now accept multiple consecutive contexts, equivalent to a single conjoined context: data G a where MkCurried :: C a => (D a, E a) => G a MkConjoined :: (C a, D a, E a) => G a This is a step towards GHC Proposal #402 "Stable GADT constructor syntax". To represent multiple contexts, the `con_mb_cxt` field of `ConDeclGADT` has been replaced by `con_cxts`, which stores a list instead of a Maybe: - con_mb_cxt :: Maybe (LHsContext pass) + con_cxts :: [LHsContext pass] The rest of this patch follows from this change. Note that in ConDeclH98, the optional context is still stored as a Maybe. To accommodate this difference, a few helper functions were generalised over a Foldable container `t`: hsConDeclTheta :: Foldable t => t (LHsContext ...) -> [LHsType ...] pprLHsContext :: (Foldable t, ...) => t (LHsContext ...) -> SDoc repContexts :: Foldable t => t (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) tcHsContext :: Foldable t => t (LHsContext GhcRn) -> TcM [PredType] In practice, the instantiations of `t` are either `Maybe` or `[]`. Record-style GADT constructors continue to accept at most one context. `splitLHsGadtTy` accounts for this by splitting off only the first context if it detects record syntax, leaving the offending part of the type in the body for the renamer to reject later on. - - - - - 20 changed files: - changelog.d/allow-gadt-prefix-con-parens - + changelog.d/gadt-curried-contexts-27424 - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Type.hs - docs/users_guide/exts/gadt_syntax.rst - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs Changes: ===================================== changelog.d/allow-gadt-prefix-con-parens ===================================== @@ -6,7 +6,7 @@ mrs: !16321 description: Parenthesized types are now accepted in prefix GADT constructor declarations, - even when they contain explicit ``forall`` quantifiers. For example: + even when they contain explicit ``forall`` quantifiers. For example:: data T where MkT :: (forall a. a -> b -> T) ===================================== changelog.d/gadt-curried-contexts-27424 ===================================== @@ -0,0 +1,15 @@ +section: language +synopsis: Allow multiple consecutive contexts in prefix GADT constructor declarations (GHC Proposal `#402 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0402-gadt-syntax.rst>`_ "Stable GADT constructor syntax") +issues: #27424 +mrs: !16819 + +description: { + Prefix GADT constructor declarations now accept multiple consecutive contexts, + equivalent to a single conjoined context. For example:: + + data G a where + MkCurried :: C a => (D a, E a) => G a + MkConjoined :: (C a, D a, E a) => G a + + Record-style GADT constructor declarations continue to accept at most one context. +} ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -886,9 +886,8 @@ getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of PrefixConGADT{} -> Nothing RecConGADT _ flds -> Just flds -hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)] -hsConDeclTheta Nothing = [] -hsConDeclTheta (Just (L _ (HsContext _ theta))) = theta +hsConDeclTheta :: Foldable t => t (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)] +hsConDeclTheta = concatMap (hsc_ctxt . unLoc) ppDataDefnHeader :: (OutputableBndrId p) @@ -971,11 +970,11 @@ pprConDecl (ConDeclH98 { con_name = L _ con pprConDecl (ConDeclGADT { con_names = cons , con_outer_bndrs = L _ outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = mcxt, con_g_args = args + , con_cxts = cxts, con_g_args = args , con_res_ty = res_ty, con_modifiers = mods, con_doc = doc }) = pprMaybeWithDoc doc $ pprLHsModifiers mods <+> ppr_con_names (toList cons) <+> dcolon <+> sep [ppr_outer_bndrs, ppr_inner_bndrs ( - sep [ pprLHsContext mcxt, + sep [ pprLHsContext cxts, sep (ppr_args args ++ [ppr res_ty])])] where ppr_args (PrefixConGADT _ args) = map (pprHsConDeclFieldWith (\arr tyDoc -> tyDoc <+> pprHsModifiedFunArr arr)) args ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -126,6 +126,7 @@ import GHC.Utils.Misc (count) import Data.Maybe import Data.Data (Data) +import Data.Foldable ( toList ) import qualified Data.Semigroup as S import GHC.Data.Bag @@ -896,7 +897,7 @@ splitLHsSigmaTyInvis ty = (tvs, ctxt, ty2) -- | Decompose a GADT type into its constituent parts. --- Returns @(outer_bndrs, inner_bndrs, mb_ctxt, body)@, where: +-- Returns @(outer_bndrs, inner_bndrs, ctxts, body)@, where: -- -- * @outer_bndrs@ are 'HsOuterExplicit' if the type has explicit, outermost -- type variable binders. Otherwise, they are 'HsOuterImplicit'. @@ -904,10 +905,9 @@ splitLHsSigmaTyInvis ty -- * @inner_bndrs@ are the remaining @forall@ telescopes, interleaved with the -- parentheses that enclose them. -- --- * @mb_ctxt@ is @Just@ the context, if it is provided. --- Otherwise, it is @Nothing@. +-- * @ctxts@ are the contexts adjacent to the @forall@s, if any. -- --- * @body@ is the body of the type after the optional @forall@s and context. +-- * @body@ is the body of the type after the optional @forall@s and contexts. -- -- This function does look through parentheses, but it does not discard them: -- they are syntactically significant, so they are recorded in @inner_bndrs@. @@ -915,16 +915,22 @@ splitLHsSigmaTyInvis ty -- in "GHC.Hs.Decls" for why this is important. splitLHsGadtTy :: LHsSigType GhcPs - -> (HsOuterSigTyVarBndrs GhcPs, [LHsGadtTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs) + -> (HsOuterSigTyVarBndrs GhcPs, [LHsGadtTelescope GhcPs], [LHsContext GhcPs], LHsType GhcPs) splitLHsGadtTy (L _ sig_ty) | (outer_bndrs, sigma_ty) <- split_outer_bndrs sig_ty , (inner_bndrs, phi_ty) <- split_inner_bndrs sigma_ty - , (mb_ctxt, rho_ty) <- splitLHsQualTy_KP phi_ty - = if is_gadt_rec_ty rho_ty && not (null inner_bndrs) - -- Bad! Record GADTs are not allowed to have inner_bndrs, - -- undo the split to get a proper error message later - then (outer_bndrs, [], Nothing, sigma_ty) - else (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty) + , (outer_theta, phi_ty') <- splitLHsQualTy_KP phi_ty + , (inner_theta, rho_ty) <- split_ctxts phi_ty' + = case rho_ty of + -- Record GADTs are not allowed to have multiple foralls or contexts. + -- Detect and undo the split to get a proper error message later. + L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _) + | not (null inner_bndrs) -> (outer_bndrs, [], [], sigma_ty) + | not (null inner_theta) -> (outer_bndrs, inner_bndrs, toList outer_theta, phi_ty') + -- All good: either a prefix GADT con, or a record GADT con with at most + -- one forall and at most one context. + _ -> let theta_tys = toList outer_theta ++ inner_theta + in (outer_bndrs, inner_bndrs, theta_tys, rho_ty) where split_outer_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) split_outer_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) = @@ -941,9 +947,10 @@ splitLHsGadtTy (L _ sig_ty) in (L l (HsGadtPar toks) : args, t) split_inner_bndrs t = ([], t) - -- type of form {fld :: ty, ...} -> ResTy - is_gadt_rec_ty (L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _)) = True - is_gadt_rec_ty _ = False + split_ctxts :: LHsType GhcPs -> ([LHsContext GhcPs], LHsType GhcPs) + split_ctxts (L _ HsQualTy { hst_ctxt = ctxt, hst_body = body }) + = let { ~(ctxts, t) = split_ctxts body } in (ctxt : ctxts, t) + split_ctxts t = ([], t) -- | Decompose a type of the form @forall <tvs>. body@ into its constituent -- parts. Only splits type variable binders that @@ -1426,10 +1433,9 @@ pprHsForAllTelescope tele = -- be updated to match. | otherwise = forAllLit <+> interppSP qtvs <> separator -pprLHsContext :: (OutputableBndrId p) - => Maybe (LHsContext (GhcPass p)) -> SDoc -pprLHsContext Nothing = empty -pprLHsContext (Just lctxt) = pprLHsContextAlways lctxt +pprLHsContext :: (Foldable t, OutputableBndrId p) + => t (LHsContext (GhcPass p)) -> SDoc +pprLHsContext = sep . map pprLHsContextAlways . toList -- For use in a HsQualTy, which always gets printed if it exists. pprLHsContextAlways :: (OutputableBndrId p) ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -888,7 +888,7 @@ repC (L _ (ConDeclH98 { con_name = con , con_args = args })) = addHsTyVarBinds FreshNamesOnly con_tvs $ \ ex_bndrs -> do { c' <- repH98DataCon con args - ; ctxt' <- repMbContext mcxt + ; ctxt' <- repContexts mcxt ; if not is_existential && isNothing mcxt then return c' else rep2 forallCOcc ([unC ex_bndrs, unC ctxt', unC c']) @@ -897,7 +897,7 @@ repC (L _ (ConDeclH98 { con_name = con repC (L l (ConDeclGADT { con_names = cons , con_outer_bndrs = L _ outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = mcxt + , con_cxts = cxts , con_g_args = args , con_res_ty = res_ty })) | no_explicit_forall, no_context @@ -908,9 +908,9 @@ repC (L l (ConDeclGADT { con_names = cons | Just invis_inner_bndrs <- m_invis_inner_bndrs = addHsOuterSigTyVarBinds outer_bndrs $ \ outer_bndrs' -> - -- the context is attached to the innermost ForallC + -- the contexts are flattened and attached to the innermost ForallC let loop last_bndrs' [] = do - ctxt' <- repMbContext mcxt + ctxt' <- repContexts cxts c' <- repGadtDataCons cons args res_ty rep2 forallCOcc ([unC last_bndrs', unC ctxt', unC c']) loop last_bndrs' (bndrs : bndrs_s) = @@ -927,7 +927,7 @@ repC (L l (ConDeclGADT { con_names = cons inner_teles = gadtArgTelescopes inner_bndrs no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_teles - no_context = isNothing mcxt + no_context = null cxts m_invis_inner_bndrs :: Maybe [[LHsTyVarBndr Specificity GhcRn]] m_invis_inner_bndrs = traverse get_invis_bndrs inner_teles @@ -936,9 +936,9 @@ repC (L l (ConDeclGADT { con_names = cons get_invis_bndrs HsForAllVis{} = Nothing get_invis_bndrs HsForAllInvis { hsf_invis_bndrs = tvbs } = Just tvbs -repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) -repMbContext Nothing = repContext emptyContext -repMbContext (Just (L _ cxt)) = repContext cxt +-- | Flatten several contexts into a single 'TH.Cxt'. +repContexts :: Foldable t => t (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) +repContexts cxts = repContext $ HsContext noAnn (hsConDeclTheta cxts) repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness)) repSrcUnpackedness SrcUnpack = rep2 sourceUnpackOcc [] ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1761,7 +1761,7 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where ConDeclGADT { con_names = names , con_outer_bndrs = L outer_bndrs_loc outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = ctx + , con_cxts = cxts , con_g_args = args , con_res_ty = typ , con_doc = doc} -> @@ -1770,14 +1770,14 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where map (C $ TyVarBind (mkScope outer_bndrs_loc) (ResolvedScopes [sigmaScope])) imp_vars , toHie $ tvScopes (ResolvedScopes [phiScope]) NoScope exp_bndrs - , toHie ctx + , toHie cxts , toHie args , toHie typ , toHie doc ] where rhsScope = combineScopes argsScope tyScope - ctxScope = maybe NoScope mkScope ctx + ctxScope = foldr combineScopes NoScope (map mkScope cxts) argsScope = case args of PrefixConGADT _ xs -> scaled_args_scope xs RecConGADT _ x -> mkScope x ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -833,13 +833,13 @@ mkGadtDecl loc mods names dcol ty = do , con_names = names , con_outer_bndrs = L outer_bndrs_loc outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = mcxt + , con_cxts = cxts , con_g_args = args , con_res_ty = res_ty , con_modifiers = mods , con_doc = Nothing } where - (outer_bndrs, inner_bndrs, mcxt, body_ty) = splitLHsGadtTy ty + (outer_bndrs, inner_bndrs, cxts, body_ty) = splitLHsGadtTy ty outer_bndrs_loc = case outer_bndrs of HsOuterImplicit{} -> getLoc ty HsOuterExplicit an _ -> EpAnn (entry an) noAnn emptyComments ===================================== compiler/GHC/Parser/PostProcess/Haddock.hs ===================================== @@ -694,7 +694,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where extendHdkA (locA l_con_decl) $ case con_decl of ConDeclGADT { con_g_ext, con_names, con_outer_bndrs, con_inner_bndrs - , con_mb_cxt, con_g_args, con_res_ty, con_modifiers } -> do + , con_cxts, con_g_args, con_res_ty, con_modifiers } -> do con_doc' <- getConDoc (getLocA (NE.head con_names)) con_g_args' <- case con_g_args of @@ -705,7 +705,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where con_res_ty' <- addHaddock con_res_ty pure $ L l_con_decl $ ConDeclGADT { con_g_ext, con_names, - con_outer_bndrs, con_inner_bndrs, con_mb_cxt, con_modifiers, + con_outer_bndrs, con_inner_bndrs, con_cxts, con_modifiers, con_doc = lexLHsDocString <$> con_doc', con_g_args = con_g_args', con_res_ty = con_res_ty' } ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -28,7 +28,8 @@ import GHC.Rename.HsType import GHC.Rename.Bind import GHC.Rename.Doc import GHC.Rename.Env -import GHC.Rename.Utils ( mapFvRn, bindLocalNames +import GHC.Rename.Utils ( mapFvRn, mapMaybeFvRn + , bindLocalNames , checkDupRdrNames, bindLocalNamesFV , warnUnusedTypePatterns , noNestedForallsContextsErr @@ -2615,7 +2616,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs ; let ctxt = ConDeclCtx [new_name] ; bindLHsTyVarBndrs ctxt WarnUnusedForalls Nothing ex_tvs $ \ new_ex_tvs -> - do { (new_context, fvs1) <- rnMbContext ctxt mcxt + do { (new_context, fvs1) <- mapMaybeFvRn (rnContext ctxt) mcxt ; (new_args, fvs2) <- rnConDeclH98Details (unLoc new_name) ctxt args ; (mods', mods_fvs) <- rnModifiersContextAndWarn ctxt mods ; let all_fvs = fvs1 `plusFN` fvs2 `plusFN` mods_fvs @@ -2635,7 +2636,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs rnConDecl (ConDeclGADT { con_names = names , con_outer_bndrs = L outer_bndrs_loc outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = mcxt + , con_cxts = cxts , con_g_args = args , con_res_ty = res_ty , con_modifiers = mods @@ -2651,7 +2652,7 @@ rnConDecl (ConDeclGADT { con_names = names implicit_bndrs = extractHsOuterTvBndrs outer_bndrs $ extractHsGadtTelescopes inner_bndrs $ - extractHsTysRdrTyVars (hsConDeclTheta mcxt) $ + extractHsTysRdrTyVars (hsConDeclTheta cxts) $ extractConDeclGADTDetailsTyVars args $ extractHsTysRdrTyVars [res_ty] [] @@ -2659,7 +2660,7 @@ rnConDecl (ConDeclGADT { con_names = names ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' -> bindHsGadtTelescopes ctxt inner_bndrs $ \inner_bndrs' -> - do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt + do { (new_cxts, fvs1) <- mapFvRn (rnContext ctxt) cxts ; (new_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty ; (mods', mods_fvs) <- rnModifiersContextAndWarn ctxt mods @@ -2678,17 +2679,11 @@ rnConDecl (ConDeclGADT { con_names = names ; return (ConDeclGADT { con_g_ext = noExtField, con_names = new_names , con_outer_bndrs = L outer_bndrs_loc outer_bndrs' , con_inner_bndrs = inner_bndrs' - , con_mb_cxt = new_cxt + , con_cxts = new_cxts , con_g_args = new_args, con_res_ty = new_res_ty , con_doc = new_mb_doc, con_modifiers = mods' }, all_fvs) } } -rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) - -> RnM (Maybe (LHsContext GhcRn), FreeNames) -rnMbContext _ Nothing = return (Nothing, emptyFNs) -rnMbContext doc cxt = do { (ctx',fvs) <- rnMaybeContext doc cxt - ; return (ctx',fvs) } - rnConDeclH98Details :: Name -> HsDocContext ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -2144,9 +2144,8 @@ checkExpKind _rn_ty ty ki (Infer cell) = do --------------------------- -tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] -tcHsContext Nothing = return [] -tcHsContext (Just cxt) = tc_hs_context typeLevelMode cxt +tcHsContext :: Foldable t => t (LHsContext GhcRn) -> TcM [PredType] +tcHsContext = foldMapM (tc_hs_context typeLevelMode) tcLHsPredType :: LHsType GhcRn -> TcM PredType tcLHsPredType pred = tc_lhs_pred typeLevelMode pred ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -2263,14 +2263,14 @@ kcConDecl new_or_data _tc_res_kind (ConDeclGADT { con_names = names , con_outer_bndrs = L _ outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = cxt + , con_cxts = cxts , con_g_args = args , con_res_ty = res_ty }) = -- See Note [kcConDecls: kind-checking data type decls] addErrCtxt (DataConDefCtxt names) $ -- Not sure this is right, should just extend rather than skolemise but no test bind_con_tvbs outer_bndrs inner_bndrs $ - do { _ <- tcHsContext cxt + do { _ <- tcHsContext cxts ; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty) ; con_res_kind <- newOpenTypeKind ; _ <- tcCheckLHsTypeInContext res_ty (TheKind con_res_kind) @@ -4175,7 +4175,7 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map (ConDeclGADT { con_names = names , con_outer_bndrs = L _ outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = cxt, con_g_args = hs_args + , con_cxts = cxts, con_g_args = hs_args , con_res_ty = hs_res_ty }) = addErrCtxt (DataConDefCtxt names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) @@ -4184,7 +4184,7 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map ; (tclvl, wanted, (tvbs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $ tcGadtConTyVarBndrs skol_info outer_bndrs inner_bndrs $ - do { ctxt <- tcHsContext cxt + do { ctxt <- tcHsContext cxts ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty -- See Note [GADT return kinds] ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -59,7 +59,7 @@ import Data.Bifunctor (first) import Data.Foldable (for_) import Data.List.NonEmpty( NonEmpty (..), nonEmpty ) import qualified Data.List.NonEmpty as NE -import Data.Maybe( catMaybes, isNothing ) +import Data.Maybe( catMaybes, maybeToList, isNothing ) import Data.Word (Word64) import GHC.Boot.TH.Syntax as TH import Foreign.ForeignPtr @@ -718,16 +718,23 @@ cvtConstr parent_con do_con_name (ForallC tvs ctxt con) add_cxt (L loc (HsContext _ cxt1)) (Just (L _ (HsContext _ cxt2))) = Just (L loc (HsContext noAnn (cxt1 ++ cxt2))) - -- Nested foralls end up flattened (see tests/th/GadtConSigs_th_dump1.stderr) + prepend_cxt :: LHsContext GhcPs -> [LHsContext GhcPs] -> [LHsContext GhcPs] + prepend_cxt lcxt = map_mb_head (add_cxt lcxt) + where + map_mb_head :: (Maybe a -> Maybe a) -> [a] -> [a] + map_mb_head f [] = maybeToList (f Nothing) + map_mb_head f (x:xs) = maybeToList (f (Just x)) ++ xs + + -- Nested foralls and contexts end up flattened (see tests/th/GadtConSigs_th_dump1.stderr) -- but it doesn't seem to matter. add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs -> ConDecl GhcPs -> ConDecl GhcPs add_forall tvs' cxt' con@(ConDeclGADT { con_outer_bndrs = L l outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = cxt }) + , con_cxts = cxts }) = con { con_outer_bndrs = L l outer_bndrs' , con_inner_bndrs = inner_bndrs - , con_mb_cxt = add_cxt cxt' cxt } + , con_cxts = prepend_cxt cxt' cxts } where outer_bndrs' | null all_tvs = mkHsOuterImplicit @@ -770,7 +777,7 @@ mk_gadt_decl names args res_ty , con_names = names , con_outer_bndrs = outer_bndrs , con_inner_bndrs = [] - , con_mb_cxt = Nothing + , con_cxts = [] , con_g_args = args , con_res_ty = res_ty , con_modifiers = [] ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -964,7 +964,7 @@ data ConDecl pass , con_inner_bndrs :: [LHsGadtTelescope pass] -- ^ The forall telescopes other than the outermost invisible forall, -- interleaved with the parentheses that enclose them. - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_cxts :: [LHsContext pass] -- ^ User-written contexts , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix , con_res_ty :: LHsType pass -- ^ Result type @@ -994,7 +994,7 @@ data ConDecl pass ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The types of both forms of GADT constructors are very structured, as they must consist of the quantified type variables (if provided), followed by the -context (if provided), followed by the argument types (if provided), followed +contexts (if provided), followed by the argument types (if provided), followed by the result type. (See "Wrinkle: No nested foralls or contexts" below for more discussion on the restrictions imposed here.) As a result, instead of storing the type of a GADT constructor as a single LHsType, we split it up @@ -1069,6 +1069,8 @@ the GADT type, in precisely that order. For instance: 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 + -- OK, `Eq a` and `Eq b` are consecutive + MkT3' :: forall a b. Eq a => a -> Eq b => b -> T -- Rejected, `Eq b` is nested MkT4 :: Int -> forall a. a -> T -- Rejected, `forall a` is nested @@ -1084,10 +1086,11 @@ User's Guide. GHC enforces that GADT constructors do not have nested `forall`s or contexts in a single place: GHC, in the process of splitting apart a GADT's type, - extracts out the leading `forall`s and context (if they are provided). To - accomplish this splitting, the parser uses the GHC.Hs.Type.splitLHsGadtTy - function, which records the parentheses that surround the leading `forall`s - in con_inner_bndrs (as these parentheses are syntactically significant). + extracts out the leading `forall`s and the adjacent contexts (if they are + provided). To accomplish this splitting, the parser uses the + GHC.Hs.Type.splitLHsGadtTy function, which records the parentheses that + surround the leading `forall`s in con_inner_bndrs (as these parentheses are + syntactically significant), and the contexts in con_cxts. If the body returned by splitLHsGadtTy still contains any `forall`s or contexts, then they must be nested, so they will be rejected. ===================================== compiler/Language/Haskell/Syntax/Type.hs ===================================== @@ -416,7 +416,7 @@ data HsGadtTelescope pass = HsGadtForAll !(XGadtForAll pass) (HsForAllTelescope pass) | HsGadtPar !(XGadtPar pass) -- ^ `HsGadtPar` is only usefull for pretty-printing/exact-printing for recovering - -- parenthisis interleaved with foralls. + -- parentheses interleaved with foralls. -- -- This approach differs from `HsPar`, which wraps the inner expression as if -- surrounding it with parentheses. We can ditch the `HsPar` approach because ===================================== docs/users_guide/exts/gadt_syntax.rst ===================================== @@ -124,7 +124,7 @@ grammar is subject to change in the future. .. code-block:: none - gadt_con ::= conids '::' foralls opt_ctxt gadt_body + gadt_con ::= conids '::' foralls ctxts gadt_body conids ::= conid | conid ',' conids @@ -145,9 +145,9 @@ grammar is subject to change in the future. | '{' tyvar '}' | '{' tyvar '::' ctype '}' - opt_ctxt ::= <empty> - | btype '=>' - | '(' ctxt ')' '=>' + ctxts ::= <empty> + | btype '=>' + | '(' ctxt ')' '=>' ctxt ::= ctype | ctype ',' ctxt @@ -194,15 +194,29 @@ syntactically allowed. Some further various observations about this grammar: - GADT constructor types are currently not permitted to have arbitrarily nested ``forall``\ s or ``=>``\ s. (e.g., something like ``MkT :: Int -> forall a. a -> T`` - would be rejected.) As a result, ``gadt_sig`` puts all of its quantification - and constraints up front with ``foralls`` and ``opt_context``. Note that + would be rejected.) As a result, ``gadt_con`` puts all of its quantification + and constraints up front with ``foralls`` and ``ctxts``. Note that higher-rank ``forall``\ s and ``=>``\ s are only permitted if they do not appear directly to the right of a function arrow in a `prefix_gadt_body`. (e.g., something like ``MkS :: Int -> (forall a. a) -> S`` is allowed, since parentheses separate the ``forall`` from the ``->``.) +- A prefix GADT constructor may be given several consecutive contexts, as + indicated by `ctxts`. Curried contexts are equivalent to a single conjoined + context, so the following constructors have interchangeable types: :: + + data G a where + MkCurried :: C a => D a => E a => G a + MkConjoined :: (C a, D a, E a) => G a + MkMixedL :: (C a, D a) => E a => G a + MkMixedR :: C a => (D a, E a) => G a + + Note that, per the grammar above, the contexts must be consecutive: it is + currently not possible to interleave contexts with foralls or function arrows. + This restriction will be lifted in a future release of GHC. + - GADT constructors permit outermost parentheses that surround the ``foralls`` - or ``opt_ctxt``, as well as interleaved parentheses between multiple + or ``ctxts``, as well as interleaved parentheses between multiple ``foralls``. For example, ``MkU :: (forall a. a -> U)`` is accepted, as is ``MkW :: forall a. (forall b. a -> b -> W)``. ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -432,7 +432,7 @@ https://gitlab.haskell.org/ghc/ghc/-/merge_requests/16644, using data InnerBindings = InnerMore (LHsGadtTelescope GhcPs) InnerBindings - | InnerDone (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs) + | InnerDone ([LHsContext GhcPs], HsConDeclGADTDetails GhcPs, LHsType GhcPs) The key part of the ExactPrint instance for this is @@ -4146,6 +4146,14 @@ instance ExactPrint (HsType GhcPs) where (ann', mt') <- exactBang (ann, mt) str ty' <- markAnnotated ty return (XHsType (HsBangTy ann' (HsSrcBang mt' up str) ty')) + -- mkGadtDecl sometimes leaves HsRecTy intact instead of converting + -- it to RecConGADT, counting on the renamer to reject it later on. + -- Exact printing must cope with it. + exact (XHsType (HsRecTy (o,c) flds)) = do + o' <- markEpToken o + flds' <- markAnnotated flds + c' <- markEpToken c + return (XHsType (HsRecTy (o',c') flds')) exact (HsExplicitListTy (sq,o,c) prom tys) = do sq' <- if (isPromoted prom) then markEpToken sq @@ -4462,7 +4470,7 @@ instance ExactPrint (ConDecl GhcPs) where , con_names = cons , con_outer_bndrs = outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = mcxt, con_g_args = args + , con_cxts = cxts, con_g_args = args , con_modifiers = mods , con_res_ty = res_ty, con_doc = doc }) = do mods' <- mapM markAnnotated mods @@ -4475,15 +4483,15 @@ instance ExactPrint (ConDecl GhcPs) where L _ (HsOuterImplicit _) -> return outer_bndrs _ -> markAnnotated outer_bndrs - let ib = toInnerBindings inner_bndrs (mcxt, args, res_ty) + let ib = toInnerBindings inner_bndrs (cxts, args, res_ty) ib' <- markAnnotated ib - let (inner_bndrs', (mcxt', args', res_ty')) = fromInnerBindings ib' + let (inner_bndrs', (cxts', args', res_ty')) = fromInnerBindings ib' return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol' , con_names = cons' , con_outer_bndrs = outer_bndrs' , con_inner_bndrs = inner_bndrs' - , con_mb_cxt = mcxt', con_g_args = args' + , con_cxts = cxts', con_g_args = args' , con_modifiers = mods' , con_res_ty = res_ty', con_doc = doc }) @@ -4491,14 +4499,14 @@ instance ExactPrint (ConDecl GhcPs) where data InnerBindings = InnerMore (LHsGadtTelescope GhcPs) InnerBindings - | InnerDone (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs) + | InnerDone ([LHsContext GhcPs], HsConDeclGADTDetails GhcPs, LHsType GhcPs) toInnerBindings :: [LHsGadtTelescope GhcPs] - -> (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs) -> InnerBindings + -> ([LHsContext GhcPs], HsConDeclGADTDetails GhcPs, LHsType GhcPs) -> InnerBindings toInnerBindings [] inner = InnerDone inner toInnerBindings (b:bs) inner = InnerMore b (toInnerBindings bs inner) -fromInnerBindings :: InnerBindings -> ([LHsGadtTelescope GhcPs], (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs)) +fromInnerBindings :: InnerBindings -> ([LHsGadtTelescope GhcPs], ([LHsContext GhcPs], HsConDeclGADTDetails GhcPs, LHsType GhcPs)) fromInnerBindings = go [] where go acc (InnerMore b n) = go (b:acc) n @@ -4520,8 +4528,8 @@ instance ExactPrint InnerBindings where xs' <- markAnnotated xs rp' <- markEpToken rp return (InnerMore (L l (HsGadtPar (lp',rp'))) xs') - exact (InnerDone (mcxt, args, res_ty)) = do - mcxt' <- markAnnotated mcxt + exact (InnerDone (cxts, args, res_ty)) = do + cxts' <- mapM markAnnotated cxts args' <- case args of (PrefixConGADT x args0) -> do @@ -4534,7 +4542,7 @@ instance ExactPrint InnerBindings where rarr' <- markEpUniToken rarr return (RecConGADT (oc',cc',rarr') fields') res_ty' <- markAnnotated res_ty - return (InnerDone (mcxt', args', res_ty')) + return (InnerDone (cxts', args', res_ty')) -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs ===================================== @@ -340,7 +340,7 @@ ppCtor { con_names = names , con_outer_bndrs = L _ outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = mcxt + , con_cxts = cxts , con_g_args = args , con_res_ty = res_ty } @@ -352,9 +352,7 @@ ppCtor con_sig_ty = HsSig noExtField outer_bndrs $ mkGadtArgTys inner_bndrs phi_ty where - phi_ty = case mcxt of - Just theta -> mkQualTy theta tau_ty - Nothing -> tau_ty + phi_ty = foldr mkQualTy tau_ty cxts tau_ty = foldr mkFunTy res_ty $ case args of PrefixConGADT _ pos_args -> map cdf_type pos_args ===================================== utils/haddock/haddock-api/src/Haddock/Convert.hs ===================================== @@ -29,7 +29,7 @@ module Haddock.Convert import Control.DeepSeq (force) import Data.Either (lefts, partitionEithers, rights) -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (catMaybes, mapMaybe, maybeToList) import GHC.Builtin.KnownKeys ( boxedRepDataConKey , eqTyConKey @@ -625,7 +625,7 @@ synifyDataCon use_gadt_syntax dc = , con_names = pure name , con_outer_bndrs = noLocA outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = ctx + , con_cxts = maybeToList ctx , con_g_args = hat , con_res_ty = synifyType WithinType emptyVarSet res_ty , con_modifiers = [] ===================================== utils/haddock/haddock-api/src/Haddock/GhcUtils.hs ===================================== @@ -220,7 +220,7 @@ getGADTConType ( ConDeclGADT { con_outer_bndrs = outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = mcxt + , con_cxts = cxts , con_g_args = args , con_res_ty = res_ty } @@ -234,9 +234,7 @@ getGADTConType ) where phi_ty :: LHsType DocNameI - phi_ty = case mcxt of - Nothing -> tau_ty - Just theta -> mkQualTy theta tau_ty + phi_ty = foldr mkQualTy tau_ty cxts tau_ty :: LHsType DocNameI tau_ty = case args of ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -758,7 +758,7 @@ renameCon { con_names = lnames , con_outer_bndrs = outer_bndrs , con_inner_bndrs = inner_bndrs - , con_mb_cxt = lcontext + , con_cxts = lcontexts , con_g_args = details , con_res_ty = res_ty , con_modifiers = mods @@ -767,7 +767,7 @@ renameCon lnames' <- mapM renameNameL lnames outer_bndrs' <- mapM renameOuterTyVarBndrs outer_bndrs inner_bndrs' <- mapM renameHsGadtTelescope inner_bndrs - lcontext' <- traverse renameLContext lcontext + lcontexts' <- traverse renameLContext lcontexts details' <- renameGADTDetails details res_ty' <- renameLType res_ty mods' <- renameModifiers mods @@ -778,7 +778,7 @@ renameCon , con_names = lnames' , con_outer_bndrs = outer_bndrs' , con_inner_bndrs = inner_bndrs' - , con_mb_cxt = lcontext' + , con_cxts = lcontexts' , con_g_args = details' , con_res_ty = res_ty' , con_modifiers = mods' View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb2c9f3555bfd5d3ce16eafecd213289... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb2c9f3555bfd5d3ce16eafecd213289... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help