Most of Trac #14529

This is all about refactoring ConDeclGADT

Better comments later.

Validates all except
   ghc-api/annotations/T10278.run            T10278 [bad exit code] (normal)
   ghc-api/annotations/T10399.run            T10399 [bad exit code] (normal)

21 files changed, 548 insertions, 465 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 2a181e8d16..8ad8e2c78d 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -630,51 +630,45 @@ repAnnProv ModuleAnnProvenance
 
 repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
 repC (L _ (ConDeclH98 { con_name = con
-                      , con_qvars = Nothing, con_cxt = Nothing
-                      , con_details = details }))
-  = repDataCon con details
+                      , con_forall = False
+                      , con_mb_cxt = Nothing
+                      , con_args = args }))
+  = repDataCon con args
 
 repC (L _ (ConDeclH98 { con_name = con
-                      , con_qvars = mcon_tvs, con_cxt = mcxt
-                      , con_details = details }))
-  = do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs
-             ctxt    = unLoc $ fromMaybe (noLoc []) mcxt
-       ; addTyVarBinds con_tvs $ \ ex_bndrs ->
-         do { c'    <- repDataCon con details
-            ; ctxt' <- repContext ctxt
-            ; if isEmptyLHsQTvs con_tvs && null ctxt
+                      , con_forall = is_existential
+                      , con_qvars = con_tvs
+                      , con_mb_cxt = mcxt
+                      , con_args = args }))
+  = do { addTyVarBinds con_tvs $ \ ex_bndrs ->
+         do { c'    <- repDataCon con args
+            ; ctxt' <- repMbContext mcxt
+            ; if not is_existential && isNothing mcxt
               then return c'
               else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
             }
        }
 
 repC (L _ (ConDeclGADT { con_names = cons
-                       , con_type = res_ty@(HsIB { hsib_vars = imp_tvs })}))
-  | (details, res_ty', L _ [] , []) <- gadtDetails
-  , [] <- imp_tvs
-    -- no implicit or explicit variables, no context = no need for a forall
-  = do { let doc = text "In the constructor for " <+> ppr (head cons)
-       ; (hs_details, gadt_res_ty) <-
-           updateGadtResult failWithDs doc details res_ty'
-       ; repGadtDataCons cons hs_details gadt_res_ty }
-
-  | (details,res_ty',ctxt, exp_tvs) <- gadtDetails
-  = do { let doc = text "In the constructor for " <+> ppr (head cons)
-             con_tvs = HsQTvs { hsq_implicit  = imp_tvs
-                              , hsq_explicit  = exp_tvs
-                              , hsq_dependent = emptyNameSet }
-             -- NB: Don't put imp_tvs into the hsq_explicit field above
+                       , con_qvars = qtvs, con_mb_cxt = mcxt
+                       , con_args = args, con_res_ty = res_ty }))
+  | isEmptyLHsQTvs qtvs  -- No implicit or explicit variables
+  , Nothing <- mcxt      -- No context
+                         -- ==> no need for a forall
+  = repGadtDataCons cons args res_ty
+
+  | otherwise
+  = addTyVarBinds qtvs $ \ ex_bndrs ->
              -- See Note [Don't quantify implicit type variables in quotes]
-       ; addTyVarBinds con_tvs $ \ ex_bndrs -> do
-       { (hs_details, gadt_res_ty) <-
-           updateGadtResult failWithDs doc details res_ty'
-       ; c'    <- repGadtDataCons cons hs_details gadt_res_ty
-       ; ctxt' <- repContext (unLoc ctxt)
-       ; if null exp_tvs && null (unLoc ctxt)
+    do { c'    <- repGadtDataCons cons args res_ty
+       ; ctxt' <- repMbContext mcxt
+       ; if null (hsQTvExplicit qtvs) && isNothing mcxt
          then return c'
-         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } }
-  where
-     gadtDetails = gadtDeclDetails res_ty
+         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
+
+repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
+repMbContext Nothing          = repContext []
+repMbContext (Just (L _ cxt)) = repContext cxt
 
 repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
 repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 4336243e91..c33b9aca67 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -42,7 +42,7 @@ import MonadUtils ( foldrM )
 import qualified Data.ByteString as BS
 import Control.Monad( unless, liftM, ap, (<=<) )
 
-import Data.Maybe( catMaybes, fromMaybe, isNothing )
+import Data.Maybe( catMaybes, isNothing )
 import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
 
@@ -509,40 +509,32 @@ cvtConstr (InfixC st1 c st2)
         ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }
 
 cvtConstr (ForallC tvs ctxt con)
-  = do  { tvs'        <- cvtTvs tvs
-        ; L loc ctxt' <- cvtContext ctxt
-        ; L _ con'    <- cvtConstr con
-        ; returnL $ case con' of
-                ConDeclGADT { con_type = conT } ->
-                  let hs_ty  = mkHsForAllTy tvs noSrcSpan tvs' rho_ty
-                      rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt')
-                                                         (hsib_body conT)
-                  in con' { con_type = mkHsImplicitBndrs hs_ty }
-                ConDeclH98  {} ->
-                  let qvars = case (tvs, con_qvars con') of
-                        ([], Nothing) -> Nothing
-                        (_ , m_qvs  ) -> Just $
-                          mkHsQTvs (hsQTvExplicit tvs' ++
-                                    maybe [] hsQTvExplicit m_qvs)
-                  in con' { con_qvars = qvars
-                          , con_cxt = Just $
-                            L loc (ctxt' ++
-                                   unLoc (fromMaybe (noLoc [])
-                                          (con_cxt con'))) } }
+  = do  { tvs'      <- cvtTvs tvs
+        ; ctxt'     <- cvtContext ctxt
+        ; L _ con'  <- cvtConstr con
+        ; let all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit (con_qvars con')
+              all_cxt = add_cxt ctxt' (con_mb_cxt con')
+        ; returnL $ con' { con_forall = not (null all_tvs)
+                         , con_qvars  = mkHsQTvs all_tvs
+                         , con_mb_cxt = all_cxt } }
+  where
+    add_cxt lcxt         Nothing           = Just lcxt
+    add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2))
+
 
 cvtConstr (GadtC c strtys ty)
   = do  { c'      <- mapM cNameL c
         ; args    <- mapM cvt_arg strtys
         ; L _ ty' <- cvtType ty
         ; c_ty    <- mk_arr_apps args ty'
-        ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
+        ; returnL $ mkGadtDecl c' c_ty}
 
 cvtConstr (RecGadtC c varstrtys ty)
   = do  { c'       <- mapM cNameL c
         ; ty'      <- cvtType ty
         ; rec_flds <- mapM cvt_id_arg varstrtys
         ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
-        ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
+        ; returnL $ mkGadtDecl c' rec_ty }
 
 cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
 cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 55d43fd058..a7ef5669f8 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -63,10 +63,8 @@ module HsDecls (
   CImportSpec(..),
   -- ** Data-constructor declarations
   ConDecl(..), LConDecl,
-  HsConDeclDetails, hsConDeclArgTys,
-  getConNames,
-  getConDetails,
-  gadtDeclDetails,
+  HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,
+  getConNames, getConArgs,
   -- ** Document comments
   DocDecl(..), LDocDecl, docDeclDoc,
   -- ** Deprecations
@@ -1151,8 +1149,16 @@ type LConDecl pass = Located (ConDecl pass)
 data ConDecl pass
   = ConDeclGADT
       { con_names   :: [Located (IdP pass)]
-      , con_type    :: LHsSigType pass
-        -- ^ The type after the ‘::’
+
+      -- The next four fields describe the type after the '::'
+      -- See Note [GADT abstract syntax]
+      , con_forall  :: Bool                    -- ^ True <=> explicit forall
+                                               -- False => hsq_explicit is empty
+      , con_qvars   :: LHsQTyVars pass
+      , con_mb_cxt  :: Maybe (LHsContext pass) -- ^ User-written context (if any)
+      , con_args    :: HsConDeclDetails pass   -- ^ Arguments; never InfixCon
+      , con_res_ty  :: LHsType pass            -- ^ Result type
+
       , con_doc     :: Maybe LHsDocString
           -- ^ A possible Haddock comment.
       }
@@ -1160,17 +1166,16 @@ data ConDecl pass
   | ConDeclH98
       { con_name    :: Located (IdP pass)
 
-      , con_qvars     :: Maybe (LHsQTyVars pass)
-        -- User-written forall (if any), and its implicit
-        -- kind variables
-        -- Non-Nothing means an explicit user-written forall
-        --     e.g. data T a = forall b. MkT b (b->a)
-        --     con_qvars = {b}
+      , con_forall  :: Bool   -- ^ True <=> explicit user-written forall
+                              --     e.g. data T a = forall b. MkT b (b->a)
+                              --     con_qvars = {b}
+                              -- False => hsq_implicit, hsq_explicit both empty
+      , con_qvars   :: LHsQTyVars pass    -- Existentials only
 
-      , con_cxt       :: Maybe (LHsContext pass)
-        -- ^ User-written context (if any)
+      , con_mb_cxt :: Maybe (LHsContext pass)
+         -- ^ User-written context (if any)
 
-      , con_details   :: HsConDeclDetails pass
+      , con_args   :: HsConDeclDetails pass
           -- ^ Arguments
 
       , con_doc       :: Maybe LHsDocString
@@ -1178,6 +1183,35 @@ data ConDecl pass
       }
 deriving instance (DataId pass) => Data (ConDecl pass)
 
+{- Note [GADT abstract syntax]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before the renamer, given:
+  data T a where
+    K :: forall a. Ord a => { x :: [a], ... } -> T a
+we make the a ConDeclGADT for K with
+   con_qvars  = {a}
+   con_mb_cxt = Just [Ord a]
+   con_args   = RecCon <the record fields>
+   con_res_ty = T a
+
+We need the RecCon so we can find the record field binders in
+HsUtils.hsConDeclsBinders.
+
+However for a GADT declaration which is not a record, we put the whole
+constr type into the res_ty for a ConDeclGADT for now, and use
+PrefixCon []; the renamer will unravel it once it has sorted out
+operator fixities. Consider for example
+     C :: a :*: b -> a :*: b -> a :+: b
+Initially this type will parse as
+      a :*: (b -> (a :*: (b -> (a :+: b))))
+so it's hard to split up the arguments until we've done the precedence
+resolution (in the renamer). So we generate
+   con_qvars  = {}   -- No explicit binders
+   con_mb_cxt = Nothing
+   con_args   = PrefixCon []
+   con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b))))
+-}
+
 -- | Haskell data Constructor Declaration Details
 type HsConDeclDetails pass
    = HsConDetails (LBangType pass) (Located [LConDeclField pass])
@@ -1186,36 +1220,21 @@ getConNames :: ConDecl pass -> [Located (IdP pass)]
 getConNames ConDeclH98  {con_name  = name}  = [name]
 getConNames ConDeclGADT {con_names = names} = names
 
--- don't call with RdrNames, because it can't deal with HsAppsTy
-getConDetails :: ConDecl pass -> HsConDeclDetails pass
-getConDetails ConDeclH98  {con_details  = details} = details
-getConDetails ConDeclGADT {con_type     = ty     } = details
-  where
-    (details,_,_,_) = gadtDeclDetails ty
-
--- don't call with RdrNames, because it can't deal with HsAppsTy
-gadtDeclDetails :: LHsSigType pass
-                -> ( HsConDeclDetails pass
-                   , LHsType pass
-                   , LHsContext pass
-                   , [LHsTyVarBndr pass] )
-gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs)
-  where
-    (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
-    (details, res_ty)           -- See Note [Sorting out the result type]
-      = case tau of
-          L _ (HsFunTy (L l (HsRecTy flds)) res_ty')
-                  -> (RecCon (L l flds), res_ty')
-          _other  -> (PrefixCon [], tau)
+getConArgs :: ConDecl pass -> HsConDeclDetails pass
+getConArgs d = con_args d
 
 hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass]
 hsConDeclArgTys (PrefixCon tys)    = tys
 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
 hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) (unLoc flds)
 
-pp_data_defn :: (SourceTextX pass, OutputableBndrId pass)
-                  => (HsContext pass -> SDoc)   -- Printing the header
-                  -> HsDataDefn pass
+hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass]
+hsConDeclTheta Nothing            = []
+hsConDeclTheta (Just (L _ theta)) = theta
+
+pp_data_defn :: (SourceTextX p, OutputableBndrId p)
+                  => (HsContext p -> SDoc)   -- Printing the header
+                  -> HsDataDefn p
                   -> SDoc
 pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
                                 , dd_cType = mb_ct
