Refactor ConDeclwip/T11028-2

Summary:
The ConDecl type in HsDecls is an uneasy compromise. For the most part,
HsSyn directly reflects the syntax written by the programmer; and that
gives just the right "pegs" on which to hang Alan's API annotations. But
ConDecl doesn't properly reflect the syntax of Haskell-98 and GADT-style
data type declarations.

To be concrete, here's a draft new data type

data ConDecl name
  | ConDeclGADT
      { con_names   :: [Located name]
      , con_type    :: LHsSigType name  -- The type after the ‘::’
      , con_doc     :: Maybe LHsDocString }

  | ConDeclH98
      { con_name    :: Located name

      , con_qvars     :: Maybe (LHsQTyVars name)
        -- User-written forall (if any), and its implicit
        -- kind variables
        -- Non-Nothing needs -XExistentialQuantification

      , con_cxt       :: Maybe (LHsContext name)
        -- ^ User-written context (if any)

      , con_details   :: HsConDeclDetails name
          -- ^ Arguments

      , con_doc       :: Maybe LHsDocString
          -- ^ A possible Haddock comment.
      } deriving (Typeable)

Note that

    For GADTs, just keep a type. That's what the user writes.
    NB:HsType can represent records on the LHS of an arrow:

      { x:Int,y:Bool} -> T

    con_qvars and con_cxt are both Maybe because they are both
    optional (the forall and the context of an existential data type

    For ConDeclGADT the type variables of the data type do not scope
    over the con_type; whereas for ConDeclH98 they do scope over con_cxt
    and con_details.

Test Plan: ./validate

Reviewers: simonpj, austin, goldfire, bgamari

Subscribers: goldfire, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D1558

GHC Trac Issues: #11028

21 files changed, 426 insertions, 339 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 8d701af329..d833baf1eb 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -302,7 +302,7 @@ repDataDefn tc bndrs opt_tys tv_names
                              _cs -> failWithDs (ptext
                                      (sLit "Multiple constructors for newtype:")
                                       <+> pprQuotedList
-                                                (con_names $ unLoc $ head cons))
+                                              (getConNames $ unLoc $ head cons))
                           }
            DataType -> do { consL <- concatMapM (repC tv_names) cons
                           ; cons1 <- coreList conQTyConName consL
@@ -623,26 +623,54 @@ repAnnProv ModuleAnnProvenance
 -------------------------------------------------------
 
 repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]
-repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ []
-                     , con_details = details, con_res = ResTyH98 }))
-  | null (hsQTvBndrs con_tvs)
-  = do { con1 <- mapM lookupLOcc con       -- See Note [Binders and occurrences]
-       ; mapM (\c -> repConstr c details) con1  }
-
-repC tvs (L _ (ConDecl { con_names = cons
-                       , con_qvars = con_tvs, con_cxt = L _ ctxt
-                       , con_details = details
-                       , con_res = res_ty }))
-  = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
+repC _ (L _ (ConDeclH98 { con_name = con
+                        , con_qvars = Nothing, con_cxt = Nothing
+                        , con_details = details }))
+  = do { con1 <- lookupLOcc con
+                 -- See Note [Binders and occurrences]
+       ; mapM (\c -> repConstr c details) [con1] }
+
+repC _ (L _ (ConDeclH98 { con_name = con
+                        , con_qvars = mcon_tvs, con_cxt = mcxt
+                        , con_details = details }))
+  = do { let (eq_ctxt, con_tv_subst) = ([], [])
+       ; let con_tvs = fromMaybe (HsQTvs [] []) mcon_tvs
+       ; let ctxt = unLoc $ fromMaybe (noLoc []) mcxt
        ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs)
                              , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }
 
-       ; binds <- mapM dupBinder con_tv_subst
+       ; let binds = []
        ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
          addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
-    do { cons1     <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
-       ; c'        <- mapM (\c -> repConstr c details) cons1
+    do { con1     <- lookupLOcc con -- See Note [Binders and occurrences]
+       ; c'        <- repConstr con1 details
        ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
+       ; if (null (hsq_kvs ex_tvs) && null (hsq_tvs ex_tvs)
+             && null (eq_ctxt ++ ctxt))
+            then return c'
+            else rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ [unC c']) }
+    ; return [b]
+    }
+repC tvs (L _ (ConDeclGADT { con_names = cons
+                           , con_type = res_ty@(HsIB { hsib_kvs = con_kvs
+                                                     , hsib_tvs = con_tvns })}))
+  = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
+       ; let con_tvs = map (noLoc . UserTyVar . noLoc) con_tvns
+       ; let ex_tvs
+               = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) con_kvs
+                        , hsq_tvs = filterOut
+                                          (in_subst con_tv_subst . hsLTyVarName)
+                                          con_tvs }
+
+       ; binds <- mapM dupBinder con_tv_subst
+       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
+         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
+    do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
+       ; let (details,res_ty',_,_) = gadtDeclDetails res_ty
+       ; let doc = ptext (sLit "In the constructor for ") <+> ppr (head cons)
+       ; (hs_details,_res_ty) <- update_con_result doc details res_ty'
+       ; c'        <- mapM (\c -> repConstr c hs_details) cons1
+       ; ctxt'     <- repContext eq_ctxt
        ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
     ; return [b]
     }
