Andrei Borzenkov pushed to branch wip/sand-witch/27423-gadt-parens at Glasgow Haskell Compiler / GHC Commits: 53de859d by Andrei Borzenkov at 2026-08-11T11:50:00+04:00 Parentheses in prefix GADT constructors (#27423) Updated `splitLHsGadtTy` to allow looking through the parentheses for inner binders. General example of a code pattern that's allowed now: data S a where MkS :: (forall a. S a) That should work now with any combination of nested foralls and parentheses. We don't perform parenthesis unwrapping for record GADT constructors in accordance with GHC Proposal #402. To this end `con_inner_bndrs` no longer stores plain forall telescopes: `[HsForAllTelescope pass]` is replaced with `[LHsGadtArg pass]`, a new `HsArg`-style type whose `HsGadtForAll` holds an inner telescope and whose `HsGadtPar` holds a pair of parentheses. The parentheses carry no meaning for renaming or type checking; the only reason to record them is exact-printing. Updated `pprConDecl` to improve the `parse == parse . ppr . parse` property of GADT pretty-printing. The pretty printer can now output code that's similar to this: data T a where MkT1 :: (forall a. T a) MkT2 :: forall . forall a. T a These are special cases of inner forall binders for prefix GADT constructors, when we have either implicit or zero explicit outer binders. - - - - - 28 changed files: - + changelog.d/allow-gadt-prefix-con-parens - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/TyCl.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Type.hs - − testsuite/tests/gadt/T14320.stderr - testsuite/tests/gadt/T18191.hs - testsuite/tests/gadt/T18191.stderr - + testsuite/tests/gadt/T27423a.hs - + testsuite/tests/gadt/T27423b.hs - + testsuite/tests/gadt/T27423b.stderr - testsuite/tests/gadt/all.T - testsuite/tests/printer/Makefile - + testsuite/tests/printer/T27423c.hs - testsuite/tests/printer/all.T - 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 - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== changelog.d/allow-gadt-prefix-con-parens ===================================== @@ -0,0 +1,15 @@ +section: language +synopsis: Allow parentheses in prefix GADT constructor declarations, as specified + by GHC Proposal #402 "Stable GADT constructor syntax". +issues: #27423 +mrs: !16321 + +description: + Parenthesized types are now accepted in prefix GADT constructor declarations, + even when they contain explicit ``forall`` quantifiers. For example: + + data T where + MkT :: (forall a. a -> b -> T) + + This is equivalent to ``MkT :: forall {b}. (forall a. a -> b -> T)``, so the + forall-or-nothing rule continues to be respected. ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -974,14 +974,33 @@ pprConDecl (ConDeclGADT { con_names = cons , con_mb_cxt = mcxt, 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 [pprHsOuterSigTyVarBndrs outer_bndrs - <+> hsep (map pprHsForAllTelescope inner_bndrs) - <+> pprLHsContext mcxt, - sep (ppr_args args ++ [ppr res_ty]) ]) + <+> (ppr_outer_bndrs <+> ppr_inner_bndrs ( + sep [ pprLHsContext mcxt, + sep (ppr_args args ++ [ppr res_ty])])) where ppr_args (PrefixConGADT _ args) = map (pprHsConDeclFieldWith (\arr tyDoc -> tyDoc <+> pprHsModifiedFunArr arr)) args ppr_args (RecConGADT _ fields) = [pprHsConDeclRecFields (unLoc fields) <+> arrow] + -- pprint all parenthisis and foralls, so parse == parse . ppr . parse + ppr_inner_bndrs :: SDoc -> SDoc + ppr_inner_bndrs tyDoc = foldr ppr_inner_bndr (tyDoc <> close_parens) inner_bndrs + + ppr_inner_bndr (L _ HsGadtPar{}) rest = lparen <> rest + ppr_inner_bndr (L _ (HsGadtForAll _ tele)) rest = pprHsForAllTelescope tele <+> rest + + -- for each open paren generate a closed one + close_parens = hcat [ rparen | L _ HsGadtPar{} <- inner_bndrs ] + + -- pprint empty explicit outer forall as `forall.` if there are inner binders, because otherwise + -- `forall. forall a. ...` would become `forall a. ...` and that would parse into + -- different AST, thus breaking parse == parse . ppr . parse property + ppr_outer_bndrs + | HsOuterExplicit{hso_bndrs = []} <- outer_bndrs + , not (null inner_bndrs) + = forAllLit <> dot + | otherwise + = pprHsOuterSigTyVarBndrs outer_bndrs + ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -623,6 +623,11 @@ deriving instance Data (HsForAllTelescope GhcPs) deriving instance Data (HsForAllTelescope GhcRn) deriving instance Data (HsForAllTelescope GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsGadtArg p) +deriving instance Data (HsGadtArg GhcPs) +deriving instance Data (HsGadtArg GhcRn) +deriving instance Data (HsGadtArg GhcTc) + -- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p) deriving instance (Data flag) => Data (HsTyVarBndr flag GhcPs) deriving instance (Data flag) => Data (HsTyVarBndr flag GhcRn) ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -39,6 +39,7 @@ module GHC.Hs.Type ( HsLit(..), HsIPName(..), hsIPNameFS, HsArg(..), numVisibleArgs, pprHsArgsApp, + HsGadtArg(..), LHsTypeArg, lhsTypeArgSrcSpan, OutputableBndrFlag, @@ -71,6 +72,7 @@ module GHC.Hs.Type ( hsLTyVarName, hsLTyVarNames, hsForAllTelescopeBndrs, hsForAllTelescopeNames, + gadtArgTelescopes, gadtArgBndrs, mkHsGadtForAlls, hsLTyVarLocName, hsExplicitLTyVarNames, splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, splitLHsPatSynTy, @@ -622,6 +624,15 @@ hsForAllTelescopeNames :: HsForAllTelescope (GhcPass p) -> [IdP (GhcPass p)] hsForAllTelescopeNames (HsForAllVis _ bndrs) = hsLTyVarNames bndrs hsForAllTelescopeNames (HsForAllInvis _ bndrs) = hsLTyVarNames bndrs +gadtArgTelescopes :: [LHsGadtArg (GhcPass p)] -> [HsForAllTelescope (GhcPass p)] +gadtArgTelescopes args = [ tele | L _ (HsGadtForAll _ tele) <- args ] + +gadtArgBndrs :: [LHsGadtArg (GhcPass p)] -> [LHsTyVarBndr ForAllTyFlag (GhcPass p)] +gadtArgBndrs = concatMap hsForAllTelescopeBndrs . gadtArgTelescopes + +mkHsGadtForAlls :: [HsForAllTelescope (GhcPass p)] -> [HsGadtArg (GhcPass p)] +mkHsGadtForAlls = map (HsGadtForAll noExtField) + hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] -- Explicit variables only hsExplicitLTyVarNames qtvs = hsLTyVarNames (hsQTvExplicit qtvs) @@ -751,6 +762,14 @@ type instance XArgPar (GhcPass _) = SrcSpan type instance XXArg (GhcPass _) = DataConCantHappen +type instance XGadtForAll (GhcPass _) = NoExtField + +type instance XGadtPar GhcPs = (EpToken "(", EpToken ")") +type instance XGadtPar GhcRn = NoExtField +type instance XGadtPar GhcTc = NoExtField + +type instance XXGadtArg (GhcPass _) = DataConCantHappen + type instance XPrefixCon (GhcPass p) = NoExtField type instance XInfixCon (GhcPass p) = NoExtField type instance XRecCon (GhcPass p) = (EpToken "{", EpToken "}") @@ -878,44 +897,55 @@ splitLHsSigmaTyInvis ty = (tvs, ctxt, ty2) -- | Decompose a GADT type into its constituent parts. --- Returns @(outer_bndrs, mb_ctxt, body)@, where: +-- Returns @(outer_bndrs, inner_bndrs, mb_ctxt, body)@, where: -- -- * @outer_bndrs@ are 'HsOuterExplicit' if the type has explicit, outermost -- type variable binders. Otherwise, they are 'HsOuterImplicit'. -- +-- * @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@. -- -- * @body@ is the body of the type after the optional @forall@s and context. -- --- This function is careful not to look through parentheses. +-- This function does look through parentheses, but it does not discard them: +-- they are syntactically significant, so they are recorded in @inner_bndrs@. -- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@ --- "GHC.Hs.Decls" for why this is important. +-- in "GHC.Hs.Decls" for why this is important. splitLHsGadtTy :: LHsSigType GhcPs - -> (HsOuterSigTyVarBndrs GhcPs, [HsForAllTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs) + -> (HsOuterSigTyVarBndrs GhcPs, [LHsGadtArg GhcPs], Maybe (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 - = case rho_ty of - L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _) | not (null inner_bndrs) + = 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 - -> (outer_bndrs, [], Nothing, sigma_ty) - _ -> (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty) + then (outer_bndrs, [], Nothing, sigma_ty) + else (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty) where split_outer_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) split_outer_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) = (outer_bndrs, body_ty) - split_inner_bndrs :: LHsType GhcPs -> ([HsForAllTelescope GhcPs], LHsType GhcPs) - split_inner_bndrs (L _ HsForAllTy { hst_tele = tele + split_inner_bndrs :: + LHsType GhcPs -> ([LHsGadtArg GhcPs], LHsType GhcPs) + split_inner_bndrs (L l HsForAllTy { hst_tele = tele , hst_body = body }) - = let ~(teles, t) = split_inner_bndrs body - in (tele:teles, t) + = let ~(args, t) = split_inner_bndrs body + in (L l (HsGadtForAll noExtField tele) : args, t) + split_inner_bndrs (L l (HsParTy toks ty)) + = let ~(args, t) = split_inner_bndrs 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 + -- | 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). @@ -1284,6 +1314,11 @@ instance OutputableBndrId p ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) = text "HsForAllInvis:" <+> ppr bndrs +instance OutputableBndrId p + => Outputable (HsGadtArg (GhcPass p)) where + ppr (HsGadtForAll _ tele) = text "HsGadtForAll" <+> ppr tele + ppr (HsGadtPar _) = text "HsGadtPar" + instance (OutputableBndrId p, OutputableBndrFlag flag p) => Outputable (HsTyVarBndr flag (GhcPass p)) where ppr = pprTyVarBndr @@ -1612,3 +1647,5 @@ type instance Anno (HsConDeclRecField (GhcPass p)) = SrcSpanAnnA type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA type instance Anno (HsModifierOf ty (GhcPass p)) = SrcSpanAnnA + +type instance Anno (HsGadtArg (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -920,11 +920,13 @@ repC (L l (ConDeclGADT { con_names = cons = notHandledL (locA l) ThDataConVisibleForall where - no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_bndrs + inner_teles = gadtArgTelescopes inner_bndrs + + no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_teles no_context = isNothing mcxt m_invis_inner_bndrs :: Maybe [[LHsTyVarBndr Specificity GhcRn]] - m_invis_inner_bndrs = traverse get_invis_bndrs inner_bndrs + m_invis_inner_bndrs = traverse get_invis_bndrs inner_teles get_invis_bndrs :: HsForAllTelescope GhcRn -> Maybe [LHsTyVarBndr Specificity GhcRn] get_invis_bndrs HsForAllVis{} = Nothing ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1788,7 +1788,7 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where HsOuterExplicit{} -> [] exp_bndrs = [ L l (updateHsTyVarBndrFlag Invisible b) | L l b <- hsOuterExplicitBndrs outer_bndrs ] - ++ concatMap hsForAllTelescopeBndrs inner_bndrs + ++ concatMap hsForAllTelescopeBndrs (gadtArgTelescopes inner_bndrs) ConDeclH98 { con_name = name, con_ex_tvs = qvars , con_mb_cxt = ctx, con_args = dets , con_doc = doc} -> ===================================== compiler/GHC/Rename/HsType.hs ===================================== @@ -28,8 +28,7 @@ module GHC.Rename.HsType ( checkPrecMatch, checkSectionPrec, -- Binding related stuff - bindHsOuterTyVarBndrs, bindHsForAllTelescope, - bindHsForAllTelescopes, + bindHsOuterTyVarBndrs, bindHsForAllTelescope, bindHsGadtArgs, bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..), rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars, FreeKiTyVars, filterInScopeM, @@ -37,7 +36,7 @@ module GHC.Rename.HsType ( extractHsTysRdrTyVars, extractRdrKindSigVars, extractConDeclGADTDetailsTyVars, extractDataDefnKindVars, extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars, - extractHsForAllTelescopes, + extractHsGadtArgs, nubL, nubN, -- Error helpers @@ -1241,16 +1240,19 @@ bindHsForAllTelescope doc tele thing_inside = checkForAllTelescopeWildcardBndrs doc bndrs' thing_inside $ mkHsForAllInvisTele noAnn bndrs' -bindHsForAllTelescopes :: HsDocContext - -> [HsForAllTelescope GhcPs] - -> ([HsForAllTelescope GhcRn] -> RnM (a, FreeNames)) - -> RnM (a, FreeNames) -bindHsForAllTelescopes _ [] thing_inside = +bindHsGadtArgs :: HsDocContext + -> [LHsGadtArg GhcPs] + -> ([LHsGadtArg GhcRn] -> RnM (a, FreeNames)) + -> RnM (a, FreeNames) +bindHsGadtArgs _ [] thing_inside = thing_inside [] -bindHsForAllTelescopes doc (tele:teles) thing_inside = - bindHsForAllTelescope doc tele $ \tele' -> - bindHsForAllTelescopes doc teles $ \teles' -> - thing_inside (tele':teles') +bindHsGadtArgs doc (L l HsGadtPar{} : args) thing_inside = + bindHsGadtArgs doc args $ \args' -> + thing_inside (L l (HsGadtPar noExtField) : args') +bindHsGadtArgs doc (L l (HsGadtForAll _ tele) : args) thing_inside = + bindHsForAllTelescope doc tele $ \tele' -> + bindHsGadtArgs doc args $ \args' -> + thing_inside (L l (HsGadtForAll noExtField tele') : args') -- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type checkForAllTelescopeWildcardBndrs :: HsDocContext @@ -2277,13 +2279,15 @@ extractHsOuterTvBndrs outer_bndrs body_fvs = HsOuterImplicit{} -> body_fvs HsOuterExplicit{hso_bndrs = bndrs} -> extract_hs_tv_bndrs bndrs [] body_fvs -extractHsForAllTelescopes :: [HsForAllTelescope GhcPs] - -> FreeKiTyVars -- Free in body - -> FreeKiTyVars -- Free in result -extractHsForAllTelescopes [] body_fvs = body_fvs -extractHsForAllTelescopes (tele:teles) body_fvs = +extractHsGadtArgs :: [LHsGadtArg GhcPs] + -> FreeKiTyVars -- Free in body + -> FreeKiTyVars -- Free in result +extractHsGadtArgs [] body_fvs = body_fvs +extractHsGadtArgs (L _ HsGadtPar{} : args) body_fvs = + extractHsGadtArgs args body_fvs +extractHsGadtArgs (L _ (HsGadtForAll _ tele) : args) body_fvs = extract_hs_for_all_telescope tele [] $ - extractHsForAllTelescopes teles body_fvs + extractHsGadtArgs args body_fvs extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars -- Accumulator ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -2641,7 +2641,7 @@ rnConDecl (ConDeclGADT { con_names = names -- See #14808. implicit_bndrs = extractHsOuterTvBndrs outer_bndrs $ - extractHsForAllTelescopes inner_bndrs $ + extractHsGadtArgs inner_bndrs $ extractHsTysRdrTyVars (hsConDeclTheta mcxt) $ extractConDeclGADTDetailsTyVars args $ extractHsTysRdrTyVars [res_ty] [] @@ -2649,7 +2649,7 @@ rnConDecl (ConDeclGADT { con_names = names ; let ctxt = ConDeclCtx (toList new_names) ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' -> - bindHsForAllTelescopes ctxt inner_bndrs $ \inner_bndrs' -> + bindHsGadtArgs ctxt inner_bndrs $ \inner_bndrs' -> do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt ; (new_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -3546,12 +3546,12 @@ tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside --------------- tcGadtConTyVarBndrs :: SkolemInfo -> HsOuterSigTyVarBndrs GhcRn - -> [HsForAllTelescope GhcRn] + -> [LHsGadtArg GhcRn] -> TcM a -> TcM ([TcTyVarBinder], a) tcGadtConTyVarBndrs skol_info outer inner thing_inside = do { (outer_bndrs, (inner_tvbs, a)) <- tcOuterTKBndrs skol_info outer $ - tcExplicitTKBndrs skol_info (concatMap hsForAllTelescopeBndrs inner) $ + tcExplicitTKBndrs skol_info (gadtArgBndrs inner) $ thing_inside ; outer_bndrs <- scopedSortOuter outer_bndrs ; let outer_tvbs = tyVarSpecToBinders (outerTyVarBndrs outer_bndrs) ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -2287,7 +2287,7 @@ kcConDecl new_or_data _tc_res_kind bind_con_tvbs outer_bndrs inner_bndrs thing_inside -- Why "_Tv"? See Note [Using TyVarTvs for kind-checking GADTs] = discardResult $ bindOuterSigTKBndrs_Tv outer_bndrs $ - bindExplicitTKBndrs_Tv (concatMap hsForAllTelescopeBndrs inner_bndrs) $ + bindExplicitTKBndrs_Tv (gadtArgBndrs inner_bndrs) $ thing_inside {- Note [kcConDecls: kind-checking data type decls] ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -961,8 +961,9 @@ data ConDecl pass -- cf. HsSigType that also stores the outermost sig_bndrs separately -- from the forall telescopes in sig_body. -- See Note [Representing type signatures] in Language.Haskell.Syntax.Type - , con_inner_bndrs :: [HsForAllTelescope pass] - -- ^ The forall telescopes other than the outermost invisible forall. + , con_inner_bndrs :: [LHsGadtArg 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_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix , con_res_ty :: LHsType pass -- ^ Result type @@ -1074,22 +1075,21 @@ the GADT type, in precisely that order. For instance: 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 + -- OK, the parentheses are recorded in con_inner_bndrs. + MkT7 :: (Eq a => a -> T) + -- OK, ditto 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. + 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). + If the body returned by splitLHsGadtTy still 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 ===================================== compiler/Language/Haskell/Syntax/Type.hs ===================================== @@ -21,6 +21,7 @@ module Language.Haskell.Syntax.Type ( isHsBndrInvisible, isHsBndrWildCard, HsForAllTelescope(..), + HsGadtArg(..), LHsGadtArg, XGadtForAll, XGadtPar, XXGadtArg, HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, @@ -392,6 +393,41 @@ data HsForAllTelescope pass } | XHsForAllTelescope !(XXHsForAllTelescope pass) +-- A type for interleaved GADT foralls and prefixes, inspired by HsArg +-- +-- `HsGadtPar` is only usefull for pretty-printing/exact-printing for recovering +-- parenthisis interleaved with foralls. +-- +-- Here's an example: +-- +-- data D where +-- MkD :: forall a b. ( forall c. forall d. ( forall. ... +-- ↑ ↑ ↑ ↑ ↑ ↑ +-- 1 2 3 4 5 6 +-- +-- That would correspond to a list +-- +-- 1 → [ HsGadtForAll +-- 2 → , HsGadtPar +-- 3 → , HsGadtForAll +-- 4 → , HsGadtForAll +-- 5 → , HsGadtPar +-- 6 → , HsGadtForAll +-- , ...] +-- +-- We can always recover parenthisis structure because they must close after +-- return type. +data HsGadtArg pass + = HsGadtForAll !(XGadtForAll pass) (HsForAllTelescope pass) + | HsGadtPar !(XGadtPar pass) + | XHsGadtArg !(XXGadtArg pass) + +type LHsGadtArg pass = XRec pass (HsGadtArg pass) + +type family XGadtForAll pass +type family XGadtPar pass +type family XXGadtArg pass + -- | Located Haskell Type Variable Binder type LHsTyVarBndr flag pass = XRec pass (HsTyVarBndr flag pass) -- See Note [HsType binders] ===================================== testsuite/tests/gadt/T14320.stderr deleted ===================================== @@ -1,4 +0,0 @@ - -T14320.hs:17:14: error: [GHC-71492] - GADT constructor type signature cannot contain nested ‘forall’s or contexts - In the definition of data constructor ‘TEBad’ ===================================== testsuite/tests/gadt/T18191.hs ===================================== @@ -2,15 +2,6 @@ {-# LANGUAGE RankNTypes #-} module T18191 where -data T where - MkT :: (forall a. a -> b -> T) - -data S a where - MkS :: (forall a. S a) - -data U a where - MkU :: (Show a => U a) - data Z a where MkZ1 :: forall a. forall b. { unZ1 :: (a, b) } -> Z (a, b) MkZ2 :: Eq a => Eq b => { unZ1 :: (a, b) } -> Z (a, b) ===================================== testsuite/tests/gadt/T18191.stderr ===================================== @@ -1,28 +1,16 @@ - -T18191.hs:6:11: error: [GHC-71492] - • GADT constructor type signature cannot contain nested ‘forall’s or contexts - • In the definition of data constructor ‘MkT’ - -T18191.hs:9:11: error: [GHC-71492] - • GADT constructor type signature cannot contain nested ‘forall’s or contexts - • In the definition of data constructor ‘MkS’ - -T18191.hs:12:11: error: [GHC-71492] - • GADT constructor type signature cannot contain nested ‘forall’s or contexts - • In the definition of data constructor ‘MkU’ - -T18191.hs:15:21: error: [GHC-71492] +T18191.hs:6:21: error: [GHC-71492] • GADT constructor type signature cannot contain nested ‘forall’s or contexts • In the definition of data constructor ‘MkZ1’ -T18191.hs:15:31: error: [GHC-89246] +T18191.hs:6:31: error: [GHC-89246] • Record syntax is illegal here: {unZ1 :: (a, b)} • In the definition of data constructor ‘MkZ1’ -T18191.hs:16:19: error: [GHC-71492] +T18191.hs:7:19: error: [GHC-71492] • GADT constructor type signature cannot contain nested ‘forall’s or contexts • In the definition of data constructor ‘MkZ2’ -T18191.hs:16:27: error: [GHC-89246] +T18191.hs:7:27: error: [GHC-89246] • Record syntax is illegal here: {unZ1 :: (a, b)} • In the definition of data constructor ‘MkZ2’ + ===================================== testsuite/tests/gadt/T27423a.hs ===================================== @@ -0,0 +1,46 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RequiredTypeArguments #-} +module T27423a where + +data G a where + MkG1 :: a -> G a + MkG2 :: (a -> G a) + MkG3 :: forall a. a -> G a + MkG4 :: forall a. (a -> G a) + +-- this is equivalent to `forall {b}. (forall a. a -> b -> T)`. +data T where + MkT2 :: (forall a. a -> b -> T) + +-- this is equivalent to `forall. (forall a. S a)`. +data S a where + MkS :: (forall a. S a) + +-- An explicit, empty outer forall combined with a parenthesised inner one. +data W a where + MkW :: forall. (forall a. W a) + +-- A forall and a context combined inside the same parentheses, with no +-- outer forall at all. +data Y a where + MkY :: (forall a. Show a => a -> Y a) + +-- Multiple, redundant nested parentheses around the whole type should +-- be accepted. +data H a where + MkH :: ((a -> H a)) + +-- An unparenthesised outer forall together with an independent, +-- parenthesised inner forall. +data I a where + MkI :: forall a. (forall b. I (b, a)) + +-- Visible foralls, parenthesised and not. +data V a b where + MkV1 :: forall a -> forall b. (Int -> V a b) + MkV2 :: forall a. (forall b -> (Bool -> V a b)) + +data P a where + MkP1 :: Show a => (a -> P a) + MkP2 :: forall a. Int -> (a -> P a) + MkP3 :: (forall a. Show a => (Int -> (a -> P a))) ===================================== testsuite/tests/gadt/T27423b.hs ===================================== @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs #-} +module T27423b where + +-- Record-style GADT constructors must remain unparenthesisable, per +-- GHC Proposal #402: this is out of scope for #27423 and should +-- continue to be rejected. +data T1 a where + MkT1 :: ({ fld :: a } -> T1 a) + +data T2 a where + MkT2 :: (forall a. { fld :: a } -> T2 a) + +-- Without parentheses, forall-or-nothing applies to the whole type, so +-- `b` is not implicitly quantified and this must be rejected. +data T3 where + MkT3 :: forall a. a -> b -> T3 + +-- That should gone soon, but let's check that we didn't implement it +-- earlier than we need to +data T4 a where + MkT4 :: Show a => (forall b. a -> b -> T4 a) ===================================== testsuite/tests/gadt/T27423b.stderr ===================================== @@ -0,0 +1,19 @@ +T27423b.hs:8:12: error: [GHC-89246] + • Record syntax is illegal here: {fld :: a} + • In the definition of data constructor ‘MkT1’ + +T27423b.hs:11:12: error: [GHC-71492] + • GADT constructor type signature cannot contain nested ‘forall’s or contexts + • In the definition of data constructor ‘MkT2’ + +T27423b.hs:11:22: error: [GHC-89246] + • Record syntax is illegal here: {fld :: a} + • In the definition of data constructor ‘MkT2’ + +T27423b.hs:16:26: error: [GHC-76037] + Not in scope: type variable ‘b’ + +T27423b.hs:21:22: error: [GHC-71492] + • GADT constructor type signature cannot contain nested ‘forall’s or contexts + • In the definition of data constructor ‘MkT4’ + ===================================== testsuite/tests/gadt/all.T ===================================== @@ -114,7 +114,7 @@ test('T7558', normal, compile, ['']) test('T9380', normal, compile_and_run, ['']) test('T12087', normal, compile_fail, ['']) test('T12468', normal, compile_fail, ['']) -test('T14320', normal, compile_fail, ['']) +test('T14320', normal, compile, ['']) test('T14719', normal, compile_fail, ['-fdiagnostics-show-caret']) test('T14808', normal, compile, ['']) test('T15009', normal, compile, ['']) @@ -132,3 +132,6 @@ test('T19847b', normal, compile, ['']) test('T23022', normal, compile, ['-dcore-lint']) test('T23023', normal, compile_fail, ['-O -dcore-lint']) # todo: move this test? test('T23298', normal, compile_fail, ['']) + +test('T27423a', normal, compile, ['']) +test('T27423b', normal, compile_fail, ['']) ===================================== testsuite/tests/printer/Makefile ===================================== @@ -932,3 +932,8 @@ PprModifiers: PprQualifiedStrings: $(CHECK_PPR) $(LIBDIR) PprQualifiedStrings.hs $(CHECK_EXACT) $(LIBDIR) PprQualifiedStrings.hs + +.PHONY: T27423c +T27423c: + $(CHECK_PPR) $(LIBDIR) T27423c.hs + $(CHECK_EXACT) $(LIBDIR) T27423c.hs ===================================== testsuite/tests/printer/T27423c.hs ===================================== @@ -0,0 +1,45 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RequiredTypeArguments #-} +module T27423c where + +-- Exact-printing regression test +-- Not every declaration there would pass renamer without errors +data G a where + MkG1 :: a -> G a + MkG2 :: (a -> G a) + MkG3 :: forall a. a -> G a + MkG4 :: forall a. (a -> G a) + +data T where + MkT1 :: forall a. a -> b -> T + MkT2 :: (forall a. a -> b -> T) + +data S a where + MkS :: (forall a. S a) + MkS2 :: forall. (forall a. S a) + MkS3 :: forall. forall a. S a + +data U a where + MkU :: (Show a => U a) + +data V a where + MkV1 :: ((a -> V a)) + MkV2 :: forall a. (forall b. V (b, a)) + MkV3 :: (forall a. Show a => a -> V a) + MkV4 :: forall a. ((forall b. (Show a => a -> (b -> V a)))) + +data W a b where + MkW1 :: forall a -> forall b. (Int -> W a b) + MkW2 :: forall a. (forall b -> (Bool -> W a b)) + +data P a where + MkP1 :: Show a => (a -> P a) + MkP2 :: forall a. Int -> (a -> P a) + +-- Comments in and around the parentheses +data C a where + MkC1 :: -- comment before the parenthesis + (forall a. C a) + MkC2 :: ( -- comment after the parenthesis + forall a. C a) + MkC3 :: (forall a. {- inline comment -} C a) ===================================== testsuite/tests/printer/all.T ===================================== @@ -223,3 +223,5 @@ test('TestLevelImports', [ignore_stderr, req_ppr_deps], makefile_test, ['TestLev test('TestNamedDefaults', [ignore_stderr, req_ppr_deps], makefile_test, ['TestNamedDefaults']) test('PprModifiers', [ignore_stderr,req_ppr_deps], makefile_test, ['PprModifiers']) test('PprQualifiedStrings', [ignore_stderr,req_ppr_deps], makefile_test, ['PprQualifiedStrings']) + +test('T27423c', [ignore_stderr,req_ppr_deps], makefile_test, ['T27423c']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -374,6 +374,9 @@ cua CanUpdateAnchor f = f cua CanUpdateAnchorOnly _ = return [] cua NoCanUpdateAnchor _ = return [] +enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a +enterAnn = enterAnnWith exact setAnnotationAnchor + -- | "Enter" an annotation, by using the associated 'anchor' field as -- the new reference point for calculating all DeltaPos positions. -- This is the heart of the exact printing process. @@ -381,14 +384,17 @@ cua NoCanUpdateAnchor _ = return [] -- This is combination of the ghc=exactprint Delta.withAST and -- Print.exactPC functions and effectively does the delta processing -- immediately followed by the print processing. JIT ghc-exactprint. -enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a -enterAnn NoEntryVal a = do +enterAnnWith :: (Monad m, Monoid w, Typeable a, Typeable b) => + (a -> EP w m b) -> -- exact + (b -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> b) -> -- setAnnotationAnchor + Entry -> a -> EP w m b +enterAnnWith exactVia _ NoEntryVal a = do p <- getPosP debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a) - r <- exact a + r <- exactVia a debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a) return r -enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do +enterAnnWith exactVia setAnnAnchor !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do acceptSpan <- getAcceptSpan setAcceptSpan False case anchor' of @@ -499,7 +505,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do advance edp debugM $ "enterAnn:exact a starting:" ++ show (showAst anchor') - a' <- exact a + a' <- exactVia a debugM $ "enterAnn:exact a done:" ++ show (showAst anchor') -- Core recursive exactprint done, start end of Entry processing @@ -553,8 +559,8 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do EpaSpan s -> EpaDelta s edp [] _ -> EpaDelta noSrcSpan edp [] let r = case canUpdateAnchor of - CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) - CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments + CanUpdateAnchor -> setAnnAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) + CanUpdateAnchorOnly -> setAnnAnchor a' newAnchor [] emptyComments NoCanUpdateAnchor -> a' return r @@ -4268,21 +4274,22 @@ instance ExactPrint (ConDecl GhcPs) where L _ (HsOuterImplicit _) -> return outer_bndrs _ -> markAnnotated outer_bndrs - inner_bndrs' <- mapM markAnnotated inner_bndrs + (inner_bndrs', (mcxt', args', res_ty')) <- markGadtArgs inner_bndrs $ do + mcxt' <- markAnnotated mcxt + args' <- + case args of + (PrefixConGADT x args0) -> do + args0' <- mapM markAnnotated args0 + return (PrefixConGADT x args0') + (RecConGADT (oc,cc,rarr) fields) -> do + oc' <- markEpToken oc + fields' <- markAnnotated fields + cc' <- markEpToken cc + rarr' <- markEpUniToken rarr + return (RecConGADT (oc',cc',rarr') fields') + res_ty' <- markAnnotated res_ty + return (mcxt', args', res_ty') - mcxt' <- markAnnotated mcxt - args' <- - case args of - (PrefixConGADT x args0) -> do - args0' <- mapM markAnnotated args0 - return (PrefixConGADT x args0') - (RecConGADT (oc,cc,rarr) fields) -> do - oc' <- markEpToken oc - fields' <- markAnnotated fields - cc' <- markEpToken cc - rarr' <- markEpUniToken rarr - return (RecConGADT (oc',cc',rarr') fields') - res_ty' <- markAnnotated res_ty return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol' , con_names = cons' , con_outer_bndrs = outer_bndrs' @@ -4291,6 +4298,44 @@ instance ExactPrint (ConDecl GhcPs) where , con_modifiers = mods' , con_res_ty = res_ty', con_doc = doc }) +-- | Exact print the inner binders of a GADT signature. +-- +-- It's that complicated because we need to mark comments/trailing anns +-- stored inside `L` and mark closing parenthesis _after_ we mark inner +-- type: +-- +-- data T a b where +-- MkT :: +-- forall a. ( -- mark inside `markGadtArgs` +-- forall b. some type -> T a b -- mark everything there +-- ) -- mark inside `markGadtArgs` +-- +-- We don't have the same problem for `HsArgPar` because we ignore it +-- during exact-print, "Does not appear in original source" +markGadtArgs :: (Monad m, Monoid w, Typeable a) + => [LHsGadtArg GhcPs] -> EP w m a + -> EP w m ([LHsGadtArg GhcPs], a) +markGadtArgs args inner_action = go args + where + go [] = do + r <- inner_action + return ([], r) + go (arg:xs) = enterAnnWith (exact_arg xs) setAnchor (entryFromLocatedA arg) arg + + exact_arg xs (L l (HsGadtForAll _ tele)) = do + tele' <- markAnnotated tele + (xs', r) <- go xs + return (L l (HsGadtForAll noExtField tele') : xs', r) + exact_arg xs (L l (HsGadtPar (lp, rp))) = do + lp' <- markEpToken lp + (xs', r) <- go xs + rp' <- markEpToken rp + return (L l (HsGadtPar (lp',rp')) : xs', r) + + -- The binder just entered is the head of the returned list + setAnchor (arg':xs', r) anc ts cs = (setAnchorAn arg' anc ts cs : xs', r) + setAnchor ([], r) _ _ _ = ([], r) + -- --------------------------------------------------------------------- instance ExactPrint Void where ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs ===================================== @@ -350,7 +350,7 @@ ppCtor typeSig = operator name ++ " :: " ++ outHsSigType sDocContext con_sig_ty name = out sDocContext $ unL <$> names con_sig_ty = HsSig noExtField outer_bndrs $ - mkForallTys inner_bndrs phi_ty + mkGadtArgTys inner_bndrs phi_ty where phi_ty = case mcxt of Just theta -> mkQualTy theta tau_ty @@ -367,13 +367,14 @@ ppCtor noLocA (HsQualTy{ hst_xqual = noExtField , hst_ctxt = ctxt, hst_body = body}) - mkForallTy :: HsForAllTelescope GhcRn -> LHsType GhcRn -> LHsType GhcRn - mkForallTy tele body = - noLocA (HsForAllTy { hst_xforall = noExtField + mkGadtArgTy :: LHsGadtArg GhcRn -> LHsType GhcRn -> LHsType GhcRn + mkGadtArgTy (L l (HsGadtForAll _ tele)) body = + L l (HsForAllTy { hst_xforall = noExtField , hst_tele = tele, hst_body = body }) + mkGadtArgTy (L l HsGadtPar{}) body = L l (HsParTy noAnn body) - mkForallTys :: [HsForAllTelescope GhcRn] -> LHsType GhcRn -> LHsType GhcRn - mkForallTys = flip (foldr mkForallTy) + mkGadtArgTys :: [LHsGadtArg GhcRn] -> LHsType GhcRn -> LHsType GhcRn + mkGadtArgTys = flip (foldr mkGadtArgTy) ppFixity :: SDocContext -> (Name, Fixity) -> [String] ppFixity sDocContext (name, fixity) = [out sDocContext ((FixitySig noExtField (NoNamespaceSpecifier noExtField) [noLocA name] fixity) :: FixitySig GhcRn)] ===================================== utils/haddock/haddock-api/src/Haddock/Convert.hs ===================================== @@ -567,7 +567,7 @@ synifyDataCon use_gadt_syntax dc = , hso_bndrs = map synifyTyVarBndr outer_tvbs } - inner_bndrs = mk_telescopes inner_tvbs + inner_bndrs = map noLocA $ mkHsGadtForAlls (mk_telescopes inner_tvbs) mk_telescopes bs | (invis, other) <- split_invis_tvbs bs, not (null invis) ===================================== utils/haddock/haddock-api/src/Haddock/GhcUtils.hs ===================================== @@ -229,7 +229,7 @@ getGADTConType ( HsSig { sig_ext = noExtField , sig_bndrs = unLoc outer_bndrs - , sig_body = mkForallTys inner_bndrs phi_ty + , sig_body = mkGadtArgTys inner_bndrs phi_ty } ) where @@ -251,13 +251,14 @@ getGADTConType noLocA (HsQualTy{ hst_xqual = noAnn , hst_ctxt = ctxt, hst_body = body}) - mkForallTy :: HsForAllTelescope DocNameI -> LHsType DocNameI -> LHsType DocNameI - mkForallTy tele body = - noLocA (HsForAllTy { hst_xforall = noAnn + mkGadtArgTy :: LHsGadtArg DocNameI -> LHsType DocNameI -> LHsType DocNameI + mkGadtArgTy (L l (HsGadtForAll _ tele)) body = + L l (HsForAllTy { hst_xforall = noAnn , hst_tele = tele, hst_body = body }) + mkGadtArgTy (L l HsGadtPar{}) body = L l (HsParTy noAnn body) - mkForallTys :: [HsForAllTelescope DocNameI] -> LHsType DocNameI -> LHsType DocNameI - mkForallTys = flip (foldr mkForallTy) + mkGadtArgTys :: [LHsGadtArg DocNameI] -> LHsType DocNameI -> LHsType DocNameI + mkGadtArgTys = flip (foldr mkGadtArgTy) getGADTConType (ConDeclH98{}) = panic "getGADTConType" ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -476,6 +476,11 @@ renameHsBndrVis :: HsBndrVis GhcRn -> RnM (HsBndrVis DocNameI) renameHsBndrVis (HsBndrRequired _) = return (HsBndrRequired noExtField) renameHsBndrVis (HsBndrInvisible at) = return (HsBndrInvisible at) +renameHsGadtArg :: LHsGadtArg GhcRn -> RnM (LHsGadtArg DocNameI) +renameHsGadtArg (L l HsGadtPar{}) = pure $ L l $ HsGadtPar noExtField +renameHsGadtArg (L l (HsGadtForAll _ tele)) = + L l . HsGadtForAll noExtField <$> renameHsForAllTelescope tele + renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI) renameHsForAllTelescope tele = case tele of HsForAllVis _ bndrs -> do @@ -761,7 +766,7 @@ renameCon } = do lnames' <- mapM renameNameL lnames outer_bndrs' <- mapM renameOuterTyVarBndrs outer_bndrs - inner_bndrs' <- mapM renameHsForAllTelescope inner_bndrs + inner_bndrs' <- mapM renameHsGadtArg inner_bndrs lcontext' <- traverse renameLContext lcontext details' <- renameGADTDetails details res_ty' <- renameLType res_ty ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -841,6 +841,7 @@ type instance Anno (CType DocNameI) = SrcSpanAnnA type instance Anno (Header DocNameI) = SrcSpanAnnA type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA +type instance Anno (HsGadtArg DocNameI) = SrcSpanAnnA type XRecCond a = ( XParTy a ~ (EpToken "(", EpToken ")") @@ -905,6 +906,10 @@ type instance XHsForAllVis DocNameI = NoExtField type instance XHsForAllInvis DocNameI = NoExtField type instance XXHsForAllTelescope DocNameI = DataConCantHappen +type instance XGadtForAll DocNameI = NoExtField +type instance XGadtPar DocNameI = NoExtField +type instance XXGadtArg DocNameI = DataConCantHappen + type instance XTyVarBndr DocNameI = NoExtField type instance XXTyVarBndr DocNameI = DataConCantHappen View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53de859d9f307c2326e0068e18abb97e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53de859d9f307c2326e0068e18abb97e... 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