summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsheaf <sam.derbyshire@gmail.com>2021-06-28 17:43:24 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-06-29 15:36:08 -0400
commit4e9f58c759f16a3a20c338799a5b83d334c2778d (patch)
treef7013651d23a13356499ef2d22b54919f8faa6ca
parentb760c1f743ddb496886f095baa920740b38c9ce0 (diff)
downloadhaskell-4e9f58c759f16a3a20c338799a5b83d334c2778d.tar.gz
Use HsExpansion for overloaded list patterns
Fixes #14380, #19997
-rw-r--r--compiler/GHC/Hs/Expr.hs15
-rw-r--r--compiler/GHC/Hs/Instances.hs4
-rw-r--r--compiler/GHC/Hs/Pat.hs141
-rw-r--r--compiler/GHC/Hs/Syn/Type.hs8
-rw-r--r--compiler/GHC/Hs/Utils.hs8
-rw-r--r--compiler/GHC/HsToCore/Match.hs48
-rw-r--r--compiler/GHC/HsToCore/Pmc/Desugar.hs71
-rw-r--r--compiler/GHC/HsToCore/Quote.hs8
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs16
-rw-r--r--compiler/GHC/Rename/Expr.hs55
-rw-r--r--compiler/GHC/Rename/Pat.hs127
-rw-r--r--compiler/GHC/Rename/Utils.hs35
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs25
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs59
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs22
-rw-r--r--compiler/Language/Haskell/Syntax/Pat.hs7
-rw-r--r--docs/users_guide/exts/overloaded_lists.rst12
-rw-r--r--testsuite/tests/overloadedlists/should_fail/overloadedlistsfail06.stderr5
-rw-r--r--testsuite/tests/patsyn/should_compile/T14380.hs (renamed from testsuite/tests/patsyn/should_fail/T14380.hs)0
-rw-r--r--testsuite/tests/patsyn/should_compile/all.T1
-rw-r--r--testsuite/tests/patsyn/should_fail/T14380.stderr9
-rw-r--r--testsuite/tests/patsyn/should_fail/all.T1
22 files changed, 430 insertions, 247 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 72ac021e45..24b8247b32 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -889,8 +889,9 @@ instance Outputable (HsPragE (GhcPass p)) where
{- Note [Rebindable syntax and HsExpansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We implement rebindable syntax (RS) support by performing a desugaring
-in the renamer. We transform GhcPs expressions affected by RS into the
-appropriate desugared form, but **annotated with the original expression**.
+in the renamer. We transform GhcPs expressions and patterns affected by
+RS into the appropriate desugared form, but **annotated with the original
+expression/pattern**.
Let us consider a piece of code like:
@@ -981,18 +982,24 @@ tcl_in_gen_code Bool to False.
---
+An overview of the constructs that are desugared in this way is laid out in
+Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.
+
A general recipe to follow this approach for new constructs could go as follows:
- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your
construct, in HsExpr or related syntax data types.
- At renaming-time:
- take your original node of interest (HsIf above)
- - rename its subexpressions (condition, true branch, false branch above)
+ - rename its subexpressions/subpatterns (condition and true/false
+ branches above)
- construct the suitable "rebound"-and-renamed result (ifThenElse call
above), where the 'SrcSpan' attached to any _fabricated node_ (the
HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'
- take both the original node and that rebound-and-renamed result and wrap
- them in an XExpr: XExpr (HsExpanded <original node> <desugared>)
+ them into an expansion construct:
+ for expressions, XExpr (HsExpanded <original node> <desugared>)
+ for patterns, XPat (HsPatExpanded <original node> <desugared>)
- At typechecking-time:
- remove any logic that was previously dealing with your rebindable
construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 4ec53aeaf0..87f1ceafff 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -421,11 +421,8 @@ deriving instance Data (Pat GhcPs)
deriving instance Data (Pat GhcRn)
deriving instance Data (Pat GhcTc)
-deriving instance Data CoPat
deriving instance Data ConPatTc
-deriving instance Data ListPatTc
-
deriving instance (Data a, Data b) => Data (HsFieldBind a b)
deriving instance (Data body) => Data (HsRecFields GhcPs body)
@@ -529,6 +526,7 @@ deriving instance Eq (IE GhcTc)
-- ---------------------------------------------------------------------
deriving instance Data XXExprGhcTc
+deriving instance Data XXPatGhcTc
-- ---------------------------------------------------------------------
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 3f856ec06d..f300c4a2ca 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -23,9 +23,9 @@ module GHC.Hs.Pat (
Pat(..), LPat,
EpAnnSumPat(..),
ConPatTc (..),
- CoPat (..),
- ListPatTc(..),
ConLikeP,
+ HsPatExpansion(..),
+ XXPatGhcTc(..),
HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsFieldBind(..), LHsFieldBind,
@@ -51,7 +51,7 @@ module GHC.Hs.Pat (
import GHC.Prelude
import Language.Haskell.Syntax.Pat
-import Language.Haskell.Syntax.Expr (SyntaxExpr)
+import Language.Haskell.Syntax.Expr ( HsExpr )
import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprSplice)
@@ -85,11 +85,6 @@ import Data.Data
import Data.Void
-data ListPatTc
- = ListPatTc
- Type -- The type of the elements
- (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax
-
type instance XWildPat GhcPs = NoExtField
type instance XWildPat GhcRn = NoExtField
type instance XWildPat GhcTc = Type
@@ -110,12 +105,15 @@ type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!'
type instance XBangPat GhcRn = NoExtField
type instance XBangPat GhcTc = NoExtField
--- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap
--- compiler, as it triggers https://gitlab.haskell.org/ghc/ghc/issues/14396 for
--- `SyntaxExpr`
type instance XListPat GhcPs = EpAnn AnnList
-type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn)
-type instance XListPat GhcTc = ListPatTc
+ -- After parsing, ListPat can refer to a built-in Haskell list pattern
+ -- or an overloaded list pattern.
+type instance XListPat GhcRn = NoExtField
+ -- Built-in list patterns only.
+ -- After renaming, overloaded list patterns are expanded to view patterns.
+ -- See Note [Desugaring overloaded list patterns]
+type instance XListPat GhcTc = Type
+ -- List element type, for use in hsPatType.
type instance XTuplePat GhcPs = EpAnn [AddEpAnn]
type instance XTuplePat GhcRn = NoExtField
@@ -130,8 +128,14 @@ type instance XConPat GhcRn = NoExtField
type instance XConPat GhcTc = ConPatTc
type instance XViewPat GhcPs = EpAnn [AddEpAnn]
-type instance XViewPat GhcRn = NoExtField
+type instance XViewPat GhcRn = Maybe (HsExpr GhcRn)
+ -- The @HsExpr GhcRn@ gives an inverse to the view function.
+ -- This is used for overloaded lists in particular.
+ -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn.
+
type instance XViewPat GhcTc = Type
+ -- Overall type of the pattern
+ -- (= the argument type of the view function), for hsPatType.
type instance XSplicePat GhcPs = NoExtField
type instance XSplicePat GhcRn = NoExtField
@@ -152,9 +156,13 @@ type instance XSigPat GhcRn = NoExtField
type instance XSigPat GhcTc = Type
type instance XXPat GhcPs = NoExtCon
-type instance XXPat GhcRn = NoExtCon
-type instance XXPat GhcTc = CoPat
- -- After typechecking, we add one extra constructor: CoPat
+type instance XXPat GhcRn = HsPatExpansion (Pat GhcRn) (Pat GhcRn)
+ -- Original pattern and its desugaring/expansion.
+ -- See Note [Rebindable syntax and HsExpansion].
+type instance XXPat GhcTc = XXPatGhcTc
+ -- After typechecking, we add extra constructors: CoPat and HsExpansion.
+ -- HsExpansion allows us to handle RebindableSyntax in pattern position:
+ -- see "XXExpr GhcTc" for the counterpart in expressions.
type instance ConLikeP GhcPs = RdrName -- IdP GhcPs
type instance ConLikeP GhcRn = Name -- IdP GhcRn
@@ -174,6 +182,35 @@ data EpAnnSumPat = EpAnnSumPat
-- ---------------------------------------------------------------------
+-- | Extension constructor for Pat, added after typechecking.
+data XXPatGhcTc
+ = -- | Coercion Pattern (translation only)
+ --
+ -- During desugaring a (CoPat co pat) turns into a cast with 'co' on the
+ -- scrutinee, followed by a match on 'pat'.
+ CoPat
+ { -- | Coercion Pattern
+ -- If co :: t1 ~ t2, p :: t2,
+ -- then (CoPat co p) :: t1
+ co_cpt_wrap :: HsWrapper
+
+ , -- | Why not LPat? Ans: existing locn will do
+ co_pat_inner :: Pat GhcTc
+
+ , -- | Type of whole pattern, t1
+ co_pat_ty :: Type
+ }
+ -- | Pattern expansion: original pattern, and desugared pattern,
+ -- for RebindableSyntax and other overloaded syntax such as OverloadedLists.
+ -- See Note [Rebindable syntax and HsExpansion].
+ | ExpansionPat (Pat GhcRn) (Pat GhcTc)
+
+
+-- See Note [Rebindable syntax and HsExpansion].
+data HsPatExpansion a b
+ = HsPatExpanded a b
+ deriving Data
+
-- | This is the extension field for ConPat, added after typechecking
-- It adds quite a few extra fields, to support elaboration of pattern matching.
data ConPatTc
@@ -202,24 +239,6 @@ data ConPatTc
cpt_wrap :: HsWrapper
}
--- | Coercion Pattern (translation only)
---
--- During desugaring a (CoPat co pat) turns into a cast with 'co' on the
--- scrutinee, followed by a match on 'pat'.
-data CoPat
- = CoPat
- { -- | Coercion Pattern
- -- If co :: t1 ~ t2, p :: t2,
- -- then (CoPat co p) :: t1
- co_cpt_wrap :: HsWrapper
-
- , -- | Why not LPat? Ans: existing locn will do
- co_pat_inner :: Pat GhcTc
-
- , -- | Type of whole pattern, t1
- co_pat_ty :: Type
- }
-
hsRecFieldId :: HsRecField GhcTc arg -> Id
hsRecFieldId = hsRecFieldSel
@@ -244,6 +263,10 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS
instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
ppr = pprPat
+-- See Note [Rebindable syntax and HsExpansion].
+instance (Outputable a, Outputable b) => Outputable (HsPatExpansion a b) where
+ ppr (HsPatExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)
+
pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc
pprLPat (L _ e) = pprPat e
@@ -270,8 +293,7 @@ pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_ela
where
need_parens print_tc_elab pat
| GhcTc <- ghcPass @p
- , XPat ext <- pat
- , CoPat {} <- ext
+ , XPat (CoPat {}) <- pat
= print_tc_elab
| otherwise
@@ -335,13 +357,16 @@ pprPat (ConPat { pat_con = con
pprPat (XPat ext) = case ghcPass @p of
#if __GLASGOW_HASKELL__ < 811
GhcPs -> noExtCon ext
- GhcRn -> noExtCon ext
#endif
- GhcTc -> pprHsWrapper co $ \parens ->
- if parens
- then pprParendPat appPrec pat
- else pprPat pat
- where CoPat co pat _ = ext
+ GhcRn -> case ext of
+ HsPatExpanded orig _ -> pprPat orig
+ GhcTc -> case ext of
+ CoPat co pat _ ->
+ pprHsWrapper co $ \parens ->
+ if parens
+ then pprParendPat appPrec pat
+ else pprPat pat
+ ExpansionPat orig _ -> pprPat orig
pprUserCon :: (OutputableBndr con, OutputableBndrId p,
Outputable (Anno (IdGhcP p)))
@@ -543,10 +568,12 @@ isIrrefutableHsPat' is_strict = goL
go (XPat ext) = case ghcPass @p of
#if __GLASGOW_HASKELL__ < 811
GhcPs -> noExtCon ext
- GhcRn -> noExtCon ext
#endif
- GhcTc -> go pat
- where CoPat _ pat _ = ext
+ GhcRn -> case ext of
+ HsPatExpanded _ pat -> go pat
+ GhcTc -> case ext of
+ CoPat _ pat _ -> go pat
+ ExpansionPat _ pat -> go pat
-- | Is the pattern any of combination of:
--
@@ -590,22 +617,28 @@ is the only thing that could possibly be matched!
-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
-- parentheses under precedence @p@.
patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool
-patNeedsParens p = go
+patNeedsParens p = go @p
where
- go :: Pat (GhcPass p) -> Bool
+ -- Remark: go needs to be polymorphic, as we call it recursively
+ -- at a different GhcPass (see the case for GhcTc XPat below).
+ go :: forall q. IsPass q => Pat (GhcPass q) -> Bool
go (NPlusKPat {}) = p > opPrec
go (SplicePat {}) = False
go (ConPat { pat_args = ds })
= conPatNeedsParens p ds
go (SigPat {}) = p >= sigPrec
go (ViewPat {}) = True
- go (XPat ext) = case ghcPass @p of
+ go (XPat ext) = case ghcPass @q of
#if __GLASGOW_HASKELL__ < 901
GhcPs -> noExtCon ext
- GhcRn -> noExtCon ext
#endif
- GhcTc -> go inner
- where CoPat _ inner _ = ext
+ GhcRn -> case ext of
+ HsPatExpanded orig _ -> go orig
+ GhcTc -> case ext of
+ CoPat _ inner _ -> go inner
+ ExpansionPat orig _ -> go orig
+ -- ^^^^^^^
+ -- NB: recursive call of go at a different GhcPass.
go (WildPat {}) = False
go (VarPat {}) = False
go (LazyPat {}) = False
@@ -679,7 +712,9 @@ collectEvVarsPat pat =
$ map collectEvVarsLPat
$ hsConPatArgs args
SigPat _ p _ -> collectEvVarsLPat p
- XPat (CoPat _ p _) -> collectEvVarsPat p
+ XPat ext -> case ext of
+ CoPat _ p _ -> collectEvVarsPat p
+ ExpansionPat _ p -> collectEvVarsPat p
_other_pat -> emptyBag
{-
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 6428a99ff4..1c9b1706bd 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -50,8 +50,7 @@ hsPatType (LazyPat _ pat) = hsLPatType pat
hsPatType (LitPat _ lit) = hsLitType lit
hsPatType (AsPat _ var _) = idType (unLoc var)
hsPatType (ViewPat ty _ _) = ty
-hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty
-hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
+hsPatType (ListPat ty _) = mkListTy ty
hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys
-- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
hsPatType (SumPat tys _ _ _ ) = mkSumTy tys
@@ -64,7 +63,10 @@ hsPatType (ConPat { pat_con = lcon
hsPatType (SigPat ty _ _) = ty
hsPatType (NPat ty _ _ _) = ty
hsPatType (NPlusKPat ty _ _ _ _ _) = ty
-hsPatType (XPat (CoPat _ _ ty)) = ty
+hsPatType (XPat ext) =
+ case ext of
+ CoPat _ _ ty -> ty
+ ExpansionPat _ pat -> hsPatType pat
hsPatType (SplicePat v _) = dataConCantHappen v
hsLitType :: HsLit (GhcPass p) -> Type
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 42ea9f0ae7..590cf87793 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1240,9 +1240,13 @@ class UnXRec p => CollectPass p where
instance IsPass p => CollectPass (GhcPass p) where
collectXXPat _ flag ext =
case ghcPass @p of
- GhcTc -> let CoPat _ pat _ = ext in collect_pat flag pat
- GhcRn -> noExtCon ext
GhcPs -> noExtCon ext
+ GhcRn
+ | HsPatExpanded _ pat <- ext
+ -> collect_pat flag pat
+ GhcTc -> case ext of
+ CoPat _ pat _ -> collect_pat flag pat
+ ExpansionPat _ pat -> collect_pat flag pat
{-
Note [Dictionary binders in ConPatOut]
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 6576add1a2..67a478907c 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -1,7 +1,9 @@
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -23,7 +25,7 @@ where
import GHC.Prelude
import GHC.Platform
-import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr)
+import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) )
import GHC.Types.SourceText
@@ -232,7 +234,6 @@ match (v:vs) ty eqns -- Eqns *can* be empty
PgBang -> matchBangs vars ty (dropGroup eqns)
PgCo {} -> matchCoercion vars ty (dropGroup eqns)
PgView {} -> matchView vars ty (dropGroup eqns)
- PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
where eqns' = NEL.toList eqns
ne l = case NEL.nonEmpty l of
Just nel -> nel
@@ -289,46 +290,42 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
= do { -- we could pass in the expr from the PgView,
-- but this needs to extract the pat anyway
-- to figure out the type of the fresh variable
- let ViewPat _ viewExpr (L _ pat) = firstPat eqn1
+ let TcViewPat viewExpr pat = firstPat eqn1
-- do the rest of the compilation
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var (idMult var) pat_ty'
; match_result <- match (var':vars) ty $ NEL.toList $
decomposeFirstPat getViewPat <$> eqns
-- compile the view expressions
- ; viewExpr' <- dsLExpr viewExpr
+ ; viewExpr' <- dsExpr viewExpr
; return (mkViewMatchResult var'
(mkCoreAppDs (text "matchView") viewExpr' (Var var))
match_result) }
-matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
-matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _))
--- Since overloaded list patterns are treated as view patterns,
--- the code is roughly the same as for matchView
- = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1
- ; var' <- newUniqueId var (idMult var) (mkListTy elt_ty) -- we construct the overall type by hand
- ; match_result <- match (var':vars) ty $ NEL.toList $
- decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
- ; e' <- dsSyntaxExpr e [Var var]
- ; return (mkViewMatchResult var' e' match_result)
- }
-
-- decompose the first pattern and leave the rest alone
decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
= eqn { eqn_pats = extractpat pat : pats}
decomposeFirstPat _ _ = panic "decomposeFirstPat"
-getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
+getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
getCoPat (XPat (CoPat _ pat _)) = pat
getCoPat _ = panic "getCoPat"
getBangPat (BangPat _ pat ) = unLoc pat
getBangPat _ = panic "getBangPat"
-getViewPat (ViewPat _ _ pat) = unLoc pat
+getViewPat (TcViewPat _ pat) = pat
getViewPat _ = panic "getViewPat"
-getOLPat (ListPat (ListPatTc ty (Just _)) pats)
- = ListPat (ListPatTc ty Nothing) pats
-getOLPat _ = panic "getOLPat"
+
+-- | Use this pattern synonym to match on a 'ViewPat'.
+--
+-- N.B.: View patterns can occur inside HsExpansions.
+pattern TcViewPat :: HsExpr GhcTc -> Pat GhcTc -> Pat GhcTc
+pattern TcViewPat viewExpr pat <- (getTcViewPat -> (viewExpr, pat))
+
+getTcViewPat :: Pat GhcTc -> (HsExpr GhcTc, Pat GhcTc)
+getTcViewPat (ViewPat _ viewLExpr pat) = (unLoc viewLExpr, unLoc pat)
+getTcViewPat (XPat (ExpansionPat _ p)) = getTcViewPat p
+getTcViewPat p = pprPanic "getTcViewPat" (ppr p)
{-
Note [Empty case alternatives]
@@ -461,7 +458,7 @@ tidy1 v _ (LazyPat _ pat)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
; return (mkCoreLets sel_binds, WildPat (idType v)) }
-tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats )
+tidy1 _ _ (ListPat ty pats)
= return (idDsWrapper, unLoc list_ConPat)
where
list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
@@ -907,7 +904,6 @@ data PatGroup
| PgView (LHsExpr GhcTc) -- view pattern (e -> p):
-- the LHsExpr is the expression e
Type -- the Type is the type of p (equivalently, the result type of e)
- | PgOverloadedList
{- Note [Don't use Literal for PgN]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1173,11 +1169,11 @@ patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
case oval of
HsIntegral i -> PgNpK (il_value i)
_ -> pprPanic "patGroup NPlusKPat" (ppr oval)
-patGroup _ (XPat (CoPat _ p _)) = PgCo (hsPatType p)
- -- Type of innelexp pattern
patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p))
-patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList
patGroup platform (LitPat _ lit) = PgLit (hsLitKey platform lit)
+patGroup platform (XPat ext) = case ext of
+ CoPat _ p _ -> PgCo (hsPatType p) -- Type of innelexp pattern
+ ExpansionPat _ p -> patGroup platform p
patGroup _ pat = pprPanic "patGroup" (ppr pat)
{-
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index fa32d391d2..81d3b1cc51 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -122,16 +122,37 @@ desugarPat x pat = case pat of
SigPat _ p _ty -> desugarLPat x p
- -- See Note [Desugar CoPats]
- -- Generally the translation is
- -- pat |> co ===> let y = x |> co, pat <- y where y is a match var of pat
- XPat (CoPat wrapper p _ty)
- | isIdHsWrapper wrapper -> desugarPat x p
- | WpCast co <- wrapper, isReflexiveCo co -> desugarPat x p
- | otherwise -> do
- (y, grds) <- desugarPatV p
- wrap_rhs_y <- dsHsWrapper wrapper
- pure (PmLet y (wrap_rhs_y (Var x)) : grds)
+ XPat ext -> case ext of
+
+ ExpansionPat orig expansion -> do
+ dflags <- getDynFlags
+ case orig of
+ -- We add special logic for overloaded list patterns. When:
+ -- - a ViewPat is the expansion of a ListPat,
+ -- - RebindableSyntax is off,
+ -- - the type of the pattern is the built-in list type,
+ -- then we assume that the view function, 'toList', is the identity.
+ -- This improves pattern-match overload checks, as this will allow
+ -- the pattern match checker to directly inspect the inner pattern.
+ -- See #14547, and Note [Desugaring overloaded list patterns] (Wrinkle).
+ ListPat {}
+ | ViewPat arg_ty _lexpr pat <- expansion
+ , not (xopt LangExt.RebindableSyntax dflags)
+ , Just _ <- splitListTyConApp_maybe arg_ty
+ -> desugarLPat x pat
+
+ _ -> desugarPat x expansion
+
+ -- See Note [Desugar CoPats]
+ -- Generally the translation is
+ -- pat |> co ===> let y = x |> co, pat <- y where y is a match var of pat
+ CoPat wrapper p _ty
+ | isIdHsWrapper wrapper -> desugarPat x p
+ | WpCast co <- wrapper, isReflexiveCo co -> desugarPat x p
+ | otherwise -> do
+ (y, grds) <- desugarPatV p
+ wrap_rhs_y <- dsHsWrapper wrapper
+ pure (PmLet y (wrap_rhs_y (Var x)) : grds)
-- (n + k) ===> let b = x >= k, True <- b, let n = x-k
NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do
@@ -149,37 +170,9 @@ desugarPat x pat = case pat of
pure $ PmLet y (App fun (Var x)) : grds
-- list
- ListPat (ListPatTc _elem_ty Nothing) ps ->
+ ListPat _ ps ->
desugarListPat x ps
- -- overloaded list
- ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) pats -> do
- dflags <- getDynFlags
- case splitListTyConApp_maybe pat_ty of
- Just _e_ty
- | not (xopt LangExt.RebindableSyntax dflags)
- -- Just desugar it as a regular ListPat
- -> desugarListPat x pats
- _ -> do
- y <- mkPmId (mkListTy elem_ty)
- grds <- desugarListPat y pats
- rhs_y <- dsSyntaxExpr to_list [Var x]
- pure $ PmLet y rhs_y : grds
-
- -- (a) In the presence of RebindableSyntax, we don't know anything about
- -- `toList`, we should treat `ListPat` as any other view pattern.
- --
- -- (b) In the absence of RebindableSyntax,
- -- - If the pat_ty is `[a]`, then we treat the overloaded list pattern
- -- as ordinary list pattern. Although we can give an instance
- -- `IsList [Int]` (more specific than the default `IsList [a]`), in
- -- practice, we almost never do that. We assume the `to_list` is
- -- the `toList` from `instance IsList [a]`.
- --
- -- - Otherwise, we treat the `ListPat` as ordinary view pattern.
- --
- -- See #14547, especially comment#9 and comment#10.
-
ConPat { pat_con = L _ con
, pat_args = ps
, pat_con_ext = ConPatTc
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 0860192e68..71e5ac9655 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -2039,12 +2039,8 @@ repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 }
repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 }
repP (AsPat _ x p) = do { x' <- lookupNBinder x; p1 <- repLP p
; repPaspat x' p1 }
-repP (ParPat _ _ p _) = repLP p
-repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs }
-repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps)
- ; e' <- repE e
- ; repPview e' p}
-repP (ListPat _ ps) = pprPanic "repP missing SyntaxExprRn" (ppr ps)
+repP (ParPat _ _ p _) = repLP p
+repP (ListPat _ ps) = do { qs <- repLPs ps; repPlist qs }
repP (TuplePat _ ps boxed)
| isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
| otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index f198dc55c1..f4cc42949a 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1020,14 +1020,14 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where
]
XPat e ->
case hiePass @p of
- HieTc ->
- let CoPat wrap pat _ = e
- in [ toHie $ L ospan wrap
- , toHie $ PS rsp scope pscope $ (L ospan pat)
- ]
-#if __GLASGOW_HASKELL__ < 811
- HieRn -> []
-#endif
+ HieRn -> case e of
+ HsPatExpanded _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]
+ HieTc -> case e of
+ CoPat wrap pat _ ->
+ [ toHie $ L ospan wrap
+ , toHie $ PS rsp scope pscope $ (L ospan pat)
+ ]
+ ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]
where
contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType (NoGhcTc (GhcPass p))) a (HsRecFields (GhcPass p) a)
-> HsConDetails (TScoped (HsPatSigType (NoGhcTc (GhcPass p)))) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index ee81957015..cd0707ef59 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -1,8 +1,10 @@
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -40,7 +42,10 @@ import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames
, bindLocalNames
, mapMaybeFvRn, mapFvRn
, warnUnusedLocalBinds, typeAppErr
- , checkUnusedRecordWildcard )
+ , checkUnusedRecordWildcard
+ , wrapGenSpan, genHsIntegralLit, genHsTyLit
+ , genHsVar, genLHsVar, genHsApp, genHsApps
+ , genAppType )
import GHC.Rename.Unbound ( reportUnboundName )
import GHC.Rename.Splice ( rnBracket, rnSpliceExpr, checkThLocalName )
import GHC.Rename.HsType
@@ -63,7 +68,6 @@ import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable as Outputable
import GHC.Types.SrcLoc
-import GHC.Data.FastString
import Control.Monad
import GHC.Builtin.Types ( nilDataConName )
import qualified GHC.LanguageExtensions as LangExt
@@ -107,7 +111,10 @@ RebindableSyntax:
This is accomplished by lookupSyntaxName, and it applies to all the
constructs below.
-Here are the constructs that we transform in this way. Some are uniform,
+See also Note [Handling overloaded and rebindable patterns] in GHC.Rename.Pat
+for the story with patterns.
+
+Here are the expressions that we transform in this way. Some are uniform,
but several have a little bit of special treatment:
* HsIf (if-the-else)
@@ -397,7 +404,7 @@ rnExpr (ExplicitList _ exps)
do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
; let rn_list = ExplicitList noExtField exps'
lit_n = mkIntegralLit (length exps)
- hs_lit = wrapGenSpan (HsLit noAnn (HsInt noExtField lit_n))
+ hs_lit = genHsIntegralLit lit_n
exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list]
; return ( mkExpandedExpr rn_list exp_list
, fvs `plusFV` fvs') } }
@@ -2146,9 +2153,9 @@ parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
can do with the rest of the statements in the same "do" expression.
-}
-isStrictPattern :: LPat (GhcPass p) -> Bool
-isStrictPattern lpat =
- case unLoc lpat of
+isStrictPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool
+isStrictPattern (L loc pat) =
+ case pat of
WildPat{} -> False
VarPat{} -> False
LazyPat{} -> False
@@ -2165,7 +2172,16 @@ isStrictPattern lpat =
NPat{} -> True
NPlusKPat{} -> True
SplicePat{} -> True
- XPat{} -> panic "isStrictPattern: XPat"
+ XPat ext -> case ghcPass @p of
+#if __GLASGOW_HASKELL__ < 811
+ GhcPs -> noExtCon ext
+#endif
+ GhcRn
+ | HsPatExpanded _ p <- ext
+ -> isStrictPattern (L loc p)
+ GhcTc -> case ext of
+ ExpansionPat _ p -> isStrictPattern (L loc p)
+ CoPat {} -> panic "isStrictPattern: CoPat"
{-
Note [ApplicativeDo and refutable patterns]
@@ -2560,29 +2576,6 @@ getMonadFailOp ctxt
* *
********************************************************************* -}
-genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
-genHsApps fun args = foldl genHsApp (genHsVar fun) args
-
-genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
-genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg
-
-genLHsVar :: Name -> LHsExpr GhcRn
-genLHsVar nm = wrapGenSpan $ genHsVar nm
-
-genHsVar :: Name -> HsExpr GhcRn
-genHsVar nm = HsVar noExtField $ wrapGenSpan nm
-
-genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
-genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan
-
-genHsTyLit :: FastString -> HsType GhcRn
-genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText
-
-wrapGenSpan :: a -> LocatedAn an a
--- Wrap something in a "generatedSrcSpan"
--- See Note [Rebindable syntax and HsExpansion]
-wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
-
-- | Build a 'HsExpansion' out of an extension constructor,
-- and the two components of the expansion: original and
-- desugared expressions.
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 524b63c49f..606c9a372b 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -57,7 +57,8 @@ import GHC.Rename.Fixity
import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames
, warnUnusedMatches, newLocalBndrRn
, checkUnusedRecordWildcard
- , checkDupNames, checkDupAndShadowedNames )
+ , checkDupNames, checkDupAndShadowedNames
+ , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit )
import GHC.Rename.HsType
import GHC.Builtin.Names
import GHC.Types.Avail ( greNameMangledName )
@@ -296,6 +297,85 @@ pattern P x = Just x
See #12615 for some more examples.
+Note [Handling overloaded and rebindable patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Overloaded paterns and rebindable patterns are desugared in the renamer
+using the HsPatExpansion mechanism detailed in:
+Note [Rebindable syntax and HsExpansion]
+The approach is similar to that of expressions, which is further detailed
+in Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.
+
+Here are the patterns that are currently desugared in this way:
+
+* ListPat (list patterns [p1,p2,p3])
+ When (and only when) OverloadedLists is on, desugar to a view pattern:
+ [p1, p2, p3]
+ ==>
+ toList -> [p1, p2, p3]
+ ^^^^^^^^^^^^ built-in (non-overloaded) list pattern
+ NB: the type checker and desugarer still see ListPat,
+ but to them it always means the built-in list pattern.
+ See Note [Desugaring overloaded list patterns] below for more details.
+
+We expect to add to this list as we deal with more patterns via the expansion
+mechanism.
+
+Note [Desugaring overloaded list patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If OverloadedLists is enabled, we desugar a list pattern to a view pattern:
+
+ [p1, p2, p3]
+==>
+ toList -> [p1, p2, p3]
+
+This happens directly in the renamer, using the HsPatExpansion mechanism
+detailed in Note [Rebindable syntax and HsExpansion].
+
+Note that we emit a special view pattern: we additionally keep track of an
+inverse to the pattern.
+See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn for details.
+
+== Wrinkle ==
+
+This is all fine, except in one very specific case:
+ - when RebindableSyntax is off,
+ - and the type being matched on is already a list type.
+
+In this case, it is undesirable to desugar an overloaded list pattern into
+a view pattern. To illustrate, consider the following program:
+
+> {-# LANGUAGE OverloadedLists #-}
+>
+> f [] = True
+> f (_:_) = False
+
+Without any special logic, the pattern `[]` is desugared to `(toList -> [])`,
+whereas `(_:_)` remains a constructor pattern. This implies that the argument
+of `f` is necessarily a list (even though `OverloadedLists` is enabled).
+After desugaring the overloaded list pattern `[]`, and type-checking, we obtain:
+
+> f :: [a] -> Bool
+> f (toList -> []) = True
+> f (_:_) = False
+
+The pattern match checker then warns that the pattern `[]` is not covered,
+as it isn't able to look through view patterns.
+We can see that this is silly: as we are matching on a list, `toList` doesn't
+actually do anything. So we ignore it, and desugar the pattern to an explicit
+list pattern, instead of a view pattern.
+
+Note however that this is not necessarily sound, because it is possible to have
+a list `l` such that `toList l` is not the same as `l`.
+This can happen with an overlapping instance, such as the following:
+
+instance {-# OVERLAPPING #-} IsList [Int] where
+ type Item [Int] = Int
+ toList = reverse
+ fromList = reverse
+
+We make the assumption that no such instance exists, in order to avoid worsening
+pattern-match warnings (see #14547).
+
*********************************************************
* *
External entry points
@@ -485,7 +565,10 @@ rnPatAndThen mk p@(ViewPat _ expr pat)
; pat' <- rnLPatAndThen mk pat
-- Note: at this point the PreTcType in ty can only be a placeHolder
-- ; return (ViewPat expr' pat' ty) }
- ; return (ViewPat noExtField expr' pat') }
+
+ -- Note: we can't cook up an inverse for an arbitrary view pattern,
+ -- so we pass 'Nothing'.
+ ; return (ViewPat Nothing expr' pat') }
rnPatAndThen mk (ConPat _ con args)
-- rnConPatAndThen takes care of reconstructing the pattern
@@ -497,12 +580,25 @@ rnPatAndThen mk (ConPat _ con args)
False -> rnConPatAndThen mk con args
rnPatAndThen mk (ListPat _ pats)
- = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
+ = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
; pats' <- rnLPatsAndThen mk pats
- ; case opt_OverloadedLists of
- True -> do { (to_list_name,_) <- liftCps $ lookupSyntax toListName
- ; return (ListPat (Just to_list_name) pats')}
- False -> return (ListPat Nothing pats') }
+ ; if not opt_OverloadedLists
+ then return (ListPat noExtField pats')
+ else
+ -- If OverloadedLists is enabled, desugar to a view pattern.
+ -- See Note [Desugaring overloaded list patterns]
+ do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
+ -- Use 'fromList' as proof of invertibility of the view pattern.
+ -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn
+ ; (from_list_n_name,_) <- liftCps $ lookupSyntaxName fromListNName
+ ; let
+ lit_n = mkIntegralLit (length pats)
+ hs_lit = genHsIntegralLit lit_n
+ inverse = genHsApps from_list_n_name [hs_lit]
+ rn_list_pat = ListPat noExtField pats'
+ exp_expr = genLHsVar to_list_name
+ exp_list_pat = ViewPat (Just inverse) exp_expr (wrapGenSpan rn_list_pat)
+ ; return $ mkExpandedPat rn_list_pat exp_list_pat }}
rnPatAndThen mk (TuplePat _ pats boxed)
= do { pats' <- rnLPatsAndThen mk pats
@@ -614,6 +710,23 @@ rnHsRecPatsAndThen mk (L _ con)
nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'
= LamMk (report_unused && (n' <= n))
+
+{- *********************************************************************
+* *
+ Generating code for HsPatExpanded
+ See Note [Handling overloaded and rebindable constructs]
+* *
+********************************************************************* -}
+
+-- | Build a 'HsPatExpansion' out of an extension constructor,
+-- and the two components of the expansion: original and
+-- desugared patterns
+mkExpandedPat
+ :: Pat GhcRn -- ^ source pattern
+ -> Pat GhcRn -- ^ expanded pattern
+ -> Pat GhcRn -- ^ suitably wrapped 'HsPatExpansion'
+mkExpandedPat a b = XPat (HsPatExpanded a b)
+
{-
************************************************************************
* *
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index a97d215b8b..bd5c9240e0 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -18,6 +18,8 @@ module GHC.Rename.Utils (
checkUnusedRecordWildcard,
mkFieldEnv,
unknownSubordinateErr, badQualBndrErr, typeAppErr,
+ wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,
+ genHsIntegralLit, genHsTyLit,
HsDocContext(..), pprHsDocContext,
inHsDocContext, withHsDocContext,
@@ -49,6 +51,7 @@ import GHC.Types.Name.Env
import GHC.Core.DataCon
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.SourceFile
+import GHC.Types.SourceText ( SourceText(..), IntegralLit )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
@@ -646,6 +649,38 @@ checkCTupSize tup_size
<+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))
2 (text "Instead, use a nested tuple")
+{- *********************************************************************
+* *
+ Generating code for HsExpanded
+ See Note [Handling overloaded and rebindable constructs]
+* *
+********************************************************************* -}
+
+wrapGenSpan :: a -> LocatedAn an a
+-- Wrap something in a "generatedSrcSpan"
+-- See Note [Rebindable syntax and HsExpansion]
+wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
+
+genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
+genHsApps fun args = foldl genHsApp (genHsVar fun) args
+
+genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
+genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg
+
+genLHsVar :: Name -> LHsExpr GhcRn
+genLHsVar nm = wrapGenSpan $ genHsVar nm
+
+genHsVar :: Name -> HsExpr GhcRn
+genHsVar nm = HsVar noExtField $ wrapGenSpan nm
+
+genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
+genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan
+
+genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn)
+genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)
+
+genHsTyLit :: FastString -> HsType GhcRn
+genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText
{-
************************************************************************
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index be5a243dec..10c862f8f6 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -450,7 +450,8 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
-- (pat_ty -> inf_res_sigma)
expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap
doc = text "When checking the view pattern function:" <+> (ppr expr)
- ; return (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res)}
+
+ ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
{- Note [View patterns and polymorphism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -487,25 +488,16 @@ Fortunately that's what matchExpectedFunTySigma returns anyway.
------------------------
-- Lists, tuples, arrays
- ListPat Nothing pats -> do
+
+ -- Necessarily a built-in list pattern, not an overloaded list pattern.
+ -- See Note [Desugaring overloaded list patterns].
+ ListPat _ pats -> do
{ (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty)
; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))
penv pats thing_inside
; pat_ty <- readExpType (scaledThing pat_ty)
; return (mkHsWrapPat coi
- (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res)
-}
-
- ListPat (Just e) pats -> do
- { tau_pat_ty <- expTypeToType (scaledThing pat_ty)
- ; ((pats', res, elt_ty), e')
- <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]
- SynList $
- \ [elt_ty] _ ->
- do { (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))
- penv pats thing_inside
- ; return (pats', res, elt_ty) }
- ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res)
+ (ListPat elt_ty pats') pat_ty, res)
}
TuplePat _ pats boxity -> do
@@ -697,6 +689,9 @@ AST is used for the subtraction operation.
; tc_pat pat_ty penv pat thing_inside }
_ -> panic "invalid splice in splice pat"
+ XPat (HsPatExpanded lpat rpat) -> do
+ { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside
+ ; return (XPat $ ExpansionPat lpat rpat', res) }
{-
Note [Hopping the LIE in lazy patterns]
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index c470258e43..bc78e8b592 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -60,6 +60,7 @@ import GHC.Tc.TyCl.Utils
import GHC.Core.ConLike
import GHC.Types.FieldLabel
import GHC.Rename.Env
+import GHC.Rename.Utils (wrapGenSpan)
import GHC.Data.Bag
import GHC.Utils.Misc
import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors )
@@ -1027,10 +1028,9 @@ tcPatToExpr name args pat = go pat
| otherwise
= Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat
- go1 p@(ListPat reb pats)
- | Nothing <- reb = do { exprs <- mapM go pats
- ; return $ ExplicitList noExtField exprs }
- | otherwise = notInvertibleListPat p
+ go1 (ListPat _ pats)
+ = do { exprs <- mapM go pats
+ ; return $ ExplicitList noExtField exprs }
go1 (TuplePat _ pats box) = do { exprs <- mapM go pats
; return $ ExplicitTuple noExtField
(map (Present noAnn) exprs) box }
@@ -1047,13 +1047,21 @@ tcPatToExpr name args pat = go pat
go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
= go1 pat
go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
+ go1 (XPat (HsPatExpanded _ pat))= go1 pat
+
+ -- See Note [Invertible view patterns]
+ go1 p@(ViewPat mbInverse _ pat) = case mbInverse of
+ Nothing -> notInvertible p
+ Just inverse ->
+ fmap
+ (\ expr -> HsApp noAnn (wrapGenSpan inverse) (wrapGenSpan expr))
+ (go1 (unLoc pat))
-- The following patterns are not invertible.
go1 p@(BangPat {}) = notInvertible p -- #14112
go1 p@(LazyPat {}) = notInvertible p
go1 p@(WildPat {}) = notInvertible p
go1 p@(AsPat {}) = notInvertible p
- go1 p@(ViewPat {}) = notInvertible p
go1 p@(NPlusKPat {}) = notInvertible p
go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p
go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
@@ -1072,27 +1080,23 @@ tcPatToExpr name args pat = go pat
pp_name = ppr name
pp_args = hsep (map ppr args)
- -- We should really be able to invert list patterns, even when
- -- rebindable syntax is on, but doing so involves a bit of
- -- refactoring; see #14380. Until then we reject with a
- -- helpful error message.
- notInvertibleListPat p
- = Left (vcat [ not_invertible_msg p
- , text "Reason: rebindable syntax is on."
- , text "This is fixable: add use-case to #14380" ])
{- Note [Builder for a bidirectional pattern synonym]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For a bidirectional pattern synonym we need to produce an /expression/
-that matches the supplied /pattern/, given values for the arguments
-of the pattern synonym. For example
+For a bidirectional pattern synonym, the function 'tcPatToExpr'
+needs to produce an /expression/ that matches the supplied /pattern/,
+given values for the arguments of the pattern synonym. For example:
pattern F x y = (Just x, [y])
The 'builder' for F looks like
$builderF x y = (Just x, [y])
We can't always do this:
- * Some patterns aren't invertible; e.g. view patterns
- pattern F x = (reverse -> x:_)
+ * Some patterns aren't invertible; e.g. general view patterns
+ pattern F x = (f -> x)
+ as we don't have the ability to write down an expression that matches
+ the view pattern specified by an arbitrary view function `f`.
+ It is however sometimes possible to write down an inverse;
+ see Note [Invertible view patterns].
* The RHS pattern might bind more variables than the pattern
synonym, so again we can't invert it
@@ -1101,6 +1105,21 @@ We can't always do this:
* Ditto wildcards
pattern F x = (x,_)
+Note [Invertible view patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For some view patterns, such as those that arise from expansion of overloaded
+patterns (as detailed in Note [Handling overloaded and rebindable patterns]),
+we are able to explicitly write out an inverse (in the sense of the previous
+Note [Builder for a bidirectional pattern synonym]).
+For instance, the inverse to the pattern
+
+ (toList -> [True, False])
+
+is the expression
+
+ (fromListN 2 [True,False])
+
+Keeping track of the inverse for such view patterns fixed #14380.
Note [Redundant constraints for builder]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1214,7 +1233,9 @@ tcCollectEx pat = go pat
= merge (cpt_tvs con', cpt_dicts con') $
goConDetails $ pat_args con
go1 (SigPat _ p _) = go p
- go1 (XPat (CoPat _ p _)) = go1 p
+ go1 (XPat ext) = case ext of
+ CoPat _ p _ -> go1 p
+ ExpansionPat _ p -> go1 p
go1 (NPlusKPat _ n k _ geq subtract)
= pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
go1 _ = empty
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 2a38a54460..49d2885c5e 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -1374,17 +1374,10 @@ zonk_pat env (ViewPat ty expr pat)
; ty' <- zonkTcTypeToTypeX env ty
; return (env', ViewPat ty' expr' pat') }
-zonk_pat env (ListPat (ListPatTc ty Nothing) pats)
+zonk_pat env (ListPat ty pats)
= do { ty' <- zonkTcTypeToTypeX env ty
; (env', pats') <- zonkPats env pats
- ; return (env', ListPat (ListPatTc ty' Nothing) pats') }
-
-zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats)
- = do { (env', wit') <- zonkSyntaxExpr env wit
- ; ty2' <- zonkTcTypeToTypeX env' ty2
- ; ty' <- zonkTcTypeToTypeX env' ty
- ; (env'', pats') <- zonkPats env' pats
- ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') }
+ ; return (env', ListPat ty' pats') }
zonk_pat env (TuplePat tys pats boxed)
= do { tys' <- mapM (zonkTcTypeToTypeX env) tys
@@ -1466,13 +1459,16 @@ zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
; ty' <- zonkTcTypeToTypeX env2 ty
; return (extendIdZonkEnv env2 n',
NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
-
-zonk_pat env (XPat (CoPat co_fn pat ty))
- = do { (env', co_fn') <- zonkCoFn env co_fn
+zonk_pat env (XPat ext) = case ext of
+ { ExpansionPat orig pat->
+ do { (env, pat') <- zonk_pat env pat
+ ; return $ (env, XPat $ ExpansionPat orig pat') }
+ ; CoPat co_fn pat ty ->
+ do { (env', co_fn') <- zonkCoFn env co_fn
; (env'', pat') <- zonkPat env' (noLocA pat)
; ty' <- zonkTcTypeToTypeX env'' ty
; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty')
- }
+ }}
zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs
index 75dc7ddd00..4393ad998a 100644
--- a/compiler/Language/Haskell/Syntax/Pat.hs
+++ b/compiler/Language/Haskell/Syntax/Pat.hs
@@ -92,9 +92,6 @@ data Pat p
------------ Lists, tuples, arrays ---------------
| ListPat (XListPat p)
[LPat p]
- -- For OverloadedLists a Just (ty,fn) gives
- -- overall type of the pattern, and the toList
--- function to convert the scrutinee to a list value
-- ^ Syntactic List
--
@@ -153,9 +150,7 @@ data Pat p
-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow'
-- For details on above see note [exact print annotations] in GHC.Parser.Annotation
- | ViewPat (XViewPat p) -- The overall type of the pattern
- -- (= the argument type of the view function)
- -- for hsPatType.
+ | ViewPat (XViewPat p)
(LHsExpr p)
(LPat p)
-- ^ View Pattern
diff --git a/docs/users_guide/exts/overloaded_lists.rst b/docs/users_guide/exts/overloaded_lists.rst
index 449e85f412..1f4ef363a5 100644
--- a/docs/users_guide/exts/overloaded_lists.rst
+++ b/docs/users_guide/exts/overloaded_lists.rst
@@ -134,6 +134,18 @@ several example instances:
fromListN = Vector.fromListN
toList = Vector.toList
+Users should not, however, provide any instance that overlaps with the first
+instance above. Namely, ``fromList`` and ``toList``, when used on lists,
+should always be the identity function.
+For example, the following instance is disallowed:
+
+::
+
+ instance {-# OVERLAPPING #-} IsList [Int] where
+ type Item [Int] = Int
+ fromList = reverse
+ toList = reverse
+
Rebindable syntax
~~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail06.stderr b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail06.stderr
index 472bd787e2..91668d16d0 100644
--- a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail06.stderr
+++ b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail06.stderr
@@ -1,4 +1,5 @@
+overloadedlistsfail06.hs:3:3: Not in scope: ‘fromListN’
-overloadedlistsfail06.hs:3:3: Not in scope: ‘toList’
+overloadedlistsfail06.hs:3:3: error: Not in scope: ‘toList’
-overloadedlistsfail06.hs:3:8: Not in scope: ‘fromListN’
+overloadedlistsfail06.hs:3:8: error: Not in scope: ‘fromListN’
diff --git a/testsuite/tests/patsyn/should_fail/T14380.hs b/testsuite/tests/patsyn/should_compile/T14380.hs
index aec398590d..aec398590d 100644
--- a/testsuite/tests/patsyn/should_fail/T14380.hs
+++ b/testsuite/tests/patsyn/should_compile/T14380.hs
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index defb2ac52b..479b5b0683 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -74,6 +74,7 @@ test('T13768', normal, compile, [''])
test('T14058', [extra_files(['T14058.hs', 'T14058a.hs'])],
multimod_compile, ['T14058', '-v0'])
test('T14326', normal, compile, [''])
+test('T14380', normal, compile, [''])
test('T14394', normal, ghci_script, ['T14394.script'])
test('T14498', normal, compile, [''])
test('T16682', [extra_files(['T16682.hs', 'T16682a.hs'])],
diff --git a/testsuite/tests/patsyn/should_fail/T14380.stderr b/testsuite/tests/patsyn/should_fail/T14380.stderr
deleted file mode 100644
index 47dcc93d81..0000000000
--- a/testsuite/tests/patsyn/should_fail/T14380.stderr
+++ /dev/null
@@ -1,9 +0,0 @@
-
-T14380.hs:8:15: error:
- Invalid right-hand side of bidirectional pattern synonym ‘Bar’:
- Pattern ‘[]’ is not invertible
- Suggestion: instead use an explicitly bidirectional pattern synonym, e.g.
- pattern Bar <- Foo [] where Bar = ...
- Reason: rebindable syntax is on.
- This is fixable: add use-case to #14380
- RHS pattern: Foo []
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index 9520cc0b77..8993e5c4bf 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -40,7 +40,6 @@ test('T13349', normal, compile_fail, [''])
test('T13470', normal, compile_fail, [''])
test('T14112', normal, compile_fail, [''])
test('T14114', normal, compile_fail, [''])
-test('T14380', normal, compile_fail, [''])
test('T14507', normal, compile_fail, ['-dsuppress-uniques'])
test('T15289', normal, compile_fail, [''])
test('T15685', normal, compile_fail, [''])