@@ -651,8 +679,37 @@ in_subst :: [(Name,Name)] -> Name -> Bool
 in_subst []          _ = False
 in_subst ((n',_):ns) n = n==n' || in_subst ns n
 
+update_con_result :: SDoc
+            -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
+                    -- Original details
+            -> LHsType Name -- The original result type
+            -> DsM (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
+                    LHsType Name)
+update_con_result doc details ty
+  = do {  let (arg_tys, res_ty) = splitHsFunType ty
+                -- We can finally split it up,
+                -- now the renamer has dealt with fixities
+                -- See Note [Sorting out the result type] in RdrHsSyn
+
+       ; case details of
+           InfixCon {}  -> pprPanic "update_con_result" (ppr ty)
+           -- See Note [Sorting out the result type] in RdrHsSyn
+
+           RecCon {}    -> do { unless (null arg_tys)
+                                       (failWithDs (badRecResTy doc))
+                                -- AZ: This error used to be reported during
+                                --     renaming, will now be reported in type
+                                --     checking. Is this a problem?
+                              ; return (details, res_ty) }
+
+           PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
+    where
+        badRecResTy :: SDoc -> SDoc
+        badRecResTy ctxt = ctxt <+>
+                        ptext (sLit "Malformed constructor signature")
+
 mkGadtCtxt :: [Name]            -- Tyvars of the data type
-           -> ResType (LHsType Name)
+           -> LHsSigType Name
            -> DsM (HsContext Name, [(Name,Name)])
 -- Given a data type in GADT syntax, figure out the equality
 -- context, so that we can represent it with an explicit
@@ -666,16 +723,16 @@ mkGadtCtxt :: [Name]            -- Tyvars of the data type
 --     (b~[e], c~e), [d->a]
 --
 -- This function is fiddly, but not really hard
-mkGadtCtxt _ ResTyH98
-  = return ([], [])
-mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
-  | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
+mkGadtCtxt data_tvs res_ty
+  | Just (_, tys) <- hsTyGetAppHead_maybe ty
   , data_tvs `equalLength` tys
   = return (go [] [] (data_tvs `zip` tys))
 
   | otherwise
   = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
   where
+    (_,ty',_,_) = gadtDeclDetails res_ty
+    (_arg_tys,ty) = splitHsFunType ty'
     go cxt subst [] = (cxt, subst)
     go cxt subst ((data_tv, ty) : rest)
        | Just con_tv <- is_hs_tyvar ty
@@ -692,7 +749,6 @@ mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
     is_hs_tyvar (L _ (HsParTy ty))      = is_hs_tyvar ty
     is_hs_tyvar _                       = Nothing
 
-
 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
 repBangTy ty = do
   MkC s <- rep2 str []
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 1fc4f09ad9..4decbe12bb 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -45,7 +45,7 @@ import Control.Applicative (Applicative(..))
 
 import Data.Char ( chr )
 import Data.Word ( Word8 )
-import Data.Maybe( catMaybes )
+import Data.Maybe( catMaybes, fromMaybe )
 import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
 
@@ -423,13 +423,13 @@ cvtConstr (NormalC c strtys)
   = do  { c'   <- cNameL c
         ; cxt' <- returnL []
         ; tys' <- mapM cvt_arg strtys
-        ; returnL $ mkSimpleConDecl c' Nothing cxt' (PrefixCon tys') }
+        ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }
 
 cvtConstr (RecC c varstrtys)
   = do  { c'    <- cNameL c
         ; cxt'  <- returnL []
         ; args' <- mapM cvt_id_arg varstrtys
-        ; returnL $ mkSimpleConDecl c' Nothing cxt'
+        ; returnL $ mkConDeclH98 c' Nothing cxt'
                                    (RecCon (noLoc args')) }
 
 cvtConstr (InfixC st1 c st2)
@@ -437,15 +437,23 @@ cvtConstr (InfixC st1 c st2)
         ; cxt' <- returnL []
         ; st1' <- cvt_arg st1
         ; st2' <- cvt_arg st2
-        ; returnL $ mkSimpleConDecl c' Nothing cxt' (InfixCon st1' 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 $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con'))
-                         , con_explicit = True
-                         , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
+        ; let qvars = case (tvs,con_qvars con') of
+                ([],Nothing) -> Nothing
+                _  ->
+                  Just $ mkHsQTvs (hsQTvBndrs tvs' ++
+                                   hsQTvBndrs (fromMaybe (HsQTvs PlaceHolder [])
+                                              (con_qvars con')))
+        ; returnL $ con' { con_qvars = qvars
+                         , con_cxt = Just $
+                                     L loc (ctxt' ++
+                                            unLoc (fromMaybe (noLoc [])
+                                                   (con_cxt con'))) } }
 
 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
 cvt_arg (NotStrict, ty) = cvtType ty
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index b8612ed2be..48348cc2e1 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -60,8 +60,11 @@ module HsDecls (
   noForeignImportCoercionYet, noForeignExportCoercionYet,
   CImportSpec(..),
   -- ** Data-constructor declarations
-  ConDecl(..), LConDecl, ResType(..),
+  ConDecl(..), LConDecl,
   HsConDeclDetails, hsConDeclArgTys,
+  getConNames,
+  getConDetails,
+  gadtDeclDetails,
   -- ** Document comments
   DocDecl(..), LDocDecl, docDeclDoc,
   -- ** Deprecations
@@ -106,6 +109,7 @@ import SrcLoc
 import FastString
 
 import Bag
+import Data.Maybe ( fromMaybe )
 import Data.Data        hiding (TyCon,Fixity)
 #if __GLASGOW_HASKELL__ < 709
 import Data.Foldable ( Foldable )
@@ -956,9 +960,9 @@ data HsDataDefn name   -- The payload of a data type defn
                      -- ^ Data constructors
                      --
                      -- For @data T a = T1 | T2 a@
-                     --   the 'LConDecl's all have 'ResTyH98'.
+                     --   the 'LConDecl's all have 'ConDeclH98'.
                      -- For @data T a where { T1 :: T a }@
-                     --   the 'LConDecls' all have 'ResTyGADT'.
+                     --   the 'LConDecls' all have 'ConDeclGADT'.
 
                  dd_derivs :: HsDeriving name  -- ^ Optional 'deriving' claues
 
@@ -1020,71 +1024,64 @@ type LConDecl name = Located (ConDecl name)
 
 -- For details on above see note [Api annotations] in ApiAnnotation
 data ConDecl name
-  = ConDecl
-    { con_names     :: [Located name]
-        -- ^ Constructor names.  This is used for the DataCon itself, and for
-        -- the user-callable wrapper Id.
-        -- It is a list to deal with GADT constructors of the form
-        --   T1, T2, T3 :: <payload>
-
-    , con_explicit  :: Bool
-        -- ^ Is there an user-written forall?
-        -- For ResTyH98, "explicit" means something like:
-        --     data T = forall a. MkT { x :: a -> a }
-        -- For ResTyGADT, "explicit" means something like
-        --     data T where { MkT :: forall a. <blah> }
-
-    , con_qvars     :: LHsQTyVars name
-        -- ^ Type variables.  Depending on 'con_res' this describes the
-        -- following entities
-        --
-        --  - ResTyH98:  the constructor's *existential* type variables
+  = ConDeclGADT
+      { con_names   :: [Located name]
+      , con_type    :: LHsSigType name
+        -- ^ The type after the ‘::’
+      , con_doc     :: Maybe LHsDocString
+          -- ^ A possible Haddock comment.
+      }
+
+  | ConDeclH98
+      { con_name    :: Located name
+
+      , con_qvars     :: Maybe (LHsQTyVars name)
+        -- User-written forall (if any), and its implicit
+        -- kind variables
+        -- Non-Nothing needs -XExistentialQuantification
         --               e.g. data T a = forall b. MkT b (b->a)
         --               con_qvars = {b}
-        --
-        --  - ResTyGADT: *all* the constructor's quantified type variables
-        --               e.g.  data T a where
-        --                       MkT :: forall a b. b -> (b->a) -> T a
-        --               con_qvars = {a,b}
-        --
-        -- If con_explicit is False, then con_qvars is irrelevant
-        -- until after renaming.
 
-    , con_cxt       :: LHsContext name
-        -- ^ The context.  This /does not/ include the \"stupid theta\" which
-        -- lives only in the 'TyData' decl.
+      , con_cxt       :: Maybe (LHsContext name)
+        -- ^ User-written context (if any)
 
-    , con_details   :: HsConDeclDetails name
-        -- ^ The main payload
+      , con_details   :: HsConDeclDetails name
+          -- ^ Arguments
 
-    , con_res       :: ResType (LHsType name)
-        -- ^ Result type of the constructor
-
-    , con_doc       :: Maybe LHsDocString
-        -- ^ A possible Haddock comment.
-    } deriving (Typeable)
+      , con_doc       :: Maybe LHsDocString
+          -- ^ A possible Haddock comment.
+      } deriving (Typeable)
 deriving instance (DataId name) => Data (ConDecl name)
 
 type HsConDeclDetails name
    = HsConDetails (LBangType name) (Located [LConDeclField name])
 
+getConNames :: ConDecl name -> [Located name]
+getConNames ConDeclH98  {con_name  = name}  = [name]
+getConNames ConDeclGADT {con_names = names} = names
+
+getConDetails :: ConDecl name -> HsConDeclDetails name
+getConDetails ConDeclH98  {con_details  = details} = details
+getConDetails ConDeclGADT {con_type     = ty     } = details
+  where
+    (details,_,_,_) = gadtDeclDetails ty
+
+gadtDeclDetails :: LHsSigType name
+     -> (HsConDeclDetails name,LHsType name,LHsContext name,[LHsTyVarBndr name])
+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)
+
 hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
 hsConDeclArgTys (PrefixCon tys)    = tys
 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
 hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) (unLoc flds)
 
-data ResType ty
-   = ResTyH98             -- Constructor was declared using Haskell 98 syntax
-   | ResTyGADT SrcSpan ty -- Constructor was declared using GADT-style syntax,
-                          --      and here is its result type, and the SrcSpan
-                          --      of the original sigtype, for API Annotations
-   deriving (Data, Typeable)
-
-instance Outputable ty => Outputable (ResType ty) where
-         -- Debugging only
-   ppr ResTyH98         = ptext (sLit "ResTyH98")
-   ppr (ResTyGADT _ ty) = ptext (sLit "ResTyGADT") <+> ppr ty
-
 pp_data_defn :: OutputableBndr name
                   => (HsContext name -> SDoc)   -- Printing the header
                   -> HsDataDefn name
@@ -1115,7 +1112,7 @@ instance Outputable NewOrData where
   ppr DataType = ptext (sLit "data")
 
 pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
-pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ _ } : _) -- In GADT syntax
+pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax
   = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
 pp_condecls cs                    -- In H98 syntax
   = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
@@ -1124,50 +1121,27 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr = pprConDecl
 
 pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
-pprConDecl (ConDecl { con_names = [L _ con]  -- NB: non-GADT means 1 con
-                    , con_explicit = expl, con_qvars = tvs
-                    , con_cxt = cxt, con_details = details
-                    , con_res = ResTyH98, con_doc = doc })
-  = sep [ppr_mbDoc doc, ppr_con_forall expl tvs cxt, ppr_details details]
+pprConDecl (ConDeclH98 { con_name = L _ con
+                       , con_qvars = mtvs
+                       , con_cxt = mcxt
+                       , con_details = details
+                       , con_doc = doc })
+  = sep [ppr_mbDoc doc, pprHsForAll tvs cxt,         ppr_details details]
   where
     ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
     ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con
                                    : map (pprParendHsType . unLoc) tys)
     ppr_details (RecCon fields)  = pprPrefixOcc con
                                  <+> pprConDeclFields (unLoc fields)
+    tvs = case mtvs of
+      Nothing -> []
+      Just (HsQTvs _ tvs) -> tvs
 
-pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
-                    , con_cxt = cxt, con_details = PrefixCon arg_tys
-                    , con_res = ResTyGADT _ res_ty, con_doc = doc })
-  = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+>
-    sep [ppr_con_forall expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
-  where
-    mk_fun_ty a b = noLoc (HsFunTy a b)
+    cxt = fromMaybe (noLoc []) mcxt
 
-pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
-                    , con_cxt = cxt, con_details = RecCon fields
-                    , con_res = ResTyGADT _ res_ty, con_doc = doc })
+pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc })
   = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
-         <+> ppr_con_forall expl tvs cxt,
-         pprConDeclFields (unLoc fields) <+> arrow <+> ppr res_ty]
-
-pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} })
-  = pprConDecl (decl { con_details = PrefixCon [ty1,ty2] })
-        -- In GADT syntax we don't allow infix constructors
-        -- so if we ever trip over one (albeit I can't see how that
-        -- can happen) print it like a prefix one
-
--- this fallthrough would happen with a non-GADT-syntax ConDecl with more
--- than one constructor, which should indeed be impossible
-pprConDecl (ConDecl { con_names = cons }) = pprPanic "pprConDecl" (ppr cons)
-
-ppr_con_forall :: OutputableBndr name => Bool -> LHsQTyVars name
-                                      -> LHsContext name -> SDoc
-ppr_con_forall explicit_forall qtvs (L _ ctxt)
-  | explicit_forall
-  = pprHsForAllTvs (hsQTvBndrs qtvs) <+> pprHsContext ctxt
-  | otherwise
-  = pprHsContext ctxt
+         <+> ppr res_ty]
 
 ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc
 ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs
