TH: revert changes to GadtC & RecGadtC

Commit 3f374399 included a breaking-change to the template-haskell
library when it made the GadtC and RecGadtC constructors take non-empty
lists of names. As this has the potential to break many users' packages,
we decided to revert these changes for now.

6 files changed, 51 insertions, 29 deletions

diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 3166370e14..75a7121548 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -95,7 +95,7 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 import Data.ByteString ( unpack )
 import Control.Monad
 import Data.List (sort, sortBy)
-import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.List.NonEmpty ( NonEmpty(..), toList )
 import Data.Function
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans.Class
@@ -2742,19 +2742,16 @@ repGadtDataCons :: NonEmpty (LocatedN Name)
                 -> LHsType GhcRn
                 -> MetaM (Core (M TH.Con))
 repGadtDataCons cons details res_ty
-    = do ne_tycon   <- lift $ dsLookupTyCon nonEmptyTyConName
-         name_tycon <- lift $ dsLookupTyCon nameTyConName
-         let mk_nonEmpty = coreListNonEmpty ne_tycon (mkTyConTy name_tycon)
-         cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
+    = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
          case details of
            PrefixConGADT ps -> do
              arg_tys <- repPrefixConArgs ps
              res_ty' <- repLTy res_ty
-             rep2 gadtCName [unC (mk_nonEmpty cons'), unC arg_tys, unC res_ty']
+             rep2 gadtCName [ unC (nonEmptyCoreList' cons'), unC arg_tys, unC res_ty']
            RecConGADT ips _ -> do
              arg_vtys <- repRecConArgs ips
              res_ty'  <- repLTy res_ty
-             rep2 recGadtCName [unC (mk_nonEmpty cons'), unC arg_vtys,
+             rep2 recGadtCName [unC (nonEmptyCoreList' cons'), unC arg_vtys,
                                 unC res_ty']
 
 -- TH currently only supports linear constructors.
@@ -3060,6 +3057,9 @@ nonEmptyCoreList :: [Core a] -> Core [a]
 nonEmptyCoreList []           = panic "coreList: empty argument"
 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
 
+nonEmptyCoreList' :: NonEmpty (Core a) -> Core [a]
+nonEmptyCoreList' xs@(MkC x:|_) = MkC (mkListExpr (exprType x) (toList $ fmap unC xs))
+
 coreStringLit :: MonadThings m => FastString -> m (Core String)
 coreStringLit s = do { z <- mkStringExprFS s; return (MkC z) }
 
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index d33a5647ae..09918d4014 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -4831,6 +4831,10 @@ pprConversionFailReason = \case
     text "Implicit parameters mixed with other bindings"
   InvalidCCallImpent from ->
     text (show from) <+> text "is not a valid ccall impent"
+  RecGadtNoCons ->
+    quotes (text "RecGadtC") <+> text "must have at least one constructor name"
+  GadtNoCons ->
+    quotes (text "GadtC") <+> text "must have at least one constructor name"
   InvalidTypeInstanceHeader tys ->
     text "Invalid type instance header:"
     <+> text (show tys)
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 5f567495a3..648074f4f3 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -3683,6 +3683,8 @@ data ConversionFailReason
   | CasesExprWithoutAlts
   | ImplicitParamsWithOtherBinds
   | InvalidCCallImpent !String -- ^ Source
+  | RecGadtNoCons
+  | GadtNoCons
   | InvalidTypeInstanceHeader !TH.Type
   | InvalidTyFamInstLHS !TH.Type
   | InvalidImplicitParamBinding
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index f3d7c3c381..fcfe39cb4d 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -143,7 +143,6 @@ import Unsafe.Coerce    ( unsafeCoerce )
 import Control.Monad
 import Data.Binary
 import Data.Binary.Get
-import qualified Data.List.NonEmpty as NE ( singleton )
 import Data.Maybe
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as LB
@@ -2235,7 +2234,7 @@ reifyDataCon isGadtDataCon tys dc
                                          dcdBangs r_arg_tys)
               | not (null fields) -> do
                   { res_ty <- reifyType g_res_ty
-                  ; return $ TH.RecGadtC (NE.singleton name)
+                  ; return $ TH.RecGadtC [name]
                                      (zip3 (map reifyFieldLabel fields)
                                       dcdBangs r_arg_tys) res_ty }
                 -- We need to check not isGadtDataCon here because GADT
@@ -2248,7 +2247,7 @@ reifyDataCon isGadtDataCon tys dc
                   ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
               | isGadtDataCon -> do
                   { res_ty <- reifyType g_res_ty
-                  ; return $ TH.GadtC (NE.singleton name)
+                  ; return $ TH.GadtC [name]
                                  (dcdBangs `zip` r_arg_tys) res_ty }
               | otherwise ->
                   return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 3b2cfc47a7..991674db34 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -276,7 +276,11 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs)
 cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
         ; ksig' <- cvtKind `traverse` ksig
-        ; con' <- cvtConstr (NE.head $ get_cons_names constr) cNameN constr
+        ; let first_datacon =
+                case get_cons_names constr of
+                  []  -> panic "cvtDec: empty list of constructors"
+                  c:_ -> c
+        ; con' <- cvtConstr first_datacon cNameN constr
         ; derivs' <- cvtDerivs derivs
         ; let defn = HsDataDefn { dd_ext = noExtField
                                 , dd_cType = Nothing
@@ -348,8 +352,10 @@ cvtDec (DataFamilyD tc tvs kind)
 cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
   = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
        ; ksig' <- cvtKind `traverse` ksig
-
-       ; let first_datacon = NE.head $ get_cons_names $ head constrs
+       ; let first_datacon =
+                case get_cons_names $ head constrs of
+                  []  -> panic "cvtDec: empty list of constructors"
+                  c:_ -> c
        ; cons' <- mapM (cvtConstr first_datacon cNameN) constrs
        ; derivs' <- cvtDerivs derivs
        ; let defn = HsDataDefn { dd_ext = noExtField
@@ -372,7 +378,11 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
 cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
   = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
        ; ksig' <- cvtKind `traverse` ksig
-       ; con' <- cvtConstr (NE.head $ get_cons_names $ constr) cNameN constr
+       ; let first_datacon =
+                case get_cons_names constr of
+                  []  -> panic "cvtDec: empty list of constructors"
+                  c:_ -> c
+       ; con' <- cvtConstr first_datacon cNameN constr
        ; derivs' <- cvtDerivs derivs
        ; let defn = HsDataDefn { dd_ext = noExtField
                                , dd_cType = Nothing
@@ -507,7 +517,10 @@ cvtGenDataDec type_data ctxt tc tvs ksig constrs derivs
         ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
         ; ksig' <- cvtKind `traverse` ksig
 
-        ; let first_datacon = NE.head $ get_cons_names $ head constrs
+        ; let first_datacon =
+                case get_cons_names $ head constrs of
+                  []  -> panic "cvtGenDataDec: empty list of constructors"
+                  c:_ -> c
         ; cons' <- mapM (cvtConstr first_datacon con_name) constrs
 
         ; derivs' <- cvtDerivs derivs
@@ -709,18 +722,22 @@ cvtConstr parent_con do_con_name (ForallC tvs ctxt con)
       where
         all_tvs = tvs' ++ ex_tvs
 
-cvtConstr _ do_con_name (GadtC cs strtys ty)
-  = do { cs'     <- mapM do_con_name cs
-       ; args    <- mapM cvt_arg strtys
-       ; ty'     <- cvtType ty
-       ; mk_gadt_decl cs' (PrefixConGADT $ map hsLinear args) ty'}
-
-cvtConstr parent_con do_con_name (RecGadtC cs varstrtys ty)
-  = do { cs'      <- mapM do_con_name cs
-       ; ty'      <- cvtType ty
-       ; rec_flds <- mapM (cvt_id_arg parent_con) varstrtys
-       ; lrec_flds <- returnLA rec_flds
-       ; mk_gadt_decl cs' (RecConGADT lrec_flds noHsUniTok) ty' }
+cvtConstr _ do_con_name (GadtC c strtys ty) = case nonEmpty c of
+    Nothing -> failWith GadtNoCons
+    Just c -> do
+        { c'      <- mapM do_con_name c
+        ; args    <- mapM cvt_arg strtys
+        ; ty'     <- cvtType ty
+        ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'}
+
+cvtConstr parent_con do_con_name (RecGadtC c varstrtys ty) = case nonEmpty c of
+    Nothing -> failWith RecGadtNoCons
+    Just c -> do
+        { c'       <- mapM do_con_name c
+        ; ty'      <- cvtType ty
+        ; rec_flds <- mapM (cvt_id_arg parent_con) varstrtys
+        ; lrec_flds <- returnLA rec_flds
+        ; mk_gadt_decl c' (RecConGADT lrec_flds noHsUniTok) ty' }
 
 mk_gadt_decl :: NonEmpty (LocatedN RdrName) -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
              -> CvtM (LConDecl GhcPs)
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 7edcbbddbd..90950b3bb4 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -622,6 +622,8 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "CasesExprWithoutAlts"                          = 91745
   GhcDiagnosticCode "ImplicitParamsWithOtherBinds"                  = 42974
   GhcDiagnosticCode "InvalidCCallImpent"                            = 60220
+  GhcDiagnosticCode "RecGadtNoCons"                                 = 18816
+  GhcDiagnosticCode "GadtNoCons"                                    = 38140
   GhcDiagnosticCode "InvalidTypeInstanceHeader"                     = 37056
   GhcDiagnosticCode "InvalidTyFamInstLHS"                           = 78486
   GhcDiagnosticCode "InvalidImplicitParamBinding"                   = 51603
@@ -705,8 +707,6 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote"                = 40027
   GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn"                   = 69639
   GhcDiagnosticCode "TcRnMixedSelectors"                            = 40887
-  GhcDiagnosticCode "RecGadtNoCons"                                 = 18816
-  GhcDiagnosticCode "GadtNoCons"                                    = 38140
 
 {- *********************************************************************
 *                                                                      *