[Git][ghc/ghc][wip/ttg-con-pat] Pure refactor of code around ConPat
John Ericson
gitlab at gitlab.haskell.org
Fri Mar 27 18:43:17 UTC 2020
John Ericson pushed to branch wip/ttg-con-pat at Glasgow Haskell Compiler / GHC
Commits:
2bb83e98 by Cale Gibbard at 2020-03-27T14:42:59-04:00
Pure refactor of code around ConPat
Now that things are working, clean some things up:
- 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
- - - - -
25 changed files:
- compiler/GHC/Hs/Extension.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/Rename/Pat.hs
- compiler/GHC/Rename/Types.hs
- compiler/GHC/ThToHs.hs
- compiler/parser/RdrHsSyn.hs
- compiler/typecheck/TcArrows.hs
- compiler/typecheck/TcBinds.hs
- compiler/typecheck/TcGenDeriv.hs
- compiler/typecheck/TcHsSyn.hs
- compiler/typecheck/TcPat.hs
- compiler/typecheck/TcPatSyn.hs
- compiler/typecheck/TcTyClsDecls.hs
- compiler/typecheck/TcTyDecls.hs
- compiler/typecheck/TcValidity.hs
Changes:
=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -662,7 +662,6 @@ type family XListPat x
type family XTuplePat x
type family XSumPat x
type family XConPat x
-type family XConPatCon x
type family XViewPat x
type family XSplicePat x
type family XLitPat x
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -23,10 +23,11 @@
{-# LANGUAGE LambdaCase #-}
module GHC.Hs.Pat (
- Pat(..), InPat, OutPat, LPat,
+ Pat(..), LPat,
ConPatTc (..),
CoPat (..),
ListPatTc(..),
+ ConLikeP,
HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsRecField'(..), LHsRecField',
@@ -72,12 +73,10 @@ import GHC.Core.Type
import SrcLoc
import Bag -- collect ev vars from pats
import Maybes
+import Name (Name)
-- libraries:
import Data.Data hiding (TyCon,Fixity)
-type InPat p = LPat p -- No 'Out' constructors
-type OutPat p = LPat GhcTc -- No 'In' constructors
-
type LPat p = XRec p Pat
-- | Pattern
@@ -175,9 +174,9 @@ data Pat p
------------ Constructor patterns ---------------
| ConPat {
- pat_con :: Located (XConPatCon p),
- pat_args :: HsConPatDetails p,
- pat_con_ext :: XConPat p
+ pat_con_ext :: XConPat p,
+ pat_con :: Located (ConLikeP p),
+ pat_args :: HsConPatDetails p
}
-- ^ Constructor Pattern
@@ -282,10 +281,6 @@ type instance XConPat GhcPs = NoExtField
type instance XConPat GhcRn = NoExtField
type instance XConPat GhcTc = ConPatTc
-type instance XConPatCon GhcPs = IdP GhcPs
-type instance XConPatCon GhcRn = IdP GhcRn
-type instance XConPatCon GhcTc = ConLike
-
type instance XSumPat GhcPs = NoExtField
type instance XSumPat GhcRn = NoExtField
type instance XSumPat GhcTc = [Type]
@@ -313,6 +308,11 @@ type instance XXPat GhcPs = NoExtCon
type instance XXPat GhcRn = NoExtCon
type instance XXPat GhcTc = CoPat
+type family ConLikeP x
+
+type instance ConLikeP GhcPs = RdrName -- IdP GhcPs
+type instance ConLikeP GhcRn = Name -- IdP GhcRn
+type instance ConLikeP GhcTc = ConLike
-- ---------------------------------------------------------------------
@@ -329,26 +329,26 @@ data ConPatTc
= ConPatTc
{ -- | The universal arg types 1-1 with the universal
-- tyvars of the constructor/pattern synonym
- -- Use (conLikeResTy pat_con pat_arg_tys) to get
+ -- Use (conLikeResTy pat_con cpt_arg_tys) to get
-- the type of the pattern
- pat_arg_tys :: [Type]
+ cpt_arg_tys :: [Type]
, -- | Existentially bound type variables
-- in correctly-scoped order e.g. [k:* x:k]
- pat_tvs :: [TyVar]
+ cpt_tvs :: [TyVar]
, -- | Ditto *coercion variables* and *dictionaries*
-- One reason for putting coercion variable here I think
-- is to ensure their kinds are zonked
- pat_dicts :: [EvVar]
+ cpt_dicts :: [EvVar]
, -- | Bindings involving those dictionaries
- pat_binds :: TcEvBinds
+ cpt_binds :: TcEvBinds
, -- ^ Extra wrapper to pass to the matcher
-- Only relevant for pattern-synonyms;
-- ignored for data cons
- pat_wrap :: HsWrapper
+ cpt_wrap :: HsWrapper
}
-- | Coercion Pattern (translation only)
@@ -360,7 +360,7 @@ data CoPat
{ -- | Coercion Pattern
-- If co :: t1 ~ t2, p :: t2,
-- then (CoPat co p) :: t1
- co_pat_wrap :: HsWrapper
+ co_cpt_wrap :: HsWrapper
, -- | Why not LPat? Ans: existing locn will do
co_pat_inner :: Pat GhcTc
@@ -523,16 +523,14 @@ pprParendLPat :: (OutputableBndrId p)
=> PprPrec -> LPat (GhcPass p) -> SDoc
pprParendLPat p = pprParendPat p . unLoc
-pprParendPat
- :: forall p
- . OutputableBndrId p
- => PprPrec
- -> Pat (GhcPass p)
- -> SDoc
+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
+ else pprPat pat
where
need_parens print_tc_elab pat
| GhcTc <- ghcPass @p
@@ -547,7 +545,7 @@ pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_ela
-- But otherwise the CoPat is discarded, so it
-- is the pattern inside that matters. Sigh.
-pprPat :: forall p. (IsPass p, OutputableBndrId p) => Pat (GhcPass p) -> SDoc
+pprPat :: forall p. (OutputableBndrId p) => Pat (GhcPass p) -> SDoc
pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar)
pprPat (WildPat _) = char '_'
pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat
@@ -591,16 +589,16 @@ pprPat (ConPat { pat_con = con
-- error message, and we want to make sure it prints nicely
ppr con
<> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
- , pprIfTc @p $ ppr binds ])
+ , ppr binds ])
<+> pprConArgs details
- where ConPatTc { pat_tvs = tvs
- , pat_dicts = dicts
- , pat_binds = binds
+ 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 -> pprIfTc @p $ pprHsWrapper co $ \parens ->
+ GhcTc -> pprHsWrapper co $ \parens ->
if parens
then pprParendPat appPrec pat
else pprPat pat
@@ -643,24 +641,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 $ ConPat { pat_con = noLoc (RealDataCon dc)
, pat_args = PrefixCon pats
, pat_con_ext = ConPatTc
- { pat_tvs = []
- , pat_dicts = []
- , pat_binds = emptyTcEvBinds
- , pat_arg_tys = tys
- , pat_wrap = idHsWrapper
+ { cpt_tvs = []
+ , cpt_dicts = []
+ , cpt_binds = emptyTcEvBinds
+ , cpt_arg_tys = tys
+ , cpt_wrap = idHsWrapper
}
}
-mkNilPat :: Type -> OutPat (GhcPass p)
+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)] []
@@ -728,7 +726,7 @@ looksLazyPat (VarPat {}) = False
looksLazyPat (WildPat {}) = False
looksLazyPat _ = True
-isIrrefutableHsPat :: forall p. (IsPass p, 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
@@ -867,11 +865,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
- :: IsPass p
- => 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
@@ -900,7 +897,7 @@ collectEvVarsPat pat =
ConPat
{ pat_args = args
, pat_con_ext = ConPatTc
- { pat_dicts = dicts
+ { cpt_dicts = dicts
}
}
-> unionBags (listToBag dicts)
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -91,7 +91,7 @@ module GHC.Hs.Utils(
collectPatBinders, collectPatsBinders,
collectLStmtsBinders, collectStmtsBinders,
collectLStmtBinders, collectStmtBinders,
- XCollectPat(..),
+ CollectPass(..),
hsLTyClDeclBinders, hsTyClForeignBinders,
hsPatSynSelectors, getPatSynBinds,
@@ -200,12 +200,11 @@ mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct)
mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
mkHsAppTypes = foldl' mkHsAppType
-mkHsLam
- :: IsPass p
- => (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
@@ -444,38 +443,41 @@ nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
nlInfixConPat con l r = noLoc $ ConPat
- (noLoc con)
- (InfixCon (parenthesizePat opPrec l)
- (parenthesizePat opPrec r))
- noExtField
+ { 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 $ ConPat
- (noLoc con)
- (PrefixCon (map (parenthesizePat appPrec) pats))
- noExtField
+ { 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 $ ConPat
- (noLoc con)
- (PrefixCon (map (parenthesizePat appPrec) pats))
- noExtField
-
-nlNullaryConPat
- :: ( XConPatCon (GhcPass p) ~ IdP (GhcPass p)
- , XConPat (GhcPass p) ~ NoExtField
- )
- => IdP (GhcPass p)
- -> LPat (GhcPass p)
-nlNullaryConPat con = noLoc $ ConPat (noLoc con) (PrefixCon []) noExtField
+ { 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 $ ConPat
- (noLoc $ getRdrName con)
- (PrefixCon $
+ { pat_con_ext = noExtField
+ , pat_con = noLoc $ getRdrName con
+ , pat_args = PrefixCon $
replicate (dataConSourceArity con)
- nlWildPat)
- noExtField
+ nlWildPat
+ }
-- | Wildcard pattern - after parsing
nlWildPat :: LPat GhcPs
@@ -897,14 +899,12 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n
, mc_strictness = NoSrcStrict }
------------
-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 :: 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
= noLoc (Match { m_ext = noExtField
, m_ctxt = ctxt
@@ -1001,74 +1001,70 @@ isBangedHsBind (PatBind {pat_lhs = pat})
isBangedHsBind _
= False
-collectLocalBinders
- :: XCollectPat (GhcPass idL)
- => HsLocalBindsLR (GhcPass idL) (GhcPass idR)
- -> [IdP (GhcPass idL)]
+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 _) = []
collectLocalBinders (XHsLocalBindsLR _) = []
-collectHsIdBinders, collectHsValBinders
- :: XCollectPat (GhcPass idL)
- => 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
- :: XCollectPat p
- => HsBindLR p idR -> [IdP p]
+collectHsBindBinders :: CollectPass p
+ => HsBindLR p idR
+ -> [IdP p]
-- ^ Collect both 'Id's and pattern-synonym binders
collectHsBindBinders b = collect_bind False b []
-collectHsBindsBinders
- :: XCollectPat p
- => LHsBindsLR p idR
- -> [IdP p]
+collectHsBindsBinders :: CollectPass p
+ => LHsBindsLR p idR
+ -> [IdP p]
collectHsBindsBinders binds = collect_binds False binds []
-collectHsBindListBinders
- :: XCollectPat p
- => [LHsBindLR p idR]
- -> [IdP 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
- :: XCollectPat (GhcPass idL)
- => Bool
- -> HsValBindsLR (GhcPass idL) (GhcPass idR)
- -> [IdP (GhcPass idL)]
+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
- :: XCollectPat p
- => Bool
- -> [(RecFlag, LHsBinds p)]
- -> [IdP p]
+collect_out_binds :: CollectPass p
+ => Bool
+ -> [(RecFlag, LHsBinds p)]
+ -> [IdP p]
collect_out_binds ps = foldr (collect_binds ps . snd) []
-collect_binds
- :: XCollectPat p
- => Bool
- -> LHsBindsLR p idR
- -> [IdP p]
- -> [IdP 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
- :: XCollectPat p
- => Bool
- -> HsBindLR p idR
- -> [IdP p]
- -> [IdP p]
+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
@@ -1092,25 +1088,24 @@ collectMethodBinders binds = foldr (get . unLoc) [] binds
-- Someone else complains about non-FunBinds
----------------- Statements --------------------------
-collectLStmtsBinders :: (XCollectPat (GhcPass idL))
+collectLStmtsBinders :: (CollectPass (GhcPass idL))
=> [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders = concatMap collectLStmtBinders
-collectStmtsBinders :: (XCollectPat (GhcPass idL))
+collectStmtsBinders :: (CollectPass (GhcPass idL))
=> [StmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectStmtsBinders = concatMap collectStmtBinders
-collectLStmtBinders :: (XCollectPat (GhcPass idL))
+collectLStmtBinders :: (CollectPass (GhcPass idL))
=> LStmtLR (GhcPass idL) (GhcPass idR) body
-> [IdP (GhcPass idL)]
collectLStmtBinders = collectStmtBinders . unLoc
-collectStmtBinders
- :: (XCollectPat (GhcPass idL))
- => StmtLR (GhcPass idL) (GhcPass idR) body
- -> [IdP (GhcPass idL)]
+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
collectStmtBinders (LetStmt _ binds) = collectLocalBinders (unLoc binds)
@@ -1129,25 +1124,21 @@ collectStmtBinders (XStmtLR nec) = noExtCon nec
----------------- Patterns --------------------------
-collectPatBinders :: XCollectPat p => LPat p -> [IdP p]
+collectPatBinders :: CollectPass p => LPat p -> [IdP p]
collectPatBinders pat = collect_lpat pat []
-collectPatsBinders :: XCollectPat p => [LPat p] -> [IdP p]
+collectPatsBinders :: CollectPass p => [LPat p] -> [IdP p]
collectPatsBinders pats = foldr collect_lpat [] pats
-------------
-collect_lpat
- :: forall pass.
- (XCollectPat pass)
- => LPat pass -> [IdP pass] -> [IdP pass]
+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.
- XCollectPat p
- => Pat p
- -> [IdP p]
- -> [IdP p]
+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
@@ -1168,19 +1159,22 @@ collect_pat pat bndrs = case pat of
(SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
-> collect_pat pat bndrs
(SplicePat _ _) -> bndrs
- (XPat ext) -> collectPatX (Proxy @p) ext bndrs
+ (XPat ext) -> collectXXPat (Proxy @p) ext bndrs
-class (XRec p Pat ~ Located (Pat p)) => XCollectPat p where
- collectPatX :: Proxy p -> XXPat p -> [IdP p] -> [IdP p]
+-- 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.
+class (XRec p Pat ~ Located (Pat p)) => CollectPass p where
+ collectXXPat :: Proxy p -> XXPat p -> [IdP p] -> [IdP p]
-instance XCollectPat (GhcPass 'Parsed) where
- collectPatX _ ext = noExtCon ext
+instance CollectPass (GhcPass 'Parsed) where
+ collectXXPat _ ext = noExtCon ext
-instance XCollectPat (GhcPass 'Renamed) where
- collectPatX _ ext = noExtCon ext
+instance CollectPass (GhcPass 'Renamed) where
+ collectXXPat _ ext = noExtCon ext
-instance XCollectPat (GhcPass 'Typechecked) where
- collectPatX _ (CoPat _ pat _) = collect_pat pat
+instance CollectPass (GhcPass 'Typechecked) where
+ collectXXPat _ (CoPat _ pat _) = collect_pat pat
{-
=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -1196,7 +1196,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
@@ -1237,7 +1237,7 @@ collectl (L _ pat) bndrs
go (SumPat _ pat _ _) = collectl pat bndrs
go (ConPat { pat_args = ps
- , pat_con_ext = ConPatTc { pat_binds = ds }}) =
+ , pat_con_ext = ConPatTc { cpt_binds = ds }}) =
collectEvBinders ds
++ foldr collectl bndrs (hsConPatArgs ps)
go (LitPat _ _) = bndrs
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -117,10 +117,9 @@ user-written. This lets us relate Names (from ClsInsts) to comments
(associated with InstDecls and DerivDecls).
-}
-getMainDeclBinder
- :: (XCollectPat (GhcPass p))
- => 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
=====================================
@@ -708,11 +708,11 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
pat = noLoc $ ConPat { pat_con = noLoc con
, pat_args = PrefixCon $ map nlVarPat arg_ids
, pat_con_ext = ConPatTc
- { pat_tvs = ex_tvs
- , pat_dicts = eqs_vars ++ theta_vars
- , pat_binds = emptyTcEvBinds
- , pat_arg_tys = in_inst_tys
- , pat_wrap = req_wrap
+ { 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) }
=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -270,7 +270,7 @@ deListComp (ApplicativeStmt {} : _) _ =
deListComp (XStmtLR nec : _) _ =
noExtCon nec
-deBindComp :: OutPat GhcTc
+deBindComp :: LPat GhcTc
-> CoreExpr
-> [ExprStmt GhcTc]
-> CoreExpr
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -525,7 +525,7 @@ tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p
tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
, pat_args = args
, pat_con_ext = ConPatTc
- { pat_arg_tys = arg_tys
+ { cpt_arg_tys = arg_tys
}
})
-- Newtypes: push bang inwards (#9844)
@@ -1124,7 +1124,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
patGroup :: Platform -> Pat GhcTc -> PatGroup
patGroup _ (ConPat { pat_con = L _ con
- , pat_con_ext = ConPatTc { pat_arg_tys = tys }
+ , pat_con_ext = ConPatTc { cpt_arg_tys = tys }
})
| RealDataCon dcon <- con = PgCon dcon
| PatSynCon psyn <- con = PgSyn psyn tys
=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -147,9 +147,9 @@ matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor
{ eqn_pats = ConPat
{ pat_args = args
, pat_con_ext = ConPatTc
- { pat_tvs = tvs
- , pat_dicts = ds
- , pat_binds = bind
+ { cpt_tvs = tvs
+ , cpt_dicts = ds
+ , cpt_binds = bind
}
} : pats
}))
@@ -181,10 +181,10 @@ matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor
ConPat { pat_con = L _ con1
, pat_args = args1
, pat_con_ext = ConPatTc
- { pat_arg_tys = arg_tys
- , pat_wrap = wrapper1
- , pat_tvs = tvs1
- , pat_dicts = dicts1
+ { cpt_arg_tys = arg_tys
+ , cpt_wrap = wrapper1
+ , cpt_tvs = tvs1
+ , cpt_dicts = dicts1
}
} = firstPat eqn1
fields1 = map flSelector (conLikeFieldLabels con1)
=====================================
compiler/GHC/HsToCore/PmCheck.hs
=====================================
@@ -502,9 +502,9 @@ translatePat fam_insts x pat = case pat of
ConPat { pat_con = L _ con
, pat_args = ps
, pat_con_ext = ConPatTc
- { pat_arg_tys = arg_tys
- , pat_tvs = ex_tvs
- , pat_dicts = dicts
+ { cpt_arg_tys = arg_tys
+ , cpt_tvs = ex_tvs
+ , cpt_dicts = dicts
}
} -> do
translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1984,7 +1984,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 (ConPat dc details NoExtField)
+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
=====================================
@@ -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/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 (ConPat con stuff NoExtField)
+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
@@ -517,7 +517,12 @@ rnConPatAndThen :: NameMaker
rnConPatAndThen mk con (PrefixCon pats)
= do { con' <- lookupConCps con
; pats' <- rnLPatsAndThen mk pats
- ; return (ConPat con' (PrefixCon pats') NoExtField) }
+ ; 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 +534,12 @@ rnConPatAndThen mk con (InfixCon pat1 pat2)
rnConPatAndThen mk con (RecCon rpats)
= do { con' <- lookupConCps con
; rpats' <- rnHsRecPatsAndThen mk con' rpats
- ; return (ConPat con' (RecCon rpats') NoExtField) }
+ ; return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = con'
+ , pat_args = RecCon rpats'
+ }
+ }
checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()
checkUnusedRecordWildcardCps loc dotdot_names =
=====================================
compiler/GHC/Rename/Types.hs
=====================================
@@ -1231,27 +1231,46 @@ 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 (ConPat op1 (InfixCon p11 p12) NoExtField)) 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 (ConPat op2 (InfixCon p1 p2) NoExtField) }
+ ; 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 (ConPat op1 (InfixCon p11 (L loc new_p)) NoExtField) }
+ ; return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = op1
+ , pat_args = InfixCon p11 (L loc new_p)
+ }
+ }
-- XXX loc right?
- else return (ConPat op2 (InfixCon p1 p2) NoExtField) }
+ 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 (ConPat op (InfixCon p1 p2) NoExtField)
+ return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = op
+ , pat_args = InfixCon p1 p2
+ }
not_op_pat :: Pat GhcRn -> Bool
-not_op_pat (ConPat _ (InfixCon _ _) NoExtField) = False
+not_op_pat (ConPat NoExtField _ (InfixCon _ _)) = False
not_op_pat _ = True
--------------------------------------
@@ -1281,7 +1300,7 @@ checkPrecMatch op (MG { mg_alts = (L _ ms) })
checkPrecMatch _ (XMatchGroup nec) = noExtCon nec
checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
-checkPrec op (ConPat op1 (InfixCon _ _) NoExtField) 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/ThToHs.hs
=====================================
@@ -1270,13 +1270,21 @@ 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 $ ConPat s' (PrefixCon pps) NoExtField }
+ ; 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) $
- ConPat s'
- (InfixCon (parenthesizePat opPrec p1')
- (parenthesizePat opPrec p2'))
- NoExtField
+ 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]
@@ -1290,9 +1298,11 @@ 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 $ ConPat c'
- (Hs.RecCon $ HsRecFields fs' Nothing)
- NoExtField
+ ; return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = c'
+ , pat_args = Hs.RecCon $ HsRecFields fs' Nothing
+ }
}
cvtp (ListP ps) = do { ps' <- cvtPats ps
; return
@@ -1323,7 +1333,11 @@ cvtOpAppP x op1 (UInfixP y op2 z)
cvtOpAppP x op y
= do { op' <- cNameL op
; y' <- cvtPat y
- ; return $ ConPat op' (InfixCon x y') NoExtField
+ ; return $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = op'
+ , pat_args = InfixCon x y'
+ }
}
-----------------------------------------------------------
=====================================
compiler/parser/RdrHsSyn.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 _ (ConPat ln@(L _ name) details NoExtField))
+ 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 (ConPat (L l c) (PrefixCon args) NoExtField))
+ | 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 (ConPat (L cl c) (InfixCon l r) NoExtField)
+ 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 $ ConPat c (RecCon (HsRecFields fs dd)) NoExtField
+ 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
=====================================
compiler/typecheck/TcArrows.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/typecheck/TcBinds.hs
=====================================
@@ -505,7 +505,7 @@ 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, XCollectPat (GhcPass p))
+ (OutputableBndrId p, CollectPass (GhcPass p))
=> SrcSpan -- ^ The location of the first pattern synonym binding
-- (for error reporting)
-> LHsBinds (GhcPass p)
=====================================
compiler/typecheck/TcGenDeriv.hs
=====================================
@@ -534,10 +534,12 @@ unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
nlConWildPat :: DataCon -> LPat GhcPs
-- The pattern (K {})
nlConWildPat con = noLoc $ ConPat
- (noLoc $ getRdrName con)
- (RecCon $ HsRecFields { rec_flds = []
- , rec_dotdot = Nothing })
- NoExtField
+ { pat_con_ext = noExtField
+ , pat_con = noLoc $ getRdrName con
+ , pat_args = RecCon $ HsRecFields
+ { rec_flds = []
+ , rec_dotdot = Nothing }
+ }
{-
************************************************************************
=====================================
compiler/typecheck/TcHsSyn.hs
=====================================
@@ -118,7 +118,7 @@ hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys
hsPatType (SumPat tys _ _ _ ) = mkSumTy tys
hsPatType (ConPat { pat_con = lcon
, pat_con_ext = ConPatTc
- { pat_arg_tys = tys
+ { cpt_arg_tys = tys
}
})
= conLikeResTy (unLoc lcon) tys
@@ -1309,7 +1309,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)
@@ -1374,11 +1374,11 @@ zonk_pat env (SumPat tys pat alt arity )
zonk_pat env p@(ConPat { pat_con = L _ con
, pat_args = args
, pat_con_ext = p'@(ConPatTc
- { pat_tvs = tyvars
- , pat_dicts = evs
- , pat_binds = binds
- , pat_wrap = wrapper
- , pat_arg_tys = tys
+ { cpt_tvs = tyvars
+ , cpt_dicts = evs
+ , cpt_binds = binds
+ , cpt_wrap = wrapper
+ , cpt_arg_tys = tys
})
})
= ASSERT( all isImmutableTyVar tyvars )
@@ -1404,11 +1404,11 @@ zonk_pat env p@(ConPat { pat_con = L _ con
, p
{ pat_args = new_args
, pat_con_ext = p'
- { pat_arg_tys = new_tys
- , pat_tvs = new_tyvars
- , pat_dicts = new_evs
- , pat_binds = new_binds
- , pat_wrap = new_wrapper
+ { cpt_arg_tys = new_tys
+ , cpt_tvs = new_tyvars
+ , cpt_dicts = new_evs
+ , cpt_binds = new_binds
+ , cpt_wrap = new_wrapper
}
}
)
@@ -1454,9 +1454,9 @@ 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') }
@@ -1475,7 +1475,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/typecheck/TcPat.hs
=====================================
@@ -495,7 +495,7 @@ tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside
------------------------
-- Data constructors
-tc_pat penv (ConPat con arg_pats NoExtField) 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
------------------------
@@ -789,10 +789,10 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty
; let res_pat = ConPat { pat_con = header
, pat_args = arg_pats'
, pat_con_ext = ConPatTc
- { pat_tvs = [], pat_dicts = []
- , pat_binds = emptyTcEvBinds
- , pat_arg_tys = ctxt_res_tys
- , pat_wrap = idHsWrapper
+ { cpt_tvs = [], cpt_dicts = []
+ , cpt_binds = emptyTcEvBinds
+ , cpt_arg_tys = ctxt_res_tys
+ , cpt_wrap = idHsWrapper
}
}
@@ -827,11 +827,11 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty
{ pat_con = header
, pat_args = arg_pats'
, pat_con_ext = ConPatTc
- { pat_tvs = ex_tvs'
- , pat_dicts = given
- , pat_binds = ev_binds
- , pat_arg_tys = ctxt_res_tys
- , pat_wrap = idHsWrapper
+ { 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)
@@ -881,11 +881,11 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
; let res_pat = ConPat { pat_con = L con_span $ PatSynCon pat_syn
, pat_args = arg_pats'
, pat_con_ext = ConPatTc
- { pat_tvs = ex_tvs'
- , pat_dicts = prov_dicts'
- , pat_binds = ev_binds
- , pat_arg_tys = mkTyVarTys univ_tvs'
- , pat_wrap = req_wrap
+ { 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
=====================================
compiler/typecheck/TcPatSyn.hs
=====================================
@@ -942,7 +942,7 @@ tcPatToExpr name args pat = go pat
go (L loc p) = L loc <$> go1 p
go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
- go1 (ConPat con info NoExtField)
+ go1 (ConPat NoExtField con info)
= case info of
PrefixCon ps -> mkPrefixConExpr con ps
InfixCon l r -> mkPrefixConExpr con [l,r]
@@ -1127,7 +1127,7 @@ tcCollectEx pat = go pat
go1 (SumPat _ p _ _) = go p
go1 (ViewPat _ _ p) = go p
go1 con at ConPat{ pat_con_ext = con' }
- = merge (pat_tvs con', pat_dicts con') $
+ = merge (cpt_tvs con', cpt_dicts con') $
goConDetails $ pat_args con
go1 (SigPat _ p _) = go p
go1 (XPat (CoPat _ p _)) = go1 p
=====================================
compiler/typecheck/TcTyClsDecls.hs
=====================================
@@ -2195,9 +2195,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
@@ -2234,8 +2234,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/typecheck/TcTyDecls.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 = ConPat (L loc (getName con)) (RecCon rec_fields) NoExtField
+ 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/typecheck/TcValidity.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)) $
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2bb83e98b5d4f49475f1ddf79c10d5ed91061082
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2bb83e98b5d4f49475f1ddf79c10d5ed91061082
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/20200327/ef454cab/attachment-0001.html>
More information about the ghc-commits
mailing list