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

Commits:

28 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,33 @@ 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 
    +    <+> (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 parenthisis 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 = pprHsForAllTelescope tele <+> rest
    990 
    +
    991 
    +    -- for each open paren generate a closed one
    992 
    +    close_parens = hcat [ rparen | L _ HsGadtPar{} <- inner_bndrs ]
    993 
    +
    994 
    +    -- pprint empty explicit outer forall as `forall.` if there are inner binders, because otherwise
    995 
    +    -- `forall. forall a. ...` would become `forall a. ...` and that would parse into
    996 
    +    -- different AST, thus breaking parse == parse . ppr . parse property
    997 
    +    ppr_outer_bndrs
    998 
    +      | HsOuterExplicit{hso_bndrs = []} <- outer_bndrs
    999 
    +      , not (null inner_bndrs)
    1000 
    +      = forAllLit <> dot
    1001 
    +      | otherwise
    1002 
    +      = pprHsOuterSigTyVarBndrs outer_bndrs
    1003 
    +
    985 1004 
     ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc
    986 1005 
     ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
    987 1006

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

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

  • compiler/GHC/Iface/Ext/Ast.hs
    ... ... @@ -1788,7 +1788,7 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where
    1788 1788 
                 HsOuterExplicit{} -> []
    1789 1789 
               exp_bndrs =
    1790 1790 
                 [ L l (updateHsTyVarBndrFlag Invisible b) | L l b <- hsOuterExplicitBndrs outer_bndrs ]
    1791 
    -            ++ concatMap hsForAllTelescopeBndrs inner_bndrs
    1791 
    +            ++ concatMap hsForAllTelescopeBndrs (gadtArgTelescopes inner_bndrs)
    1792 1792 
           ConDeclH98 { con_name = name, con_ex_tvs = qvars
    1793 1793 
                      , con_mb_cxt = ctx, con_args = dets
    1794 1794 
                      , 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, bindHsGadtArgs,
    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 
    +        extractHsGadtArgs,
    41 40 
             nubL, nubN,
    42 41
    43 42 
             -- Error helpers
    ... ... @@ -1241,16 +1240,19 @@ bindHsForAllTelescope doc tele thing_inside =
    1241 1240 
             checkForAllTelescopeWildcardBndrs doc bndrs'
    1242 1241 
             thing_inside $ mkHsForAllInvisTele noAnn bndrs'
    1243 1242
    1244 
    -bindHsForAllTelescopes :: HsDocContext
    1245 
    -                       -> [HsForAllTelescope GhcPs]
    1246 
    -                       -> ([HsForAllTelescope GhcRn] -> RnM (a, FreeNames))
    1247 
    -                       -> RnM (a, FreeNames)
    1248 
    -bindHsForAllTelescopes _ [] thing_inside =
    1243 
    +bindHsGadtArgs :: HsDocContext
    1244 
    +               -> [LHsGadtArg GhcPs]
    1245 
    +               -> ([LHsGadtArg GhcRn] -> RnM (a, FreeNames))
    1246 
    +               -> RnM (a, FreeNames)
    1247 
    +bindHsGadtArgs _ [] thing_inside =
    1249 1248 
       thing_inside []
    1250 
    -bindHsForAllTelescopes doc (tele:teles) thing_inside =
    1251 
    -  bindHsForAllTelescope  doc tele  $ \tele'  ->
    1252 
    -  bindHsForAllTelescopes doc teles $ \teles' ->
    1253 
    -    thing_inside (tele':teles')
    1249 
    +bindHsGadtArgs doc (L l HsGadtPar{} : args) thing_inside =
    1250 
    +  bindHsGadtArgs doc args $ \args' ->
    1251 
    +    thing_inside (L l (HsGadtPar noExtField) : args')
    1252 
    +bindHsGadtArgs doc (L l (HsGadtForAll _ tele) : args) thing_inside =
    1253 
    +  bindHsForAllTelescope doc tele $ \tele' ->
    1254 
    +  bindHsGadtArgs        doc args $ \args' ->
    1255 
    +    thing_inside (L l (HsGadtForAll noExtField tele') : args')
    1254 1256
    1255 1257 
     -- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type
    1256 1258 
     checkForAllTelescopeWildcardBndrs :: HsDocContext
    ... ... @@ -2277,13 +2279,15 @@ extractHsOuterTvBndrs outer_bndrs body_fvs =
    2277 2279 
         HsOuterImplicit{}                  -> body_fvs
    2278 2280 
         HsOuterExplicit{hso_bndrs = bndrs} -> extract_hs_tv_bndrs bndrs [] body_fvs
    2279 2281
    2280 
    -extractHsForAllTelescopes :: [HsForAllTelescope GhcPs]
    2281 
    -                          -> FreeKiTyVars -- Free in body
    2282 
    -                          -> FreeKiTyVars -- Free in result
    2283 
    -extractHsForAllTelescopes []           body_fvs = body_fvs
    2284 
    -extractHsForAllTelescopes (tele:teles) body_fvs =
    2282 
    +extractHsGadtArgs :: [LHsGadtArg GhcPs]
    2283 
    +                  -> FreeKiTyVars -- Free in body
    2284 
    +                  -> FreeKiTyVars -- Free in result
    2285 
    +extractHsGadtArgs []                           body_fvs = body_fvs
    2286 
    +extractHsGadtArgs (L _ HsGadtPar{} : args)         body_fvs =
    2287 
    +  extractHsGadtArgs args body_fvs
    2288 
    +extractHsGadtArgs (L _ (HsGadtForAll _ tele) : args) body_fvs =
    2285 2289 
       extract_hs_for_all_telescope tele [] $
    2286 
    -  extractHsForAllTelescopes teles body_fvs
    2290 
    +  extractHsGadtArgs args body_fvs
    2287 2291
    2288 2292 
     extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs]
    2289 2293 
                         -> FreeKiTyVars  -- Accumulator

  • compiler/GHC/Rename/Module.hs
    ... ... @@ -2641,7 +2641,7 @@ rnConDecl (ConDeclGADT { con_names = names
    2641 2641 
                   -- See #14808.
    2642 2642 
                   implicit_bndrs =
    2643 2643 
                     extractHsOuterTvBndrs outer_bndrs           $
    2644 
    -                extractHsForAllTelescopes inner_bndrs       $
    2644 
    +                extractHsGadtArgs inner_bndrs               $
    2645 2645 
                     extractHsTysRdrTyVars (hsConDeclTheta mcxt) $
    2646 2646 
                     extractConDeclGADTDetailsTyVars args        $
    2647 2647 
                     extractHsTysRdrTyVars [res_ty] []
    ... ... @@ -2649,7 +2649,7 @@ rnConDecl (ConDeclGADT { con_names = names
    2649 2649 
             ; let ctxt = ConDeclCtx (toList new_names)
    2650 2650
    2651 2651 
             ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' ->
    2652 
    -          bindHsForAllTelescopes ctxt inner_bndrs $ \inner_bndrs' ->
    2652 
    +          bindHsGadtArgs ctxt inner_bndrs $ \inner_bndrs' ->
    2653 2653 
         do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt
    2654 2654 
             ; (new_args, fvs2)   <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args
    2655 2655 
             ; (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
    3546 3546 
     ---------------
    3547 3547 
     tcGadtConTyVarBndrs :: SkolemInfo
    3548 3548 
                         -> HsOuterSigTyVarBndrs GhcRn
    3549 
    -                    -> [HsForAllTelescope GhcRn]
    3549 
    +                    -> [LHsGadtArg GhcRn]
    3550 3550 
                         -> TcM a -> TcM ([TcTyVarBinder], a)
    3551 3551 
     tcGadtConTyVarBndrs skol_info outer inner thing_inside
    3552 3552 
       = do { (outer_bndrs, (inner_tvbs, a)) <-
    3553 3553 
                 tcOuterTKBndrs skol_info outer $
    3554 
    -            tcExplicitTKBndrs skol_info (concatMap hsForAllTelescopeBndrs inner) $
    3554 
    +            tcExplicitTKBndrs skol_info (gadtArgBndrs inner) $
    3555 3555 
                 thing_inside
    3556 3556 
            ; outer_bndrs <- scopedSortOuter outer_bndrs
    3557 3557 
            ; 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 :: [LHsGadtArg 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 1084 
     or contexts in two parts:
    1084 1085
    1085 1086 
     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.
    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

  • 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 
    +        HsGadtArg(..), LHsGadtArg, XGadtForAll, XGadtPar, XXGadtArg,
    24 25 
             HsTyVarBndr(..), LHsTyVarBndr,
    25 26 
             LHsQTyVars(..),
    26 27 
             HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,
    ... ... @@ -392,6 +393,41 @@ data HsForAllTelescope pass
    392 393 
         }
    393 394 
       | XHsForAllTelescope !(XXHsForAllTelescope pass)
    394 395
    396 
    +-- A type for interleaved GADT foralls and prefixes, inspired by HsArg
    397 
    +--
    398 
    +-- `HsGadtPar` is only usefull for pretty-printing/exact-printing for recovering
    399 
    +-- parenthisis interleaved with foralls.
    400 
    +--
    401 
    +-- Here's an example:
    402 
    +--
    403 
    +--  data D where
    404 
    +--    MkD :: forall a b. ( forall c. forall d. ( forall. ...
    405 
    +--           ↑           ↑ ↑         ↑         ↑ ↑
    406 
    +--           1           2 3         4         5 6
    407 
    +--
    408 
    +-- That would correspond to a list
    409 
    +--
    410 
    +--   1 → [ HsGadtForAll
    411 
    +--   2 → , HsGadtPar
    412 
    +--   3 → , HsGadtForAll
    413 
    +--   4 → , HsGadtForAll
    414 
    +--   5 → , HsGadtPar
    415 
    +--   6 → , HsGadtForAll
    416 
    +--       , ...]
    417 
    +--
    418 
    +-- We can always recover parenthisis structure because they must close after
    419 
    +-- return type.
    420 
    +data HsGadtArg pass
    421 
    +  = HsGadtForAll !(XGadtForAll pass) (HsForAllTelescope pass)
    422 
    +  | HsGadtPar !(XGadtPar pass)
    423 
    +  | XHsGadtArg !(XXGadtArg pass)
    424 
    +
    425 
    +type LHsGadtArg pass = XRec pass (HsGadtArg pass)
    426 
    +
    427 
    +type family XGadtForAll pass
    428 
    +type family XGadtPar    pass
    429 
    +type family XXGadtArg   pass
    430 
    +
    395 431 
     -- | Located Haskell Type Variable Binder
    396 432 
     type LHsTyVarBndr flag pass = XRec pass (HsTyVarBndr flag pass)
    397 433 
                              -- See Note [HsType binders]

  • 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
    ... ... @@ -932,3 +932,8 @@ PprModifiers:
    932 932 
     PprQualifiedStrings:
    933 933 
     	$(CHECK_PPR)   $(LIBDIR) PprQualifiedStrings.hs
    934 934 
     	$(CHECK_EXACT) $(LIBDIR) PprQualifiedStrings.hs
    935 
    +
    936 
    +.PHONY: T27423c
    937 
    +T27423c:
    938 
    +	$(CHECK_PPR)   $(LIBDIR) T27423c.hs
    939 
    +	$(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 
    +
    22 
    +data U a where
    23 
    +  MkU :: (Show a => U a)
    24 
    +
    25 
    +data V a where
    26 
    +  MkV1 :: ((a -> V a))
    27 
    +  MkV2 :: forall a. (forall b. V (b, a))
    28 
    +  MkV3 :: (forall a. Show a => a -> V a)
    29 
    +  MkV4 :: forall a. ((forall b. (Show a => a -> (b -> V a))))
    30 
    +
    31 
    +data W a b where
    32 
    +  MkW1 :: forall a -> forall b. (Int -> W a b)
    33 
    +  MkW2 :: forall a. (forall b -> (Bool -> W a b))
    34 
    +
    35 
    +data P a where
    36 
    +  MkP1 :: Show a => (a -> P a)
    37 
    +  MkP2 :: forall a. Int -> (a -> P a)
    38 
    +
    39 
    +-- Comments in and around the parentheses
    40 
    +data C a where
    41 
    +  MkC1 :: -- comment before the parenthesis
    42 
    +          (forall a. C a)
    43 
    +  MkC2 :: ( -- comment after the parenthesis
    44 
    +           forall a. C a)
    45 
    +  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
    223 223 
     test('TestNamedDefaults', [ignore_stderr, req_ppr_deps], makefile_test, ['TestNamedDefaults'])
    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 
    +
    227 
    +test('T27423c', [ignore_stderr,req_ppr_deps], makefile_test, ['T27423c'])

  • utils/check-exact/ExactPrint.hs
    ... ... @@ -374,6 +374,9 @@ cua CanUpdateAnchor f = f
    374 374 
     cua CanUpdateAnchorOnly _ = return []
    375 375 
     cua NoCanUpdateAnchor _ = return []
    376 376
    377 
    +enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a
    378 
    +enterAnn = enterAnnWith exact setAnnotationAnchor
    379 
    +
    377 380 
     -- | "Enter" an annotation, by using the associated 'anchor' field as
    378 381 
     -- the new reference point for calculating all DeltaPos positions.
    379 382 
     -- This is the heart of the exact printing process.
    ... ... @@ -381,14 +384,17 @@ cua NoCanUpdateAnchor _ = return []
    381 384 
     -- This is combination of the ghc=exactprint Delta.withAST and
    382 385 
     -- Print.exactPC functions and effectively does the delta processing
    383 386 
     -- immediately followed by the print processing.  JIT ghc-exactprint.
    384 
    -enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a
    385 
    -enterAnn NoEntryVal a = do
    387 
    +enterAnnWith :: (Monad m, Monoid w, Typeable a, Typeable b) =>
    388 
    +  (a -> EP w m b) -> -- exact
    389 
    +  (b -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> b) -> -- setAnnotationAnchor
    390 
    +  Entry -> a -> EP w m b
    391 
    +enterAnnWith exactVia _ NoEntryVal a = do
    386 392 
       p <- getPosP
    387 393 
       debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a)
    388 
    -  r <- exact a
    394 
    +  r <- exactVia a
    389 395 
       debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a)
    390 396 
       return r
    391 
    -enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
    397 
    +enterAnnWith exactVia setAnnAnchor !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
    392 398 
       acceptSpan <- getAcceptSpan
    393 399 
       setAcceptSpan False
    394 400 
       case anchor' of
    ... ... @@ -499,7 +505,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
    499 505
    500 506 
       advance edp
    501 507 
       debugM $ "enterAnn:exact a starting:" ++ show (showAst anchor')
    502 
    -  a' <- exact a
    508 
    +  a' <- exactVia a
    503 509 
       debugM $ "enterAnn:exact a done:" ++ show (showAst anchor')
    504 510
    505 511 
       -- Core recursive exactprint done, start end of Entry processing
    ... ... @@ -553,8 +559,8 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
    553 559 
               EpaSpan s -> EpaDelta s         edp []
    554 560 
               _         -> EpaDelta noSrcSpan edp []
    555 561 
       let r = case canUpdateAnchor of
    556 
    -            CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs)
    557 
    -            CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments
    562 
    +            CanUpdateAnchor -> setAnnAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs)
    563 
    +            CanUpdateAnchorOnly -> setAnnAnchor a' newAnchor [] emptyComments
    558 564 
                 NoCanUpdateAnchor -> a'
    559 565 
       return r
    560 566
    ... ... @@ -4268,21 +4274,22 @@ instance ExactPrint (ConDecl GhcPs) where
    4268 4274 
           L _ (HsOuterImplicit _) -> return outer_bndrs
    4269 4275 
           _ -> markAnnotated outer_bndrs
    4270 4276
    4271 
    -    inner_bndrs' <- mapM markAnnotated inner_bndrs
    4277 
    +    (inner_bndrs', (mcxt', args', res_ty')) <- markGadtArgs inner_bndrs $ do
    4278 
    +      mcxt' <- markAnnotated mcxt
    4279 
    +      args' <-
    4280 
    +        case args of
    4281 
    +            (PrefixConGADT x args0) -> do
    4282 
    +              args0' <- mapM markAnnotated args0
    4283 
    +              return (PrefixConGADT x args0')
    4284 
    +            (RecConGADT (oc,cc,rarr) fields) -> do
    4285 
    +              oc' <- markEpToken oc
    4286 
    +              fields' <- markAnnotated fields
    4287 
    +              cc' <- markEpToken cc
    4288 
    +              rarr' <- markEpUniToken rarr
    4289 
    +              return (RecConGADT (oc',cc',rarr') fields')
    4290 
    +      res_ty' <- markAnnotated res_ty
    4291 
    +      return (mcxt', args', res_ty')
    4272 4292
    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 4293 
         return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol'
    4287 4294 
                             , con_names = cons'
    4288 4295 
                             , con_outer_bndrs = outer_bndrs'
    ... ... @@ -4291,6 +4298,44 @@ instance ExactPrint (ConDecl GhcPs) where
    4291 4298 
                             , con_modifiers = mods'
    4292 4299 
                             , con_res_ty = res_ty', con_doc = doc })
    4293 4300
    4301 
    +-- | Exact print the inner binders of a GADT signature.
    4302 
    +--
    4303 
    +-- It's that complicated because we need to mark comments/trailing anns
    4304 
    +-- stored inside `L` and mark closing parenthesis _after_ we mark inner
    4305 
    +-- type:
    4306 
    +--
    4307 
    +--   data T a b where
    4308 
    +--    MkT ::
    4309 
    +--      forall a. ( -- mark inside `markGadtArgs`
    4310 
    +--          forall b. some type -> T a b -- mark everything there
    4311 
    +--        ) -- mark inside `markGadtArgs`
    4312 
    +--
    4313 
    +-- We don't have the same problem for `HsArgPar` because we ignore it
    4314 
    +-- during exact-print, "Does not appear in original source"
    4315 
    +markGadtArgs :: (Monad m, Monoid w, Typeable a)
    4316 
    +             => [LHsGadtArg GhcPs] -> EP w m a
    4317 
    +             -> EP w m ([LHsGadtArg GhcPs], a)
    4318 
    +markGadtArgs args inner_action = go args
    4319 
    +  where
    4320 
    +    go [] = do
    4321 
    +      r <- inner_action
    4322 
    +      return ([], r)
    4323 
    +    go (arg:xs) = enterAnnWith (exact_arg xs) setAnchor (entryFromLocatedA arg) arg
    4324 
    +
    4325 
    +    exact_arg xs (L l (HsGadtForAll _ tele)) = do
    4326 
    +      tele' <- markAnnotated tele
    4327 
    +      (xs', r) <- go xs
    4328 
    +      return (L l (HsGadtForAll noExtField tele') : xs', r)
    4329 
    +    exact_arg xs (L l (HsGadtPar (lp, rp))) = do
    4330 
    +      lp' <- markEpToken lp
    4331 
    +      (xs', r) <- go xs
    4332 
    +      rp' <- markEpToken rp
    4333 
    +      return (L l (HsGadtPar (lp',rp')) : xs', r)
    4334 
    +
    4335 
    +    -- The binder just entered is the head of the returned list
    4336 
    +    setAnchor (arg':xs', r) anc ts cs = (setAnchorAn arg' anc ts cs : xs', r)
    4337 
    +    setAnchor ([], r)       _   _  _  = ([], r)
    4338 
    +
    4294 4339 
     -- ---------------------------------------------------------------------
    4295 4340
    4296 4341 
     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 :: LHsGadtArg 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 :: [LHsGadtArg 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 :: LHsGadtArg 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 :: [LHsGadtArg 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 
    +renameHsGadtArg :: LHsGadtArg GhcRn -> RnM (LHsGadtArg DocNameI)
    480 
    +renameHsGadtArg (L l HsGadtPar{}) = pure $ L l $ HsGadtPar noExtField
    481 
    +renameHsGadtArg (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 renameHsGadtArg 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
    ... ... @@ -841,6 +841,7 @@ type instance Anno (CType DocNameI) = SrcSpanAnnA
    841 841 
     type instance Anno (Header DocNameI) = SrcSpanAnnA
    842 842 
     type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA
    843 843 
     type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA
    844 
    +type instance Anno (HsGadtArg DocNameI) = SrcSpanAnnA
    844 845
    845 846 
     type XRecCond a =
    846 847 
       ( XParTy a ~ (EpToken "(", EpToken ")")
    ... ... @@ -905,6 +906,10 @@ type instance XHsForAllVis DocNameI = NoExtField
    905 906 
     type instance XHsForAllInvis DocNameI = NoExtField
    906 907 
     type instance XXHsForAllTelescope DocNameI = DataConCantHappen
    907 908
    909 
    +type instance XGadtForAll DocNameI = NoExtField
    910 
    +type instance XGadtPar DocNameI = NoExtField
    911 
    +type instance XXGadtArg DocNameI = DataConCantHappen
    912 
    +
    908 913 
     type instance XTyVarBndr DocNameI = NoExtField
    909 914 
     type instance XXTyVarBndr DocNameI = DataConCantHappen
    910 915

    • —
    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/53de859d9f307c2326e0068e18abb97e60b6088e at 1786434629