Use 'NonEmpty' for the fields in an 'HsProjection' (#20389)

T12545 is very inconsistently affected by this change for some reason.
There is a decrease in allocations on most configurations, but
an increase on validate-x86_64-linux-deb9-unreg-hadrian. Accepting it
as it seems unrelated to this patch.

Metric Decrease:
    T12545
Metric Increase:
    T12545

10 files changed, 57 insertions, 17 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 1c689629f1..c051f1c559 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -1873,6 +1873,9 @@ concretePrimTyConKey                    = mkPreludeTyConUnique 82
 eitherTyConKey :: Unique
 eitherTyConKey                          = mkPreludeTyConUnique 84
 
+nonEmptyTyConKey :: Unique
+nonEmptyTyConKey                        = mkPreludeTyConUnique 85
+
 -- Kind constructors
 liftedTypeKindTyConKey, unliftedTypeKindTyConKey,
   tYPETyConKey, liftedRepTyConKey, unliftedRepTyConKey,
@@ -2053,7 +2056,8 @@ charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,
     floatDataConKey, intDataConKey, nilDataConKey,
     ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,
     word8DataConKey, ioDataConKey, heqDataConKey,
-    coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey :: Unique
+    coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey,
+    nonEmptyDataConKey :: Unique
 
 charDataConKey                          = mkPreludeDataConUnique  1
 consDataConKey                          = mkPreludeDataConUnique  2
@@ -2072,6 +2076,7 @@ trueDataConKey                          = mkPreludeDataConUnique 14
 wordDataConKey                          = mkPreludeDataConUnique 15
 ioDataConKey                            = mkPreludeDataConUnique 16
 heqDataConKey                           = mkPreludeDataConUnique 18
+nonEmptyDataConKey                      = mkPreludeDataConUnique 19
 
 -- Generic data constructors
 crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index 42cf6c3a4b..79d0fcdb47 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -63,6 +63,10 @@ module GHC.Builtin.Types (
         promotedNilDataCon, promotedConsDataCon,
         mkListTy, mkPromotedListTy,
 
+        -- * NonEmpty
+        nonEmptyTyCon, nonEmptyTyConName,
+        nonEmptyDataCon, nonEmptyDataConName,
+
         -- * Maybe
         maybeTyCon, maybeTyConName,
         nothingDataCon, nothingDataConName, promotedNothingDataCon,
@@ -314,6 +318,7 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they
                 , unliftedRepTyCon
                 , zeroBitRepTyCon
                 , zeroBitTypeTyCon
+                , nonEmptyTyCon
                 ]
 
 mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
@@ -393,6 +398,10 @@ listTyConName     = mkWiredInTyConName   BuiltInSyntax gHC_TYPES (fsLit "[]") li
 nilDataConName    = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon
 consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon
 
+nonEmptyTyConName, nonEmptyDataConName :: Name
+nonEmptyTyConName   = mkWiredInTyConName   UserSyntax  gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey nonEmptyTyCon
+nonEmptyDataConName = mkWiredInDataConName UserSyntax  gHC_BASE (fsLit ":|") nonEmptyDataConKey nonEmptyDataCon
+
 maybeTyConName, nothingDataConName, justDataConName :: Name
 maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_MAYBE (fsLit "Maybe")
                                           maybeTyConKey maybeTyCon
@@ -1976,6 +1985,17 @@ consDataCon = pcDataConWithFixity True {- Declared infix -}
 -- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy
 -- gets the over-specific type (Type -> Type)
 
+-- NonEmpty lists (used for 'ProjectionE')
+nonEmptyTyCon :: TyCon
+nonEmptyTyCon = pcTyCon nonEmptyTyConName Nothing [alphaTyVar] [nonEmptyDataCon]
+
+nonEmptyDataCon :: DataCon
+nonEmptyDataCon = pcDataConWithFixity True {- Declared infix -}
+                    nonEmptyDataConName
+                    alpha_tyvar [] alpha_tyvar
+                    (map linear [alphaTy, mkTyConApp listTyCon alpha_ty])
+                    nonEmptyTyCon
+
 -- Wired-in type Maybe
 
 maybeTyCon :: TyCon
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index 3387523e20..0ab8a151bc 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -42,6 +42,9 @@ module GHC.Core.Make (
         mkNilExpr, mkConsExpr, mkListExpr,
         mkFoldrExpr, mkBuildExpr,
 
+        -- * Constructing non empty lists
+        mkNonEmptyListExpr,
+
         -- * Constructing Maybe expressions
         mkNothingExpr, mkJustExpr,
 
@@ -679,6 +682,9 @@ mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl]
 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
 
+mkNonEmptyListExpr :: Type -> CoreExpr -> [CoreExpr] -> CoreExpr
+mkNonEmptyListExpr ty x xs = mkCoreConApps nonEmptyDataCon [Type ty, x, mkListExpr ty xs]
+
 -- | Make a fully applied 'foldr' expression
 mkFoldrExpr :: MonadThings m
             => Type             -- ^ Element type of the list
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 9d3b5b12c3..ad49273464 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -71,6 +71,7 @@ import qualified Data.Data as Data (Fixity(..))
 import qualified Data.Kind
 import Data.Maybe (isJust)
 import Data.Void  ( Void )
+import Data.Foldable ( toList )
 
 {- *********************************************************************
 *                                                                      *
@@ -654,7 +655,7 @@ ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds })
 ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field })
   = ppr fexp <> dot <> ppr field
 
-ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr flds))))
+ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr $ toList flds))))
 
 ppr_expr (ExprWithTySig _ expr sig)
   = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index d6db406b44..42d2742bec 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -92,6 +92,7 @@ import qualified GHC.LanguageExtensions as LangExt
 import Data.ByteString ( unpack )
 import Control.Monad
 import Data.List (sort, sortBy)
+import Data.List.NonEmpty ( NonEmpty(..) )
 import Data.Function
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans.Class
@@ -1628,7 +1629,7 @@ repE (HsUnboundVar _ uv)   = do
 repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ f)))) = do
   e1 <- repLE e
   repGetField e1 f
-repE (HsProjection _ xs) = repProjection (map (unLoc . dfoLabel . unLoc) xs)
+repE (HsProjection _ xs) = repProjection (fmap (unLoc . dfoLabel . unLoc) xs)
 repE (XExpr (HsExpanded orig_expr ds_expr))
   = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
        ; if rebindable_on  -- See Note [Quotation and rebindable syntax]
@@ -2936,9 +2937,9 @@ repGetField (MkC exp) fs = do
   MkC s <- coreStringLit $ unpackFS fs
   rep2 getFieldEName [exp,s]
 
-repProjection :: [FastString] -> MetaM (Core (M TH.Exp))
+repProjection :: NonEmpty FastString -> MetaM (Core (M TH.Exp))
 repProjection fs = do
-  MkC xs <- coreList' stringTy <$> mapM (coreStringLit . unpackFS) fs
+  MkC xs <- coreListNonEmpty stringTy <$> mapM (coreStringLit . unpackFS) fs
   rep2 projectionEName [xs]
 
 ------------ Lists -------------------
@@ -2970,6 +2971,9 @@ coreList' :: Type       -- The element type
           -> [Core a] -> Core [a]
 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
 
+coreListNonEmpty :: Type -> NonEmpty (Core a) -> Core (NonEmpty a)
+coreListNonEmpty ty (MkC x :| xs) = MkC $ mkNonEmptyListExpr ty x (map unC xs)
+
 nonEmptyCoreList :: [Core a] -> Core [a]
   -- The list must be non-empty so we can get the element type
   -- Otherwise use coreList
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 9dcf96551e..3575ee8eee 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -44,6 +44,8 @@ where
 import Control.Monad    ( unless, liftM, when, (<=<) )
 import GHC.Exts
 import Data.Maybe       ( maybeToList )
+import Data.List.NonEmpty ( NonEmpty(..) )
+import qualified Data.List.NonEmpty as NE
 import qualified Prelude -- for happy-generated code
 
 import GHC.Prelude
@@ -2891,7 +2893,7 @@ aexp2   :: { ECP }
 
         -- This case is only possible when 'OverloadedRecordDotBit' is enabled.
         | '(' projection ')'            { ECP $
-                                            acsA (\cs -> sLL $1 $> $ mkRdrProjection (reverse (unLoc $2)) (EpAnn (glR $1) (AnnProjection (glAA $1) (glAA $3)) cs))
+                                            acsA (\cs -> sLL $1 $> $ mkRdrProjection (NE.reverse (unLoc $2)) (EpAnn (glR $1) (AnnProjection (glAA $1) (glAA $3)) cs))
                                             >>= ecpFromExp'
                                         }
 
@@ -2939,12 +2941,12 @@ aexp2   :: { ECP }
                                       acsA (\cs -> sLL $1 $> $ HsCmdArrForm (EpAnn (glR $1) (AnnList (Just $ glR $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix
                                                            Nothing (reverse $3)) }
 
-projection :: { Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] }
+projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) }
 projection
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer
         : projection TIGHT_INFIX_PROJ field
