Andrei Borzenkov pushed to branch wip/sand-witch/27423-gadt-parens at Glasgow Haskell Compiler / GHC

Commits:

29 changed files:

Changes:

  • changelog.d/allow-gadt-prefix-con-parens
    1 
    +section: language
    2 
    +synopsis: Allow parentheses in prefix GADT constructor declarations, as specified
    3 
    +  by GHC Proposal #402 "Stable GADT constructor syntax".
    4 
    +issues: #27423
    5 
    +mrs: !16321
    6 
    +
    7 
    +description:
    8 
    +  Parenthesized types are now accepted in prefix GADT constructor declarations,
    9 
    +  even when they contain explicit ``forall`` quantifiers. For example:
    10 
    +
    11 
    +    data T where
    12 
    +      MkT :: (forall a. a -> b -> T)
    13 
    +
    14 
    +  This is equivalent to ``MkT :: forall {b}. (forall a. a -> b -> T)``, so the
    15 
    +  forall-or-nothing rule continues to be respected.

  • compiler/GHC/Hs/Decls.hs
    ... ... @@ -974,14 +974,37 @@ pprConDecl (ConDeclGADT { con_names = cons
    974 974 
                             , con_mb_cxt = mcxt, con_g_args = args
    975 975 
                             , con_res_ty = res_ty, con_modifiers = mods, con_doc = doc })
    976 976 
       = pprMaybeWithDoc doc $ pprLHsModifiers mods <+> ppr_con_names (toList cons) <+> dcolon
    977 
    -    <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs
    978 
    -                <+> hsep (map pprHsForAllTelescope inner_bndrs)
    979 
    -                <+> pprLHsContext mcxt,
    980 
    -              sep (ppr_args args ++ [ppr res_ty]) ])
    977 
    +    <+> sep [ppr_outer_bndrs, ppr_inner_bndrs (
    978 
    +                sep [ pprLHsContext mcxt,
    979 
    +                      sep (ppr_args args ++ [ppr res_ty])])]
    981 980 
       where
    982 981 
         ppr_args (PrefixConGADT _ args) = map (pprHsConDeclFieldWith (\arr tyDoc -> tyDoc <+> pprHsModifiedFunArr arr)) args
    983 982 
         ppr_args (RecConGADT _ fields) = [pprHsConDeclRecFields (unLoc fields) <+> arrow]
    984 983
    984 
    +    -- pprint all parentheses and foralls, so parse == parse . ppr . parse
    985 
    +    ppr_inner_bndrs :: SDoc -> SDoc
    986 
    +    ppr_inner_bndrs tyDoc = foldr ppr_inner_bndr (tyDoc <> close_parens) inner_bndrs
    987 
    +
    988 
    +    ppr_inner_bndr (L _ HsGadtPar{})           rest = lparen <> rest
    989 
    +    ppr_inner_bndr (L _ (HsGadtForAll _ tele)) rest
    990 
    +      | HsForAllInvis {hsf_invis_bndrs=[]} <- tele = empty_forall <+> rest
    991 
    +      | otherwise = pprHsForAllTelescope tele <+> rest
    992 
    +
    993 
    +    -- for each open paren generate a closed one
    994 
    +    close_parens = hcat [ rparen | L _ HsGadtPar{} <- inner_bndrs ]
    995 
    +
    996 
    +    -- pprint empty explicit outer forall as `forall.` if there are inner binders, because otherwise
    997 
    +    -- `forall. forall a. ...` would become `forall a. ...` and that would parse into
    998 
    +    -- different AST, thus breaking parse == parse . ppr . parse property
    999 
    +    ppr_outer_bndrs
    1000 
    +      | HsOuterExplicit{hso_bndrs = []} <- outer_bndrs
    1001 
    +      , not (null inner_bndrs)
    1002 
    +      = empty_forall
    1003 
    +      | otherwise
    1004 
    +      = pprHsOuterSigTyVarBndrs outer_bndrs
    1005 
    +
    1006 
    +    empty_forall = forAllLit <> dot
    1007 
    +
    985 1008 
     ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc
    986 1009 
     ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
    987 1010

  • compiler/GHC/Hs/Instances.hs
    ... ... @@ -623,6 +623,11 @@ deriving instance Data (HsForAllTelescope GhcPs)
    623 623 
     deriving instance Data (HsForAllTelescope GhcRn)
    624 624 
     deriving instance Data (HsForAllTelescope GhcTc)
    625 625
    626 
    +-- deriving instance (DataIdLR p p) => Data (HsGadtTelescope p)
    627 
    +deriving instance Data (HsGadtTelescope GhcPs)
    628 
    +deriving instance Data (HsGadtTelescope GhcRn)
    629 
    +deriving instance Data (HsGadtTelescope GhcTc)
    630 
    +
    626 631 
     -- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p)
    627 632 
     deriving instance (Data flag) => Data (HsTyVarBndr flag GhcPs)
    628 633 
     deriving instance (Data flag) => Data (HsTyVarBndr flag GhcRn)

  • compiler/GHC/Hs/Type.hs
    ... ... @@ -39,6 +39,7 @@ module GHC.Hs.Type (
    39 39 
             HsLit(..),
    40 40 
             HsIPName(..), hsIPNameFS,
    41 41 
             HsArg(..), numVisibleArgs, pprHsArgsApp,
    42 
    +        HsGadtTelescope(..),
    42 43 
             LHsTypeArg, lhsTypeArgSrcSpan,
    43 44 
             OutputableBndrFlag,
    44 45
    ... ... @@ -71,6 +72,7 @@ module GHC.Hs.Type (
    71 72 
             hsLTyVarName, hsLTyVarNames,
    72 73 
             hsForAllTelescopeBndrs,
    73 74 
             hsForAllTelescopeNames,
    75 
    +        gadtArgTelescopes, gadtArgBndrs, mkHsGadtForAlls,
    74 76 
             hsLTyVarLocName, hsExplicitLTyVarNames,
    75 77 
             splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
    76 78 
             splitLHsPatSynTy,
    ... ... @@ -621,6 +623,15 @@ hsForAllTelescopeNames :: HsForAllTelescope (GhcPass p) -> [IdP (GhcPass p)]
    621 623 
     hsForAllTelescopeNames (HsForAllVis _ bndrs) = hsLTyVarNames bndrs
    622 624 
     hsForAllTelescopeNames (HsForAllInvis _ bndrs) = hsLTyVarNames bndrs
    623 625
    626 
    +gadtArgTelescopes :: [LHsGadtTelescope (GhcPass p)] -> [HsForAllTelescope (GhcPass p)]
    627 
    +gadtArgTelescopes args = [ tele | L _ (HsGadtForAll _ tele) <- args ]
    628 
    +
    629 
    +gadtArgBndrs :: [LHsGadtTelescope (GhcPass p)] -> [LHsTyVarBndr ForAllTyFlag (GhcPass p)]
    630 
    +gadtArgBndrs = concatMap hsForAllTelescopeBndrs . gadtArgTelescopes
    631 
    +
    632 
    +mkHsGadtForAlls :: [HsForAllTelescope (GhcPass p)] -> [HsGadtTelescope (GhcPass p)]
    633 
    +mkHsGadtForAlls = map (HsGadtForAll noExtField)
    634 
    +
    624 635 
     hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)]
    625 636 
     -- Explicit variables only
    626 637 
     hsExplicitLTyVarNames qtvs = hsLTyVarNames (hsQTvExplicit qtvs)
    ... ... @@ -750,6 +761,14 @@ type instance XArgPar (GhcPass _) = SrcSpan
    750 761
    751 762 
     type instance XXArg (GhcPass _) = DataConCantHappen
    752 763
    764 
    +type instance XGadtForAll (GhcPass _) = NoExtField
    765 
    +
    766 
    +type instance XGadtPar GhcPs = (EpToken "(", EpToken ")")
    767 
    +type instance XGadtPar GhcRn = NoExtField
    768 
    +type instance XGadtPar GhcTc = NoExtField
    769 
    +
    770 
    +type instance XXGadtArg (GhcPass _) = DataConCantHappen
    771 
    +
    753 772 
     type instance XPrefixCon      (GhcPass p) = NoExtField
    754 773 
     type instance XInfixCon       (GhcPass p) = NoExtField
    755 774 
     type instance XRecCon         (GhcPass p) = (EpToken "{", EpToken "}")
    ... ... @@ -877,44 +896,55 @@ splitLHsSigmaTyInvis ty
    877 896 
       = (tvs, ctxt, ty2)
    878 897
    879 898 
     -- | Decompose a GADT type into its constituent parts.
    880 
    --- Returns @(outer_bndrs, mb_ctxt, body)@, where:
    899 
    +-- Returns @(outer_bndrs, inner_bndrs, mb_ctxt, body)@, where:
    881 900 
     --
    882 901 
     -- * @outer_bndrs@ are 'HsOuterExplicit' if the type has explicit, outermost
    883 902 
     --   type variable binders. Otherwise, they are 'HsOuterImplicit'.
    884 903 
     --
    904 
    +-- * @inner_bndrs@ are the remaining @forall@ telescopes, interleaved with the
    905 
    +--   parentheses that enclose them.
    906 
    +--
    885 907 
     -- * @mb_ctxt@ is @Just@ the context, if it is provided.
    886 908 
     --   Otherwise, it is @Nothing@.
    887 909 
     --
    888 910 
     -- * @body@ is the body of the type after the optional @forall@s and context.
    889 911 
     --
    890 
    --- This function is careful not to look through parentheses.
    912 
    +-- This function does look through parentheses, but it does not discard them:
    913 
    +-- they are syntactically significant, so they are recorded in @inner_bndrs@.
    891 914 
     -- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@
    892 
    --- "GHC.Hs.Decls" for why this is important.
    915 
    +-- in "GHC.Hs.Decls" for why this is important.
    893 916 
     splitLHsGadtTy ::
    894 917 
          LHsSigType GhcPs
    895 
    -  -> (HsOuterSigTyVarBndrs GhcPs, [HsForAllTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs)
    918 
    +  -> (HsOuterSigTyVarBndrs GhcPs, [LHsGadtTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs)
    896 919 
     splitLHsGadtTy (L _ sig_ty)
    897 920 
       | (outer_bndrs, sigma_ty) <- split_outer_bndrs sig_ty
    898 921 
       , (inner_bndrs, phi_ty)   <- split_inner_bndrs sigma_ty
    899 922 
       , (mb_ctxt, rho_ty)       <- splitLHsQualTy_KP phi_ty
    900 
    -  = case rho_ty of
    901 
    -      L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _) | not (null inner_bndrs)
    923 
    +  = if is_gadt_rec_ty rho_ty && not (null inner_bndrs)
    902 924 
             -- Bad! Record GADTs are not allowed to have inner_bndrs,
    903 925 
             -- undo the split to get a proper error message later
    904 
    -        -> (outer_bndrs, [], Nothing, sigma_ty)
    905 
    -      _ -> (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty)
    926 
    +      then (outer_bndrs, [], Nothing, sigma_ty)
    927 
    +      else (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty)
    906 928 
       where
    907 929 
         split_outer_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)
    908 930 
         split_outer_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) =
    909 931 
           (outer_bndrs, body_ty)
    910 932
    911 
    -    split_inner_bndrs :: LHsType GhcPs -> ([HsForAllTelescope GhcPs], LHsType GhcPs)
    912 
    -    split_inner_bndrs (L _ HsForAllTy { hst_tele = tele
    933 
    +    split_inner_bndrs ::
    934 
    +      LHsType GhcPs -> ([LHsGadtTelescope GhcPs], LHsType GhcPs)
    935 
    +    split_inner_bndrs (L l HsForAllTy { hst_tele = tele
    913 936 
                                           , hst_body = body })
    914 
    -      = let ~(teles, t) = split_inner_bndrs body
    915 
    -        in (tele:teles, t)
    937 
    +      = let ~(args, t) = split_inner_bndrs body
    938 
    +        in (L l (HsGadtForAll noExtField tele) : args, t)
    939 
    +    split_inner_bndrs (L l (HsParTy toks ty))
    940 
    +      = let ~(args, t) = split_inner_bndrs ty
    941 
    +        in (L l (HsGadtPar toks) : args, t)
    916 942 
         split_inner_bndrs t = ([], t)
    917 943
    944 
    +    -- type of form {fld :: ty, ...} -> ResTy
    945 
    +    is_gadt_rec_ty (L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _)) = True
    946 
    +    is_gadt_rec_ty _ = False
    947 
    +
    918 948 
     -- | Decompose a type of the form @forall <tvs>. body@ into its constituent
    919 949 
     -- parts. Only splits type variable binders that
    920 950 
     -- were quantified invisibly (e.g., @forall a.@, with a dot).
    ... ... @@ -1283,6 +1313,11 @@ instance OutputableBndrId p
    1283 1313 
         ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) =
    1284 1314 
           text "HsForAllInvis:" <+> ppr bndrs
    1285 1315
    1316 
    +instance OutputableBndrId p
    1317 
    +       => Outputable (HsGadtTelescope (GhcPass p)) where
    1318 
    +    ppr (HsGadtForAll _ tele) = text "HsGadtForAll" <+> ppr tele
    1319 
    +    ppr (HsGadtPar _)         = text "HsGadtPar"
    1320 
    +
    1286 1321 
     instance (OutputableBndrId p, OutputableBndrFlag flag p)
    1287 1322 
            => Outputable (HsTyVarBndr flag (GhcPass p)) where
    1288 1323 
         ppr = pprTyVarBndr
    ... ... @@ -1611,3 +1646,5 @@ type instance Anno (HsConDeclRecField (GhcPass p)) = SrcSpanAnnA
    1611 1646
    1612 1647 
     type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA
    1613 1648 
     type instance Anno (HsModifierOf ty (GhcPass p)) = SrcSpanAnnA
    1649 
    +
    1650 
    +type instance Anno (HsGadtTelescope (GhcPass p)) = SrcSpanAnnA

  • compiler/GHC/HsToCore/Quote.hs
    ... ... @@ -924,11 +924,13 @@ repC (L l (ConDeclGADT { con_names = cons
    924 924 
       = notHandledL (locA l) ThDataConVisibleForall
    925 925
    926 926 
       where
    927 
    -    no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_bndrs
    927 
    +    inner_teles = gadtArgTelescopes inner_bndrs
    928 
    +
    929 
    +    no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_teles
    928 930 
         no_context         = isNothing mcxt
    929 931
    930 932 
         m_invis_inner_bndrs :: Maybe [[LHsTyVarBndr Specificity GhcRn]]
    931 
    -    m_invis_inner_bndrs = traverse get_invis_bndrs inner_bndrs
    933 
    +    m_invis_inner_bndrs = traverse get_invis_bndrs inner_teles
    932 934
    933 935 
         get_invis_bndrs :: HsForAllTelescope GhcRn -> Maybe [LHsTyVarBndr Specificity GhcRn]
    934 936 
         get_invis_bndrs HsForAllVis{} = Nothing

  • compiler/GHC/Iface/Ext/Ast.hs
    ... ... @@ -1789,7 +1789,7 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where
    1789 1789 
                 HsOuterExplicit{} -> []
    1790 1790 
               exp_bndrs =
    1791 1791 
                 [ L l (updateHsTyVarBndrFlag Invisible b) | L l b <- hsOuterExplicitBndrs outer_bndrs ]
    1792 
    -            ++ concatMap hsForAllTelescopeBndrs inner_bndrs
    1792 
    +            ++ concatMap hsForAllTelescopeBndrs (gadtArgTelescopes inner_bndrs)
    1793 1793 
           ConDeclH98 { con_name = name, con_ex_tvs = qvars
    1794 1794 
                      , con_mb_cxt = ctx, con_args = dets
    1795 1795 
                      , con_doc = doc} ->

  • compiler/GHC/Rename/HsType.hs
    ... ... @@ -28,8 +28,7 @@ module GHC.Rename.HsType (
    28 28 
             checkPrecMatch, checkSectionPrec,
    29 29
    30 30 
             -- Binding related stuff
    31 
    -        bindHsOuterTyVarBndrs, bindHsForAllTelescope,
    32 
    -        bindHsForAllTelescopes,
    31 
    +        bindHsOuterTyVarBndrs, bindHsForAllTelescope, bindHsGadtTelescopes,
    33 32 
             bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),
    34 33 
             rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars,
    35 34 
             FreeKiTyVars, filterInScopeM,
    ... ... @@ -37,7 +36,7 @@ module GHC.Rename.HsType (
    37 36 
             extractHsTysRdrTyVars, extractRdrKindSigVars,
    38 37 
             extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,
    39 38 
             extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars,
    40 
    -        extractHsForAllTelescopes,
    39 
    +        extractHsGadtTelescopes,
    41 40 
             nubL, nubN,
    42 41
    43 42 
             -- Error helpers
    ... ... @@ -1249,16 +1248,19 @@ bindHsForAllTelescope doc tele thing_inside =
    1249 1248 
             checkForAllTelescopeWildcardBndrs doc bndrs'
    1250 1249 
             thing_inside $ mkHsForAllInvisTele noAnn bndrs'
    1251 1250
    1252 
    -bindHsForAllTelescopes :: HsDocContext
    1253 
    -                       -> [HsForAllTelescope GhcPs]
    1254 
    -                       -> ([HsForAllTelescope GhcRn] -> RnM (a, FreeNames))
    1255 
    -                       -> RnM (a, FreeNames)
    1256 
    -bindHsForAllTelescopes _ [] thing_inside =
    1251 
    +bindHsGadtTelescopes :: HsDocContext
    1252 
    +               -> [LHsGadtTelescope GhcPs]
    1253 
    +               -> ([LHsGadtTelescope GhcRn] -> RnM (a, FreeNames))
    1254 
    +               -> RnM (a, FreeNames)
    1255 
    +bindHsGadtTelescopes _ [] thing_inside =
    1257 1256 
       thing_inside []
    1258 
    -bindHsForAllTelescopes doc (tele:teles) thing_inside =
    1259 
    -  bindHsForAllTelescope  doc tele  $ \tele'  ->
    1260 
    -  bindHsForAllTelescopes doc teles $ \teles' ->
    1261 
    -    thing_inside (tele':teles')
    1257 
    +bindHsGadtTelescopes doc (L l HsGadtPar{} : args) thing_inside =
    1258 
    +  bindHsGadtTelescopes doc args $ \args' ->
    1259 
    +    thing_inside (L l (HsGadtPar noExtField) : args')
    1260 
    +bindHsGadtTelescopes doc (L l (HsGadtForAll _ tele) : args) thing_inside =
    1261 
    +  bindHsForAllTelescope doc tele $ \tele' ->
    1262 
    +  bindHsGadtTelescopes        doc args $ \args' ->
    1263 
    +    thing_inside (L l (HsGadtForAll noExtField tele') : args')
    1262 1264
    1263 1265 
     -- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type
    1264 1266 
     checkForAllTelescopeWildcardBndrs :: HsDocContext
    ... ... @@ -2286,13 +2288,15 @@ extractHsOuterTvBndrs outer_bndrs body_fvs =
    2286 2288 
         HsOuterImplicit{}                  -> body_fvs
    2287 2289 
         HsOuterExplicit{hso_bndrs = bndrs} -> extract_hs_tv_bndrs bndrs [] body_fvs
    2288 2290
    2289 
    -extractHsForAllTelescopes :: [HsForAllTelescope GhcPs]
    2290 
    -                          -> FreeKiTyVars -- Free in body
    2291 
    -                          -> FreeKiTyVars -- Free in result
    2292 
    -extractHsForAllTelescopes []           body_fvs = body_fvs
    2293 
    -extractHsForAllTelescopes (tele:teles) body_fvs =
    2291 
    +extractHsGadtTelescopes :: [LHsGadtTelescope GhcPs]
    2292 
    +                  -> FreeKiTyVars -- Free in body
    2293 
    +                  -> FreeKiTyVars -- Free in result
    2294 
    +extractHsGadtTelescopes []                           body_fvs = body_fvs
    2295 
    +extractHsGadtTelescopes (L _ HsGadtPar{} : args)         body_fvs =
    2296 
    +  extractHsGadtTelescopes args body_fvs
    2297 
    +extractHsGadtTelescopes (L _ (HsGadtForAll _ tele) : args) body_fvs =
    2294 2298 
       extract_hs_for_all_telescope tele [] $
    2295 
    -  extractHsForAllTelescopes teles body_fvs
    2299 
    +  extractHsGadtTelescopes args body_fvs
    2296 2300
    2297 2301 
     extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs]
    2298 2302 
                         -> FreeKiTyVars  -- Accumulator

  • compiler/GHC/Rename/Module.hs
    ... ... @@ -2644,7 +2644,7 @@ rnConDecl (ConDeclGADT { con_names = names
    2644 2644 
                   -- See #14808.
    2645 2645 
                   implicit_bndrs =
    2646 2646 
                     extractHsOuterTvBndrs outer_bndrs           $
    2647 
    -                extractHsForAllTelescopes inner_bndrs       $
    2647 
    +                extractHsGadtTelescopes inner_bndrs               $
    2648 2648 
                     extractHsTysRdrTyVars (hsConDeclTheta mcxt) $
    2649 2649 
                     extractConDeclGADTDetailsTyVars args        $
    2650 2650 
                     extractHsTysRdrTyVars [res_ty] []
    ... ... @@ -2652,7 +2652,7 @@ rnConDecl (ConDeclGADT { con_names = names
    2652 2652 
             ; let ctxt = ConDeclCtx (toList new_names)
    2653 2653
    2654 2654 
             ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' ->
    2655 
    -          bindHsForAllTelescopes ctxt inner_bndrs $ \inner_bndrs' ->
    2655 
    +          bindHsGadtTelescopes ctxt inner_bndrs $ \inner_bndrs' ->
    2656 2656 
         do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt
    2657 2657 
             ; (new_args, fvs2)   <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args
    2658 2658 
             ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty

  • compiler/GHC/Tc/Gen/HsType.hs
    ... ... @@ -3549,12 +3549,12 @@ tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside
    3549 3549 
     ---------------
    3550 3550 
     tcGadtConTyVarBndrs :: SkolemInfo
    3551 3551 
                         -> HsOuterSigTyVarBndrs GhcRn
    3552 
    -                    -> [HsForAllTelescope GhcRn]
    3552 
    +                    -> [LHsGadtTelescope GhcRn]
    3553 3553 
                         -> TcM a -> TcM ([TcTyVarBinder], a)
    3554 3554 
     tcGadtConTyVarBndrs skol_info outer inner thing_inside
    3555 3555 
       = do { (outer_bndrs, (inner_tvbs, a)) <-
    3556 3556 
                 tcOuterTKBndrs skol_info outer $
    3557 
    -            tcExplicitTKBndrs skol_info (concatMap hsForAllTelescopeBndrs inner) $
    3557 
    +            tcExplicitTKBndrs skol_info (gadtArgBndrs inner) $
    3558 3558 
                 thing_inside
    3559 3559 
            ; outer_bndrs <- scopedSortOuter outer_bndrs
    3560 3560 
            ; let outer_tvbs = tyVarSpecToBinders (outerTyVarBndrs outer_bndrs)

  • compiler/GHC/Tc/TyCl.hs
    ... ... @@ -2287,7 +2287,7 @@ kcConDecl new_or_data _tc_res_kind
    2287 2287 
         bind_con_tvbs outer_bndrs inner_bndrs thing_inside
    2288 2288 
           -- Why "_Tv"? See Note [Using TyVarTvs for kind-checking GADTs]
    2289 2289 
           = discardResult $ bindOuterSigTKBndrs_Tv outer_bndrs $
    2290 
    -                        bindExplicitTKBndrs_Tv (concatMap hsForAllTelescopeBndrs inner_bndrs) $
    2290 
    +                        bindExplicitTKBndrs_Tv (gadtArgBndrs inner_bndrs) $
    2291 2291 
                             thing_inside
    2292 2292
    2293 2293 
     {- Note [kcConDecls: kind-checking data type decls]

  • compiler/Language/Haskell/Syntax/Decls.hs
    ... ... @@ -961,8 +961,9 @@ data ConDecl pass
    961 961 
             --   cf. HsSigType that also stores the outermost sig_bndrs separately
    962 962 
             --   from the forall telescopes in sig_body.
    963 963 
             --   See Note [Representing type signatures] in Language.Haskell.Syntax.Type
    964 
    -      , con_inner_bndrs :: [HsForAllTelescope pass]
    965 
    -        -- ^ The forall telescopes other than the outermost invisible forall.
    964 
    +      , con_inner_bndrs :: [LHsGadtTelescope pass]
    965 
    +        -- ^ The forall telescopes other than the outermost invisible forall,
    966 
    +        --   interleaved with the parentheses that enclose them.
    966 967 
           , con_mb_cxt  :: Maybe (LHsContext pass)   -- ^ User-written context (if any)
    967 968 
           , con_g_args  :: HsConDeclGADTDetails pass -- ^ Arguments; never infix
    968 969 
           , con_res_ty  :: LHsType pass              -- ^ Result type
    ... ... @@ -1074,22 +1075,21 @@ the GADT type, in precisely that order. For instance:
    1074 1075 
         MkT5 :: forall a. Int -> Eq a => a -> T
    1075 1076 
           -- Rejected, `Eq a` is nested
    1076 1077 
         MkT6 :: (forall a. a -> T)
    1077 
    -      -- Rejected, `forall a` is nested due to the surrounding parentheses
    1078 
    -    MkT7 :: (Eq a => a -> t)
    1079 
    -      -- Rejected, `Eq a` is nested due to the surrounding parentheses
    1078 
    +      -- OK, the parentheses are recorded in con_inner_bndrs.
    1079 
    +    MkT7 :: (Eq a => a -> T)
    1080 
    +      -- OK, ditto
    1080 1081
    1081 1082 
     For the full details, see the "Formal syntax for GADTs" section of the GHC
    1082 1083 
     User's Guide. GHC enforces that GADT constructors do not have nested `forall`s
    1083 
    -or contexts in two parts:
    1084 
    +or contexts in a single place:
    1084 1085
    1085 
    -1. GHC, in the process of splitting apart a GADT's type,
    1086 
    -   extracts out the leading `forall` and context (if they are provided). To
    1087 
    -   accomplish this splitting, the renamer uses the
    1088 
    -   GHC.Hs.Type.splitLHsGADTPrefixTy function, which is careful not to remove
    1089 
    -   parentheses surrounding the leading `forall` or context (as these
    1090 
    -   parentheses can be syntactically significant). If the third result returned
    1091 
    -   by splitLHsGADTPrefixTy contains any `forall`s or contexts, then they must
    1092 
    -   be nested, so they will be rejected.
    1086 
    +   GHC, in the process of splitting apart a GADT's type,
    1087 
    +   extracts out the leading `forall`s and context (if they are provided). To
    1088 
    +   accomplish this splitting, the parser uses the GHC.Hs.Type.splitLHsGadtTy
    1089 
    +   function, which records the parentheses that surround the leading `forall`s
    1090 
    +   in con_inner_bndrs (as these parentheses are syntactically significant).
    1091 
    +   If the body returned by splitLHsGadtTy still contains any `forall`s or
    1092 
    +   contexts, then they must be nested, so they will be rejected.
    1093 1093
    1094 1094 
        Note that this step applies to both prefix and record GADTs alike, as they
    1095 1095 
        both have syntax which permits `forall`s and contexts. The difference is
    ... ... @@ -1098,11 +1098,6 @@ or contexts in two parts:
    1098 1098 
        * For prefix GADTs, this happens in the renamer (in rnConDecl), as we cannot
    1099 1099 
          split until after the type operator fixities have been resolved.
    1100 1100 
        * For record GADTs, this happens in the parser (in mkGadtDecl).
    1101 
    -2. If the GADT type is prefix, the renamer (in the ConDeclGADTPrefixPs case of
    1102 
    -   rnConDecl) will then check for nested `forall`s/contexts in the body of a
    1103 
    -   prefix GADT type, after it has determined what all of the argument types are.
    1104 
    -   This step is necessary to catch examples like MkT4 above, where the nested
    1105 
    -   quantification occurs after a visible argument type.
    1106 1101 
     -}
    1107 1102
    1108 1103 
     -- | The arguments in a Haskell98-style data constructor.

  • compiler/Language/Haskell/Syntax/Type.hs
    ... ... @@ -21,6 +21,7 @@ module Language.Haskell.Syntax.Type (
    21 21 
             isHsBndrInvisible,
    22 22 
             isHsBndrWildCard,
    23 23 
             HsForAllTelescope(..),
    24 
    +        HsGadtTelescope(..), LHsGadtTelescope, XGadtForAll, XGadtPar, XXGadtArg,
    24 25 
             HsTyVarBndr(..), LHsTyVarBndr,
    25 26 
             LHsQTyVars(..),
    26 27 
             HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,
    ... ... @@ -392,6 +393,42 @@ data HsForAllTelescope pass
    392 393 
         }
    393 394 
       | XHsForAllTelescope !(XXHsForAllTelescope pass)
    394 395
    396 
    +-- | A type for interleaved GADT foralls and parentheses, inspired by HsArg.
    397 
    +--
    398 
    +-- Here's an example:
    399 
    +--
    400 
    +--  data D where
    401 
    +--    MkD :: forall x y. -- these go to the `con_outer_bndrs` field
    402 
    +--             forall a b. ( forall c. forall d. ( forall. ...
    403 
    +--             ↑           ↑ ↑         ↑         ↑ ↑
    404 
    +--             1           2 3         4         5 6
    405 
    +--
    406 
    +-- That would correspond to a list
    407 
    +--
    408 
    +--   1 → [ HsGadtForAll
    409 
    +--   2 → , HsGadtPar
    410 
    +--   3 → , HsGadtForAll
    411 
    +--   4 → , HsGadtForAll
    412 
    +--   5 → , HsGadtPar
    413 
    +--   6 → , HsGadtForAll
    414 
    +--       , ...]
    415 
    +data HsGadtTelescope pass
    416 
    +  = HsGadtForAll !(XGadtForAll pass) (HsForAllTelescope pass)
    417 
    +  | HsGadtPar !(XGadtPar pass)
    418 
    +    -- ^ `HsGadtPar` is only usefull for pretty-printing/exact-printing for recovering
    419 
    +    -- parenthisis interleaved with foralls.
    420 
    +    --
    421 
    +    -- This approach differs from `HsPar`, which wraps the inner expression as if
    422 
    +    -- surrounding it with parentheses. We can ditch the `HsPar` approach because
    423 
    +    -- we know that all parentheses will be closed after the return type.
    424 
    +  | XHsGadtTelescope !(XXGadtArg pass)
    425 
    +
    426 
    +type LHsGadtTelescope pass = XRec pass (HsGadtTelescope pass)
    427 
    +
    428 
    +type family XGadtForAll pass
    429 
    +type family XGadtPar    pass
    430 
    +type family XXGadtArg   pass
    431 
    +
    395 432 
     -- | Located Haskell Type Variable Binder
    396 433 
     type LHsTyVarBndr flag pass = XRec pass (HsTyVarBndr flag pass)
    397 434 
                              -- See Note [HsType binders]

  • docs/users_guide/exts/gadt_syntax.rst
    ... ... @@ -201,12 +201,12 @@ syntactically allowed. Some further various observations about this grammar:
    201 201 
       something like ``MkS :: Int -> (forall a. a) -> S`` is allowed, since
    202 202 
       parentheses separate the ``forall`` from the ``->``.)
    203 203
    204 
    -- Furthermore, GADT constructors do not permit outermost parentheses that
    205 
    -  surround the ``foralls`` or ``opt_ctxt``, if at least one of them are
    206 
    -  used. For example, ``MkU :: (forall a. a -> U)`` would be rejected, since
    207 
    -  it would treat the ``forall`` as being nested.
    204 
    +- GADT constructors permit outermost parentheses that surround the ``foralls``
    205 
    +  or ``opt_ctxt``, as well as interleaved parentheses between multiple
    206 
    +  ``foralls``. For example, ``MkU :: (forall a. a -> U)`` is accepted, as is
    207 
    +  ``MkW :: forall a. (forall b. a -> b -> W)``.
    208 208
    209 
    -  Note that it is acceptable to use parentheses in a ``prefix_gadt_body``.
    209 
    +  Note that it is also acceptable to use parentheses in a ``prefix_gadt_body``.
    210 210 
       For instance, ``MkV1 :: forall a. (a) -> (V1)`` is acceptable, as is
    211 211 
       ``MkV2 :: forall a. (a -> V2)``.
    212 212

  • testsuite/tests/gadt/T14320.stderr deleted
    1 
    -
    2 
    -T14320.hs:17:14: error: [GHC-71492]
    3 
    -    GADT constructor type signature cannot contain nested ‘forall’s or contexts
    4 
    -    In the definition of data constructor ‘TEBad’

  • testsuite/tests/gadt/T18191.hs
    ... ... @@ -2,15 +2,6 @@
    2 2 
     {-# LANGUAGE RankNTypes #-}
    3 3 
     module T18191 where
    4 4
    5 
    -data T where
    6 
    -  MkT :: (forall a. a -> b -> T)
    7 
    -
    8 
    -data S a where
    9 
    -  MkS :: (forall a. S a)
    10 
    -
    11 
    -data U a where
    12 
    -  MkU :: (Show a => U a)
    13 
    -
    14 5 
     data Z a where
    15 6 
       MkZ1 :: forall a. forall b. { unZ1 :: (a, b) } -> Z (a, b)
    16 7 
       MkZ2 :: Eq a => Eq b => { unZ1 :: (a, b) } -> Z (a, b)

  • testsuite/tests/gadt/T18191.stderr
    1 
    -
    2 
    -T18191.hs:6:11: error: [GHC-71492]
    3 
    -    • GADT constructor type signature cannot contain nested ‘forall’s or contexts
    4 
    -    • In the definition of data constructor ‘MkT’
    5 
    -
    6 
    -T18191.hs:9:11: error: [GHC-71492]
    7 
    -    • GADT constructor type signature cannot contain nested ‘forall’s or contexts
    8 
    -    • In the definition of data constructor ‘MkS’
    9 
    -
    10 
    -T18191.hs:12:11: error: [GHC-71492]
    11 
    -    • GADT constructor type signature cannot contain nested ‘forall’s or contexts
    12 
    -    • In the definition of data constructor ‘MkU’
    13 
    -
    14 
    -T18191.hs:15:21: error: [GHC-71492]
    1 
    +T18191.hs:6:21: error: [GHC-71492]
    15 2 
         • GADT constructor type signature cannot contain nested ‘forall’s or contexts
    16 3 
         • In the definition of data constructor ‘MkZ1’
    17 4
    18 
    -T18191.hs:15:31: error: [GHC-89246]
    5 
    +T18191.hs:6:31: error: [GHC-89246]
    19 6 
         • Record syntax is illegal here: {unZ1 :: (a, b)}
    20 7 
         • In the definition of data constructor ‘MkZ1’
    21 8
    22 
    -T18191.hs:16:19: error: [GHC-71492]
    9 
    +T18191.hs:7:19: error: [GHC-71492]
    23 10 
         • GADT constructor type signature cannot contain nested ‘forall’s or contexts
    24 11 
         • In the definition of data constructor ‘MkZ2’
    25 12
    26 
    -T18191.hs:16:27: error: [GHC-89246]
    13 
    +T18191.hs:7:27: error: [GHC-89246]
    27 14 
         • Record syntax is illegal here: {unZ1 :: (a, b)}
    28 15 
         • In the definition of data constructor ‘MkZ2’
    16 
    +

  • testsuite/tests/gadt/T27423a.hs
    1 
    +{-# LANGUAGE GADTs #-}
    2 
    +{-# LANGUAGE RequiredTypeArguments #-}
    3 
    +module T27423a where
    4 
    +
    5 
    +data G a where
    6 
    +  MkG1 :: a -> G a
    7 
    +  MkG2 :: (a -> G a)
    8 
    +  MkG3 :: forall a. a -> G a
    9 
    +  MkG4 :: forall a. (a -> G a)
    10 
    +
    11 
    +-- this is equivalent to `forall {b}. (forall a. a -> b -> T)`.
    12 
    +data T where
    13 
    +  MkT2 :: (forall a. a -> b -> T)
    14 
    +
    15 
    +-- this is equivalent to `forall. (forall a. S a)`.
    16 
    +data S a where
    17 
    +  MkS :: (forall a. S a)
    18 
    +
    19 
    +-- An explicit, empty outer forall combined with a parenthesised inner one.
    20 
    +data W a where
    21 
    +  MkW :: forall. (forall a. W a)
    22 
    +
    23 
    +-- A forall and a context combined inside the same parentheses, with no
    24 
    +-- outer forall at all.
    25 
    +data Y a where
    26 
    +  MkY :: (forall a. Show a => a -> Y a)
    27 
    +
    28 
    +-- Multiple, redundant nested parentheses around the whole type should
    29 
    +-- be accepted.
    30 
    +data H a where
    31 
    +  MkH :: ((a -> H a))
    32 
    +
    33 
    +-- An unparenthesised outer forall together with an independent,
    34 
    +-- parenthesised inner forall.
    35 
    +data I a where
    36 
    +  MkI :: forall a. (forall b. I (b, a))
    37 
    +
    38 
    +-- Visible foralls, parenthesised and not.
    39 
    +data V a b where
    40 
    +  MkV1 :: forall a -> forall b. (Int -> V a b)
    41 
    +  MkV2 :: forall a. (forall b -> (Bool -> V a b))
    42 
    +
    43 
    +data P a where
    44 
    +  MkP1 :: Show a => (a -> P a)
    45 
    +  MkP2 :: forall a. Int -> (a -> P a)
    46 
    +  MkP3 :: (forall a. Show a => (Int -> (a -> P a)))

  • testsuite/tests/gadt/T27423b.hs
    1 
    +{-# LANGUAGE GADTs #-}
    2 
    +module T27423b where
    3 
    +
    4 
    +-- Record-style GADT constructors must remain unparenthesisable, per
    5 
    +-- GHC Proposal #402: this is out of scope for #27423 and should
    6 
    +-- continue to be rejected.
    7 
    +data T1 a where
    8 
    +  MkT1 :: ({ fld :: a } -> T1 a)
    9 
    +
    10 
    +data T2 a where
    11 
    +  MkT2 :: (forall a. { fld :: a } -> T2 a)
    12 
    +
    13 
    +-- Without parentheses, forall-or-nothing applies to the whole type, so
    14 
    +-- `b` is not implicitly quantified and this must be rejected.
    15 
    +data T3 where
    16 
    +  MkT3 :: forall a. a -> b -> T3
    17 
    +
    18 
    +-- That should gone soon, but let's check that we didn't implement it
    19 
    +-- earlier than we need to
    20 
    +data T4 a where
    21 
    +  MkT4 :: Show a => (forall b. a -> b -> T4 a)

  • testsuite/tests/gadt/T27423b.stderr
    1 
    +T27423b.hs:8:12: error: [GHC-89246]
    2 
    +    • Record syntax is illegal here: {fld :: a}
    3 
    +    • In the definition of data constructor ‘MkT1’
    4 
    +
    5 
    +T27423b.hs:11:12: error: [GHC-71492]
    6 
    +    • GADT constructor type signature cannot contain nested ‘forall’s or contexts
    7 
    +    • In the definition of data constructor ‘MkT2’
    8 
    +
    9 
    +T27423b.hs:11:22: error: [GHC-89246]
    10 
    +    • Record syntax is illegal here: {fld :: a}
    11 
    +    • In the definition of data constructor ‘MkT2’
    12 
    +
    13 
    +T27423b.hs:16:26: error: [GHC-76037]
    14 
    +    Not in scope: type variable ‘b’
    15 
    +
    16 
    +T27423b.hs:21:22: error: [GHC-71492]
    17 
    +    • GADT constructor type signature cannot contain nested ‘forall’s or contexts
    18 
    +    • In the definition of data constructor ‘MkT4’
    19 
    +

  • testsuite/tests/gadt/all.T
    ... ... @@ -114,7 +114,7 @@ test('T7558', normal, compile, [''])
    114 114 
     test('T9380', normal, compile_and_run, [''])
    115 115 
     test('T12087', normal, compile_fail, [''])
    116 116 
     test('T12468', normal, compile_fail, [''])
    117 
    -test('T14320', normal, compile_fail, [''])
    117 
    +test('T14320', normal, compile, [''])
    118 118 
     test('T14719', normal, compile_fail, ['-fdiagnostics-show-caret'])
    119 119 
     test('T14808', normal, compile, [''])
    120 120 
     test('T15009', normal, compile, [''])
    ... ... @@ -132,3 +132,6 @@ test('T19847b', normal, compile, [''])
    132 132 
     test('T23022', normal, compile, ['-dcore-lint'])
    133 133 
     test('T23023', normal, compile_fail, ['-O -dcore-lint']) # todo: move this test?
    134 134 
     test('T23298', normal, compile_fail, [''])
    135 
    +
    136 
    +test('T27423a', normal, compile, [''])
    137 
    +test('T27423b', normal, compile_fail, [''])

  • testsuite/tests/printer/Makefile
    ... ... @@ -937,3 +937,8 @@ PprQualifiedStrings:
    937 937 
     Haddock1:
    938 938 
     	# $(CHECK_PPR)   $(LIBDIR) Haddock1.hs
    939 939 
     	$(CHECK_EXACT) $(LIBDIR) Haddock1.hs
    940 
    +
    941 
    +.PHONY: T27423c
    942 
    +T27423c:
    943 
    +	$(CHECK_PPR)   $(LIBDIR) T27423c.hs
    944 
    +	$(CHECK_EXACT) $(LIBDIR) T27423c.hs

  • testsuite/tests/printer/T27423c.hs
    1 
    +{-# LANGUAGE GADTs #-}
    2 
    +{-# LANGUAGE RequiredTypeArguments #-}
    3 
    +module T27423c where
    4 
    +
    5 
    +-- Exact-printing regression test
    6 
    +-- Not every declaration there would pass renamer without errors
    7 
    +data G a where
    8 
    +  MkG1 :: a -> G a
    9 
    +  MkG2 :: (a -> G a)
    10 
    +  MkG3 :: forall a. a -> G a
    11 
    +  MkG4 :: forall a. (a -> G a)
    12 
    +
    13 
    +data T where
    14 
    +  MkT1 :: forall a. a -> b -> T
    15 
    +  MkT2 :: (forall a. a -> b -> T)
    16 
    +
    17 
    +data S a where
    18 
    +  MkS :: (forall a. S a)
    19 
    +  MkS2 :: forall. (forall a. S a)
    20 
    +  MkS3 :: forall. forall a. S a
    21 
    +  MkS4 :: forall a. forall. forall b. forall. forall. forall c. S a
    22 
    +
    23 
    +data U a where
    24 
    +  MkU :: (Show a => U a)
    25 
    +
    26 
    +data V a where
    27 
    +  MkV1 :: ((a -> V a))
    28 
    +  MkV2 :: forall a. (forall b. V (b, a))
    29 
    +  MkV3 :: (forall a. Show a => a -> V a)
    30 
    +  MkV4 :: forall a. ((forall b. (Show a => a -> (b -> V a))))
    31 
    +
    32 
    +data W a b where
    33 
    +  MkW1 :: forall a -> forall b. (Int -> W a b)
    34 
    +  MkW2 :: forall a. (forall b -> (Bool -> W a b))
    35 
    +
    36 
    +data P a where
    37 
    +  MkP1 :: Show a => (a -> P a)
    38 
    +  MkP2 :: forall a. Int -> (a -> P a)
    39 
    +
    40 
    +-- Comments in and around the parentheses
    41 
    +data C a where
    42 
    +  MkC1 :: -- comment before the parenthesis
    43 
    +          (forall a. C a)
    44 
    +  MkC2 :: ( -- comment after the parenthesis
    45 
    +           forall a. C a)
    46 
    +  MkC3 :: (forall a. {- inline comment -} C a)

  • testsuite/tests/printer/all.T
    ... ... @@ -224,3 +224,4 @@ test('TestNamedDefaults', [ignore_stderr, req_ppr_deps], makefile_test, ['TestNa
    224 224 
     test('PprModifiers', [ignore_stderr,req_ppr_deps], makefile_test, ['PprModifiers'])
    225 225 
     test('PprQualifiedStrings', [ignore_stderr,req_ppr_deps], makefile_test, ['PprQualifiedStrings'])
    226 226 
     test('Haddock1', [ignore_stderr,req_ppr_deps], makefile_test, ['Haddock1'])
    227 
    +test('T27423c', [ignore_stderr,req_ppr_deps], makefile_test, ['T27423c'])

  • utils/check-exact/ExactPrint.hs
    ... ... @@ -370,6 +370,10 @@ cua CanUpdateAnchor f = f
    370 370 
     cua CanUpdateAnchorOnly _ = return []
    371 371 
     cua NoCanUpdateAnchor _ = return []
    372 372
    373 
    +enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a
    374 
    +enterAnn = enterAnnWith exact setAnnotationAnchor
    375 
    +
    376 
    +{-# INLINE enterAnnWith #-}
    373 377 
     -- | "Enter" an annotation, by using the associated 'anchor' field as
    374 378 
     -- the new reference point for calculating all DeltaPos positions.
    375 379 
     -- This is the heart of the exact printing process.
    ... ... @@ -377,14 +381,17 @@ cua NoCanUpdateAnchor _ = return []
    377 381 
     -- This is combination of the ghc=exactprint Delta.withAST and
    378 382 
     -- Print.exactPC functions and effectively does the delta processing
    379 383 
     -- immediately followed by the print processing.  JIT ghc-exactprint.
    380 
    -enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a
    381 
    -enterAnn NoEntryVal a = do
    384 
    +enterAnnWith :: (Monad m, Monoid w, Typeable a, Typeable b) =>
    385 
    +  (a -> EP w m b) -> -- exact
    386 
    +  (b -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> b) -> -- setAnnotationAnchor
    387 
    +  Entry -> a -> EP w m b
    388 
    +enterAnnWith exactVia _ NoEntryVal a = do
    382 389 
       p <- getPosP
    383 390 
       debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a)
    384 
    -  r <- exact a
    391 
    +  r <- exactVia a
    385 392 
       debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a)
    386 393 
       return r
    387 
    -enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
    394 
    +enterAnnWith exactVia setAnnAnchor !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
    388 395 
       acceptSpan <- getAcceptSpan
    389 396 
       setAcceptSpan False
    390 397 
       case anchor' of
    ... ... @@ -495,7 +502,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
    495 502
    496 503 
       advance edp
    497 504 
       debugM $ "enterAnn:exact a starting:" ++ show (showAst anchor')
    498 
    -  a' <- exact a
    505 
    +  a' <- exactVia a
    499 506 
       debugM $ "enterAnn:exact a done:" ++ show (showAst anchor')
    500 507
    501 508 
       -- Core recursive exactprint done, start end of Entry processing
    ... ... @@ -549,8 +556,8 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
    549 556 
               EpaSpan s -> EpaDelta s         edp []
    550 557 
               _         -> EpaDelta noSrcSpan edp []
    551 558 
       let r = case canUpdateAnchor of
    552 
    -            CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs)
    553 
    -            CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments
    559 
    +            CanUpdateAnchor -> setAnnAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs)
    560 
    +            CanUpdateAnchorOnly -> setAnnAnchor a' newAnchor [] emptyComments
    554 561 
                 NoCanUpdateAnchor -> a'
    555 562 
       return r
    556 563
    ... ... @@ -4262,21 +4269,22 @@ instance ExactPrint (ConDecl GhcPs) where
    4262 4269 
           L _ (HsOuterImplicit _) -> return outer_bndrs
    4263 4270 
           _ -> markAnnotated outer_bndrs
    4264 4271
    4265 
    -    inner_bndrs' <- mapM markAnnotated inner_bndrs
    4272 
    +    (inner_bndrs', (mcxt', args', res_ty')) <- markGadtArgs inner_bndrs $ do
    4273 
    +      mcxt' <- markAnnotated mcxt
    4274 
    +      args' <-
    4275 
    +        case args of
    4276 
    +            (PrefixConGADT x args0) -> do
    4277 
    +              args0' <- mapM markAnnotated args0
    4278 
    +              return (PrefixConGADT x args0')
    4279 
    +            (RecConGADT (oc,cc,rarr) fields) -> do
    4280 
    +              oc' <- markEpToken oc
    4281 
    +              fields' <- markAnnotated fields
    4282 
    +              cc' <- markEpToken cc
    4283 
    +              rarr' <- markEpUniToken rarr
    4284 
    +              return (RecConGADT (oc',cc',rarr') fields')
    4285 
    +      res_ty' <- markAnnotated res_ty
    4286 
    +      return (mcxt', args', res_ty')
    4266 4287
    4267 
    -    mcxt' <- markAnnotated mcxt
    4268 
    -    args' <-
    4269 
    -      case args of
    4270 
    -          (PrefixConGADT x args0) -> do
    4271 
    -            args0' <- mapM markAnnotated args0
    4272 
    -            return (PrefixConGADT x args0')
    4273 
    -          (RecConGADT (oc,cc,rarr) fields) -> do
    4274 
    -            oc' <- markEpToken oc
    4275 
    -            fields' <- markAnnotated fields
    4276 
    -            cc' <- markEpToken cc
    4277 
    -            rarr' <- markEpUniToken rarr
    4278 
    -            return (RecConGADT (oc',cc',rarr') fields')
    4279 
    -    res_ty' <- markAnnotated res_ty
    4280 4288 
         return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol'
    4281 4289 
                             , con_names = cons'
    4282 4290 
                             , con_outer_bndrs = outer_bndrs'
    ... ... @@ -4285,6 +4293,44 @@ instance ExactPrint (ConDecl GhcPs) where
    4285 4293 
                             , con_modifiers = mods'
    4286 4294 
                             , con_res_ty = res_ty', con_doc = doc })
    4287 4295
    4296 
    +-- | Exact print the inner binders of a GADT signature.
    4297 
    +--
    4298 
    +-- It's that complicated because we need to mark comments/trailing anns
    4299 
    +-- stored inside `L` and mark closing parenthesis _after_ we mark inner
    4300 
    +-- type:
    4301 
    +--
    4302 
    +--   data T a b where
    4303 
    +--    MkT ::
    4304 
    +--      forall a. ( -- mark inside `markGadtArgs`
    4305 
    +--          forall b. some type -> T a b -- mark everything there
    4306 
    +--        ) -- mark inside `markGadtArgs`
    4307 
    +--
    4308 
    +-- We don't have the same problem for `HsArgPar` because we ignore it
    4309 
    +-- during exact-print, "Does not appear in original source"
    4310 
    +markGadtArgs :: (Monad m, Monoid w, Typeable a)
    4311 
    +             => [LHsGadtTelescope GhcPs] -> EP w m a
    4312 
    +             -> EP w m ([LHsGadtTelescope GhcPs], a)
    4313 
    +markGadtArgs args inner_action = go args
    4314 
    +  where
    4315 
    +    go [] = do
    4316 
    +      r <- inner_action
    4317 
    +      return ([], r)
    4318 
    +    go (arg:xs) = enterAnnWith (exact_arg xs) setAnchor (entryFromLocatedA arg) arg
    4319 
    +
    4320 
    +    exact_arg xs (L l (HsGadtForAll _ tele)) = do
    4321 
    +      tele' <- markAnnotated tele
    4322 
    +      (xs', r) <- go xs
    4323 
    +      return (L l (HsGadtForAll noExtField tele') : xs', r)
    4324 
    +    exact_arg xs (L l (HsGadtPar (lp, rp))) = do
    4325 
    +      lp' <- markEpToken lp
    4326 
    +      (xs', r) <- go xs
    4327 
    +      rp' <- markEpToken rp
    4328 
    +      return (L l (HsGadtPar (lp',rp')) : xs', r)
    4329 
    +
    4330 
    +    -- The binder just entered is the head of the returned list
    4331 
    +    setAnchor (arg':xs', r) anc ts cs = (setAnchorAn arg' anc ts cs : xs', r)
    4332 
    +    setAnchor ([], r)       _   _  _  = ([], r)
    4333 
    +
    4288 4334 
     -- ---------------------------------------------------------------------
    4289 4335
    4290 4336 
     instance ExactPrint Void where

  • utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
    ... ... @@ -350,7 +350,7 @@ ppCtor
    350 350 
           typeSig = operator name ++ " :: " ++ outHsSigType sDocContext con_sig_ty
    351 351 
           name = out sDocContext $ unL <$> names
    352 352 
           con_sig_ty = HsSig noExtField outer_bndrs $
    353 
    -                   mkForallTys inner_bndrs phi_ty
    353 
    +                   mkGadtArgTys inner_bndrs phi_ty
    354 354 
             where
    355 355 
               phi_ty = case mcxt of
    356 356 
                 Just theta -> mkQualTy theta tau_ty
    ... ... @@ -367,13 +367,14 @@ ppCtor
    367 367 
                 noLocA (HsQualTy{ hst_xqual = noExtField
    368 368 
                                 , hst_ctxt = ctxt, hst_body = body})
    369 369
    370 
    -          mkForallTy :: HsForAllTelescope GhcRn -> LHsType GhcRn -> LHsType GhcRn
    371 
    -          mkForallTy tele body =
    372 
    -            noLocA (HsForAllTy { hst_xforall = noExtField
    370 
    +          mkGadtArgTy :: LHsGadtTelescope GhcRn -> LHsType GhcRn -> LHsType GhcRn
    371 
    +          mkGadtArgTy (L l (HsGadtForAll _ tele)) body =
    372 
    +            L l (HsForAllTy { hst_xforall = noExtField
    373 373 
                                    , hst_tele = tele, hst_body = body })
    374 
    +          mkGadtArgTy (L l HsGadtPar{}) body = L l (HsParTy noAnn body)
    374 375
    375 
    -          mkForallTys :: [HsForAllTelescope GhcRn] -> LHsType GhcRn -> LHsType GhcRn
    376 
    -          mkForallTys = flip (foldr mkForallTy)
    376 
    +          mkGadtArgTys :: [LHsGadtTelescope GhcRn] -> LHsType GhcRn -> LHsType GhcRn
    377 
    +          mkGadtArgTys = flip (foldr mkGadtArgTy)
    377 378
    378 379 
     ppFixity :: SDocContext -> (Name, Fixity) -> [String]
    379 380 
     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 =
    567 567 
                 , hso_bndrs = map synifyTyVarBndr outer_tvbs
    568 568 
                 }
    569 569
    570 
    -    inner_bndrs = mk_telescopes inner_tvbs
    570 
    +    inner_bndrs = map noLocA $ mkHsGadtForAlls (mk_telescopes inner_tvbs)
    571 571
    572 572 
         mk_telescopes bs
    573 573 
           | (invis, other) <- split_invis_tvbs bs, not (null invis)

  • utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
    ... ... @@ -229,7 +229,7 @@ getGADTConType
    229 229 
           ( HsSig
    230 230 
               { sig_ext = noExtField
    231 231 
               , sig_bndrs = unLoc outer_bndrs
    232 
    -          , sig_body = mkForallTys inner_bndrs phi_ty
    232 
    +          , sig_body = mkGadtArgTys inner_bndrs phi_ty
    233 233 
               }
    234 234 
           )
    235 235 
         where
    ... ... @@ -251,13 +251,14 @@ getGADTConType
    251 251 
             noLocA (HsQualTy{ hst_xqual = noAnn
    252 252 
                             , hst_ctxt = ctxt, hst_body = body})
    253 253
    254 
    -      mkForallTy :: HsForAllTelescope DocNameI -> LHsType DocNameI -> LHsType DocNameI
    255 
    -      mkForallTy tele body =
    256 
    -        noLocA (HsForAllTy { hst_xforall = noAnn
    254 
    +      mkGadtArgTy :: LHsGadtTelescope DocNameI -> LHsType DocNameI -> LHsType DocNameI
    255 
    +      mkGadtArgTy (L l (HsGadtForAll _ tele)) body =
    256 
    +        L l (HsForAllTy { hst_xforall = noAnn
    257 257 
                                , hst_tele = tele, hst_body = body })
    258 
    +      mkGadtArgTy (L l HsGadtPar{}) body = L l (HsParTy noAnn body)
    258 259
    259 
    -      mkForallTys :: [HsForAllTelescope DocNameI] -> LHsType DocNameI -> LHsType DocNameI
    260 
    -      mkForallTys = flip (foldr mkForallTy)
    260 
    +      mkGadtArgTys :: [LHsGadtTelescope DocNameI] -> LHsType DocNameI -> LHsType DocNameI
    261 
    +      mkGadtArgTys = flip (foldr mkGadtArgTy)
    261 262
    262 263 
     getGADTConType (ConDeclH98{}) = panic "getGADTConType"
    263 264

  • utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
    ... ... @@ -476,6 +476,11 @@ renameHsBndrVis :: HsBndrVis GhcRn -> RnM (HsBndrVis DocNameI)
    476 476 
     renameHsBndrVis (HsBndrRequired _) = return (HsBndrRequired noExtField)
    477 477 
     renameHsBndrVis (HsBndrInvisible at) = return (HsBndrInvisible at)
    478 478
    479 
    +renameHsGadtTelescope :: LHsGadtTelescope GhcRn -> RnM (LHsGadtTelescope DocNameI)
    480 
    +renameHsGadtTelescope (L l HsGadtPar{}) = pure $ L l $ HsGadtPar noExtField
    481 
    +renameHsGadtTelescope (L l (HsGadtForAll _ tele)) =
    482 
    +  L l . HsGadtForAll noExtField <$> renameHsForAllTelescope tele
    483 
    +
    479 484 
     renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI)
    480 485 
     renameHsForAllTelescope tele = case tele of
    481 486 
       HsForAllVis _ bndrs -> do
    ... ... @@ -761,7 +766,7 @@ renameCon
    761 766 
         } = do
    762 767 
         lnames' <- mapM renameNameL lnames
    763 768 
         outer_bndrs' <- mapM renameOuterTyVarBndrs outer_bndrs
    764 
    -    inner_bndrs' <- mapM renameHsForAllTelescope inner_bndrs
    769 
    +    inner_bndrs' <- mapM renameHsGadtTelescope inner_bndrs
    765 770 
         lcontext' <- traverse renameLContext lcontext
    766 771 
         details' <- renameGADTDetails details
    767 772 
         res_ty' <- renameLType res_ty

  • utils/haddock/haddock-api/src/Haddock/Types.hs
    ... ... @@ -840,6 +840,7 @@ type instance Anno (CType DocNameI) = SrcSpanAnnA
    840 840 
     type instance Anno (Header DocNameI) = SrcSpanAnnA
    841 841 
     type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA
    842 842 
     type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA
    843 
    +type instance Anno (HsGadtTelescope DocNameI) = SrcSpanAnnA
    843 844
    844 845 
     type XRecCond a =
    845 846 
       ( XParTy a ~ (EpToken "(", EpToken ")")
    ... ... @@ -904,6 +905,10 @@ type instance XHsForAllVis DocNameI = NoExtField
    904 905 
     type instance XHsForAllInvis DocNameI = NoExtField
    905 906 
     type instance XXHsForAllTelescope DocNameI = DataConCantHappen
    906 907
    908 
    +type instance XGadtForAll DocNameI = NoExtField
    909 
    +type instance XGadtPar DocNameI = NoExtField
    910 
    +type instance XXGadtArg DocNameI = DataConCantHappen
    911 
    +
    907 912 
     type instance XTyVarBndr DocNameI = NoExtField
    908 913 
     type instance XXTyVarBndr DocNameI = DataConCantHappen
    909 914

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/f0590079d2acacb326212e5a0d3ea60e73f86c90 at 1788350245