[commit: ghc] wip/ttg-2017-10-13: Bring in (Unused) NewPat constructor (29eb240)
git at git.haskell.org
git at git.haskell.org
Tue Oct 17 13:02:19 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/ttg-2017-10-13
Link : http://ghc.haskell.org/trac/ghc/changeset/29eb2407a53b25281fdfd5d5f7fc9a695675bae8/ghc
>---------------------------------------------------------------
commit 29eb2407a53b25281fdfd5d5f7fc9a695675bae8
Author: Alan Zimmerman <alan.zimm at gmail.com>
Date: Tue Oct 17 11:43:56 2017 +0200
Bring in (Unused) NewPat constructor
>---------------------------------------------------------------
29eb2407a53b25281fdfd5d5f7fc9a695675bae8
compiler/deSugar/Check.hs | 1 +
compiler/deSugar/DsArrows.hs | 1 +
compiler/hsSyn/HsExtension.hs | 30 +++++++++++++++++++++---------
compiler/hsSyn/HsPat.hs | 13 ++++++++++++-
compiler/hsSyn/HsTypes.hs | 2 +-
compiler/hsSyn/HsUtils.hs | 1 +
compiler/typecheck/TcPatSyn.hs | 2 ++
7 files changed, 39 insertions(+), 11 deletions(-)
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 3a2406e..bb05256 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -829,6 +829,7 @@ translatePat fam_insts pat = case pat of
ConPatIn {} -> panic "Check.translatePat: ConPatIn"
SplicePat {} -> panic "Check.translatePat: SplicePat"
SigPatIn {} -> panic "Check.translatePat: SigPatIn"
+ NewPat {} -> panic "Check.translatePat: NewPat"
-- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)
translateNPat :: FamInstEnvs
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
index d12c733..5c69bfd 100644
--- a/compiler/deSugar/DsArrows.hs
+++ b/compiler/deSugar/DsArrows.hs
@@ -1212,6 +1212,7 @@ collectl (L _ pat) bndrs
go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
go (ViewPat _ _ pat) = collectl pat bndrs
go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
+ go p@(NewPat {}) = pprPanic "collectl/go" (ppr p)
collectEvBinders :: TcEvBinds -> [Id]
collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs
diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs
index 56d52ad..2bea25b 100644
--- a/compiler/hsSyn/HsExtension.hs
+++ b/compiler/hsSyn/HsExtension.hs
@@ -67,17 +67,17 @@ type NoConExt = Void
-- | A data type index stating "there are no field extensions"
-- see "Trees that Grow"
type NoFieldExt = ()
-pattern
- NoFieldExt :: NoFieldExt
-pattern
- NoFieldExt = ()
+-- pattern
+-- NoFieldExt :: NoFieldExt
+-- pattern
+-- NoFieldExt = ()
-- | A data type index for pass `x` of GHC
-data GHC x
+-- data GHC x
-- TODO: unify `GHC` and `Ghcpass` by making `GhcTcId` part of `Ghcpass`
-deriving instance Data x => Data (GHC x)
+-- deriving instance Data x => Data (GHC x)
-- | Used as a data type index for the hsSyn AST
@@ -160,7 +160,7 @@ type ForallXPat (c :: * -> Constraint) (x :: *) =
, c (XNPlusKPat x)
, c (XSigPat x)
, c (XCoPat x)
- -- , c (XNewPat x)
+ , c (XNewPat x)
)
-- ---------------------------------------------------------------------
-- ValBindsLR type families
@@ -345,8 +345,8 @@ type ConvertIdX a b =
-- ----------------------------------------------------------------------
--- | Provide a summary constraint that gives all extension points a Monoid
--- constraint.
+-- | Provide a summary constraint that gives all a Monoid constraint to
+-- extension points needing one
type MonoidX p =
( Monoid (XBangPat p)
, Monoid (XParPat p)
@@ -354,10 +354,21 @@ type MonoidX p =
, Monoid (XVarPat p)
, Monoid (XLitPat p)
, Monoid (XCoPat p)
+ , Monoid (XNewPat p)
)
-- ----------------------------------------------------------------------
+-- | Provide a summary constraint that gives all am Outputable constraint to
+-- extension points needing one
+type OutputableX p =
+ ( Outputable (XNewPat p)
+ , Outputable (XNewPat GhcRn)
+ )
+-- TODO: Should OutputableX be included in OutputableBndrId?
+
+-- ----------------------------------------------------------------------
+
--
type DataId p =
( Data p
@@ -404,4 +415,5 @@ type DataIdLR pL pR =
type OutputableBndrId id =
( OutputableBndr (NameOrRdrName (IdP id))
, OutputableBndr (IdP id)
+ , OutputableX id
)
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index 75a07e6..129da56 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -282,6 +282,10 @@ data Pat p
-- 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
+ | NewPat
+ (XNewPat p)
deriving instance (DataId p) => Data (Pat p)
-- | The typechecker-specific information for a 'ListPat'
@@ -362,6 +366,10 @@ type instance XSigPat GhcTc = NoFieldExt
type instance XCoPat GhcPs = NoFieldExt
type instance XCoPat GhcRn = NoFieldExt
type instance XCoPat GhcTc = NoFieldExt
+
+type instance XNewPat GhcPs = NoFieldExt
+type instance XNewPat GhcRn = NoFieldExt
+type instance XNewPat GhcTc = NoFieldExt
{-
type instance
XConPat (GhcPass pass) = NoFieldExt
@@ -598,7 +606,7 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
, ppr binds])
<+> pprConArgs details
else pprUserCon (unLoc con) details
-
+pprPat (NewPat x) = ppr x
pprUserCon :: (SourceTextX p, OutputableBndr con, OutputableBndrId p)
=> con -> HsConPatDetails p -> SDoc
@@ -758,6 +766,8 @@ isIrrefutableHsPat pat
-- since we cannot know until the splice is evaluated.
go1 (SplicePat {}) = False
+ go1 (NewPat {}) = False
+
{- Note [Unboxed sum patterns aren't irrefutable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
@@ -801,6 +811,7 @@ hsPatNeedsParens (ListPat {}) = False
hsPatNeedsParens (PArrPat {}) = False
hsPatNeedsParens (LitPat {}) = False
hsPatNeedsParens (NPat {}) = False
+hsPatNeedsParens (NewPat {}) = True -- conservative default
conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon {}) = False
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 56b7d24..ed54759 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -789,7 +789,7 @@ instance (Outputable arg, Outputable rec)
-- parser and rejigs them using information about fixities from the renamer.
-- See Note [Sorting out the result type] in RdrHsSyn
updateGadtResult
- :: (Monad m)
+ :: (Monad m, OutputableX GhcRn)
=> (SDoc -> m ())
-> SDoc
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index b6e29c9..0c298e9 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -981,6 +981,7 @@ collect_lpat (L _ pat) bndrs
= go pat
go (SplicePat _ _) = bndrs
go (CoPat _ _ pat _) = go pat
+ go (NewPat {}) = bndrs
{-
Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index d4bbc12..ea023ff 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -698,6 +698,7 @@ tcPatToExpr name args pat = go pat
go1 p@(AsPat {}) = notInvertible p
go1 p@(ViewPat {}) = notInvertible p
go1 p@(NPlusKPat {}) = notInvertible p
+ go1 p@(NewPat {}) = notInvertible p
go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p
go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p
@@ -824,6 +825,7 @@ tcCheckPatSynPat = go
go1 ConPatOut{} = panic "ConPatOut in output of renamer"
go1 SigPatOut{} = panic "SigPatOut in output of renamer"
go1 CoPat{} = panic "CoPat in output of renamer"
+ go1 NewPat{} = panic "NewPat in output of renamer"
asPatInPatSynErr :: (SourceTextX p, OutputableBndrId p) => Pat p -> TcM a
asPatInPatSynErr pat
More information about the ghc-commits
mailing list