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

10 files changed, 31 insertions, 21 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 2bb6fc7d98..381db046b6 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -70,6 +70,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 032c003c6a..79cd28cfeb 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]
@@ -2938,10 +2939,11 @@ repGetField (MkC exp) fs = do
   MkC s <- coreStringLit $ unpackFS fs
   rep2 getFieldEName [exp,s]
 
-repProjection :: [FastString] -> MetaM (Core (M TH.Exp))
-repProjection fs = do
+repProjection :: NonEmpty FastString -> MetaM (Core (M TH.Exp))
+repProjection (f :| fs) = do
+  MkC x  <- coreStringLit $ unpackFS f
   MkC xs <- coreList' stringTy <$> mapM (coreStringLit . unpackFS) fs
-  rep2 projectionEName [xs]
+  rep2 projectionEName [x,xs]
 
 ------------ Lists -------------------
 -- turn a list of patterns into a single pattern matching a list
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 6d0a276ab7..a69f33b99b 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
@@ -2897,7 +2899,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'
                                         }
 
@@ -2945,12 +2947,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 [Located (DotFieldOcc GhcPs)] }
+projection :: { Located (NonEmpty (Located (DotFieldOcc GhcPs))) }
 projection
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer
         : projection TIGHT_INFIX_PROJ field
-                             {% acs (\cs -> sLL $1 $> ((sLL $2 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) : unLoc $1)) }
-        | PREFIX_PROJ field  {% acs (\cs -> sLL $1 $>  [sLL $1 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2]) }
+                             {% acs (\cs -> sLL $1 $> ((sLL $2 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) `NE.cons` unLoc $1)) }
+        | PREFIX_PROJ field  {% acs (\cs -> sLL $1 $>  ((sLL $1 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $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 688464dd9d..2b0ca42e7c 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -156,6 +156,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)
 
 {- **********************************************************************
 
@@ -3020,8 +3021,7 @@ mkRdrGetField loc arg field anns =
     , gf_field = field
     }
 
-mkRdrProjection :: [Located (DotFieldOcc GhcPs)] -> EpAnn AnnProjection -> HsExpr GhcPs
-mkRdrProjection [] _ = panic "mkRdrProjection: The impossible has happened!"
+mkRdrProjection :: NonEmpty (Located (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 fe8056f6c6..2a296e2f62 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -73,6 +73,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
@@ -332,7 +333,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) }
 
 ------------------------------------------
@@ -2634,15 +2635,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 -> [Located FieldLabelString] -> HsExpr GhcRn
-mkProjection getFieldName circName (field : fields) = foldl' f (proj field) fields
+mkProjection :: Name -> Name -> NonEmpty (Located FieldLabelString) -> HsExpr GhcRn
+mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fields
   where
     f :: HsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn
     f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc]
 
     proj :: Located 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 eb92fe1240..84e2f7079f 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -58,6 +58,7 @@ import qualified Data.ByteString as BS
 import Control.Monad( unless, ap )
 
 import Data.Maybe( catMaybes, isNothing )
+import Data.List.NonEmpty ( NonEmpty(..) )
 import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
 import Foreign.ForeignPtr
@@ -1057,7 +1058,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 noSrcSpan (DotFieldOcc noAnn (L noSrcSpan (fsLit f)))) }
-    cvt (ProjectionE xs) = return $ HsProjection noAnn $ map (L noSrcSpan . DotFieldOcc noAnn . L noSrcSpan . fsLit) xs
+    cvt (ProjectionE x xs) = return $ HsProjection noAnn $ fmap (L noSrcSpan . DotFieldOcc noAnn . L noSrcSpan . fsLit) (x :| 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 29769b6e93..0d2b54068a 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -51,6 +51,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)
 
@@ -554,7 +556,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@
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index 11e53ca701..0154c59d22 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -23,6 +23,7 @@ import qualified Language.Haskell.TH.Syntax as TH
 import Control.Applicative(liftA, liftA2)
 import qualified Data.Kind as Kind (Type)
 import Data.Word( Word8 )
+import Data.List.NonEmpty ( NonEmpty(..) )
 import GHC.Exts (TYPE)
 import Prelude
 
@@ -371,8 +372,8 @@ getFieldE e f = do
   e' <- e
   pure (GetFieldE e' f)
 
-projectionE :: Quote m => [String] -> m Exp
-projectionE xs = pure (ProjectionE xs)
+projectionE :: Quote m => NonEmpty String -> m Exp
+projectionE (x :| xs) = pure (ProjectionE x xs)
 
 -- ** 'arithSeqE' Shortcuts
 fromE :: Quote m => m Exp -> m Exp
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 7ed842ca94..d7c4ee1aca 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -224,7 +224,7 @@ pprExp _ (UnboundVarE v) = pprName' Applied v
 pprExp _ (LabelE s) = text "#" <> text s
 pprExp _ (ImplicitParamVarE n) = text ('?' : n)
 pprExp _ (GetFieldE e f) = pprExp appPrec e <> text ('.': f)
-pprExp _ (ProjectionE xs) = parens $ hcat $ map ((char '.'<>) . text) xs
+pprExp _ (ProjectionE x xs) = parens $ hcat $ map ((char '.'<>) . text) (x:xs)
 
 pprFields :: [(Name,Exp)] -> Doc
 pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index c219467337..76b9b954a5 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -2234,7 +2234,8 @@ data Exp
   | LabelE String                      -- ^ @{ #x }@ ( Overloaded label )
   | ImplicitParamVarE String           -- ^ @{ ?x }@ ( Implicit parameter )
   | GetFieldE Exp String               -- ^ @{ exp.field }@ ( Overloaded Record Dot )
-  | ProjectionE [String]                -- ^ @(.x)@ or @(.x.y)@ (Record projections)
+  | ProjectionE String [String]        -- ^ @(.x)@ or @(.x.y)@ or @(.x.y.z)@ etc. (Record projections)
+                                       -- There has to be at least one projection in the expression
   deriving( Show, Eq, Ord, Data, Generic )
 
 type FieldExp = (Name,Exp)