summaryrefslogtreecommitdiff
path: root/compiler/GHC/Hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Hs')
-rw-r--r--compiler/GHC/Hs/Binds.hs7
-rw-r--r--compiler/GHC/Hs/Decls.hs9
-rw-r--r--compiler/GHC/Hs/Pat.hs35
-rw-r--r--compiler/GHC/Hs/Type.hs26
-rw-r--r--compiler/GHC/Hs/Utils.hs10
5 files changed, 52 insertions, 35 deletions
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 41db2d5f85..270dc97364 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -51,6 +51,7 @@ import GHC.Utils.Panic
import Data.Data hiding ( Fixity )
import Data.List hiding ( foldr )
import Data.Function
+import Data.Void
{-
************************************************************************
@@ -766,7 +767,7 @@ instance (OutputableBndrId l, OutputableBndrId r,
ppr_details = case details of
InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
- PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr vs)
+ PrefixCon _ vs -> hsep (pprPrefixOcc psyn : map ppr vs)
RecCon vs -> pprPrefixOcc psyn
<> braces (sep (punctuate comma (map ppr vs)))
@@ -1229,7 +1230,9 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
-}
-- | Haskell Pattern Synonym Details
-type HsPatSynDetails pass = HsConDetails (LIdP pass) [RecordPatSynField (LIdP pass)]
+type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField (LIdP pass)]
+-- The Void argument to HsConDetails here is a reflection of the fact that
+-- type applications are not allowed in declarations of pattern synonyms at present.
-- See Note [Record PatSyn Fields]
-- | Record Pattern Synonym Field
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index dcb810ed7e..882303373f 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -128,6 +128,7 @@ import GHC.Unit.Module.Warnings
import GHC.Data.Bag
import GHC.Data.Maybe
import Data.Data hiding (TyCon,Fixity, Infix)
+import Data.Void
{-
************************************************************************
@@ -1617,7 +1618,9 @@ or contexts in two parts:
-- | The arguments in a Haskell98-style data constructor.
type HsConDeclH98Details pass
- = HsConDetails (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])
+ = HsConDetails Void (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])
+-- The Void argument to HsConDetails here is a reflection of the fact that
+-- type applications are not allowed in data constructor declarations.
-- | The arguments in a GADT constructor. Unlike Haskell98-style constructors,
-- GADT constructors cannot be declared with infix syntax. As a result, we do
@@ -1716,8 +1719,8 @@ pprConDecl (ConDeclH98 { con_name = L _ con
ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1),
pprInfixOcc con,
ppr (hsScaledThing t2)]
- ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con
- : map (pprHsType . unLoc . hsScaledThing) tys)
+ ppr_details (PrefixCon _ tys) = hsep (pprPrefixOcc con
+ : map (pprHsType . unLoc . hsScaledThing) tys)
ppr_details (RecCon fields) = pprPrefixOcc con
<+> pprConDeclFields (unLoc fields)
cxt = fromMaybe noLHsContext mcxt
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 3033806ddd..a1d59699c5 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -317,10 +317,10 @@ type instance ConLikeP GhcTc = ConLike
-- | Haskell Constructor Pattern Details
-type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
+type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p))
hsConPatArgs :: HsConPatDetails p -> [LPat p]
-hsConPatArgs (PrefixCon ps) = ps
+hsConPatArgs (PrefixCon _ ps) = ps
hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs)
hsConPatArgs (InfixCon p1 p2) = [p1,p2]
@@ -580,10 +580,10 @@ pprPat (ConPat { pat_con = con
}
)
= case ghcPass @p of
- GhcPs -> pprUserCon (unLoc con) details
- GhcRn -> pprUserCon (unLoc con) details
+ GhcPs -> regular
+ GhcRn -> regular
GhcTc -> sdocOption sdocPrintTypecheckerElaboration $ \case
- False -> pprUserCon (unLoc con) details
+ False -> regular
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
@@ -595,6 +595,9 @@ pprPat (ConPat { pat_con = con
, cpt_dicts = dicts
, cpt_binds = binds
} = ext
+ where
+ regular :: OutputableBndr (ConLikeP (GhcPass p)) => SDoc
+ regular = pprUserCon (unLoc con) details
pprPat (XPat ext) = case ghcPass @p of
#if __GLASGOW_HASKELL__ < 811
GhcPs -> noExtCon ext
@@ -611,12 +614,14 @@ pprUserCon :: (OutputableBndr con, OutputableBndrId p)
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
+
pprConArgs :: (OutputableBndrId p)
=> HsConPatDetails (GhcPass p) -> SDoc
-pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats)
-pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
- , pprParendLPat appPrec p2 ]
-pprConArgs (RecCon rpats) = ppr rpats
+pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats)
+ where pprTyArgs tyargs = fsep (map (\ty -> char '@' <> ppr ty) tyargs)
+pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
+ , pprParendLPat appPrec p2 ]
+pprConArgs (RecCon rpats) = ppr rpats
instance (Outputable arg)
=> Outputable (HsRecFields p arg) where
@@ -647,7 +652,7 @@ mkPrefixConPat :: DataCon ->
-- Make a vanilla Prefix constructor pattern
mkPrefixConPat dc pats tys
= noLoc $ ConPat { pat_con = noLoc (RealDataCon dc)
- , pat_args = PrefixCon pats
+ , pat_args = PrefixCon [] pats
, pat_con_ext = ConPatTc
{ cpt_tvs = []
, cpt_dicts = []
@@ -837,7 +842,7 @@ patNeedsParens p = go
go :: Pat (GhcPass p) -> Bool
go (NPlusKPat {}) = p > opPrec
go (SplicePat {}) = False
- go (ConPat { pat_args = ds})
+ go (ConPat { pat_args = ds })
= conPatNeedsParens p ds
go (SigPat {}) = p >= sigPrec
go (ViewPat {}) = True
@@ -867,12 +872,12 @@ patNeedsParens p = go
-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@
-- needs parentheses under precedence @p@.
-conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool
+conPatNeedsParens :: PprPrec -> HsConDetails t a b -> Bool
conPatNeedsParens p = go
where
- go (PrefixCon args) = p >= appPrec && not (null args)
- go (InfixCon {}) = p >= opPrec
- go (RecCon {}) = False
+ go (PrefixCon ts args) = p >= appPrec && (not (null args) || not (null ts))
+ go (InfixCon {}) = p >= opPrec -- type args should be empty in this case
+ go (RecCon {}) = False
-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index ad950883f4..dde27857ec 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -46,7 +46,7 @@ module GHC.Hs.Type (
ConDeclField(..), LConDeclField, pprConDeclFields,
- HsConDetails(..),
+ HsConDetails(..), noTypeArgs,
FieldOcc(..), LFieldOcc, mkFieldOcc,
AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,
@@ -107,10 +107,11 @@ import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Utils.Misc ( count )
+import GHC.Parser.Annotation
import Data.Data hiding ( Fixity, Prefix, Infix )
import Data.Maybe
-import GHC.Parser.Annotation
+import Data.Void
{-
************************************************************************
@@ -505,7 +506,7 @@ type instance XHsWC GhcPs b = NoExtField
type instance XHsWC GhcRn b = [Name]
type instance XHsWC GhcTc b = [Name]
-type instance XXHsWildCardBndrs (GhcPass _) b = NoExtCon
+type instance XXHsWildCardBndrs (GhcPass _) _ = NoExtCon
-- | Types that can appear in pattern signatures, as well as the signatures for
-- term-level binders in RULES.
@@ -1333,17 +1334,22 @@ instance OutputableBndrId p
-- a separate data type entirely (see 'HsConDeclGADTDetails' in
-- "GHC.Hs.Decls"). This is because GADT constructors cannot be declared with
-- infix syntax, unlike the concepts above (#18844).
-data HsConDetails arg rec
- = PrefixCon [arg] -- C p1 p2 p3
+data HsConDetails tyarg arg rec
+ = PrefixCon [tyarg] [arg] -- C @t1 @t2 p1 p2 p3
| RecCon rec -- C { x = p1, y = p2 }
| InfixCon arg arg -- p1 `C` p2
deriving Data
-instance (Outputable arg, Outputable rec)
- => Outputable (HsConDetails arg rec) where
- ppr (PrefixCon args) = text "PrefixCon" <+> ppr args
- ppr (RecCon rec) = text "RecCon:" <+> ppr rec
- ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
+-- | An empty list that can be used to indicate that there are no
+-- type arguments allowed in cases where HsConDetails is applied to Void.
+noTypeArgs :: [Void]
+noTypeArgs = []
+
+instance (Outputable tyarg, Outputable arg, Outputable rec)
+ => Outputable (HsConDetails tyarg arg rec) where
+ ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args
+ ppr (RecCon rec) = text "RecCon:" <+> ppr rec
+ ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
{-
Note [ConDeclField passs]
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index e530110cda..0051eaa2c9 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -480,28 +480,28 @@ nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
nlConPat con pats = noLoc $ ConPat
{ pat_con_ext = noExtField
, pat_con = noLoc con
- , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)
+ , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)
}
nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
nlConPatName con pats = noLoc $ ConPat
{ pat_con_ext = noExtField
, pat_con = noLoc con
- , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)
+ , 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 []
+ , pat_args = PrefixCon [] []
}
nlWildConPat :: DataCon -> LPat GhcPs
nlWildConPat con = noLoc $ ConPat
{ pat_con_ext = noExtField
, pat_con = noLoc $ getRdrName con
- , pat_args = PrefixCon $
+ , pat_args = PrefixCon [] $
replicate (dataConSourceArity con)
nlWildPat
}
@@ -1396,7 +1396,7 @@ lPatImplicits = hs_lpat
hs_pat _ = []
details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]
- details _ (PrefixCon ps) = hs_lpats ps
+ details _ (PrefixCon _ ps) = hs_lpats ps
details n (RecCon fs) =
[(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]
++ hs_lpats explicit_pats
View Lorry Controller Status