Refactor ConDeclwip/T11028

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.

Trac issue: #11028

4 files changed, 70 insertions, 87 deletions

diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index c90b556cac..57890aad4f 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..3cbb887693 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -610,11 +610,20 @@ 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..fb6ab27078 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)