index e890b3bd93..b929f86761 100644
--- a/compiler/hsSyn/HsLit.hs
+++ b/compiler/hsSyn/HsLit.hs
@@ -195,4 +195,3 @@ pmPprHsLit (HsInteger _ i _)  = integer i
 pmPprHsLit (HsRat f _)        = ppr f
 pmPprHsLit (HsFloatPrim f)    = ppr f
 pmPprHsLit (HsDoublePrim d)   = ppr d
-
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index cd8f20342c..5546a91843 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -137,7 +137,7 @@ See also Note [Kind and type-variable binders] in RnTypes
 
 Note [HsType binders]
 ~~~~~~~~~~~~~~~~~~~~~
-The system fr recording type and kind-variable binders in HsTypes
+The system for recording type and kind-variable binders in HsTypes
 is a bit complicated.  Here's how it works.
 
 * In a HsType,
@@ -146,7 +146,7 @@ is a bit complicated.  Here's how it works.
      HsQualTy     reprsents an /explicit, user-written/ context
                    e.g.   (Eq a, Show a) => ...
                   The context can be empty if that's what the user wrote
-  These constructors reprsents what the user wrote, no more
+  These constructors represent what the user wrote, no more
   and no less.
 
 * HsTyVarBndr describes a quantified type variable written by the
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 19996fd0f1..ca3cae5260 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -953,14 +953,32 @@ hsConDeclsBinders cons = go id cons
           case r of
              -- remove only the first occurrence of any seen field in order to
              -- avoid circumventing detection of duplicate fields (#9156)
-             L loc (ConDecl { con_names = names, con_details = RecCon flds }) ->
-               (map (L loc . unLoc) names ++ ns, r' ++ fs)
+             L loc (ConDeclGADT { con_names = names
+                                , con_type = HsIB { hsib_body = res_ty}}) ->
+               case tau of
+                 L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
+                         -> (map (L loc . unLoc) names ++ ns, r' ++ fs)
+                            where r' = remSeen (concatMap (cd_fld_names . unLoc)
+                                                          flds)
+                                  remSeen'
+                                    = foldr (.) remSeen
+                                        [deleteBy ((==) `on`
+                                                  rdrNameFieldOcc . unLoc) v
+                                        | v <- r']
+                                  (ns, fs) = go remSeen' rs
+                 _other  -> (map (L loc . unLoc) names ++ ns, fs)
+                            where (ns, fs) = go remSeen rs
+                 where
+                   (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
+             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` rdrNameFieldOcc . unLoc) v | v <- r']
                         (ns, fs) = go remSeen' rs
-             L loc (ConDecl { con_names = names }) ->
-                (map (L loc . unLoc) names ++ ns, fs)
+             L loc (ConDeclH98 { con_name = name }) ->
+                ([L loc (unLoc name)] ++ ns, fs)
                   where (ns, fs) = go remSeen rs
 
 {-
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index fb5c8dbd45..bbde989293 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1895,10 +1895,9 @@ gadt_constr_with_doc
 gadt_constr :: { LConDecl RdrName }
     -- see Note [Difference in parsing GADT and data constructors]
     -- Returns a list because of:   C,D :: ty
-        : con_list '::' ctype
-                {% do { let { (anns,gadtDecl) = mkGadtDecl (unLoc $1) $3 }
-                      ; ams (sLL $1 $> gadtDecl)
-                            (mu AnnDcolon $2:anns) } }
+        : con_list '::' sigtype
+                {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3)))
+                       [mu AnnDcolon $2] }
 
 {- Note [Difference in parsing GADT and data constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1925,13 +1924,13 @@ constrs1 :: { Located [LConDecl RdrName] }
 constr :: { LConDecl RdrName }
         : maybe_docnext forall context '=>' constr_stuff maybe_docprev
                 {% ams (let (con,details) = unLoc $5 in
-                  addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con
+                  addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
                                                    (snd $ unLoc $2) $3 details))
                             ($1 `mplus` $6))
                         (mu AnnDarrow $4:(fst $ unLoc $2)) }
         | maybe_docnext forall constr_stuff maybe_docprev
                 {% ams ( let (con,details) = unLoc $3 in
-                  addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con
+                  addConDoc (L (comb2 $2 $3) (mkConDeclH98 con
                                            (snd $ unLoc $2) (noLoc []) details))
                             ($1 `mplus` $4))
                        (fst $ unLoc $2) }
@@ -2671,7 +2670,6 @@ stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
 -- here, because we need too much lookahead if we see do { e ; }
 -- So we use BodyStmts throughout, and switch the last one over
 -- in ParseUtils.checkDo instead
--- AZ: TODO check that we can retrieve multiple semis.
 
 stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) }
         : stmts ';' stmt  {% if null (snd $ unLoc $1)
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 4b744fe69a..53e6184491 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -35,7 +35,7 @@ module RdrHsSyn (
         mkExport,
         mkExtName,           -- RdrName -> CLabelString
         mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
-        mkSimpleConDecl,
+        mkConDeclH98,
         mkATDefault,
 
         -- Bunch of functions in the parser monad for
@@ -487,58 +487,25 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
         text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
         quotes (ppr patsyn_name) $$ ppr decl
 
-mkSimpleConDecl :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
+mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
                 -> LHsContext RdrName -> HsConDeclDetails RdrName
                 -> ConDecl RdrName
 
-mkSimpleConDecl name mb_forall cxt details
-  = ConDecl { con_names    = [name]
-            , con_explicit = explicit
-            , con_qvars    = qvars
-            , con_cxt      = cxt
-            , con_details  = details
-            , con_res      = ResTyH98
-            , con_doc      = Nothing }
-  where
-    (explicit, qvars) = case mb_forall of
-                          Nothing  -> (False, mkHsQTvs [])
-                          Just tvs -> (True,  mkHsQTvs tvs)
+mkConDeclH98 name mb_forall cxt details
+  = ConDeclH98 { con_name     = name
+               , con_qvars    = fmap mkHsQTvs mb_forall
+               , con_cxt      = Just cxt
+                             -- AZ:TODO: when can cxt be Nothing?
+                             --          remembering that () is a valid context.
+               , con_details  = details
+               , con_doc      = Nothing }
 
 mkGadtDecl :: [Located RdrName]
-           -> LHsType RdrName     -- Always a HsForAllTy
-           -> ([AddAnn], ConDecl RdrName)
-mkGadtDecl names ty = ([], mkGadtDecl' names ty)
-
-mkGadtDecl' :: [Located RdrName]
-            -> LHsType RdrName
-            -> ConDecl RdrName
--- We allow C,D :: ty
--- and expand it as if it had been
---    C :: ty; D :: ty
--- (Just like type signatures in general.)
-
-mkGadtDecl' names lbody_ty@(L loc body_ty)
-  = mk_gadt_con names
-  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)
-
-    explicit = case body_ty of
-                 HsForAllTy {} -> True
-                 _             -> False
-
-    mk_gadt_con names
-       = ConDecl { con_names    = names
-                 , con_explicit = explicit
-                 , con_qvars    = mkHsQTvs tvs
-                 , con_cxt      = cxt
-                 , con_details  = details
-                 , con_res      = ResTyGADT loc res_ty
-                 , con_doc      = Nothing }
+           -> LHsSigType RdrName     -- Always a HsForAllTy
+           -> ConDecl RdrName
+mkGadtDecl names ty = ConDeclGADT { con_names = names
+                                  , con_type  = ty
+                                  , con_doc   = Nothing }
 
 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 tyConToDataCon loc tc
@@ -639,19 +606,19 @@ really doesn't matter!
 
 -- | Note [Sorting out the result type]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- In a GADT declaration which is not a record, we put the whole constr
--- type into the ResTyGADT for now; the renamer will unravel it once it
--- has sorted out operator fixities. Consider for example
+-- In a GADT declaration which is not a record, we put the whole constr type
+-- into the res_ty for a ConDeclGADT for now; 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) On the other hand, for a record
 --         { x,y :: Int } -> a :*: b
 -- there is no doubt.  AND we need to sort records out so that
 -- we can bring x,y into scope.  So:
---    * For PrefixCon we keep all the args in the ResTyGADT
+--    * For PrefixCon we keep all the args in the res_ty
 --    * For RecCon we do not
 
 checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName)
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 57b427b0de..42a159f3d4 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -2123,6 +2123,8 @@ checkTupSize tup_size
 ************************************************************************
 -}
 
+-- AZ:TODO: Change these all to be Name instead of RdrName.
+--          Merge TcType.UserTypeContext in to it.
 data HsDocContext
   = TypeSigCtx SDoc
   | PatCtx
@@ -2135,7 +2137,7 @@ data HsDocContext
   | TySynCtx (Located RdrName)
   | TyFamilyCtx (Located RdrName)
   | FamPatCtx (Located RdrName)    -- The patterns of a type/data family instance
-  | ConDeclCtx [Located RdrName]
+  | ConDeclCtx [Located Name]
   | ClassDeclCtx (Located RdrName)
   | ExprWithTySigCtx
   | TypBrCtx
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index b0b79f55e6..c673ac3729 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -610,11 +610,22 @@ getLocalNonValBinders fixity_env
     mk_fld_env :: HsDataDefn RdrName -> [Name] -> [FieldLabel] -> [(Name, [FieldLabel])]
     mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
       where
-        find_con_flds (L _ (ConDecl { con_names   = rdrs
+        find_con_flds (L _ (ConDeclH98 { con_name   = rdrs
                                     , con_details = RecCon cdflds }))
             = map (\ (L _ rdr) -> ( find_con_name rdr
                                   , concatMap find_con_decl_flds (unLoc cdflds)))
+                  [rdrs] -- AZ:TODO remove map
+        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 _ (HsRecTy flds)) _) -> flds
+                 _                                    -> []
         find_con_flds _ = []
 
         find_con_name rdr
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 2fbbea4179..dafae7cf5f 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1242,8 +1242,8 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
         }
   where
     h98_style = case condecls of  -- Note [Stupid theta]
-                     L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
-                     _                                             -> True
+                     L _ (ConDeclGADT {}) : _  -> False
+                     _                         -> True
 
     rn_derivs Nothing
       = return (Nothing, emptyFVs)
@@ -1454,7 +1454,7 @@ depAnalTyClDecls ds_w_fvs
         DataDecl { tcdLName = L _ data_name
                  , tcdDataDefn = HsDataDefn { dd_cons = cons } }
           -> do L _ dc <- cons
-                return $ zip (map unLoc $ con_names dc) (repeat data_name)
+                return $ zip (map unLoc $ getConNames dc) (repeat data_name)
         _ -> []
 
 {-
@@ -1506,29 +1506,6 @@ modules), we get better error messages, too.
 \subsection{Support code for type/data declarations}
 *                                                      *
 *********************************************************
-
-Note [Quantification in data constructor declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Four cases, afer renaming
-  * ResTyH98
-     - data T a = forall b. MkT { x :: b -> a }
-       The 'b' is explicitly declared;
-       con_qvars = [b]
-
-     - data T a = MkT { x :: a -> b }
-       Do *not* implicitly quantify over 'b'; it is
-       simply out of scope.  con_qvars = []
-
-  * ResTyGADT
-     - data T a where { MkT :: forall b. (b -> a) -> T a }
-       con_qvars = [a,b]
-
-     - data T a where { MkT :: (b -> a) -> T a }
-       con_qvars = [a,b], by implicit quantification
-                          of the type signature
-       It is uncomfortable that we add implicitly-bound
-       type variables to the HsQTyVars, which usually
-       only has explicitly-bound type variables
 -}
 
 ---------------
@@ -1543,75 +1520,61 @@ rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
 
 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
-rnConDecl decl@(ConDecl { con_names = names, con_qvars = qtvs
-                        , con_cxt = lcxt@(L loc cxt), con_details = details
-                        , con_res = res_ty, con_doc = mb_doc
-                        , con_explicit = explicit })
-  = do  { mapM_ (addLocM checkConName) names
-        ; new_names    <- mapM lookupLocatedTopBndrRn names
+rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
+                           , con_cxt = mcxt, con_details = details
+                           , con_doc = mb_doc })
+  = do  { _ <- addLocM checkConName name
+        ; new_name     <- lookupLocatedTopBndrRn name
+        ; let doc = ConDeclCtx [new_name]
         ; mb_doc'      <- rnMbLHsDoc mb_doc
-        ; let (kvs, qtvs') = get_con_qtvs qtvs (hsConDeclArgTys details) res_ty
+        ; let (kvs, qtvs') = get_con_qtvs qtvs (hsConDeclArgTys details)
 
         ; bindHsQTyVars doc Nothing kvs qtvs' $ \new_tyvars -> do
-        { (new_context, fvs1) <- rnContext doc lcxt
-        ; (new_details, fvs2) <- rnConDeclDetails (unLoc $ head new_names) doc details
-        ; (new_details', new_res_ty, fvs3)
-                     <- rnConResult doc (map unLoc new_names) new_details res_ty
-        ; traceRn (text "rnConDecl" <+> ppr names <+> vcat
+        { (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)
+        ; traceRn (text "rnConDecl" <+> ppr name <+> vcat
              [ text "free_kvs:" <+> ppr kvs
              , text "qtvs:" <+> ppr qtvs
              , text "qtvs':" <+> ppr qtvs' ])
         ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
         ; warnUnusedForAlls (inHsDocContext doc) (hsQTvBndrs new_tyvars) all_fvs
-        ; return (decl { con_names = new_names, con_qvars = new_tyvars
+        ; let 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'
-                       , con_res = new_res_ty, con_doc = mb_doc' },
+                       , con_doc = mb_doc' },
                   all_fvs) }}
  where
-    doc = ConDeclCtx names
+    cxt = maybe [] unLoc mcxt
     get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
 
-    get_con_qtvs :: LHsQTyVars RdrName -> [LHsType RdrName]
-                 -> ResType (LHsType RdrName)
+    get_con_qtvs :: Maybe (LHsQTyVars RdrName) -> [LHsType RdrName]
                  -> ([RdrName], LHsQTyVars RdrName)
-    get_con_qtvs qtvs arg_tys ResTyH98
-      | explicit   -- data T = forall a. MkT (a -> a)
-      = (free_kvs, qtvs)
-      | otherwise  -- data T = MkT (a -> a)
+    get_con_qtvs Nothing _arg_tys
       = ([], mkHsQTvs [])
+    get_con_qtvs (Just qtvs) arg_tys
+      = (free_kvs, qtvs)
       where
         (free_kvs, _) = get_rdr_tvs arg_tys
 
-    get_con_qtvs qtvs arg_tys (ResTyGADT _ ty)
-      | explicit  -- data T x where { MkT :: forall a. a -> T a }
-      = (free_kvs, qtvs)
-      | otherwise -- data T x where { MkT :: a -> T a }
-      = (free_kvs, mkHsQTvs (userHsTyVarBndrs loc free_tvs))
-      where
-        (free_kvs, free_tvs) = get_rdr_tvs (ty : arg_tys)
-
-rnConResult :: HsDocContext -> [Name]
-            -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
-            -> ResType (LHsType RdrName)
-            -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
-                    ResType (LHsType Name), FreeVars)
-rnConResult _   _   details ResTyH98 = return (details, ResTyH98, emptyFVs)
-rnConResult doc _con details (ResTyGADT ls ty)
-  = do { (ty', fvs) <- rnLHsType doc ty
-       ; let (arg_tys, res_ty) = splitHsFunType ty'
-                -- We can finally split it up,
-                -- now the renamer has dealt with fixities
-                -- See Note [Sorting out the result type] in RdrHsSyn
-
-       ; case details of
-           InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
-           -- See Note [Sorting out the result type] in RdrHsSyn
-
-           RecCon {}    -> do { unless (null arg_tys)
-                                       (addErr (badRecResTy doc))
-                              ; return (details, ResTyGADT ls res_ty, fvs) }
-
-           PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT ls res_ty, fvs)}
+rnConDecl decl@(ConDeclGADT { con_names = names, con_type = 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 (text "rnConDecl" <+> ppr names <+> vcat
+             [ text "fvs:" <+> ppr fvs ])
+        ; return (decl { con_names = new_names, con_type = ty'
+                       , con_doc = mb_doc' },
+                  fvs) }
 
 rnConDeclDetails
    :: Name
@@ -1635,9 +1598,6 @@ rnConDeclDetails con doc (RecCon (L l fields))
         ; return (RecCon (L l new_fields), fvs) }
 
 -------------------------------------------------
-badRecResTy :: HsDocContext -> SDoc
-badRecResTy ctxt = withHsDocContext ctxt $
-                   ptext (sLit "Malformed constructor signature")
 
 -- | Brings pattern synonym names and also pattern synonym selectors
 -- from record pattern synonyms into scope.
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 49b707c370..b716ee0721 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -363,6 +363,14 @@ rnHsTyKi _ doc (HsBangTy b ty)
   = do { (ty', fvs) <- rnLHsType doc ty
        ; return (HsBangTy b ty', fvs) }
 
+rnHsTyKi _ doc@(ConDeclCtx names) (HsRecTy flds)
+  = do {
+       -- AZ:reviewers: is there a monadic version of concatMap?
+         flss <- mapM (lookupConstructorFields . unLoc) names
+       ; let fls = concat flss
+       ; (flds', fvs) <- rnConDeclFields fls doc flds
+       ; return (HsRecTy flds', fvs) }
+
 rnHsTyKi _ doc ty@(HsRecTy flds)
   = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
                     2 (ppr ty))
@@ -1200,14 +1208,18 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
           extract_mb (extract_sig_tys . unLoc) derivs $
           foldr (extract_con . unLoc) ([],[]) cons
   where
-    extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc
-    extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs
-                         , con_cxt = ctxt, con_details = details }) acc
-      = extract_hs_tv_bndrs (hsQTvBndrs qvs) acc $
-        extract_lctxt ctxt $
+    extract_con (ConDeclGADT { }) acc = acc
+    extract_con (ConDeclH98 { con_qvars = qvs
+                            , con_cxt = ctxt, con_details = details }) acc
+      = extract_hs_tv_bndrs (maybe [] hsQTvBndrs qvs) acc $
+        extract_mlctxt ctxt $
         extract_ltys (hsConDeclArgTys details) ([],[])
 
 
+extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> FreeKiTyVars
+extract_mlctxt Nothing     = mempty
+extract_mlctxt (Just ctxt) = extract_lctxt ctxt
+
 extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars
 extract_lctxt ctxt = extract_ltys (unLoc ctxt)
 
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index c0fef87334..2b671463cd 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -9,7 +9,7 @@
 
 module TcHsType (
         -- Type signatures
-        kcClassSigType, tcClassSigType,
+        kcHsSigType, tcClassSigType,
         tcHsSigType, tcHsSigWcType,
         zonkSigType, zonkAndCheckValidity,
         funsSigCtxt, addSigCtxt,
@@ -183,8 +183,8 @@ tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType Name -> TcM Type
 -- alrady checked this, so we can simply ignore it.
 tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)
 
-kcClassSigType :: [Located Name] -> LHsSigType Name -> TcM ()
-kcClassSigType names (HsIB { hsib_body = hs_ty
+kcHsSigType :: [Located Name] -> LHsSigType Name -> TcM ()
+kcHsSigType names (HsIB { hsib_body = hs_ty
                            , hsib_kvs  = sig_kvs
                            , hsib_tvs  = sig_tvs })
   = addSigCtxt (funsSigCtxt names) hs_ty $
@@ -387,9 +387,10 @@ tc_hs_type ty@(HsBangTy {})    _
     -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
     -- bangs are invalid, so fail. (#7210)
     = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty)
-tc_hs_type (HsRecTy _)         _ = panic "tc_hs_type: record" -- Unwrapped by con decls
+tc_hs_type ty@(HsRecTy _)      _
       -- Record types (which only show up temporarily in constructor
       -- signatures) should have been removed by now
+    = failWithTc (ptext (sLit "Record syntax is illegal here:") <+> ppr ty)
 
 ---------- Functions and applications
 tc_hs_type hs_ty@(HsTyVar (L _ name)) exp_kind
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index ee95bb5594..27b807455a 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1444,7 +1444,7 @@ tcTyClsInstDecls tycl_decls inst_decls deriv_decls
 
     get_fi_cons :: DataFamInstDecl Name -> [Name]
     get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
-      = map unLoc $ concatMap (con_names . unLoc) cons
+      = map unLoc $ concatMap (getConNames . unLoc) cons
 
 {-
 Note [AFamDataCon: not promoting data family constructors]
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index a2b6a6386e..1cb71d6182 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -67,6 +67,7 @@ import BasicTypes
 
 import Control.Monad
 import Data.List
+import Data.Monoid ( mempty )
 
 {-
 ************************************************************************
@@ -381,7 +382,7 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
               ; return (res_k, ()) }
        ; let main_pr = (name, AThing decl_kind)
              inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
-                         | L _ con' <- cons, con <- con_names con' ]
+                         | L _ con' <- cons, con <- getConNames con' ]
        ; return (main_pr : inner_prs) }
 
 getInitialKind (FamDecl { tcdFam = decl })
@@ -480,7 +481,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
     do  { _ <- tcHsContext ctxt
         ; mapM_ (wrapLocM kc_sig) sigs }
   where
-    kc_sig (ClassOpSig _ nms op_ty) = kcClassSigType nms op_ty
+    kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType nms op_ty
     kc_sig _                        = return ()
 
 -- closed type families look at their equations, but other families don't
@@ -495,20 +496,25 @@ kcTyClDecl (FamDecl {})    = return ()
 
 -------------------
 kcConDecl :: ConDecl Name -> TcM ()
-kcConDecl (ConDecl { con_names = names, con_qvars = ex_tvs
-                   , con_cxt = ex_ctxt, con_details = details
-                   , con_res = res })
-  = addErrCtxt (dataConCtxtName names) $
+kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
+                      , con_cxt = ex_ctxt, con_details = details })
+  = 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!
-    do { _ <- kcHsTyVarBndrs False ex_tvs $
-              do { _ <- tcHsContext ex_ctxt
+    do { _ <- kcHsTyVarBndrs False ((fromMaybe (HsQTvs mempty []) ex_tvs)) $
+              do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt)
                  ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)
-                 ; _ <- tcConRes res
                  ; return (panic "kcConDecl", ()) }
        ; return () }
 
+kcConDecl (ConDeclGADT { con_names = names
+                       , con_type = ty })
+  = addErrCtxt (dataConCtxtName names) $
+      do { _ <- tcGadtSigType (ppr names) (unLoc $ head names) ty
+         ; return () }
+
+
 {-
 Note [Recursion and promoting data constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1241,8 +1247,8 @@ dataDeclChecks tc_name new_or_data stupid_theta cons
 
 -----------------------------------
 consUseGadtSyntax :: [LConDecl a] -> Bool
-consUseGadtSyntax (L _ (ConDecl { con_res = ResTyGADT _ _ }) : _) = True
-consUseGadtSyntax _                                               = False
+consUseGadtSyntax (L _ (ConDeclGADT { }) : _) = True
+consUseGadtSyntax _                           = False
                  -- All constructors have same shape
 
 -----------------------------------
@@ -1261,41 +1267,72 @@ tcConDecl :: NewOrData
           -> TcM [DataCon]
 
 tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
-          (ConDecl { con_names = names
-                   , con_qvars = hs_tvs, con_cxt = hs_ctxt
-                   , con_details = hs_details, con_res = hs_res_ty })
-  = addErrCtxt (dataConCtxtName names) $
-    do { traceTc "tcConDecl 1" (ppr names)
-       ; (ctxt, arg_tys, res_ty, field_lbls, stricts)
-           <- tcHsQTyVars hs_tvs $ \ _ ->
-              do { traceTc "tcConDecl" (ppr names <+> text "tvs:" <+> ppr hs_tvs)
-                 ; ctxt <- tcHsContext hs_ctxt
+          (ConDeclH98 { con_name = name
+                      , con_qvars = hs_tvs, con_cxt = hs_ctxt
+                      , con_details = hs_details })
+  = addErrCtxt (dataConCtxtName [name]) $
+    do { traceTc "tcConDecl 1" (ppr name)
+       ; (ctxt, arg_tys, field_lbls, stricts)
+           <- tcHsQTyVars (fromMaybe (HsQTvs [] []) hs_tvs) $ \ _ ->
+              do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs)
+                 ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt)
                  ; btys <- tcConArgs new_or_data hs_details
-                 ; res_ty  <- tcConRes hs_res_ty
-                 ; field_lbls <- lookupConstructorFields (unLoc $ head names)
+                 ; field_lbls <- lookupConstructorFields (unLoc name)
                  ; let (arg_tys, stricts) = unzip btys
-                 ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
+                 ; return (ctxt, arg_tys, field_lbls, stricts)
                  }
 
-             -- Generalise the kind variables (returning quantified TcKindVars)
-             -- and quantify the type variables (substituting their kinds)
-             -- REMEMBER: 'tkvs' are:
-             --    ResTyH98:  the *existential* type variables only
-             --    ResTyGADT: *all* the quantified type variables
-             -- c.f. the comment on con_qvars in HsDecls
-       ; tkvs <- case res_ty of
-                   ResTyH98           -> quantifyTyVars (mkVarSet tmpl_tvs)
-                                                 (tyVarsOfTypes (ctxt++arg_tys))
-                   ResTyGADT _ res_ty -> quantifyTyVars emptyVarSet
-                                          (tyVarsOfTypes (res_ty:ctxt++arg_tys))
+       ; tkvs <- quantifyTyVars (mkVarSet tmpl_tvs)
+                                (tyVarsOfTypes (ctxt++arg_tys))
 
              -- Zonk to Types
        ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs
        ; arg_tys <- zonkTcTypeToTypes ze arg_tys
        ; ctxt    <- zonkTcTypeToTypes ze ctxt
-       ; res_ty  <- case res_ty of
-                      ResTyH98        -> return ResTyH98
-                      ResTyGADT ls ty -> ResTyGADT ls <$> zonkTcTypeToType ze ty
+
+       ; let (univ_tvs, ex_tvs, eq_preds) = (tmpl_tvs, qtkvs, [])
+         -- AZ:TODO: Is this comment needed here for ConDeclH98?
+         -- NB: this is a /lazy/ binding, so we pass four thunks to buildDataCon
+         --     without yet forcing the guards in rejigConRes
+         -- See Note [Checking GADT return types]
+
+       ; fam_envs <- tcGetFamInstEnvs
+
+       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
+       ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)
+       ; let
+           buildOneDataCon (L _ name) = do
+             { is_infix <- tcConIsInfixH98 name hs_details
+             ; rep_nm   <- newTyConRepName name
+
+             ; buildDataCon fam_envs name is_infix
+                            (if is_prom then Promoted rep_nm else NotPromoted)
+                              -- Must be lazy in is_prom because it is knot-tied
+                            stricts Nothing field_lbls
+                            univ_tvs ex_tvs eq_preds ctxt arg_tys
+                            res_tmpl rep_tycon
+                  -- NB:  we put data_tc, the type constructor gotten from the
+                  --      constructor type signature into the data constructor;
+                  --      that way checkValidDataCon can complain if it's wrong.
+             }
+       ; traceTc "tcConDecl 2" (ppr name)
+       ; mapM buildOneDataCon [name]
+       }
+
+tcConDecl _new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
+          (ConDeclGADT { con_names = names, con_type = ty })
+  = addErrCtxt (dataConCtxtName names) $
+    do { traceTc "tcConDecl 1" (ppr names)
+       ; (ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details)
+           <- tcGadtSigType (ppr names) (unLoc $ head names) ty
+       ; tkvs <- quantifyTyVars emptyVarSet
+                                (tyVarsOfTypes (res_ty:ctxt++arg_tys))
+
+             -- Zonk to Types
+       ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs
+       ; arg_tys <- zonkTcTypeToTypes ze arg_tys
+       ; ctxt    <- zonkTcTypeToTypes ze ctxt
+       ; res_ty  <- zonkTcTypeToType ze res_ty
 
        ; let (univ_tvs, ex_tvs, eq_preds, res_ty') = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty
              -- NB: this is a /lazy/ binding, so we pass four thunks to buildDataCon
@@ -1308,7 +1345,7 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
        ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
        ; let
            buildOneDataCon (L _ name) = do
-             { is_infix <- tcConIsInfix name hs_details res_ty
+             { is_infix <- tcConIsInfixGADT name hs_details
              ; rep_nm   <- newTyConRepName name
 
              ; buildDataCon fam_envs name is_infix
@@ -1326,19 +1363,72 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
        }
 
 
-tcConIsInfix :: Name
+tcGadtSigType :: SDoc -> Name -> LHsSigType Name
+             -> TcM ([PredType],[HsSrcBang], [FieldLabel], [Type], Type
+                    ,HsConDetails (LHsType Name) (Located [LConDeclField Name]))
+tcGadtSigType doc name ty@(HsIB { hsib_kvs = kvs, hsib_tvs = tvs})
+  = do { let (hs_details',res_ty',cxt,gtvs) = gadtDeclDetails ty
+       ; (hs_details,res_ty) <- tcUpdateConResult doc hs_details' res_ty'
+       ; let hs_tvs = HsQTvs { hsq_kvs = kvs
+                             , hsq_tvs = gtvs ++
+                                           map (noLoc . UserTyVar . noLoc) tvs }
+       ; (ctxt, arg_tys, res_ty, field_lbls, stricts)
+           <- tcHsQTyVars hs_tvs $ \ _ ->
+              do { ctxt <- tcHsContext cxt
+                 ; btys <- tcConArgs DataType hs_details
+                 ; ty' <- tcHsLiftedType res_ty
+                 ; field_lbls <- lookupConstructorFields name
+                 ; let (arg_tys, stricts) = unzip btys
+                 ; return (ctxt, arg_tys, ty', field_lbls, stricts)
+                 }
+       ; return (ctxt,stricts,field_lbls,arg_tys,res_ty,hs_details)
+       }
+
+tcUpdateConResult :: SDoc
+            -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
+                    -- Original details
+            -> LHsType Name -- The original result type
+            -> TcM (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
+                    LHsType Name)
+tcUpdateConResult doc details ty
+  = do {  let (arg_tys, res_ty) = splitHsFunType ty
+                -- We can finally split it up,
+                -- now the renamer has dealt with fixities
+                -- See Note [Sorting out the result type] in RdrHsSyn
+
+       ; case details of
+           InfixCon {}  -> pprPanic "tcUpdateConResult" (ppr ty)
+           -- See Note [Sorting out the result type] in RdrHsSyn
+
+           RecCon {}    -> do { unless (null arg_tys)
+                                       (failWithTc (badRecResTy doc))
+                                -- AZ: This error used to be reported during
+                                --     renaming, will now be reported in type
+                                --     checking. Is this a problem?
+                              ; return (details, res_ty) }
+
+           PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
+    where
+        badRecResTy :: SDoc -> SDoc
+        badRecResTy ctxt = ctxt <+>
+                        ptext (sLit "Malformed constructor signature")
+
+tcConIsInfixH98 :: Name
              -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
-             -> ResType Type
              -> TcM Bool
-tcConIsInfix _   details ResTyH98
+tcConIsInfixH98 _   details
   = case details of
            InfixCon {}  -> return True
            _            -> return False
-tcConIsInfix con details (ResTyGADT _ _)
+
+tcConIsInfixGADT :: Name
+             -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
+             -> TcM Bool
+tcConIsInfixGADT con details
   = case details of
            InfixCon {}  -> return True
            RecCon {}    -> return False
-           PrefixCon arg_tys           -- See Note [Infix GADT cons]
+           PrefixCon arg_tys           -- See Note [Infix GADT constructors]
                | isSymOcc (getOccName con)
                , [_ty1,_ty2] <- arg_tys
                   -> do { fix_env <- getFixityEnv
@@ -1372,11 +1462,6 @@ tcConArg new_or_data bty
         ; traceTc "tcConArg 2" (ppr bty)
         ; return (arg_ty, getBangStrictness bty) }
 
-tcConRes :: ResType (LHsType Name) -> TcM (ResType Type)
-tcConRes ResTyH98           = return ResTyH98
-tcConRes (ResTyGADT ls res_ty) = do { res_ty' <- tcHsLiftedType res_ty
-                                    ; return (ResTyGADT ls res_ty') }
-
 {-
 Note [Infix GADT constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1432,7 +1517,7 @@ rejigConRes :: [TyVar] -> Type  -- Template for result type; e.g.
                                 -- data instance T [a] b c = ...
                                 --      gives template ([a,b,c], T [a] b c)
              -> [TyVar]         -- where MkT :: forall x y z. ...
-             -> ResType Type
+             -> Type            -- res_ty
              -> ([TyVar],               -- Universal
                  [TyVar],               -- Existential (distinct OccNames from univs)
                  [(TyVar,Type)],        -- Equality predicates
@@ -1440,13 +1525,7 @@ rejigConRes :: [TyVar] -> Type  -- Template for result type; e.g.
         -- We don't check that the TyCon given in the ResTy is
         -- the same as the parent tycon, because checkValidDataCon will do it
 
-rejigConRes tmpl_tvs res_ty dc_tvs ResTyH98
-  = (tmpl_tvs, dc_tvs, [], res_ty)
-        -- In H98 syntax the dc_tvs are the existential ones
-        --      data T a b c = forall d e. MkT ...
-        -- The universals {a,b,c} are tc_tvs, and the existentials {d,e} are dc_tvs
-
-rejigConRes tmpl_tvs res_tmpl dc_tvs (ResTyGADT _ res_ty)
+rejigConRes tmpl_tvs res_tmpl dc_tvs res_ty
         -- E.g.  data T [a] b c where
         --         MkT :: forall x y z. T [(x,y)] z z
         -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs
@@ -1499,7 +1578,7 @@ data SList s as where
 We call tcResultType with
   tmpl_tvs = [(k :: BOX), (s :: k -> *), (as :: List k)]
   res_tmpl = SList k s as
-  res_ty = ResTyGADT (SList k1 (s1 :: k1 -> *) (Nil k1))
+  res_ty = (SList k1 (s1 :: k1 -> *) (Nil k1))
 
 We get subst:
   k -> k1
diff --git a/testsuite/tests/ghc-api/annotations/T10399.stdout b/testsuite/tests/ghc-api/annotations/T10399.stdout
index 58a4093aae..612ecfd734 100644
--- a/testsuite/tests/ghc-api/annotations/T10399.stdout
+++ b/testsuite/tests/ghc-api/annotations/T10399.stdout
@@ -44,9 +44,7 @@
 ((Test10399.hs:15:45-46,AnnBang), [Test10399.hs:15:45]),
 ((Test10399.hs:15:45-46,AnnRarrow), [Test10399.hs:15:48-49]),
 ((Test10399.hs:15:45-64,AnnRarrow), [Test10399.hs:15:48-49]),
-((Test10399.hs:(16,5)-(17,69),AnnCloseP), [Test10399.hs:17:69]),
 ((Test10399.hs:(16,5)-(17,69),AnnDcolon), [Test10399.hs:16:12-13]),
-((Test10399.hs:(16,5)-(17,69),AnnOpenP), [Test10399.hs:16:27]),
 ((Test10399.hs:(16,15)-(17,69),AnnDot), [Test10399.hs:16:25]),
 ((Test10399.hs:(16,15)-(17,69),AnnForall), [Test10399.hs:16:15-20]),
 ((Test10399.hs:(16,27)-(17,69),AnnCloseP), [Test10399.hs:17:69]),
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index 4104bceebf..c7c8542a11 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -16,7 +16,7 @@ test('T10358',      normal, run_command, ['$MAKE -s --no-print-directory T10358'
 test('T10278',      normal, run_command, ['$MAKE -s --no-print-directory T10278'])
 test('T10354',      normal, run_command, ['$MAKE -s --no-print-directory T10354'])
 test('T10396',      normal, run_command, ['$MAKE -s --no-print-directory T10396'])
-test('T10399',      expect_broken(11028), run_command, ['$MAKE -s --no-print-directory T10399'])
+test('T10399',      normal, run_command, ['$MAKE -s --no-print-directory T10399'])
 test('T10313',      normal, run_command, ['$MAKE -s --no-print-directory T10313'])
 test('T11018',      normal, run_command, ['$MAKE -s --no-print-directory T11018'])
 test('bundle-export', normal, run_command, ['$MAKE -s --no-print-directory bundle-export'])
diff --git a/testsuite/tests/ghc-api/landmines/landmines.stdout b/testsuite/tests/ghc-api/landmines/landmines.stdout
index db0b651dfa..551b2cf8d7 100644
--- a/testsuite/tests/ghc-api/landmines/landmines.stdout
+++ b/testsuite/tests/ghc-api/landmines/landmines.stdout
@@ -1,4 +1,4 @@
 (12,12,7)
-(66,62,0)
+(63,63,0)
 (13,13,7)
 (10,10,7)
diff --git a/testsuite/tests/rename/should_compile/T5331.stderr b/testsuite/tests/rename/should_compile/T5331.stderr
index 13249b0e17..965e15a9b4 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:
 

 T5331.hs:11:16: warning:

     Unused quantified type variable ‘a’

-    In the definition of data constructor ‘W1’

+    In the type ‘forall a. W’

 

 T5331.hs:13:13: warning:

     Unused quantified type variable ‘a’

diff --git a/testsuite/tests/rename/should_fail/T7943.stderr b/testsuite/tests/rename/should_fail/T7943.stderr
index 8594a25e2f..c6bf7ae9b5 100644
--- a/testsuite/tests/rename/should_fail/T7943.stderr
+++ b/testsuite/tests/rename/should_fail/T7943.stderr
@@ -1,2 +1,6 @@
 
-T7943.hs:4:22: Record syntax is illegal here: {bar :: String}
+T7943.hs:4:22:
+     Record syntax is illegal here: {bar :: String}
+     In the type ‘{bar :: String}’
+      In the definition of data constructor ‘B’
+      In the data declaration for ‘Foo’
\ No newline at end of file
diff --git a/utils/haddock b/utils/haddock
-Subproject a6deefad581cbeb62048826bc1d626c41a0dd56
+Subproject 222954753de7a8a3708baff1d75a4b7c3a675f4