summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Hs/Expr.hs3
-rw-r--r--compiler/GHC/HsToCore/Quote.hs10
-rw-r--r--compiler/GHC/Parser.y10
-rw-r--r--compiler/GHC/Parser/PostProcess.hs4
-rw-r--r--compiler/GHC/Rename/Expr.hs8
-rw-r--r--compiler/GHC/ThToHs.hs3
6 files changed, 22 insertions, 16 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:
View Lorry Controller Status