-                             {% acs (\cs -> sLL $1 $> ((sLLa $2 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) (reLocA $3)) : unLoc $1)) }
-        | PREFIX_PROJ field  {% acs (\cs -> sLL $1 $>  [sLLa $1 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) (reLocA $2)]) }
+                             {% acs (\cs -> sLL $1 $> ((sLLa $2 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) (reLocA $3)) `NE.cons` unLoc $1)) }
+        | PREFIX_PROJ field  {% acs (\cs -> sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) (reLocA $2)) :| [])) }
 
 splice_exp :: { LHsExpr GhcPs }
         : splice_untyped { mapLoc (HsSpliceE noAnn) (reLocA $1) }
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 96e08d781f..aab72310ac 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -159,6 +159,7 @@ import Text.ParserCombinators.ReadP as ReadP
 import Data.Char
 import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
 import Data.Kind       ( Type )
+import Data.List.NonEmpty (NonEmpty)
 
 {- **********************************************************************
 
@@ -3057,8 +3058,7 @@ mkRdrGetField loc arg field anns =
     , gf_field = field
     }
 
-mkRdrProjection :: [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] -> EpAnn AnnProjection -> HsExpr GhcPs
-mkRdrProjection [] _ = panic "mkRdrProjection: The impossible has happened!"
+mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> EpAnn AnnProjection -> HsExpr GhcPs
 mkRdrProjection flds anns =
   HsProjection {
       proj_ext = anns
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 53d9c6fa32..1e24c1bb3d 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -74,6 +74,7 @@ import GHC.Builtin.Types ( nilDataConName )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Data.List (unzip4, minimumBy)
+import Data.List.NonEmpty ( NonEmpty(..) )
 import Data.Maybe (isJust, isNothing)
 import Control.Arrow (first)
 import Data.Ord
@@ -331,7 +332,7 @@ rnExpr (HsProjection _ fs)
        ; let fs' = fmap rnDotFieldOcc fs
        ; return ( mkExpandedExpr
                     (HsProjection noExtField fs')
-                    (mkProjection getField circ (map (fmap (unLoc . dfoLabel)) fs'))
+                    (mkProjection getField circ (fmap (fmap (unLoc . dfoLabel)) fs'))
                 , unitFV circ `plusFV` fv_getField) }
 
 ------------------------------------------
@@ -2635,15 +2636,14 @@ mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc)
 -- mkProjection fields calculates a projection.
 -- e.g. .x = mkProjection [x] = getField @"x"
 --      .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x"
-mkProjection :: Name -> Name -> [LocatedAn NoEpAnns FieldLabelString] -> HsExpr GhcRn
-mkProjection getFieldName circName (field : fields) = foldl' f (proj field) fields
+mkProjection :: Name -> Name -> NonEmpty (LocatedAn NoEpAnns FieldLabelString) -> HsExpr GhcRn
+mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fields
   where
     f :: HsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
     f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc]
 
     proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
     proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f
-mkProjection _ _ [] = panic "mkProjection: The impossible happened"
 
 -- mkProjUpdateSetField calculates functions representing dot notation record updates.
 -- e.g. Suppose an update like foo.bar = 1.
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index a0c7b7e222..891eb0af0e 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1050,7 +1050,7 @@ cvtl e = wrapLA (cvt e)
     cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' }
     cvt (GetFieldE exp f) = do { e' <- cvtl exp
                                ; return $ HsGetField noComments e' (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (fsLit f)))) }
-    cvt (ProjectionE xs) = return $ HsProjection noAnn $ map (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . fsLit) xs
+    cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . fsLit) xs
 
 {- | #16895 Ensure an infix expression's operator is a variable/constructor.
 Consider this example:
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index b472ac9589..16e0e4d2e5 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -50,6 +50,8 @@ import GHC.Core.Type
 import Data.Data hiding (Fixity(..))
 import qualified Data.Data as Data (Fixity(..))
 
+import Data.List.NonEmpty ( NonEmpty )
+
 import GHCi.RemoteTypes ( ForeignRef )
 import qualified Language.Haskell.TH as TH (Q)
 
@@ -555,7 +557,7 @@ data HsExpr p
   -- For details on above see note [exact print annotations] in GHC.Parser.Annotation
   | HsProjection {
         proj_ext :: XProjection p
-      , proj_flds :: [XRec p (DotFieldOcc p)]
+      , proj_flds :: NonEmpty (XRec p (DotFieldOcc p))
       }
 
   -- | Expression with an explicit type signature. @e :: type@