summaryrefslogtreecommitdiff
path: root/compiler/GHC/Hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Hs')
-rw-r--r--compiler/GHC/Hs/Decls.hs57
-rw-r--r--compiler/GHC/Hs/Instances.hs5
-rw-r--r--compiler/GHC/Hs/Type.hs19
-rw-r--r--compiler/GHC/Hs/Utils.hs23
4 files changed, 68 insertions, 36 deletions
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 51f1e2a127..2024b61b81 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -74,8 +74,8 @@ module GHC.Hs.Decls (
CImportSpec(..),
-- ** Data-constructor declarations
ConDecl(..), LConDecl,
- HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,
- getConNames, getConArgs,
+ HsConDeclH98Details, HsConDeclGADTDetails(..), hsConDeclTheta,
+ getConNames, getRecConArgs_maybe,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
@@ -1476,9 +1476,9 @@ data ConDecl pass
-- Whether or not there is an /explicit/ forall, we still
-- need to capture the implicitly-bound type/kind variables
- , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
- , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon
- , con_res_ty :: LHsType pass -- ^ Result type
+ , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
+ , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix
+ , con_res_ty :: LHsType pass -- ^ Result type
, con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment.
@@ -1495,7 +1495,7 @@ data ConDecl pass
-- False => con_ex_tvs is empty
, con_ex_tvs :: [LHsTyVarBndr Specificity pass] -- ^ Existentials only
, con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
- , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon
+ , con_args :: HsConDeclH98Details pass -- ^ Arguments; can be infix
, con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment.
@@ -1626,27 +1626,35 @@ or contexts in two parts:
quantification occurs after a visible argument type.
-}
--- | Haskell data Constructor Declaration Details
-type HsConDeclDetails pass
+-- | The arguments in a Haskell98-style data constructor.
+type HsConDeclH98Details pass
= HsConDetails (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])
+-- | The arguments in a GADT constructor. Unlike Haskell98-style constructors,
+-- GADT constructors cannot be declared with infix syntax. As a result, we do
+-- not use 'HsConDetails' here, as 'InfixCon' would be an unrepresentable
+-- state. (There is a notion of infix GADT constructors for the purposes of
+-- derived Show instances—see Note [Infix GADT constructors] in
+-- GHC.Tc.TyCl—but that is an orthogonal concern.)
+data HsConDeclGADTDetails pass
+ = PrefixConGADT [HsScaled pass (LBangType pass)]
+ | RecConGADT (XRec pass [LConDeclField pass])
+
getConNames :: ConDecl GhcRn -> [Located Name]
getConNames ConDeclH98 {con_name = name} = [name]
getConNames ConDeclGADT {con_names = names} = names
-getConArgs :: ConDecl GhcRn -> HsConDeclDetails GhcRn
-getConArgs d = con_args d
-
-hsConDeclArgTys :: HsConDeclDetails (GhcPass p) -> [HsScaled (GhcPass p) (LBangType (GhcPass p))]
-hsConDeclArgTys (PrefixCon tys) = tys
-hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
-hsConDeclArgTys (RecCon flds) = map (hsLinear . cd_fld_type . unLoc) (unLoc flds)
- -- Remark: with the record syntax, constructors have all their argument
- -- linear, despite the fact that projections do not make sense on linear
- -- constructors. The design here is that the record projection themselves are
- -- typed to take an unrestricted argument (that is the record itself is
- -- unrestricted). By the transfer property, projections are then correct in
- -- that all the non-projected fields have multiplicity Many, and can be dropped.
+-- | Return @'Just' fields@ if a data constructor declaration uses record
+-- syntax (i.e., 'RecCon'), where @fields@ are the field selectors.
+-- Otherwise, return 'Nothing'.
+getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (Located [LConDeclField GhcRn])
+getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of
+ PrefixCon{} -> Nothing
+ RecCon flds -> Just flds
+ InfixCon{} -> Nothing
+getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of
+ PrefixConGADT{} -> Nothing
+ RecConGADT flds -> Just flds
hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)]
hsConDeclTheta Nothing = []
@@ -1726,15 +1734,14 @@ pprConDecl (ConDeclH98 { con_name = L _ con
cxt = fromMaybe noLHsContext mcxt
pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
- , con_mb_cxt = mcxt, con_args = args
+ , con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty, con_doc = doc })
= ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
<+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) cxt,
ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
where
- get_args (PrefixCon args) = map ppr args
- get_args (RecCon fields) = [pprConDeclFields (unLoc fields)]
- get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons)
+ get_args (PrefixConGADT args) = map ppr args
+ get_args (RecConGADT fields) = [pprConDeclFields (unLoc fields)]
cxt = fromMaybe noLHsContext mcxt
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index e1f3d29f21..76ce16948b 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -173,6 +173,11 @@ deriving instance Data (ConDecl GhcPs)
deriving instance Data (ConDecl GhcRn)
deriving instance Data (ConDecl GhcTc)
+-- deriving instance DataIdLR p p => Data (HsConDeclGADTDetails p)
+deriving instance Data (HsConDeclGADTDetails GhcPs)
+deriving instance Data (HsConDeclGADTDetails GhcRn)
+deriving instance Data (HsConDeclGADTDetails GhcTc)
+
-- deriving instance DataIdLR p p => Data (TyFamInstDecl p)
deriving instance Data (TyFamInstDecl GhcPs)
deriving instance Data (TyFamInstDecl GhcRn)
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index ed3b20a0ec..db6508d581 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -1102,9 +1102,22 @@ instance OutputableBndrId p
=> Outputable (ConDeclField (GhcPass p)) where
ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
--- HsConDetails is used for patterns/expressions *and* for data type
--- declarations
--- | Haskell Constructor Details
+-- | Describes the arguments to a data constructor. This is a common
+-- representation for several constructor-related concepts, including:
+--
+-- * The arguments in a Haskell98-style constructor declaration
+-- (see 'HsConDeclH98Details' in "GHC.Hs.Decls").
+--
+-- * The arguments in constructor patterns in @case@/function definitions
+-- (see 'HsConPatDetails' in "GHC.Hs.Pat").
+--
+-- * The left-hand side arguments in a pattern synonym binding
+-- (see 'HsPatSynDetails' in "GHC.Hs.Binds").
+--
+-- One notable exception is the arguments in a GADT constructor, which uses
+-- 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
| RecCon rec -- C { x = p1, y = p2 }
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 8252d91249..da55ebf89e 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1259,29 +1259,36 @@ hsConDeclsBinders cons
in case unLoc r of
-- remove only the first occurrence of any seen field in order to
-- avoid circumventing detection of duplicate fields (#9156)
- ConDeclGADT { con_names = names, con_args = args }
+ ConDeclGADT { con_names = names, con_g_args = args }
-> (map (L loc . unLoc) names ++ ns, flds ++ fs)
where
- (remSeen', flds) = get_flds remSeen args
+ (remSeen', flds) = get_flds_gadt remSeen args
(ns, fs) = go remSeen' rs
ConDeclH98 { con_name = name, con_args = args }
-> ([L loc (unLoc name)] ++ ns, flds ++ fs)
where
- (remSeen', flds) = get_flds remSeen args
+ (remSeen', flds) = get_flds_h98 remSeen args
(ns, fs) = go remSeen' rs
- get_flds :: Seen p -> HsConDeclDetails (GhcPass p)
+ get_flds_h98 :: Seen p -> HsConDeclH98Details (GhcPass p)
+ -> (Seen p, [LFieldOcc (GhcPass p)])
+ get_flds_h98 remSeen (RecCon flds) = get_flds remSeen flds
+ get_flds_h98 remSeen _ = (remSeen, [])
+
+ get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p)
+ -> (Seen p, [LFieldOcc (GhcPass p)])
+ get_flds_gadt remSeen (RecConGADT flds) = get_flds remSeen flds
+ get_flds_gadt remSeen _ = (remSeen, [])
+
+ get_flds :: Seen p -> Located [LConDeclField (GhcPass p)]
-> (Seen p, [LFieldOcc (GhcPass p)])
- get_flds remSeen (RecCon flds)
- = (remSeen', fld_names)
+ get_flds remSeen flds = (remSeen', fld_names)
where
fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))
remSeen' = foldr (.) remSeen
[deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v
| v <- fld_names]
- get_flds remSeen _
- = (remSeen, [])
{-
View Lorry Controller Status