@@ -1258,27 +1277,36 @@ instance (SourceTextX pass, OutputableBndrId pass)
 
 pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc
 pprConDecl (ConDeclH98 { con_name = L _ con
-                       , con_qvars = mtvs
-                       , con_cxt = mcxt
-                       , con_details = details
+                       , con_qvars = qtvs
+                       , con_mb_cxt = mcxt
+                       , con_args = args
                        , con_doc = doc })
-  = sep [ppr_mbDoc doc, pprHsForAll tvs cxt,         ppr_details details]
+  = sep [ppr_mbDoc doc, pprHsForAll tvs cxt, ppr_details args]
   where
     ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
     ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con
                                    : map (pprHsType . unLoc) tys)
     ppr_details (RecCon fields)  = pprPrefixOcc con
                                  <+> pprConDeclFields (unLoc fields)
-    tvs = case mtvs of
-      Nothing -> []
-      Just (HsQTvs { hsq_explicit = tvs }) -> tvs
-
+    tvs = hsQTvExplicit qtvs
     cxt = fromMaybe (noLoc []) mcxt
 
-pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc })
-  = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
-         <+> ppr res_ty]
+pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
+                        , con_mb_cxt = mcxt, con_args = args 
+                        , con_res_ty = res_ty, con_doc = doc })
+  = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
+    <+> (sep [pprHsForAll (hsq_explicit qvars) cxt,
+              ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
+  where
+    get_args (PrefixCon args) = map ppr args
+    get_args (RecCon fields)  = [pprConDeclFields (unLoc fields)]
+    get_args (InfixCon {})    = pprPanic "pprConDecl:GADT" (ppr cons)
+
+    cxt = fromMaybe (noLoc []) mcxt
 
+    ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
+    ppr_arrow_chain []     = empty
+    
 ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc
 ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
 
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index f5b4149f99..10e2d00c0e 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -35,7 +35,7 @@ module HsTypes (
         SrcStrictness(..), SrcUnpackedness(..),
         getBangType, getBangStrictness,
 
-        ConDeclField(..), LConDeclField, pprConDeclFields, updateGadtResult,
+        ConDeclField(..), LConDeclField, pprConDeclFields,
 
         HsConDetails(..),
 
@@ -50,7 +50,7 @@ module HsTypes (
         mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
         mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
         mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,
-        isHsKindedTyVar, hsTvbAllKinded,
+        isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,
         hsScopedTvs, hsWcScopedTvs, dropWildCards,
         hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
         hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
@@ -59,7 +59,7 @@ module HsTypes (
         splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
         splitHsFunType, splitHsAppsTy,
         splitHsAppTys, getAppsTyHead_maybe, hsTyGetAppHead_maybe,
-        mkHsOpTy, mkHsAppTy, mkHsAppTys,
+        mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppsTy,
         ignoreParens, hsSigType, hsSigWcType,
         hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
 
@@ -93,7 +93,6 @@ import Maybes( isJust )
 
 import Data.Data hiding ( Fixity, Prefix, Infix )
 import Data.Maybe ( fromMaybe )
-import Control.Monad ( unless )
 
 {-
 ************************************************************************
@@ -785,30 +784,6 @@ instance (Outputable arg, Outputable rec)
   ppr (RecCon rec)     = text "RecCon:" <+> ppr rec
   ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r]
 
--- Takes details and result type of a GADT data constructor as created by the
--- parser and rejigs them using information about fixities from the renamer.
--- See Note [Sorting out the result type] in RdrHsSyn
-updateGadtResult
-  :: (Monad m)
-     => (SDoc -> m ())
-     -> SDoc
-     -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
-                     -- ^ Original details
-     -> LHsType GhcRn -- ^ Original result type
-     -> m (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
-           LHsType GhcRn)
-updateGadtResult failWith doc details ty
-  = do { let (arg_tys, res_ty) = splitHsFunType ty
-             badConSig         = text "Malformed constructor signature"
-       ; case details of
-           InfixCon {}  -> pprPanic "updateGadtResult" (ppr ty)
-
-           RecCon {}    -> do { unless (null arg_tys)
-                                       (failWith (doc <+> badConSig))
-                              ; return (details, res_ty) }
-
-           PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
-
 {-
 Note [ConDeclField passs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -917,9 +892,12 @@ sameWildCard :: Located (HsWildCardInfo pass)
 sameWildCard (L l1 (AnonWildCard _))   (L l2 (AnonWildCard _))   = l1 == l2
 
 ignoreParens :: LHsType pass -> LHsType pass
-ignoreParens (L _ (HsParTy ty))                      = ignoreParens ty
-ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty
-ignoreParens ty                                      = ty
+ignoreParens (L _ (HsParTy ty)) = ignoreParens ty
+ignoreParens ty                 = ty
+
+isLHsForAllTy :: LHsType p -> Bool
+isLHsForAllTy (L _ (HsForAllTy {})) = True
+isLHsForAllTy _                     = False
 
 {-
 ************************************************************************
@@ -941,6 +919,11 @@ mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
 mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass
 mkHsAppTys = foldl mkHsAppTy
 
+mkHsAppsTy :: [LHsAppType GhcPs] -> HsType GhcPs
+-- In the common case of a singleton non-operator,
+-- avoid the clutter of wrapping in a HsAppsTy
+mkHsAppsTy [L _ (HsAppPrefix (L _ ty))] = ty
+mkHsAppsTy app_tys                      = HsAppsTy app_tys
 
 {-
 ************************************************************************
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 8e17994993..67c0c3bc23 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -84,7 +84,6 @@ module HsUtils(
   hsLTyClDeclBinders, hsTyClForeignBinders,
   hsPatSynSelectors, getPatSynBinds,
   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
-  hsDataDefnBinders,
 
   -- Collecting implicit binders
   lStmtsImplicits, hsValBindsImplicits, lPatImplicits
@@ -1106,55 +1105,48 @@ hsDataDefnBinders (HsDataDefn { dd_cons = cons })
   -- See Note [Binders in family instances]
 
 -------------------
+type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass]
+                 -- Filters out ones that have already been seen
+
 hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
-  -- See hsLTyClDeclBinders for what this does
-  -- The function is boringly complicated because of the records
-  -- And since we only have equality, we have to be a little careful
-hsConDeclsBinders cons = go id cons
-  where go :: ([LFieldOcc pass] -> [LFieldOcc pass])
-           -> [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
-        go _ [] = ([], [])
-        go remSeen (r:rs) =
-          -- don't re-mangle the location of field names, because we don't
-          -- have a record of the full location of the field declaration anyway
-          case r of
-             -- remove only the first occurrence of any seen field in order to
-             -- avoid circumventing detection of duplicate fields (#9156)
-             L loc (ConDeclGADT { con_names = names
-                                , con_type = HsIB { hsib_body = res_ty}}) ->
-               case tau of
-                 L _ (HsFunTy
-                      (L _ (HsAppsTy
-                            [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty)
-                         -> record_gadt flds
-                 L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
-                         -> record_gadt flds
-
-                 _other  -> (map (L loc . unLoc) names ++ ns, fs)
-                            where (ns, fs) = go remSeen rs
-               where
-                 (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
-                 record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs)
-                   where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
-                         remSeen' = foldr (.) remSeen
-                                        [deleteBy ((==) `on`
-                                              unLoc . rdrNameFieldOcc . unLoc) v
-                                        | v <- r']
-                         (ns, fs) = go remSeen' rs
-
-             L loc (ConDeclH98 { con_name = name
-                               , con_details = RecCon flds }) ->
-               ([L loc (unLoc name)] ++ ns, r' ++ fs)
-                  where r' = remSeen (concatMap (cd_fld_names . unLoc)
-                                                (unLoc flds))
-                        remSeen'
-                          = foldr (.) remSeen
-                               [deleteBy ((==) `on`
-                                   unLoc . rdrNameFieldOcc . unLoc) v | v <- r']
-                        (ns, fs) = go remSeen' rs
-             L loc (ConDeclH98 { con_name = name }) ->
-                ([L loc (unLoc name)] ++ ns, fs)
-                  where (ns, fs) = go remSeen rs
+   -- See hsLTyClDeclBinders for what this does
+   -- The function is boringly complicated because of the records
+   -- And since we only have equality, we have to be a little careful
+hsConDeclsBinders cons
+  = go id cons
+  where
+    go :: Seen pass -> [LConDecl pass]
+       -> ([Located (IdP pass)], [LFieldOcc pass])
+    go _ [] = ([], [])
+    go remSeen (r:rs)
+      -- Don't re-mangle the location of field names, because we don't
+      -- have a record of the full location of the field declaration anyway
+      = case r of
+           -- remove only the first occurrence of any seen field in order to
+           -- avoid circumventing detection of duplicate fields (#9156)
+           L loc (ConDeclGADT { con_names = names, con_args = args })
+             -> (map (L loc . unLoc) names ++ ns, flds ++ fs)
+             where
+                (remSeen', flds) = get_flds remSeen args
+                (ns, fs) = go remSeen' rs
+
+           L loc (ConDeclH98 { con_name = name, con_args = args })
+             -> ([L loc (unLoc name)] ++ ns, flds ++ fs)
+             where
+                (remSeen', flds) = get_flds remSeen args
+                (ns, fs) = go remSeen' rs
+
+    get_flds :: Seen pass -> HsConDeclDetails pass
+             -> (Seen pass, [LFieldOcc pass])
+    get_flds remSeen (RecCon flds)
+       = (remSeen', fld_names)
+       where
+          fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))
+          remSeen' = foldr (.) remSeen
+                               [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v
+                               | v <- fld_names]
+    get_flds remSeen _
+       = (remSeen, [])
 
 {-
 
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index c60f51722f..69c8fdefd0 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1839,7 +1839,7 @@ typedoc :: { LHsType GhcPs }
 -- See Note [Parsing ~]
 btype :: { LHsType GhcPs }
         : tyapps                      {%  splitTildeApps (reverse (unLoc $1)) >>=
-                                          \ts -> return $ sL1 $1 $ HsAppsTy ts }
+                                          \ts -> return $ sL1 $1 $ mkHsAppsTy ts }
 
 -- Used for parsing Haskell98-style data constructors,
 -- in order to forbid the blasphemous
@@ -2064,7 +2064,7 @@ gadt_constr :: { LConDecl GhcPs }
     -- see Note [Difference in parsing GADT and data constructors]
     -- Returns a list because of:   C,D :: ty
         : con_list '::' sigtype
-                {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3)))
+                {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) $3))
                        [mu AnnDcolon $2] }
 
 {- Note [Difference in parsing GADT and data constructors]
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 126e92e7ad..fcc263fda0 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MagicHash #-}
 
 module   RdrHsSyn (
         mkHsOpApp,
@@ -68,7 +69,6 @@ module   RdrHsSyn (
     ) where
 
 import GhcPrelude
-
 import HsSyn            -- Lots of it
 import Class            ( FunDep )
 import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
@@ -555,21 +555,42 @@ mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
                 -> LHsContext GhcPs -> HsConDeclDetails GhcPs
                 -> ConDecl GhcPs
 
-mkConDeclH98 name mb_forall cxt details
-  = ConDeclH98 { con_name     = name
-               , con_qvars    = fmap mkHsQTvs mb_forall
-               , con_cxt      = Just cxt
+mkConDeclH98 name mb_forall cxt args
+  = ConDeclH98 { con_name   = name
+               , con_forall = isJust mb_forall
+               , con_qvars  = mkHsQTvs (mb_forall `orElse` [])
+               , con_mb_cxt = Just cxt
                              -- AZ:TODO: when can cxt be Nothing?
                              --          remembering that () is a valid context.
-               , con_details  = details
-               , con_doc      = Nothing }
+               , con_args  = args
+               , con_doc   = Nothing }
 
 mkGadtDecl :: [Located RdrName]
-           -> LHsSigType GhcPs     -- Always a HsForAllTy
+           -> LHsType GhcPs     -- Always a HsForAllTy
            -> ConDecl GhcPs
-mkGadtDecl names ty = ConDeclGADT { con_names = names
-                                  , con_type  = ty
-                                  , con_doc   = Nothing }
+mkGadtDecl names ty
+  = ConDeclGADT { con_names  = names
+                , con_forall = isLHsForAllTy ty
+                , con_qvars  = mkHsQTvs tvs
+                , con_mb_cxt = mcxt
+                , con_args   = args
+                , con_res_ty = res_ty
+                , con_doc    = Nothing }
+  where
+    (tvs, rho) = splitLHsForAllTy ty
+    (mcxt, tau) = split_rho rho
+
+    split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau }))
+                                 = (Just cxt, tau)
+    split_rho (L _ (HsParTy ty)) = split_rho ty
+    split_rho tau                = (Nothing, tau)
+
+    (args, res_ty) = split_tau tau
+
+    split_tau (L _ (HsFunTy (L loc (HsRecTy rf)) res_ty))
+                                 = (RecCon (L loc rf), res_ty)
+    split_tau (L _ (HsParTy ty)) = split_tau ty
+    split_tau tau                = (PrefixCon [], tau)
 
 setRdrNameSpace :: RdrName -> NameSpace -> RdrName
 -- ^ This rather gruesome function is used mainly by the parser.
@@ -694,13 +715,10 @@ checkTyVars pp_what equals_or_where tc tparms
   = do { tvs <- mapM chk tparms
        ; return (mkHsQTvs tvs) }
   where
-
     chk (L _ (HsParTy ty)) = chk ty
-    chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty
 
         -- Check that the name space is correct!
-    chk (L l (HsKindSig
-            (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k))
+    chk (L l (HsKindSig (L lv (HsTyVar _ (L _ tv))) k))
         | isRdrTyVar tv    = return (L l (KindedTyVar (L lv tv) k))
     chk (L l (HsTyVar _ (L ltv tv)))
         | isRdrTyVar tv    = return (L l (UserTyVar (L ltv tv)))
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index b1dc8877b5..60c8b1b7dd 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -639,24 +639,16 @@ getLocalNonValBinders fixity_env
                -> [(Name, [FieldLabel])]
     mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
       where
-        find_con_flds (L _ (ConDeclH98 { con_name    = L _ rdr
-                                       , con_details = RecCon cdflds }))
+        find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr
+                                       , con_args = RecCon cdflds }))
             = [( find_con_name rdr
                , concatMap find_con_decl_flds (unLoc cdflds) )]
-        find_con_flds (L _ (ConDeclGADT
-                              { con_names = rdrs
-                              , con_type = (HsIB { hsib_body = res_ty})}))
-            = map (\ (L _ rdr) -> ( find_con_name rdr
-                                  , concatMap find_con_decl_flds cdflds))
-                  rdrs
-            where
-              (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
-              cdflds = case tau of
-                 L _ (HsFunTy
-                      (L _ (HsAppsTy
-                        [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds
-                 L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds
-                 _                                    -> []
+        find_con_flds (L _ (ConDeclGADT { con_names = rdrs
+                                        , con_args = RecCon flds }))
+            = [ ( find_con_name rdr
+                 , concatMap find_con_decl_flds (unLoc flds))
+              | L _ rdr <- rdrs ]
+
         find_con_flds _ = []
 
         find_con_name rdr
@@ -664,6 +656,7 @@ getLocalNonValBinders fixity_env
               find (\ n -> nameOccName n == rdrNameOcc rdr) names
         find_con_decl_flds (L _ x)
           = map find_con_decl_fld (cd_fld_names x)
+
         find_con_decl_fld  (L _ (FieldOcc (L _ rdr) _))
           = expectJust "getLocalNonValBinders/find_con_decl_fld" $
               find (\ fl -> flLabel fl == lbl) flds
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index b182382381..f12c2d316b 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -52,7 +52,6 @@ import Avail
 import Outputable
 import Bag
 import BasicTypes       ( DerivStrategy, RuleName, pprRuleName )
-import Maybes           ( orElse )
 import FastString
 import SrcLoc
 import DynFlags
@@ -1656,6 +1655,7 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
        ; typeintype <- xoptM LangExt.TypeInType
        ; let cusk = hsTvbAllKinded tyvars' &&
                     (not typeintype || no_rhs_kvs)
+       ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
        ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
                           , tcdFixity = fixity
                           , tcdDataDefn = defn', tcdDataCusk = cusk
@@ -1993,51 +1993,89 @@ rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
 
 rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
 rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
-                           , con_cxt = mcxt, con_details = details
+                           , con_mb_cxt = mcxt, con_args = args
                            , con_doc = mb_doc })
-  = do  { _ <- addLocM checkConName name
-        ; new_name     <- lookupLocatedTopBndrRn name
-        ; mb_doc'      <- rnMbLHsDoc mb_doc
-
-        ; let doc      = ConDeclCtx [new_name]
-              qtvs'    = qtvs `orElse` mkHsQTvs []
-              body_kvs = []  -- Consider   data T a = forall (b::k). MkT (...)
-                             -- The 'k' will already be in scope from the
-                             -- bindHsQTyVars for the entire DataDecl
-                             -- So there can be no new body_kvs here
-        ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing body_kvs qtvs' $
-          \new_tyvars _ -> do
-        { (new_context, fvs1) <- case mcxt of
-                             Nothing   -> return (Nothing,emptyFVs)
-                             Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
-                                             ; return (Just lctx',fvs) }
-        ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
-        ; let (new_details',fvs3) = (new_details,emptyFVs)
+  = do  { _        <- addLocM checkConName name
+        ; new_name <- lookupLocatedTopBndrRn name
+        ; mb_doc'  <- rnMbLHsDoc mb_doc
+
+        -- We bind no implicit binders here; this is just like
+        -- a nested HsForAllTy.  E.g. consider
+        --         data T a = forall (b::k). MkT (...)
+        -- The 'k' will already be in scope from the bindHsQTyVars
+        -- for the data decl itself. So we'll get
+        --         data T {k} a = ...
+        -- And indeed we may later discover (a::k).  But that's the
+        -- scoping we get.  So no implicit binders at the existential forall
+
+        ; let ctxt = ConDeclCtx [new_name]
+        ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))
+                            Nothing (hsQTvExplicit qtvs) $ \ tv_bndrs ->
+    do  { (new_context, fvs1) <- rnMbContext ctxt mcxt
+        ; (new_args,    fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args
+        ; let all_fvs  = fvs1 `plusFV` fvs2
+              new_qtvs =  HsQTvs { hsq_implicit  = []
+                                 , hsq_explicit  = tv_bndrs
+                                 , hsq_dependent = emptyNameSet }
         ; traceRn "rnConDecl" (ppr name <+> vcat
              [ text "qtvs:" <+> ppr qtvs
-             , text "qtvs':" <+> ppr qtvs' ])
-        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
-              new_tyvars' = case qtvs of
-                Nothing -> Nothing
-                Just _ -> Just new_tyvars
-        ; return (decl { con_name = new_name, con_qvars = new_tyvars'
-                       , con_cxt = new_context, con_details = new_details'
+             , text "qtvs':" <+> ppr new_qtvs ])
+
+        ; return (decl { con_name = new_name, con_qvars = new_qtvs
+                       , con_mb_cxt = new_context, con_args = new_args
                        , con_doc = mb_doc' },
                   all_fvs) }}
 
-rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
+rnConDecl decl@(ConDeclGADT { con_names   = names
+                            , con_forall  = explicit_forall
+                            , con_qvars   = qtvs
+                            , con_mb_cxt  = mcxt
+                            , con_args    = args
+                            , con_res_ty  = res_ty
                             , con_doc = mb_doc })
   = do  { mapM_ (addLocM checkConName) names
-        ; new_names    <- mapM lookupLocatedTopBndrRn names
-        ; let doc = ConDeclCtx new_names
-        ; mb_doc'      <- rnMbLHsDoc mb_doc
-
-        ; (ty', fvs) <- rnHsSigType doc ty
-        ; traceRn "rnConDecl" (ppr names <+> vcat
-             [ text "fvs:" <+> ppr fvs ])
-        ; return (decl { con_names = new_names, con_type = ty'
+        ; new_names <- mapM lookupLocatedTopBndrRn names
+        ; mb_doc'   <- rnMbLHsDoc mb_doc
+
+        ; let explicit_tkvs = hsQTvExplicit qtvs
+              theta         = hsConDeclTheta mcxt
+              arg_tys       = hsConDeclArgTys args
+        ; free_tkvs <- extractHsTysRdrTyVarsDups (res_ty : theta ++ arg_tys)
+        ; free_tkvs <- extractHsTvBndrs explicit_tkvs free_tkvs
+
+        ; let ctxt    = ConDeclCtx new_names
+              mb_ctxt = Just (inHsDocContext ctxt)
+
+        ; rnImplicitBndrs (not explicit_forall) ctxt free_tkvs $ \ implicit_tkvs ->
+          bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->
+    do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt
+        ; (new_args, fvs2)   <- rnConDeclDetails (unLoc (head new_names)) ctxt args
+        ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
+
+        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
+              (args', res_ty')
+                  = case args of
+                      InfixCon {}  -> pprPanic "rnConDecl" (ppr names)
+                      RecCon {}    -> (new_args, new_res_ty)
+                      PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty
+                                   -> ASSERT( null as )
+                                      (PrefixCon arg_tys, final_res_ty)
+
+              new_qtvs =  HsQTvs { hsq_implicit  = implicit_tkvs
+                                 , hsq_explicit  = explicit_tkvs
+                                 , hsq_dependent = emptyNameSet }
+
+        ; return (decl { con_names = new_names
+                       , con_qvars = new_qtvs, con_mb_cxt = new_cxt
+                       , con_args = args', con_res_ty = res_ty'
                        , con_doc = mb_doc' },
-                  fvs) }
+                  all_fvs) } }
+
+rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
+            -> RnM (Maybe (LHsContext GhcRn), FreeVars)
+rnMbContext _    Nothing    = return (Nothing, emptyFVs)
+rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt
+                                ; return (Just ctx',fvs) }
 
 rnConDeclDetails
    :: Name
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index dd66cd3aec..1594989bff 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -23,13 +23,14 @@ module RnTypes (
         checkPrecMatch, checkSectionPrec,
 
         -- Binding related stuff
-        bindLHsTyVarBndr,
+        bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
         bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
         extractFilteredRdrTyVars, extractFilteredRdrTyVarsDups,
         extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
         extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars,
         extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
         extractRdrKindSigVars, extractDataDefnKindVars,
+        extractHsTvBndrs,
         freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars,
         elemRdr
   ) where
@@ -59,6 +60,7 @@ import NameSet
 import FieldLabel
 
 import Util
+import ListSetOps       ( deleteBys )
 import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
                           Fixity(..), FixityDirection(..), LexicalFixity(..) )
 import Outputable
@@ -66,7 +68,7 @@ import FastString
 import Maybes
 import qualified GHC.LanguageExtensions as LangExt
 
-import Data.List          ( nubBy, partition )
+import Data.List          ( nubBy, partition, (\\) )
 import Control.Monad      ( unless, when )
 
 #include "HsVersions.h"
@@ -85,7 +87,7 @@ to break several loop.
 rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs
             -> RnM (LHsSigWcType GhcRn, FreeVars)
 rnHsSigWcType doc sig_ty
-  = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' ->
+  = rn_hs_sig_wc_type False doc sig_ty $ \sig_ty' ->
     return (sig_ty', emptyFVs)
 
 rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
@@ -99,26 +101,31 @@ rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
 rnHsSigWcTypeScoped ctx sig_ty thing_inside
   = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
        ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
-       ; rn_hs_sig_wc_type False ctx sig_ty thing_inside
+       ; rn_hs_sig_wc_type True ctx sig_ty thing_inside
        }
-    -- False: for pattern type sigs and rules we /do/ want
-    --        to bring those type variables into scope
+    -- True: for pattern type sigs and rules we /do/ want
+    --       to bring those type variables into scope, even
+    --       if there's a forall at the top which usually
+    --       stops that happening
     -- e.g  \ (x :: forall a. a-> b) -> e
     -- Here we do bring 'b' into scope
 
-rn_hs_sig_wc_type :: Bool   -- see rnImplicitBndrs
+rn_hs_sig_wc_type :: Bool   -- True <=> always bind any free tyvars of the
+                            --          type, regardless of whether it has
+                            --          a forall at the top
                   -> HsDocContext
                   -> LHsSigWcType GhcPs
                   -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
                   -> RnM (a, FreeVars)
 -- rn_hs_sig_wc_type is used for source-language type signatures
-rn_hs_sig_wc_type no_implicit_if_forall ctxt
+rn_hs_sig_wc_type always_bind_free_tvs ctxt
                   (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
                   thing_inside
   = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
        ; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars
        ; let nwc_rdrs = nubL nwc_rdrs'
-       ; rnImplicitBndrs no_implicit_if_forall ctxt hs_ty tv_rdrs $ \ vars ->
+             bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty)
+       ; rnImplicitBndrs bind_free_tvs ctxt tv_rdrs $ \ vars ->
     do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
        ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = ib_ty' }
              ib_ty'  = mk_implicit_bndrs vars hs_ty' fvs1
@@ -265,32 +272,31 @@ rnHsSigType :: HsDocContext -> LHsSigType GhcPs
 rnHsSigType ctx (HsIB { hsib_body = hs_ty })
   = do { traceRn "rnHsSigType" (ppr hs_ty)
        ; vars <- extractFilteredRdrTyVarsDups hs_ty
-       ; rnImplicitBndrs True ctx hs_ty vars $ \ vars ->
+       ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) ctx vars $ \ vars ->
     do { (body', fvs) <- rnLHsType ctx hs_ty
        ; return ( mk_implicit_bndrs vars body' fvs, fvs ) } }
 
-rnImplicitBndrs :: Bool    -- True <=> no implicit quantification
-                           --          if type is headed by a forall
+rnImplicitBndrs :: Bool    -- True <=> bring into scope any free type variables
                            -- E.g.  f :: forall a. a->b
-                           -- Do not quantify over 'b' too.
+                           --  we do not want to bring 'b' into scope, hence False
+                           -- But   f :: a -> b
+                           --  we want to bring both 'a' and 'b' into scope
                 -> HsDocContext
-                -> LHsType GhcPs   -- hs_ty: the type over which the
-                                   -- implicit binders will scope
                 -> FreeKiTyVarsWithDups
                                    -- Free vars of hs_ty (excluding wildcards)
                                    -- May have duplicates, which is
                                    -- checked here
                 -> ([Name] -> RnM (a, FreeVars))
                 -> RnM (a, FreeVars)
-rnImplicitBndrs no_implicit_if_forall doc (L loc hs_ty)
+rnImplicitBndrs bind_free_tvs doc
                 fvs_with_dups@(FKTV { fktv_kis = kvs_with_dups
                                     , fktv_tys = tvs_with_dups })
                 thing_inside
   = do { let FKTV kvs tvs = rmDupsInRdrTyVars fvs_with_dups
-             real_tvs | no_implicit_if_forall
-                      , HsForAllTy {} <- hs_ty = []
-                      | otherwise              = tvs
-             -- Quantify over type variables only if there is no
+             real_tvs | bind_free_tvs = tvs
+                      | otherwise         = []
+             -- We always bind over free /kind/ variables.
+             -- Bind free /type/ variables only if there is no
              -- explicit forall.  E.g.
              --    f :: Proxy (a :: k) -> b
              --         Quantify over {k} and {a,b}
@@ -300,8 +306,9 @@ rnImplicitBndrs no_implicit_if_forall doc (L loc hs_ty)
              -- but, rather arbitrarily, we switch off the type-quantification
              -- if there is an explicit forall
 
-       ; traceRn "rnImplicitBndrs" (vcat [ ppr hs_ty, ppr kvs, ppr tvs, ppr real_tvs ])
+       ; traceRn "rnImplicitBndrs" (vcat [ ppr kvs, ppr tvs, ppr real_tvs ])
 
+       ; loc <- getSrcSpanM
        ; vars <- mapM (newLocalBndrRn . L loc . unLoc) (kvs ++ real_tvs)
 
        ; checkBadKindBndrs doc kvs
@@ -898,23 +905,24 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
 
        ; let -- See Note [bindHsQTyVars examples] for what
              -- all these various things are doing
-             bndrs, kv_occs, implicit_bndr_kvs,
-                    implicit_body_kvs, implicit_kvs :: [Located RdrName]
-             bndrs             = map hsLTyVarLocName hs_tv_bndrs
-             kv_occs           = body_kv_occs ++ bndr_kv_occs
-             implicit_bndr_kvs = filter_occs rdr_env bndrs bndr_kv_occs
-             implicit_body_kvs = filter_occs rdr_env (implicit_bndr_kvs ++ bndrs) body_kv_occs
+             bndrs, kv_occs, implicit_kvs :: [Located RdrName]
+             bndrs        = map hsLTyVarLocName hs_tv_bndrs
+             kv_occs      = nubL (body_kv_occs ++ bndr_kv_occs)
+             implicit_kvs = filter_occs rdr_env bndrs kv_occs
                                  -- Deleting bndrs: See Note [Kind-variable ordering]
-             implicit_kvs      = implicit_bndr_kvs ++ implicit_body_kvs
-
              -- dep_bndrs is the subset of bndrs that are dependent
              --   i.e. appear in bndr/body_kv_occs
              -- Can't use implicit_kvs because we've deleted bndrs from that!
              dep_bndrs = filter (`elemRdr` kv_occs) bndrs
+             del       = deleteBys eqLocated
+             all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)
 
        ; traceRn "checkMixedVars3" $
            vcat [ text "kv_occs" <+> ppr kv_occs
-                , text "bndrs"   <+> ppr bndrs ]
+                , text "bndrs"   <+> ppr hs_tv_bndrs
+                , text "bndr_kv_occs"   <+> ppr bndr_kv_occs
+                , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs)
+                ]
        ; checkBadKindBndrs doc implicit_kvs
        ; checkMixedVars kv_occs bndrs
 
@@ -927,7 +935,7 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
        ; thing_inside (HsQTvs { hsq_implicit  = implicit_kv_nms
                               , hsq_explicit  = rn_bndrs
                               , hsq_dependent = mkNameSet dep_bndr_nms })
-                      (null implicit_body_kvs) } }
+                      all_bound_on_lhs } }
 
   where
     filter_occs :: LocalRdrEnv         -- In scope
@@ -957,15 +965,10 @@ Then:
   body_kv_occs = [k2,k1], kind variables free in the
                           result kind signature
 
-  implicit_bndr_kvs = [k1], kind variables free in kind signatures
-                            of hs_tv_bndrs, and not bound by bndrs
-
-  implicit_body_kvs = [k2], kind variables free in the result kind
-                            signature, and not bound either by
-                            bndrs or by implicit_bndr_kvs
+  implicit_kvs = [k1,k2], kind variables free in kind signatures
+                          of hs_tv_bndrs, and not bound by bndrs
 
-* We want to quantify add implicit bindings for
-  implicit_bndr_kvs and implicit_body_kvs
+* We want to quantify add implicit bindings for implicit_kvs
 
 * The "dependent" bndrs (hsq_dependent) are the subset of
   bndrs that are free in bndr_kv_occs or body_kv_occs
@@ -1740,10 +1743,10 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
   where
     extract_con (ConDeclGADT { }) acc = return acc
     extract_con (ConDeclH98 { con_qvars = qvs
-                            , con_cxt = ctxt, con_details = details }) acc
-      = extract_hs_tv_bndrs (maybe [] hsQTvExplicit qvs) acc =<<
+                            , con_mb_cxt = ctxt, con_args = args }) acc
+      = extract_hs_tv_bndrs (hsQTvExplicit qvs) acc =<<
         extract_mlctxt ctxt =<<
-        extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV
+        extract_ltys TypeLevel (hsConDeclArgTys args) emptyFKTV
 
 extract_mlctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_mlctxt Nothing     acc = return acc
@@ -1815,6 +1818,12 @@ extract_app :: TypeOrKind -> LHsAppType GhcPs -> FreeKiTyVars
 extract_app t_or_k (L _ (HsAppInfix tv))  acc = extract_tv t_or_k tv acc
 extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc
 
+extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
+                 -> FreeKiTyVars           -- Free in body
+                 -> RnM FreeKiTyVars       -- Free in result
+extractHsTvBndrs tv_bndrs body_fvs
+  = extract_hs_tv_bndrs tv_bndrs emptyFKTV body_fvs
+
 extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVars
                     -> FreeKiTyVars -> RnM FreeKiTyVars
 -- In (forall (a :: Maybe e). a -> b) we have
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 10794e2d2b..cc826b9401 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -32,7 +32,7 @@ module TcHsType (
         tcHsLiftedType,   tcHsOpenType,
         tcHsLiftedTypeNC, tcHsOpenTypeNC,
         tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType,
-        tcHsContext, tcLHsPredType, tcInferApps,
+        tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps,
         solveEqualities, -- useful re-export
 
         typeLevelMode, kindLevelMode,
@@ -983,6 +983,10 @@ instantiateTyUntilN mb_kind_env n ty ki
     instantiateTyN mb_kind_env num_to_inst ty bndrs inner_ki
 
 ---------------------------
+tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]
+tcHsMbContext Nothing    = return []
+tcHsMbContext (Just cxt) = tcHsContext cxt
+
 tcHsContext :: LHsContext GhcRn -> TcM [PredType]
 tcHsContext = tc_hs_context typeLevelMode
 
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index b6fe855efa..539ec214c7 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -624,33 +624,41 @@ kcTyClDecl (FamDecl (FamilyDecl { fdLName  = L _ fam_tc_name
 -------------------
 kcConDecl :: ConDecl GhcRn -> TcM ()
 kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
-                      , con_cxt = ex_ctxt, con_details = details })
+                      , con_mb_cxt = ex_ctxt, con_args = args })
   = addErrCtxt (dataConCtxtName [name]) $
          -- the 'False' says that the existentials don't have a CUSK, as the
          -- concept doesn't really apply here. We just need to bring the variables
          -- into scope. (Similarly, the choice of PromotedDataConFlavour isn't
          -- particularly important.)
     do { _ <- kcHsTyVarBndrs (unLoc name) PromotedDataConFlavour
-                             False False
-                             ((fromMaybe emptyLHsQTvs ex_tvs)) $
-              do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt)
-                 ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)
+                             False False ex_tvs $
+              do { _ <- tcHsMbContext ex_ctxt
+                 ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)
                  ; return (panic "kcConDecl", ()) }
               -- We don't need to check the telescope here, because that's
               -- done in tcConDecl
        ; return () }
 
 kcConDecl (ConDeclGADT { con_names = names
-                       , con_type = ty })
-  = addErrCtxt (dataConCtxtName names) $
-      do { _ <- tcGadtSigType (ppr names) (unLoc $ head names) ty
-                -- Even though the data constructor's type is closed, we
-                -- must still call tcGadtSigType, because that influences
-                -- the inferred kind of the /type/ constructor.  Example:
-                --    data T f a where
-                --      MkT :: f a -> T f a
-                -- If we don't look at MkT we won't get the correct kind
-                -- for the type constructor T
+                       , con_qvars = qtvs, con_mb_cxt = cxt
+                       , con_args = args, con_res_ty = res_ty })
+  | HsQTvs { hsq_implicit = implicit_tkv_nms
+           , hsq_explicit = explicit_tkv_nms } <- qtvs
+  = -- Even though the data constructor's type is closed, we
+    -- must still kind-check the type, because that may influence
+    -- the inferred kind of the /type/ constructor.  Example:
+    --    data T f a where
+    --      MkT :: f a -> T f a
+    -- If we don't look at MkT we won't get the correct kind
+    -- for the type constructor T
+    addErrCtxt (dataConCtxtName names) $
+    do { _ <- solveEqualities $
+              tcImplicitTKBndrs implicit_tkv_nms $
+              tcExplicitTKBndrs explicit_tkv_nms $ \ _ ->
+              do { _ <- tcHsMbContext cxt
+                 ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)
+                 ; _ <- tcHsOpenType res_ty
+                 ; return (panic "kcConDecl", emptyVarSet) }
          ; return () }
 
 {-
@@ -1641,28 +1649,26 @@ tcConDecl :: TyCon             -- Representation tycon. Knot-tied!
 
 tcConDecl rep_tycon tmpl_bndrs res_tmpl
           (ConDeclH98 { con_name = name
-                      , con_qvars = hs_qvars, con_cxt = hs_ctxt
-                      , con_details = hs_details })
+                      , con_qvars = hs_qvars
+                      , con_mb_cxt = hs_ctxt
+                      , con_args = hs_args })
+  | HsQTvs { hsq_implicit = implicit_tkv_nms
+           , hsq_explicit = explicit_tkv_nms } <- hs_qvars
   = addErrCtxt (dataConCtxtName [name]) $
     do { -- Get hold of the existential type variables
          -- e.g. data T a = forall (b::k) f. MkT a (f b)
          -- Here tmpl_bndrs = {a}
-         --          hs_kvs = {k}
-         --          hs_tvs = {f,b}
-       ; let (hs_kvs, hs_tvs) = case hs_qvars of
-               Nothing -> ([], [])
-               Just (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs })
-                       -> (kvs, tvs)
+         --      hs_qvars = HsQTvs { hsq_implicit = {k}
+         --                        , hsq_explicit = {f,b} }
 
-       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr hs_kvs, ppr hs_tvs ])
+       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr hs_qvars ])
 
        ; (imp_tvs, (exp_tvs, ctxt, arg_tys, field_lbls, stricts))
            <- solveEqualities $
-              tcImplicitTKBndrs hs_kvs $
-              tcExplicitTKBndrs hs_tvs $ \ exp_tvs ->
-              do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs)
-                 ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt)
-                 ; btys <- tcConArgs hs_details
+              tcImplicitTKBndrs implicit_tkv_nms $
+              tcExplicitTKBndrs explicit_tkv_nms $ \ exp_tvs ->
+              do { ctxt <- tcHsMbContext hs_ctxt
+                 ; btys <- tcConArgs hs_args
                  ; field_lbls <- lookupConstructorFields (unLoc name)
                  ; let (arg_tys, stricts) = unzip btys
                        bound_vars  = allBoundVariabless ctxt `unionVarSet`
@@ -1711,7 +1717,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
            -- See Note [DataCon user type variable binders] in DataCon.
            user_tvbs = univ_tvbs ++ ex_tvbs
            buildOneDataCon (L _ name) = do
-             { is_infix <- tcConIsInfixH98 name hs_details
+             { is_infix <- tcConIsInfixH98 name hs_args
              ; rep_nm   <- newTyConRepName name
 
              ; buildDataCon fam_envs name is_infix rep_nm
@@ -1728,11 +1734,31 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
        }
 
 tcConDecl rep_tycon tmpl_bndrs res_tmpl
-          (ConDeclGADT { con_names = names, con_type = ty })
+          (ConDeclGADT { con_names = names
+                       , con_qvars = qtvs
+                       , con_mb_cxt = cxt, con_args = hs_args
+                       , con_res_ty = res_ty })
+  | HsQTvs { hsq_implicit = implicit_tkv_nms
+           , hsq_explicit = explicit_tkv_nms } <- qtvs
   = addErrCtxt (dataConCtxtName names) $
     do { traceTc "tcConDecl 1" (ppr names)
-       ; (user_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details)
-           <- tcGadtSigType (ppr names) (unLoc $ head names) ty
+       ; let (L _ name : _) = names
+
+       ; (imp_tvs, (exp_tvs, ctxt, arg_tys, res_ty, field_lbls, stricts))
+           <- solveEqualities $
+              tcImplicitTKBndrs implicit_tkv_nms $
+              tcExplicitTKBndrs explicit_tkv_nms $ \ exp_tvs ->
+              do { ctxt <- tcHsMbContext cxt
+                 ; btys <- tcConArgs hs_args
+                 ; res_ty' <- tcHsLiftedType res_ty
+                 ; field_lbls <- lookupConstructorFields name
+                 ; let (arg_tys, stricts) = unzip btys
+                       bound_vars = allBoundVariabless ctxt `unionVarSet`
+                                    allBoundVariabless arg_tys
+
+                 ; return ((exp_tvs, ctxt, arg_tys, res_ty', field_lbls, stricts), bound_vars)
+                 }
+       ; let user_tvs = imp_tvs ++ exp_tvs
 
        ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys user_tvs $
                                             mkFunTys ctxt $
@@ -1771,7 +1797,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
        ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
        ; let
            buildOneDataCon (L _ name) = do
-             { is_infix <- tcConIsInfixGADT name hs_details
+             { is_infix <- tcConIsInfixGADT name hs_args
              ; rep_nm   <- newTyConRepName name
 
              ; buildDataCon fam_envs name is_infix
@@ -1787,31 +1813,6 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
        ; mapM buildOneDataCon names
        }
 
-
-tcGadtSigType :: SDoc -> Name -> LHsSigType GhcRn
-              -> TcM ( [TcTyVar], [PredType],[HsSrcBang], [FieldLabel], [Type], Type
-                     , HsConDetails (LHsType GhcRn)
-                                    (Located [LConDeclField GhcRn]) )
-tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })
-  = do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty
-       ; (hs_details, res_ty) <- updateGadtResult failWithTc doc hs_details' res_ty'
-       ; (imp_tvs, (exp_tvs, ctxt, arg_tys, res_ty, field_lbls, stricts))
-           <- solveEqualities $
-              tcImplicitTKBndrs vars $
-              tcExplicitTKBndrs gtvs $ \ exp_tvs ->
-              do { ctxt <- tcHsContext cxt
-                 ; btys <- tcConArgs hs_details
-                 ; ty' <- tcHsLiftedType res_ty
-                 ; field_lbls <- lookupConstructorFields name
-                 ; let (arg_tys, stricts) = unzip btys
-                       bound_vars = allBoundVariabless ctxt `unionVarSet`
-                                    allBoundVariabless arg_tys
-
-                 ; return ((exp_tvs, ctxt, arg_tys, ty', field_lbls, stricts), bound_vars)
-                 }
-       ; return (imp_tvs ++ exp_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty, hs_details)
-       }
-
 tcConIsInfixH98 :: Name
              -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
              -> TcM Bool
diff --git a/compiler/utils/ListSetOps.hs b/compiler/utils/ListSetOps.hs
index c311ac9c85..a0fd9879bc 100644
--- a/compiler/utils/ListSetOps.hs
+++ b/compiler/utils/ListSetOps.hs
@@ -8,7 +8,7 @@
 {-# LANGUAGE CPP #-}
 
 module ListSetOps (
-        unionLists, minusList,
+        unionLists, minusList, deleteBys,
 
         -- Association lists
         Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
@@ -37,6 +37,11 @@ getNth :: Outputable a => [a] -> Int -> a
 getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
              xs !! n
 
+deleteBys :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+-- (deleteBys eq xs ys) returns xs-ys, using the given equality function
+-- Just like 'Data.List.delete' but with an equality function
+deleteBys eq xs ys = foldl (flip (deleteBy eq)) xs ys
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index 46ab21412e..1c7a2800e0 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -30,7 +30,11 @@
           ({ DumpParsedAst.hs:5:14-17 }
            (Unqual
             {OccName: Zero}))
-          (Nothing)
+          (False)
+          (HsQTvs
+           (PlaceHolder)
+           []
+           (PlaceHolder))
           (Just
            ({ <no location info> }
             []))
@@ -42,7 +46,11 @@
           ({ DumpParsedAst.hs:5:21-24 }
            (Unqual
             {OccName: Succ}))
-          (Nothing)
+          (False)
+          (HsQTvs
+           (PlaceHolder)
+           []
+           (PlaceHolder))
           (Just
            ({ <no location info> }
             []))
@@ -144,15 +152,11 @@
                 []))]
              (Prefix)
              ({ DumpParsedAst.hs:9:21-24 }
-              (HsAppsTy
-               [({ DumpParsedAst.hs:9:21-24 }
-                 (HsAppPrefix
-                  ({ DumpParsedAst.hs:9:21-24 }
-                   (HsTyVar
-                    (NotPromoted)
-                    ({ DumpParsedAst.hs:9:21-24 }
-                     (Unqual
-                      {OccName: Zero}))))))])))
+              (HsTyVar
+               (NotPromoted)
+               ({ DumpParsedAst.hs:9:21-24 }
+                (Unqual
+                 {OccName: Zero})))))
             (PlaceHolder)))]))
        ({ DumpParsedAst.hs:7:13-18 }
         (Unqual
@@ -165,35 +169,23 @@
             (Unqual
              {OccName: as}))
            ({ DumpParsedAst.hs:7:27-29 }
-            (HsAppsTy
-             [({ DumpParsedAst.hs:7:27-29 }
-               (HsAppPrefix
-                ({ DumpParsedAst.hs:7:27-29 }
-                 (HsListTy
-                  ({ DumpParsedAst.hs:7:28 }
-                   (HsAppsTy
-                    [({ DumpParsedAst.hs:7:28 }
-                      (HsAppPrefix
-                       ({ DumpParsedAst.hs:7:28 }
-                        (HsTyVar
-                         (NotPromoted)
-                         ({ DumpParsedAst.hs:7:28 }
-                          (Unqual
-                           {OccName: k}))))))]))))))]))))]
+            (HsListTy
+             ({ DumpParsedAst.hs:7:28 }
+              (HsTyVar
+               (NotPromoted)
+               ({ DumpParsedAst.hs:7:28 }
+                (Unqual
+                 {OccName: k}))))))))]
         (PlaceHolder))
        (Prefix)
        ({ DumpParsedAst.hs:7:32-39 }
         (KindSig
          ({ DumpParsedAst.hs:7:35-39 }
-          (HsAppsTy
-           [({ DumpParsedAst.hs:7:35-39 }
-             (HsAppPrefix
-              ({ DumpParsedAst.hs:7:35-39 }
-               (HsTyVar
-                (NotPromoted)
-                ({ DumpParsedAst.hs:7:35-39 }
-                 (Unqual
-                  {OccName: Peano}))))))]))))
+          (HsTyVar
+           (NotPromoted)
+           ({ DumpParsedAst.hs:7:35-39 }
+            (Unqual
+             {OccName: Peano}))))))
        (Nothing)))))
   ,({ DumpParsedAst.hs:11:1-23 }
     (ValD
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index c7daf90ff0..a9fb5412ea 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -70,7 +70,12 @@
            (ConDeclH98
             ({ DumpRenamedAst.hs:6:14-17 }
              {Name: DumpRenamedAst.Zero})
-            (Nothing)
+            (False)
+            (HsQTvs
+             []
+             []
+             {NameSet:
+              []})
             (Just
              ({ <no location info> }
               []))
@@ -81,7 +86,12 @@
            (ConDeclH98
             ({ DumpRenamedAst.hs:6:21-24 }
              {Name: DumpRenamedAst.Succ})
-            (Nothing)
+            (False)
+            (HsQTvs
+             []
+             []
+             {NameSet:
+              []})
             (Just
              ({ <no location info> }
               []))
@@ -293,65 +303,68 @@
               (ConDeclGADT
                [({ DumpRenamedAst.hs:16:3-5 }
                  {Name: DumpRenamedAst.Nat})]
-               (HsIB
+               (False)
+               (HsQTvs
                 [{Name: f}
                 ,{Name: g}]
-                ({ DumpRenamedAst.hs:16:10-45 }
-                 (HsFunTy
-                  ({ DumpRenamedAst.hs:16:10-34 }
-                   (HsParTy
-                    ({ DumpRenamedAst.hs:16:11-33 }
-                     (HsForAllTy
-                      [({ DumpRenamedAst.hs:16:18-19 }
-                        (UserTyVar
-                         ({ DumpRenamedAst.hs:16:18-19 }
-                          {Name: xx})))]
-                      ({ DumpRenamedAst.hs:16:22-33 }
-                       (HsFunTy
-                        ({ DumpRenamedAst.hs:16:22-25 }
-                         (HsAppTy
-                          ({ DumpRenamedAst.hs:16:22 }
-                           (HsTyVar
-                            (NotPromoted)
-                            ({ DumpRenamedAst.hs:16:22 }
-                             {Name: f})))
-                          ({ DumpRenamedAst.hs:16:24-25 }
-                           (HsTyVar
-                            (NotPromoted)
-                            ({ DumpRenamedAst.hs:16:24-25 }
-                             {Name: xx})))))
-                        ({ DumpRenamedAst.hs:16:30-33 }
-                         (HsAppTy
-                          ({ DumpRenamedAst.hs:16:30 }
-                           (HsTyVar
-                            (NotPromoted)
-                            ({ DumpRenamedAst.hs:16:30 }
-                             {Name: g})))
-                          ({ DumpRenamedAst.hs:16:32-33 }
-                           (HsTyVar
-                            (NotPromoted)
-                            ({ DumpRenamedAst.hs:16:32-33 }
-                             {Name: xx})))))))))))
-                  ({ DumpRenamedAst.hs:16:39-45 }
-                   (HsAppTy
-                    ({ DumpRenamedAst.hs:16:39-43 }
-                     (HsAppTy
-                      ({ DumpRenamedAst.hs:16:39-41 }
-                       (HsTyVar
-                        (NotPromoted)
-                        ({ DumpRenamedAst.hs:16:39-41 }
-                         {Name: DumpRenamedAst.Nat})))
-                      ({ DumpRenamedAst.hs:16:43 }
-                       (HsTyVar
-                        (NotPromoted)
-                        ({ DumpRenamedAst.hs:16:43 }
-                         {Name: f})))))
-                    ({ DumpRenamedAst.hs:16:45 }
-                     (HsTyVar
-                      (NotPromoted)
-                      ({ DumpRenamedAst.hs:16:45 }
-                       {Name: g})))))))
-                (True))
+                []
+                {NameSet:
+                 []})
+               (Nothing)
+               (PrefixCon
+                [({ DumpRenamedAst.hs:16:10-34 }
+                  (HsParTy
+                   ({ DumpRenamedAst.hs:16:11-33 }
+                    (HsForAllTy
+                     [({ DumpRenamedAst.hs:16:18-19 }
+                       (UserTyVar
+                        ({ DumpRenamedAst.hs:16:18-19 }
+                         {Name: xx})))]
+                     ({ DumpRenamedAst.hs:16:22-33 }
+                      (HsFunTy
+                       ({ DumpRenamedAst.hs:16:22-25 }
+                        (HsAppTy
+                         ({ DumpRenamedAst.hs:16:22 }
+                          (HsTyVar
+                           (NotPromoted)
+                           ({ DumpRenamedAst.hs:16:22 }
+                            {Name: f})))
+                         ({ DumpRenamedAst.hs:16:24-25 }
+                          (HsTyVar
+                           (NotPromoted)
+                           ({ DumpRenamedAst.hs:16:24-25 }
+                            {Name: xx})))))
+                       ({ DumpRenamedAst.hs:16:30-33 }
+                        (HsAppTy
+                         ({ DumpRenamedAst.hs:16:30 }
+                          (HsTyVar
+                           (NotPromoted)
+                           ({ DumpRenamedAst.hs:16:30 }
+                            {Name: g})))
+                         ({ DumpRenamedAst.hs:16:32-33 }
+                          (HsTyVar
+                           (NotPromoted)
+                           ({ DumpRenamedAst.hs:16:32-33 }
+                            {Name: xx})))))))))))])
+               ({ DumpRenamedAst.hs:16:39-45 }
+                (HsAppTy
+                 ({ DumpRenamedAst.hs:16:39-43 }
+                  (HsAppTy
+                   ({ DumpRenamedAst.hs:16:39-41 }
+                    (HsTyVar
+                     (NotPromoted)
+                     ({ DumpRenamedAst.hs:16:39-41 }
+                      {Name: DumpRenamedAst.Nat})))
+                   ({ DumpRenamedAst.hs:16:43 }
+                    (HsTyVar
+                     (NotPromoted)
+                     ({ DumpRenamedAst.hs:16:43 }
+                      {Name: f})))))
+                 ({ DumpRenamedAst.hs:16:45 }
+                  (HsTyVar
+                   (NotPromoted)
+                   ({ DumpRenamedAst.hs:16:45 }
+                    {Name: g})))))
                (Nothing)))]
             ({ <no location info> }
              [])))
diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr
index 53e4a6f941..8be750df9c 100644
--- a/testsuite/tests/parser/should_compile/T14189.stderr
+++ b/testsuite/tests/parser/should_compile/T14189.stderr
@@ -29,7 +29,12 @@
            (ConDeclH98
             ({ T14189.hs:6:15-16 }
              {Name: T14189.MT})
-            (Nothing)
+            (False)
+            (HsQTvs
+             []
+             []
+             {NameSet:
+              []})
             (Just
              ({ <no location info> }
               []))
@@ -44,7 +49,12 @@
            (ConDeclH98
             ({ T14189.hs:6:24-25 }
              {Name: T14189.NT})
-            (Nothing)
+            (False)
+            (HsQTvs
+             []
+             []
+             {NameSet:
+              []})
             (Just
              ({ <no location info> }
               []))
@@ -55,7 +65,12 @@
            (ConDeclH98
             ({ T14189.hs:6:29 }
              {Name: T14189.F})
-            (Nothing)
+            (False)
+            (HsQTvs
+             []
+             []
+             {NameSet:
+              []})
             (Just
              ({ <no location info> }
               []))
diff --git a/testsuite/tests/patsyn/should_fail/T11039.stderr b/testsuite/tests/patsyn/should_fail/T11039.stderr
index 4783bc9fe6..14d67a2bb2 100644
--- a/testsuite/tests/patsyn/should_fail/T11039.stderr
+++ b/testsuite/tests/patsyn/should_fail/T11039.stderr
@@ -2,7 +2,8 @@
 T11039.hs:8:15: error:
     • Couldn't match type ‘f’ with ‘A’
       ‘f’ is a rigid type variable bound by
-        the signature for pattern synonym ‘Q’ at T11039.hs:7:14-38
+        the signature for pattern synonym ‘Q’
+        at T11039.hs:7:1-38
       Expected type: f a
         Actual type: A a
     • In the pattern: A a
diff --git a/testsuite/tests/patsyn/should_fail/T11667.stderr b/testsuite/tests/patsyn/should_fail/T11667.stderr
index fdd447704d..c9c00c9165 100644
--- a/testsuite/tests/patsyn/should_fail/T11667.stderr
+++ b/testsuite/tests/patsyn/should_fail/T11667.stderr
@@ -16,7 +16,8 @@ T11667.hs:18:28: error:
         arising from the "provided" constraints claimed by
           the signature of ‘Pat2’
       ‘b’ is a rigid type variable bound by
-        the signature for pattern synonym ‘Pat2’ at T11667.hs:17:17-50
+        the signature for pattern synonym ‘Pat2’
+        at T11667.hs:17:1-50
     • In the declaration for pattern synonym ‘Pat2’
     • Relevant bindings include y :: b (bound at T11667.hs:18:21)
 
diff --git a/testsuite/tests/rename/should_compile/T5331.stderr b/testsuite/tests/rename/should_compile/T5331.stderr
index 9bc0b102b7..fb27e64af1 100644
--- a/testsuite/tests/rename/should_compile/T5331.stderr
+++ b/testsuite/tests/rename/should_compile/T5331.stderr
@@ -5,7 +5,7 @@ T5331.hs:8:17: warning: [-Wunused-foralls (in -Wextra)]
 
 T5331.hs:11:16: warning: [-Wunused-foralls (in -Wextra)]
     Unused quantified type variable ‘a’
-    In the type ‘forall a. W’
+    In the definition of data constructor ‘W1’
 
 T5331.hs:13:13: warning: [-Wunused-foralls (in -Wextra)]
     Unused quantified type variable ‘a’
diff --git a/testsuite/tests/typecheck/should_compile/T2494.stderr b/testsuite/tests/typecheck/should_compile/T2494.stderr
index 48b2221220..5cf4fde746 100644
--- a/testsuite/tests/typecheck/should_compile/T2494.stderr
+++ b/testsuite/tests/typecheck/should_compile/T2494.stderr
@@ -2,9 +2,11 @@
 T2494.hs:15:14: error:
     • Couldn't match type ‘b’ with ‘a’
       ‘b’ is a rigid type variable bound by
-        the RULE "foo/foo" at T2494.hs:14:16-62
+        the RULE "foo/foo"
+        at T2494.hs:(12,1)-(15,33)
       ‘a’ is a rigid type variable bound by
-        the RULE "foo/foo" at T2494.hs:13:16-62
+        the RULE "foo/foo"
+        at T2494.hs:(12,1)-(15,33)
       Expected type: Maybe (m a) -> Maybe (m a)
         Actual type: Maybe (m b) -> Maybe (m b)
     • In the first argument of ‘foo’, namely ‘g’
@@ -20,9 +22,11 @@ T2494.hs:15:14: error:
 T2494.hs:15:30: error:
     • Couldn't match type ‘b’ with ‘a’
       ‘b’ is a rigid type variable bound by
-        the RULE "foo/foo" at T2494.hs:14:16-62
+        the RULE "foo/foo"
+        at T2494.hs:(12,1)-(15,33)
       ‘a’ is a rigid type variable bound by
-        the RULE "foo/foo" at T2494.hs:13:16-62
+        the RULE "foo/foo"
+        at T2494.hs:(12,1)-(15,33)
       Expected type: Maybe (m b) -> Maybe (m a)
         Actual type: Maybe (m b) -> Maybe (m b)
     • In the second argument of ‘(.)’, namely ‘g’
diff --git a/utils/haddock b/utils/haddock
-Subproject ae0d140334fff57f2737dbd7c5804b4868d9c3a
+Subproject 587a13ada6ae1e6d04355bc241699f18a0be85e