diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index ea8b32e188567044772d3dfefedf698995fac77f..74f17d1b782dfb73314df265e97bf0483f863dfe 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -714,7 +714,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri
(mkDataConWorkId wrk_name data_con)
NoDataConRep -- Wired-in types are too simple to need wrappers
- no_bang = mkHsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
+ no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
wrk_name = mkDataConWorkerName data_con wrk_key
diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs
index 074017a24453f4a060c1c3f9bec64ac85dcd37cb..914f47ff075a5c7e9f47c4a83ba502d0c892cb6f 100644
--- a/compiler/GHC/Core/DataCon.hs
+++ b/compiler/GHC/Core/DataCon.hs
@@ -12,7 +12,7 @@ module GHC.Core.DataCon (
-- * Main data types
DataCon, DataConRep(..),
SrcStrictness(..), SrcUnpackedness(..),
- HsSrcBang(..), HsBang(..), HsImplBang(..),
+ HsSrcBang(..), HsImplBang(..),
StrictnessMark(..),
ConTag,
DataConEnv,
@@ -25,7 +25,7 @@ module GHC.Core.DataCon (
FieldLabel(..), flLabel, FieldLabelString,
-- ** Type construction
- mkHsSrcBang, mkDataCon, fIRST_TAG,
+ mkDataCon, fIRST_TAG,
-- ** Type deconstruction
dataConRepType, dataConInstSig, dataConFullSig,
@@ -847,14 +847,16 @@ type DataConEnv a = UniqFM DataCon a -- Keyed by DataCon
-- Bangs on data constructor arguments as written by the user, including the
-- source code for exact-printing.
--
--- In the AST, the SourceText is deconstructed and hidden inside
--- 'Language.Haskell.Syntax.Extension.XBangTy' extension point.
+-- @(HsSrcBang _ SrcUnpack SrcLazy)@ and
+-- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we
+-- emit a warning (in checkValidDataCon) and treat it like
+-- @(HsSrcBang _ NoSrcUnpack SrcLazy)@
+--
+-- In the AST, the @SourceText@ is hidden inside the extension point
+-- 'Language.Haskell.Syntax.Extension.XConDeclField'.
data HsSrcBang
- = HsSrcBang SourceText HsBang -- See Note [Pragma source text] in "GHC.Types.SourceText"
-
--- | Make a 'HsSrcBang' from all parts
-mkHsSrcBang :: SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
-mkHsSrcBang stext u s = HsSrcBang stext (HsBang u s)
+ = HsSrcBang SourceText SrcUnpackedness SrcStrictness -- See Note [Pragma source text] in "GHC.Types.SourceText"
+ deriving Data.Data
-- | Haskell Implementation Bang
--
@@ -1020,10 +1022,7 @@ instance Data.Data DataCon where
dataTypeOf _ = mkNoRepType "DataCon"
instance Outputable HsSrcBang where
- ppr (HsSrcBang _source_text bang) = ppr bang
-
-instance Outputable HsBang where
- ppr (HsBang prag mark) = ppr prag <+> ppr mark
+ ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark
instance Outputable HsImplBang where
ppr HsLazy = text "Lazy"
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index 8aecc1a78592d748e935401048a11a8e25c3e11f..e8f22eb482ffb04dd65e6a1597fceb2a0f60d34c 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -1282,7 +1282,7 @@ Two wrinkles:
f (\(MkT @b (d::Num b) (x::b)) -> h @b d x) = ...
where the HOP is (h @b d x). In principle this might be possible, but
it seems fragile; e.g. we would still need to insist that the (invisible)
- @b was a type variable. And since `h` gets a polymoprhic type, that
+ @b was a type variable. And since `h` gets a polymorphic type, that
type would have to be declared by the programmer.
Maybe one day. But for now, we insist (in `arg_as_lcl_var`)that a HOP
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index f6d0bad23d81876c74de7178f3e882a5485daed7..cf5e136488dcf169e100f26a79e2f2bb9f076ce6 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -435,7 +435,7 @@ toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env c
toIfaceBang _ (HsStrict _) = IfStrict
toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
-toIfaceSrcBang (HsSrcBang _ (HsBang unpk bang)) = IfSrcBang unpk bang
+toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang
toIfaceLetBndr :: Id -> IfaceLetBndr
toIfaceLetBndr id = IfLetBndr (mkIfLclName (occNameFS (getOccName id)))
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 71f22be4d1d183ad5ce9e950a5b68f0351248c9c..cbe5f5b1a6efaa0d2090a06dcf05c6d58790b4cc 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -140,20 +140,6 @@ type instance XPSB (GhcPass idL) GhcTc = NameSet
type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = DataConCantHappen
-type instance XNoMultAnn GhcPs = NoExtField
-type instance XNoMultAnn GhcRn = NoExtField
-type instance XNoMultAnn GhcTc = Mult
-
-type instance XPct1Ann GhcPs = EpToken "%1"
-type instance XPct1Ann GhcRn = NoExtField
-type instance XPct1Ann GhcTc = Mult
-
-type instance XMultAnn GhcPs = EpToken "%"
-type instance XMultAnn GhcRn = NoExtField
-type instance XMultAnn GhcTc = Mult
-
-type instance XXMultAnn (GhcPass _) = DataConCantHappen
-
data AnnPSB
= AnnPSB {
ap_pattern :: EpToken "pattern",
@@ -167,14 +153,14 @@ instance NoAnn AnnPSB where
noAnn = AnnPSB noAnn noAnn noAnn noAnn noAnn
setTcMultAnn :: Mult -> HsMultAnn GhcRn -> HsMultAnn GhcTc
-setTcMultAnn mult (HsPct1Ann _) = HsPct1Ann mult
-setTcMultAnn mult (HsMultAnn _ p) = HsMultAnn mult p
-setTcMultAnn mult (HsNoMultAnn _) = HsNoMultAnn mult
+setTcMultAnn mult (HsLinearAnn _) = HsLinearAnn mult
+setTcMultAnn mult (HsExplicitMult _ p) = HsExplicitMult mult p
+setTcMultAnn mult (HsUnannotated _) = HsUnannotated mult
getTcMultAnn :: HsMultAnn GhcTc -> Mult
-getTcMultAnn (HsPct1Ann mult) = mult
-getTcMultAnn (HsMultAnn mult _) = mult
-getTcMultAnn (HsNoMultAnn mult) = mult
+getTcMultAnn (HsLinearAnn mult) = mult
+getTcMultAnn (HsExplicitMult mult _) = mult
+getTcMultAnn (HsUnannotated mult) = mult
-- ---------------------------------------------------------------------
@@ -546,13 +532,6 @@ plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))
plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds"
--- Used to print, for instance, let bindings:
--- let %1 x = …
-pprHsMultAnn :: forall id. OutputableBndrId id => HsMultAnn (GhcPass id) -> SDoc
-pprHsMultAnn (HsNoMultAnn _) = empty
-pprHsMultAnn (HsPct1Ann _) = text "%1"
-pprHsMultAnn (HsMultAnn _ p) = text "%" <> ppr p
-
instance (OutputableBndrId pl, OutputableBndrId pr)
=> Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where
ppr mbind = ppr_monobind mbind
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 76dcc9416426078641d528ccff2b5b62ed7e9096..fd56f9fff5d24fe6081904cb2c186285cfdd07fd 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -805,7 +805,7 @@ getConNames ConDeclGADT {con_names = names} = toList names
-- | 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 (LocatedL [LConDeclField GhcRn])
+getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (LocatedL [LHsConDeclRecField GhcRn])
getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of
PrefixCon{} -> Nothing
RecCon flds -> Just flds
@@ -886,13 +886,13 @@ pprConDecl (ConDeclH98 { con_name = L _ con
where
-- In ppr_details: let's not print the multiplicities (they are always 1, by
-- definition) as they do not appear in an actual declaration.
- ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1),
+ ppr_details (InfixCon t1 t2) = hsep [pprHsConDeclFieldNoMult t1,
pprInfixOcc con,
- ppr (hsScaledThing t2)]
+ pprHsConDeclFieldNoMult t2]
ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con
- : map (pprHsType . unLoc . hsScaledThing) tys)
+ : map pprHsConDeclFieldNoMult tys)
ppr_details (RecCon fields) = pprPrefixOcc con
- <+> pprConDeclFields (unLoc fields)
+ <+> pprHsConDeclRecFields (unLoc fields)
pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs
, con_mb_cxt = mcxt, con_g_args = args
@@ -901,12 +901,12 @@ pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs
<+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt,
sep (ppr_args args ++ [ppr res_ty]) ])
where
- ppr_args (PrefixConGADT _ args) = map (\(HsScaled arr t) -> ppr t <+> ppr_arr arr) args
- ppr_args (RecConGADT _ fields) = [pprConDeclFields (unLoc fields) <+> arrow]
+ ppr_args (PrefixConGADT _ args) = map (pprHsConDeclFieldWith (\arr tyDoc -> tyDoc <+> ppr_arr arr)) args
+ ppr_args (RecConGADT _ fields) = [pprHsConDeclRecFields (unLoc fields) <+> arrow]
-- Display linear arrows as unrestricted with -XNoLinearTypes
-- (cf. dataConDisplayType in Note [Displaying linear fields] in GHC.Core.DataCon)
- ppr_arr (HsLinearArrow _) = sdocOption sdocLinearTypes $ \show_linear_types ->
+ ppr_arr (HsLinearAnn _) = sdocOption sdocLinearTypes $ \show_linear_types ->
if show_linear_types then lollipop else arrow
ppr_arr arr = pprHsArrow arr
@@ -1479,7 +1479,7 @@ type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC
type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA
type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno Bool = EpAnnCO
-type instance Anno [LocatedA (ConDeclField (GhcPass _))] = SrcSpanAnnL
+type instance Anno [LocatedA (HsConDeclRecField (GhcPass _))] = SrcSpanAnnL
type instance Anno (FamEqn p (LocatedA (HsType p))) = SrcSpanAnnA
type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (DataFamInstDecl (GhcPass p)) = SrcSpanAnnA
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 4907be8c1903997814e41fba498ff5f6d3790e16..09dd9af2fceabb135b919f60e9b5bd8d953fce71 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -414,8 +414,8 @@ type instance XFunRhs = AnnFunRhs
type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnLW
type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA
-arrowToHsExpr :: HsArrowOf (LocatedA (HsExpr GhcRn)) GhcRn -> LocatedA (HsExpr GhcRn)
-arrowToHsExpr = expandHsArrow (HsVar noExtField)
+multAnnToHsExpr :: HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn -> Maybe (LocatedA (HsExpr GhcRn))
+multAnnToHsExpr = expandHsMultAnnOf (HsVar noExtField)
data AnnExplicitSum
= AnnExplicitSum {
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index a77cc738740e3694300b31687bf7fe1609057da2..71628262464739bf5c8a560766cb387a52741584 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -110,9 +110,6 @@ deriving instance Data (HsPatSynDir GhcPs)
deriving instance Data (HsPatSynDir GhcRn)
deriving instance Data (HsPatSynDir GhcTc)
-deriving instance Data (HsMultAnn GhcPs)
-deriving instance Data (HsMultAnn GhcRn)
-deriving instance Data (HsMultAnn GhcTc)
-- ---------------------------------------------------------------------
-- Data derivations from GHC.Hs.Decls ----------------------------------
@@ -532,33 +529,35 @@ deriving instance Data (HsType GhcPs)
deriving instance Data (HsType GhcRn)
deriving instance Data (HsType GhcTc)
+deriving instance Data HsTypeGhcPsExt
+
-- deriving instance (DataIdLR p p) => Data (HsTyLit p)
deriving instance Data (HsTyLit GhcPs)
deriving instance Data (HsTyLit GhcRn)
deriving instance Data (HsTyLit GhcTc)
--- deriving instance (Data mult, DataIdLR p p) => Data (HsArrowOf mult p)
-deriving instance Data (HsArrowOf (LocatedA (HsType GhcPs)) GhcPs)
-deriving instance Data (HsArrowOf (LocatedA (HsType GhcRn)) GhcRn)
-deriving instance Data (HsArrowOf (LocatedA (HsType GhcTc)) GhcTc)
-deriving instance Data (HsArrowOf (LocatedA (HsExpr GhcPs)) GhcPs)
-deriving instance Data (HsArrowOf (LocatedA (HsExpr GhcRn)) GhcRn)
-deriving instance Data (HsArrowOf (LocatedA (HsExpr GhcTc)) GhcTc)
-
--- deriving instance (DataIdLR p p) => Data (HsScaled p a)
-deriving instance Data thing => Data (HsScaled GhcPs thing)
-deriving instance Data thing => Data (HsScaled GhcRn thing)
-deriving instance Data thing => Data (HsScaled GhcTc thing)
+-- deriving instance (Data mult, DataIdLR p p) => Data (HsMultAnnOf mult p)
+deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcPs)) GhcPs)
+deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcRn)) GhcRn)
+deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcRn)) GhcTc)
+deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcPs)) GhcPs)
+deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn)
+deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcTc)) GhcTc)
-- deriving instance (Data a, Data b) => Data (HsArg p a b)
deriving instance (Data a, Data b) => Data (HsArg GhcPs a b)
deriving instance (Data a, Data b) => Data (HsArg GhcRn a b)
deriving instance (Data a, Data b) => Data (HsArg GhcTc a b)
--- deriving instance (DataIdLR p p) => Data (ConDeclField p)
-deriving instance Data (ConDeclField GhcPs)
-deriving instance Data (ConDeclField GhcRn)
-deriving instance Data (ConDeclField GhcTc)
+-- deriving instance (DataIdLR p p) => Data (HsConDeclRecField p)
+deriving instance Data (HsConDeclRecField GhcPs)
+deriving instance Data (HsConDeclRecField GhcRn)
+deriving instance Data (HsConDeclRecField GhcTc)
+
+-- deriving instance (DataIdLR p p, Typeable on) => Data (HsConDeclField on p)
+deriving instance Data (HsConDeclField GhcPs)
+deriving instance Data (HsConDeclField GhcRn)
+deriving instance Data (HsConDeclField GhcTc)
-- deriving instance (DataId p) => Data (FieldOcc p)
deriving instance Data (FieldOcc GhcPs)
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index bd3e3511633fc1eafde6913965bf98686b96a1ad..8b9f78a07ffd3e330d7e6fb32c907d580dde32a9 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -23,14 +23,14 @@ GHC.Hs.Type: Abstract syntax: user-defined types
-}
module GHC.Hs.Type (
- Mult, HsScaled(..),
- hsMult, hsScaledThing,
- HsArrow, HsArrowOf(..), arrowToHsType, expandHsArrow,
- EpLinearArrow(..),
- hsLinear, hsUnrestricted, isUnrestricted,
- pprHsArrow,
+ Mult,
+ HsMultAnn, HsMultAnnOf(..),
+ multAnnToHsType, expandHsMultAnnOf,
+ EpLinear(..), EpArrowOrColon(..),
+ pprHsArrow, pprHsMultAnn,
HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,
+ HsTypeGhcPsExt(..),
HsForAllTelescope(..), EpAnnForallVis, EpAnnForallInvis,
HsTyVarBndr(..), LHsTyVarBndr, AnnTyVarBndr(..),
HsBndrKind(..),
@@ -51,14 +51,14 @@ module GHC.Hs.Type (
LHsTypeArg, lhsTypeArgSrcSpan,
OutputableBndrFlag,
- LBangType, BangType,
HsSrcBang(..), HsImplBang(..),
SrcStrictness(..), SrcUnpackedness(..),
- getBangType, getBangStrictness,
- ConDeclField(..), LConDeclField, pprConDeclFields,
+ HsConDeclRecField(..), LHsConDeclRecField, pprHsConDeclRecFields,
HsConDetails(..),
+ HsConDeclField(..), pprHsConDeclFieldWith, pprHsConDeclFieldNoMult,
+ hsPlainTypeField, mkConDeclField,
FieldOcc(..), LFieldOcc, mkFieldOcc,
fieldOccRdrName, fieldOccLRdrName,
@@ -105,7 +105,6 @@ import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..)
import Language.Haskell.Syntax.Extension
import GHC.Core.DataCon ( SrcStrictness(..), SrcUnpackedness(..)
, HsSrcBang(..), HsImplBang(..)
- , mkHsSrcBang
)
import GHC.Hs.Extension
import GHC.Parser.Annotation
@@ -117,7 +116,7 @@ import GHC.Types.Name.Reader ( RdrName )
import GHC.Types.Var ( VarBndr, visArgTypeLike )
import GHC.Core.TyCo.Rep ( Type(..) )
import GHC.Builtin.Names ( negateName )
-import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )
+import GHC.Builtin.Types( oneDataConName, mkTupleStr )
import GHC.Core.Ppr ( pprOccWithTick)
import GHC.Core.Type
import GHC.Core.Multiplicity( pprArrowWithMultiplicity )
@@ -133,25 +132,6 @@ import Data.Data (Data)
import qualified Data.Semigroup as S
import GHC.Data.Bag
-{-
-************************************************************************
-* *
-\subsection{Bang annotations}
-* *
-************************************************************************
--}
-
-getBangType :: LHsType (GhcPass p) -> LHsType (GhcPass p)
-getBangType (L _ (HsBangTy _ _ lty)) = lty
-getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =
- addCLocA lty lds (HsDocTy x lty lds)
-getBangType lty = lty
-
-getBangStrictness :: LHsType (GhcPass p) -> HsSrcBang
-getBangStrictness (L _ (HsBangTy (_, s) b _)) = HsSrcBang s b
-getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy (_, s) b _)) _)) = HsSrcBang s b
-getBangStrictness _ = (mkHsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
-
{-
************************************************************************
* *
@@ -479,11 +459,8 @@ type instance XSpliceTy GhcRn = HsUntypedSpliceResult (LHsType GhcRn)
type instance XSpliceTy GhcTc = Kind
type instance XDocTy (GhcPass _) = NoExtField
-type instance XBangTy (GhcPass _) = ((EpaLocation, EpToken "#-}", EpaLocation), SourceText)
-
-type instance XRecTy GhcPs = AnnList ()
-type instance XRecTy GhcRn = NoExtField
-type instance XRecTy GhcTc = NoExtField
+type instance XConDeclField (GhcPass _) = ((EpaLocation, EpToken "#-}", EpaLocation), SourceText)
+type instance XXConDeclRecField (GhcPass _) = DataConCantHappen
type instance XExplicitListTy GhcPs = (EpToken "'", EpToken "[", EpToken "]")
type instance XExplicitListTy GhcRn = NoExtField
@@ -499,91 +476,122 @@ type instance XWildCardTy GhcPs = EpToken "_"
type instance XWildCardTy GhcRn = NoExtField
type instance XWildCardTy GhcTc = NoExtField
-type instance XXType (GhcPass _) = HsCoreTy
-
--- An escape hatch for tunnelling a Core 'Type' through 'HsType'.
--- For more details on how this works, see:
---
--- * @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType"
---
--- * @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType"
-type HsCoreTy = Type
+type instance XXType GhcPs = HsTypeGhcPsExt
+type instance XXType GhcRn = HsCoreTy
+type instance XXType GhcTc = DataConCantHappen
type instance XNumTy (GhcPass _) = SourceText
type instance XStrTy (GhcPass _) = SourceText
type instance XCharTy (GhcPass _) = SourceText
type instance XXTyLit (GhcPass _) = DataConCantHappen
-data EpLinearArrow
- = EpPct1 !(EpToken "%1") !(TokRarrow)
+type HsCoreTy = Type
+
+-- Extension of HsType during parsing.
+-- see Note [Trees That Grow] in Language.Haskell.Syntax.Extension
+data HsTypeGhcPsExt
+ = HsCoreTy HsCoreTy
+ -- An escape hatch for tunnelling a Core 'Type' through 'HsType'.
+ -- For more details on how this works, see:
+ --
+ -- @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType"
+ --
+ -- @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType"
+
+ | HsBangTy (EpaLocation, EpToken "#-}", EpaLocation)
+ HsSrcBang
+ (LHsType GhcPs)
+ -- See Note [Parsing data type declarations]
+
+ | HsRecTy (AnnList ())
+ [LHsConDeclRecField GhcPs]
+ -- See Note [Parsing data type declarations]
+
+{- Note [Parsing data type declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When parsing it is not always clear if we're parsing a constructor field type
+or not. So during parsing we extend the type syntax to support bang annotations
+and record braces. We do this through the extension constructor of (HsType GhcPs),
+namely `HsTypeGhcPsExt`, adding data constructors for `HsBangTy` and `HsRecTy`.
+Once parsing is done (i.e. (HsType GhcRn) and (HsType GhcTc)) these constructors
+are not needed; instead the data is stored in `HsConDeclField`. It is an error
+if it turns out the extensions were used outside of a constructor field type.
+-}
+
+data EpArrowOrColon
+ = EpArrow !TokRarrow
+ | EpColon !TokDcolon
+ | EpPatBind
+ deriving Data
+
+data EpLinear
+ = EpPct1 !(EpToken "%1") !EpArrowOrColon
| EpLolly !(EpToken "⊸")
deriving Data
-instance NoAnn EpLinearArrow where
- noAnn = EpPct1 noAnn noAnn
+instance NoAnn EpLinear where
+ noAnn = EpPct1 noAnn (EpArrow noAnn)
-type instance XUnrestrictedArrow _ GhcPs = TokRarrow
-type instance XUnrestrictedArrow _ GhcRn = NoExtField
-type instance XUnrestrictedArrow _ GhcTc = NoExtField
+type instance XUnannotated _ GhcPs = EpArrowOrColon
+type instance XUnannotated _ GhcRn = NoExtField
+type instance XUnannotated _ GhcTc = Mult
-type instance XLinearArrow _ GhcPs = EpLinearArrow
-type instance XLinearArrow _ GhcRn = NoExtField
-type instance XLinearArrow _ GhcTc = NoExtField
+type instance XLinearAnn _ GhcPs = EpLinear
+type instance XLinearAnn _ GhcRn = NoExtField
+type instance XLinearAnn _ GhcTc = Mult
-type instance XExplicitMult _ GhcPs = (EpToken "%", TokRarrow)
-type instance XExplicitMult _ GhcRn = NoExtField
-type instance XExplicitMult _ GhcTc = NoExtField
+type instance XExplicitMult _ GhcPs = (EpToken "%", EpArrowOrColon)
+type instance XExplicitMult _ GhcRn = NoExtField
+type instance XExplicitMult _ GhcTc = Mult
-type instance XXArrow _ (GhcPass _) = DataConCantHappen
+type instance XXMultAnnOf _ (GhcPass _) = DataConCantHappen
-hsLinear :: forall p a. IsPass p => a -> HsScaled (GhcPass p) a
-hsLinear = HsScaled (HsLinearArrow x)
- where
- x = case ghcPass @p of
- GhcPs -> noAnn
- GhcRn -> noExtField
- GhcTc -> noExtField
+multAnnToHsType :: HsMultAnn GhcRn -> Maybe (LHsType GhcRn)
+multAnnToHsType = expandHsMultAnnOf (HsTyVar noAnn NotPromoted)
-hsUnrestricted :: forall p a. IsPass p => a -> HsScaled (GhcPass p) a
-hsUnrestricted = HsScaled (HsUnrestrictedArrow x)
- where
- x = case ghcPass @p of
- GhcPs -> noAnn
- GhcRn -> noExtField
- GhcTc -> noExtField
-
-isUnrestricted :: HsArrow GhcRn -> Bool
-isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName
-isUnrestricted _ = False
-
-arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn
-arrowToHsType = expandHsArrow (HsTyVar noAnn NotPromoted)
-
--- | Convert an arrow into its corresponding multiplicity. In essence this
--- erases the information of whether the programmer wrote an explicit
--- multiplicity or a shorthand.
-expandHsArrow :: (LocatedN Name -> t GhcRn) -> HsArrowOf (LocatedA (t GhcRn)) GhcRn -> LocatedA (t GhcRn)
-expandHsArrow mk_var (HsUnrestrictedArrow _) = noLocA (mk_var (noLocA manyDataConName))
-expandHsArrow mk_var (HsLinearArrow _) = noLocA (mk_var (noLocA oneDataConName))
-expandHsArrow _mk_var (HsExplicitMult _ p) = p
+-- | Convert an multiplicity annotation into its corresponding multiplicity.
+-- If no annotation was written, `Nothing` is returned.
+-- In this polymorphic function, `t` can be `HsType` or `HsExpr`
+expandHsMultAnnOf :: (LocatedN Name -> t GhcRn)
+ -> HsMultAnnOf (LocatedA (t GhcRn)) GhcRn
+ -> Maybe (LocatedA (t GhcRn))
+expandHsMultAnnOf _mk_var HsUnannotated{} = Nothing
+expandHsMultAnnOf mk_var (HsLinearAnn _) = Just (noLocA (mk_var (noLocA oneDataConName)))
+expandHsMultAnnOf _mk_var (HsExplicitMult _ p) = Just p
instance
(Outputable mult, OutputableBndrId pass) =>
- Outputable (HsArrowOf mult (GhcPass pass)) where
+ Outputable (HsMultAnnOf mult (GhcPass pass)) where
ppr arr = parens (pprHsArrow arr)
-- See #18846
-pprHsArrow :: (Outputable mult, OutputableBndrId pass) => HsArrowOf mult (GhcPass pass) -> SDoc
-pprHsArrow (HsUnrestrictedArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left False)
-pprHsArrow (HsLinearArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left True)
-pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p))
-
-type instance XConDeclField (GhcPass _) = TokDcolon
-type instance XXConDeclField (GhcPass _) = DataConCantHappen
+pprHsArrow :: (Outputable mult, OutputableBndrId pass) => HsMultAnnOf mult (GhcPass pass) -> SDoc
+pprHsArrow (HsUnannotated _) = pprArrowWithMultiplicity visArgTypeLike (Left False)
+pprHsArrow (HsLinearAnn _) = pprArrowWithMultiplicity visArgTypeLike (Left True)
+pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p))
+
+-- Used to print, for instance, let bindings:
+-- let %1 x = …
+-- and record field declarations:
+-- { x %1 :: … }
+pprHsMultAnn :: forall id. OutputableBndrId id => HsMultAnn (GhcPass id) -> SDoc
+pprHsMultAnn (HsUnannotated _) = empty
+pprHsMultAnn (HsLinearAnn _) = text "%1"
+pprHsMultAnn (HsExplicitMult _ p) = text "%" <> ppr p
+
+type instance XConDeclRecField (GhcPass _) = NoExtField
+type instance XXConDeclRecField (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
- => Outputable (ConDeclField (GhcPass p)) where
- ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
+ => Outputable (HsConDeclRecField (GhcPass p)) where
+ ppr (HsConDeclRecField _ fld_n cfs) = pprMaybeWithDoc (cdf_doc cfs) (ppr_names fld_n <+> pprHsConDeclFieldWith ppr_mult cfs { cdf_doc = Nothing })
+ where
+ ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc
+ ppr_names [n] = pprPrefixOcc n
+ ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))
+
+ ppr_mult :: HsMultAnn (GhcPass p) -> SDoc -> SDoc
+ ppr_mult mult tyDoc = pprHsMultAnn mult <+> dcolon <+> tyDoc
---------------------
hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]
@@ -715,10 +723,10 @@ mkHsAppKindTy at ty k = addCLocA ty k (HsAppKindTy at ty k)
-- splitHsFunType (a -> (b -> c)) = ([a,b], c)
-- It returns API Annotations for any parens removed
splitHsFunType ::
- LHsType (GhcPass p)
+ LHsType GhcPs
-> ( ([EpToken "("], [EpToken ")"]) , EpAnnComments -- The locations of any parens and
-- comments discarded
- , [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))
+ , [HsConDeclField GhcPs], LHsType GhcPs)
splitHsFunType ty = go ty
where
go (L l (HsParTy (op,cp) ty))
@@ -729,7 +737,7 @@ splitHsFunType ty = go ty
go (L ll (HsFunTy _ mult x y))
| (anns, csy, args, res) <- splitHsFunType y
- = (anns, csy S.<> epAnnComments ll, HsScaled mult x:args, res)
+ = (anns, csy S.<> epAnnComments ll, mkConDeclField mult x:args, res)
go other = (noAnn, emptyComments, [], other)
@@ -1289,6 +1297,23 @@ instance (Outputable arg, Outputable rec)
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
+pprHsConDeclFieldWith :: (OutputableBndrId p)
+ => (HsMultAnn (GhcPass p) -> SDoc -> SDoc)
+ -> HsConDeclField (GhcPass p) -> SDoc
+pprHsConDeclFieldWith ppr_mult (CDF _ prag mark mult ty doc) =
+ pprMaybeWithDoc doc (ppr_mult mult (ppr prag <+> ppr mark <> ppr ty))
+
+pprHsConDeclFieldNoMult :: (OutputableBndrId p) => HsConDeclField (GhcPass p) -> SDoc
+pprHsConDeclFieldNoMult = pprHsConDeclFieldWith (\_ d -> d)
+
+hsPlainTypeField :: LHsType GhcPs -> HsConDeclField GhcPs
+hsPlainTypeField = mkConDeclField (HsUnannotated (EpColon noAnn))
+
+mkConDeclField :: HsMultAnn GhcPs -> LHsType GhcPs -> HsConDeclField GhcPs
+mkConDeclField mult (L _ (HsDocTy _ ty lds)) = (mkConDeclField mult ty) { cdf_doc = Just lds }
+mkConDeclField mult (L _ (XHsType (HsBangTy ann (HsSrcBang srcTxt unp str) t))) = CDF (ann, srcTxt) unp str mult t Nothing
+mkConDeclField mult t = CDF noAnn NoSrcUnpack NoSrcStrict mult t Nothing
+
instance Outputable (XRecGhc (IdGhcP p)) =>
Outputable (FieldOcc (GhcPass p)) where
ppr = ppr . foLabel
@@ -1361,17 +1386,9 @@ pprLHsContextAlways (L _ ctxt)
[L _ ty] -> ppr_mono_ty ty <+> darrow
_ -> parens (interpp'SP ctxt) <+> darrow
-pprConDeclFields :: forall p. OutputableBndrId p
- => [LConDeclField (GhcPass p)] -> SDoc
-pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
- where
- ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
- cd_fld_doc = doc }))
- = pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty)
-
- ppr_names :: forall p. OutputableBndrId p => [LFieldOcc (GhcPass p)] -> SDoc
- ppr_names [n] = pprPrefixOcc n
- ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))
+pprHsConDeclRecFields :: forall p. OutputableBndrId p
+ => [LHsConDeclRecField (GhcPass p)] -> SDoc
+pprHsConDeclRecFields fields = braces (sep (punctuate comma (map ppr fields)))
-- Printing works more-or-less as for Types
@@ -1389,8 +1406,6 @@ ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty })
ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })
= sep [pprLHsContextAlways ctxt, ppr_mono_lty ty]
-ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty
-ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds
ppr_mono_ty (HsTyVar _ prom (L _ name)) = pprOccWithTick Prefix prom name
ppr_mono_ty (HsFunTy _ mult ty1 ty2) = ppr_fun_ty mult ty1 ty2
ppr_mono_ty (HsTupleTy _ con tys)
@@ -1447,11 +1462,16 @@ ppr_mono_ty (HsParTy _ ty)
ppr_mono_ty (HsDocTy _ ty doc)
= pprWithDoc doc $ ppr_mono_lty ty
-ppr_mono_ty (XHsType t) = ppr t
+ppr_mono_ty (XHsType t) = case ghcPass @p of
+ GhcPs -> case t of
+ HsCoreTy ty -> ppr ty
+ HsBangTy _ b ty -> ppr b <> ppr_mono_lty ty
+ HsRecTy _ flds -> pprHsConDeclRecFields flds
+ GhcRn -> ppr t
--------------------------
ppr_fun_ty :: (OutputableBndrId p)
- => HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
+ => HsMultAnn (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
ppr_fun_ty mult ty1 ty2
= let p1 = ppr_mono_lty ty1
p2 = ppr_mono_lty ty2
@@ -1466,13 +1486,11 @@ quote_tuple NotPromoted doc = doc
--------------------------
-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses
-- under precedence @p@.
-hsTypeNeedsParens :: PprPrec -> HsType (GhcPass p) -> Bool
+hsTypeNeedsParens :: forall p. IsPass p => PprPrec -> HsType (GhcPass p) -> Bool
hsTypeNeedsParens p = go_hs_ty
where
go_hs_ty (HsForAllTy{}) = p >= funPrec
go_hs_ty (HsQualTy{}) = p >= funPrec
- go_hs_ty (HsBangTy{}) = p > topPrec
- go_hs_ty (HsRecTy{}) = False
go_hs_ty (HsTyVar{}) = False
go_hs_ty (HsFunTy{}) = p >= funPrec
-- Special-case unary boxed tuple applications so that they are
@@ -1503,7 +1521,12 @@ hsTypeNeedsParens p = go_hs_ty
go_hs_ty (HsOpTy{}) = p >= opPrec
go_hs_ty (HsParTy{}) = False
go_hs_ty (HsDocTy _ (L _ t) _) = go_hs_ty t
- go_hs_ty (XHsType ty) = go_core_ty ty
+ go_hs_ty (XHsType t) = case ghcPass @p of
+ GhcPs -> case t of
+ HsCoreTy ty -> go_core_ty ty
+ HsBangTy{} -> p > topPrec
+ HsRecTy{} -> False
+ GhcRn -> go_core_ty t
go_core_ty (TyVarTy{}) = False
go_core_ty (AppTy{}) = p >= appPrec
@@ -1535,8 +1558,6 @@ lhsTypeHasLeadingPromotionQuote ty
go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})
| (L _ (c:_)) <- ctxt = goL c
| otherwise = goL body
- go (HsBangTy{}) = False
- go (HsRecTy{}) = False
go (HsTyVar _ p _) = isPromoted p
go (HsFunTy _ _ arg _) = goL arg
go (HsListTy{}) = False
@@ -1560,7 +1581,7 @@ lhsTypeHasLeadingPromotionQuote ty
-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is
-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply
-- returns @ty@.
-parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+parenthesizeHsType :: IsPass p => PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType p lty@(L loc ty)
| hsTypeNeedsParens p ty = L loc (HsParTy noAnn lty)
| otherwise = lty
@@ -1569,8 +1590,7 @@ parenthesizeHsType p lty@(L loc ty)
-- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@
-- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply
-- returns @ctxt@ unchanged.
-parenthesizeHsContext :: PprPrec
- -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)
+parenthesizeHsContext :: IsPass p => PprPrec -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)
parenthesizeHsContext p lctxt@(L loc ctxt) =
case ctxt of
[c] -> L loc [parenthesizeHsType p c]
@@ -1584,7 +1604,6 @@ parenthesizeHsContext p lctxt@(L loc ctxt) =
************************************************************************
-}
-type instance Anno (BangType (GhcPass p)) = SrcSpanAnnA
type instance Anno [LocatedA (HsType (GhcPass p))] = SrcSpanAnnC
type instance Anno (HsType (GhcPass p)) = SrcSpanAnnA
type instance Anno (HsSigType (GhcPass p)) = SrcSpanAnnA
@@ -1598,6 +1617,6 @@ type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA
type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA
type instance Anno HsIPName = EpAnnCO
-type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA
+type instance Anno (HsConDeclRecField (GhcPass p)) = SrcSpanAnnA
type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 188de89b56f03bffc36eb6a48af376cc6da4c55c..1841481805b9d6b1a4937808d18cf9f28bbedec6 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -135,7 +135,7 @@ import GHC.Core.ConLike
import GHC.Core.Make ( mkChunkified )
import GHC.Core.Type ( Type, isUnliftedType )
-import GHC.Builtin.Types ( unitTy )
+import GHC.Builtin.Types ( unitTy, manyDataConTy )
import GHC.Types.Id
import GHC.Types.Name
@@ -626,12 +626,12 @@ nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsAppTy f t = noLocA (HsAppTy noExtField f t)
nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x))
-nlHsFunTy a b = noLocA (HsFunTy noExtField (HsUnrestrictedArrow x) a b)
+nlHsFunTy a b = noLocA (HsFunTy noExtField (HsUnannotated x) a b)
where
x = case ghcPass @p of
- GhcPs -> noAnn
+ GhcPs -> EpArrow noAnn
GhcRn -> noExtField
- GhcTc -> noExtField
+ GhcTc -> manyDataConTy
nlHsParTy t = noLocA (HsParTy noAnn t)
nlHsTyConApp :: forall p a. IsSrcSpanAnn p a
@@ -1645,7 +1645,7 @@ hsConDeclsBinders cons = go emptyFieldIndices cons
get_flds_gadt seen (PrefixConGADT _ []) = (Just [], seen)
get_flds_gadt seen _ = (Nothing, seen)
- get_flds :: FieldIndices p -> LocatedL [LConDeclField (GhcPass p)]
+ get_flds :: FieldIndices p -> LocatedL [LHsConDeclRecField (GhcPass p)]
-> ([Located Int], FieldIndices p)
get_flds seen flds =
foldr add_fld ([], seen) fld_names
@@ -1653,7 +1653,7 @@ hsConDeclsBinders cons = go emptyFieldIndices cons
add_fld fld (is, ixs) =
let (i, ixs') = insertField fld ixs
in (i:is, ixs')
- fld_names = concatMap (cd_fld_names . unLoc) (unLoc flds)
+ fld_names = concatMap (cdrf_names . unLoc) (unLoc flds)
-- | A bijection between record fields of a datatype and integers,
-- used to implement Note [Collecting record fields in data declarations].
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index 83e143bf1f75bd9cc494d7a5f9f0c75f4e3bf242..a7af5b4b490ad9f4545e454ea1c03d78b4f46170 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -399,7 +399,7 @@ subordinates env instMap decl = case decl of
| c <- toList cons, cname <- getConNames c ]
fields = [ (unLoc $ foLabel n, maybeToList $ fmap unLoc doc, IM.empty)
| Just flds <- toList $ fmap getRecConArgs_maybe cons
- , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
+ , (L _ (HsConDeclRecField _ ns (CDF { cdf_doc = doc }))) <- (unLoc flds)
, (L _ n) <- ns ]
derivs = [ (instName, [unLoc doc], IM.empty)
| (l, doc) <- concatMap (extract_deriv_clause_tys .
@@ -430,21 +430,23 @@ conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =
h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap (HsDoc GhcRn)
h98ConArgDocs con_args = case con_args of
- PrefixCon args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args
- InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)
- , unLoc (hsScaledThing arg2) ]
+ PrefixCon args -> con_arg_docs 0 $ map cdf_doc args
+ InfixCon arg1 arg2 -> con_arg_docs 0 [ cdf_doc arg1, cdf_doc arg2 ]
RecCon _ -> IM.empty
gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap (HsDoc GhcRn)
gadtConArgDocs con_args res_ty = case con_args of
- PrefixConGADT _ args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]
- RecConGADT _ _ -> con_arg_docs 1 [res_ty]
+ PrefixConGADT _ args -> con_arg_docs 0 $ map cdf_doc args ++ [res_doc]
+ RecConGADT _ _ -> con_arg_docs 1 [res_doc]
+ where
+ res_doc = case res_ty of
+ HsDocTy _ _ lds -> Just lds
+ _ -> Nothing
-con_arg_docs :: Int -> [HsType GhcRn] -> IntMap (HsDoc GhcRn)
+con_arg_docs :: Int -> [Maybe (LHsDoc GhcRn)] -> IntMap (HsDoc GhcRn)
con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]
where
- f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
- f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)
+ f n (Just lds) = Just (n, unLoc lds)
f _ _ = Nothing
isValD :: HsDecl a -> Bool
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index b0ad0a6781171c0e81e79a59727b5d76ce7f7ac6..2ad4417df293a88ba13db201f0fd4186f3727665 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -46,6 +46,7 @@ import GHC.Hs
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
+import GHC.Tc.TyCl ( IsPrefixConGADT(..), unannotatedMultIsLinear )
import GHC.Core.Class
import GHC.Core.DataCon
@@ -927,17 +928,13 @@ repSrcStrictness SrcLazy = rep2 sourceLazyName []
repSrcStrictness SrcStrict = rep2 sourceStrictName []
repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
-repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType))
-repBangTy ty = do
- MkC u <- repSrcUnpackedness su'
- MkC s <- repSrcStrictness ss'
+repConDeclField :: HsConDeclField GhcRn -> MetaM (Core (M TH.BangType))
+repConDeclField (CDF { cdf_unpack, cdf_bang, cdf_type }) = do
+ MkC u <- repSrcUnpackedness cdf_unpack
+ MkC s <- repSrcStrictness cdf_bang
MkC b <- rep2 bangName [u, s]
- MkC t <- repLTy ty'
+ MkC t <- repLTy cdf_type
rep2 bangTypeName [b, t]
- where
- (su', ss', ty') = case unLoc ty of
- HsBangTy _ (HsBang su ss) ty -> (su, ss, ty)
- _ -> (NoSrcUnpack, NoSrcStrict, ty)
-------------------------------------------------------
-- Deriving clauses
@@ -1452,16 +1449,17 @@ repTy (HsAppKindTy _ ty ki) = do
ty1 <- repLTy ty
ki1 <- repLTy ki
repTappKind ty1 ki1
-repTy (HsFunTy _ w f a) | isUnrestricted w = do
- f1 <- repLTy f
- a1 <- repLTy a
+repTy (HsFunTy _ w f a) = do
+ f1 <- repLTy f
+ a1 <- repLTy a
+ case multAnnToHsType w of
+ Nothing -> do
tcon <- repArrowTyCon
repTapps tcon [f1, a1]
-repTy (HsFunTy _ w f a) = do w1 <- repLTy (arrowToHsType w)
- f1 <- repLTy f
- a1 <- repLTy a
- tcon <- repMulArrowTyCon
- repTapps tcon [w1, f1, a1]
+ Just m -> do
+ w1 <- repLTy m
+ tcon <- repMulArrowTyCon
+ repTapps tcon [w1, f1, a1]
repTy (HsListTy _ t) = do
t1 <- repLTy t
tcon <- repListTyCon
@@ -1729,7 +1727,7 @@ repE (HsForAll _ tele body) =
body' <- repLE body
rep2 forall_name [unC bndrs, unC body']
repE (HsFunArr _ mult arg res) = do
- fun <- repFunArr mult
+ fun <- repFunArrMult mult
arg' <- repLE arg
res' <- repLE res
repApps fun [arg', res']
@@ -1750,12 +1748,12 @@ repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e)
repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)
repE e@(HsProc{}) = notHandled (ThExpressionForm e)
-repFunArr :: HsArrowOf (LocatedA (HsExpr GhcRn)) GhcRn -> MetaM (Core (M TH.Exp))
-repFunArr HsUnrestrictedArrow{} = repConName unrestrictedFunTyConName
-repFunArr mult
- = do { fun <- repConName fUNTyConName
- ; mult' <- repLE (arrowToHsExpr mult)
- ; repApp fun mult' }
+repFunArrMult :: HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn -> MetaM (Core (M TH.Exp))
+repFunArrMult mult = case multAnnToHsExpr mult of
+ Nothing -> repConName unrestrictedFunTyConName
+ Just e -> do { fun <- repConName fUNTyConName
+ ; mult' <- repLE e
+ ; repApp fun mult' }
repConName :: Name -> MetaM (Core (M TH.Exp))
repConName n = do
@@ -2868,12 +2866,12 @@ repH98DataCon con details
= do con' <- lookupLOcc con -- See Note [Binders and occurrences]
case details of
PrefixCon ps -> do
- arg_tys <- repPrefixConArgs ps
+ arg_tys <- repPrefixConArgs IsNotPrefixConGADT ps
rep2 normalCName [unC con', unC arg_tys]
InfixCon st1 st2 -> do
- verifyLinearFields [st1, st2]
- arg1 <- repBangTy (hsScaledThing st1)
- arg2 <- repBangTy (hsScaledThing st2)
+ verifyLinearFields IsNotPrefixConGADT [st1, st2]
+ arg1 <- repConDeclField st1
+ arg2 <- repConDeclField st2
rep2 infixCName [unC arg1, unC con', unC arg2]
RecCon ips -> do
arg_vtys <- repRecConArgs ips
@@ -2887,7 +2885,7 @@ repGadtDataCons cons details res_ty
= do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
case details of
PrefixConGADT _ ps -> do
- arg_tys <- repPrefixConArgs ps
+ arg_tys <- repPrefixConArgs IsPrefixConGADT ps
res_ty' <- repLTy res_ty
rep2 gadtCName [ unC (nonEmptyCoreList' cons'), unC arg_tys, unC res_ty']
RecConGADT _ ips -> do
@@ -2899,36 +2897,37 @@ repGadtDataCons cons details res_ty
-- TH currently only supports linear constructors.
-- We also accept the (->) arrow when -XLinearTypes is off, because this
-- denotes a linear field.
--- This check is not performed in repRecConArgs, since the GADT record
--- syntax currently does not have a way to mark fields as nonlinear.
-verifyLinearFields :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM ()
-verifyLinearFields ps = do
- linear <- lift $ xoptM LangExt.LinearTypes
- let allGood = all (\st -> case hsMult st of
- HsUnrestrictedArrow _ -> not linear
- HsLinearArrow _ -> True
- _ -> False) ps
+verifyLinearFields :: IsPrefixConGADT -> [HsConDeclField GhcRn] -> MetaM ()
+verifyLinearFields isPrefixConGADT ps = do
+ linear <- lift $ unannotatedMultIsLinear isPrefixConGADT
+ let allGood = all (hsMultIsLinear linear . cdf_multiplicity) ps
unless allGood $ notHandled ThNonLinearDataCon
+ where
+ hsMultIsLinear linear HsUnannotated{} = linear
+ hsMultIsLinear _ HsLinearAnn{} = True
+ hsMultIsLinear _ (HsExplicitMult _ (L _ (HsTyVar _ _ (L _ n)))) = n == oneDataConName
+ hsMultIsLinear _ _ = False
-- Desugar the arguments in a data constructor declared with prefix syntax.
-repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)]
- -> MetaM (Core [M TH.BangType])
-repPrefixConArgs ps = do
- verifyLinearFields ps
- repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
+repPrefixConArgs :: IsPrefixConGADT -> [HsConDeclField GhcRn] -> MetaM (Core [M TH.BangType])
+repPrefixConArgs isPrefixConGADT ps = do
+ verifyLinearFields isPrefixConGADT ps
+ repListM bangTypeTyConName repConDeclField ps
-- Desugar the arguments in a data constructor declared with record syntax.
-repRecConArgs :: LocatedL [LConDeclField GhcRn]
+repRecConArgs :: LocatedL [LHsConDeclRecField GhcRn]
-> MetaM (Core [M TH.VarBangType])
-repRecConArgs ips = do
- args <- concatMapM rep_ip (unLoc ips)
+repRecConArgs lips = do
+ let ips = map unLoc (unLoc lips)
+ verifyLinearFields IsNotPrefixConGADT (map cdrf_spec ips)
+ args <- concatMapM rep_ip ips
coreListM varBangTypeTyConName args
where
- rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
+ rep_ip ip = mapM (rep_one_ip (cdrf_spec ip)) (cdrf_names ip)
- rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
+ rep_one_ip :: HsConDeclField GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
rep_one_ip t n = do { MkC v <- lookupOcc (unLoc . foLabel $ unLoc n)
- ; MkC ty <- repBangTy t
+ ; MkC ty <- repConDeclField t
; rep2 varBangTypeName [v,ty] }
------------ Types -------------------
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 2a5ff9790f4a5d48da5f276d721802a3fa7286e2..e8ed8cdb710d4dd8d163c7ca572ef336930b9db9 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1302,7 +1302,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
HieTc -> dataConCantHappen x
HsFunArr x mult arg res -> case hiePass @p of
HieRn ->
- [ toHie (arrowToHsExpr mult)
+ [ toHie (multAnnToHsExpr mult)
, toHie arg
, toHie res
]
@@ -1726,9 +1726,6 @@ instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where
instance ToHie (LocatedP OverlapMode) where
toHie (L span _) = locOnly (locA span)
-instance ToHie a => ToHie (HsScaled GhcRn a) where
- toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t]
-
instance ToHie (LocatedA (ConDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of
ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs
@@ -1770,15 +1767,22 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where
PrefixCon xs -> scaled_args_scope xs
InfixCon a b -> scaled_args_scope [a, b]
RecCon x -> mkScope x
- where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope
- scaled_args_scope = foldr combineScopes NoScope . map (mkScope . hsScaledThing)
+ where scaled_args_scope :: [HsConDeclField GhcRn] -> Scope
+ scaled_args_scope = foldr combineScopes NoScope . map (mkScope . cdf_type)
-instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where
+instance ToHie (LocatedL [LocatedA (HsConDeclRecField GhcRn)]) where
toHie (L span decls) = concatM $
[ locOnly (locA span)
, toHie decls
]
+instance ToHie (HsConDeclField GhcRn) where
+ toHie (CDF { cdf_multiplicity, cdf_type, cdf_doc }) = concatM
+ [ toHie (multAnnToHsType cdf_multiplicity)
+ , toHie cdf_type
+ , toHie cdf_doc
+ ]
+
instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsSigType GhcRn)))) where
toHie (TS sc (HsWC names a)) = concatM $
[ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
@@ -1892,7 +1896,7 @@ instance ToHie (LocatedA (HsType GhcRn)) where
, toHie ki
]
HsFunTy _ w a b ->
- [ toHie (arrowToHsType w)
+ [ toHie (multAnnToHsType w)
, toHie a
, toHie b
]
@@ -1928,12 +1932,6 @@ instance ToHie (LocatedA (HsType GhcRn)) where
[ toHie a
, toHie doc
]
- HsBangTy _ _ ty ->
- [ toHie ty
- ]
- HsRecTy _ fields ->
- [ toHie fields
- ]
HsExplicitListTy _ _ tys ->
[ toHie tys
]
@@ -1982,12 +1980,11 @@ instance HiePass p => ToHie (LocatedC [LocatedA (HsExpr (GhcPass p))]) where
, toHie exprs
]
-instance ToHie (LocatedA (ConDeclField GhcRn)) where
+instance ToHie (LocatedA (HsConDeclRecField GhcRn)) where
toHie (L span field) = concatM $ makeNode field (locA span) : case field of
- ConDeclField _ fields typ doc ->
- [ toHie $ map (RFC RecFieldDecl (getRealSpan $ getHasLoc typ)) fields
+ HsConDeclRecField _ fields typ ->
+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ getHasLoc $ cdf_type typ)) fields
, toHie typ
- , toHie doc
]
instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 67912f2ac598031979067be00f8dea6916ef9130..44f6cfe4e1e6983ea5eb972a226d69c781e6c4ea 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1238,7 +1238,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
; return (HsUnpack (Just co)) }
src_strict :: IfaceSrcBang -> HsSrcBang
- src_strict (IfSrcBang unpk bang) = mkHsSrcBang NoSourceText unpk bang
+ src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang
tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
tcIfaceEqSpec spec
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 3d649bd249eb3d20b25403aef12862842cf7bc28..df002912ab4a8fa7958b5896c9ebbc60206dce57 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2267,19 +2267,19 @@ type :: { LHsType GhcPs }
-- See Note [%shift: type -> btype]
: btype %shift { $1 }
| btype '->' ctype {% amsA' (sLL $1 $>
- $ HsFunTy noExtField (HsUnrestrictedArrow (epUniTok $2)) $1 $3) }
+ $ HsFunTy noExtField (HsUnannotated (EpArrow (epUniTok $2))) $1 $3) }
| btype mult '->' ctype {% hintLinear (getLoc $2)
>> let arr = (unLoc $2) (epUniTok $3)
in amsA' (sLL $1 $> $ HsFunTy noExtField arr $1 $4) }
| btype '->.' ctype {% hintLinear (getLoc $2) >>
- amsA' (sLL $1 $> $ HsFunTy noExtField (HsLinearArrow (EpLolly (epTok $2))) $1 $3) }
+ amsA' (sLL $1 $> $ HsFunTy noExtField (HsLinearAnn (EpLolly (epTok $2))) $1 $3) }
-mult :: { Located (EpUniToken "->" "\8594" -> HsArrow GhcPs) }
- : PREFIX_PERCENT atype { sLL $1 $> (mkMultTy (epTok $1) $2) }
+mult :: { Located (EpUniToken "->" "\8594" -> HsMultAnn GhcPs) }
+ : PREFIX_PERCENT atype { sLL $1 $> (mkMultAnn (epTok $1) $2 . EpArrow) }
-expmult :: { forall b. DisambECP b => PV (Located (EpUniToken "->" "\8594" -> HsArrowOf (LocatedA b) GhcPs)) }
+expmult :: { forall b. DisambECP b => PV (Located (EpUniToken "->" "\8594" -> HsMultAnnOf (LocatedA b) GhcPs)) }
expmult : PREFIX_PERCENT aexp { unECP $2 >>= \ $2 ->
fmap (sLL $1 $>) (mkHsMultPV (epTok $1) $2) }
@@ -2331,7 +2331,7 @@ atype :: { LHsType GhcPs }
| PREFIX_TILDE atype {% amsA' (sLL $1 $> (mkBangTy (glR $1) SrcLazy $2)) }
| PREFIX_BANG atype {% amsA' (sLL $1 $> (mkBangTy (glR $1) SrcStrict $2)) }
- | '{' fielddecls '}' {% do { decls <- amsA' (sLL $1 $> $ HsRecTy (AnnList (listAsAnchorM $2) (ListBraces (epTok $1) (epTok $3)) [] noAnn []) $2)
+ | '{' fielddecls '}' {% do { decls <- amsA' (sLL $1 $> $ XHsType $ HsRecTy (AnnList (listAsAnchorM $2) (ListBraces (epTok $1) (epTok $3)) [] noAnn []) $2)
; checkRecordSyntax decls }}
-- Constructor sigs only
@@ -2588,23 +2588,30 @@ usum_constr :: { (LHsType GhcPs, Int, Int) } -- constructor for the data decls S
: ktype bars { ($1, 1, (snd $2 + 1)) }
| bars ktype bars0 { ($2, snd $1 + 1, snd $1 + snd $3 + 1) }
-fielddecls :: { [LConDeclField GhcPs] }
+fielddecls :: { [LHsConDeclRecField GhcPs] }
: {- empty -} { [] }
| fielddecls1 { $1 }
-fielddecls1 :: { [LConDeclField GhcPs] }
+fielddecls1 :: { [LHsConDeclRecField GhcPs] }
: fielddecl ',' fielddecls1
{% do { h <- addTrailingCommaA $1 (epTok $2)
; return (h : $3) }}
| fielddecl { [$1] }
-fielddecl :: { LConDeclField GhcPs }
+fielddecl :: { LHsConDeclRecField GhcPs }
-- A list because of f,g :: Int
: sig_vars '::' ctype
{% amsA' (L (comb2 $1 $3)
- (ConDeclField (epUniTok $2)
+ (HsConDeclRecField noExtField
(reverse (map (\ln@(L l n)
- -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1))) $3 Nothing))}
+ -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1)))
+ (mkConDeclField (HsUnannotated (EpColon (epUniTok $2))) $3)))}
+ | sig_vars PREFIX_PERCENT atype '::' ctype
+ {% amsA' (L (comb4 $1 $2 $3 $5)
+ (HsConDeclRecField noExtField
+ (reverse (map (\ln@(L l n)
+ -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1)))
+ (mkMultField (epTok $2) $3 (epUniTok $4) $5)))}
-- Reversed!
maybe_derivings :: { Located (HsDeriving GhcPs) }
@@ -2668,17 +2675,17 @@ There's an awkward overlap with a type signature. Consider
decl_no_th :: { LHsDecl GhcPs }
: sigdecl { $1 }
- | infixexp opt_sig rhs {% runPV (unECP $1) >>= \ $1 ->
+ | infixexp opt_sig rhs {% runPV (unECP $1) >>= \ $1 ->
do { let { l = comb2 $1 $> }
- ; r <- checkValDef l $1 (HsNoMultAnn noExtField, $2) $3;
+ ; r <- checkValDef l $1 (HsUnannotated EpPatBind, $2) $3;
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
-- [FunBind vs PatBind]
; !cs <- getCommentsFor l
; return $! (sL (commentsA l cs) $ ValD noExtField r) } }
- | PREFIX_PERCENT atype infixexp opt_sig rhs {% runPV (unECP $3) >>= \ $3 ->
+ | PREFIX_PERCENT atype infixexp opt_sig rhs {% runPV (unECP $3) >>= \ $3 ->
do { let { l = comb2 $1 $> }
- ; r <- checkValDef l $3 (mkMultAnn (epTok $1) $2, $4) $5;
+ ; r <- checkValDef l $3 (mkMultAnn (epTok $1) $2 EpPatBind, $4) $5;
-- parses bindings of the form %p x or
-- %p x :: sig
--
@@ -2871,7 +2878,7 @@ infixexp2 :: { ECP }
withArrowParsingMode' $ \mode ->
unECP $1 >>= \ $1 ->
unECP $3 >>= \ $3 ->
- let arr = HsUnrestrictedArrow (epUniTok $2)
+ let arr = HsUnannotated (EpArrow (epUniTok $2))
in mkHsArrowPV (comb2 $1 $>) mode $1 arr $3 }
| infixexp expmult '->' infixexp2
{ ECP $
@@ -2886,7 +2893,7 @@ infixexp2 :: { ECP }
hintLinear (getLoc $2) >>
unECP $1 >>= \ $1 ->
unECP $3 >>= \ $3 ->
- let arr = HsLinearArrow (EpLolly (epTok $2))
+ let arr = HsLinearAnn (EpLolly (epTok $2))
in mkHsArrowPV (comb2 $1 $>) ArrowIsFunType $1 arr $3 }
| expcontext '=>' infixexp2
{ ECP $
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index 9f814ebdecd5f3437f73ac46f02df3a69ce391eb..8419ecebc1a8403e50177585a223b88b1b83b1db 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -466,7 +466,7 @@ data PsMessage
| PsErrParseRightOpSectionInPat !RdrName !(PatBuilder GhcPs)
-- | Illegal linear arrow or multiplicity annotation in GADT record syntax
- | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs)
+ | PsErrIllegalGadtRecordMultiplicity !(HsMultAnn GhcPs)
| PsErrInvalidCApiImport
@@ -568,7 +568,7 @@ data PsErrPunDetails
data PsErrTypeSyntaxDetails
= PETS_FunctionArrow
!(LocatedA (PatBuilder GhcPs))
- !(HsArrowOf (LocatedA (PatBuilder GhcPs)) GhcPs)
+ !(HsMultAnnOf (LocatedA (PatBuilder GhcPs)) GhcPs)
!(LocatedA (PatBuilder GhcPs))
| PETS_Multiplicity
!(EpToken "%")
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index cc2f7ddce3f238b6945e2addc423733c7456c2fb..8eb20a8b495d8f6afba08c36ba490f4e592bec4d 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -71,8 +71,9 @@ module GHC.Parser.PostProcess (
addFatalError, hintBangPat,
mkBangTy,
UnpackednessPragma(..),
- mkMultTy,
mkMultAnn,
+ mkMultField,
+ mkConDeclField,
-- Token location
mkTokenLocation,
@@ -805,9 +806,9 @@ mkGadtDecl loc names dcol ty = do
(args, res_ty, (ops, cps), csa) <-
case body_ty of
- L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (HsRecTy an rf)) res_ty) -> do
+ L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (XHsType (HsRecTy an rf))) res_ty) -> do
arr <- case hsArr of
- HsUnrestrictedArrow arr -> return arr
+ HsUnannotated (EpArrow arr) -> return arr
_ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $
(PsErrIllegalGadtRecordMultiplicity hsArr)
return noAnn
@@ -1434,7 +1435,7 @@ checkValDef loc lhs (mult, Just (sigAnn, sig)) grhss
checkPatBind loc lhs' grhss mult
checkValDef loc lhs (mult_ann, Nothing) grhss
- | HsNoMultAnn{} <- mult_ann
+ | HsUnannotated{} <- mult_ann
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ops, cps) -> do
@@ -1495,7 +1496,7 @@ checkPatBind :: SrcSpan
-> HsMultAnn GhcPs
-> P (HsBind GhcPs)
checkPatBind loc (L _ (BangPat an (L _ (VarPat _ v))))
- (L _match_span grhss) (HsNoMultAnn _)
+ (L _match_span grhss) (HsUnannotated _)
= return (makeFunBind v (L (noAnnSrcSpan loc)
[L (noAnnSrcSpan loc) (m an v)]))
where
@@ -1585,8 +1586,8 @@ isFunLhs e = go e [] [] []
go _ _ _ _ = return Nothing
mkBangTy :: EpaLocation -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
-mkBangTy tok_loc strictness =
- HsBangTy ((noAnn, noAnn, tok_loc), NoSourceText) (HsBang NoSrcUnpack strictness)
+mkBangTy tok_loc strictness lty =
+ XHsType (HsBangTy (noAnn, noAnn, tok_loc) (HsSrcBang NoSourceText NoSrcUnpack strictness) lty)
-- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.
data UnpackednessPragma =
@@ -1603,11 +1604,11 @@ addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do
-- such as ~T or !T, then add the pragma to the existing HsBangTy.
--
-- Otherwise, wrap the type in a new HsBangTy constructor.
- addUnpackedness (o,c) (L _ (HsBangTy ((_,_,tl), NoSourceText) bang t))
- | HsBang NoSrcUnpack strictness <- bang
- = HsBangTy ((o,c,tl), prag) (HsBang unpk strictness) t
+ addUnpackedness (o,c) (L _ (XHsType (HsBangTy (_,_,tl) bang t)))
+ | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang
+ = XHsType (HsBangTy (o,c,tl) (HsSrcBang prag unpk strictness) t)
addUnpackedness (o,c) t
- = HsBangTy ((o,c,noAnn), prag) (HsBang unpk NoSrcStrict) t
+ = XHsType (HsBangTy (o,c,noAnn) (HsSrcBang prag unpk NoSrcStrict) t)
---------------------------------------------------------------------------
-- | Check for monad comprehensions
@@ -1778,10 +1779,10 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
:: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (LocatedA b)
-- | Disambiguate "(a -> b)" (view pattern or function type arrow)
mkHsArrowPV
- :: SrcSpan -> ArrowParsingMode lhs b -> LocatedA lhs -> HsArrowOf (LocatedA b) GhcPs -> LocatedA b -> PV (LocatedA b)
+ :: SrcSpan -> ArrowParsingMode lhs b -> LocatedA lhs -> HsMultAnnOf (LocatedA b) GhcPs -> LocatedA b -> PV (LocatedA b)
-- | Disambiguate "%m" to the left of "->" (multiplicity)
mkHsMultPV
- :: EpToken "%" -> LocatedA b -> PV (TokRarrow -> HsArrowOf (LocatedA b) GhcPs)
+ :: EpToken "%" -> LocatedA b -> PV (TokRarrow -> HsMultAnnOf (LocatedA b) GhcPs)
-- | Disambiguate "forall a. b" and "forall a -> b" (forall telescope)
mkHsForallPV :: SrcSpan -> HsForAllTelescope GhcPs -> LocatedA b -> PV (LocatedA b)
-- | Disambiguate "(a,b,c)" to the left of "=>" (constraint list)
@@ -2121,10 +2122,10 @@ instance DisambECP (PatBuilder GhcPs) where
where
tok :: TokRarrow
tok = case arr of
- HsUnrestrictedArrow x -> x
+ HsUnannotated (EpArrow x) -> x
_ -> -- unreachable case because in Parser.y the reduction rules for
-- (a %m -> b) and (a ->. b) use ArrowIsFunType
- panic "mkHsArrowPV ArrowIsViewPat: expected HsUnrestrictedArrow"
+ panic "mkHsArrowPV ArrowIsViewPat: expected HsUnannotated"
mkHsArrowPV l ArrowIsFunType a arr b =
patFail l (PsErrTypeSyntaxInPat (PETS_FunctionArrow a arr b))
mkHsMultPV tok arg =
@@ -2381,16 +2382,16 @@ dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs
-- Detect when the record syntax is used:
-- data T = MkT { ... }
dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
- | [L (EpAnn anc _ cs) (HsRecTy an fields)] <- toList flds
+ | [L (EpAnn anc _ cs) (XHsType (HsRecTy an fields))] <- toList flds
= RecCon (L (EpAnn anc an cs) fields)
-- Normal prefix constructor, e.g. data T = MkT A B C
dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
- = PrefixCon (map hsLinear (toList flds))
+ = PrefixCon (map hsPlainTypeField (toList flds))
-- Infix constructor, e.g. data T = Int :! Bool
dataConBuilderDetails (L (EpAnn _ _ csl) (InfixDataConBuilder (L (EpAnn anc ann csll) lhs) _ rhs))
- = InfixCon (hsLinear (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsLinear rhs)
+ = InfixCon (hsPlainTypeField (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsPlainTypeField rhs)
instance DisambTD DataConBuilder where
@@ -2417,7 +2418,7 @@ instance DisambTD DataConBuilder where
return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs)
where
l = combineLocsA lhs rhs
- check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
+ check_no_ops (XHsType (HsBangTy _ _ t)) = check_no_ops (unLoc t)
check_no_ops (HsOpTy{}) =
addError $ mkPlainErrorMsgEnvelope (locA l) $
(PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs))
@@ -2458,7 +2459,7 @@ checkNotPromotedDataCon IsPromoted (L l name) =
mkUnboxedSumCon :: LHsType GhcPs -> ConTag -> Arity -> (LocatedN RdrName, HsConDeclH98Details GhcPs)
mkUnboxedSumCon t tag arity =
- (noLocA (getRdrName (sumDataCon tag arity)), PrefixCon [hsLinear t])
+ (noLocA (getRdrName (sumDataCon tag arity)), PrefixCon [hsPlainTypeField t])
{- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3538,35 +3539,28 @@ mkLHsOpTy prom x op y =
let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y
in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y)
-mkMultTy :: EpToken "%" -> LHsType GhcPs -> TokRarrow -> HsArrow GhcPs
-mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr
- -- See #18888 for the use of (SourceText "1") above
- = HsLinearArrow (EpPct1 pct1 arr)
- where
- -- The location of "%" combined with the location of "1".
- pct1 :: EpToken "%1"
- pct1 = epTokenWidenR pct (locA (getLoc t))
-mkMultTy pct t arr = HsExplicitMult (pct, arr) t
-
-mkMultExpr :: EpToken "%" -> LHsExpr GhcPs -> TokRarrow -> HsArrowOf (LHsExpr GhcPs) GhcPs
+mkMultExpr :: EpToken "%" -> LHsExpr GhcPs -> TokRarrow -> HsMultAnnOf (LHsExpr GhcPs) GhcPs
mkMultExpr pct t@(L _ (HsOverLit _ (OverLit _ (HsIntegral (IL (SourceText (unpackFS -> "1")) _ 1))))) arr
-- See #18888 for the use of (SourceText "1") above
- = HsLinearArrow (EpPct1 pct1 arr)
+ = HsLinearAnn (EpPct1 pct1 (EpArrow arr))
where
-- The location of "%" combined with the location of "1".
pct1 :: EpToken "%1"
pct1 = epTokenWidenR pct (locA (getLoc t))
-mkMultExpr pct t arr = HsExplicitMult (pct, arr) t
+mkMultExpr pct t arr = HsExplicitMult (pct, EpArrow arr) t
-mkMultAnn :: EpToken "%" -> LHsType GhcPs -> HsMultAnn GhcPs
-mkMultAnn pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1)))
+mkMultAnn :: EpToken "%" -> LHsType GhcPs -> EpArrowOrColon -> HsMultAnn GhcPs
+mkMultAnn pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) ep
-- See #18888 for the use of (SourceText "1") above
- = HsPct1Ann pct1
+ = HsLinearAnn (EpPct1 pct1 ep)
where
-- The location of "%" combined with the location of "1".
pct1 :: EpToken "%1"
pct1 = epTokenWidenR pct (locA (getLoc t))
-mkMultAnn pct t = HsMultAnn pct t
+mkMultAnn pct t ep = HsExplicitMult (pct, ep) t
+
+mkMultField :: EpToken "%" -> LHsType GhcPs -> TokDcolon -> LHsType GhcPs -> HsConDeclField GhcPs
+mkMultField pct mult col t = mkConDeclField (mkMultAnn pct mult (EpColon col)) t
mkTokenLocation :: SrcSpan -> TokenLocation
mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index 644e4b5b27f7a3fcffbec753364b34e0fe49c89e..87bd35f94acf34d4a292381052d294b00d91d188 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -215,9 +215,8 @@ collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } =
-- But having a single name for all of them is just easier to read, and makes it clear
-- that they all are of the form t -> HdkA t for some t.
--
--- If you need to handle a more complicated scenario that doesn't fit this
--- pattern, it's always possible to define separate functions outside of this
--- class, as is done in case of e.g. addHaddockConDeclField.
+-- If you need to handle a more complicated scenario that doesn't fit this pattern,
+-- it's always possible to define separate functions outside of this class.
--
-- See Note [Adding Haddock comments to the syntax tree].
class HasHaddock a where
@@ -711,7 +710,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where
case con_g_args of
PrefixConGADT x ts -> PrefixConGADT x <$> addHaddock ts
RecConGADT arr (L l_rec flds) -> do
- flds' <- traverse addHaddockConDeclField flds
+ flds' <- traverse addHaddock flds
pure $ RecConGADT arr (L l_rec flds')
con_res_ty' <- addHaddock con_res_ty
pure $ L l_con_decl $
@@ -735,22 +734,22 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where
case con_args of
PrefixCon ts -> do
con_doc' <- getConDoc (getLocA con_name)
- ts' <- traverse addHaddockConDeclFieldTy ts
+ ts' <- traverse addHaddock ts
pure $ L l_con_decl $
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
con_doc = lexLHsDocString <$> con_doc',
con_args = PrefixCon ts' }
InfixCon t1 t2 -> do
- t1' <- addHaddockConDeclFieldTy t1
+ t1' <- addHaddock t1
con_doc' <- getConDoc (getLocA con_name)
- t2' <- addHaddockConDeclFieldTy t2
+ t2' <- addHaddock t2
pure $ L l_con_decl $
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
con_doc = lexLHsDocString <$> con_doc',
con_args = InfixCon t1' t2' }
RecCon (L l_rec flds) -> do
con_doc' <- getConDoc (getLocA con_name)
- flds' <- traverse addHaddockConDeclField flds
+ flds' <- traverse addHaddock flds
pure $ L l_con_decl $
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
con_doc = lexLHsDocString <$> con_doc',
@@ -785,25 +784,11 @@ getConDoc
-> HdkA (Maybe (Located HsDocString))
getConDoc l = extendHdkA l $ liftHdkA $ getPrevNextDoc l
--- Add documentation comment to a data constructor field.
--- Used for PrefixCon and InfixCon.
-addHaddockConDeclFieldTy
- :: HsScaled GhcPs (LHsType GhcPs)
- -> HdkA (HsScaled GhcPs (LHsType GhcPs))
-addHaddockConDeclFieldTy (HsScaled mult (L l t)) =
- extendHdkA (locA l) $ liftHdkA $ do
- mDoc <- getPrevNextDoc (locA l)
- return (HsScaled mult (mkLHsDocTy (L l t) mDoc))
-
--- Add documentation comment to a data constructor field.
--- Used for RecCon.
-addHaddockConDeclField
- :: LConDeclField GhcPs
- -> HdkA (LConDeclField GhcPs)
-addHaddockConDeclField (L l_fld fld) =
- extendHdkA (locA l_fld) $ liftHdkA $ do
- cd_fld_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld)
- return (L l_fld (fld { cd_fld_doc }))
+instance HasHaddock (LocatedA (HsConDeclRecField GhcPs)) where
+ addHaddock (L l_fld (HsConDeclRecField ext nms cfs)) =
+ extendHdkA (locA l_fld) $ liftHdkA $ do
+ cdf_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld)
+ return $ L l_fld (HsConDeclRecField ext nms (cfs { cdf_doc }))
{- Note [Leading and trailing comments on H98 constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -906,8 +891,12 @@ We implement this in two steps:
including its field types
-}
-instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where
- addHaddock (HsScaled mult a) = HsScaled mult <$> addHaddock a
+instance HasHaddock (HsConDeclField GhcPs) where
+ addHaddock cfs = do
+ cdf_type <- addHaddock (cdf_type cfs)
+ return $ case cdf_type of
+ L _ (HsDocTy _ ty doc) -> cfs { cdf_type = ty, cdf_doc = Just doc }
+ _ -> cfs { cdf_type }
instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where
addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 5876e7f27f49151d0025be920ec261693b12c997..90d897cad76b37ab31d0c143e66eda75e4389840 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -455,7 +455,7 @@ rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat, pat_mult = pat_mult })
= do
-- we don't actually use the FV processing of rnPatsAndThen here
(pat',pat'_fvs) <- rnBindPat name_maker pat
- (pat_mult', mult'_fvs) <- rnHsMultAnn pat_mult
+ (pat_mult', mult'_fvs) <- rnHsMultAnnWith (rnLHsType PatCtx) pat_mult
return (bind { pat_lhs = pat', pat_ext = pat'_fvs `plusFV` mult'_fvs, pat_mult = pat_mult' })
-- We temporarily store the pat's FVs in bind_fvs;
-- gets updated to the FVs of the whole bind
@@ -742,16 +742,6 @@ makeMiniFixityEnv decls = foldlM add_one_sig emptyMiniFixityEnv decls
DataNamespaceSpecifier{} -> env { mfe_data_level_names = (extendFsEnv mfe_data_level_names fs fix_item)}
-
--- | Multiplicity annotations are a simple wrapper around types. As such,
--- renaming them is a straightforward wrapper around 'rnLHsType'.
-rnHsMultAnn :: HsMultAnn GhcPs -> RnM (HsMultAnn GhcRn, FreeVars)
-rnHsMultAnn (HsNoMultAnn _) = return (HsNoMultAnn noExtField, emptyFVs)
-rnHsMultAnn (HsPct1Ann _) = return (HsPct1Ann noExtField, emptyFVs)
-rnHsMultAnn (HsMultAnn _ p) = do
- (p', freeVars') <- rnLHsType PatCtx p
- return $ (HsMultAnn noExtField p', freeVars')
-
{- *********************************************************************
* *
Pattern synonym bindings
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index cd148332a835afb257ff7b07738f75ab56fedea5..efa0d233237c354a39045312c4c7844a42e4d721 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -634,7 +634,7 @@ rnExpr (HsForAll _ tele expr)
rnExpr (HsFunArr _ mult arg res)
= do { (arg', fvs1) <- rnLExpr arg
- ; (mult', fvs2) <- rnHsArrowWith rnLExpr mult
+ ; (mult', fvs2) <- rnHsMultAnnWith rnLExpr mult
; (res', fvs3) <- rnLExpr res
; checkTypeSyntaxExtension FunctionArrowSyntax
; return (HsFunArr noExtField mult' arg' res', plusFVs [fvs1, fvs2, fvs3]) }
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index d7ad77dd671627c9e522df7c81c2b8cf4cafdb70..5f095637a124e84ecb9ea468e8e64aab88ee0f65 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -14,14 +14,14 @@ module GHC.Rename.HsType (
-- Type related stuff
rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext,
rnLHsKind, rnLHsTypeArgs,
- rnHsSigType, rnHsWcType, rnHsTyLit, rnHsArrowWith,
+ rnHsSigType, rnHsWcType, rnHsTyLit, rnHsMultAnnWith,
HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, rnHsPatSigKind,
newTyVarNameRn,
- rnConDeclFields,
+ rnHsConDeclRecFields,
lookupField, mkHsOpTyRn,
rnLTyVar,
- rnScaledLHsType,
+ rnHsConDeclField,
-- Precence related stuff
NegationHandling(..),
@@ -450,12 +450,17 @@ rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
-rnScaledLHsType :: HsDocContext -> HsScaled GhcPs (LHsType GhcPs)
- -> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
-rnScaledLHsType doc (HsScaled w ty) = do
- (w' , fvs_w) <- rnHsArrow (mkTyKiEnv doc TypeLevel RnTypeBody) w
- (ty', fvs) <- rnLHsType doc ty
- return (HsScaled w' ty', fvs `plusFV` fvs_w)
+rnHsConDeclField :: HsDocContext -> HsConDeclField GhcPs
+ -> RnM (HsConDeclField GhcRn, FreeVars)
+rnHsConDeclField doc = rnHsConDeclFieldTyKi (mkTyKiEnv doc TypeLevel RnTypeBody)
+
+rnHsConDeclFieldTyKi :: RnTyKiEnv -> HsConDeclField GhcPs
+ -> RnM (HsConDeclField GhcRn, FreeVars)
+rnHsConDeclFieldTyKi env cdf@(CDF { cdf_multiplicity, cdf_type, cdf_doc }) = do
+ (w , fvs_w) <- rnHsMultAnnWith (rnLHsTyKi env) cdf_multiplicity
+ (ty, fvs) <- rnLHsTyKi env cdf_type
+ doc <- traverse rnLHsDoc cdf_doc
+ return (cdf { cdf_multiplicity = w, cdf_type = ty, cdf_doc = doc }, fvs `plusFV` fvs_w)
rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
@@ -567,35 +572,10 @@ rnHsTyKi env (HsParTy _ ty)
= do { (ty', fvs) <- rnLHsTyKi env ty
; return (HsParTy noAnn ty', fvs) }
-rnHsTyKi env (HsBangTy x b ty)
- = do { (ty', fvs) <- rnLHsTyKi env ty
- ; return (HsBangTy x b ty', fvs) }
-
-rnHsTyKi env ty@(HsRecTy _ flds)
- = do { let ctxt = rtke_ctxt env
- ; fls <- get_fields ctxt
- ; (flds', fvs) <- rnConDeclFields ctxt fls flds
- ; return (HsRecTy noExtField flds', fvs) }
- where
- get_fields ctxt@(ConDeclCtx names)
- = do res <- concatMapM (lookupConstructorFields . unLoc) names
- if equalLength res names
- -- Lookup can fail when the record syntax is incorrect, e.g.
- -- data D = D Int { fld :: Bool }. See T7943.
- then return res
- else err ctxt
- get_fields ctxt = err ctxt
-
- err ctxt =
- do { addErr $
- TcRnWithHsDocContext ctxt $
- TcRnIllegalRecordSyntax (Left ty)
- ; return [] }
-
rnHsTyKi env (HsFunTy u mult ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
- ; (mult', w_fvs) <- rnHsArrow env mult
+ ; (mult', w_fvs) <- rnHsMultAnnWith (rnLHsTyKi env) mult
; return (HsFunTy u mult' ty1' ty2'
, plusFVs [fvs1, fvs2, w_fvs]) }
@@ -662,7 +642,7 @@ rnHsTyKi env (HsDocTy x ty haddock_doc)
; return (HsDocTy x ty' haddock_doc', fvs) }
-- See Note [Renaming HsCoreTys]
-rnHsTyKi env (XHsType ty)
+rnHsTyKi env (XHsType (HsCoreTy ty))
= do mapM_ (check_in_scope . nameRdrName) fvs_list
return (XHsType ty, fvs)
where
@@ -677,6 +657,23 @@ rnHsTyKi env (XHsType ty)
TcRnWithHsDocContext (rtke_ctxt env) $
TcRnNotInScope (notInScopeErr WL_LocalOnly rdr_name) rdr_name [] noHints
+rnHsTyKi env ty@(XHsType (HsBangTy _ bang (L _ inner))) = do
+ -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),
+ -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
+ -- bangs are invalid, so fail. (#7210, #14761)
+ addErr $
+ TcRnWithHsDocContext (rtke_ctxt env) $
+ TcRnUnexpectedAnnotation ty bang
+ rnHsTyKi env inner
+
+rnHsTyKi env ty@(XHsType (HsRecTy {})) = do
+ -- Record types (which only show up temporarily in constructor
+ -- signatures) should have been removed by now
+ addErr $
+ TcRnWithHsDocContext (rtke_ctxt env) $
+ TcRnIllegalRecordSyntax ty
+ return (HsWildCardTy noExtField, emptyFVs) -- trick to avoid `failWithTc`
+
rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
= do { checkDataKinds env ty
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
@@ -703,15 +700,12 @@ rnHsTyLit tyLit@(HsNumTy x i) = do
rnHsTyLit (HsCharTy x c) = pure (HsCharTy x c)
-rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
-rnHsArrow env = rnHsArrowWith (rnLHsTyKi env)
-
-rnHsArrowWith :: (LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars))
- -> HsArrowOf (LocatedA (mult GhcPs)) GhcPs
- -> RnM (HsArrowOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)
-rnHsArrowWith _rn (HsUnrestrictedArrow _) = pure (HsUnrestrictedArrow noExtField, emptyFVs)
-rnHsArrowWith _rn (HsLinearArrow _) = pure (HsLinearArrow noExtField, emptyFVs)
-rnHsArrowWith rn (HsExplicitMult _ p)
+rnHsMultAnnWith :: (LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars))
+ -> HsMultAnnOf (LocatedA (mult GhcPs)) GhcPs
+ -> RnM (HsMultAnnOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)
+rnHsMultAnnWith _rn (HsUnannotated _) = pure (HsUnannotated noExtField, emptyFVs)
+rnHsMultAnnWith _rn (HsLinearAnn _) = pure (HsLinearAnn noExtField, emptyFVs)
+rnHsMultAnnWith rn (HsExplicitMult _ p)
= (\(mult, fvs) -> (HsExplicitMult noExtField mult, fvs)) <$> rn p
{-
@@ -1311,34 +1305,33 @@ before we check for term variable capture.
{-
*********************************************************
* *
- ConDeclField
+ HsConDeclRecField
* *
*********************************************************
-When renaming a ConDeclField, we have to find the FieldLabel
+When renaming a HsConDeclRecField, we have to find the FieldLabel
associated with each field. But we already have all the FieldLabels
available (since they were brought into scope by
GHC.Rename.Names.getLocalNonValBinders), so we just take the list as an
argument, build a map and look them up.
-}
-rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]
- -> RnM ([LConDeclField GhcRn], FreeVars)
+rnHsConDeclRecFields :: HsDocContext -> [FieldLabel] -> [LHsConDeclRecField GhcPs]
+ -> RnM ([LHsConDeclRecField GhcRn], FreeVars)
-- Also called from GHC.Rename.Module
-- No wildcards can appear in record fields
-rnConDeclFields ctxt fls fields
+rnHsConDeclRecFields ctxt fls fields
= mapFvRn (rnField fl_env env) fields
where
env = mkTyKiEnv ctxt TypeLevel RnTypeBody
fl_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ]
-rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
- -> RnM (LConDeclField GhcRn, FreeVars)
-rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))
+rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LHsConDeclRecField GhcPs
+ -> RnM (LHsConDeclRecField GhcRn, FreeVars)
+rnField fl_env env (L l (HsConDeclRecField _ names ty))
= do { let new_names = map (fmap (lookupField fl_env)) names
- ; (new_ty, fvs) <- rnLHsTyKi env ty
- ; haddock_doc' <- traverse rnLHsDoc haddock_doc
- ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc')
+ ; (new_ty, fvs) <- rnHsConDeclFieldTyKi env ty
+ ; return (L l (HsConDeclRecField noExtField new_names new_ty)
, fvs) }
lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn
@@ -2032,7 +2025,7 @@ extractConDeclGADTDetailsTyVars ::
HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars
extractConDeclGADTDetailsTyVars con_args = case con_args of
PrefixConGADT _ args -> extract_scaled_ltys args
- RecConGADT _ (L _ flds) -> extract_ltys $ map (cd_fld_type . unLoc) $ flds
+ RecConGADT _ (L _ flds) -> extract_scaled_ltys $ map (cdrf_spec . unLoc) $ flds
-- | Get type/kind variables mentioned in the kind signature, preserving
-- left-to-right order:
@@ -2048,13 +2041,14 @@ extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })
extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lctxt ctxt = extract_ltys (unLoc ctxt)
-extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]
+extract_scaled_ltys :: [HsConDeclField GhcPs]
-> FreeKiTyVars -> FreeKiTyVars
extract_scaled_ltys args acc = foldr extract_scaled_lty acc args
-extract_scaled_lty :: HsScaled GhcPs (LHsType GhcPs)
+extract_scaled_lty :: HsConDeclField GhcPs
-> FreeKiTyVars -> FreeKiTyVars
-extract_scaled_lty (HsScaled m ty) acc = extract_lty ty $ extract_hs_arrow m acc
+extract_scaled_lty (CDF { cdf_multiplicity, cdf_type }) acc
+ = extract_lty cdf_type $ extract_hs_mult_ann cdf_multiplicity acc
extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extract_ltys tys acc = foldr extract_lty acc tys
@@ -2063,10 +2057,6 @@ extract_lty :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty (L _ ty) acc
= case ty of
HsTyVar _ _ ltv -> extract_tv ltv acc
- HsBangTy _ _ ty -> extract_lty ty acc
- HsRecTy _ flds -> foldr (extract_lty
- . cd_fld_type . unLoc) acc
- flds
HsAppTy _ ty1 ty2 -> extract_lty ty1 $
extract_lty ty2 acc
HsAppKindTy _ ty k -> extract_lty ty $
@@ -2075,7 +2065,7 @@ extract_lty (L _ ty) acc
HsTupleTy _ _ tys -> extract_ltys tys acc
HsSumTy _ tys -> extract_ltys tys acc
HsFunTy _ m ty1 ty2 -> extract_lty ty1 $
- extract_hs_arrow m $ -- See Note [Ordering of implicit variables]
+ extract_hs_mult_ann m $ -- See Note [Ordering of implicit variables]
extract_lty ty2 acc
HsIParamTy _ _ ty -> extract_lty ty acc
HsOpTy _ _ ty1 tv ty2 -> extract_lty ty1 $
@@ -2116,10 +2106,9 @@ extract_lhs_sig_ty :: LHsSigType GhcPs -> FreeKiTyVars
extract_lhs_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =
extractHsOuterTvBndrs outer_bndrs $ extract_lty body []
-extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->
- FreeKiTyVars
-extract_hs_arrow (HsExplicitMult _ p) acc = extract_lty p acc
-extract_hs_arrow _ acc = acc
+extract_hs_mult_ann :: HsMultAnn GhcPs -> FreeKiTyVars -> FreeKiTyVars
+extract_hs_mult_ann (HsExplicitMult _ p) acc = extract_lty p acc
+extract_hs_mult_ann _ acc = acc
extract_hs_for_all_telescope :: HsForAllTelescope GhcPs
-> FreeKiTyVars -- Accumulator
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index f48b0ae770e85c0828c9b7c68ca373b2e347f4f6..7c0793038a883bb2e8de24b41d1f775a85ed2472 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -1889,14 +1889,12 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond
has_labelled_fields _ = False
has_strictness_flags condecl
- = any (is_strict . getBangStrictness . hsScaledThing) (con_args condecl)
+ = any isSrcStrict (con_arg_bangs condecl)
- is_strict (HsSrcBang _ (HsBang _ s)) = isSrcStrict s
-
- con_args (ConDeclGADT { con_g_args = PrefixConGADT _ args }) = args
- con_args (ConDeclH98 { con_args = PrefixCon args }) = args
- con_args (ConDeclH98 { con_args = InfixCon arg1 arg2 }) = [arg1, arg2]
- con_args _ = []
+ con_arg_bangs (ConDeclGADT { con_g_args = PrefixConGADT _ args }) = map cdf_bang args
+ con_arg_bangs (ConDeclH98 { con_args = PrefixCon args }) = map cdf_bang args
+ con_arg_bangs (ConDeclH98 { con_args = InfixCon arg1 arg2 }) = [cdf_bang arg1, cdf_bang arg2]
+ con_arg_bangs _ = []
{-
Note [Type data declarations]
@@ -2444,14 +2442,14 @@ rnConDeclH98Details ::
-> HsConDeclH98Details GhcPs
-> RnM (HsConDeclH98Details GhcRn, FreeVars)
rnConDeclH98Details _ doc (PrefixCon tys)
- = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys
+ = do { (new_tys, fvs) <- mapFvRn (rnHsConDeclField doc) tys
; return (PrefixCon new_tys, fvs) }
rnConDeclH98Details _ doc (InfixCon ty1 ty2)
- = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1
- ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2
+ = do { (new_ty1, fvs1) <- rnHsConDeclField doc ty1
+ ; (new_ty2, fvs2) <- rnHsConDeclField doc ty2
; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
rnConDeclH98Details con doc (RecCon flds)
- = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds
+ = do { (new_flds, fvs) <- rnRecHsConDeclRecFields con doc flds
; return (RecCon new_flds, fvs) }
rnConDeclGADTDetails ::
@@ -2460,20 +2458,20 @@ rnConDeclGADTDetails ::
-> HsConDeclGADTDetails GhcPs
-> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
rnConDeclGADTDetails _ doc (PrefixConGADT _ tys)
- = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys
+ = do { (new_tys, fvs) <- mapFvRn (rnHsConDeclField doc) tys
; return (PrefixConGADT noExtField new_tys, fvs) }
rnConDeclGADTDetails con doc (RecConGADT _ flds)
- = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds
+ = do { (new_flds, fvs) <- rnRecHsConDeclRecFields con doc flds
; return (RecConGADT noExtField new_flds, fvs) }
-rnRecConDeclFields ::
+rnRecHsConDeclRecFields ::
Name
-> HsDocContext
- -> LocatedL [LConDeclField GhcPs]
- -> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
-rnRecConDeclFields con doc (L l fields)
+ -> LocatedL [LHsConDeclRecField GhcPs]
+ -> RnM (LocatedL [LHsConDeclRecField GhcRn], FreeVars)
+rnRecHsConDeclRecFields con doc (L l fields)
= do { fls <- lookupConstructorFields con
- ; (new_fields, fvs) <- rnConDeclFields doc fls fields
+ ; (new_fields, fvs) <- rnHsConDeclRecFields doc fls fields
-- No need to check for duplicate fields
-- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn
; pure (L l new_fields, fvs) }
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index c6969ab4232b7ecfb90529c37f4a7686c1a89887..c13e468bfaa78c1e0fbb6c033a3ab7e9b0eb6c73 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -1283,7 +1283,7 @@ rn_ty_pat (HsAppKindTy _ ty ki) = do
rn_ty_pat (HsFunTy an mult lhs rhs) = do
lhs' <- rn_lty_pat lhs
- mult' <- rn_ty_pat_arrow mult
+ mult' <- rn_ty_pat_mult mult
rhs' <- rn_lty_pat rhs
pure (HsFunTy an mult' lhs' rhs')
@@ -1371,29 +1371,14 @@ rn_ty_pat (HsSpliceTy _ splice) = do
| hsTypeNeedsParens maxPrec hs_ty = L loc (HsParTy noAnn lhs_ty)
| otherwise = lhs_ty
-rn_ty_pat (HsBangTy an bang_src lty) = do
- ctxt <- askDocContext
- lty'@(L _ ty') <- rn_lty_pat lty
- liftRn $ addErr $
- TcRnWithHsDocContext ctxt $
- TcRnUnexpectedAnnotation ty' bang_src
- pure (HsBangTy an bang_src lty')
-
-rn_ty_pat ty@HsRecTy{} = do
- ctxt <- askDocContext
- liftRn $ addErr $
- TcRnWithHsDocContext ctxt $
- TcRnIllegalRecordSyntax (Left ty)
- pure (HsWildCardTy noExtField) -- trick to avoid `failWithTc`
-
rn_ty_pat ty@(XHsType{}) = do
ctxt <- askDocContext
liftRnFV $ rnHsType ctxt ty
-rn_ty_pat_arrow :: HsArrow GhcPs -> TPRnM (HsArrow GhcRn)
-rn_ty_pat_arrow (HsUnrestrictedArrow _) = pure (HsUnrestrictedArrow noExtField)
-rn_ty_pat_arrow (HsLinearArrow _) = pure (HsLinearArrow noExtField)
-rn_ty_pat_arrow (HsExplicitMult _ p)
+rn_ty_pat_mult :: HsMultAnn GhcPs -> TPRnM (HsMultAnn GhcRn)
+rn_ty_pat_mult (HsUnannotated _) = pure (HsUnannotated noExtField)
+rn_ty_pat_mult (HsLinearAnn _) = pure (HsLinearAnn noExtField)
+rn_ty_pat_mult (HsExplicitMult _ p)
= rn_lty_pat p <&> (\mult -> HsExplicitMult noExtField mult)
check_data_kinds :: HsType GhcPs -> TPRnM ()
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 8ca42395fc9ba66d6ad83cfce9f4a259739821bb..c8ca522b04e2884d24b567671bcc7ac204beef2f 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -2126,7 +2126,7 @@ nlHsAppType e s = noLocA (HsAppType noAnn e hs_ty)
hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s
nlHsCoreTy :: HsCoreTy -> LHsType GhcPs
-nlHsCoreTy = noLocA . XHsType
+nlHsCoreTy = noLocA . XHsType . HsCoreTy
mkCoerceClassMethEqn :: Class -- the class being derived
-> [TyVar] -- the tvs in the instance head (this includes
@@ -2243,10 +2243,10 @@ genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
genAuxBindSpecSig loc spec = case spec of
DerivTag2Con tycon _
-> mk_sig $ L (noAnnSrcSpan loc) $
- XHsType $ mkSpecForAllTys (tyConTyVars tycon) $
+ XHsType $ HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
intTy `mkVisFunTyMany` mkParentType tycon
DerivMaxTag _ _
- -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy))
+ -> mk_sig (L (noAnnSrcSpan loc) (XHsType (HsCoreTy intTy)))
DerivDataDataType _ _ _
-> mk_sig (nlHsTyVar NotPromoted dataType_RDR)
DerivDataConstr _ _ _
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index a9dea73390d1bfa56d65e5e0823c1407262f2983..7163e903fbdf6e9bc367b56ce233f8f2dedd2cb2 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -610,7 +610,7 @@ tc_mkRepTy gk get_fixity dit@(DerivInstTys{ dit_rep_tc = tycon
| (t,sb',ib',j) <- zip4 l sb ib [0..] ]
arg :: GenericKind_DC -> Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
- arg gk_ t (HsSrcBang _ (HsBang su ss)) ib fl = mkS fl su ss ib $ case gk_ of
+ arg gk_ t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of
-- Here we previously used Par0 if t was a type variable, but we
-- realized that we can't always guarantee that we are wrapping-up
-- all type variables in Par0. So we decided to stop using Par0
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index fccd05e17f859ac61005a8c6739438ccb935061f..0f74486f6f07caf8e3eef2f717fb143588bddf42 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1006,15 +1006,15 @@ instance Diagnostic TcRnMessage where
TcRnUnexpectedAnnotation ty bang
-> mkSimpleDecorated $
let err = case bang of
- HsBang SrcUnpack _ -> "UNPACK"
- HsBang SrcNoUnpack _ -> "NOUNPACK"
- HsBang NoSrcUnpack SrcLazy -> "laziness"
- HsBang _ _ -> "strictness"
+ HsSrcBang _ SrcUnpack _ -> "UNPACK"
+ HsSrcBang _ SrcNoUnpack _ -> "NOUNPACK"
+ HsSrcBang _ NoSrcUnpack SrcLazy -> "laziness (~)"
+ HsSrcBang _ _ _ -> "strictness (!)"
in text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$
- text err <+> text "annotation cannot appear nested inside a type"
- TcRnIllegalRecordSyntax either_ty_ty
+ text err <+> text "annotation can only appear on the arguments of a data constructor type"
+ TcRnIllegalRecordSyntax ty
-> mkSimpleDecorated $
- text "Record syntax is illegal here:" <+> either ppr ppr either_ty_ty
+ text "Record syntax is illegal here:" <+> ppr ty
TcRnInvalidVisibleKindArgument arg ty
-> mkSimpleDecorated $
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 45e0b6d1791e5958636fd929d85eaba42e98e11e..71494cf6ac4c794ee549ee3d6d2a7bb4043edc38 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -2274,7 +2274,7 @@ data TcRnMessage where
typecheck/should_fail/T7210
rename/should_fail/T22478b
-}
- TcRnUnexpectedAnnotation :: !(HsType GhcRn) -> !HsBang -> TcRnMessage
+ TcRnUnexpectedAnnotation :: !(HsType GhcPs) -> !HsSrcBang -> TcRnMessage
{-| TcRnIllegalRecordSyntax is an error indicating an illegal use of record syntax.
@@ -2285,7 +2285,7 @@ data TcRnMessage where
rename/should_fail/T9077
rename/should_fail/T22478b
-}
- TcRnIllegalRecordSyntax :: Either (HsType GhcPs) (HsType GhcRn) -> TcRnMessage
+ TcRnIllegalRecordSyntax :: HsType GhcPs -> TcRnMessage
{-| TcRnInvalidVisibleKindArgument is an error for a kind application on a
target type that cannot accept it.
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index 6763e450a318d8b14cb7bfa4d271566669cdd19e..4c68b9e6e0609e087967502a7ff47fd0f2543cb4 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -990,9 +990,9 @@ expr_to_type earg =
; res' <- go res
; return (L l (HsFunTy noExtField mult' arg' res'))}
where
- go_arrow :: HsArrowOf (LHsExpr GhcRn) GhcRn -> TcM (HsArrow GhcRn)
- go_arrow (HsUnrestrictedArrow{}) = pure (HsUnrestrictedArrow noExtField)
- go_arrow (HsLinearArrow{}) = pure (HsLinearArrow noExtField)
+ go_arrow :: HsMultAnnOf (LHsExpr GhcRn) GhcRn -> TcM (HsMultAnn GhcRn)
+ go_arrow (HsUnannotated _) = pure (HsUnannotated noExtField)
+ go_arrow (HsLinearAnn{}) = pure (HsLinearAnn noExtField)
go_arrow (HsExplicitMult _ exp) = HsExplicitMult noExtField <$> go exp
go (L l (HsForAll _ tele expr)) =
do { ty <- go expr
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index eb4ea696b7181081646b6e82195c8bd07fc938a8..94497889c2b95da3d26adb060466071ff4f5a7c6 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -593,7 +593,7 @@ tcPolyCheck prag_fn
-- the BinderStack, whence it shows up in "Relevant bindings.."
; mono_name <- newNameAt (nameOccName name) (locA nm_loc)
- ; mult <- tcMultAnn (HsNoMultAnn noExtField)
+ ; mult <- newMultiplicityVar
; (wrap_gen, (wrap_res, matches'))
<- tcSkolemiseCompleteSig sig $ \invis_pat_tys rho_ty ->
@@ -1313,7 +1313,7 @@ tcMonoBinds is_rec sig_fn no_gen
| NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
, Nothing <- sig_fn name -- ...with no type signature
= setSrcSpanA b_loc $
- do { mult <- tcMultAnn (HsNoMultAnn noExtField)
+ do { mult <- newMultiplicityVar
; ((co_fn, matches'), rhs_ty')
<- tcInferFRR (FRRBinder name) $ \ exp_ty ->
@@ -1342,7 +1342,7 @@ tcMonoBinds is_rec sig_fn no_gen
| NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
, all (isNothing . sig_fn) bndrs
= addErrCtxt (PatMonoBindsCtxt pat grhss) $
- do { mult <- tcMultAnn mult_ann
+ do { mult <- tcMultAnnOnPatBind mult_ann
; (grhss', pat_ty) <- tcInferFRR FRRPatBind $ \ exp_ty ->
-- tcInferFRR: the type of each let-binder must have
@@ -1509,12 +1509,12 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name
-- Just g = ...f...
-- Hence always typechecked with InferGen
do { mono_info <- tcLhsSigId no_gen (name, sig)
- ; mult <- tcMultAnn (HsNoMultAnn noExtField)
+ ; mult <- newMultiplicityVar
; return (TcFunBind mono_info (locA nm_loc) mult matches) }
| otherwise -- No type signature
= do { mono_ty <- newOpenFlexiTyVarTy
- ; mult <- tcMultAnn (HsNoMultAnn noExtField)
+ ; mult <- newMultiplicityVar
; mono_id <- newLetBndr no_gen name mult mono_ty
; let mono_info = MBI { mbi_poly_name = name
, mbi_sig = Nothing
@@ -1529,7 +1529,7 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_a
; let inst_sig_fun = lookupNameEnv $ mkNameEnv $
[ (mbi_poly_name mbi, mbi_mono_id mbi)
| mbi <- sig_mbis ]
- ; mult <- tcMultAnn mult_ann
+ ; mult <- tcMultAnnOnPatBind mult_ann
-- See Note [Typechecking pattern bindings]
; ((pat', nosig_mbis), pat_ty)
<- addErrCtxt (PatMonoBindsCtxt pat grhss) $
@@ -1624,13 +1624,13 @@ tcRhs (TcPatBind infos pat' mult mult_ann grhss pat_ty)
, pat_mult = setTcMultAnn mult mult_ann } )}
--- | @'tcMultAnn' ann@ takes an optional multiplicity annotation. If
+-- | @'tcMultAnnOnPatBind' ann@ takes an optional multiplicity annotation. If
-- present the multiplicity is returned, otherwise a fresh unification variable
-- is generated so that multiplicity can be inferred.
-tcMultAnn :: HsMultAnn GhcRn -> TcM Mult
-tcMultAnn (HsPct1Ann _) = return oneDataConTy
-tcMultAnn (HsMultAnn _ p) = tcCheckLHsTypeInContext p (TheKind multiplicityTy)
-tcMultAnn (HsNoMultAnn _) = newFlexiTyVarTy multiplicityTy
+tcMultAnnOnPatBind :: HsMultAnn GhcRn -> TcM Mult
+tcMultAnnOnPatBind (HsLinearAnn _) = return oneDataConTy
+tcMultAnnOnPatBind (HsExplicitMult _ p) = tcCheckLHsTypeInContext p (TheKind multiplicityTy)
+tcMultAnnOnPatBind (HsUnannotated _) = newMultiplicityVar
tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvForRhs Nothing thing_inside
@@ -1854,7 +1854,7 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds
Just (TcIdSig (TcPartialSig {})) -> True
_ -> False
has_mult_anns_and_pats = any has_mult_ann_and_pat lbinds
- has_mult_ann_and_pat (L _ (PatBind{pat_mult=HsNoMultAnn{}})) = False
+ has_mult_ann_and_pat (L _ (PatBind{pat_mult=HsUnannotated{}})) = False
has_mult_ann_and_pat (L _ (PatBind{pat_lhs=(L _ (VarPat{}))})) = False
has_mult_ann_and_pat (L _ (PatBind{})) = True
has_mult_ann_and_pat _ = False
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index d95e53693ff7642088f502d0944118e9e6a4fdf0..784defe5dbf4b7e579df1f85a49825e548e36db4 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -945,8 +945,8 @@ concern things that the renamer can't handle.
-}
-tcMult :: HsArrow GhcRn -> TcM Mult
-tcMult hc = tc_mult typeLevelMode hc
+tcMult :: LHsType GhcRn -> TcM Mult
+tcMult ty = tc_check_lhs_type typeLevelMode ty multiplicityTy
-- | Info about the context in which we're checking a type. Currently,
-- differentiates only between types and kinds, but this will likely
@@ -1100,15 +1100,6 @@ tcHsType :: TcTyMode -> HsType GhcRn -> ExpKind -> TcM TcType
tcHsType mode (HsParTy _ ty) exp_kind = tcLHsType mode ty exp_kind
tcHsType mode (HsDocTy _ ty _) exp_kind = tcLHsType mode ty exp_kind
-tcHsType _ ty@(HsBangTy _ bang _) _
- -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),
- -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
- -- bangs are invalid, so fail. (#7210, #14761)
- = failWith $ TcRnUnexpectedAnnotation ty bang
-tcHsType _ ty@(HsRecTy {}) _
- -- Record types (which only show up temporarily in constructor
- -- signatures) should have been removed by now
- = failWithTc $ TcRnIllegalRecordSyntax (Right ty)
-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'.
-- Here we get rid of it and add the finalizers to the global environment
@@ -1128,7 +1119,7 @@ tcHsType mode (HsFunTy _ mult ty1 ty2) exp_kind
tcHsType mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind
| op `hasKey` unrestrictedFunTyConKey
- = tc_fun_type mode (HsUnrestrictedArrow noExtField) ty1 ty2 exp_kind
+ = tc_fun_type mode (HsUnannotated noExtField) ty1 ty2 exp_kind
--------- Foralls
tcHsType mode t@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind
@@ -1371,10 +1362,7 @@ Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo
-}
------------------------------------------
-tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult
-tc_mult mode ty = tc_check_lhs_type mode (arrowToHsType ty) multiplicityTy
-------------------------------------------
-tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> ExpKind
+tc_fun_type :: TcTyMode -> HsMultAnn GhcRn -> LHsType GhcRn -> LHsType GhcRn -> ExpKind
-> TcM TcType
tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of
TypeLevel ->
@@ -1394,6 +1382,10 @@ tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of
; checkExpKind (HsFunTy noExtField mult ty1 ty2)
(tcMkVisFunTy mult' ty1' ty2')
liftedTypeKind exp_kind }
+ where
+ tc_mult mode mult = case multAnnToHsType mult of
+ Just mult' -> tc_check_lhs_type mode mult' multiplicityTy
+ Nothing -> return manyDataConTy
{- Note [Skolem escape and forall-types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index 05e170f7cf69d456b780ade6e52a377d97a774a8..01283878adf1e233f4faacbf3c2fd92411af878e 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -287,7 +287,7 @@ no_anon_wc_ty lty = go lty
HsWildCardTy _ -> False
HsAppTy _ ty1 ty2 -> go ty1 && go ty2
HsAppKindTy _ ty ki -> go ty && go ki
- HsFunTy _ w ty1 ty2 -> go ty1 && go ty2 && go (arrowToHsType w)
+ HsFunTy _ w ty1 ty2 -> go ty1 && go ty2 && all go (multAnnToHsType w)
HsListTy _ ty -> go ty
HsTupleTy _ _ tys -> gos tys
HsSumTy _ tys -> gos tys
@@ -296,8 +296,6 @@ no_anon_wc_ty lty = go lty
HsIParamTy _ _ ty -> go ty
HsKindSig _ ty kind -> go ty && go kind
HsDocTy _ ty _ -> go ty
- HsBangTy _ _ ty -> go ty
- HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds
HsExplicitListTy _ _ tys -> gos tys
HsExplicitTupleTy _ _ tys -> gos tys
HsForAllTy { hst_tele = tele
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 6acda948aa06d5ce0915a088dd248986f667f4a3..e7969b0fa87238ea33951efc2f7c15844d778604 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -2824,7 +2824,7 @@ reifyStrictness SrcLazy = TH.SourceLazy
reifySourceBang :: DataCon.HsSrcBang
-> (TH.SourceUnpackedness, TH.SourceStrictness)
-reifySourceBang (HsSrcBang _ (HsBang u s)) = (reifyUnpackedness u, reifyStrictness s)
+reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)
reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness
reifyDecidedStrictness HsLazy = TH.DecidedLazy
diff --git a/compiler/GHC/Tc/Solver/Solve.hs b/compiler/GHC/Tc/Solver/Solve.hs
index 8ab06ccae5aea4e5bf71d17ab92587be8435af49..771493bfe80b6c58567f21a1c6ea5c23abf11e46 100644
--- a/compiler/GHC/Tc/Solver/Solve.hs
+++ b/compiler/GHC/Tc/Solver/Solve.hs
@@ -855,7 +855,7 @@ everything to be in terms of b, while k does none of that. This is
ridiculous, but I (Richard E) don't see a good fix.
Shortcoming 2. Removing a redundant constraint can cause clients to fail to
-compile, by making the function more polymoprhic. Consider (#16154)
+compile, by making the function more polymorphic. Consider (#16154)
f :: (a ~ Bool) => a -> Int
f x = 3
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index a175e857a399d5e45efd133ad6f1c8a47ed565dc..7074bb37aba3ae1ea8cf14981200eddda00304ac 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -21,7 +21,10 @@ module GHC.Tc.TyCl (
tcFamTyPats, tcTyFamInstEqn,
tcAddOpenTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
unravelFamInstPats, addConsistencyConstraints,
- checkFamTelescope
+ checkFamTelescope,
+
+ -- Used by GHC.HsToCore.Quote
+ IsPrefixConGADT(..), unannotatedMultIsLinear
) where
import GHC.Prelude
@@ -57,7 +60,7 @@ import GHC.Tc.Types.ErrCtxt ( TyConInstFlavour(..) )
import GHC.Tc.Types.LclEnv
import GHC.Tc.Types.Origin
-import GHC.Builtin.Types ( oneDataConTy, unitTy, makeRecoveryTyCon )
+import GHC.Builtin.Types ( oneDataConTy, unitTy, makeRecoveryTyCon, manyDataConTy )
import GHC.Rename.Env( lookupConstructorFields )
@@ -1804,13 +1807,13 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc
-- This includes doing kind unification if the type is a newtype.
-- See Note [Implementation of UnliftedNewtypes] for why we need
-- the first two arguments.
-kcConArgTys :: ConArgKind -- Expected kind of the argument(s)
- -> [HsScaled GhcRn (LHsType GhcRn)] -- User-written argument types
+kcConArgTys :: ConArgKind -- Expected kind of the argument(s)
+ -> [HsConDeclField GhcRn] -- User-written argument types
-> TcM ()
kcConArgTys exp_kind arg_tys
- = forM_ arg_tys $ \(HsScaled mult ty) ->
- do { _ <- tcCheckLHsTypeInContext (getBangType ty) exp_kind
- ; tcMult mult }
+ = forM_ arg_tys $ \(CDF { cdf_multiplicity, cdf_type }) ->
+ do { _ <- tcCheckLHsTypeInContext cdf_type exp_kind
+ ; maybe (pure ()) (void . tcMult) (multAnnToHsType cdf_multiplicity) }
-- See Note [Implementation of UnliftedNewtypes], STEP 2
-- Kind-check the types of arguments to a Haskell98 data constructor.
@@ -1821,7 +1824,7 @@ kcConH98Args exp_kind con_args = case con_args of
PrefixCon tys -> kcConArgTys exp_kind tys
InfixCon ty1 ty2 -> kcConArgTys exp_kind [ty1, ty2]
RecCon (L _ flds) -> kcConArgTys exp_kind $
- map (hsLinear . cd_fld_type . unLoc) flds
+ map (cdrf_spec . unLoc) flds
-- Kind-check the types of arguments to a GADT data constructor.
kcConGADTArgs :: ConArgKind -- Expected kind of the argument(s)
@@ -1830,7 +1833,7 @@ kcConGADTArgs :: ConArgKind -- Expected kind of the argume
kcConGADTArgs exp_kind con_args = case con_args of
PrefixConGADT _ tys -> kcConArgTys exp_kind tys
RecConGADT _ (L _ flds) -> kcConArgTys exp_kind $
- map (hsLinear . cd_fld_type . unLoc) flds
+ map (cdrf_spec . unLoc) flds
kcConDecls :: TcKind -- Result kind of tycon
-- Used only in H98 case
@@ -3957,7 +3960,7 @@ tcConIsInfixGADT con details
RecConGADT{} -> return False
PrefixConGADT _ arg_tys -- See Note [Infix GADT constructors]
| isSymOcc (getOccName con)
- , [_ty1,_ty2] <- map hsScaledThing arg_tys
+ , [_ty1,_ty2] <- arg_tys
-> do { fix_env <- getFixityEnv
; return (con `elemNameEnv` fix_env) }
| otherwise -> return False
@@ -3968,13 +3971,13 @@ tcConH98Args :: ConArgKind -- expected kind of arguments
-> HsConDeclH98Details GhcRn
-> TcM [(Scaled TcType, HsSrcBang)]
tcConH98Args exp_kind (PrefixCon btys)
- = mapM (tcConArg exp_kind) btys
+ = mapM (tcConArg exp_kind IsNotPrefixConGADT) btys
tcConH98Args exp_kind (InfixCon bty1 bty2)
- = do { bty1' <- tcConArg exp_kind bty1
- ; bty2' <- tcConArg exp_kind bty2
+ = do { bty1' <- tcConArg exp_kind IsNotPrefixConGADT bty1
+ ; bty2' <- tcConArg exp_kind IsNotPrefixConGADT bty2
; return [bty1', bty2'] }
tcConH98Args exp_kind (RecCon fields)
- = tcRecConDeclFields exp_kind fields
+ = tcRecHsConDeclRecFields exp_kind fields
tcConGADTArgs :: ConArgKind -- expected kind of arguments
-- always OpenKind for datatypes, but unlifted newtypes
@@ -3982,39 +3985,51 @@ tcConGADTArgs :: ConArgKind -- expected kind of arguments
-> HsConDeclGADTDetails GhcRn
-> TcM [(Scaled TcType, HsSrcBang)]
tcConGADTArgs exp_kind (PrefixConGADT _ btys)
- = mapM (tcConArg exp_kind) btys
+ = mapM (tcConArg exp_kind IsPrefixConGADT) btys
tcConGADTArgs exp_kind (RecConGADT _ fields)
- = tcRecConDeclFields exp_kind fields
+ = tcRecHsConDeclRecFields exp_kind fields
tcConArg :: ConArgKind -- expected kind for args; always OpenKind for datatypes,
-- but might be an unlifted type with UnliftedNewtypes
- -> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang)
-tcConArg exp_kind (HsScaled w bty)
+ -> IsPrefixConGADT
+ -> HsConDeclField GhcRn -> TcM (Scaled TcType, HsSrcBang)
+tcConArg exp_kind isPrefixConGADT (CDF (_, src) unp str w bty _)
= do { traceTc "tcConArg 1" (ppr bty)
- ; arg_ty <- tcCheckLHsTypeInContext (getBangType bty) exp_kind
- ; w' <- tcDataConMult w
+ ; arg_ty <- tcCheckLHsTypeInContext bty exp_kind
+ ; w' <- tcDataConMult isPrefixConGADT w
; traceTc "tcConArg 2" (ppr bty)
- ; return (Scaled w' arg_ty, getBangStrictness bty) }
+ ; return (Scaled w' arg_ty, HsSrcBang src unp str) }
-tcRecConDeclFields :: ConArgKind
- -> LocatedL [LConDeclField GhcRn]
+tcRecHsConDeclRecFields :: ConArgKind
+ -> LocatedL [LHsConDeclRecField GhcRn]
-> TcM [(Scaled TcType, HsSrcBang)]
-tcRecConDeclFields exp_kind fields
- = mapM (tcConArg exp_kind) btys
+tcRecHsConDeclRecFields exp_kind fields
+ = mapM (tcConArg exp_kind IsNotPrefixConGADT) btys
where
-- We need a one-to-one mapping from field_names to btys
- combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f)))
+ combined = map (\(L _ f) -> (cdrf_names f, cdrf_spec f))
(unLoc fields)
explode (ns,ty) = zip ns (repeat ty)
exploded = concatMap explode combined
(_,btys) = unzip exploded
-tcDataConMult :: HsArrow GhcRn -> TcM Mult
-tcDataConMult arr@(HsUnrestrictedArrow _) = do
- -- See Note [Function arrows in GADT constructors]
- linearEnabled <- xoptM LangExt.LinearTypes
- if linearEnabled then tcMult arr else return oneDataConTy
-tcDataConMult arr = tcMult arr
+data IsPrefixConGADT = IsPrefixConGADT | IsNotPrefixConGADT deriving (Eq)
+
+-- See Note [Function arrows in GADT constructors]
+unannotatedMultIsLinear :: IsPrefixConGADT -> TcRnIf gbl lcl Bool
+unannotatedMultIsLinear isPrefixConGADT = do
+ if isPrefixConGADT == IsPrefixConGADT then do
+ linearEnabled <- xoptM LangExt.LinearTypes
+ return $ not linearEnabled
+ else
+ return True
+
+tcDataConMult :: IsPrefixConGADT -> HsMultAnn GhcRn -> TcM Mult
+tcDataConMult isPrefixConGADT arr = case multAnnToHsType arr of
+ Nothing -> do
+ isLinear <- unannotatedMultIsLinear isPrefixConGADT
+ return $ if isLinear then oneDataConTy else manyDataConTy
+ Just ty -> tcMult ty
{-
Note [Function arrows in GADT constructors]
@@ -4760,32 +4775,32 @@ checkValidDataCon dflags existential_ok tc con
; hsc_env <- getTopEnv
; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM ()
check_bang orig_arg_ty bang rep_bang n
- | HsSrcBang _ (HsBang _ SrcLazy) <- bang
+ | HsSrcBang _ _ SrcLazy <- bang
, not (bang_opt_strict_data bang_opts)
= addErrTc (bad_bang n LazyFieldsDisabled)
-- Warn about UNPACK without "!"
-- e.g. data T = MkT {-# UNPACK #-} Int
- | HsSrcBang _ (HsBang want_unpack strict_mark) <- bang
+ | HsSrcBang _ want_unpack strict_mark <- bang
, isSrcUnpacked want_unpack, not (is_strict strict_mark)
, not (isUnliftedType orig_arg_ty)
= addDiagnosticTc (bad_bang n UnpackWithoutStrictness)
-- Warn about a redundant ! on an unlifted type
-- e.g. data T = MkT !Int#
- | HsSrcBang _ (HsBang _ SrcStrict) <- bang
+ | HsSrcBang _ _ SrcStrict <- bang
, isUnliftedType orig_arg_ty
= addDiagnosticTc $ TcRnBangOnUnliftedType orig_arg_ty
-- Warn about a ~ on an unlifted type (#21951)
-- e.g. data T = MkT ~Int#
- | HsSrcBang _ (HsBang _ SrcLazy) <- bang
+ | HsSrcBang _ _ SrcLazy <- bang
, isUnliftedType orig_arg_ty
= addDiagnosticTc $ TcRnLazyBangOnUnliftedType orig_arg_ty
-- Warn about unusable UNPACK pragmas
-- e.g. data T a = MkT {-# UNPACK #-} !a -- Can't unpack
- | HsSrcBang _ (HsBang want_unpack _) <- bang
+ | HsSrcBang _ want_unpack _ <- bang
-- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon.
, isSrcUnpacked want_unpack -- this means the user wrote {-# UNPACK #-}
@@ -4884,9 +4899,9 @@ checkNewDataCon con
(_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)
= dataConFullSig con
- ok_bang (HsSrcBang _ (HsBang _ SrcStrict)) = False
- ok_bang (HsSrcBang _ (HsBang _ SrcLazy)) = False
- ok_bang _ = True
+ ok_bang (HsSrcBang _ _ SrcStrict) = False
+ ok_bang (HsSrcBang _ _ SrcLazy) = False
+ ok_bang _ = True
ok_mult OneTy = True
ok_mult _ = False
diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs
index ba0a742593380094fadb1bebfd5962e2214f7a13..c445d39aa59f6d9503177144cdf3bdf1325a5bef 100644
--- a/compiler/GHC/Tc/TyCl/Build.hs
+++ b/compiler/GHC/Tc/TyCl/Build.hs
@@ -397,7 +397,7 @@ buildClass tycon_name binders roles fds
; traceIf (text "buildClass" <+> ppr tycon)
; return result }
where
- no_bang = mkHsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
+ no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
mk_op_item rec_clas (op_name, _, dm_spec)
diff --git a/compiler/GHC/Tc/Zonk/Type.hs b/compiler/GHC/Tc/Zonk/Type.hs
index 07a70244d6e102eab402854983bb2bd6436bad45..e4c98454cf44bb8c5492e56f9ad4e5e7ccc25c85 100644
--- a/compiler/GHC/Tc/Zonk/Type.hs
+++ b/compiler/GHC/Tc/Zonk/Type.hs
@@ -813,15 +813,15 @@ zonk_bind (PatSynBind x bind@(PSB { psb_id = L loc id
, psb_dir = dir' } } }
zonkMultAnn :: HsMultAnn GhcTc -> ZonkTcM (HsMultAnn GhcTc)
-zonkMultAnn (HsNoMultAnn mult)
+zonkMultAnn (HsUnannotated mult)
= do { mult' <- zonkTcTypeToTypeX mult
- ; return (HsNoMultAnn mult') }
-zonkMultAnn (HsPct1Ann mult)
+ ; return (HsUnannotated mult') }
+zonkMultAnn (HsLinearAnn mult)
= do { mult' <- zonkTcTypeToTypeX mult
- ; return (HsPct1Ann mult') }
-zonkMultAnn (HsMultAnn mult hs_ty)
+ ; return (HsLinearAnn mult') }
+zonkMultAnn (HsExplicitMult mult hs_ty)
= do { mult' <- zonkTcTypeToTypeX mult
- ; return (HsMultAnn mult' hs_ty) }
+ ; return (HsExplicitMult mult' hs_ty) }
zonkPatSynDetails :: HsPatSynDetails GhcTc
-> ZonkTcM (HsPatSynDetails GhcTc)
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index e8d3a878aa23399147240069c980bf117da39168..f14c62497ac8f4ffb5a07c0b7a4fdcb15c6fc38f 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -245,7 +245,7 @@ cvtDec (TH.ValD pat body ds)
PatBind { pat_lhs = pat'
, pat_rhs = GRHSs emptyComments body' ds'
, pat_ext = noExtField
- , pat_mult = HsNoMultAnn noExtField
+ , pat_mult = HsUnannotated EpPatBind
} }
cvtDec (TH.FunD nm cls)
@@ -704,7 +704,7 @@ cvtConstr :: TH.Name -- ^ name of first constructor of parent type
cvtConstr _ do_con_name (NormalC c strtys)
= do { c' <- do_con_name c
; tys' <- mapM cvt_arg strtys
- ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon (map hsLinear tys')) }
+ ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon tys') }
cvtConstr parent_con do_con_name (RecC c varstrtys)
= do { c' <- do_con_name c
@@ -717,7 +717,7 @@ cvtConstr _ do_con_name (InfixC st1 c st2)
; st1' <- cvt_arg st1
; st2' <- cvt_arg st2
; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing
- (InfixCon (hsLinear st1') (hsLinear st2')) }
+ (InfixCon st1' st2') }
cvtConstr parent_con do_con_name (ForallC tvs ctxt con)
= do { tvs' <- cvtTvs tvs
@@ -756,7 +756,7 @@ cvtConstr _ do_con_name (GadtC c strtys ty) = case nonEmpty c of
{ c' <- mapM do_con_name c
; args <- mapM cvt_arg strtys
; ty' <- cvtType ty
- ; mk_gadt_decl c' (PrefixConGADT noExtField $ map hsLinear args) ty'}
+ ; mk_gadt_decl c' (PrefixConGADT noExtField args) ty'}
cvtConstr parent_con do_con_name (RecGadtC c varstrtys ty) = case nonEmpty c of
Nothing -> failWith RecGadtNoCons
@@ -790,25 +790,24 @@ cvtSrcStrictness NoSourceStrictness = NoSrcStrict
cvtSrcStrictness SourceLazy = SrcLazy
cvtSrcStrictness SourceStrict = SrcStrict
-cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
+cvt_arg :: (TH.Bang, TH.Type) -> CvtM (HsConDeclField GhcPs)
cvt_arg (Bang su ss, ty)
= do { ty'' <- cvtType ty
; let ty' = parenthesizeHsType appPrec ty''
su' = cvtSrcUnpackedness su
ss' = cvtSrcStrictness ss
- ; returnLA $ HsBangTy (noAnn, NoSourceText) (HsBang su' ss') ty' }
+ ; return $ CDF noAnn su' ss' (HsUnannotated (EpColon noAnn)) ty' Nothing }
cvt_id_arg :: TH.Name -- ^ parent constructor name
- -> (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
+ -> (TH.Name, TH.Bang, TH.Type) -> CvtM (LHsConDeclRecField GhcPs)
cvt_id_arg parent_con (i, str, ty)
= do { L li i' <- fldNameN (nameBase parent_con) i
; ty' <- cvt_arg (str,ty)
- ; returnLA $ ConDeclField
- { cd_fld_ext = noAnn
- , cd_fld_names
+ ; returnLA $ HsConDeclRecField
+ { cdrf_ext = noExtField
+ , cdrf_names
= [L (l2l li) $ FieldOcc noExtField (L li i')]
- , cd_fld_type = ty'
- , cd_fld_doc = Nothing} }
+ , cdrf_spec = ty' } }
cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs cs = do { mapM cvtDerivClause cs }
@@ -1720,7 +1719,7 @@ cvtTypeKind typeOrKind ty
_ -> return $
parenthesizeHsType sigPrec x'
let y'' = parenthesizeHsType sigPrec y'
- returnLA (HsFunTy noExtField (HsUnrestrictedArrow noAnn) x'' y'')
+ returnLA (HsFunTy noExtField (HsUnannotated (EpArrow noAnn)) x'' y'')
| otherwise
-> do { fun_tc <- returnLA $ getRdrName unrestrictedFunTyCon
; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' }
@@ -1883,12 +1882,12 @@ cvtTypeKind typeOrKind ty
_ -> failWith (MalformedType typeOrKind ty)
}
-hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs
+hsTypeToArrow :: LHsType GhcPs -> HsMultAnn GhcPs
hsTypeToArrow w = case unLoc w of
HsTyVar _ _ (L _ (isExact_maybe -> Just n))
- | n == oneDataConName -> HsLinearArrow noAnn
- | n == manyDataConName -> HsUnrestrictedArrow noAnn
- _ -> HsExplicitMult noAnn w
+ | n == oneDataConName -> HsLinearAnn noAnn
+ | n == manyDataConName -> HsUnannotated (EpArrow noAnn)
+ _ -> HsExplicitMult (noAnn, EpArrow noAnn) w
-- ConT/InfixT can contain both data constructor (i.e., promoted) names and
-- other (i.e, unpromoted) names, as opposed to PromotedT, which can only
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 7d8dde12d12d93e029b7e86a74e420534416a2c7..8b6b5b39ea3cd97fe949946789e940472e5c964b 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -1144,18 +1144,18 @@ dataConSrcToImplBang
-> HsImplBang
dataConSrcToImplBang bang_opts fam_envs arg_ty
- (HsSrcBang ann (HsBang unpk NoSrcStrict))
+ (HsSrcBang ann unpk NoSrcStrict)
| bang_opt_strict_data bang_opts -- StrictData => strict field
= dataConSrcToImplBang bang_opts fam_envs arg_ty
- (mkHsSrcBang ann unpk SrcStrict)
+ (HsSrcBang ann unpk SrcStrict)
| otherwise -- no StrictData => lazy field
= HsLazy
-dataConSrcToImplBang _ _ _ (HsSrcBang _ (HsBang _ SrcLazy))
+dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)
= HsLazy
dataConSrcToImplBang bang_opts fam_envs arg_ty
- (HsSrcBang _ (HsBang unpk_prag SrcStrict))
+ (HsSrcBang _ unpk_prag SrcStrict)
| isUnliftedType (scaledThing arg_ty)
-- NB: non-newtype data constructors can't have representation-polymorphic fields
-- so this is OK.
@@ -1470,7 +1470,7 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty
-- We'd get a black hole if we used dataConImplBangs
ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool
- ok_arg dcs (Scaled _ ty, HsSrcBang _ (HsBang unpack_prag str_prag))
+ ok_arg dcs (Scaled _ ty, HsSrcBang _ unpack_prag str_prag)
| strict_field str_prag
, Just data_cons <- unpackable_type_datacons (topNormaliseType fam_envs ty)
, should_unpack_conservative unpack_prag data_cons -- Wrinkle (W3)
diff --git a/compiler/Language/Haskell/Syntax/Basic.hs b/compiler/Language/Haskell/Syntax/Basic.hs
index a39565c1a53be9d5c2b3b1d5a6cea9e3a3a34773..320b9118fd4136a309d3d65fc50809c18e6ede31 100644
--- a/compiler/Language/Haskell/Syntax/Basic.hs
+++ b/compiler/Language/Haskell/Syntax/Basic.hs
@@ -81,24 +81,6 @@ Source Strictness and Unpackedness
************************************************************************
-}
--- | Haskell Bang
---
--- Bangs on data constructor arguments written by the user.
---
--- @(HsBang SrcUnpack SrcLazy)@ and
--- @(HsBang SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we
--- emit a warning (in checkValidDataCon) and treat it like
--- @(HsBang NoSrcUnpack SrcLazy)@
---
--- 'GHC.Core.DataCon.HsSrcBang' is a wrapper around this, associating it with
--- a 'GHC.Types.SourceText.SourceText' as written by the user.
--- In the AST, the @SourceText@ is hidden inside the extension point
--- 'Language.Haskell.Syntax.Extension.XBangTy'.
-data HsBang =
- HsBang SrcUnpackedness
- SrcStrictness
- deriving Data
-
-- | Source Strictness
--
-- What strictness annotation the user wrote
diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs
index b298916c8e9b3ece34b024697015d655b9cad7b4..197052624b4872d6185a2799560d327b81e470d4 100644
--- a/compiler/Language/Haskell/Syntax/Binds.hs
+++ b/compiler/Language/Haskell/Syntax/Binds.hs
@@ -251,20 +251,6 @@ data PatSynBind idL idR
}
| XPatSynBind !(XXPatSynBind idL idR)
--- | Multiplicity annotations, on binders, are always resolved (to a unification
--- variable if there is no annotation) during type-checking. The resolved
--- multiplicity is stored in the extension fields.
-data HsMultAnn pass
- = HsNoMultAnn !(XNoMultAnn pass)
- | HsPct1Ann !(XPct1Ann pass)
- | HsMultAnn !(XMultAnn pass) (LHsType (NoGhcTc pass))
- | XMultAnn !(XXMultAnn pass)
-
-type family XNoMultAnn p
-type family XPct1Ann p
-type family XMultAnn p
-type family XXMultAnn p
-
{-
************************************************************************
* *
diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs
index 7d9a6adb04b8c484c551cc2dac8269630b8dc6d9..4a8667c2de41c15c5adea77360fb74e7a01c422d 100644
--- a/compiler/Language/Haskell/Syntax/Decls.hs
+++ b/compiler/Language/Haskell/Syntax/Decls.hs
@@ -1115,7 +1115,7 @@ 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 (HsConDeclField pass) (XRec pass [LHsConDeclRecField pass])
-- The Void argument to HsConDetails here is a reflection of the fact that
-- type applications are not allowed in data constructor declarations.
@@ -1126,8 +1126,8 @@ type HsConDeclH98Details pass
-- derived Show instances—see Note [Infix GADT constructors] in
-- GHC.Tc.TyCl—but that is an orthogonal concern.)
data HsConDeclGADTDetails pass
- = PrefixConGADT !(XPrefixConGADT pass) [HsScaled pass (LBangType pass)]
- | RecConGADT !(XRecConGADT pass) (XRec pass [LConDeclField pass])
+ = PrefixConGADT !(XPrefixConGADT pass) [HsConDeclField pass]
+ | RecConGADT !(XRecConGADT pass) (XRec pass [LHsConDeclRecField pass])
| XConDeclGADTDetails !(XXConDeclGADTDetails pass)
type family XPrefixConGADT p
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index f43c1bc54bc458096613cd8e45795282ca8fe614..beb978640560f7535731f24d01211ad18fa0f01d 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -292,7 +292,7 @@ expressions and their grammar:
...
| HsForAll (XForAll p) (HsForAllTelescope p) (LHsExpr p)
| HsQual (XQual p) (XRec p [LHsExpr p]) (LHsExpr p)
- | HsFunArr (XFunArr p) (HsArrowOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p)
+ | HsFunArr (XFunArr p) (HsMultAnnOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p)
-- GHC/Parser.y
infixexp2 :: { ECP }
@@ -542,7 +542,7 @@ data HsExpr p
-- | Function types @a -> b@.
-- Used with @RequiredTypeArguments@, e.g. @fn (Int -> Bool)@.
-- See Note [Types in terms]
- | HsFunArr (XFunArr p) (HsArrowOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p)
+ | HsFunArr (XFunArr p) (HsMultAnnOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p)
| XExpr !(XXExpr p)
-- Note [Trees That Grow] in Language.Haskell.Syntax.Extension for the
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 8cd0248526584a72b1930c9a11e433edb6c85bf4..ee0eef681aa563dc418be66b23df6da79a01cedf 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -657,8 +657,6 @@ type family XStarTy x
type family XKindSig x
type family XSpliceTy x
type family XDocTy x
-type family XBangTy x
-type family XRecTy x
type family XExplicitListTy x
type family XExplicitTupleTy x
type family XTyLit x
@@ -683,6 +681,11 @@ type family XXHsForAllTelescope x
type family XTyVarBndr x
type family XXTyVarBndr x
+-- ---------------------------------------------------------------------
+-- HsConDeclRecField type families
+type family XConDeclRecField x
+type family XXConDeclRecField x
+
-- ---------------------------------------------------------------------
-- ConDeclField type families
type family XConDeclField x
diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs
index 994245f6e2308d2e2adc7fbf04776e84f74ad109..bdcb18a59a5c5d0ea203ab632a4be13ec1ae2e53 100644
--- a/compiler/Language/Haskell/Syntax/Type.hs
+++ b/compiler/Language/Haskell/Syntax/Type.hs
@@ -20,9 +20,8 @@ GHC.Hs.Type: Abstract syntax: user-defined types
-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*
module Language.Haskell.Syntax.Type (
- HsScaled(..),
- hsMult, hsScaledThing,
- HsArrow, HsArrowOf(..), XUnrestrictedArrow, XLinearArrow, XExplicitMult, XXArrow,
+ HsMultAnn, HsMultAnnOf(..),
+ XUnannotated, XLinearAnn, XExplicitMult, XXMultAnnOf,
HsType(..), LHsType, HsKind, LHsKind,
HsBndrVis(..), XBndrRequired, XBndrInvisible, XXBndrVis,
@@ -46,13 +45,12 @@ module Language.Haskell.Syntax.Type (
LHsTypeArg,
- LBangType, BangType,
- HsBang(..),
PromotionFlag(..), isPromoted,
- ConDeclField(..), LConDeclField,
+ HsConDeclRecField(..), LHsConDeclRecField,
HsConDetails(..),
+ HsConDeclField(..),
FieldOcc(..), LFieldOcc,
@@ -63,7 +61,7 @@ module Language.Haskell.Syntax.Type (
import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice )
-import Language.Haskell.Syntax.Basic ( HsBang(..) )
+import Language.Haskell.Syntax.Basic ( SrcStrictness, SrcUnpackedness )
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Specificity
@@ -103,25 +101,6 @@ instance NFData PromotionFlag where
rnf NotPromoted = ()
rnf IsPromoted = ()
-{-
-************************************************************************
-* *
-\subsection{Bang annotations}
-* *
-************************************************************************
--}
-
--- | Located Bang Type
-type LBangType pass = XRec pass (BangType pass)
-
--- | Bang Type
---
--- In the parser, strictness and packedness annotations bind more tightly
--- than docstrings. This means that when consuming a 'BangType' (and looking
--- for 'HsBangTy') we must be ready to peer behind a potential layer of
--- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example.
-type BangType pass = HsType pass -- Bangs are in the HsType data type
-
{-
************************************************************************
* *
@@ -860,7 +839,7 @@ data HsType pass
(LHsKind pass)
| HsFunTy (XFunTy pass)
- (HsArrow pass)
+ (HsMultAnn pass) -- multiplicty annotations, includes the arrow
(LHsType pass) -- function type
(LHsType pass)
@@ -908,12 +887,6 @@ data HsType pass
| HsDocTy (XDocTy pass)
(LHsType pass) (LHsDoc pass) -- A documented type
- | HsBangTy (XBangTy pass) -- Contains the SourceText in GHC passes.
- HsBang (LHsType pass) -- Bang-style type annotations
-
- | HsRecTy (XRecTy pass)
- [LConDeclField pass] -- Only in data type declarations
-
| HsExplicitListTy -- A promoted explicit list
(XExplicitListTy pass)
PromotionFlag -- whether explicitly promoted, for pretty printer
@@ -941,38 +914,31 @@ data HsTyLit pass
| HsCharTy (XCharTy pass) Char
| XTyLit !(XXTyLit pass)
-type HsArrow pass = HsArrowOf (LHsType pass) pass
+type HsMultAnn pass = HsMultAnnOf (LHsType (NoGhcTc pass)) pass
--- | Denotes the type of arrows in the surface language
-data HsArrowOf mult pass
- = HsUnrestrictedArrow !(XUnrestrictedArrow mult pass)
- -- ^ a -> b or a → b
+-- | Denotes multiplicity annotations in the surface language.
+-- The `mult` type argument is usually `LHsType (NoGhcTc pass)`, but when the annotation
+-- is part of a type used in a term, it is `LHsExpr pass`. See Note [Types in terms].
+data HsMultAnnOf mult pass
+ = HsUnannotated !(XUnannotated mult pass)
+ -- ^ a -> b or a → b or { nm :: a }
- | HsLinearArrow !(XLinearArrow mult pass)
- -- ^ a %1 -> b or a %1 → b, or a ⊸ b
+ | HsLinearAnn !(XLinearAnn mult pass)
+ -- ^ a %1 -> b or a %1 → b, or a ⊸ b, or { nm %1 :: a }
| HsExplicitMult !(XExplicitMult mult pass) !mult
- -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`!
+ -- ^ a %m -> b or a %m → b or { nm %m :: a }
+ -- (very much including `a %Many -> b`!
-- This is how the programmer wrote it). It is stored as an
-- `HsType` so as to preserve the syntax as written in the
-- program.
- | XArrow !(XXArrow mult pass)
-
-type family XUnrestrictedArrow mult p
-type family XLinearArrow mult p
-type family XExplicitMult mult p
-type family XXArrow mult p
-
--- | This is used in the syntax. In constructor declaration. It must keep the
--- arrow representation.
-data HsScaled pass a = HsScaled (HsArrow pass) a
-
-hsMult :: HsScaled pass a -> HsArrow pass
-hsMult (HsScaled m _) = m
+ | XMultAnnOf !(XXMultAnnOf mult pass)
-hsScaledThing :: HsScaled pass a -> a
-hsScaledThing (HsScaled _ t) = t
+type family XUnannotated mult p
+type family XLinearAnn mult p
+type family XExplicitMult mult p
+type family XXMultAnnOf mult p
{-
Note [Unit tuples]
@@ -1069,17 +1035,16 @@ data HsTupleSort = HsUnboxedTuple
| HsBoxedOrConstraintTuple
deriving Data
--- | Located Constructor Declaration Field
-type LConDeclField pass = XRec pass (ConDeclField pass)
+-- | Located Constructor Declaration Record Field
+type LHsConDeclRecField pass = XRec pass (HsConDeclRecField pass)
--- | Constructor Declaration Field
-data ConDeclField pass -- Record fields have Haddock docs on them
- = ConDeclField { cd_fld_ext :: XConDeclField pass,
- cd_fld_names :: [LFieldOcc pass],
- -- ^ See Note [ConDeclField pass]
- cd_fld_type :: LBangType pass,
- cd_fld_doc :: Maybe (LHsDoc pass)}
- | XConDeclField !(XXConDeclField pass)
+-- | Constructor Declaration Record Field
+data HsConDeclRecField pass
+ = HsConDeclRecField { cdrf_ext :: XConDeclRecField pass,
+ cdrf_names :: [LFieldOcc pass],
+ -- ^ See Note [FieldOcc pass]
+ cdrf_spec :: HsConDeclField pass }
+ | XConDeclRecField !(XXConDeclRecField pass)
-- | Describes the arguments to a data constructor. This is a common
-- representation for several constructor-related concepts, including:
@@ -1103,24 +1068,50 @@ data HsConDetails arg rec
| InfixCon arg arg -- p1 `C` p2
deriving Data
-{-
-Note [ConDeclField pass]
-~~~~~~~~~~~~~~~~~~~~~~~~~
+-- | Constructor declaration field specification, see Note [HsConDeclField on pass]
+data HsConDeclField pass
+ = CDF { cdf_ext :: XConDeclField pass
+ -- ^ Extension point
-A ConDeclField contains a list of field occurrences: these always
-include the field label as the user wrote it. After the renamer, it
-will additionally contain the identity of the selector function in the
-second component.
+ , cdf_unpack :: SrcUnpackedness
+ -- ^ UNPACK pragma if any
+ -- E.g. data T = MkT {-# UNPACK #-} Int
+ -- or data T where MtT :: {-# UNPACK #-} Int -> T
-Due to DuplicateRecordFields, the OccName of the selector function
-may have been mangled, which is why we keep the original field label
-separately. For example, when DuplicateRecordFields is enabled
+ , cdf_bang :: SrcStrictness
+ -- ^ User-specified strictness, if any
+ -- E.g. data T a = MkT !a
+ -- or data T a where MtT :: !a -> T a
- data T = MkT { x :: Int }
+ , cdf_multiplicity :: HsMultAnn pass
+ -- ^ User-specified multiplicity, if any
+ -- E.g. data T a = MkT { t %Many :: a }
+ -- or data T a where MtT :: a %1 -> T a
-gives
+ , cdf_type :: LHsType pass
+ -- ^ The type of the field
- ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }.
+ , cdf_doc :: Maybe (LHsDoc pass)
+ -- ^ Documentation for the field
+ -- F.e. this very piece of documentation
+ }
+
+{- Note [HsConDeclField on pass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+`HsConDeclField` is used to specify the type of a data single constructor argument for all of:
+* Haskell-98 style declarations (with prefix, infix or record syntax)
+ e.g. data T1 a = MkT (Maybe a) !Int
+* GADT-style declarations with arrow syntax
+ e.g. data T2 a where MkT :: Maybe a -> !Int -> T2 a
+* GADT-style declarations with record syntax
+ e.g. data T3 a where MkT :: { x :: Maybe a, y :: !Int } -> T3 a
+
+Each argument type is decorated with any user-defined
+ a) UNPACK pragma `cdf_unpack`
+ b) strictness annotation `cdf_bang`
+ c) multiplicity annotation `cdf_multiplicity`
+ In the case of Haskell-98 style declarations, this only applies to record syntax.
+ d) documentation `cdf_doc`
-}
-----------------------
@@ -1268,13 +1259,13 @@ type LFieldOcc pass = XRec pass (FieldOcc pass)
-- | Field Occurrence
--
-- Represents an *occurrence* of a field. This may or may not be a
--- binding occurrence (e.g. this type is used in 'ConDeclField' and
+-- binding occurrence (e.g. this type is used in 'HsConDeclRecField' and
-- 'RecordPatSynField' which bind their fields, but also in
-- 'HsRecField' for record construction and patterns, which do not).
--
-- We store both the 'RdrName' the user originally wrote, and after
-- the renamer we use the extension field to store the selector
--- function.
+-- function. See note [FieldOcc pass]
--
-- There is a wrinkle in that update field occurances are sometimes
-- ambiguous during the rename stage. See note
@@ -1292,6 +1283,23 @@ deriving instance (
, Eq (XXFieldOcc pass)
) => Eq (FieldOcc pass)
+{- Note [FieldOcc pass]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+The foLabel field of FieldOcc GhcRn contains the field name as the user wrote it.
+After the renamer, a FieldOcc GhcTc has
+- foExt field: A RdrName containing the original field label written by the user
+- foLabel field: An Id for the field selector, whose OccName may have been mangled
+ to give it a globally unique identity.
+
+For example, when DuplicateRecordFields is enabled
+
+ data T = MkT { x :: Int }
+
+gives
+
+ FieldOcc "x" $sel:x:MkT.
+-}
+
{-
************************************************************************
* *
diff --git a/docs/users_guide/9.14.1-notes.rst b/docs/users_guide/9.14.1-notes.rst
index 8c53f6d2719d731f51cd4197b795a557f7c8dfd5..112c04597a9de62362730d29270aae6fb22a36ba 100644
--- a/docs/users_guide/9.14.1-notes.rst
+++ b/docs/users_guide/9.14.1-notes.rst
@@ -69,6 +69,15 @@ Language
complaining about ambiguous type variables, GHC will consider that such type
variables are determined by the ``Coercible`` constraints they appear in.
+* With :extension:`LinearTypes` record fields can now be non-linear. This means that
+ the following record declaration is now valid:
+
+ ::
+
+ data Record = Rec { x %'Many :: Int, y :: Char }
+
+ This causes the constructor to have type ``Rec :: Int %'Many -> Char %1 -> Record``.
+
Compiler
~~~~~~~~
diff --git a/docs/users_guide/exts/linear_types.rst b/docs/users_guide/exts/linear_types.rst
index af515b5caed08512f22272eb0de813527fe6f8e9..e4c487d7760c2af1e95185ee2a9c3679ceaad527 100644
--- a/docs/users_guide/exts/linear_types.rst
+++ b/docs/users_guide/exts/linear_types.rst
@@ -250,7 +250,8 @@ therefore constructors appear to have regular function types.
Hence the linearity of type constructors is invisible when
``-XLinearTypes`` is off.
-Whether a data constructor field is linear or not can be customized using the GADT syntax. Given
+Whether a data constructor field is linear or not can be customized
+using GADT syntax or record syntax. Given
::
@@ -260,7 +261,16 @@ Whether a data constructor field is linear or not can be customized using the GA
the value ``MkT2 x y z`` can be constructed only if ``x`` is
unrestricted. On the other hand, a linear function which is matching
on ``MkT2 x y z`` must consume ``y`` and ``z`` exactly once, but there
-is no restriction on ``x``.
+is no restriction on ``x``. The same example can be written using record syntax:
+
+::
+
+ data T2 a b c = MkT2 { x %'Many :: a, y :: b, z :: c }
+
+Again, the constructor ``MkT2`` has type ``MkT2 :: a -> b %1 -> c %1 -> T2 a b c``.
+Note that by default record fields are linear, only unrestricted fields
+require a multiplicity annotation. The annotation has no effect on the record selectors.
+So ``x`` has type ``x :: T2 a b c -> a`` and similarly ``y`` has type ``y :: T2 a b c -> b``.
It is also possible to define a multiplicity-polymorphic field:
@@ -269,6 +279,12 @@ It is also possible to define a multiplicity-polymorphic field:
data T3 a m where
MkT3 :: a %m -> T3 a m
+or using record syntax:
+
+::
+
+ data T3 a m = MkT3 { x %m :: a }
+
While linear fields are generalized (``MkT1 :: forall {m} a. a %m -> T1 a``
in the previous example), multiplicity-polymorphic fields are not;
it is not possible to directly use ``MkT3`` as a function ``a -> T3 a One``.
diff --git a/libraries/ghc-internal/src/GHC/Internal/TypeError.hs b/libraries/ghc-internal/src/GHC/Internal/TypeError.hs
index a7b8aa9611388e0711176268f6cf305c3f1066ca..d11a313556a98c0da79544498971d47f6dd057a5 100644
--- a/libraries/ghc-internal/src/GHC/Internal/TypeError.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/TypeError.hs
@@ -162,7 +162,7 @@ Note [The Unsatisfiable representation-polymorphism trick]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The class method `unsatisfiableLifted :: forall (a::Type). Unsatisfiable msg => a`
works only for lifted types `a`. What if we want an unsatisfiable value of type
-`Int#`, say? The function `unsatisfiable` has a representation-polymoprhic type
+`Int#`, say? The function `unsatisfiable` has a representation-polymorphic type
unsatisfiable :: forall {rep} (msg :: ErrorMessage) (b :: TYPE rep).
Unsatisfiable msg => b
and yet is defined in terms of `unsatisfiableLifted`. How? By instantiating
diff --git a/testsuite/tests/ghc-api/exactprint/Test20239.stderr b/testsuite/tests/ghc-api/exactprint/Test20239.stderr
index d4c719c17440067418ebad426711b05ff4d4c13a..5b37691e2b5a7379fb8f308062133157995c8572 100644
--- a/testsuite/tests/ghc-api/exactprint/Test20239.stderr
+++ b/testsuite/tests/ghc-api/exactprint/Test20239.stderr
@@ -160,10 +160,17 @@
[]
(Nothing)
(PrefixCon
- [(HsScaled
- (HsLinearArrow
- (EpPct1
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -183,7 +190,8 @@
(EpaComments
[]))
(Unqual
- {OccName: Query})))))])
+ {OccName: Query}))))
+ (Nothing))])
(Nothing)))
,(L
(EpAnn
@@ -210,10 +218,17 @@
[]
(Nothing)
(PrefixCon
- [(HsScaled
- (HsLinearArrow
- (EpPct1
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -237,10 +252,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { Test20239.hs:7:62-63 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { Test20239.hs:7:62-63 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { Test20239.hs:7:51-60 })
@@ -371,7 +387,8 @@
(EpTok
(EpaSpan { Test20239.hs:7:84 })))
(HsBoxedOrConstraintTuple)
- [])))))))))))))])
+ []))))))))))))
+ (Nothing))])
(Nothing)))])
[]))))))]))
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
index 69073a1dbaf37727f5df84fadafe0a997a41d784..ff2c2b3fb9b4e1207f8b36b33d4e9c5ea63dac11 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
@@ -148,10 +148,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { T17544.hs:6:11-12 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { T17544.hs:6:11-12 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { T17544.hs:6:9 })
@@ -326,10 +327,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { T17544.hs:10:11-12 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { T17544.hs:10:11-12 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { T17544.hs:10:9 })
@@ -502,10 +504,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { T17544.hs:14:11-12 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { T17544.hs:14:11-12 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { T17544.hs:14:9 })
@@ -681,10 +684,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { T17544.hs:18:11-12 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { T17544.hs:18:11-12 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { T17544.hs:18:9 })
@@ -767,10 +771,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { T17544.hs:20:11-12 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { T17544.hs:20:11-12 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { T17544.hs:20:9 })
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
index 5caab76b718ec3cbc510390280a326e2d7e3f6f2..585e0b8a04b0f735254cf393db42ae0cdfaac8d9 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
@@ -244,11 +244,20 @@
(Nothing)
(PrefixConGADT
(NoExtField)
- [(HsScaled
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { T17544_kw.hs:19:21-22 })
- (NormalSyntax)))
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { T17544_kw.hs:19:21-22 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { T17544_kw.hs:19:18-19 })
@@ -263,7 +272,8 @@
(EpTok
(EpaSpan { T17544_kw.hs:19:19 })))
(HsBoxedOrConstraintTuple)
- [])))])
+ []))
+ (Nothing))])
(L
(EpAnn
(EpaSpan { T17544_kw.hs:19:24-26 })
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
index c8678bb4f893aea95079898fb8c1b5c0da317d44..4dd213079b1a3748018978d5360624b993c7fe38 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
@@ -108,10 +108,17 @@
[]
(Nothing)
(PrefixCon
- [(HsScaled
- (HsLinearArrow
- (EpPct1
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -131,7 +138,8 @@
(EpaComments
[]))
(Unqual
- {OccName: Int})))))])
+ {OccName: Int}))))
+ (Nothing))])
(Just
(L
{ T24221.hs:4:3-20 }
@@ -172,10 +180,17 @@
[]
(Nothing)
(PrefixCon
- [(HsScaled
- (HsLinearArrow
- (EpPct1
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -195,7 +210,8 @@
(EpaComments
[]))
(Unqual
- {OccName: Int})))))])
+ {OccName: Int}))))
+ (Nothing))])
(Just
(L
{ T24221.hs:6:3-20 }
@@ -234,10 +250,17 @@
[]
(Nothing)
(InfixCon
- (HsScaled
- (HsLinearArrow
- (EpPct1
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -257,11 +280,19 @@
(EpaComments
[]))
(Unqual
- {OccName: Int})))))
- (HsScaled
- (HsLinearArrow
- (EpPct1
+ {OccName: Int}))))
+ (Nothing))
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -281,7 +312,8 @@
(EpaComments
[]))
(Unqual
- {OccName: Bool}))))))
+ {OccName: Bool}))))
+ (Nothing)))
(Just
(L
{ T24221.hs:8:3-33 }
@@ -365,10 +397,17 @@
[]
(Nothing)
(InfixCon
- (HsScaled
- (HsLinearArrow
- (EpPct1
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -388,11 +427,19 @@
(EpaComments
[]))
(Unqual
- {OccName: Int})))))
- (HsScaled
- (HsLinearArrow
- (EpPct1
+ {OccName: Int}))))
+ (Nothing))
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -412,7 +459,8 @@
(EpaComments
[]))
(Unqual
- {OccName: Bool}))))))
+ {OccName: Bool}))))
+ (Nothing)))
(Just
(L
{ T24221.hs:12:15-45 }
@@ -496,10 +544,17 @@
[]
(Nothing)
(InfixCon
- (HsScaled
- (HsLinearArrow
- (EpPct1
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -508,43 +563,42 @@
[])
(EpaComments
[]))
- (HsDocTy
- (NoExtField)
+ (HsTyVar
+ (NoEpTok)
+ (NotPromoted)
(L
(EpAnn
(EpaSpan { T24221.hs:15:3-5 })
- (AnnListItem
+ (NameAnnTrailing
[])
(EpaComments
[]))
- (HsTyVar
- (NoEpTok)
- (NotPromoted)
- (L
- (EpAnn
- (EpaSpan { T24221.hs:15:3-5 })
- (NameAnnTrailing
- [])
- (EpaComments
- []))
- (Unqual
- {OccName: Int}))))
- (L
- { T24221.hs:15:10-26 }
- (WithHsDocIdentifiers
- (MultiLineDocString
- (HsDocStringPrevious)
- (:|
- (L
- { T24221.hs:15:14-26 }
- (HsDocStringChunk
- " Docs for Int"))
- []))
- [])))))
- (HsScaled
- (HsLinearArrow
- (EpPct1
+ (Unqual
+ {OccName: Int}))))
+ (Just
+ (L
+ { T24221.hs:15:10-26 }
+ (WithHsDocIdentifiers
+ (MultiLineDocString
+ (HsDocStringPrevious)
+ (:|
+ (L
+ { T24221.hs:15:14-26 }
+ (HsDocStringChunk
+ " Docs for Int"))
+ []))
+ []))))
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -553,39 +607,31 @@
[])
(EpaComments
[]))
- (HsDocTy
- (NoExtField)
+ (HsTyVar
+ (NoEpTok)
+ (NotPromoted)
(L
(EpAnn
(EpaSpan { T24221.hs:17:3-6 })
- (AnnListItem
+ (NameAnnTrailing
[])
(EpaComments
[]))
- (HsTyVar
- (NoEpTok)
- (NotPromoted)
- (L
- (EpAnn
- (EpaSpan { T24221.hs:17:3-6 })
- (NameAnnTrailing
- [])
- (EpaComments
- []))
- (Unqual
- {OccName: Bool}))))
- (L
- { T24221.hs:17:10-27 }
- (WithHsDocIdentifiers
- (MultiLineDocString
- (HsDocStringPrevious)
- (:|
- (L
- { T24221.hs:17:14-27 }
- (HsDocStringChunk
- " Docs for Bool"))
- []))
- []))))))
+ (Unqual
+ {OccName: Bool}))))
+ (Just
+ (L
+ { T24221.hs:17:10-27 }
+ (WithHsDocIdentifiers
+ (MultiLineDocString
+ (HsDocStringPrevious)
+ (:|
+ (L
+ { T24221.hs:17:14-27 }
+ (HsDocStringChunk
+ " Docs for Bool"))
+ []))
+ [])))))
(Just
(L
{ T24221.hs:16:10-40 }
@@ -669,10 +715,17 @@
[]
(Nothing)
(InfixCon
- (HsScaled
- (HsLinearArrow
- (EpPct1
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -681,43 +734,42 @@
[])
(EpaComments
[]))
- (HsDocTy
- (NoExtField)
+ (HsTyVar
+ (NoEpTok)
+ (NotPromoted)
(L
(EpAnn
(EpaSpan { T24221.hs:21:3-5 })
- (AnnListItem
+ (NameAnnTrailing
[])
(EpaComments
[]))
- (HsTyVar
- (NoEpTok)
- (NotPromoted)
- (L
- (EpAnn
- (EpaSpan { T24221.hs:21:3-5 })
- (NameAnnTrailing
- [])
- (EpaComments
- []))
- (Unqual
- {OccName: Int}))))
- (L
- { T24221.hs:20:3-19 }
- (WithHsDocIdentifiers
- (MultiLineDocString
- (HsDocStringNext)
- (:|
- (L
- { T24221.hs:20:7-19 }
- (HsDocStringChunk
- " Docs for Int"))
- []))
- [])))))
- (HsScaled
- (HsLinearArrow
- (EpPct1
+ (Unqual
+ {OccName: Int}))))
+ (Just
+ (L
+ { T24221.hs:20:3-19 }
+ (WithHsDocIdentifiers
+ (MultiLineDocString
+ (HsDocStringNext)
+ (:|
+ (L
+ { T24221.hs:20:7-19 }
+ (HsDocStringChunk
+ " Docs for Int"))
+ []))
+ []))))
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -726,39 +778,31 @@
[])
(EpaComments
[]))
- (HsDocTy
- (NoExtField)
+ (HsTyVar
+ (NoEpTok)
+ (NotPromoted)
(L
(EpAnn
(EpaSpan { T24221.hs:25:3-6 })
- (AnnListItem
+ (NameAnnTrailing
[])
(EpaComments
[]))
- (HsTyVar
- (NoEpTok)
- (NotPromoted)
- (L
- (EpAnn
- (EpaSpan { T24221.hs:25:3-6 })
- (NameAnnTrailing
- [])
- (EpaComments
- []))
- (Unqual
- {OccName: Bool}))))
- (L
- { T24221.hs:24:3-20 }
- (WithHsDocIdentifiers
- (MultiLineDocString
- (HsDocStringNext)
- (:|
- (L
- { T24221.hs:24:7-20 }
- (HsDocStringChunk
- " Docs for Bool"))
- []))
- []))))))
+ (Unqual
+ {OccName: Bool}))))
+ (Just
+ (L
+ { T24221.hs:24:3-20 }
+ (WithHsDocIdentifiers
+ (MultiLineDocString
+ (HsDocStringNext)
+ (:|
+ (L
+ { T24221.hs:24:7-20 }
+ (HsDocStringChunk
+ " Docs for Bool"))
+ []))
+ [])))))
(Just
(L
{ T24221.hs:22:3-33 }
@@ -865,10 +909,8 @@
(EpaSpan { T24221.hs:29:10 })))])
(EpaComments
[]))
- (ConDeclField
- (EpUniTok
- (EpaSpan { T24221.hs:28:15-16 })
- (NormalSyntax))
+ (HsConDeclRecField
+ (NoExtField)
[(L
(EpAnn
(EpaSpan { T24221.hs:28:12-13 })
@@ -887,38 +929,52 @@
[]))
(Unqual
{OccName: a6}))))]
- (L
- (EpAnn
- (EpaSpan { T24221.hs:28:18-20 })
- (AnnListItem
- [])
- (EpaComments
- []))
- (HsTyVar
- (NoEpTok)
- (NotPromoted)
- (L
- (EpAnn
- (EpaSpan { T24221.hs:28:18-20 })
- (NameAnnTrailing
- [])
- (EpaComments
- []))
- (Unqual
- {OccName: Int}))))
- (Just
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
+ (EpUniTok
+ (EpaSpan { T24221.hs:28:15-16 })
+ (NormalSyntax))))
(L
- { T24221.hs:28:24-39 }
- (WithHsDocIdentifiers
- (MultiLineDocString
- (HsDocStringPrevious)
- (:|
- (L
- { T24221.hs:28:28-39 }
- (HsDocStringChunk
- " Docs for a6"))
- []))
- [])))))
+ (EpAnn
+ (EpaSpan { T24221.hs:28:18-20 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ (NoEpTok)
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { T24221.hs:28:18-20 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Int}))))
+ (Just
+ (L
+ { T24221.hs:28:24-39 }
+ (WithHsDocIdentifiers
+ (MultiLineDocString
+ (HsDocStringPrevious)
+ (:|
+ (L
+ { T24221.hs:28:28-39 }
+ (HsDocStringChunk
+ " Docs for a6"))
+ []))
+ []))))))
,(L
(EpAnn
(EpaSpan { T24221.hs:29:12-20 })
@@ -926,10 +982,8 @@
[])
(EpaComments
[]))
- (ConDeclField
- (EpUniTok
- (EpaSpan { T24221.hs:29:15-16 })
- (NormalSyntax))
+ (HsConDeclRecField
+ (NoExtField)
[(L
(EpAnn
(EpaSpan { T24221.hs:29:12-13 })
@@ -948,38 +1002,52 @@
[]))
(Unqual
{OccName: b6}))))]
- (L
- (EpAnn
- (EpaSpan { T24221.hs:29:18-20 })
- (AnnListItem
- [])
- (EpaComments
- []))
- (HsTyVar
- (NoEpTok)
- (NotPromoted)
- (L
- (EpAnn
- (EpaSpan { T24221.hs:29:18-20 })
- (NameAnnTrailing
- [])
- (EpaComments
- []))
- (Unqual
- {OccName: Int}))))
- (Just
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
+ (EpUniTok
+ (EpaSpan { T24221.hs:29:15-16 })
+ (NormalSyntax))))
(L
- { T24221.hs:29:24-39 }
- (WithHsDocIdentifiers
- (MultiLineDocString
- (HsDocStringPrevious)
- (:|
- (L
- { T24221.hs:29:28-39 }
- (HsDocStringChunk
- " Docs for b6"))
- []))
- [])))))]))
+ (EpAnn
+ (EpaSpan { T24221.hs:29:18-20 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ (NoEpTok)
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { T24221.hs:29:18-20 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Int}))))
+ (Just
+ (L
+ { T24221.hs:29:24-39 }
+ (WithHsDocIdentifiers
+ (MultiLineDocString
+ (HsDocStringPrevious)
+ (:|
+ (L
+ { T24221.hs:29:28-39 }
+ (HsDocStringChunk
+ " Docs for b6"))
+ []))
+ []))))))]))
(Nothing)))])
[]))))
,(L
@@ -1074,10 +1142,8 @@
(EpaSpan { T24221.hs:34:5 })))])
(EpaComments
[]))
- (ConDeclField
- (EpUniTok
- (EpaSpan { T24221.hs:33:10-11 })
- (NormalSyntax))
+ (HsConDeclRecField
+ (NoExtField)
[(L
(EpAnn
(EpaSpan { T24221.hs:33:7-8 })
@@ -1096,38 +1162,52 @@
[]))
(Unqual
{OccName: a7}))))]
- (L
- (EpAnn
- (EpaSpan { T24221.hs:33:13-15 })
- (AnnListItem
- [])
- (EpaComments
- []))
- (HsTyVar
- (NoEpTok)
- (NotPromoted)
- (L
- (EpAnn
- (EpaSpan { T24221.hs:33:13-15 })
- (NameAnnTrailing
- [])
- (EpaComments
- []))
- (Unqual
- {OccName: Int}))))
- (Just
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
+ (EpUniTok
+ (EpaSpan { T24221.hs:33:10-11 })
+ (NormalSyntax))))
(L
- { T24221.hs:33:20-35 }
- (WithHsDocIdentifiers
- (MultiLineDocString
- (HsDocStringPrevious)
- (:|
- (L
- { T24221.hs:33:24-35 }
- (HsDocStringChunk
- " Docs for a7"))
- []))
- [])))))
+ (EpAnn
+ (EpaSpan { T24221.hs:33:13-15 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ (NoEpTok)
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { T24221.hs:33:13-15 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Int}))))
+ (Just
+ (L
+ { T24221.hs:33:20-35 }
+ (WithHsDocIdentifiers
+ (MultiLineDocString
+ (HsDocStringPrevious)
+ (:|
+ (L
+ { T24221.hs:33:24-35 }
+ (HsDocStringChunk
+ " Docs for a7"))
+ []))
+ []))))))
,(L
(EpAnn
(EpaSpan { T24221.hs:34:7-15 })
@@ -1135,10 +1215,8 @@
[])
(EpaComments
[]))
- (ConDeclField
- (EpUniTok
- (EpaSpan { T24221.hs:34:10-11 })
- (NormalSyntax))
+ (HsConDeclRecField
+ (NoExtField)
[(L
(EpAnn
(EpaSpan { T24221.hs:34:7-8 })
@@ -1157,38 +1235,52 @@
[]))
(Unqual
{OccName: b7}))))]
- (L
- (EpAnn
- (EpaSpan { T24221.hs:34:13-15 })
- (AnnListItem
- [])
- (EpaComments
- []))
- (HsTyVar
- (NoEpTok)
- (NotPromoted)
- (L
- (EpAnn
- (EpaSpan { T24221.hs:34:13-15 })
- (NameAnnTrailing
- [])
- (EpaComments
- []))
- (Unqual
- {OccName: Int}))))
- (Just
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
+ (EpUniTok
+ (EpaSpan { T24221.hs:34:10-11 })
+ (NormalSyntax))))
(L
- { T24221.hs:34:20-35 }
- (WithHsDocIdentifiers
- (MultiLineDocString
- (HsDocStringPrevious)
- (:|
- (L
- { T24221.hs:34:24-35 }
- (HsDocStringChunk
- " Docs for b7"))
- []))
- [])))))]))
+ (EpAnn
+ (EpaSpan { T24221.hs:34:13-15 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ (NoEpTok)
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { T24221.hs:34:13-15 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Int}))))
+ (Just
+ (L
+ { T24221.hs:34:20-35 }
+ (WithHsDocIdentifiers
+ (MultiLineDocString
+ (HsDocStringPrevious)
+ (:|
+ (L
+ { T24221.hs:34:24-35 }
+ (HsDocStringChunk
+ " Docs for b7"))
+ []))
+ []))))))]))
(Just
(L
{ T24221.hs:32:10-29 }
@@ -1295,10 +1387,8 @@
(EpaSpan { T24221.hs:40:14 })))])
(EpaComments
[]))
- (ConDeclField
- (EpUniTok
- (EpaSpan { T24221.hs:40:8-9 })
- (NormalSyntax))
+ (HsConDeclRecField
+ (NoExtField)
[(L
(EpAnn
(EpaSpan { T24221.hs:40:5-6 })
@@ -1317,38 +1407,52 @@
[]))
(Unqual
{OccName: a8}))))]
- (L
- (EpAnn
- (EpaSpan { T24221.hs:40:11-13 })
- (AnnListItem
- [])
- (EpaComments
- []))
- (HsTyVar
- (NoEpTok)
- (NotPromoted)
- (L
- (EpAnn
- (EpaSpan { T24221.hs:40:11-13 })
- (NameAnnTrailing
- [])
- (EpaComments
- []))
- (Unqual
- {OccName: Int}))))
- (Just
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
+ (EpUniTok
+ (EpaSpan { T24221.hs:40:8-9 })
+ (NormalSyntax))))
(L
- { T24221.hs:39:5-20 }
- (WithHsDocIdentifiers
- (MultiLineDocString
- (HsDocStringNext)
- (:|
- (L
- { T24221.hs:39:9-20 }
- (HsDocStringChunk
- " Docs for a8"))
- []))
- [])))))
+ (EpAnn
+ (EpaSpan { T24221.hs:40:11-13 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ (NoEpTok)
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { T24221.hs:40:11-13 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Int}))))
+ (Just
+ (L
+ { T24221.hs:39:5-20 }
+ (WithHsDocIdentifiers
+ (MultiLineDocString
+ (HsDocStringNext)
+ (:|
+ (L
+ { T24221.hs:39:9-20 }
+ (HsDocStringChunk
+ " Docs for a8"))
+ []))
+ []))))))
,(L
(EpAnn
(EpaSpan { T24221.hs:42:5-13 })
@@ -1356,10 +1460,8 @@
[])
(EpaComments
[]))
- (ConDeclField
- (EpUniTok
- (EpaSpan { T24221.hs:42:8-9 })
- (NormalSyntax))
+ (HsConDeclRecField
+ (NoExtField)
[(L
(EpAnn
(EpaSpan { T24221.hs:42:5-6 })
@@ -1378,38 +1480,52 @@
[]))
(Unqual
{OccName: b8}))))]
- (L
- (EpAnn
- (EpaSpan { T24221.hs:42:11-13 })
- (AnnListItem
- [])
- (EpaComments
- []))
- (HsTyVar
- (NoEpTok)
- (NotPromoted)
- (L
- (EpAnn
- (EpaSpan { T24221.hs:42:11-13 })
- (NameAnnTrailing
- [])
- (EpaComments
- []))
- (Unqual
- {OccName: Int}))))
- (Just
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
+ (EpUniTok
+ (EpaSpan { T24221.hs:42:8-9 })
+ (NormalSyntax))))
(L
- { T24221.hs:41:5-20 }
- (WithHsDocIdentifiers
- (MultiLineDocString
- (HsDocStringNext)
- (:|
- (L
- { T24221.hs:41:9-20 }
- (HsDocStringChunk
- " Docs for b8"))
- []))
- [])))))]))
+ (EpAnn
+ (EpaSpan { T24221.hs:42:11-13 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ (NoEpTok)
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { T24221.hs:42:11-13 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Int}))))
+ (Just
+ (L
+ { T24221.hs:41:5-20 }
+ (WithHsDocIdentifiers
+ (MultiLineDocString
+ (HsDocStringNext)
+ (:|
+ (L
+ { T24221.hs:41:9-20 }
+ (HsDocStringChunk
+ " Docs for b8"))
+ []))
+ []))))))]))
(Just
(L
{ T24221.hs:37:3-22 }
diff --git a/testsuite/tests/linear/should_compile/NonLinearRecord.hs b/testsuite/tests/linear/should_compile/NonLinearRecord.hs
new file mode 100644
index 0000000000000000000000000000000000000000..42f7497f0e287d2d2a4953e8a88d13a961ece005
--- /dev/null
+++ b/testsuite/tests/linear/should_compile/NonLinearRecord.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE LinearTypes, DataKinds #-}
+module NonLinearRecord where
+
+import GHC.Exts (Multiplicity(..))
+
+data C m = C { linC %1 :: Int, urC %Many :: Char, varC %m :: String, noC :: Bool }
+
+data G mult where
+ G :: { linG %1 :: Int, urG %Many :: Char, varG %m :: String, noG :: Bool } -> G m
+
+testC :: Int %1 -> Char -> String -> Bool %1 -> C Many
+testC w x y z = C w x y z
+
+testCR :: Int %1 -> Char -> String -> Bool %1 -> C Many
+testCR w x y z = C { linC = w, urC = x, varC = y, noC = z }
+
+testG :: Int %1 -> Char -> String %1 -> Bool %1 -> G One
+testG w x y z = G w x y z
+
+testGR :: Int %1 -> Char -> String %1 -> Bool %1 -> G One
+testGR w x y z = G { linG = w, urG = x, varG = y, noG = z }
diff --git a/testsuite/tests/linear/should_compile/all.T b/testsuite/tests/linear/should_compile/all.T
index 0aeb55bcaa6b57935f90e3c73494b20438bee22d..ff7e64016a355567cee0756125cf042833d1bef1 100644
--- a/testsuite/tests/linear/should_compile/all.T
+++ b/testsuite/tests/linear/should_compile/all.T
@@ -49,3 +49,4 @@ test('LinearListComprehension', normal, compile, ['-dlinear-core-lint'])
test('OmitFieldPat', normal, compile, ['-dcore-lint'])
test('T25515', normal, compile, ['-dcore-lint'])
test('T25428', normal, compile, [''])
+test('NonLinearRecord', normal, compile, [''])
diff --git a/testsuite/tests/linear/should_fail/LinearRecFieldMany.hs b/testsuite/tests/linear/should_fail/LinearRecFieldMany.hs
new file mode 100644
index 0000000000000000000000000000000000000000..0d4fa9aaf4f42d6f0fa32759c2be6500dfc16947
--- /dev/null
+++ b/testsuite/tests/linear/should_fail/LinearRecFieldMany.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE LinearTypes, DataKinds #-}
+module LinearRecFieldMany where
+
+import GHC.Exts (Multiplicity(..))
+
+data C = C { urC %'Many :: Int }
+
+test :: Int %1 -> C
+test x = C x
+
+test2 :: Int %1 -> C
+test2 x = C { urC = x }
diff --git a/testsuite/tests/linear/should_fail/LinearRecFieldMany.stderr b/testsuite/tests/linear/should_fail/LinearRecFieldMany.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..d37e78f198de9002c15c380f561845e9f488d251
--- /dev/null
+++ b/testsuite/tests/linear/should_fail/LinearRecFieldMany.stderr
@@ -0,0 +1,10 @@
+LinearRecFieldMany.hs:9:6: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘test’: test x = C x
+
+LinearRecFieldMany.hs:12:7: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘test2’: test2 x = C {urC = x}
+
diff --git a/testsuite/tests/linear/should_fail/all.T b/testsuite/tests/linear/should_fail/all.T
index aaac0adebb390f0555f567a444e4abd2cfac8408..3495c6fc6b8e8ae65812eb20e972519d7702286b 100644
--- a/testsuite/tests/linear/should_fail/all.T
+++ b/testsuite/tests/linear/should_fail/all.T
@@ -34,6 +34,7 @@ test('LinearFFI', normal, compile_fail, [''])
test('LinearTHFail', normal, compile_fail, [''])
test('LinearTHFail2', normal, compile_fail, [''])
test('LinearTHFail3', normal, compile_fail, [''])
+test('LinearRecFieldMany', normal, compile_fail, [''])
test('T18888', normal, compile_fail, [''])
test('T18888_datakinds', normal, compile_fail, [''])
test('T19120', normal, compile_fail, [''])
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index c512545deecfae2d7ad608142e8dc487c91d066a..75195135c7075e6c478896926541089c7cd4d96b 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -171,10 +171,17 @@
[]
(Nothing)
(PrefixCon
- [(HsScaled
- (HsLinearArrow
- (EpPct1
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -194,7 +201,8 @@
(EpaComments
[]))
(Unqual
- {OccName: Peano})))))])
+ {OccName: Peano}))))
+ (Nothing))])
(Nothing)))])
[]))))
,(L
@@ -242,10 +250,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpParsedAst.hs:9:20-21 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:9:20-21 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:9:16-18 })
@@ -825,10 +834,17 @@
[]
(Nothing)
(PrefixCon
- [(HsScaled
- (HsLinearArrow
- (EpPct1
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
(NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpColon
(NoEpUniTok)))
(L
(EpAnn
@@ -889,7 +905,8 @@
(EpaComments
[]))
(Unqual
- {OccName: a})))))))))])
+ {OccName: a}))))))))
+ (Nothing))])
(Nothing)))])
[]))))
,(L
@@ -937,10 +954,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpParsedAst.hs:17:14-15 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:17:14-15 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:17:12 })
@@ -969,10 +987,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpParsedAst.hs:17:29-30 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:17:29-30 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:17:17-27 })
@@ -995,10 +1014,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpParsedAst.hs:17:20-21 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:17:20-21 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:17:18 })
@@ -1381,10 +1401,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpParsedAst.hs:18:33-34 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:18:33-34 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:18:31 })
@@ -1513,10 +1534,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpParsedAst.hs:21:22-23 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:21:22-23 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:21:20 })
@@ -1545,10 +1567,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpParsedAst.hs:21:27-28 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:21:27-28 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:21:25 })
@@ -1670,10 +1693,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpParsedAst.hs:22:30-31 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:22:30-31 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:22:28 })
@@ -1742,10 +1766,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpParsedAst.hs:22:54-55 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:22:54-55 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:22:42-52 })
@@ -1768,10 +1793,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpParsedAst.hs:22:45-46 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:22:45-46 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:22:43 })
@@ -1867,11 +1893,20 @@
(Nothing)
(PrefixConGADT
(NoExtField)
- [(HsScaled
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpParsedAst.hs:23:36-37 })
- (NormalSyntax)))
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:23:36-37 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:23:10-34 })
@@ -1939,10 +1974,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpParsedAst.hs:23:27-28 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpParsedAst.hs:23:27-28 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:23:22-25 })
@@ -2036,7 +2072,8 @@
(EpaComments
[]))
(Unqual
- {OccName: xx})))))))))))))])
+ {OccName: xx}))))))))))))
+ (Nothing))])
(L
(EpAnn
(EpaSpan { DumpParsedAst.hs:23:39-45 })
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index 8b072c1a45f4c3e84afccbe9e2063e6d3ee18f0b..4cbb95c44c85b07fc9c5d37bbfe6cfb73b5ec29a 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -220,8 +220,16 @@
[]
(Nothing)
(PrefixCon
- [(HsScaled
- (HsLinearArrow
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -240,7 +248,8 @@
[])
(EpaComments
[]))
- {Name: DumpRenamedAst.Peano}))))])
+ {Name: DumpRenamedAst.Peano})))
+ (Nothing))])
(Nothing)))])
[])))]
[]
@@ -638,7 +647,7 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -746,7 +755,7 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -775,7 +784,7 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -893,7 +902,7 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -957,7 +966,7 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -979,7 +988,7 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -1068,8 +1077,16 @@
(Nothing)
(PrefixConGADT
(NoExtField)
- [(HsScaled
- (HsUnrestrictedArrow
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -1134,7 +1151,7 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -1225,7 +1242,8 @@
[])
(EpaComments
[]))
- {Name: xx}))))))))))))])
+ {Name: xx})))))))))))
+ (Nothing))])
(L
(EpAnn
(EpaSpan { DumpRenamedAst.hs:20:39-45 })
@@ -1439,8 +1457,16 @@
[]
(Nothing)
(PrefixCon
- [(HsScaled
- (HsLinearArrow
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -1497,7 +1523,8 @@
[])
(EpaComments
[]))
- {Name: a}))))))))])
+ {Name: a})))))))
+ (Nothing))])
(Nothing)))])
[])))]
[]
@@ -1809,7 +1836,7 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -1913,7 +1940,7 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -1942,7 +1969,7 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -1964,7 +1991,7 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
diff --git a/testsuite/tests/parser/should_compile/DumpSemis.stderr b/testsuite/tests/parser/should_compile/DumpSemis.stderr
index 38ae90e49c97355004eddbe0383133862195a7fb..61a053f1a48efb2bb4ccb82c3988c501b2d9956d 100644
--- a/testsuite/tests/parser/should_compile/DumpSemis.stderr
+++ b/testsuite/tests/parser/should_compile/DumpSemis.stderr
@@ -1495,10 +1495,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpSemis.hs:29:18-19 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpSemis.hs:29:18-19 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpSemis.hs:29:12-16 })
@@ -1711,10 +1712,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { DumpSemis.hs:31:27-28 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { DumpSemis.hs:31:27-28 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { DumpSemis.hs:31:25 })
diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr
index 0fd2135cf6a28cfe3e04fca1eeb3a726061aaa87..b2b1dcf83443d3e52d34859a394b408d78d6e01b 100644
--- a/testsuite/tests/parser/should_compile/KindSigs.stderr
+++ b/testsuite/tests/parser/should_compile/KindSigs.stderr
@@ -827,10 +827,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { KindSigs.hs:22:22-23 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { KindSigs.hs:22:22-23 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { KindSigs.hs:22:8-20 })
@@ -902,10 +903,11 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { KindSigs.hs:22:30-31 })
- (NormalSyntax)))
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { KindSigs.hs:22:30-31 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { KindSigs.hs:22:25-28 })
diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr
index 04398316090b203fb82f59fdfd4b6ebc7ff4d757..7a229e1606054ca8968776b8227c35f8b886b61f 100644
--- a/testsuite/tests/parser/should_compile/T14189.stderr
+++ b/testsuite/tests/parser/should_compile/T14189.stderr
@@ -77,8 +77,16 @@
[]
(Nothing)
(PrefixCon
- [(HsScaled
- (HsLinearArrow
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
(NoExtField))
(L
(EpAnn
@@ -97,7 +105,8 @@
[])
(EpaComments
[]))
- {Name: GHC.Internal.Types.Int}))))])
+ {Name: GHC.Internal.Types.Int})))
+ (Nothing))])
(Nothing)))
,(L
(EpAnn
@@ -166,8 +175,8 @@
[])
(EpaComments
[]))
- (ConDeclField
- (NoEpUniTok)
+ (HsConDeclRecField
+ (NoExtField)
[(L
(EpAnn
(EpaSpan { T14189.hs:6:33 })
@@ -186,25 +195,36 @@
(EpaComments
[]))
{Name: T14189.f})))]
- (L
- (EpAnn
- (EpaSpan { T14189.hs:6:38-40 })
- (AnnListItem
- [])
- (EpaComments
- []))
- (HsTyVar
- (NoEpTok)
- (NotPromoted)
- (L
- (EpAnn
- (EpaSpan { T14189.hs:6:38-40 })
- (NameAnnTrailing
- [])
- (EpaComments
- []))
- {Name: GHC.Internal.Types.Int})))
- (Nothing)))]))
+ (CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (NoExtField))
+ (L
+ (EpAnn
+ (EpaSpan { T14189.hs:6:38-40 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ (NoEpTok)
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { T14189.hs:6:38-40 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ {Name: GHC.Internal.Types.Int})))
+ (Nothing))))]))
(Nothing)))])
[])))]
[]
diff --git a/testsuite/tests/parser/should_compile/T15279.stderr b/testsuite/tests/parser/should_compile/T15279.stderr
index c3d28abb030e6fb983b222aa7b4726e9cbbc5750..838ecb29a41e8f8101bd44d7c041a2a5f391815a 100644
--- a/testsuite/tests/parser/should_compile/T15279.stderr
+++ b/testsuite/tests/parser/should_compile/T15279.stderr
@@ -84,7 +84,7 @@
[]))
(HsFunTy
(NoExtField)
- (HsUnrestrictedArrow
+ (HsUnannotated
(EpUniTok
(EpaSpan { T15279.hs:5:13-14 })
(NormalSyntax)))
diff --git a/testsuite/tests/parser/should_fail/T3811c.stderr b/testsuite/tests/parser/should_fail/T3811c.stderr
index f6ea865149178cf8fde751025c2fb5c784952eb6..9c91612b63e2c6195a77ca9a68de46a7394f30cd 100644
--- a/testsuite/tests/parser/should_fail/T3811c.stderr
+++ b/testsuite/tests/parser/should_fail/T3811c.stderr
@@ -1,7 +1,5 @@
-
-T3811c.hs:6:10: error: [GHC-53946]
- • Illegal head of an instance declaration: ‘!Show D’.
- Instance heads must be of the form
- C ty_1 ... ty_n
- where ‘C’ is a class.
+T3811c.hs:6:10: error: [GHC-18932]
+ • Unexpected strictness (!) annotation: !Show
+ strictness (!) annotation can only appear on the arguments of a data constructor type
• In an instance declaration
+
diff --git a/testsuite/tests/parser/should_fail/unpack_inside_type.stderr b/testsuite/tests/parser/should_fail/unpack_inside_type.stderr
index be0ca667afb9e483bc8fb9aa7281dff4347012bb..41d52ed70076e4176d81c681fdda5611f1830176 100644
--- a/testsuite/tests/parser/should_fail/unpack_inside_type.stderr
+++ b/testsuite/tests/parser/should_fail/unpack_inside_type.stderr
@@ -1,7 +1,5 @@
-
unpack_inside_type.hs:3:25: error: [GHC-18932]
• Unexpected UNPACK annotation: {-# UNPACK #-}Int
- UNPACK annotation cannot appear nested inside a type
- • In the first argument of ‘Maybe’, namely ‘{-# UNPACK #-}Int’
- In the type ‘Maybe {-# UNPACK #-}Int’
- In the definition of data constructor ‘T’
+ UNPACK annotation can only appear on the arguments of a data constructor type
+ • In the definition of data constructor ‘T’
+
diff --git a/testsuite/tests/printer/T18791.stderr b/testsuite/tests/printer/T18791.stderr
index f96af5f2c05ba8c9d78a8a25b636d7e67897b5a3..b31170992a4446de63c12dc3702c605fbaf61ad5 100644
--- a/testsuite/tests/printer/T18791.stderr
+++ b/testsuite/tests/printer/T18791.stderr
@@ -118,11 +118,20 @@
(Nothing)
(PrefixConGADT
(NoExtField)
- [(HsScaled
- (HsUnrestrictedArrow
- (EpUniTok
- (EpaSpan { T18791.hs:5:14-15 })
- (NormalSyntax)))
+ [(CDF
+ ((,)
+ ((,,)
+ (EpaDelta { <no location info> } (SameLine 0) [])
+ (NoEpTok)
+ (EpaDelta { <no location info> } (SameLine 0) []))
+ (NoSourceText))
+ (NoSrcUnpack)
+ (NoSrcStrict)
+ (HsUnannotated
+ (EpArrow
+ (EpUniTok
+ (EpaSpan { T18791.hs:5:14-15 })
+ (NormalSyntax))))
(L
(EpAnn
(EpaSpan { T18791.hs:5:10-12 })
@@ -141,7 +150,8 @@
(EpaComments
[]))
(Unqual
- {OccName: Int})))))])
+ {OccName: Int}))))
+ (Nothing))])
(L
(EpAnn
(EpaSpan { T18791.hs:5:17 })
diff --git a/testsuite/tests/rename/should_fail/T22478b.stderr b/testsuite/tests/rename/should_fail/T22478b.stderr
index dbcb1c966ca249d950667352bf34c62d12f7d8c8..78bc4b3d4659dd5d145e6faafff7dd6e0f826c48 100644
--- a/testsuite/tests/rename/should_fail/T22478b.stderr
+++ b/testsuite/tests/rename/should_fail/T22478b.stderr
@@ -5,8 +5,8 @@ T22478b.hs:16:18: error: [GHC-10498]
• In an equation for ‘fOutOfOrder’
T22478b.hs:18:14: error: [GHC-18932]
- • Unexpected strictness annotation: Int
- strictness annotation cannot appear nested inside a type
+ • Unexpected strictness (!) annotation: !Int
+ strictness (!) annotation can only appear on the arguments of a data constructor type
• In a type argument in a pattern
T22478b.hs:21:54: error: [GHC-76037]
diff --git a/testsuite/tests/typecheck/should_fail/T7210.stderr b/testsuite/tests/typecheck/should_fail/T7210.stderr
index 3a6754122d867101466f7d4a4bd639af0209222b..7e4f9f2e86fd40329396a35436c596d0833a8934 100644
--- a/testsuite/tests/typecheck/should_fail/T7210.stderr
+++ b/testsuite/tests/typecheck/should_fail/T7210.stderr
@@ -1,7 +1,5 @@
T7210.hs:5:19: error: [GHC-18932]
- • Unexpected strictness annotation: !IntMap
- strictness annotation cannot appear nested inside a type
- • In the type ‘!IntMap Int’
- In the definition of data constructor ‘C’
- In the data type declaration for ‘T’
+ • Unexpected strictness (!) annotation: !IntMap
+ strictness (!) annotation can only appear on the arguments of a data constructor type
+ • In the definition of data constructor ‘C’
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 451cb7cde848167f9b1316f836a677b55e1cefd2..ca8537a96161732bbb870a3d35642ce1fcfd5c5a 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -808,9 +808,6 @@ markLensBracketsC' a l =
ListNone -> return (set l ListNone a)
-- -------------------------------------
--- markEpTokenM :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
--- => Maybe (EpToken tok) -> EP w m (Maybe (EpToken tok))
-
markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
=> EpToken tok -> EP w m (EpToken tok)
markEpToken NoEpTok = return NoEpTok
@@ -836,25 +833,6 @@ markEpUniToken (EpUniTok aa isUnicode) = do
-- ---------------------------------------------------------------------
-markArrow :: (Monad m, Monoid w, ExactPrint a) => HsArrowOf a GhcPs -> EP w m (HsArrowOf a GhcPs)
-markArrow (HsUnrestrictedArrow arr) = do
- arr' <- markEpUniToken arr
- return (HsUnrestrictedArrow arr')
-markArrow (HsLinearArrow (EpPct1 pct1 arr)) = do
- pct1' <- markEpToken pct1
- arr' <- markEpUniToken arr
- return (HsLinearArrow (EpPct1 pct1' arr'))
-markArrow (HsLinearArrow (EpLolly arr)) = do
- arr' <- markEpToken arr
- return (HsLinearArrow (EpLolly arr'))
-markArrow (HsExplicitMult (pct, arr) t) = do
- pct' <- markEpToken pct
- t' <- markAnnotated t
- arr' <- markEpUniToken arr
- return (HsExplicitMult (pct', arr') t')
-
--- ---------------------------------------------------------------------
-
markAnnOpen' :: (Monad m, Monoid w)
=> Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation)
markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt
@@ -2313,8 +2291,7 @@ instance ExactPrint (HsBind GhcPs) where
return (FunBind x fun_id' matches')
exact (PatBind x pat q grhss) = do
- q' <- markAnnotated q
- pat' <- markAnnotated pat
+ (q', pat') <- markMultAnnOf q (markAnnotated pat)
grhss' <- markAnnotated grhss
return (PatBind x pat' q' grhss')
exact (PatSynBind x bind) = do
@@ -2323,19 +2300,6 @@ instance ExactPrint (HsBind GhcPs) where
exact x = error $ "HsBind: exact for " ++ showAst x
-instance ExactPrint (HsMultAnn GhcPs) where
- getAnnotationEntry _ = NoEntryVal
- setAnnotationAnchor a _ _ _ = a
-
- exact (HsNoMultAnn x) = return (HsNoMultAnn x)
- exact (HsPct1Ann tok) = do
- tok' <- markEpToken tok
- return (HsPct1Ann tok')
- exact (HsMultAnn tok ty) = do
- tok' <- markEpToken tok
- ty' <- markAnnotated ty
- return (HsMultAnn tok' ty')
-
-- ---------------------------------------------------------------------
instance ExactPrint (PatSynBind GhcPs GhcPs) where
@@ -3147,8 +3111,7 @@ instance ExactPrint (HsExpr GhcPs) where
return (HsEmbTy toktype' t')
exact (HsFunArr _ mult arg res) = do
- arg' <- markAnnotated arg
- mult' <- markArrow mult
+ (mult', arg') <- markMultAnnOf mult (markAnnotated arg)
res' <- markAnnotated res
return (HsFunArr noExtField mult' arg' res')
@@ -3956,8 +3919,7 @@ instance ExactPrint (HsType GhcPs) where
ki' <- markAnnotated ki
return (HsAppKindTy at' ty' ki')
exact (HsFunTy an mult ty1 ty2) = do
- ty1' <- markAnnotated ty1
- mult' <- markArrow mult
+ (mult', ty1') <- markMultAnnOf mult (markAnnotated ty1)
ty2' <- markAnnotated ty2
return (HsFunTy an mult' ty1' ty2')
exact (HsListTy an tys) = do
@@ -4006,22 +3968,10 @@ instance ExactPrint (HsType GhcPs) where
exact (HsDocTy an ty doc) = do
ty' <- markAnnotated ty
return (HsDocTy an ty' doc)
- exact (HsBangTy ((o,c,tk), mt) (HsBang up str) ty) = do
- (o',c') <-
- case mt of
- NoSourceText -> return (o,c)
- SourceText src -> do
- debugM $ "HsBangTy: src=" ++ showAst src
- o' <- printStringAtAA o (unpackFS src)
- c' <- markEpToken c
- return (o',c')
- tk' <-
- case str of
- SrcLazy -> printStringAtAA tk "~"
- SrcStrict -> printStringAtAA tk "!"
- NoSrcStrict -> return tk
+ exact (XHsType (HsBangTy ann (HsSrcBang mt up str) ty)) = do
+ (ann', mt') <- exactBang (ann, mt) str
ty' <- markAnnotated ty
- return (HsBangTy ((o',c',tk'), mt) (HsBang up str) ty')
+ return (XHsType (HsBangTy ann' (HsSrcBang mt' up str) ty'))
exact (HsExplicitListTy (sq,o,c) prom tys) = do
sq' <- if (isPromoted prom)
then markEpToken sq
@@ -4384,15 +4334,14 @@ instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) wher
-- ---------------------------------------------------------------------
-instance ExactPrint (ConDeclField GhcPs) where
+instance ExactPrint (HsConDeclRecField GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (ConDeclField td names ftype mdoc) = do
+ exact (HsConDeclRecField _ names ftype) = do
names' <- markAnnotated names
- td' <- markEpUniToken td
ftype' <- markAnnotated ftype
- return (ConDeclField td' names' ftype' mdoc)
+ return (HsConDeclRecField noExtField names' ftype')
-- ---------------------------------------------------------------------
@@ -4405,13 +4354,60 @@ instance ExactPrint (FieldOcc GhcPs) where
-- ---------------------------------------------------------------------
-instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where
+instance ExactPrint (HsConDeclField GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (HsScaled arr t) = do
- t' <- markAnnotated t
- arr' <- markArrow arr
- return (HsScaled arr' t')
+ exact cdf@(CDF { cdf_ext, cdf_bang, cdf_multiplicity, cdf_type }) = do
+ (mult, (an, t)) <- markMultAnnOf cdf_multiplicity ((,) <$> exactBang cdf_ext cdf_bang <*> markAnnotated cdf_type)
+ return (cdf { cdf_ext = an, cdf_multiplicity = mult, cdf_type = t })
+
+markMultAnnOf :: (Monad m, Monoid w, ExactPrint a) => HsMultAnnOf a GhcPs -> EP w m b -> EP w m (HsMultAnnOf a GhcPs, b)
+markMultAnnOf (HsUnannotated arrOrCol) tyM = do
+ ((), arrOrCol', ty') <- markArrOrCol (pure ()) arrOrCol tyM
+ return (HsUnannotated arrOrCol', ty')
+markMultAnnOf (HsLinearAnn (EpPct1 pct1 arrOrCol)) tyM = do
+ (pct1', arrOrCol', ty') <- markArrOrCol (markEpToken pct1) arrOrCol tyM
+ return (HsLinearAnn (EpPct1 pct1' arrOrCol'), ty')
+markMultAnnOf (HsLinearAnn (EpLolly arr)) tyM = do
+ ty' <- tyM
+ arr' <- markEpToken arr
+ return (HsLinearAnn (EpLolly arr'), ty')
+markMultAnnOf (HsExplicitMult (pct, arrOrCol) t) tyM = do
+ ((pct', t'), arrOrCol', ty') <- markArrOrCol ((,) <$> markEpToken pct <*> markAnnotated t) arrOrCol tyM
+ return (HsExplicitMult (pct', arrOrCol') t', ty')
+
+markArrOrCol :: (Monad m, Monoid w) => EP w m a -> EpArrowOrColon -> EP w m b -> EP w m (a, EpArrowOrColon, b)
+markArrOrCol multM (EpArrow arr) tyM = do
+ ty' <- tyM
+ mult' <- multM
+ arr' <- markEpUniToken arr
+ return (mult', EpArrow arr', ty')
+markArrOrCol multM (EpColon col) tyM = do
+ mult' <- multM
+ col' <- markEpUniToken col
+ ty' <- tyM
+ return (mult', EpColon col', ty')
+markArrOrCol multM EpPatBind patM = do
+ mult' <- multM
+ pat' <- patM
+ return (mult', EpPatBind, pat')
+
+exactBang :: (Monoid w, Monad m) => XConDeclField GhcPs -> SrcStrictness -> EP w m (XConDeclField GhcPs)
+exactBang ((o,c,tk), mt) str = do
+ (o',c') <-
+ case mt of
+ NoSourceText -> return (o,c)
+ SourceText src -> do
+ debugM $ "HsBangTy: src=" ++ showAst src
+ o' <- printStringAtAA o (unpackFS src)
+ c' <- markEpToken c
+ return (o',c')
+ tk' <-
+ case str of
+ SrcLazy -> printStringAtAA tk "~"
+ SrcStrict -> printStringAtAA tk "!"
+ NoSrcStrict -> return tk
+ return ((o',c',tk'), mt)
-- ---------------------------------------------------------------------
@@ -4504,11 +4500,11 @@ instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd Gh
an1 <- markLensBracketsC an0 lal_brackets
return (L an1 es')
-instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where
+instance ExactPrint (LocatedL [LocatedA (HsConDeclRecField GhcPs)]) where
getAnnotationEntry = entryFromLocatedA
setAnnotationAnchor = setAnchorAn
exact (L an fs) = do
- debugM $ "LocatedL [LConDeclField"
+ debugM $ "LocatedL [LHsConDeclRecField"
(an', fs') <- markAnnList an (markAnnotated fs)
return (L an' fs')
diff --git a/utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs b/utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
index e0a0203e1e11df9f41cd383d570582f3942e8cf3..14aa1b5905923e41d81509c8a6aebf0ad9b59268 100644
--- a/utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -98,7 +98,6 @@ dropHsDocTy = drop_sig_ty
drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e)
drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e)
- drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b)
drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b)
drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b)
drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)
@@ -295,17 +294,17 @@ ppCtor sDocContext dat subdocs con@ConDeclH98{con_args = con_args'} =
-- AZ:TODO get rid of the concatMap
concatMap (lookupCon sDocContext subdocs) [con_name con] ++ f con_args'
where
- f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
+ f (PrefixCon args) = [typeSig name $ (map cdf_type args) ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1, a2]
f (RecCon (L _ recs)) =
- f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs)
+ f (PrefixCon $ map (cdrf_spec . unLoc) recs)
++ concat
- [ (concatMap (lookupCon sDocContext subdocs . noLocA . unLoc . foLabel . unLoc) (cd_fld_names r))
- ++ [out sDocContext (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
+ [ (concatMap (lookupCon sDocContext subdocs . noLocA . unLoc . foLabel . unLoc) (cdrf_names r))
+ ++ [out sDocContext (map (foExt . unLoc) $ cdrf_names r) `typeSig` [resType, cdf_type $ cdrf_spec r]]
| r <- map unLoc recs
]
- funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow noExtField) x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnannotated noExtField) x y)
apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
typeSig nm flds =
@@ -355,9 +354,9 @@ ppCtor
Nothing -> tau_ty
tau_ty = foldr mkFunTy res_ty $
case args of
- PrefixConGADT _ pos_args -> map hsScaledThing pos_args
- RecConGADT _ (L _ flds) -> map (cd_fld_type . unL) flds
- mkFunTy a b = noLocA (HsFunTy noExtField (HsUnrestrictedArrow noExtField) a b)
+ PrefixConGADT _ pos_args -> map cdf_type pos_args
+ RecConGADT _ (L _ flds) -> map (cdf_type . cdrf_spec . unL) flds
+ mkFunTy a b = noLocA (HsFunTy noExtField (HsUnannotated noExtField) a b)
ppFixity :: SDocContext -> (Name, Fixity) -> [String]
ppFixity sDocContext (name, fixity) = [out sDocContext ((FixitySig NoNamespaceSpecifier [noLocA name] fixity) :: FixitySig GhcRn)]
diff --git a/utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs b/utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
index 037e65cbfa0ba0f1c32d209ee3e97e6c3832c742..c0d5e3579c34e8d2698781e57894d265ddd38c46 100644
--- a/utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -27,7 +27,7 @@ import Data.List (sort)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
-import GHC hiding (fromMaybeContext)
+import GHC hiding (HsTypeGhcPsExt (..), fromMaybeContext)
import GHC.Core.Type (Specificity (..))
import GHC.Data.FastString (unpackFS)
import GHC.Types.Name (getOccString, nameOccName, tidyNameOcc)
@@ -597,7 +597,7 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ
, decltt (ppLContextNoArrow lctxt unicode) <+> nl
)
: do_largs n (darrow unicode) ltype
- do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) =
+ do_args n leader (HsFunTy _ _w (L _ (XHsType (HsRecTy fields))) r) =
[ (decltt ldr, latex <+> nl)
| (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
, let latex = ppSideBySideField subdocs unicode field
@@ -964,7 +964,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
hsep
[ header_
, ppOcc
- , hsep (map (ppLParendType unicode . hsScaledThing) args)
+ , hsep (map (ppLParendType unicode . hsConDeclFieldToHsTypeNoMult) args)
]
-- Record constructor, e.g. 'Identity { runIdentity :: a }'
RecCon _ -> header_ <+> ppOcc
@@ -974,9 +974,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
| otherwise ->
hsep
[ header_
- , ppLParendType unicode (hsScaledThing arg1)
+ , ppLParendType unicode (hsConDeclFieldToHsTypeNoMult arg1)
, ppOccInfix
- , ppLParendType unicode (hsScaledThing arg2)
+ , ppLParendType unicode (hsConDeclFieldToHsTypeNoMult arg2)
]
ConDeclGADT{}
| hasArgDocs || not (isEmpty fieldPart) -> ppOcc
@@ -993,15 +993,15 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
-- GADT record declarations
RecConGADT _ _ -> doConstrArgsWithDocs []
-- GADT prefix data constructors
- PrefixConGADT _ args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
+ PrefixConGADT _ args | hasArgDocs -> doConstrArgsWithDocs (map hsConDeclFieldToHsTypeNoMult args)
_ -> empty
ConDeclH98{con_args = con_args'} -> case con_args' of
-- H98 record declarations
RecCon (L _ fields) -> doRecordFields fields
-- H98 prefix data constructors
- PrefixCon args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
+ PrefixCon args | hasArgDocs -> doConstrArgsWithDocs (map hsConDeclFieldToHsTypeNoMult args)
-- H98 infix data constructor
- InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1, arg2])
+ InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsConDeclFieldToHsTypeNoMult [arg1, arg2])
_ -> empty
doRecordFields fields =
@@ -1030,23 +1030,30 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
>>= fmap _doc . combineDocumentation . fst
-- | Pretty-print a record field
-ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX
-ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> HsConDeclRecField DocNameI -> LaTeX
+ppSideBySideField subdocs unicode (HsConDeclRecField _ names ltype) =
decltt
( cat (punctuate comma (map (ppBinder . rdrNameOcc . foExt . unLoc) names))
+ <+> ppRecFieldMultAnn unicode ltype
<+> dcolon unicode
- <+> ppLType unicode ltype
+ <+> ppLType unicode (hsConDeclFieldToHsTypeNoMult ltype)
)
<-> rDoc mbDoc
where
- -- don't use cd_fld_doc for same reason we don't use con_doc above
- -- Where there is more than one name, they all have the same documentation
mbDoc = lookup (unLoc . foLabel . unLoc $ name) subdocs >>= fmap _doc . combineDocumentation . fst
name =
case Maybe.listToMaybe names of
Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
Just hd -> hd
+-- don't use cdf_doc for same reason we don't use con_doc above
+-- Where there is more than one name, they all have the same documentation
+ppRecFieldMultAnn :: Bool -> HsConDeclField DocNameI -> LaTeX
+ppRecFieldMultAnn unicode (CDF { cdf_multiplicity = ann }) = case ann of
+ HsUnannotated _ -> empty
+ HsLinearAnn _ -> text "%1"
+ HsExplicitMult _ mult -> multAnnotation <> ppr_mono_lty mult unicode
+
-- | Pretty-print a bundled pattern synonym
ppSideBySidePat
:: [LocatedN DocName]
@@ -1193,9 +1200,9 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
-------------------------------------------------------------------------------
-ppBang :: HsBang -> LaTeX
-ppBang (HsBang _ SrcStrict) = char '!'
-ppBang (HsBang _ SrcLazy) = char '~'
+ppBang :: HsSrcBang -> LaTeX
+ppBang (HsSrcBang _ _ SrcStrict) = char '!'
+ppBang (HsSrcBang _ _ SrcLazy) = char '~'
ppBang _ = empty
tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX
@@ -1311,10 +1318,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u =
]
where
arr = case mult of
- HsLinearArrow _ -> lollipop u
- HsUnrestrictedArrow _ -> arrow u
+ HsLinearAnn _ -> lollipop u
+ HsUnannotated _ -> arrow u
HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u
-ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
ppr_mono_ty (HsTyVar _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name
ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys)
@@ -1323,8 +1329,9 @@ ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+>
ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u)
ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u
ppr_mono_ty (HsSpliceTy v _) _ = dataConCantHappen v
-ppr_mono_ty (HsRecTy{}) _ = text "{..}"
-ppr_mono_ty (XHsType{}) _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty (XHsType (HsBangTy b ty)) u = ppBang b <> ppLParendType u ty
+ppr_mono_ty (XHsType HsRecTy{}) _ = text "{..}"
+ppr_mono_ty (XHsType HsCoreTy{}) _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty (HsExplicitTupleTy _ IsPromoted tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
diff --git a/utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 34b87eb84c23931d47a37903bd98a1e67181819f..b5a4afdbf8a839c44260e36512193e8b80a99351 100644
--- a/utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -29,7 +29,7 @@ import Data.List (intersperse, sort)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
-import GHC hiding (LexicalFixity (..), fromMaybeContext)
+import GHC hiding (HsTypeGhcPsExt (..), LexicalFixity (..), fromMaybeContext)
import GHC.Core.Type (Specificity (..))
import GHC.Data.BooleanFormula
import GHC.Exts hiding (toList)
@@ -335,7 +335,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep
| otherwise =
(leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
: do_largs n (darrow unicode) ltype
- do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) =
+ do_args n leader (HsFunTy _ _w (L _ (XHsType (HsRecTy fields))) r) =
[ (ldr <+> html, mdoc, subs)
| (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
, let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field
@@ -1350,7 +1350,7 @@ ppShortConstrParts summary dataInst con unicode qual =
in case det of
-- Prefix constructor, e.g. 'Just a'
PrefixCon args ->
- ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)
+ ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsConDeclFieldToHsTypeNoMult) args)
, noHtml
, noHtml
)
@@ -1368,9 +1368,9 @@ ppShortConstrParts summary dataInst con unicode qual =
InfixCon arg1 arg2 ->
( header_
<+> hsep
- [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)
+ [ ppLParendType unicode qual HideEmptyContexts (hsConDeclFieldToHsTypeNoMult arg1)
, ppOccInfix
- , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2)
+ , ppLParendType unicode qual HideEmptyContexts (hsConDeclFieldToHsTypeNoMult arg2)
]
, noHtml
, noHtml
@@ -1431,7 +1431,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) =
| otherwise ->
hsep
[ header_ <+> ppOcc
- , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)
+ , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsConDeclFieldToHsTypeNoMult) args)
, fixity
]
-- Record constructor, e.g. 'Identity { runIdentity :: a }'
@@ -1441,9 +1441,9 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) =
| hasArgDocs -> header_ <+> ppOcc <+> fixity
| otherwise ->
hsep
- [ header_ <+> ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)
+ [ header_ <+> ppLParendType unicode qual HideEmptyContexts (hsConDeclFieldToHsTypeNoMult arg1)
, ppOccInfix
- , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2)
+ , ppLParendType unicode qual HideEmptyContexts (hsConDeclFieldToHsTypeNoMult arg2)
, fixity
]
-- GADT constructor, e.g. 'Foo :: Int -> Foo'
@@ -1480,10 +1480,11 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) =
qual
(map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
+ doConstrArgsWithDocs :: [HsConDeclField DocNameI] -> Html
doConstrArgsWithDocs args = subFields pkg qual $ case con of
ConDeclH98{} ->
[ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, [])
- | (i, arg) <- zip [0 ..] (map hsScaledThing args)
+ | (i, arg) <- zip [0 ..] (map hsConDeclFieldToHsTypeNoMult args)
, let mdoc = Map.lookup i argDocs
]
ConDeclGADT{} ->
@@ -1531,9 +1532,9 @@ ppSideBySideField
:: [(DocName, DocForDecl DocName)]
-> Unicode
-> Qualification
- -> ConDeclField DocNameI
+ -> HsConDeclRecField DocNameI
-> SubDecl
-ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
+ppSideBySideField subdocs unicode qual (HsConDeclRecField _ names ltype) =
( hsep
( punctuate
comma
@@ -1542,24 +1543,32 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
, let field = (foExt) name
]
)
+ <+> ppRecFieldMultAnn unicode qual ltype
<+> dcolon unicode
- <+> ppLType unicode qual HideEmptyContexts ltype
+ <+> ppLType unicode qual HideEmptyContexts (hsConDeclFieldToHsTypeNoMult ltype)
, mbDoc
, []
)
where
- -- don't use cd_fld_doc for same reason we don't use con_doc above
- -- Where there is more than one name, they all have the same documentation
mbDoc = lookup (unLoc . foLabel $ unLoc declName) subdocs >>= combineDocumentation . fst
declName = case Maybe.listToMaybe names of
Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
Just hd -> hd
-ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
-ppShortField summary unicode qual (ConDeclField _ names ltype _) =
+-- don't use cdf_doc for same reason we don't use con_doc above
+-- Where there is more than one name, they all have the same documentation
+ppRecFieldMultAnn :: Unicode -> Qualification -> HsConDeclField DocNameI -> Html
+ppRecFieldMultAnn unicode qual (CDF { cdf_multiplicity = ann }) = case ann of
+ HsUnannotated _ -> noHtml
+ HsLinearAnn _ -> toHtml "%1"
+ HsExplicitMult _ mult -> multAnnotation <> ppr_mono_lty mult unicode qual HideEmptyContexts
+
+ppShortField :: Bool -> Unicode -> Qualification -> HsConDeclRecField DocNameI -> Html
+ppShortField summary unicode qual (HsConDeclRecField _ names ltype) =
hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . foExt . unLoc) names))
+ <+> ppRecFieldMultAnn unicode qual ltype
<+> dcolon unicode
- <+> ppLType unicode qual HideEmptyContexts ltype
+ <+> ppLType unicode qual HideEmptyContexts (hsConDeclFieldToHsTypeNoMult ltype)
-- | Pretty print an expanded pattern (for bundled patterns)
ppSideBySidePat
@@ -1654,9 +1663,9 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
--------------------------------------------------------------------------------
-ppBang :: HsBang -> Html
-ppBang (HsBang _ SrcStrict) = toHtml "!"
-ppBang (HsBang _ SrcLazy) = toHtml "~"
+ppBang :: HsSrcBang -> Html
+ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!"
+ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~"
ppBang _ = noHtml
tupleParens :: HsTupleSort -> [Html] -> Html
@@ -1802,8 +1811,6 @@ ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts =
-- UnicodeSyntax alternatives
ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _
| getOccString (getName name) == "(->)" = toHtml "(→)"
-ppr_mono_ty (HsBangTy _ b ty) u q _ =
- ppBang b +++ ppLParendType u q HideEmptyContexts ty
ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _
| isPromoted prom = promoQuote (ppDocName q Prefix True name)
| otherwise = ppDocName q Prefix True name
@@ -1816,8 +1823,8 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
]
where
arr = case mult of
- HsLinearArrow _ -> lollipop u
- HsUnrestrictedArrow _ -> arrow u
+ HsLinearAnn _ -> lollipop u
+ HsUnannotated _ -> arrow u
HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
ppr_mono_ty (HsTupleTy _ con tys) u q _ =
tupleParens con (map (ppLType u q HideEmptyContexts) tys)
@@ -1829,11 +1836,13 @@ ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyConte
ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ =
ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts
ppr_mono_ty (HsSpliceTy v _) _ _ _ = dataConCantHappen v
-ppr_mono_ty (HsRecTy{}) _ _ _ = toHtml "{..}"
+ppr_mono_ty (XHsType (HsBangTy b ty)) u q _ =
+ ppBang b +++ ppLParendType u q HideEmptyContexts ty
+ppr_mono_ty (XHsType (HsRecTy{})) _ _ _ = toHtml "{..}"
-- Can now legally occur in ConDeclGADT, the output here is to provide a
-- placeholder in the signature, which is followed by the field
-- declarations.
-ppr_mono_ty (XHsType{}) _ _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty (XHsType HsCoreTy{}) _ _ _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty (HsExplicitTupleTy _ IsPromoted tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
diff --git a/utils/haddock/haddock-api/src/Haddock/Convert.hs b/utils/haddock/haddock-api/src/Haddock/Convert.hs
index 1b280721758bbfb817923896b078ed4df8fceed9..ba56997cbc4a73e78561ffd44f07ac63ff39befd 100644
--- a/utils/haddock/haddock-api/src/Haddock/Convert.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Convert.hs
@@ -493,11 +493,10 @@ synifyDataCon use_gadt_syntax dc =
linear_tys =
zipWith
- ( \ty bang ->
- let tySyn = synifyType WithinType [] (scaledThing ty)
- in case bang of
- (HsSrcBang _ (HsBang NoSrcUnpack NoSrcStrict)) -> tySyn
- (HsSrcBang src bang') -> noLocA $ HsBangTy (noAnn, src) bang' tySyn
+ ( \(Scaled mult ty) (HsSrcBang st unp str) ->
+ let tySyn = synifyType WithinType [] ty
+ multSyn = synifyMultRec [] mult
+ in CDF (noAnn, st) unp str multSyn tySyn Nothing
)
arg_tys
(dataConSrcBangs dc)
@@ -505,25 +504,24 @@ synifyDataCon use_gadt_syntax dc =
field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys
con_decl_field fl synTy =
noLocA $
- ConDeclField
- noAnn
- [noLocA $ FieldOcc (mkVarUnqual $ field_label $ flLabel fl) (noLocA (flSelector fl))]
+ HsConDeclRecField
+ noExtField
+ [noLocA $ FieldOcc (mkVarUnqual $ field_label $ flLabel fl) (noLocA (flSelector fl))]
synTy
- Nothing
mk_h98_arg_tys :: Either String (HsConDeclH98Details GhcRn)
mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True, True) -> Left "synifyDataCon: contradiction!"
(True, False) -> return $ RecCon (noLocA field_tys)
- (False, False) -> return $ PrefixCon (map hsUnrestricted linear_tys)
+ (False, False) -> return $ PrefixCon linear_tys
(False, True) -> case linear_tys of
- [a, b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)
+ [a, b] -> return $ InfixCon a b
_ -> Left "synifyDataCon: infix with non-2 args?"
mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn
mk_gadt_arg_tys
| use_named_field_syntax = RecConGADT noExtField (noLocA field_tys)
- | otherwise = PrefixConGADT noExtField (map hsUnrestricted linear_tys)
+ | otherwise = PrefixConGADT noExtField linear_tys
in
-- finally we get synifyDataCon's result!
if use_gadt_syntax
@@ -829,7 +827,7 @@ synifyType s vs funty@(FunTy af w t1 t2)
where
s1 = synifyType WithinType vs t1
s2 = synifyType WithinType vs t2
- w' = synifyMult vs w
+ w' = synifyMultArrow vs w
synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =
case argf of
Required -> synifyVisForAllType vs forallty
@@ -985,10 +983,15 @@ noKindTyVars ts (FunTy _ w t1 t2) =
noKindTyVars ts (CastTy t _) = noKindTyVars ts t
noKindTyVars _ _ = emptyVarSet
-synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn
-synifyMult vs t = case t of
- OneTy -> HsLinearArrow noExtField
- ManyTy -> HsUnrestrictedArrow noExtField
+synifyMultArrow :: [TyVar] -> Mult -> HsMultAnn GhcRn
+synifyMultArrow vs t = case t of
+ OneTy -> HsLinearAnn noExtField
+ ManyTy -> HsUnannotated noExtField
+ ty -> HsExplicitMult noExtField (synifyType WithinType vs ty)
+
+synifyMultRec :: [TyVar] -> Mult -> HsMultAnn GhcRn
+synifyMultRec vs t = case t of
+ OneTy -> HsUnannotated noExtField
ty -> HsExplicitMult noExtField (synifyType WithinType vs ty)
synifyPatSynType :: PatSyn -> LHsType GhcRn
diff --git a/utils/haddock/haddock-api/src/Haddock/GhcUtils.hs b/utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
index 5c97ddacfa578dc52c22d3483083b0c95e7903a0..80ac93ff713ac5a80d74a213ebab0a092387a414 100644
--- a/utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
+++ b/utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
@@ -8,6 +8,7 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -39,7 +40,7 @@ import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as Set
-import GHC
+import GHC hiding (HsTypeGhcPsExt (..))
import GHC.Builtin.Types (liftedRepTy)
import GHC.Core.TyCo.Rep (Type (..))
import GHC.Core.Type (binderVar, isRuntimeRepVar)
@@ -49,6 +50,7 @@ import GHC.Driver.Session
import GHC.HsToCore.Docs hiding (sigNameNoLoc)
import GHC.Types.Name
import GHC.Types.SrcLoc (advanceSrcLoc)
+import GHC.Types.SourceText (SourceText(..))
import GHC.Types.Var
( Specificity
, TyVarBinder
@@ -64,7 +66,7 @@ import GHC.Utils.Outputable (Outputable, SDocContext, ppr)
import qualified GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic (panic)
-import Haddock.Types (DocName, DocNameI, XRecCond)
+import Haddock.Types (DocName, DocNameI, XRecCond, HsTypeDocNameIExt(..))
moduleString :: Module -> String
moduleString = moduleNameString . moduleName
@@ -189,6 +191,18 @@ mkHsImplicitSigTypeI body =
, sig_body = body
}
+hsConDeclFieldToFunTy :: HsConDeclField DocNameI -> LHsType DocNameI -> LHsType DocNameI
+hsConDeclFieldToFunTy cfs tgt =
+ noLocA (HsFunTy noAnn (cdf_multiplicity cfs) (hsConDeclFieldToHsTypeNoMult cfs) tgt)
+
+hsConDeclFieldToHsTypeNoMult :: HsConDeclField DocNameI -> LHsType DocNameI
+hsConDeclFieldToHsTypeNoMult (CDF _ unp str _ t doc) = case doc of
+ Just doc' -> noLocA (HsDocTy noAnn (mkBang unp str t) doc')
+ _ -> mkBang unp str t
+ where
+ mkBang NoSrcUnpack NoSrcStrict ty = ty
+ mkBang u s ty = noLocA (XHsType (HsBangTy (HsSrcBang NoSourceText u s) ty))
+
getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI
-- The full type of a GADT data constructor We really only get this in
-- order to pretty-print it, and currently only in Haddock's code. So
@@ -218,11 +232,11 @@ getGADTConType
-- tau_ty :: LHsType DocNameI
tau_ty = case args of
- RecConGADT _ flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty
- PrefixConGADT _ pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
+ RecConGADT _ flds -> mkFunTy (noLocA (XHsType (HsRecTy (unLoc flds)))) res_ty
+ PrefixConGADT _ pos_args -> foldr hsConDeclFieldToFunTy res_ty pos_args
mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
- mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noExtField) a b)
+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnannotated noExtField) a b)
getGADTConType (ConDeclH98{}) = panic "getGADTConType"
-- Should only be called on ConDeclGADT
@@ -356,11 +370,11 @@ restrictCons names decls = [L p d | L p (Just d) <- fmap keep <$> decls]
where
-- see above
- field_avail :: LConDeclField GhcRn -> Bool
- field_avail (L _ (ConDeclField _ fs _ _)) =
+ field_avail :: LHsConDeclRecField GhcRn -> Bool
+ field_avail (L _ (HsConDeclRecField _ fs _)) =
all (\f -> (unLoc . foLabel . unLoc $ f) `elem` names) fs
- field_types flds = [hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds]
+ field_types flds = [t | L _ (HsConDeclRecField _ _ t) <- flds]
keep _ = Nothing
restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]
@@ -409,11 +423,9 @@ reparenTypePrec = go
where
-- Shorter name for 'reparenType'
go :: Precedence -> HsType a -> HsType a
- go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty)
go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)
go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys)
go _ (HsListTy x ty) = HsListTy x (reparenLType ty)
- go _ (HsRecTy x flds) = HsRecTy x (map (mapXRec @a reparenConDeclField) flds)
go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d
go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)
go _ (HsExplicitTupleTy x p tys) = HsExplicitTupleTy x p (map reparenLType tys)
@@ -509,11 +521,6 @@ reparenBndrKind (HsBndrNoKind x) = HsBndrNoKind x
reparenBndrKind (HsBndrKind x k) = HsBndrKind x (reparenLType k)
reparenBndrKind v@XBndrKind{} = v
--- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
-reparenConDeclField :: XRecCond a => ConDeclField a -> ConDeclField a
-reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d
-reparenConDeclField c@XConDeclField{} = c
-
-------------------------------------------------------------------------------
-- * Located
@@ -551,7 +558,7 @@ instance Parent (ConDecl GhcRn) where
children con =
case getRecConArgs_maybe con of
Nothing -> []
- Just flds -> map (unLoc . foLabel . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)
+ Just flds -> map (unLoc . foLabel . unLoc) $ concatMap (cdrf_names . unLoc) (unLoc flds)
instance Parent (TyClDecl GhcRn) where
children d
diff --git a/utils/haddock/haddock-api/src/Haddock/Interface/Create.hs b/utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
index 586def96bb03f3d32c17e2c72d8783d7820f4503..437dbff48bdfc340d9a2112fcffb5d57c00d97a8 100644
--- a/utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
@@ -933,7 +933,7 @@ extractDecl prr dflags sDocContext name decl
insts
, -- , L _ ConDecl { con_details = RecCon rec } <- toList $ dd_cons (feqn_rhs d)
Just rec <- toList $ getRecConArgs_maybe . unLoc <$> dd_cons (feqn_rhs d)
- , ConDeclField{cd_fld_names = ns} <- map unLoc (unLoc rec)
+ , HsConDeclRecField{cdrf_names = ns} <- map unLoc (unLoc rec)
, L _ n <- ns
, unLoc (foLabel n) == name
]
@@ -962,12 +962,12 @@ extractPatternSyn nm t tvs cons =
let args =
case con of
ConDeclH98{con_args = con_args'} -> case con_args' of
- PrefixCon args' -> map hsScaledThing args'
- RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
- InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
+ PrefixCon args' -> map cdf_type args'
+ RecCon (L _ fields) -> cdf_type . cdrf_spec . unLoc <$> fields
+ InfixCon arg1 arg2 -> map cdf_type [arg1, arg2]
ConDeclGADT{con_g_args = con_args'} -> case con_args' of
- PrefixConGADT _ args' -> map hsScaledThing args'
- RecConGADT _ (L _ fields) -> cd_fld_type . unLoc <$> fields
+ PrefixConGADT _ args' -> map cdf_type args'
+ RecConGADT _ (L _ fields) -> cdf_type . cdrf_spec . unLoc <$> fields
typ = longArrow args (data_ty con)
typ' =
case con of
@@ -977,7 +977,7 @@ extractPatternSyn nm t tvs cons =
in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'')
longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
- longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noExtField (HsUnrestrictedArrow noExtField) x y)) output inputs
+ longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noExtField (HsUnannotated noExtField) x y)) output inputs
data_ty con
| ConDeclGADT{} <- con = con_res_ty con
@@ -998,13 +998,13 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
case getRecConArgs_maybe con of
Just (L _ fields)
- | ((l, L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
- pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noExtField (HsUnrestrictedArrow noExtField) data_ty (getBangType ty))))))
+ | ((l, L _ (HsConDeclRecField _ _nn ty)) : _) <- matching_fields fields ->
+ pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noExtField (HsUnannotated noExtField) data_ty (cdf_type ty))))))
_ -> extractRecSel nm t tvs rest
where
- matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
+ matching_fields :: [LHsConDeclRecField GhcRn] -> [(SrcSpan, LHsConDeclRecField GhcRn)]
matching_fields flds =
- [ (locA l, f) | f@(L _ (ConDeclField _ ns _ _)) <- flds, L l n <- ns, unLoc (foLabel n) == nm
+ [ (locA l, f) | f@(L _ (HsConDeclRecField _ ns _)) <- flds, L l n <- ns, unLoc (foLabel n) == nm
]
data_ty
-- ResTyGADT _ ty <- con_res con = ty
diff --git a/utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs b/utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
index 281a51b01d3b8a1bff09818eea771d6b98b55c24..c4762916ca97b76fac9be0281b07fbc7bbdedb7d 100644
--- a/utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
@@ -31,7 +31,7 @@ import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Traversable (mapM)
-import GHC hiding (NoLink)
+import GHC hiding (NoLink, HsTypeGhcPsExt (..))
import GHC.Builtin.Types (eqTyCon_RDR, tupleDataConName, tupleTyConName)
import GHC.Types.Basic (Boxity (..), TopLevelFlag (..), TupleSort (..))
import GHC.Types.Name
@@ -340,10 +340,10 @@ renameMaybeInjectivityAnn
-> RnM (Maybe (LInjectivityAnn DocNameI))
renameMaybeInjectivityAnn = traverse renameInjectivityAnn
-renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)
-renameArrow (HsUnrestrictedArrow _) = return (HsUnrestrictedArrow noExtField)
-renameArrow (HsLinearArrow _) = return (HsLinearArrow noExtField)
-renameArrow (HsExplicitMult _ p) = HsExplicitMult noExtField <$> renameLType p
+renameMultAnn :: HsMultAnn GhcRn -> RnM (HsMultAnn DocNameI)
+renameMultAnn (HsUnannotated _) = return (HsUnannotated noExtField)
+renameMultAnn (HsLinearAnn _) = return (HsLinearAnn noExtField)
+renameMultAnn (HsExplicitMult _ p) = HsExplicitMult noExtField <$> renameLType p
renameType :: HsType GhcRn -> RnM (HsType DocNameI)
renameType t = case t of
@@ -362,7 +362,6 @@ renameType t = case t of
ltype' <- renameLType ltype
return (HsQualTy{hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype'})
HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< renameName n
- HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype
HsStarTy _ isUni -> return (HsStarTy noAnn isUni)
HsAppTy _ a b -> do
a' <- renameLType a
@@ -375,7 +374,7 @@ renameType t = case t of
HsFunTy _ w a b -> do
a' <- renameLType a
b' <- renameLType b
- w' <- renameArrow w
+ w' <- renameMultAnn w
return (HsFunTy noAnn w' a' b')
HsListTy _ ty -> return . (HsListTy noAnn) =<< renameLType ty
HsIParamTy _ n ty -> liftM (HsIParamTy noAnn n) (renameLType ty)
@@ -403,8 +402,7 @@ renameType t = case t of
doc' <- renameLDocHsSyn doc
return (HsDocTy noAnn ty' doc')
HsTyLit _ x -> return (HsTyLit noAnn (renameTyLit x))
- HsRecTy _ a -> HsRecTy noAnn <$> mapM renameConDeclFieldField a
- XHsType a -> pure (XHsType a)
+ XHsType a -> pure (XHsType (HsCoreTy a))
HsExplicitListTy _ a b -> HsExplicitListTy noAnn a <$> mapM renameLType b
-- Special-case unary boxed tuples so that they are pretty-printed as
-- `'MkSolo x`, not `'(x)`
@@ -718,37 +716,47 @@ renameCon
}
)
-renameHsScaled
- :: HsScaled GhcRn (LHsType GhcRn)
- -> RnM (HsScaled DocNameI (LHsType DocNameI))
-renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty
+renameHsConDeclField
+ :: HsConDeclField GhcRn
+ -> RnM (HsConDeclField DocNameI)
+renameHsConDeclField cdf = do
+ w <- renameMultAnn (cdf_multiplicity cdf)
+ ty <- renameLType (cdf_type cdf)
+ doc <- mapM renameLDocHsSyn (cdf_doc cdf)
+ return
+ ( cdf
+ { cdf_ext = noExtField
+ , cdf_multiplicity = w
+ , cdf_type = ty
+ , cdf_doc = doc
+ }
+ )
renameH98Details
:: HsConDeclH98Details GhcRn
-> RnM (HsConDeclH98Details DocNameI)
renameH98Details (RecCon (L l fields)) = do
- fields' <- mapM renameConDeclFieldField fields
+ fields' <- mapM renameHsConDeclRecFieldField fields
return (RecCon (L (locA l) fields'))
-renameH98Details (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps
+renameH98Details (PrefixCon ps) = PrefixCon <$> mapM renameHsConDeclField ps
renameH98Details (InfixCon a b) = do
- a' <- renameHsScaled a
- b' <- renameHsScaled b
+ a' <- renameHsConDeclField a
+ b' <- renameHsConDeclField b
return (InfixCon a' b')
renameGADTDetails
:: HsConDeclGADTDetails GhcRn
-> RnM (HsConDeclGADTDetails DocNameI)
renameGADTDetails (RecConGADT _ (L l fields)) = do
- fields' <- mapM renameConDeclFieldField fields
+ fields' <- mapM renameHsConDeclRecFieldField fields
return (RecConGADT noExtField (L (locA l) fields'))
-renameGADTDetails (PrefixConGADT _ ps) = PrefixConGADT noExtField <$> mapM renameHsScaled ps
+renameGADTDetails (PrefixConGADT _ ps) = PrefixConGADT noExtField <$> mapM renameHsConDeclField ps
-renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
-renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
+renameHsConDeclRecFieldField :: LHsConDeclRecField GhcRn -> RnM (LHsConDeclRecField DocNameI)
+renameHsConDeclRecFieldField (L l (HsConDeclRecField _ names t)) = do
names' <- mapM renameLFieldOcc names
- t' <- renameLType t
- doc' <- mapM renameLDocHsSyn doc
- return $ L (locA l) (ConDeclField noExtField names' t' doc')
+ t' <- renameHsConDeclField t
+ return $ L (locA l) (HsConDeclRecField noExtField names' t')
renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
renameLFieldOcc (L l (FieldOcc rdr (L n sel))) = do
diff --git a/utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs b/utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
index d8dde34903ef7597d6e8102682fcf7773a46b871..79668f4d33f6b992ae216d25fd318b9f86e47fa9 100644
--- a/utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
@@ -100,7 +100,7 @@ renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name
renameType t@(HsStarTy _ _) = pure t
renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk
-renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType la <*> renameLType lr
+renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsMultAnn w <*> renameLType la <*> renameLType lr
renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt
@@ -111,8 +111,6 @@ renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk
renameType t@(HsSpliceTy _ _) = pure t
renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc
-renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt
-renameType t@(HsRecTy _ _) = pure t
renameType t@(XHsType _) = pure t
renameType (HsExplicitListTy x ip ltys) =
HsExplicitListTy x ip <$> renameLTypes ltys
@@ -121,9 +119,9 @@ renameType (HsExplicitTupleTy x ip ltys) =
renameType t@(HsTyLit _ _) = pure t
renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
-renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)
-renameHsArrow (HsExplicitMult x p) = HsExplicitMult x <$> renameLType p
-renameHsArrow mult = pure mult
+renameHsMultAnn :: HsMultAnn GhcRn -> Rename (IdP GhcRn) (HsMultAnn GhcRn)
+renameHsMultAnn (HsExplicitMult x p) = HsExplicitMult x <$> renameLType p
+renameHsMultAnn mult = pure mult
renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType = located renameType
diff --git a/utils/haddock/haddock-api/src/Haddock/Types.hs b/utils/haddock/haddock-api/src/Haddock/Types.hs
index f0ba52aafada0011b779c92c17c1452d972a3c71..07f7d9620ed794667b1280006a0f3e35a128372d 100644
--- a/utils/haddock/haddock-api/src/Haddock/Types.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Types.hs
@@ -805,9 +805,9 @@ type instance Anno (HsType DocNameI) = SrcSpanAnnA
type instance Anno (DataFamInstDecl DocNameI) = SrcSpanAnnA
type instance Anno (DerivStrategy DocNameI) = EpAnn NoEpAnns
type instance Anno (FieldOcc DocNameI) = SrcSpanAnnA
-type instance Anno (ConDeclField DocNameI) = SrcSpan
-type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan
-type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan
+type instance Anno (HsConDeclRecField DocNameI) = SrcSpan
+type instance Anno (Located (HsConDeclRecField DocNameI)) = SrcSpan
+type instance Anno [Located (HsConDeclRecField DocNameI)] = SrcSpan
type instance Anno (ConDecl DocNameI) = SrcSpan
type instance Anno (FunDep DocNameI) = SrcSpan
type instance Anno (TyFamInstDecl DocNameI) = SrcSpanAnnA
@@ -838,10 +838,10 @@ type instance XBndrRequired DocNameI = NoExtField
type instance XBndrInvisible DocNameI = NoExtField
type instance XXBndrVis DocNameI = DataConCantHappen
-type instance XUnrestrictedArrow _ DocNameI = NoExtField
-type instance XLinearArrow _ DocNameI = NoExtField
+type instance XUnannotated _ DocNameI = NoExtField
+type instance XLinearAnn _ DocNameI = NoExtField
type instance XExplicitMult _ DocNameI = NoExtField
-type instance XXArrow _ DocNameI = DataConCantHappen
+type instance XXMultAnnOf _ DocNameI = DataConCantHappen
type instance XForAllTy DocNameI = EpAnn NoEpAnns
type instance XQualTy DocNameI = EpAnn NoEpAnns
@@ -859,13 +859,19 @@ type instance XIParamTy DocNameI = EpAnn NoEpAnns
type instance XKindSig DocNameI = EpAnn NoEpAnns
type instance XSpliceTy DocNameI = DataConCantHappen
type instance XDocTy DocNameI = EpAnn NoEpAnns
-type instance XBangTy DocNameI = EpAnn NoEpAnns
-type instance XRecTy DocNameI = EpAnn NoEpAnns
type instance XExplicitListTy DocNameI = EpAnn NoEpAnns
type instance XExplicitTupleTy DocNameI = EpAnn NoEpAnns
type instance XTyLit DocNameI = EpAnn NoEpAnns
type instance XWildCardTy DocNameI = EpAnn NoEpAnns
-type instance XXType DocNameI = HsCoreTy
+type instance XXType DocNameI = HsTypeDocNameIExt
+
+data HsTypeDocNameIExt
+ = HsCoreTy HsCoreTy
+
+ | HsBangTy HsSrcBang
+ (LHsType DocNameI)
+
+ | HsRecTy [LHsConDeclRecField DocNameI]
type instance XNumTy DocNameI = NoExtField
type instance XStrTy DocNameI = NoExtField
@@ -960,6 +966,9 @@ type instance XXHsSigType DocNameI = DataConCantHappen
type instance XHsQTvs DocNameI = NoExtField
type instance XXLHsQTyVars DocNameI = DataConCantHappen
+type instance XConDeclRecField DocNameI = NoExtField
+type instance XXConDeclRecField DocNameI = DataConCantHappen
+
type instance XConDeclField DocNameI = NoExtField
type instance XXConDeclField DocNameI = DataConCantHappen
diff --git a/utils/haddock/html-test/ref/LinearTypes.html b/utils/haddock/html-test/ref/LinearTypes.html
index 19a8a7e4551c44dd09a0caa07066c603cd635444..dbe0babf7ad414ca2e6694d1ff6f4f2c6d460fe8 100644
--- a/utils/haddock/html-test/ref/LinearTypes.html
+++ b/utils/haddock/html-test/ref/LinearTypes.html
@@ -36,7 +36,7 @@
><th
>Safe Haskell</th
><td
- >Safe-Inferred</td
+ >None</td
></tr
><tr
><th
@@ -69,6 +69,66 @@
> a (m :: <a href="#" title="GHC.Exts"
>Multiplicity</a
>) b. a %m -> b</li
+ ><li class="src short"
+ ><span class="keyword"
+ >data</span
+ > <a href="#"
+ >C</a
+ > (m :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >) = <a href="#"
+ >C</a
+ > {<ul class="subs"
+ ><li
+ ><a href="#"
+ >linC</a
+ > :: <a href="#" title="Data.Int"
+ >Int</a
+ ></li
+ ><li
+ ><a href="#"
+ >urC</a
+ > %'<a href="#" title="GHC.Exts"
+ >Many</a
+ > :: <a href="#" title="Data.Char"
+ >Char</a
+ ></li
+ ><li
+ ><a href="#"
+ >varC</a
+ > %m :: <a href="#" title="Data.String"
+ >String</a
+ ></li
+ ><li
+ ><a href="#"
+ >noC</a
+ > :: <a href="#" title="Data.Bool"
+ >Bool</a
+ ></li
+ ></ul
+ >}</li
+ ><li class="src short"
+ ><span class="keyword"
+ >data</span
+ > <a href="#"
+ >G</a
+ > (mult :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >) <span class="keyword"
+ >where</span
+ ><ul class="subs"
+ ><li
+ ><a href="#"
+ >G</a
+ > :: <span class="keyword"
+ >forall</span
+ > (mult :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >). {..} -> <a href="#" title="LinearTypes"
+ >G</a
+ > mult</li
+ ></ul
+ ></li
></ul
></details
></div
@@ -115,6 +175,184 @@
>Does something polymorphic.</p
></div
></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data</span
+ > <a id="t:C" class="def"
+ >C</a
+ > (m :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >) <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >A record with non-linear fields.</p
+ ></div
+ ><div class="subs constructors"
+ ><p class="caption"
+ >Constructors</p
+ ><table
+ ><tr
+ ><td class="src"
+ ><a id="v:C" class="def"
+ >C</a
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><div class="subs fields"
+ ><p class="caption"
+ >Fields</p
+ ><ul
+ ><li
+ ><dfn class="src"
+ ><a id="v:linC" class="def"
+ >linC</a
+ > :: <a href="#" title="Data.Int"
+ >Int</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ ><a id="v:urC" class="def"
+ >urC</a
+ > %'<a href="#" title="GHC.Exts"
+ >Many</a
+ > :: <a href="#" title="Data.Char"
+ >Char</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ ><a id="v:varC" class="def"
+ >varC</a
+ > %m :: <a href="#" title="Data.String"
+ >String</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ ><a id="v:noC" class="def"
+ >noC</a
+ > :: <a href="#" title="Data.Bool"
+ >Bool</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ></ul
+ ></div
+ ></td
+ ></tr
+ ></table
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data</span
+ > <a id="t:G" class="def"
+ >G</a
+ > (mult :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >) <span class="keyword"
+ >where</span
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >A GADT record with non-linear fields.</p
+ ></div
+ ><div class="subs constructors"
+ ><p class="caption"
+ >Constructors</p
+ ><table
+ ><tr
+ ><td class="src"
+ ><a id="v:G" class="def"
+ >G</a
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><div class="subs fields"
+ ><p class="caption"
+ >Fields</p
+ ><ul
+ ><li
+ ><dfn class="src"
+ >:: <span class="keyword"
+ >forall</span
+ > (mult :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >). { <a id="v:linG" class="def"
+ >linG</a
+ > :: <a href="#" title="Data.Int"
+ >Int</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ > , <a id="v:urG" class="def"
+ >urG</a
+ > %'<a href="#" title="GHC.Exts"
+ >Many</a
+ > :: <a href="#" title="Data.Char"
+ >Char</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ > , <a id="v:varG" class="def"
+ >varG</a
+ > %mult :: <a href="#" title="Data.String"
+ >String</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ > , <a id="v:noG" class="def"
+ >noG</a
+ > :: <a href="#" title="Data.Bool"
+ >Bool</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ > } -> <a href="#" title="LinearTypes"
+ >G</a
+ > mult</dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ></ul
+ ></div
+ ></td
+ ></tr
+ ></table
+ ></div
+ ></div
></div
></div
></body
diff --git a/utils/haddock/html-test/src/LinearTypes.hs b/utils/haddock/html-test/src/LinearTypes.hs
index c4f9c84fd6347e48de3eff12588ce2886166d5cb..ea59108440ef2715485c3fc343efc0ae5da28e98 100644
--- a/utils/haddock/html-test/src/LinearTypes.hs
+++ b/utils/haddock/html-test/src/LinearTypes.hs
@@ -1,7 +1,11 @@
{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
module LinearTypes where
+import GHC.Exts (Multiplicity(..))
+
-- | Does something unrestricted.
unrestricted :: a -> b
unrestricted = undefined
@@ -13,3 +17,10 @@ linear = linear
-- | Does something polymorphic.
poly :: a %m -> b
poly = poly
+
+-- | A record with non-linear fields.
+data C m = C { linC %1 :: Int, urC %Many :: Char, varC %m :: String, noC :: Bool }
+
+-- | A GADT record with non-linear fields.
+data G mult where
+ G :: { linG %1 :: Int, urG %Many :: Char, varG %m :: String, noG :: Bool } -> G m
diff --git a/utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex b/utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
index c2eefe1a8731ed74a7a8e85c0c6d8a23f3f03a3a..dbc4e47623a8eb3c41de632fe09a51792e7a43ec 100644
--- a/utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
+++ b/utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
@@ -3,7 +3,8 @@
\haddockbeginheader
{\haddockverb\begin{verbatim}
module LinearTypes (
- unrestricted, linear, poly
+ unrestricted, linear, poly, C(C, linC, noC, urC, varC),
+ G(G, linG, noG, urG, varG)
) where\end{verbatim}}
\haddockendheader
@@ -27,4 +28,32 @@ poly :: forall a (m :: Multiplicity) b. a {\char '45}m -> b
\end{tabular}]
{\haddockbegindoc
Does something polymorphic.\par}
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+data C m
+\end{tabular}]
+{\haddockbegindoc
+A record with non-linear fields.\par
+\enspace \emph{Constructors}\par
+\haddockbeginconstrs
+\haddockdecltt{=} & \haddockdecltt{C} & \\
+ & \haddocktt{\qquad \{} \haddockdecltt{linC :: Int} & \\
+ & \haddocktt{\qquad ,} \haddockdecltt{urC {\char '45}'Many :: Char} & \\
+ & \haddocktt{\qquad ,} \haddockdecltt{varC {\char '45}m :: String} & \\
+ & \haddocktt{\qquad ,} \haddockdecltt{noC :: Bool} & \\ & \haddocktt{\qquad \}} \\
+\end{tabulary}\par}
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+data G mult where
+\end{tabular}]
+{\haddockbegindoc
+A GADT record with non-linear fields.\par
+\enspace \emph{Constructors}\par
+\haddockbeginconstrs
+& \haddockdecltt{G} & \\
+ & \qquad \haddockdecltt{::} \enspace \haddockdecltt{forall (mult :: Multiplicity).} {..}
+ -> G mult
+\end{tabulary}\par}
\end{haddockdesc}
\ No newline at end of file
diff --git a/utils/haddock/latex-test/src/LinearTypes/LinearTypes.hs b/utils/haddock/latex-test/src/LinearTypes/LinearTypes.hs
index c4f9c84fd6347e48de3eff12588ce2886166d5cb..ea59108440ef2715485c3fc343efc0ae5da28e98 100644
--- a/utils/haddock/latex-test/src/LinearTypes/LinearTypes.hs
+++ b/utils/haddock/latex-test/src/LinearTypes/LinearTypes.hs
@@ -1,7 +1,11 @@
{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
module LinearTypes where
+import GHC.Exts (Multiplicity(..))
+
-- | Does something unrestricted.
unrestricted :: a -> b
unrestricted = undefined
@@ -13,3 +17,10 @@ linear = linear
-- | Does something polymorphic.
poly :: a %m -> b
poly = poly
+
+-- | A record with non-linear fields.
+data C m = C { linC %1 :: Int, urC %Many :: Char, varC %m :: String, noC :: Bool }
+
+-- | A GADT record with non-linear fields.
+data G mult where
+ G :: { linG %1 :: Int, urG %Many :: Char, varG %m :: String, noG :: Bool } -> G m