diff options
Diffstat (limited to 'compiler/GHC')
27 files changed, 583 insertions, 330 deletions
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 0d67899b4c..db7a46805c 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -358,6 +358,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) diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 2b5c871ab1..c92967db81 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -10,6 +10,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] @@ -23,8 +24,11 @@ {-# LANGUAGE LambdaCase #-} module GHC.Hs.Pat ( - Pat(..), InPat, OutPat, LPat, + Pat(..), LPat, + ConPatTc (..), + CoPat (..), ListPatTc(..), + ConLikeP, HsConPatDetails, hsConPatArgs, HsRecFields(..), HsRecField'(..), LHsRecField', @@ -59,7 +63,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 GHC.Builtin.Types import GHC.Types.Var import GHC.Types.Name.Reader ( RdrName ) @@ -71,12 +74,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 +174,12 @@ data Pat p -- For details on above see note [Api annotations] in GHC.Parser.Annotation ------------ 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 +245,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 +278,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 +305,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 +327,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 +527,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 +563,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 +578,37 @@ 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 +#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 pprUserCon :: (OutputableBndr con, OutputableBndrId p) => con -> HsConPatDetails (GhcPass p) -> SDoc @@ -602,21 +647,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 +732,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 +748,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 +765,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 +786,14 @@ isIrrefutableHsPat -- since we cannot know until the splice is evaluated. go (SplicePat {}) = False + 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 + -- | Is the pattern any of combination of: -- -- - (pat) @@ -777,16 +835,21 @@ is the only thing that could possibly be matched! -- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs -- parentheses under precedence @p@. -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 +861,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@. @@ -811,7 +873,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@. -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 +902,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 diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 0b3300719e..75ef5b06bf 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/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 #-} @@ -89,6 +92,7 @@ module GHC.Hs.Utils( collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectStmtsBinders, collectLStmtBinders, collectStmtBinders, + CollectPass(..), hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors, getPatSynBinds, @@ -135,6 +139,7 @@ import GHC.Settings.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 _ = [] diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 3139610902..e3ac5a046b 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/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) diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index 48a8ef6f20..30cf626d6d 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/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 diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 5bd2326e62..8e4313f80d 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/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] diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index 368576cf30..9db596fb52 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/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 diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 2e62fa9856..b9e053c005 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -268,7 +268,7 @@ matchBangs (var :| vars) ty eqns matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- 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 $ @@ -314,7 +314,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" @@ -513,8 +513,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 @@ -523,9 +523,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) @@ -1119,8 +1122,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 @@ -1137,7 +1141,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 diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs index f9c3e021d4..c7022d6b1d 100644 --- a/compiler/GHC/HsToCore/Match/Constructor.hs +++ b/compiler/GHC/HsToCore/Match/Constructor.hs @@ -145,9 +145,16 @@ matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor ; return $ 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) @@ -173,10 +180,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 diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index 7fd431c434..6c8ac7f046 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/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. diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index c96eaf4e10..b49bd9d66b 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/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 } diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index d208fb73da..01f2a5c776 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -716,14 +716,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) @@ -753,7 +753,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 diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index c3b144dbfa..15edfd7bb6 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/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,15 @@ instance ( a ~ GhcPass p (protectSig @a cscope sig) -- See Note [Scoping Rules for SigPat] ] - CoPat _ _ _ _ -> - [] + XPat e -> case ghcPass @p of +#if __GLASGOW_HASKELL__ < 811 + GhcPs -> noExtCon e + GhcRn -> noExtCon e +#endif + 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' diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 7ce2f4fb9a..b135478584 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -603,7 +603,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 @@ -1077,7 +1077,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) @@ -1114,7 +1118,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) @@ -2065,7 +2073,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 diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 6142718ceb..9c52087448 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -12,6 +12,7 @@ free variables. {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -1823,13 +1824,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] diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index a91a672dfb..822f6f9cb9 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/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 diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index d8f55ccc1f..8e6747550e 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/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 = diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 5156bb0aa1..ad103ca7c8 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/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 } + } {- ************************************************************************ diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index 94e90acd24..69c5e67197 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/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 $ diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index a8a8d027f0..44fd594849 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/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 diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 2ae1f1cfb9..0456677cc7 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -521,7 +521,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 ------------------------ @@ -872,12 +872,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) } @@ -906,13 +909,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) } } @@ -957,13 +964,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) } diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 07d1453a5c..e69990cb63 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/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) $ diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 797ff2f594..37ba4e3329 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -940,7 +940,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] @@ -973,8 +973,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" @@ -1124,10 +1122,11 @@ tcCollectEx pat = go pat go1 (TuplePat _ ps _) = mergeMany . map go $ ps go1 (SumPat _ p _ _) = go p go1 (ViewPat _ _ p) = go p - go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $ + go1 con@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 diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index d12e7efce4..5ee3620db1 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/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 diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 00f11c09ae..09caf5fefa 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/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 @@ -1296,7 +1298,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) @@ -1358,13 +1360,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 @@ -1384,12 +1389,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 @@ -1420,19 +1432,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') } @@ -1451,7 +1464,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 diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index 6e44a6c399..c72d4cd357 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/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)) $ diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 7b5e4ce219..622ab13403 100644 --- a/compiler/GHC/ThToHs.hs +++ b/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 |