[Git][ghc/ghc][wip/ttg-con-pat] Trees That Grow refactor for `ConPat` and `CoPat`
cgibbard
gitlab at gitlab.haskell.org
Wed Apr 15 15:44:57 UTC 2020
cgibbard pushed to branch wip/ttg-con-pat at Glasgow Haskell Compiler / GHC
Commits:
b18aef96 by John Ericson at 2020-04-15T11:43:59-04:00
Trees That Grow refactor for `ConPat` and `CoPat`
- `ConPat{In,Out}` -> `ConPat`
- `CoPat` -> `XPat (CoPat ..)`
Note that `GHC.HS.*` still uses `HsWrap`, but only when `p ~ GhcTc`.
After this change, moving the type family instances out of `GHC.HS.*` is
sufficient to break the cycle.
Add XCollectPat class to decide how binders are collected from XXPat based on the pass.
Previously we did this with IsPass, but that doesn't work for Haddock's
DocNameI, and the constraint doesn't express what actual distinction is being
made. Perhaps a class for collecting binders more generally is in order, but we
haven't attempted this yet.
Pure refactor of code around ConPat
- InPat/OutPat synonyms removed
- rename several identifiers
- redundant constraints removed
- move extension field in ConPat to be first
- make ConPat use record syntax more consistently
Fix T6145 (ConPatIn became ConPat)
Add comments from SPJ.
Add comment about haddock's use of CollectPass.
Updates haddock submodule.
- - - - -
29 changed files:
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/ListComp.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/HsToCore/PmCheck.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/Zonk.hs
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/ThToHs.hs
- compiler/parser/RdrHsSyn.hs
- testsuite/tests/ghc-api/T6145.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -355,6 +355,9 @@ 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 (DataIdLR p p, Data body) => Data (HsRecFields p body)
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -23,8 +23,11 @@
{-# LANGUAGE LambdaCase #-}
module GHC.Hs.Pat (
- Pat(..), InPat, OutPat, LPat,
+ Pat(..), LPat,
+ ConPatTc (..),
+ CoPat (..),
ListPatTc(..),
+ ConLikeP,
HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsRecField'(..), LHsRecField',
@@ -59,7 +62,6 @@ import GHC.Tc.Types.Evidence
import GHC.Types.Basic
-- others:
import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )
-import GHC.Driver.Session ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) )
import TysWiredIn
import GHC.Types.Var
import GHC.Types.Name.Reader ( RdrName )
@@ -71,12 +73,10 @@ import GHC.Core.Type
import GHC.Types.SrcLoc
import Bag -- collect ev vars from pats
import Maybes
+import GHC.Types.Name (Name)
-- libraries:
import Data.Data hiding (TyCon,Fixity)
-type InPat p = LPat p -- No 'Out' constructors
-type OutPat p = LPat p -- No 'In' constructors
-
type LPat p = XRec p Pat
-- | Pattern
@@ -173,30 +173,12 @@ data Pat p
-- For details on above see note [Api annotations] in ApiAnnotation
------------ Constructor patterns ---------------
- | ConPatIn (Located (IdP p))
- (HsConPatDetails p)
- -- ^ Constructor Pattern In
-
- | ConPatOut {
- pat_con :: Located ConLike,
- pat_arg_tys :: [Type], -- The universal arg types, 1-1 with the universal
- -- tyvars of the constructor/pattern synonym
- -- Use (conLikeResTy pat_con pat_arg_tys) to get
- -- the type of the pattern
-
- pat_tvs :: [TyVar], -- Existentially bound type variables
- -- in correctly-scoped order e.g. [k:*, x:k]
- pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries*
- -- One reason for putting coercion variable here, I think,
- -- is to ensure their kinds are zonked
-
- pat_binds :: TcEvBinds, -- Bindings involving those dictionaries
- pat_args :: HsConPatDetails p,
- pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher
- -- Only relevant for pattern-synonyms;
- -- ignored for data cons
+ | ConPat {
+ pat_con_ext :: XConPat p,
+ pat_con :: Located (ConLikeP p),
+ pat_args :: HsConPatDetails p
}
- -- ^ Constructor Pattern Out
+ -- ^ Constructor Pattern
------------ View patterns ---------------
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
@@ -262,17 +244,6 @@ data Pat p
-- ^ Pattern with a type signature
- ------------ Pattern coercions (translation only) ---------------
- | CoPat (XCoPat p)
- HsWrapper -- Coercion Pattern
- -- If co :: t1 ~ t2, p :: t2,
- -- then (CoPat co p) :: t1
- (Pat p) -- Why not LPat? Ans: existing locn will do
- Type -- Type of whole pattern, t1
- -- During desugaring a (CoPat co pat) turns into a cast with 'co' on
- -- the scrutinee, followed by a match on 'pat'
- -- ^ Coercion Pattern
-
-- | Trees that Grow extension point for new constructors
| XPat
!(XXPat p)
@@ -306,6 +277,10 @@ type instance XTuplePat GhcPs = NoExtField
type instance XTuplePat GhcRn = NoExtField
type instance XTuplePat GhcTc = [Type]
+type instance XConPat GhcPs = NoExtField
+type instance XConPat GhcRn = NoExtField
+type instance XConPat GhcTc = ConPatTc
+
type instance XSumPat GhcPs = NoExtField
type instance XSumPat GhcRn = NoExtField
type instance XSumPat GhcTc = [Type]
@@ -329,9 +304,16 @@ type instance XSigPat GhcPs = NoExtField
type instance XSigPat GhcRn = NoExtField
type instance XSigPat GhcTc = Type
-type instance XCoPat (GhcPass _) = NoExtField
+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 (GhcPass _) = NoExtCon
+type family ConLikeP x
+
+type instance ConLikeP GhcPs = RdrName -- IdP GhcPs
+type instance ConLikeP GhcRn = Name -- IdP GhcRn
+type instance ConLikeP GhcTc = ConLike
-- ---------------------------------------------------------------------
@@ -344,6 +326,52 @@ hsConPatArgs (PrefixCon ps) = ps
hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs)
hsConPatArgs (InfixCon p1 p2) = [p1,p2]
+-- | 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
+ = ConPatTc
+ { -- | The universal arg types 1-1 with the universal
+ -- tyvars of the constructor/pattern synonym
+ -- Use (conLikeResTy pat_con cpt_arg_tys) to get
+ -- the type of the pattern
+ cpt_arg_tys :: [Type]
+
+ , -- | Existentially bound type variables
+ -- in correctly-scoped order e.g. [k:* x:k]
+ cpt_tvs :: [TyVar]
+
+ , -- | Ditto *coercion variables* and *dictionaries*
+ -- One reason for putting coercion variable here I think
+ -- is to ensure their kinds are zonked
+ cpt_dicts :: [EvVar]
+
+ , -- | Bindings involving those dictionaries
+ cpt_binds :: TcEvBinds
+
+ , -- ^ Extra wrapper to pass to the matcher
+ -- Only relevant for pattern-synonyms;
+ -- ignored for data cons
+ 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
+ }
+
-- | Haskell Record Fields
--
-- HsRecFields is used only for patterns and expressions (not data type
@@ -498,16 +526,23 @@ pprParendLPat :: (OutputableBndrId p)
=> PprPrec -> LPat (GhcPass p) -> SDoc
pprParendLPat p = pprParendPat p . unLoc
-pprParendPat :: (OutputableBndrId p)
- => PprPrec -> Pat (GhcPass p) -> SDoc
-pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \print_tc_elab ->
- if need_parens print_tc_elab pat
- then parens (pprPat pat)
- else pprPat pat
+pprParendPat :: forall p. OutputableBndrId p
+ => PprPrec
+ -> Pat (GhcPass p)
+ -> SDoc
+pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_elab ->
+ if need_parens print_tc_elab pat
+ then parens (pprPat pat)
+ else pprPat pat
where
need_parens print_tc_elab pat
- | CoPat {} <- pat = print_tc_elab
- | otherwise = patNeedsParens p pat
+ | GhcTc <- ghcPass @p
+ , XPat ext <- pat
+ , CoPat {} <- ext
+ = print_tc_elab
+
+ | otherwise
+ = patNeedsParens p pat
-- For a CoPat we need parens if we are going to show it, which
-- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper)
-- But otherwise the CoPat is discarded, so it
@@ -527,12 +562,6 @@ pprPat (NPat _ l Nothing _) = ppr l
pprPat (NPat _ l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k]
pprPat (SplicePat _ splice) = pprSplice splice
-pprPat (CoPat _ co pat _) = pprIfTc @p $
- sdocWithDynFlags $ \ dflags ->
- if gopt Opt_PrintTypecheckerElaboration dflags
- then hang (text "CoPat" <+> parens (ppr co))
- 2 (pprParendPat appPrec pat)
- else pprPat pat
pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr_ty
where ppr_ty = case ghcPass @p of
GhcPs -> ppr ty
@@ -548,22 +577,35 @@ pprPat (TuplePat _ pats bx)
| otherwise
= tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
-pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
-pprPat (ConPatOut { pat_con = con
- , pat_tvs = tvs
- , pat_dicts = dicts
- , pat_binds = binds
- , pat_args = details })
- = sdocOption sdocPrintTypecheckerElaboration $ \case
- False -> pprUserCon (unLoc con) details
- True -> -- Tiresome; in GHC.Tc.Gen.Bind.tcRhs we print out a
- -- typechecked Pat in an error message,
- -- and we want to make sure it prints nicely
- ppr con
- <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
- , pprIfTc @p $ ppr binds ])
- <+> pprConArgs details
-
+pprPat (ConPat { pat_con = con
+ , pat_args = details
+ , pat_con_ext = ext
+ }
+ )
+ = case ghcPass @p of
+ GhcPs -> pprUserCon (unLoc con) details
+ GhcRn -> pprUserCon (unLoc con) details
+ GhcTc -> sdocOption sdocPrintTypecheckerElaboration $ \case
+ False -> pprUserCon (unLoc con) details
+ True ->
+ -- Tiresome; in TcBinds.tcRhs we print out a typechecked Pat in an
+ -- error message, and we want to make sure it prints nicely
+ ppr con
+ <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
+ , ppr binds ])
+ <+> pprConArgs details
+ where ConPatTc { cpt_tvs = tvs
+ , cpt_dicts = dicts
+ , cpt_binds = binds
+ } = ext
+pprPat (XPat ext) = case ghcPass @p of
+ GhcPs -> noExtCon ext
+ GhcRn -> noExtCon ext
+ GhcTc -> pprHsWrapper co $ \parens ->
+ if parens
+ then pprParendPat appPrec pat
+ else pprPat pat
+ where CoPat co pat _ = ext
pprUserCon :: (OutputableBndr con, OutputableBndrId p)
=> con -> HsConPatDetails (GhcPass p) -> SDoc
@@ -602,21 +644,24 @@ instance (Outputable p, Outputable arg)
-}
mkPrefixConPat :: DataCon ->
- [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p)
+ [LPat GhcTc] -> [Type] -> LPat GhcTc
-- Make a vanilla Prefix constructor pattern
mkPrefixConPat dc pats tys
- = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc)
- , pat_tvs = []
- , pat_dicts = []
- , pat_binds = emptyTcEvBinds
- , pat_args = PrefixCon pats
- , pat_arg_tys = tys
- , pat_wrap = idHsWrapper }
-
-mkNilPat :: Type -> OutPat (GhcPass p)
+ = noLoc $ ConPat { pat_con = noLoc (RealDataCon dc)
+ , pat_args = PrefixCon pats
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = []
+ , cpt_dicts = []
+ , cpt_binds = emptyTcEvBinds
+ , cpt_arg_tys = tys
+ , cpt_wrap = idHsWrapper
+ }
+ }
+
+mkNilPat :: Type -> LPat GhcTc
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
-mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
+mkCharLitPat :: SourceText -> Char -> LPat GhcTc
mkCharLitPat src c = mkPrefixConPat charDataCon
[noLoc $ LitPat noExtField (HsCharPrim src c)] []
@@ -684,7 +729,7 @@ looksLazyPat (VarPat {}) = False
looksLazyPat (WildPat {}) = False
looksLazyPat _ = True
-isIrrefutableHsPat :: (OutputableBndrId p) => LPat (GhcPass p) -> Bool
+isIrrefutableHsPat :: forall p. (OutputableBndrId p) => LPat (GhcPass p) -> Bool
-- (isIrrefutableHsPat p) is true if matching against p cannot fail,
-- in the sense of falling through to the next pattern.
-- (NB: this is not quite the same as the (silly) defn
@@ -700,13 +745,14 @@ isIrrefutableHsPat :: (OutputableBndrId p) => LPat (GhcPass p) -> Bool
isIrrefutableHsPat
= goL
where
+ goL :: LPat (GhcPass p) -> Bool
goL = go . unLoc
+ go :: Pat (GhcPass p) -> Bool
go (WildPat {}) = True
go (VarPat {}) = True
go (LazyPat {}) = True
go (BangPat _ pat) = goL pat
- go (CoPat _ _ pat _) = go pat
go (ParPat _ pat) = goL pat
go (AsPat _ _ pat) = goL pat
go (ViewPat _ _ pat) = goL pat
@@ -716,18 +762,19 @@ isIrrefutableHsPat
-- See Note [Unboxed sum patterns aren't irrefutable]
go (ListPat {}) = False
- go (ConPatIn {}) = False -- Conservative
- go (ConPatOut
- { pat_con = L _ (RealDataCon con)
+ go (ConPat
+ { pat_con = con
, pat_args = details })
- =
- isJust (tyConSingleDataCon_maybe (dataConTyCon con))
- -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because
- -- the latter is false of existentials. See #4439
- && all goL (hsConPatArgs details)
- go (ConPatOut
- { pat_con = L _ (PatSynCon _pat) })
- = False -- Conservative
+ = case ghcPass @p of
+ GhcPs -> False -- Conservative
+ GhcRn -> False -- Conservative
+ GhcTc -> case con of
+ L _ (PatSynCon _pat) -> False -- Conservative
+ L _ (RealDataCon con) ->
+ isJust (tyConSingleDataCon_maybe (dataConTyCon con))
+ -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because
+ -- the latter is false of existentials. See #4439
+ && all goL (hsConPatArgs details)
go (LitPat {}) = False
go (NPat {}) = False
go (NPlusKPat {}) = False
@@ -736,6 +783,12 @@ isIrrefutableHsPat
-- since we cannot know until the splice is evaluated.
go (SplicePat {}) = False
+ go (XPat ext) = case ghcPass @p of
+ GhcPs -> noExtCon ext
+ GhcRn -> noExtCon ext
+ GhcTc -> go pat
+ where CoPat _ pat _ = ext
+
-- | Is the pattern any of combination of:
--
-- - (pat)
@@ -777,16 +830,21 @@ is the only thing that could possibly be matched!
-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
-- parentheses under precedence @p at .
-patNeedsParens :: PprPrec -> Pat p -> Bool
+patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool
patNeedsParens p = go
where
+ go :: Pat (GhcPass p) -> Bool
go (NPlusKPat {}) = p > opPrec
go (SplicePat {}) = False
- go (ConPatIn _ ds) = conPatNeedsParens p ds
- go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp)
+ go (ConPat { pat_args = ds})
+ = conPatNeedsParens p ds
go (SigPat {}) = p >= sigPrec
go (ViewPat {}) = True
- go (CoPat _ _ p _) = go p
+ go (XPat ext) = case ghcPass @p of
+ GhcPs -> noExtCon ext
+ GhcRn -> noExtCon ext
+ GhcTc -> go inner
+ where CoPat _ inner _ = ext
go (WildPat {}) = False
go (VarPat {}) = False
go (LazyPat {}) = False
@@ -798,7 +856,6 @@ patNeedsParens p = go
go (ListPat {}) = False
go (LitPat _ l) = hsLitNeedsParens p l
go (NPat _ lol _ _) = hsOverLitNeedsParens p (unLoc lol)
- go (XPat {}) = True -- conservative default
-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@
-- needs parentheses under precedence @p at .
@@ -811,7 +868,10 @@ conPatNeedsParens p = go
-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat at .
-parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
+parenthesizePat :: IsPass p
+ => PprPrec
+ -> LPat (GhcPass p)
+ -> LPat (GhcPass p)
parenthesizePat p lpat@(L loc pat)
| patNeedsParens p pat = L loc (ParPat noExtField lpat)
| otherwise = lpat
@@ -837,12 +897,16 @@ collectEvVarsPat pat =
ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps
TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps
SumPat _ p _ _ -> collectEvVarsLPat p
- ConPatOut {pat_dicts = dicts, pat_args = args}
+ ConPat
+ { pat_args = args
+ , pat_con_ext = ConPatTc
+ { cpt_dicts = dicts
+ }
+ }
-> unionBags (listToBag dicts)
$ unionManyBags
$ map collectEvVarsLPat
$ hsConPatArgs args
SigPat _ p _ -> collectEvVarsLPat p
- CoPat _ _ p _ -> collectEvVarsPat p
- ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn"
+ XPat (CoPat _ p _) -> collectEvVarsPat p
_other_pat -> emptyBag
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -24,6 +24,9 @@ just attach noSrcSpan to everything.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -88,6 +91,7 @@ module GHC.Hs.Utils(
collectPatBinders, collectPatsBinders,
collectLStmtsBinders, collectStmtsBinders,
collectLStmtBinders, collectStmtBinders,
+ CollectPass(..),
hsLTyClDeclBinders, hsTyClForeignBinders,
hsPatSynSelectors, getPatSynBinds,
@@ -134,6 +138,7 @@ import Constants
import Data.Either
import Data.Function
import Data.List
+import Data.Proxy
{-
************************************************************************
@@ -196,8 +201,11 @@ mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct)
mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
mkHsAppTypes = foldl' mkHsAppType
-mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
- [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
+mkHsLam :: IsPass p
+ => (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField)
+ => [LPat (GhcPass p)]
+ -> LHsExpr (GhcPass p)
+ -> LHsExpr (GhcPass p)
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
where
matches = mkMatchGroup Generated
@@ -230,7 +238,7 @@ mkLHsPar le@(L loc e)
| hsExprNeedsParens appPrec e = L loc (HsPar noExtField le)
| otherwise = le
-mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
+mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p)
mkParPat lp@(L loc p)
| patNeedsParens appPrec p = L loc (ParPat noExtField lp)
| otherwise = lp
@@ -435,25 +443,42 @@ nlConVarPatName :: Name -> [Name] -> LPat GhcRn
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
-nlInfixConPat con l r = noLoc (ConPatIn (noLoc con)
- (InfixCon (parenthesizePat opPrec l)
- (parenthesizePat opPrec r)))
+nlInfixConPat con l r = noLoc $ ConPat
+ { pat_con = noLoc con
+ , pat_args = InfixCon (parenthesizePat opPrec l)
+ (parenthesizePat opPrec r)
+ , pat_con_ext = noExtField
+ }
nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
-nlConPat con pats =
- noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
+nlConPat con pats = noLoc $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = noLoc con
+ , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)
+ }
nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
-nlConPatName con pats =
- noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
-
-nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p)
-nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
+nlConPatName con pats = noLoc $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = noLoc con
+ , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)
+ }
+
+nlNullaryConPat :: RdrName -> LPat GhcPs
+nlNullaryConPat con = noLoc $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = noLoc con
+ , pat_args = PrefixCon []
+ }
nlWildConPat :: DataCon -> LPat GhcPs
-nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
- (PrefixCon (replicate (dataConSourceArity con)
- nlWildPat)))
+nlWildConPat con = noLoc $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = noLoc $ getRdrName con
+ , pat_args = PrefixCon $
+ replicate (dataConSourceArity con)
+ nlWildPat
+ }
-- | Wildcard pattern - after parsing
nlWildPat :: LPat GhcPs
@@ -800,11 +825,11 @@ mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
mkHsWrapPat :: HsWrapper -> Pat GhcTc -> Type -> Pat GhcTc
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
- | otherwise = CoPat noExtField co_fn p ty
+ | otherwise = XPat $ CoPat co_fn p ty
mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
- | otherwise = CoPat noExtField (mkWpCastN co) pat ty
+ | otherwise = XPat $ CoPat (mkWpCastN co) pat ty
mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
@@ -879,8 +904,10 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n
, mc_strictness = NoSrcStrict }
------------
-mkMatch :: HsMatchContext (NoGhcTc (GhcPass p))
- -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p)
+mkMatch :: forall p. IsPass p
+ => HsMatchContext (NoGhcTc (GhcPass p))
+ -> [LPat (GhcPass p)]
+ -> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch ctxt pats expr lbinds
@@ -889,6 +916,7 @@ mkMatch ctxt pats expr lbinds
, m_pats = map paren pats
, m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds })
where
+ paren :: Located (Pat (GhcPass p)) -> Located (Pat (GhcPass p))
paren lp@(L l p)
| patNeedsParens appPrec p = L l (ParPat noExtField lp)
| otherwise = lp
@@ -978,49 +1006,69 @@ isBangedHsBind (PatBind {pat_lhs = pat})
isBangedHsBind _
= False
-collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR)
+collectLocalBinders :: CollectPass (GhcPass idL)
+ => HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds
-- No pattern synonyms here
collectLocalBinders (HsIPBinds {}) = []
collectLocalBinders (EmptyLocalBinds _) = []
-collectHsIdBinders, collectHsValBinders
- :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
+collectHsIdBinders :: CollectPass (GhcPass idL)
+ => HsValBindsLR (GhcPass idL) (GhcPass idR)
+ -> [IdP (GhcPass idL)]
-- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively
collectHsIdBinders = collect_hs_val_binders True
+
+collectHsValBinders :: CollectPass (GhcPass idL)
+ => HsValBindsLR (GhcPass idL) (GhcPass idR)
+ -> [IdP (GhcPass idL)]
collectHsValBinders = collect_hs_val_binders False
-collectHsBindBinders :: XRec pass Pat ~ Located (Pat pass) =>
- HsBindLR pass idR -> [IdP pass]
+collectHsBindBinders :: CollectPass p
+ => HsBindLR p idR
+ -> [IdP p]
-- ^ Collect both 'Id's and pattern-synonym binders
collectHsBindBinders b = collect_bind False b []
-collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)]
+collectHsBindsBinders :: CollectPass p
+ => LHsBindsLR p idR
+ -> [IdP p]
collectHsBindsBinders binds = collect_binds False binds []
-collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)]
+collectHsBindListBinders :: CollectPass p
+ => [LHsBindLR p idR]
+ -> [IdP p]
-- ^ Same as 'collectHsBindsBinders', but works over a list of bindings
collectHsBindListBinders = foldr (collect_bind False . unLoc) []
-collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)
+collect_hs_val_binders :: CollectPass (GhcPass idL)
+ => Bool
+ -> HsValBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []
collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))
= collect_out_binds ps binds
-collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] ->
- [IdP (GhcPass p)]
+collect_out_binds :: CollectPass p
+ => Bool
+ -> [(RecFlag, LHsBinds p)]
+ -> [IdP p]
collect_out_binds ps = foldr (collect_binds ps . snd) []
-collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR ->
- [IdP (GhcPass p)] -> [IdP (GhcPass p)]
+collect_binds :: CollectPass p
+ => Bool
+ -> LHsBindsLR p idR
+ -> [IdP p]
+ -> [IdP p]
-- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag
collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds
-collect_bind :: XRec pass Pat ~ Located (Pat pass) =>
- Bool -> HsBindLR pass idR ->
- [IdP pass] -> [IdP pass]
+collect_bind :: CollectPass p
+ => Bool
+ -> HsBindLR p idR
+ -> [IdP p]
+ -> [IdP p]
collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc
collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
collect_bind _ (VarBind { var_id = f }) acc = f : acc
@@ -1044,19 +1092,23 @@ collectMethodBinders binds = foldr (get . unLoc) [] binds
-- Someone else complains about non-FunBinds
----------------- Statements --------------------------
-collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body]
+collectLStmtsBinders :: (CollectPass (GhcPass idL))
+ => [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders = concatMap collectLStmtBinders
-collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body]
+collectStmtsBinders :: (CollectPass (GhcPass idL))
+ => [StmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectStmtsBinders = concatMap collectStmtBinders
-collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body
+collectLStmtBinders :: (CollectPass (GhcPass idL))
+ => LStmtLR (GhcPass idL) (GhcPass idR) body
-> [IdP (GhcPass idL)]
collectLStmtBinders = collectStmtBinders . unLoc
-collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
+collectStmtBinders :: (CollectPass (GhcPass idL))
+ => StmtLR (GhcPass idL) (GhcPass idR) body
-> [IdP (GhcPass idL)]
-- Id Binders for a Stmt... [but what about pattern-sig type vars]?
collectStmtBinders (BindStmt _ pat _ _ _) = collectPatBinders pat
@@ -1071,47 +1123,65 @@ collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args
where
collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat
collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat
+ collectArgBinders (_, XApplicativeArg {}) = []
----------------- Patterns --------------------------
-collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)]
+collectPatBinders :: CollectPass p => LPat p -> [IdP p]
collectPatBinders pat = collect_lpat pat []
-collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)]
+collectPatsBinders :: CollectPass p => [LPat p] -> [IdP p]
collectPatsBinders pats = foldr collect_lpat [] pats
-------------
-collect_lpat :: XRec pass Pat ~ Located (Pat pass) =>
- LPat pass -> [IdP pass] -> [IdP pass]
-collect_lpat p bndrs
- = go (unLoc p)
- where
- go (VarPat _ var) = unLoc var : bndrs
- go (WildPat _) = bndrs
- go (LazyPat _ pat) = collect_lpat pat bndrs
- go (BangPat _ pat) = collect_lpat pat bndrs
- go (AsPat _ a pat) = unLoc a : collect_lpat pat bndrs
- go (ViewPat _ _ pat) = collect_lpat pat bndrs
- go (ParPat _ pat) = collect_lpat pat bndrs
-
- go (ListPat _ pats) = foldr collect_lpat bndrs pats
- go (TuplePat _ pats _) = foldr collect_lpat bndrs pats
- go (SumPat _ pat _ _) = collect_lpat pat bndrs
-
- go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
- go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
- -- See Note [Dictionary binders in ConPatOut]
- go (LitPat _ _) = bndrs
- go (NPat {}) = bndrs
- go (NPlusKPat _ n _ _ _ _) = unLoc n : bndrs
-
- go (SigPat _ pat _) = collect_lpat pat bndrs
-
- go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
- = go pat
- go (SplicePat _ _) = bndrs
- go (CoPat _ _ pat _) = go pat
- go (XPat {}) = bndrs
+collect_lpat :: forall pass. (CollectPass pass)
+ => LPat pass -> [IdP pass] -> [IdP pass]
+collect_lpat p bndrs = collect_pat (unLoc p) bndrs
+
+collect_pat :: forall p. CollectPass p
+ => Pat p
+ -> [IdP p]
+ -> [IdP p]
+collect_pat pat bndrs = case pat of
+ (VarPat _ var) -> unLoc var : bndrs
+ (WildPat _) -> bndrs
+ (LazyPat _ pat) -> collect_lpat pat bndrs
+ (BangPat _ pat) -> collect_lpat pat bndrs
+ (AsPat _ a pat) -> unLoc a : collect_lpat pat bndrs
+ (ViewPat _ _ pat) -> collect_lpat pat bndrs
+ (ParPat _ pat) -> collect_lpat pat bndrs
+ (ListPat _ pats) -> foldr collect_lpat bndrs pats
+ (TuplePat _ pats _) -> foldr collect_lpat bndrs pats
+ (SumPat _ pat _ _) -> collect_lpat pat bndrs
+ (ConPat {pat_args=ps}) -> foldr collect_lpat bndrs (hsConPatArgs ps)
+ -- See Note [Dictionary binders in ConPatOut]
+ (LitPat _ _) -> bndrs
+ (NPat {}) -> bndrs
+ (NPlusKPat _ n _ _ _ _) -> unLoc n : bndrs
+ (SigPat _ pat _) -> collect_lpat pat bndrs
+ (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
+ -> collect_pat pat bndrs
+ (SplicePat _ _) -> bndrs
+ (XPat ext) -> collectXXPat (Proxy @p) ext bndrs
+
+-- | This class specifies how to collect variable identifiers from extension patterns in the given pass.
+-- Consumers of the GHC API that define their own passes should feel free to implement instances in order
+-- to make use of functions which depend on it.
+--
+-- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that
+-- it can reuse the code in GHC for collecting binders.
+class (XRec p Pat ~ Located (Pat p)) => CollectPass p where
+ collectXXPat :: Proxy p -> XXPat p -> [IdP p] -> [IdP p]
+
+instance CollectPass (GhcPass 'Parsed) where
+ collectXXPat _ ext = noExtCon ext
+
+instance CollectPass (GhcPass 'Renamed) where
+ collectXXPat _ ext = noExtCon ext
+
+instance CollectPass (GhcPass 'Typechecked) where
+ collectXXPat _ (CoPat _ pat _) = collect_pat pat
+
{-
Note [Dictionary binders in ConPatOut] See also same Note in GHC.HsToCore.Arrows
@@ -1393,10 +1463,8 @@ lPatImplicits = hs_lpat
hs_pat (TuplePat _ pats _) = hs_lpats pats
hs_pat (SigPat _ pat _) = hs_lpat pat
- hs_pat (CoPat _ _ pat _) = hs_pat pat
- hs_pat (ConPatIn n ps) = details n ps
- hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps
+ hs_pat (ConPat {pat_con=con, pat_args=ps}) = details con ps
hs_pat _ = []
=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -1191,7 +1191,7 @@ Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The following functions to collect value variables from patterns are
copied from GHC.Hs.Utils, with one change: we also collect the dictionary
-bindings (pat_binds) from ConPatOut. We need them for cases like
+bindings (cpt_binds) from ConPatOut. We need them for cases like
h :: Arrow a => Int -> a (Int,Int) Int
h x = proc (y,z) -> case compare x y of
@@ -1231,8 +1231,8 @@ collectl (L _ pat) bndrs
go (TuplePat _ pats _) = foldr collectl bndrs pats
go (SumPat _ pat _ _) = collectl pat bndrs
- go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
- go (ConPatOut {pat_args=ps, pat_binds=ds}) =
+ go (ConPat { pat_args = ps
+ , pat_con_ext = ConPatTc { cpt_binds = ds }}) =
collectEvBinders ds
++ foldr collectl bndrs (hsConPatArgs ps)
go (LitPat _ _) = bndrs
@@ -1240,7 +1240,7 @@ collectl (L _ pat) bndrs
go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
go (SigPat _ pat _) = collectl pat bndrs
- go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
+ go (XPat (CoPat _ pat _)) = collectl (noLoc pat) bndrs
go (ViewPat _ _ pat) = collectl pat bndrs
go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -117,7 +117,9 @@ user-written. This lets us relate Names (from ClsInsts) to comments
(associated with InstDecls and DerivDecls).
-}
-getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
+getMainDeclBinder :: (CollectPass (GhcPass p))
+ => HsDecl (GhcPass p)
+ -> [IdP (GhcPass p)]
getMainDeclBinder (TyClD _ d) = [tcdName d]
getMainDeclBinder (ValD _ d) =
case collectHsBindBinders d of
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -697,13 +697,16 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
- pat = noLoc $ ConPatOut { pat_con = noLoc con
- , pat_tvs = ex_tvs
- , pat_dicts = eqs_vars ++ theta_vars
- , pat_binds = emptyTcEvBinds
- , pat_args = PrefixCon $ map nlVarPat arg_ids
- , pat_arg_tys = in_inst_tys
- , pat_wrap = req_wrap }
+ pat = noLoc $ ConPat { pat_con = noLoc con
+ , pat_args = PrefixCon $ map nlVarPat arg_ids
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = ex_tvs
+ , cpt_dicts = eqs_vars ++ theta_vars
+ , cpt_binds = emptyTcEvBinds
+ , cpt_arg_tys = in_inst_tys
+ , cpt_wrap = req_wrap
+ }
+ }
; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
{- Note [Scrutinee in Record updates]
=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -266,7 +266,7 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
deListComp (ApplicativeStmt {} : _) _ =
panic "deListComp ApplicativeStmt"
-deBindComp :: OutPat GhcTc
+deBindComp :: LPat GhcTc
-> CoreExpr
-> [ExprStmt GhcTc]
-> CoreExpr
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -267,7 +267,7 @@ matchBangs (var :| vars) ty eqns
matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
-- Apply the coercion to the match variable and then match that
matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
- = do { let CoPat _ co pat _ = firstPat eqn1
+ = do { let XPat (CoPat co pat _) = firstPat eqn1
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var pat_ty'
; match_result <- match (var':vars) ty $ NEL.toList $
@@ -313,7 +313,7 @@ decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
decomposeFirstPat _ _ = panic "decomposeFirstPat"
getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
-getCoPat (CoPat _ _ pat _) = pat
+getCoPat (XPat (CoPat _ pat _)) = pat
getCoPat _ = panic "getCoPat"
getBangPat (BangPat _ pat ) = unLoc pat
getBangPat _ = panic "getBangPat"
@@ -512,8 +512,8 @@ tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p
-- it may disappear next time
tidy_bang_pat v o l (AsPat x v' p)
= tidy1 v o (AsPat x v' (L l (BangPat noExtField p)))
-tidy_bang_pat v o l (CoPat x w p t)
- = tidy1 v o (CoPat x w (BangPat noExtField (L l p)) t)
+tidy_bang_pat v o l (XPat (CoPat w p t))
+ = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t)
-- Discard bang around strict pattern
tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p
@@ -522,9 +522,12 @@ tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p
tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p
-- Data/newtype constructors
-tidy_bang_pat v o l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
- , pat_args = args
- , pat_arg_tys = arg_tys })
+tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
+ , pat_args = args
+ , pat_con_ext = ConPatTc
+ { cpt_arg_tys = arg_tys
+ }
+ })
-- Newtypes: push bang inwards (#9844)
=
if isNewTyCon (dataConTyCon dc)
@@ -1117,8 +1120,9 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
patGroup :: Platform -> Pat GhcTc -> PatGroup
-patGroup _ (ConPatOut { pat_con = L _ con
- , pat_arg_tys = tys })
+patGroup _ (ConPat { pat_con = L _ con
+ , pat_con_ext = ConPatTc { cpt_arg_tys = tys }
+ })
| RealDataCon dcon <- con = PgCon dcon
| PatSynCon psyn <- con = PgSyn psyn tys
patGroup _ (WildPat {}) = PgAny
@@ -1135,7 +1139,7 @@ patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
case oval of
HsIntegral i -> PgNpK (il_value i)
_ -> pprPanic "patGroup NPlusKPat" (ppr oval)
-patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p)
+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
=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -143,9 +143,16 @@ matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor
; match_result <- match (group_arg_vars ++ vars) ty eqns'
; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
- shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
- pat_binds = bind, pat_args = args
- } : pats }))
+ shift (_, eqn@(EqnInfo
+ { eqn_pats = ConPat
+ { pat_args = args
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = tvs
+ , cpt_dicts = ds
+ , cpt_binds = bind
+ }
+ } : pats
+ }))
= do ds_bind <- dsTcEvBinds bind
return ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
@@ -171,10 +178,15 @@ matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor
alt_wrapper = wrapper1,
alt_result = foldr1 combineMatchResults match_results } }
where
- ConPatOut { pat_con = L _ con1
- , pat_arg_tys = arg_tys, pat_wrap = wrapper1,
- pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
- = firstPat eqn1
+ ConPat { pat_con = L _ con1
+ , pat_args = args1
+ , pat_con_ext = ConPatTc
+ { cpt_arg_tys = arg_tys
+ , cpt_wrap = wrapper1
+ , cpt_tvs = tvs1
+ , cpt_dicts = dicts1
+ }
+ } = firstPat eqn1
fields1 = map flSelector (conLikeFieldLabels con1)
ex_tvs = conLikeExTyCoVars con1
=====================================
compiler/GHC/HsToCore/PmCheck.hs
=====================================
@@ -443,7 +443,7 @@ translatePat fam_insts x pat = case pat of
-- See Note [Translate 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
+ XPat (CoPat wrapper p _ty)
| isIdHsWrapper wrapper -> translatePat fam_insts x p
| WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts x p
| otherwise -> do
@@ -498,11 +498,14 @@ translatePat fam_insts x pat = case pat of
--
-- See #14547, especially comment#9 and comment#10.
- ConPatOut { pat_con = L _ con
- , pat_arg_tys = arg_tys
- , pat_tvs = ex_tvs
- , pat_dicts = dicts
- , pat_args = ps } -> do
+ ConPat { pat_con = L _ con
+ , pat_args = ps
+ , pat_con_ext = ConPatTc
+ { cpt_arg_tys = arg_tys
+ , cpt_tvs = ex_tvs
+ , cpt_dicts = dicts
+ }
+ } -> do
translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps
NPat ty (L _ olit) mb_neg _ -> do
@@ -544,7 +547,6 @@ translatePat fam_insts x pat = case pat of
-- --------------------------------------------------------------------------
-- Not supposed to happen
- ConPatIn {} -> panic "Check.translatePat: ConPatIn"
SplicePat {} -> panic "Check.translatePat: SplicePat"
-- | 'translatePat', but also select and return a new match var.
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1914,7 +1914,7 @@ repP (TuplePat _ ps boxed)
| otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
repP (SumPat _ p alt arity) = do { p1 <- repLP p
; repPunboxedSum p1 alt arity }
-repP (ConPatIn dc details)
+repP (ConPat NoExtField dc details)
= do { con_str <- lookupLOcc dc
; case details of
PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -723,14 +723,14 @@ strip_bangs (L _ (ParPat _ p)) = strip_bangs p
strip_bangs (L _ (BangPat _ p)) = strip_bangs p
strip_bangs lp = lp
-is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
+is_flat_prod_lpat :: LPat GhcTc -> Bool
is_flat_prod_lpat = is_flat_prod_pat . unLoc
-is_flat_prod_pat :: Pat (GhcPass p) -> Bool
+is_flat_prod_pat :: Pat GhcTc -> Bool
is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p
is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
-is_flat_prod_pat (ConPatOut { pat_con = L _ pcon
- , pat_args = ps})
+is_flat_prod_pat (ConPat { pat_con = L _ pcon
+ , pat_args = ps})
| RealDataCon con <- pcon
, isProductTyCon (dataConTyCon con)
= all is_triv_lpat (hsConPatArgs ps)
@@ -760,7 +760,7 @@ mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats = L (getLoc (head lpats)) $
mkVanillaTuplePat lpats Boxed
-mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
+mkVanillaTuplePat :: [LPat GhcTc] -> Boxity -> Pat GhcTc
-- A vanilla tuple pattern simply gets its type from its sub-patterns
mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -765,6 +765,7 @@ instance ( ToHie (HsMatchContext a)
toHie _ = pure []
instance ( a ~ GhcPass p
+ , IsPass p
, ToHie (Context (Located (IdP a)))
, ToHie (RContext (HsRecFields a (PScoped (LPat a))))
, ToHie (LHsExpr a)
@@ -807,12 +808,11 @@ instance ( a ~ GhcPass p
SumPat _ pat _ _ ->
[ toHie $ PS rsp scope pscope pat
]
- ConPatIn c dets ->
- [ toHie $ C Use c
- , toHie $ contextify dets
- ]
- ConPatOut {pat_con = con, pat_args = dets}->
- [ toHie $ C Use $ fmap conLikeName con
+ ConPat {pat_con = con, pat_args = dets}->
+ [ case ghcPass @p of
+ GhcPs -> toHie $ C Use $ con
+ GhcRn -> toHie $ C Use $ con
+ GhcTc -> toHie $ C Use $ fmap conLikeName con
, toHie $ contextify dets
]
ViewPat _ expr pat ->
@@ -836,8 +836,13 @@ instance ( a ~ GhcPass p
(protectSig @a cscope sig)
-- See Note [Scoping Rules for SigPat]
]
- CoPat _ _ _ _ ->
- []
+ XPat e -> case ghcPass @p of
+ GhcPs -> noExtCon e
+ GhcRn -> noExtCon e
+ GhcTc -> []
+ where
+ -- Make sure we get an error if this changes
+ _noWarn@(CoPat _ _ _) = e
where
contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
contextify (InfixCon a b) = InfixCon a' b'
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -12,6 +12,7 @@ free variables.
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
@@ -1821,13 +1822,12 @@ isStrictPattern lpat =
ListPat{} -> True
TuplePat{} -> True
SumPat{} -> True
- ConPatIn{} -> True
- ConPatOut{} -> True
+ ConPat{} -> True
LitPat{} -> True
NPat{} -> True
NPlusKPat{} -> True
SplicePat{} -> True
- CoPat{} -> panic "isStrictPattern: CoPat"
+ XPat{} -> panic "isStrictPattern: XPat"
{-
Note [ApplicativeDo and refutable patterns]
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -1221,28 +1221,47 @@ mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn
-> RnM (Pat GhcRn)
-mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
+mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) p2
= do { fix1 <- lookupFixityRn (unLoc op1)
; let (nofix_error, associate_right) = compareFixity fix1 fix2
; if nofix_error then do
{ precParseErr (NormalOp (unLoc op1),fix1)
(NormalOp (unLoc op2),fix2)
- ; return (ConPatIn op2 (InfixCon p1 p2)) }
+ ; return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = op2
+ , pat_args = InfixCon p1 p2
+ }
+ }
else if associate_right then do
{ new_p <- mkConOpPatRn op2 fix2 p12 p2
- ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) }
+ ; return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = op1
+ , pat_args = InfixCon p11 (L loc new_p)
+ }
+ }
-- XXX loc right?
- else return (ConPatIn op2 (InfixCon p1 p2)) }
+ else return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = op2
+ , pat_args = InfixCon p1 p2
+ }
+ }
mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
= ASSERT( not_op_pat (unLoc p2) )
- return (ConPatIn op (InfixCon p1 p2))
+ return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = op
+ , pat_args = InfixCon p1 p2
+ }
not_op_pat :: Pat GhcRn -> Bool
-not_op_pat (ConPatIn _ (InfixCon _ _)) = False
-not_op_pat _ = True
+not_op_pat (ConPat NoExtField _ (InfixCon _ _)) = False
+not_op_pat _ = True
--------------------------------------
checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
@@ -1270,7 +1289,7 @@ checkPrecMatch op (MG { mg_alts = (L _ ms) })
-- second eqn.
checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
-checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
+checkPrec op (ConPat NoExtField op1 (InfixCon _ _)) right = do
op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op
op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
let
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -468,14 +468,14 @@ rnPatAndThen mk p@(ViewPat x expr pat)
-- ; return (ViewPat expr' pat' ty) }
; return (ViewPat x expr' pat') }
-rnPatAndThen mk (ConPatIn con stuff)
+rnPatAndThen mk (ConPat NoExtField con args)
-- rnConPatAndThen takes care of reconstructing the pattern
-- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
= case unLoc con == nameRdrName (dataConName nilDataCon) of
True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
; if ol_flag then rnPatAndThen mk (ListPat noExtField [])
- else rnConPatAndThen mk con stuff}
- False -> rnConPatAndThen mk con stuff
+ else rnConPatAndThen mk con args}
+ False -> rnConPatAndThen mk con args
rnPatAndThen mk (ListPat _ pats)
= do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
@@ -505,9 +505,6 @@ rnPatAndThen mk (SplicePat _ splice)
Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed
Right already_renamed -> return already_renamed }
-rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)
-
-
--------------------
rnConPatAndThen :: NameMaker
-> Located RdrName -- the constructor
@@ -517,7 +514,12 @@ rnConPatAndThen :: NameMaker
rnConPatAndThen mk con (PrefixCon pats)
= do { con' <- lookupConCps con
; pats' <- rnLPatsAndThen mk pats
- ; return (ConPatIn con' (PrefixCon pats')) }
+ ; return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = con'
+ , pat_args = PrefixCon pats'
+ }
+ }
rnConPatAndThen mk con (InfixCon pat1 pat2)
= do { con' <- lookupConCps con
@@ -529,7 +531,12 @@ rnConPatAndThen mk con (InfixCon pat1 pat2)
rnConPatAndThen mk con (RecCon rpats)
= do { con' <- lookupConCps con
; rpats' <- rnHsRecPatsAndThen mk con' rpats
- ; return (ConPatIn con' (RecCon rpats')) }
+ ; return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = con'
+ , pat_args = RecCon rpats'
+ }
+ }
checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()
checkUnusedRecordWildcardCps loc dotdot_names =
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -532,9 +532,13 @@ unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
nlConWildPat :: DataCon -> LPat GhcPs
-- The pattern (K {})
-nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
- (RecCon (HsRecFields { rec_flds = []
- , rec_dotdot = Nothing })))
+nlConWildPat con = noLoc $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = noLoc $ getRdrName con
+ , pat_args = RecCon $ HsRecFields
+ { rec_flds = []
+ , rec_dotdot = Nothing }
+ }
{-
************************************************************************
=====================================
compiler/GHC/Tc/Gen/Arrow.hs
=====================================
@@ -81,9 +81,9 @@ Note that
************************************************************************
-}
-tcProc :: InPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr
+tcProc :: LPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr
-> ExpRhoType -- Expected type of whole proc expression
- -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)
+ -> TcM (LPat GhcTc, LHsCmdTop GhcTcId, TcCoercion)
tcProc pat cmd exp_ty
= newArrowScope $
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -506,8 +506,8 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
recursivePatSynErr ::
- OutputableBndrId p =>
- SrcSpan -- ^ The location of the first pattern synonym binding
+ (OutputableBndrId p, CollectPass (GhcPass p))
+ => SrcSpan -- ^ The location of the first pattern synonym binding
-- (for error reporting)
-> LHsBinds (GhcPass p)
-> TcM a
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -503,7 +503,7 @@ tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside
------------------------
-- Data constructors
-tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside
+tc_pat penv (ConPat NoExtField con arg_pats) pat_ty thing_inside
= tcConPat penv con pat_ty arg_pats thing_inside
------------------------
@@ -794,12 +794,15 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty
-- (see Note [Arrows and patterns])
(arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys'
arg_pats penv thing_inside
- ; let res_pat = ConPatOut { pat_con = header,
- pat_tvs = [], pat_dicts = [],
- pat_binds = emptyTcEvBinds,
- pat_args = arg_pats',
- pat_arg_tys = ctxt_res_tys,
- pat_wrap = idHsWrapper }
+ ; let res_pat = ConPat { pat_con = header
+ , pat_args = arg_pats'
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = [], cpt_dicts = []
+ , cpt_binds = emptyTcEvBinds
+ , cpt_arg_tys = ctxt_res_tys
+ , cpt_wrap = idHsWrapper
+ }
+ }
; return (mkHsWrapPat wrap res_pat pat_ty, res) }
@@ -828,13 +831,17 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty
<- checkConstraints skol_info ex_tvs' given $
tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside
- ; let res_pat = ConPatOut { pat_con = header,
- pat_tvs = ex_tvs',
- pat_dicts = given,
- pat_binds = ev_binds,
- pat_args = arg_pats',
- pat_arg_tys = ctxt_res_tys,
- pat_wrap = idHsWrapper }
+ ; let res_pat = ConPat
+ { pat_con = header
+ , pat_args = arg_pats'
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = ex_tvs'
+ , cpt_dicts = given
+ , cpt_binds = ev_binds
+ , cpt_arg_tys = ctxt_res_tys
+ , cpt_wrap = idHsWrapper
+ }
+ }
; return (mkHsWrapPat wrap res_pat pat_ty, res)
} }
@@ -879,13 +886,16 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside
; traceTc "checkConstraints }" (ppr ev_binds)
- ; let res_pat = ConPatOut { pat_con = L con_span $ PatSynCon pat_syn,
- pat_tvs = ex_tvs',
- pat_dicts = prov_dicts',
- pat_binds = ev_binds,
- pat_args = arg_pats',
- pat_arg_tys = mkTyVarTys univ_tvs',
- pat_wrap = req_wrap }
+ ; let res_pat = ConPat { pat_con = L con_span $ PatSynCon pat_syn
+ , pat_args = arg_pats'
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = ex_tvs'
+ , cpt_dicts = prov_dicts'
+ , cpt_binds = ev_binds
+ , cpt_arg_tys = mkTyVarTys univ_tvs'
+ , cpt_wrap = req_wrap
+ }
+ }
; pat_ty <- readExpType pat_ty
; return (mkHsWrapPat wrap res_pat pat_ty, res) }
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -2178,9 +2178,9 @@ tcDefaultAssocDecl fam_tc
, text "pats" <+> ppr pats
, text "rhs_ty" <+> ppr rhs_ty
])
- ; pat_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis
- ; check_all_distinct_tvs ppr_eqn $ zip pat_tvs pats_vis
- ; let subst = zipTvSubst pat_tvs (mkTyVarTys fam_tvs)
+ ; cpt_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis
+ ; check_all_distinct_tvs ppr_eqn $ zip cpt_tvs pats_vis
+ ; let subst = zipTvSubst cpt_tvs (mkTyVarTys fam_tvs)
; pure $ Just (substTyUnchecked subst rhs_ty, loc)
-- We also perform other checks for well-formedness and validity
-- later, in checkValidClass
@@ -2217,8 +2217,8 @@ tcDefaultAssocDecl fam_tc
-- visibilities (the latter are only used for error
-- message purposes)
-> TcM ()
- check_all_distinct_tvs ppr_eqn pat_tvs_vis =
- let dups = findDupsEq ((==) `on` fst) pat_tvs_vis in
+ check_all_distinct_tvs ppr_eqn cpt_tvs_vis =
+ let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in
traverse_
(\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $
pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -941,7 +941,7 @@ tcPatToExpr name args pat = go pat
go (L loc p) = L loc <$> go1 p
go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
- go1 (ConPatIn con info)
+ go1 (ConPat NoExtField con info)
= case info of
PrefixCon ps -> mkPrefixConExpr con ps
InfixCon l r -> mkPrefixConExpr con [l,r]
@@ -974,8 +974,6 @@ tcPatToExpr name args pat = go pat
= return $ unLoc $ foldl' nlHsApp (noLoc neg)
[noLoc (HsOverLit noExtField n)]
| otherwise = return $ HsOverLit noExtField n
- go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
- go1 (CoPat{}) = panic "CoPat in output of renamer"
go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
= go1 pat
go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
@@ -1125,10 +1123,11 @@ tcCollectEx pat = go pat
go1 (TuplePat _ ps _) = mergeMany . map go $ ps
go1 (SumPat _ p _ _) = go p
go1 (ViewPat _ _ p) = go p
- go1 con at ConPatOut{} = merge (pat_tvs con, pat_dicts con) $
+ go1 con at ConPat{ pat_con_ext = con' }
+ = merge (cpt_tvs con', cpt_dicts con') $
goConDetails $ pat_args con
go1 (SigPat _ p _) = go p
- go1 (CoPat _ _ p _) = go1 p
+ go1 (XPat (CoPat _ p _)) = go1 p
go1 (NPlusKPat _ n k _ geq subtract)
= pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
go1 _ = empty
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -895,7 +895,7 @@ mkOneRecordSelector all_cons idDetails fl
mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
[L loc (mk_sel_pat con)]
(L loc (HsVar noExtField (L loc field_var)))
- mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
+ mk_sel_pat con = ConPat NoExtField (L loc (getName con)) (RecCon rec_fields)
rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
rec_field = noLoc (HsRecField
{ hsRecFieldLbl
=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -114,14 +114,16 @@ hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = 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
-hsPatType (ConPatOut { pat_con = lcon
- , pat_arg_tys = tys })
+hsPatType (ConPat { pat_con = lcon
+ , pat_con_ext = ConPatTc
+ { cpt_arg_tys = tys
+ }
+ })
= conLikeResTy (unLoc lcon) tys
hsPatType (SigPat ty _ _) = ty
hsPatType (NPat ty _ _ _) = ty
hsPatType (NPlusKPat ty _ _ _ _ _) = ty
-hsPatType (CoPat _ _ _ ty) = ty
-hsPatType ConPatIn{} = panic "hsPatType: ConPatIn"
+hsPatType (XPat (CoPat _ _ ty)) = ty
hsPatType SplicePat{} = panic "hsPatType: SplicePat"
hsLitType :: HsLit (GhcPass p) -> TcType
@@ -1285,7 +1287,7 @@ mapIPNameTc f (Right x) = do r <- f x
************************************************************************
-}
-zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc)
+zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
-- Extend the environment as we go, because it's possible for one
-- pattern to bind something that is used in another (inside or
-- to the right)
@@ -1347,13 +1349,16 @@ zonk_pat env (SumPat tys pat alt arity )
; (env', pat') <- zonkPat env pat
; return (env', SumPat tys' pat' alt arity) }
-zonk_pat env p@(ConPatOut { pat_arg_tys = tys
- , pat_tvs = tyvars
- , pat_dicts = evs
- , pat_binds = binds
- , pat_args = args
- , pat_wrap = wrapper
- , pat_con = L _ con })
+zonk_pat env p@(ConPat { pat_con = L _ con
+ , pat_args = args
+ , pat_con_ext = p'@(ConPatTc
+ { cpt_tvs = tyvars
+ , cpt_dicts = evs
+ , cpt_binds = binds
+ , cpt_wrap = wrapper
+ , cpt_arg_tys = tys
+ })
+ })
= ASSERT( all isImmutableTyVar tyvars )
do { new_tys <- mapM (zonkTcTypeToTypeX env) tys
@@ -1373,12 +1378,19 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys
; (env2, new_binds) <- zonkTcEvBinds env1 binds
; (env3, new_wrapper) <- zonkCoFn env2 wrapper
; (env', new_args) <- zonkConStuff env3 args
- ; return (env', p { pat_arg_tys = new_tys,
- pat_tvs = new_tyvars,
- pat_dicts = new_evs,
- pat_binds = new_binds,
- pat_args = new_args,
- pat_wrap = new_wrapper}) }
+ ; pure ( env'
+ , p
+ { pat_args = new_args
+ , pat_con_ext = p'
+ { cpt_arg_tys = new_tys
+ , cpt_tvs = new_tyvars
+ , cpt_dicts = new_evs
+ , cpt_binds = new_binds
+ , cpt_wrap = new_wrapper
+ }
+ }
+ )
+ }
where
doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
@@ -1409,19 +1421,20 @@ zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
; return (extendIdZonkEnv env2 n',
NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
-zonk_pat env (CoPat x co_fn pat ty)
+zonk_pat env (XPat (CoPat co_fn pat ty))
= do { (env', co_fn') <- zonkCoFn env co_fn
; (env'', pat') <- zonkPat env' (noLoc pat)
; ty' <- zonkTcTypeToTypeX env'' ty
- ; return (env'', CoPat x co_fn' (unLoc pat') ty') }
+ ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty')
+ }
zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
---------------------------
zonkConStuff :: ZonkEnv
- -> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId))
+ -> HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc))
-> TcM (ZonkEnv,
- HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc)))
+ HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc)))
zonkConStuff env (PrefixCon pats)
= do { (env', pats') <- zonkPats env pats
; return (env', PrefixCon pats') }
@@ -1440,7 +1453,7 @@ zonkConStuff env (RecCon (HsRecFields rpats dd))
-- Field selectors have declared types; hence no zonking
---------------------------
-zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat GhcTc])
+zonkPats :: ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
zonkPats env [] = return (env, [])
zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
; (env', pats') <- zonkPats env1 pats
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -2155,8 +2155,8 @@ checkFamPatBinders fam_tc qtvs pats rhs
, ppr (mkTyConApp fam_tc pats)
, text "qtvs:" <+> ppr qtvs
, text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs)
- , text "pat_tvs:" <+> ppr pat_tvs
- , text "inj_pat_tvs:" <+> ppr inj_pat_tvs ]
+ , text "cpt_tvs:" <+> ppr cpt_tvs
+ , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs ]
-- Check for implicitly-bound tyvars, mentioned on the
-- RHS but not bound on the LHS
@@ -2176,23 +2176,23 @@ checkFamPatBinders fam_tc qtvs pats rhs
(text "used in")
}
where
- pat_tvs = tyCoVarsOfTypes pats
- inj_pat_tvs = fvVarSet $ injectiveVarsOfTypes False pats
+ cpt_tvs = tyCoVarsOfTypes pats
+ inj_cpt_tvs = fvVarSet $ injectiveVarsOfTypes False pats
-- The type variables that are in injective positions.
-- See Note [Dodgy binding sites in type family instances]
-- NB: The False above is irrelevant, as we never have type families in
-- patterns.
--
-- NB: It's OK to use the nondeterministic `fvVarSet` function here,
- -- since the order of `inj_pat_tvs` is never revealed in an error
+ -- since the order of `inj_cpt_tvs` is never revealed in an error
-- message.
rhs_fvs = tyCoFVsOfType rhs
- used_tvs = pat_tvs `unionVarSet` fvVarSet rhs_fvs
+ used_tvs = cpt_tvs `unionVarSet` fvVarSet rhs_fvs
bad_qtvs = filterOut (`elemVarSet` used_tvs) qtvs
-- Bound but not used at all
- bad_rhs_tvs = filterOut (`elemVarSet` inj_pat_tvs) (fvVarList rhs_fvs)
+ bad_rhs_tvs = filterOut (`elemVarSet` inj_cpt_tvs) (fvVarList rhs_fvs)
-- Used on RHS but not bound on LHS
- dodgy_tvs = pat_tvs `minusVarSet` inj_pat_tvs
+ dodgy_tvs = cpt_tvs `minusVarSet` inj_cpt_tvs
check_tvs tvs what what2
= unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1268,12 +1268,22 @@ cvtp (UnboxedSumP p alt arity)
; return $ SumPat noExtField p' alt arity }
cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps
; let pps = map (parenthesizePat appPrec) ps'
- ; return $ ConPatIn s' (PrefixCon pps) }
+ ; return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = s'
+ , pat_args = PrefixCon pps
+ }
+ }
cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
; wrapParL (ParPat noExtField) $
- ConPatIn s' $
- InfixCon (parenthesizePat opPrec p1')
- (parenthesizePat opPrec p2') }
+ ConPat
+ { pat_con_ext = NoExtField
+ , pat_con = s'
+ , pat_args = InfixCon
+ (parenthesizePat opPrec p1')
+ (parenthesizePat opPrec p2')
+ }
+ }
-- See Note [Operator association]
cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
cvtp (ParensP p) = do { p' <- cvtPat p;
@@ -1286,8 +1296,12 @@ cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p
; return $ AsPat noExtField s' p' }
cvtp TH.WildP = return $ WildPat noExtField
cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
- ; return $ ConPatIn c'
- $ Hs.RecCon (HsRecFields fs' Nothing) }
+ ; return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = c'
+ , pat_args = Hs.RecCon $ HsRecFields fs' Nothing
+ }
+ }
cvtp (ListP ps) = do { ps' <- cvtPats ps
; return
$ ListPat noExtField ps'}
@@ -1317,7 +1331,12 @@ cvtOpAppP x op1 (UInfixP y op2 z)
cvtOpAppP x op y
= do { op' <- cNameL op
; y' <- cvtPat y
- ; return (ConPatIn op' (InfixCon x y')) }
+ ; return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = op'
+ , pat_args = InfixCon x y'
+ }
+ }
-----------------------------------------------------------
-- Types and type variables
=====================================
compiler/parser/RdrHsSyn.hs
=====================================
@@ -602,7 +602,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
; return $ mkMatchGroup FromSource matches }
where
fromDecl (L loc decl@(ValD _ (PatBind _
- pat@(L _ (ConPatIn ln@(L _ name) details))
+ pat@(L _ (ConPat NoExtField ln@(L _ name) details))
rhs _))) =
do { unless (name == patsyn_name) $
wrongNameBindingErr loc decl
@@ -1076,7 +1076,11 @@ checkLPat e@(L l _) = checkPat l e []
checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat loc (L l e@(PatBuilderVar (L _ c))) args
- | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
+ | isRdrDataCon c = return . L loc $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = L l c
+ , pat_args = PrefixCon args
+ }
| not (null args) && patIsRec c =
localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $
patFail l (ppr e)
@@ -1113,7 +1117,11 @@ checkAPat loc e0 = do
| isRdrDataCon c -> do
l <- checkLPat l
r <- checkLPat r
- return (ConPatIn (L cl c) (InfixCon l r))
+ return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = L cl c
+ , pat_args = InfixCon l r
+ }
PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField))
_ -> patFail loc (ppr e0)
@@ -2064,7 +2072,11 @@ mkPatRec ::
mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd)
| isRdrDataCon (unLoc c)
= do fs <- mapM checkPatField fs
- return (PatBuilderPat (ConPatIn c (RecCon (HsRecFields fs dd))))
+ return $ PatBuilderPat $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = c
+ , pat_args = RecCon (HsRecFields fs dd)
+ }
mkPatRec p _ =
addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p
=====================================
testsuite/tests/ghc-api/T6145.hs
=====================================
@@ -39,7 +39,7 @@ main = do
= not (isEmptyBag (filterBag isDataCon bs))
isDataCon (L l (f at FunBind {}))
| (MG _ (L _ (m:_)) _) <- fun_matches f,
- ((L _ (c at ConPatOut{})):_)<-hsLMatchPats m,
+ ((L _ (c at ConPat{})):_)<-hsLMatchPats m,
(L l _)<-pat_con c
= isGoodSrcSpan l -- Check that the source location is a good one
isDataCon _
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 5ec817a3e41b7eaa50c74701ab2d7642df86464c
+Subproject commit b6bebdce0f217af8b6a249b3b6c2bd32dfa2b0b0
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b18aef96db43671ca89087389a4a7cf5c3a2734b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b18aef96db43671ca89087389a4a7cf5c3a2734b
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200415/b742a5bd/attachment-0001.html>
More information about the ghc-commits
mailing list