description:

   Parenthesized types are now accepted in prefix GADT constructor declarations,

     data T where

       MkT :: (forall a. a -> b -> T)

   PrefixConGADT{} -> Nothing

   RecConGADT _ flds -> Just flds

 ppDataDefnHeader

  :: (OutputableBndrId p)

 pprConDecl (ConDeclGADT { con_names = cons

                         , con_outer_bndrs = L _ outer_bndrs

                         , con_inner_bndrs = inner_bndrs

                         , con_res_ty = res_ty, con_modifiers = mods, con_doc = doc })

   = pprMaybeWithDoc doc $ pprLHsModifiers mods <+> ppr_con_names (toList cons) <+> dcolon

     <+> sep [ppr_outer_bndrs, ppr_inner_bndrs (

                       sep (ppr_args args ++ [ppr res_ty])])]

   where

     ppr_args (PrefixConGADT _ args) = map (pprHsConDeclFieldWith (\arr tyDoc -> tyDoc <+> pprHsModifiedFunArr arr)) args

 import Data.Maybe

 import Data.Data (Data)

 import qualified Data.Semigroup as S

 import GHC.Data.Bag

   = (tvs, ctxt, ty2)

 -- | Decompose a GADT type into its constituent parts.

 --

 -- * @outer_bndrs@ are 'HsOuterExplicit' if the type has explicit, outermost

 --   type variable binders. Otherwise, they are 'HsOuterImplicit'.

 -- * @inner_bndrs@ are the remaining @forall@ telescopes, interleaved with the

 --   parentheses that enclose them.

 --

 --

 --

 -- This function does look through parentheses, but it does not discard them:

 -- they are syntactically significant, so they are recorded in @inner_bndrs@.

 -- in "GHC.Hs.Decls" for why this is important.

 splitLHsGadtTy ::

      LHsSigType GhcPs

 splitLHsGadtTy (L _ sig_ty)

   | (outer_bndrs, sigma_ty) <- split_outer_bndrs sig_ty

   , (inner_bndrs, phi_ty)   <- split_inner_bndrs sigma_ty

   where

     split_outer_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)

     split_outer_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) =

         in (L l (HsGadtPar toks) : args, t)

     split_inner_bndrs t = ([], t)

 -- | Decompose a type of the form @forall <tvs>. body@ into its constituent

 -- parts. Only splits type variable binders that

   -- be updated to match.

       | otherwise = forAllLit <+> interppSP qtvs <> separator

 -- For use in a HsQualTy, which always gets printed if it exists.

 pprLHsContextAlways :: (OutputableBndrId p)

                       , con_args = args }))

   = addHsTyVarBinds FreshNamesOnly con_tvs $ \ ex_bndrs ->

          do { c'    <- repH98DataCon con args

             ; if not is_existential && isNothing mcxt

               then return c'

               else rep2 forallCOcc ([unC ex_bndrs, unC ctxt', unC c'])

 repC (L l (ConDeclGADT { con_names  = cons

                        , con_outer_bndrs = L _ outer_bndrs

                        , con_inner_bndrs = inner_bndrs

                        , con_g_args = args

                        , con_res_ty = res_ty }))

   | no_explicit_forall, no_context

   | Just invis_inner_bndrs <- m_invis_inner_bndrs

   = addHsOuterSigTyVarBinds outer_bndrs $ \ outer_bndrs' ->

     let loop last_bndrs' [] = do

           c'    <- repGadtDataCons cons args res_ty

           rep2 forallCOcc ([unC last_bndrs', unC ctxt', unC c'])

         loop last_bndrs' (bndrs : bndrs_s) =

     inner_teles = gadtArgTelescopes inner_bndrs

     no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_teles

     m_invis_inner_bndrs :: Maybe [[LHsTyVarBndr Specificity GhcRn]]

     m_invis_inner_bndrs = traverse get_invis_bndrs inner_teles

     get_invis_bndrs HsForAllVis{} = Nothing

     get_invis_bndrs HsForAllInvis { hsf_invis_bndrs = tvbs } = Just tvbs

 repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness))

 repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackOcc         []

       ConDeclGADT { con_names = names

                   , con_outer_bndrs = L outer_bndrs_loc outer_bndrs

                   , con_inner_bndrs = inner_bndrs

                   , con_g_args = args

                   , con_res_ty = typ

                   , con_doc = doc} ->

             map (C $ TyVarBind (mkScope outer_bndrs_loc) (ResolvedScopes [sigmaScope]))

                 imp_vars

         , toHie $ tvScopes (ResolvedScopes [phiScope]) NoScope exp_bndrs

         , toHie args

         , toHie typ

         , toHie doc

         ]

         where

           rhsScope = combineScopes argsScope tyScope

           argsScope = case args of

             PrefixConGADT _ xs -> scaled_args_scope xs

             RecConGADT _ x     -> mkScope x

                      , con_names  = names

                      , con_outer_bndrs = L outer_bndrs_loc outer_bndrs

                      , con_inner_bndrs = inner_bndrs

                      , con_g_args = args

                      , con_res_ty = res_ty

                      , con_modifiers = mods

                      , con_doc    = Nothing }

   where

     outer_bndrs_loc = case outer_bndrs of

       HsOuterImplicit{} -> getLoc ty

       HsOuterExplicit an _ -> EpAnn (entry an) noAnn emptyComments

     extendHdkA (locA l_con_decl) $

     case con_decl of

       ConDeclGADT { con_g_ext, con_names, con_outer_bndrs, con_inner_bndrs

         con_doc' <- getConDoc (getLocA (NE.head con_names))

         con_g_args' <-

           case con_g_args of

         con_res_ty' <- addHaddock con_res_ty

         pure $ L l_con_decl $

           ConDeclGADT { con_g_ext, con_names,

                         con_doc = lexLHsDocString <$> con_doc',

                         con_g_args = con_g_args',

                         con_res_ty = con_res_ty' }

 import GHC.Rename.Bind

 import GHC.Rename.Doc

 import GHC.Rename.Env

                         , checkDupRdrNames, bindLocalNamesFV

                         , warnUnusedTypePatterns

                         , noNestedForallsContextsErr

         ; let ctxt = ConDeclCtx [new_name]

         ; bindLHsTyVarBndrs ctxt WarnUnusedForalls

                             Nothing ex_tvs $ \ new_ex_tvs ->

         ; (new_args,    fvs2) <- rnConDeclH98Details (unLoc new_name) ctxt args

         ; (mods', mods_fvs) <- rnModifiersContextAndWarn ctxt mods

         ; let all_fvs  = fvs1 `plusFN` fvs2 `plusFN` mods_fvs

 rnConDecl (ConDeclGADT { con_names   = names

                        , con_outer_bndrs = L outer_bndrs_loc outer_bndrs

                        , con_inner_bndrs = inner_bndrs

                        , con_g_args  = args

                        , con_res_ty  = res_ty

                        , con_modifiers = mods

               implicit_bndrs =

                 extractHsOuterTvBndrs outer_bndrs           $

                 extractHsGadtTelescopes inner_bndrs         $

                 extractConDeclGADTDetailsTyVars args        $

                 extractHsTysRdrTyVars [res_ty] []

         ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' ->

           bindHsGadtTelescopes ctxt inner_bndrs $ \inner_bndrs' ->

         ; (new_args, fvs2)   <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args

         ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty

         ; (mods', mods_fvs) <- rnModifiersContextAndWarn ctxt mods

         ; return (ConDeclGADT { con_g_ext = noExtField, con_names = new_names

                               , con_outer_bndrs = L outer_bndrs_loc outer_bndrs'

                               , con_inner_bndrs = inner_bndrs'

                               , con_g_args = new_args, con_res_ty = new_res_ty

                               , con_doc = new_mb_doc, con_modifiers = mods' },

                   all_fvs) } }

 rnConDeclH98Details ::

       Name

    -> HsDocContext

 ---------------------------

 tcLHsPredType :: LHsType GhcRn -> TcM PredType

 tcLHsPredType pred = tc_lhs_pred typeLevelMode pred

           (ConDeclGADT { con_names = names

                        , con_outer_bndrs = L _ outer_bndrs

                        , con_inner_bndrs = inner_bndrs

                        , con_g_args = args

                        , con_res_ty = res_ty })

   = -- See Note [kcConDecls: kind-checking data type decls]

     addErrCtxt (DataConDefCtxt names) $

     -- Not sure this is right, should just extend rather than skolemise but no test

     bind_con_tvbs outer_bndrs inner_bndrs $

        ; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty)

        ; con_res_kind <- newOpenTypeKind

        ; _ <- tcCheckLHsTypeInContext res_ty (TheKind con_res_kind)

           (ConDeclGADT { con_names = names

                        , con_outer_bndrs = L _ outer_bndrs

                        , con_inner_bndrs = inner_bndrs

                        , con_res_ty = hs_res_ty })

   = addErrCtxt (DataConDefCtxt names) $

     do { traceTc "tcConDecl 1 gadt" (ppr names)

        ; (tclvl, wanted, (tvbs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))

            <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $

               tcGadtConTyVarBndrs skol_info outer_bndrs inner_bndrs $

                  ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty

                          -- See Note [GADT return kinds]

 import Data.Foldable (for_)

 import Data.List.NonEmpty( NonEmpty (..), nonEmpty )

 import qualified Data.List.NonEmpty as NE

 import Data.Word (Word64)

 import GHC.Boot.TH.Syntax as TH

 import Foreign.ForeignPtr

     add_cxt (L loc (HsContext _ cxt1)) (Just (L _ (HsContext _ cxt2)))

       = Just (L loc (HsContext noAnn (cxt1 ++ cxt2)))

     -- but it doesn't seem to matter.

     add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs

                -> ConDecl GhcPs -> ConDecl GhcPs

     add_forall tvs' cxt' con@(ConDeclGADT { con_outer_bndrs = L l outer_bndrs

                                           , con_inner_bndrs = inner_bndrs

       = con { con_outer_bndrs = L l outer_bndrs'

             , con_inner_bndrs = inner_bndrs

       where

         outer_bndrs'

           | null all_tvs = mkHsOuterImplicit

                    , con_names  = names

                    , con_outer_bndrs = outer_bndrs

                    , con_inner_bndrs = []

                    , con_g_args = args

                    , con_res_ty = res_ty

                    , con_modifiers = []

       , con_inner_bndrs :: [LHsGadtTelescope pass]

         -- ^ The forall telescopes other than the outermost invisible forall,

         --   interleaved with the parentheses that enclose them.

       , con_g_args  :: HsConDeclGADTDetails pass -- ^ Arguments; never infix

       , con_res_ty  :: LHsType pass              -- ^ Result type

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 The types of both forms of GADT constructors are very structured, as they

 must consist of the quantified type variables (if provided), followed by the

 by the result type. (See "Wrinkle: No nested foralls or contexts" below for

 more discussion on the restrictions imposed here.) As a result, instead of

 storing the type of a GADT constructor as a single LHsType, we split it up

     MkT2 :: forall a. Eq a => forall b. a -> b -> T

       -- Rejected, `forall b` is nested

     MkT3 :: forall a b. Eq a => Eq b => a -> b -> T

       -- Rejected, `Eq b` is nested

     MkT4 :: Int -> forall a. a -> T

       -- Rejected, `forall a` is nested

 or contexts in a single place:

    GHC, in the process of splitting apart a GADT's type,

    If the body returned by splitLHsGadtTy still contains any `forall`s or

    contexts, then they must be nested, so they will be rejected.

   = HsGadtForAll !(XGadtForAll pass) (HsForAllTelescope pass)

   | HsGadtPar !(XGadtPar pass)

     -- ^ `HsGadtPar` is only usefull for pretty-printing/exact-printing for recovering

     --

     -- This approach differs from `HsPar`, which wraps the inner expression as if

     -- surrounding it with parentheses. We can ditch the `HsPar` approach because

 .. code-block:: none

   conids ::= conid

           |  conid ',' conids

                  |  '{' tyvar '}'

                  |  '{' tyvar '::' ctype '}'

   ctxt ::= ctype

         |  ctype ',' ctxt

 - GADT constructor types are currently not permitted to have arbitrarily nested

   ``forall``\ s or ``=>``\ s. (e.g., something like ``MkT :: Int -> forall a. a -> T``

   higher-rank ``forall``\ s and ``=>``\ s are only permitted if they do not appear

   directly to the right of a function arrow in a `prefix_gadt_body`. (e.g.,

   something like ``MkS :: Int -> (forall a. a) -> S`` is allowed, since

   parentheses separate the ``forall`` from the ``->``.)

 - GADT constructors permit outermost parentheses that surround the ``foralls``

   ``foralls``. For example, ``MkU :: (forall a. a -> U)`` is accepted, as is

   ``MkW :: forall a. (forall b. a -> b -> W)``.

   data InnerBindings

     = InnerMore (LHsGadtTelescope GhcPs) InnerBindings

 The key part of the ExactPrint instance for this is

     (ann', mt') <- exactBang (ann, mt) str

     ty' <- markAnnotated ty

     return (XHsType (HsBangTy ann' (HsSrcBang mt' up str) ty'))

   exact (HsExplicitListTy (sq,o,c) prom tys) = do

     sq' <- if (isPromoted prom)

              then markEpToken sq

                      , con_names = cons

                      , con_outer_bndrs = outer_bndrs

                      , con_inner_bndrs = inner_bndrs

                      , con_modifiers = mods

                      , con_res_ty = res_ty, con_doc = doc }) = do

     mods' <- mapM markAnnotated mods

       L _ (HsOuterImplicit _) -> return outer_bndrs

       _ -> markAnnotated outer_bndrs

     ib' <- markAnnotated ib

     return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol'

                         , con_names = cons'

                         , con_outer_bndrs = outer_bndrs'

                         , con_inner_bndrs = inner_bndrs'

                         , con_modifiers = mods'

                         , con_res_ty = res_ty', con_doc = doc })

 data InnerBindings

   = InnerMore (LHsGadtTelescope GhcPs) InnerBindings

 toInnerBindings :: [LHsGadtTelescope GhcPs]

 toInnerBindings [] inner = InnerDone inner

 toInnerBindings (b:bs) inner = InnerMore b (toInnerBindings bs inner)

 fromInnerBindings = go []

   where

     go acc (InnerMore b n) = go (b:acc) n

     xs' <- markAnnotated xs

     rp' <- markEpToken rp

     return (InnerMore (L l (HsGadtPar (lp',rp'))) xs')

     args' <-

       case args of

           (PrefixConGADT x args0) -> do

             rarr' <- markEpUniToken rarr

             return (RecConGADT (oc',cc',rarr') fields')

     res_ty' <- markAnnotated res_ty

 -- ---------------------------------------------------------------------

       { con_names = names

       , con_outer_bndrs = L _ outer_bndrs

       , con_inner_bndrs = inner_bndrs

       , con_g_args = args

       , con_res_ty = res_ty

       }

       con_sig_ty = HsSig noExtField outer_bndrs $

                    mkGadtArgTys inner_bndrs phi_ty

         where

           tau_ty = foldr mkFunTy res_ty $

             case args of

               PrefixConGADT _ pos_args -> map cdf_type pos_args

 import Control.DeepSeq (force)

 import Data.Either (lefts, partitionEithers, rights)

 import GHC.Builtin.KnownKeys

   ( boxedRepDataConKey

   , eqTyConKey

               , con_names = pure name

               , con_outer_bndrs = noLocA outer_bndrs

               , con_inner_bndrs = inner_bndrs

               , con_g_args = hat

               , con_res_ty = synifyType WithinType emptyVarSet res_ty

               , con_modifiers = []

   ( ConDeclGADT

       { con_outer_bndrs = outer_bndrs

       , con_inner_bndrs = inner_bndrs

       , con_g_args = args

       , con_res_ty = res_ty

       }

       )

     where

       phi_ty :: LHsType DocNameI

       tau_ty :: LHsType DocNameI

       tau_ty = case args of

     { con_names = lnames

     , con_outer_bndrs = outer_bndrs

     , con_inner_bndrs = inner_bndrs

     , con_g_args = details

     , con_res_ty = res_ty

     , con_modifiers = mods

     lnames' <- mapM renameNameL lnames

     outer_bndrs' <- mapM renameOuterTyVarBndrs outer_bndrs

     inner_bndrs' <- mapM renameHsGadtTelescope inner_bndrs

     details' <- renameGADTDetails details

     res_ty' <- renameLType res_ty

     mods' <- renameModifiers mods

           , con_names = lnames'

           , con_outer_bndrs = outer_bndrs'

           , con_inner_bndrs = inner_bndrs'

           , con_g_args = details'

           , con_res_ty = res_ty'

           , con_modifiers = mods'