[Git][ghc/ghc][wip/T18844] 4 commits: Parser regression tests, close #12862 #12446
Ryan Scott
gitlab at gitlab.haskell.org
Sun Oct 25 12:13:18 UTC 2020
Ryan Scott pushed to branch wip/T18844 at Glasgow Haskell Compiler / GHC
Commits:
e2c4a947 by Vladislav Zavialov at 2020-10-21T16:00:30+03:00
Parser regression tests, close #12862 #12446
These issues were fixed by earlier parser changes, most likely related
to whitespace-sensitive parsing.
- - - - -
711929e6 by Simon Peyton Jones at 2020-10-23T02:42:59-04:00
Fix error message location in tcCheckPatSynDecl
Ticket #18856 showed that we were failing to set the right location
for an error message. Easy to fix, happily.
Turns out that this also improves the error location in test T11010,
which was bogus before but we had never noticed.
- - - - -
730bb590 by Ben Gamari at 2020-10-23T02:43:33-04:00
cmm: Add Note reference to ForeignHint
- - - - -
04b85ddc by Ryan Scott at 2020-10-25T08:12:41-04:00
Split HsConDecl{H98,GADT}Details
Haskell98 and GADT constructors both use `HsConDeclDetails`, which includes
`InfixCon`. But `InfixCon` is never used for GADT constructors, which results
in an awkward unrepresentable state. This removes the unrepresentable state by:
* Adding a third type parameter to `HsConDeclDetails` to represent the types
in an `InfixCon`, separate from the type parameters for `PrefixCon` and
`RecCon`, and
* Creating `HsConDeclH98Details` and `HsConDeclGADTDetails` synonyms on top
of the new `HsConDeclDetails`, which instantiate the `inf` type parameter
to `HsScaled pass (LBangType pass)` and `Void`, respectively. Using `Void`
allows functions that consume `HsConDeclGADTDetails` to simply call
`noGadtInfix` (i.e, `\x -> case x of {}`) instead of having to, say, `panic`.
See also `Note [GADT syntax can't be infix]` in `GHC.Hs.Decls`.
The rest of the patch is refactoring to accommodate the new structure of
`HsConDecl{,H98,GADT}Details`. Some highlights:
* The `getConArgs` and `hsConDeclArgTys` functions have been removed, as
there is no way to implement these functions uniformly for all
`ConDecl`s. For the most part, their previous call sites now
pattern match on the `ConDecl`s directly and do different things for
`ConDeclH98`s and `ConDeclGADT`s.
I did introduce one new function to make the transition easier:
`getRecConArgs_maybe`, which extracts the arguments from a `RecCon`.
This is still possible since `RecCon`s still use the same representation
in both `HsConDeclH98Details` and `HsConDeclGADTDetails`, and since the
pattern that `getRecConArgs_maybe` implements is used in several places,
I thought it worthwhile to factor it out into its own function.
* Previously, the `con_args` fields in `ConDeclH98` and `ConDeclGADT` were
both of type `HsConDeclDetails`. Now, the former is of type
`HsConDeclH98Details`, and the latter is of type `HsConDeclGADTDetails`,
which are distinct types. As a result, I had to rename the `con_args` field
in `ConDeclGADT` to `con_g_args` to make it typecheck.
A consequence of all this is that the `con_args` field is now partial, so
using `con_args` as a top-level field selector is dangerous. (Indeed, Haddock
was using `con_args` at the top-level, which caused it to crash at runtime
before I noticed what was wrong!) I decided to add a disclaimer in the 9.2.1
release notes to advertise this pitfall.
Fixes #18844. Bumps the `haddock` submodule.
- - - - -
29 changed files:
- compiler/GHC/Cmm/Type.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/ThToHs.hs
- docs/users_guide/9.2.1-notes.rst
- + testsuite/tests/parser/should_compile/T12862.hs
- testsuite/tests/parser/should_compile/all.T
- + testsuite/tests/parser/should_fail/T12446.hs
- + testsuite/tests/parser/should_fail/T12446.stderr
- testsuite/tests/parser/should_fail/all.T
- testsuite/tests/patsyn/should_fail/T11010.stderr
- + testsuite/tests/patsyn/should_fail/T18856.hs
- + testsuite/tests/patsyn/should_fail/T18856.stderr
- testsuite/tests/patsyn/should_fail/all.T
- utils/haddock
Changes:
=====================================
compiler/GHC/Cmm/Type.hs
=====================================
@@ -311,6 +311,8 @@ isVecType _ = False
-- Hints are extra type information we attach to the arguments and
-- results of a foreign call, where more type information is sometimes
-- needed by the ABI to make the correct kind of call.
+--
+-- See Note [Signed vs unsigned] for one case where this is used.
data ForeignHint
= NoHint | AddrHint | SignedHint
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -1227,7 +1227,10 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
-}
-- | Haskell Pattern Synonym Details
-type HsPatSynDetails pass = HsConDetails (LIdP pass) [RecordPatSynField (LIdP pass)]
+type HsPatSynDetails pass
+ = HsConDetails (LIdP pass)
+ [RecordPatSynField (LIdP pass)]
+ (LIdP pass)
-- See Note [Record PatSyn Fields]
-- | Record Pattern Synonym Field
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -2,6 +2,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -74,8 +75,9 @@ module GHC.Hs.Decls (
CImportSpec(..),
-- ** Data-constructor declarations
ConDecl(..), LConDecl,
- HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,
- getConNames, getConArgs,
+ HsConDeclDetails, HsConDeclH98Details, HsConDeclGADTDetails, noGadtInfix,
+ hsConDeclTheta,
+ getConNames, getRecConArgs_maybe,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
@@ -126,6 +128,7 @@ import GHC.Core.Type
import GHC.Data.Bag
import GHC.Data.Maybe
import Data.Data hiding (TyCon,Fixity, Infix)
+import Data.Void
{-
************************************************************************
@@ -1473,9 +1476,9 @@ data ConDecl pass
-- Whether or not there is an /explicit/ forall, we still
-- need to capture the implicitly-bound type/kind variables
- , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
- , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon
- , con_res_ty :: LHsType pass -- ^ Result type
+ , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
+ , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never InfixCon
+ , con_res_ty :: LHsType pass -- ^ Result type
, con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment.
@@ -1492,7 +1495,7 @@ data ConDecl pass
-- False => con_ex_tvs is empty
, con_ex_tvs :: [LHsTyVarBndr Specificity pass] -- ^ Existentials only
, con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
- , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon
+ , con_args :: HsConDeclH98Details pass -- ^ Arguments; can be InfixCon
, con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment.
@@ -1623,27 +1626,94 @@ or contexts in two parts:
quantification occurs after a visible argument type.
-}
--- | Haskell data Constructor Declaration Details
-type HsConDeclDetails pass
- = HsConDetails (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])
+-- | The arguments in a data constructor declaration. The @inf@ type parameter
+-- represents the representation for infix data constructors, which is
+-- different depending on whether the data constructor is Haskell98-style or
+-- GADT-style.
+type HsConDeclDetails pass inf
+ = HsConDetails (HsScaled pass (LBangType pass))
+ (XRec pass [LConDeclField pass])
+ inf
+
+-- | The arguments in a Haskell98-style data constructor, which can be infix.
+type HsConDeclH98Details pass
+ = HsConDeclDetails pass (HsScaled pass (LBangType pass))
+
+-- | The arguments in a GADT constructor, which cannot be infix.
+-- See @Note [GADT syntax can't be infix]@.
+type HsConDeclGADTDetails pass
+ = HsConDeclDetails pass Void
+
+-- | Eliminate the payload of an 'InfixCon' of type 'HsConDeclGADTDetails'.
+-- This function witnesses the fact that GADT constructors cannot be declared
+-- with infix syntax (see @Note [GADT syntax can't be infix]@). This function
+-- has the same implementation as 'Data.Void.absurd', but with a more specific
+-- name to indicate its purpose.
+noGadtInfix :: Void -> a
+noGadtInfix v = case v of {}
+
+{-
+Note [GADT syntax can't be infix]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The overall shape of Haskell98-style data constructors and GADT constructors
+are very similar, which allows us to use the HsConDetails data type to
+represent both forms of data constructors:
+
+ data HsConDetails arg rec inf
+ = PrefixCon [arg]
+ | RecCon rec
+ | InfixCon inf inf
+
+But there is a key difference between the syntaxes of each form of data
+constructor, however. Haskell98-style data constructors can use all three
+varieties of HsConDetails above:
+
+ data C p1 p2
+ = C1 p1 p2 -- PrefixCon
+ | C2 { x :: p1, y :: p2 } -- InfixCon
+ | p1 `C2` p2 -- RecCon
+
+GADT constructors, on the other hand, can only use two HsConDetails varieties:
+
+ data G p1 p2 where
+ G1 :: p1 -> p2 -> G p1 p2 -- PrefixCon
+ G2 :: { x :: p1, y :: p2 } -> G p1 p2 -- RecCon
+
+In other words, InfixCon is an unrepresentable state for GADT constructor
+syntax (#18844). We encode this knowledge as a Haskell type by using separate
+HsConDeclH98Details and HsConDeclGADTDetails type synonyms, which instantiate
+the `inf` parameter of `HsConDetails pre rec inf` to different things. In
+particular, HsConDeclGADTDetails instantiates `inf` to Void. This means that
+when you match on an argument of type HsConDeclGADTDetails, you can "forget"
+about the unrepresentable InfixCon case by using `noGadtInfix`:
+
+ f :: HsConDeclGADTDetails pass -> blah
+ f (PrefixCon _) = ...
+ f (RecCon _) = ...
+ f (InfixCon v _) = noGadtInfix v
+
+Note that this Note only applies to the *surface syntax* of GADT constructors.
+There is a notion of infix GADT constructors for the purposes of derived Show
+instances (see Note [Infix GADT constructors] in GHC.Tc.TyCl), but that is an
+orthogonal concern.
+-}
getConNames :: ConDecl GhcRn -> [Located Name]
getConNames ConDeclH98 {con_name = name} = [name]
getConNames ConDeclGADT {con_names = names} = names
-getConArgs :: ConDecl GhcRn -> HsConDeclDetails GhcRn
-getConArgs d = con_args d
-
-hsConDeclArgTys :: HsConDeclDetails (GhcPass p) -> [HsScaled (GhcPass p) (LBangType (GhcPass p))]
-hsConDeclArgTys (PrefixCon tys) = tys
-hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
-hsConDeclArgTys (RecCon flds) = map (hsLinear . cd_fld_type . unLoc) (unLoc flds)
- -- Remark: with the record syntax, constructors have all their argument
- -- linear, despite the fact that projections do not make sense on linear
- -- constructors. The design here is that the record projection themselves are
- -- typed to take an unrestricted argument (that is the record itself is
- -- unrestricted). By the transfer property, projections are then correct in
- -- that all the non-projected fields have multiplicity Many, and can be dropped.
+-- | Return @'Just' fields@ if a data constructor declaration uses record
+-- syntax (i.e., 'RecCon'), where @fields@ are the field selectors.
+-- Otherwise, return 'Nothing'.
+getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (Located [LConDeclField GhcRn])
+getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of
+ PrefixCon{} -> Nothing
+ RecCon flds -> Just flds
+ InfixCon{} -> Nothing
+getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of
+ PrefixCon{} -> Nothing
+ RecCon flds -> Just flds
+ InfixCon v _ -> noGadtInfix v
hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)]
hsConDeclTheta Nothing = []
@@ -1723,7 +1793,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con
cxt = fromMaybe noLHsContext mcxt
pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
- , con_mb_cxt = mcxt, con_args = args
+ , con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty, con_doc = doc })
= ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
<+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) cxt,
@@ -1731,7 +1801,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
where
get_args (PrefixCon args) = map ppr args
get_args (RecCon fields) = [pprConDeclFields (unLoc fields)]
- get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons)
+ get_args (InfixCon v _) = noGadtInfix v
cxt = fromMaybe noLHsContext mcxt
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -316,7 +316,7 @@ type instance ConLikeP GhcTc = ConLike
-- | Haskell Constructor Pattern Details
-type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
+type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p)) (LPat p)
hsConPatArgs :: HsConPatDetails p -> [LPat p]
hsConPatArgs (PrefixCon ps) = ps
@@ -866,7 +866,7 @@ patNeedsParens p = go
-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@
-- needs parentheses under precedence @p at .
-conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool
+conPatNeedsParens :: PprPrec -> HsConDetails a b c -> Bool
conPatNeedsParens p = go
where
go (PrefixCon args) = p >= appPrec && not (null args)
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -1104,15 +1104,19 @@ instance OutputableBndrId p
-- HsConDetails is used for patterns/expressions *and* for data type
-- declarations
--- | Haskell Constructor Details
-data HsConDetails arg rec
+-- | Haskell Constructor Details.
+--
+-- The @arg@ and @inf@ type parameters are kept separate so that GADT
+-- constructors (which cannot be declared with infix syntax) can instantiate
+-- @inf@ to @Void at . See @Note [GADT syntax can't be infix]@ in "GHC.Hs.Decls".
+data HsConDetails arg rec inf
= PrefixCon [arg] -- C p1 p2 p3
| RecCon rec -- C { x = p1, y = p2 }
- | InfixCon arg arg -- p1 `C` p2
+ | InfixCon inf inf -- p1 `C` p2
deriving Data
-instance (Outputable arg, Outputable rec)
- => Outputable (HsConDetails arg rec) where
+instance (Outputable arg, Outputable rec, Outputable inf)
+ => Outputable (HsConDetails arg rec inf) where
ppr (PrefixCon args) = text "PrefixCon" <+> ppr args
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1257,7 +1257,7 @@ hsConDeclsBinders cons
in case unLoc r of
-- remove only the first occurrence of any seen field in order to
-- avoid circumventing detection of duplicate fields (#9156)
- ConDeclGADT { con_names = names, con_args = args }
+ ConDeclGADT { con_names = names, con_g_args = args }
-> (map (L loc . unLoc) names ++ ns, flds ++ fs)
where
(remSeen', flds) = get_flds remSeen args
@@ -1269,7 +1269,7 @@ hsConDeclsBinders cons
(remSeen', flds) = get_flds remSeen args
(ns, fs) = go remSeen' rs
- get_flds :: Seen p -> HsConDeclDetails (GhcPass p)
+ get_flds :: Seen p -> HsConDeclDetails (GhcPass p) inf
-> (Seen p, [LFieldOcc (GhcPass p)])
get_flds remSeen (RecCon flds)
= (remSeen', fld_names)
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -189,7 +189,7 @@ subordinates instMap decl = case decl of
, conArgDocs c)
| c <- cons, cname <- getConNames c ]
fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
- | RecCon flds <- map getConArgs cons
+ | Just flds <- map getRecConArgs_maybe cons
, (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
, (L _ n) <- ns ]
derivs = [ (instName, [unLoc doc], M.empty)
@@ -216,22 +216,31 @@ subordinates instMap decl = case decl of
_ -> Nothing
-- | Extract constructor argument docs from inside constructor decls.
-conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
-conArgDocs con = case getConArgs con of
- PrefixCon args -> go 0 (map (unLoc . hsScaledThing) args ++ ret)
- InfixCon arg1 arg2 -> go 0 ([unLoc (hsScaledThing arg1),
- unLoc (hsScaledThing arg2)] ++ ret)
- RecCon _ -> go 1 ret
+conArgDocs :: ConDecl GhcRn -> Map Int HsDocString
+conArgDocs (ConDeclH98{con_args = args}) =
+ h98ConArgDocs args
+conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =
+ gadtConArgDocs args (unLoc res_ty)
+
+h98ConArgDocs :: HsConDeclH98Details GhcRn -> Map Int HsDocString
+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) ]
+ RecCon _ -> M.empty
+
+gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> Map Int HsDocString
+gadtConArgDocs con_args res_ty = case con_args of
+ PrefixCon args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]
+ InfixCon v _ -> noGadtInfix v
+ RecCon _ -> con_arg_docs 1 [res_ty]
+
+con_arg_docs :: Int -> [HsType GhcRn] -> Map Int HsDocString
+con_arg_docs n = M.fromList . catMaybes . zipWith f [n..]
where
- go n = M.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 _ _ = Nothing
-
- ret = case con of
- ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
- _ -> []
+ f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
+ f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)
+ f _ _ = Nothing
isValD :: HsDecl a -> Bool
isValD (ValD _ _) = True
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -869,7 +869,7 @@ repC (L _ (ConDeclH98 { con_name = con
, con_forall = (L _ False)
, con_mb_cxt = Nothing
, con_args = args }))
- = repDataCon con args
+ = repH98DataCon con args
repC (L _ (ConDeclH98 { con_name = con
, con_forall = L _ is_existential
@@ -877,7 +877,7 @@ repC (L _ (ConDeclH98 { con_name = con
, con_mb_cxt = mcxt
, con_args = args }))
= do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
- do { c' <- repDataCon con args
+ do { c' <- repH98DataCon con args
; ctxt' <- repMbContext mcxt
; if not is_existential && isNothing mcxt
then return c'
@@ -889,7 +889,7 @@ repC (L _ (ConDeclGADT { con_g_ext = imp_tvs
, con_names = cons
, con_qvars = exp_tvs
, con_mb_cxt = mcxt
- , con_args = args
+ , con_g_args = args
, con_res_ty = res_ty }))
| null imp_tvs && null exp_tvs -- No implicit or explicit variables
, Nothing <- mcxt -- No context
@@ -2581,49 +2581,52 @@ repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt))
repCtxt (MkC tys) = rep2 cxtName [tys]
-repDataCon :: Located Name
- -> HsConDeclDetails GhcRn
- -> MetaM (Core (M TH.Con))
-repDataCon con details
+repH98DataCon :: Located Name
+ -> HsConDeclH98Details GhcRn
+ -> MetaM (Core (M TH.Con))
+repH98DataCon con details
= do con' <- lookupLOcc con -- See Note [Binders and occurrences]
- repConstr details Nothing [con']
+ case details of
+ PrefixCon ps -> do
+ arg_tys <- repPrefixConArgs ps
+ rep2 normalCName [unC con', unC arg_tys]
+ InfixCon st1 st2 -> do
+ arg1 <- repBangTy (hsScaledThing st1)
+ arg2 <- repBangTy (hsScaledThing st2)
+ rep2 infixCName [unC arg1, unC con', unC arg2]
+ RecCon ips -> do
+ arg_vtys <- repRecConArgs ips
+ rep2 recCName [unC con', unC arg_vtys]
repGadtDataCons :: [Located Name]
- -> HsConDeclDetails GhcRn
+ -> HsConDeclGADTDetails GhcRn
-> LHsType GhcRn
-> MetaM (Core (M TH.Con))
repGadtDataCons cons details res_ty
= do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
- repConstr details (Just res_ty) cons'
-
--- Invariant:
--- * for plain H98 data constructors second argument is Nothing and third
--- argument is a singleton list
--- * for GADTs data constructors second argument is (Just return_type) and
--- third argument is a non-empty list
-repConstr :: HsConDeclDetails GhcRn
- -> Maybe (LHsType GhcRn)
- -> [Core TH.Name]
- -> MetaM (Core (M TH.Con))
-repConstr (PrefixCon ps) Nothing [con]
- = do arg_tys <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
- rep2 normalCName [unC con, unC arg_tys]
-
-repConstr (PrefixCon ps) (Just res_ty) cons
- = do arg_tys <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
- res_ty' <- repLTy res_ty
- rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
-
-repConstr (RecCon ips) resTy cons
- = do args <- concatMapM rep_ip (unLoc ips)
- arg_vtys <- coreListM varBangTypeTyConName args
- case resTy of
- Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
- Just res_ty -> do
+ case details of
+ PrefixCon ps -> do
+ arg_tys <- repPrefixConArgs ps
res_ty' <- repLTy res_ty
- rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
+ rep2 gadtCName [ unC (nonEmptyCoreList cons'), unC arg_tys, unC res_ty']
+ InfixCon v _ -> noGadtInfix v
+ RecCon ips -> do
+ arg_vtys <- repRecConArgs ips
+ res_ty' <- repLTy res_ty
+ rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys,
unC res_ty']
+-- Desugar the arguments in a PrefixCon.
+repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)]
+ -> MetaM (Core [M TH.BangType])
+repPrefixConArgs ps = repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
+
+-- Desugar the arguments in a RecCon.
+repRecConArgs :: Located [LConDeclField GhcRn]
+ -> MetaM (Core [M TH.VarBangType])
+repRecConArgs ips = do
+ args <- concatMapM rep_ip (unLoc ips)
+ coreListM varBangTypeTyConName args
where
rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
@@ -2632,16 +2635,6 @@ repConstr (RecCon ips) resTy cons
; MkC ty <- repBangTy t
; rep2 varBangTypeName [v,ty] }
-repConstr (InfixCon st1 st2) Nothing [con]
- = do arg1 <- repBangTy (hsScaledThing st1)
- arg2 <- repBangTy (hsScaledThing st2)
- rep2 infixCName [unC arg1, unC con, unC arg2]
-
-repConstr (InfixCon {}) (Just _) _ =
- panic "repConstr: infix GADT constructor should be in a PrefixCon"
-repConstr _ _ _ =
- panic "repConstr: invariant violated"
-
------------ Types -------------------
repTForall :: Core [(M (TH.TyVarBndr TH.Specificity))] -> Core (M TH.Cxt) -> Core (M TH.Type)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -68,6 +68,7 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Data.Data ( Data, Typeable )
import Data.List ( foldl1' )
+import Data.Void
import Control.Monad ( forM_ )
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Reader
@@ -578,6 +579,9 @@ class ToHie a where
class HasType a where
getTypeNode :: a -> HieM [HieAST Type]
+instance ToHie Void where
+ toHie = absurd
+
instance (ToHie a) => ToHie [a] where
toHie = concatMapM toHie
@@ -996,8 +1000,10 @@ instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where
HieRn -> []
#endif
where
- contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a)
- -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))
+ contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a) a
+ -> HsConDetails (PScoped a)
+ (RContext (HsRecFields (GhcPass p) (PScoped a)))
+ (PScoped a)
contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
contextify (InfixCon a b) = InfixCon a' b'
where [a', b'] = patScopes rsp scope pscope [a,b]
@@ -1314,7 +1320,7 @@ instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
, toHie $ PS Nothing sc NoScope pat
]
-instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
+instance (ToHie arg, ToHie rec, ToHie inf) => ToHie (HsConDetails arg rec inf) where
toHie (PrefixCon args) = toHie args
toHie (RecCon rec) = toHie rec
toHie (InfixCon a b) = concatM [ toHie a, toHie b]
@@ -1530,7 +1536,7 @@ instance ToHie a => ToHie (HsScaled GhcRn a) where
instance ToHie (Located (ConDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars
- , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
+ , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } ->
[ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
, concatM $ [ bindingsOnly bindings
, toHie $ tvScopes resScope NoScope exp_vars ]
@@ -1541,7 +1547,10 @@ instance ToHie (Located (ConDecl GhcRn)) where
where
rhsScope = combineScopes argsScope tyScope
ctxScope = maybe NoScope mkLScope ctx
- argsScope = condecl_scope args
+ argsScope = case args of
+ PrefixCon xs -> scaled_args_scope xs
+ InfixCon v _ -> noGadtInfix v
+ RecCon x -> mkLScope x
tyScope = mkLScope typ
resScope = ResolvedScopes [ctxScope, rhsScope]
bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars
@@ -1555,13 +1564,12 @@ instance ToHie (Located (ConDecl GhcRn)) where
where
rhsScope = combineScopes ctxScope argsScope
ctxScope = maybe NoScope mkLScope ctx
- argsScope = condecl_scope dets
- where condecl_scope :: HsConDeclDetails (GhcPass p) -> Scope
- condecl_scope args = case args of
- PrefixCon xs -> foldr combineScopes NoScope $ map (mkLScope . hsScaledThing) xs
- InfixCon a b -> combineScopes (mkLScope (hsScaledThing a))
- (mkLScope (hsScaledThing b))
- RecCon x -> mkLScope x
+ argsScope = case dets of
+ PrefixCon xs -> scaled_args_scope xs
+ InfixCon a b -> scaled_args_scope [a, b]
+ RecCon x -> mkLScope x
+ where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope
+ scaled_args_scope = foldr combineScopes NoScope . map (mkLScope . hsScaledThing)
instance ToHie (Located [Located (ConDeclField GhcRn)]) where
toHie (L span decls) = concatM $
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2332,7 +2332,7 @@ forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }
: 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }
| {- empty -} { noLoc ([], Nothing) }
-constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs) }
+constr_stuff :: { Located (Located RdrName, HsConDeclH98Details GhcPs) }
: infixtype {% fmap (mapLoc (\b -> (dataConBuilderCon b,
dataConBuilderDetails b)))
(runPV $1) }
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -608,7 +608,7 @@ recordPatSynErr loc pat =
addFatalError $ Error (ErrRecordSyntaxInPatSynDecl pat) [] loc
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
- -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
+ -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs
-> ConDecl GhcPs
mkConDeclH98 name mb_forall mb_cxt args
@@ -643,7 +643,7 @@ mkGadtDecl names ty = do
, con_forall = L (getLoc ty) $ isJust mtvs
, con_qvars = fromMaybe [] mtvs
, con_mb_cxt = mcxt
- , con_args = args
+ , con_g_args = args
, con_res_ty = res_ty
, con_doc = Nothing }
, anns )
@@ -1615,7 +1615,7 @@ dataConBuilderCon :: DataConBuilder -> Located RdrName
dataConBuilderCon (PrefixDataConBuilder _ dc) = dc
dataConBuilderCon (InfixDataConBuilder _ dc _) = dc
-dataConBuilderDetails :: DataConBuilder -> HsConDeclDetails GhcPs
+dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs
-- Detect when the record syntax is used:
-- data T = MkT { ... }
=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -690,22 +690,22 @@ instance HasHaddock (Located (ConDecl GhcPs)) where
addHaddock (L l_con_decl con_decl) =
extendHdkA l_con_decl $
case con_decl of
- ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_args, con_res_ty } -> do
+ ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_g_args, con_res_ty } -> do
-- discardHasInnerDocs is ok because we don't need this info for GADTs.
con_doc' <- discardHasInnerDocs $ getConDoc (getLoc (head con_names))
- con_args' <-
- case con_args of
+ con_g_args' <-
+ case con_g_args of
PrefixCon ts -> PrefixCon <$> addHaddock ts
RecCon (L l_rec flds) -> do
-- discardHasInnerDocs is ok because we don't need this info for GADTs.
flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds
pure $ RecCon (L l_rec flds')
- InfixCon _ _ -> panic "ConDeclGADT InfixCon"
+ InfixCon v _ -> noGadtInfix v
con_res_ty' <- addHaddock con_res_ty
pure $ L l_con_decl $
ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt,
con_doc = con_doc',
- con_args = con_args',
+ con_g_args = con_g_args',
con_res_ty = con_res_ty' }
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } ->
addConTrailingDoc (srcSpanEnd l_con_decl) $
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -29,9 +29,9 @@ module GHC.Rename.HsType (
rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars,
FreeKiTyVars,
extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
- extractHsTysRdrTyVars, extractRdrKindSigVars, extractDataDefnKindVars,
+ extractHsTysRdrTyVars, extractRdrKindSigVars,
+ extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,
extractHsTvBndrs, extractHsTyArgRdrKiTyVars,
- extractHsScaledTysRdrTyVars,
forAllOrNothing, nubL
) where
@@ -1747,9 +1747,6 @@ extractHsTyArgRdrKiTyVars args
extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars ty = extract_lty ty []
-extractHsScaledTysRdrTyVars :: [HsScaled GhcPs (LHsType GhcPs)] -> FreeKiTyVars -> FreeKiTyVars
-extractHsScaledTysRdrTyVars args acc = foldr (\(HsScaled m ty) -> extract_lty ty . extract_hs_arrow m) acc args
-
-- | Extracts the free type/kind variables from the kind signature of a HsType.
-- This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k at .
-- The left-to-right order of variables is preserved.
@@ -1787,6 +1784,16 @@ extractRdrKindSigVars (L _ resultSig) = case resultSig of
TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k
_ -> []
+-- | Extracts free type and kind variables from an argument in a GADT
+-- constructor, returning variable occurrences in left-to-right order.
+-- See @Note [Ordering of implicit variables]@.
+extractConDeclGADTDetailsTyVars ::
+ HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars
+extractConDeclGADTDetailsTyVars con_args = case con_args of
+ PrefixCon args -> extract_scaled_ltys args
+ InfixCon v _ -> noGadtInfix v
+ RecCon (L _ flds) -> extract_ltys $ map (cd_fld_type . unLoc) $ flds
+
-- | Get type/kind variables mentioned in the kind signature, preserving
-- left-to-right order:
--
@@ -1801,6 +1808,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)]
+ -> FreeKiTyVars -> FreeKiTyVars
+extract_scaled_ltys args acc = foldr extract_scaled_lty acc args
+
+extract_scaled_lty :: HsScaled GhcPs (LHsType GhcPs)
+ -> FreeKiTyVars -> FreeKiTyVars
+extract_scaled_lty (HsScaled m ty) acc = extract_lty ty $ extract_hs_arrow m acc
+
extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extract_ltys tys acc = foldr extract_lty acc tys
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -2180,7 +2180,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
; bindLHsTyVarBndrs ctxt WarnUnusedForalls
Nothing ex_tvs $ \ new_ex_tvs ->
do { (new_context, fvs1) <- rnMbContext ctxt mcxt
- ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args
+ ; (new_args, fvs2) <- rnConDeclH98Details (unLoc new_name) ctxt args
; let all_fvs = fvs1 `plusFV` fvs2
; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat
[ text "ex_tvs:" <+> ppr ex_tvs
@@ -2197,15 +2197,12 @@ rnConDecl decl@(ConDeclGADT { con_names = names
, con_forall = forall@(L _ explicit_forall)
, con_qvars = explicit_tkvs
, con_mb_cxt = mcxt
- , con_args = args
+ , con_g_args = args
, con_res_ty = res_ty
, con_doc = mb_doc })
= do { mapM_ (addLocM checkConName) names
; new_names <- mapM lookupLocatedTopBndrRn names
- ; let theta = hsConDeclTheta mcxt
- arg_tys = hsConDeclArgTys args
-
-- We must ensure that we extract the free tkvs in left-to-right
-- order of their appearance in the constructor type.
-- That order governs the order the implicitly-quantified type
@@ -2213,9 +2210,9 @@ rnConDecl decl@(ConDeclGADT { con_names = names
-- See #14808.
; implicit_bndrs <- forAllOrNothing explicit_forall
$ extractHsTvBndrs explicit_tkvs
- $ extractHsTysRdrTyVars theta
- $ extractHsScaledTysRdrTyVars arg_tys
- $ extractHsTysRdrTyVars [res_ty] []
+ $ extractHsTysRdrTyVars (hsConDeclTheta mcxt)
+ $ extractConDeclGADTDetailsTyVars args
+ $ extractHsTyRdrTyVars res_ty
; let ctxt = ConDeclCtx new_names
@@ -2223,7 +2220,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names
bindLHsTyVarBndrs ctxt WarnUnusedForalls
Nothing explicit_tkvs $ \ explicit_tkvs ->
do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt
- ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args
+ ; (new_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args
; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
-- Ensure that there are no nested `forall`s or contexts, per
@@ -2238,7 +2235,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names
(ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)
; return (decl { con_g_ext = implicit_tkvs, con_names = new_names
, con_qvars = explicit_tkvs, con_mb_cxt = new_cxt
- , con_args = new_args, con_res_ty = new_res_ty
+ , con_g_args = new_args, con_res_ty = new_res_ty
, con_doc = mb_doc
, con_forall = forall }, -- Remove when #18311 is fixed
all_fvs) } }
@@ -2249,22 +2246,36 @@ rnMbContext _ Nothing = return (Nothing, emptyFVs)
rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt
; return (Just ctx',fvs) }
-rnConDeclDetails
- :: Name
+rnConDeclH98Details ::
+ Name
+ -> HsDocContext
+ -> HsConDeclH98Details GhcPs
+ -> RnM (HsConDeclH98Details GhcRn, FreeVars)
+rnConDeclH98Details = rnConDeclDetails rnScaledLHsType
+
+rnConDeclGADTDetails ::
+ Name
+ -> HsDocContext
+ -> HsConDeclGADTDetails GhcPs
+ -> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
+rnConDeclGADTDetails = rnConDeclDetails (\_ -> noGadtInfix)
+
+rnConDeclDetails ::
+ (HsDocContext -> infPs -> RnM (infRn, FreeVars))
+ -> Name
-> HsDocContext
- -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (Located [LConDeclField GhcPs])
- -> RnM ((HsConDetails (HsScaled GhcRn (LHsType GhcRn))) (Located [LConDeclField GhcRn]),
- FreeVars)
-rnConDeclDetails _ doc (PrefixCon tys)
+ -> HsConDeclDetails GhcPs infPs
+ -> RnM (HsConDeclDetails GhcRn infRn, FreeVars)
+rnConDeclDetails _ _ doc (PrefixCon tys)
= do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys
; return (PrefixCon new_tys, fvs) }
-rnConDeclDetails _ doc (InfixCon ty1 ty2)
- = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1
- ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2
+rnConDeclDetails rn_inf _ doc (InfixCon ty1 ty2)
+ = do { (new_ty1, fvs1) <- rn_inf doc ty1
+ ; (new_ty2, fvs2) <- rn_inf doc ty2
; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
-rnConDeclDetails con doc (RecCon (L l fields))
+rnConDeclDetails _ con doc (RecCon (L l fields))
= do { fls <- lookupConstructorFields con
; (new_fields, fvs) <- rnConDeclFields doc fls fields
-- No need to check for duplicate fields
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -759,7 +759,7 @@ getLocalNonValBinders fixity_env
= [( find_con_name rdr
, concatMap find_con_decl_flds (unLoc cdflds) )]
find_con_flds (L _ (ConDeclGADT { con_names = rdrs
- , con_args = RecCon flds }))
+ , con_g_args = RecCon flds }))
= [ ( find_con_name rdr
, concatMap find_con_decl_flds (unLoc flds))
| L _ rdr <- rdrs ]
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -1563,7 +1563,7 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc
-------------------
--- Type check the types of the arguments to a data constructor.
+-- Kind-check the type of an argument to a data constructor.
-- This includes doing kind unification if the type is a newtype.
-- See Note [Implementation of UnliftedNewtypes] for why we need
-- the first two arguments.
@@ -1576,6 +1576,23 @@ kcConArgTys new_or_data res_kind arg_tys = do
-- See Note [Implementation of UnliftedNewtypes], STEP 2
}
+-- Kind-check the types of arguments to a Haskell98 data constructor.
+kcConH98Args :: NewOrData -> Kind -> HsConDeclH98Details GhcRn -> TcM ()
+kcConH98Args = kcConArgs kcConArgTys
+
+-- Kind-check the types of arguments to a GADT data constructor.
+kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM ()
+kcConGADTArgs = kcConArgs (\_ _ -> mapM_ noGadtInfix)
+
+-- Kind-check the types of argument to a data constructor.
+kcConArgs :: (NewOrData -> Kind -> [infRn] -> TcM ())
+ -> NewOrData -> Kind -> HsConDeclDetails GhcRn infRn -> TcM ()
+kcConArgs kc_inf new_or_data res_kind con_args = case con_args of
+ PrefixCon tys -> kcConArgTys new_or_data res_kind tys
+ InfixCon ty1 ty2 -> kc_inf new_or_data res_kind [ty1, ty2]
+ RecCon (L _ flds) -> kcConArgTys new_or_data res_kind $
+ map (hsLinear . cd_fld_type . unLoc) flds
+
kcConDecls :: NewOrData
-> Kind -- The result kind signature
-> [LConDecl GhcRn] -- The data constructors
@@ -1604,14 +1621,14 @@ kcConDecl new_or_data res_kind (ConDeclH98
discardResult $
bindExplicitTKBndrs_Tv ex_tvs $
do { _ <- tcHsMbContext ex_ctxt
- ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)
+ ; kcConH98Args new_or_data res_kind args
-- We don't need to check the telescope here,
-- because that's done in tcConDecl
}
kcConDecl new_or_data res_kind (ConDeclGADT
{ con_names = names, con_qvars = explicit_tkv_nms, con_mb_cxt = cxt
- , con_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms })
+ , con_g_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms })
= -- Even though the GADT-style data constructor's type is closed,
-- we must still kind-check the type, because that may influence
-- the inferred kind of the /type/ constructor. Example:
@@ -1625,7 +1642,7 @@ kcConDecl new_or_data res_kind (ConDeclGADT
bindExplicitTKBndrs_Tv explicit_tkv_nms $
-- Why "_Tv"? See Note [Kind-checking for GADTs]
do { _ <- tcHsMbContext cxt
- ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)
+ ; kcConGADTArgs new_or_data res_kind args
; _ <- tcHsOpenType res_ty
; return () }
@@ -3196,7 +3213,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data
bindExplicitTKBndrs_Skol explicit_tkv_nms $
do { ctxt <- tcHsMbContext hs_ctxt
; let exp_kind = getArgExpKind new_or_data res_kind
- ; btys <- tcConArgs exp_kind hs_args
+ ; btys <- tcConH98Args exp_kind hs_args
; field_lbls <- lookupConstructorFields name
; let (arg_tys, stricts) = unzip btys
; return (ctxt, arg_tys, field_lbls, stricts)
@@ -3266,7 +3283,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data
(ConDeclGADT { con_g_ext = implicit_tkv_nms
, con_names = names
, con_qvars = explicit_tkv_nms
- , con_mb_cxt = cxt, con_args = hs_args
+ , con_mb_cxt = cxt, con_g_args = hs_args
, con_res_ty = hs_res_ty })
= addErrCtxt (dataConCtxtName names) $
do { traceTc "tcConDecl 1 gadt" (ppr names)
@@ -3283,7 +3300,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data
-- See Note [Datatype return kinds]
; let exp_kind = getArgExpKind new_or_data res_kind
- ; btys <- tcConArgs exp_kind hs_args
+ ; btys <- tcConGADTArgs exp_kind hs_args
; let (arg_tys, stricts) = unzip btys
; field_lbls <- lookupConstructorFields name
; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
@@ -3362,19 +3379,20 @@ getArgExpKind NewType res_ki = TheKind res_ki
getArgExpKind DataType _ = OpenKind
tcConIsInfixH98 :: Name
- -> HsConDetails a b
+ -> HsConDeclH98Details GhcRn
-> TcM Bool
tcConIsInfixH98 _ details
= case details of
InfixCon {} -> return True
- _ -> return False
+ RecCon{} -> return False
+ PrefixCon{} -> return False
tcConIsInfixGADT :: Name
- -> HsConDetails (HsScaled GhcRn (LHsType GhcRn)) r
+ -> HsConDeclGADTDetails GhcRn
-> TcM Bool
tcConIsInfixGADT con details
= case details of
- InfixCon {} -> return True
+ InfixCon v _ -> noGadtInfix v
RecCon {} -> return False
PrefixCon arg_tys -- See Note [Infix GADT constructors]
| isSymOcc (getOccName con)
@@ -3383,18 +3401,31 @@ tcConIsInfixGADT con details
; return (con `elemNameEnv` fix_env) }
| otherwise -> return False
-tcConArgs :: ContextKind -- expected kind of arguments
+tcConH98Args :: ContextKind -- expected kind of arguments
+ -- always OpenKind for datatypes, but unlifted newtypes
+ -- might have a specific kind
+ -> HsConDeclH98Details GhcRn
+ -> TcM [(Scaled TcType, HsSrcBang)]
+tcConH98Args = tcConArgs tcConArg
+
+tcConGADTArgs :: ContextKind -- expected kind of arguments
+ -- always OpenKind for datatypes, but unlifted newtypes
+ -- might have a specific kind
+ -> HsConDeclGADTDetails GhcRn
+ -> TcM [(Scaled TcType, HsSrcBang)]
+tcConGADTArgs = tcConArgs (\_ -> noGadtInfix)
+
+tcConArgs :: (ContextKind -> infRn -> TcM (Scaled TcType, HsSrcBang))
+ -> ContextKind -- expected kind of arguments
-- always OpenKind for datatypes, but unlifted newtypes
-- might have a specific kind
- -> HsConDeclDetails GhcRn
+ -> HsConDeclDetails GhcRn infRn
-> TcM [(Scaled TcType, HsSrcBang)]
-tcConArgs exp_kind (PrefixCon btys)
+tcConArgs _ exp_kind (PrefixCon btys)
= mapM (tcConArg exp_kind) btys
-tcConArgs exp_kind (InfixCon bty1 bty2)
- = do { bty1' <- tcConArg exp_kind bty1
- ; bty2' <- tcConArg exp_kind bty2
- ; return [bty1', bty2'] }
-tcConArgs exp_kind (RecCon fields)
+tcConArgs tc_inf exp_kind (InfixCon bty1 bty2)
+ = mapM (tc_inf exp_kind) [bty1, bty2]
+tcConArgs _ exp_kind (RecCon fields)
= mapM (tcConArg exp_kind) btys
where
-- We need a one-to-one mapping from field_names to btys
@@ -3434,7 +3465,8 @@ matches what the user wrote (#18791).
Note [Infix GADT constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not currently have syntax to declare an infix constructor in GADT syntax,
+We do not currently have syntax to declare an infix constructor in GADT syntax
+(see Note [GADT syntax can't be infix] in GHC.Hs.Decls),
but it makes a (small) difference to the Show instance. So as a slightly
ad-hoc solution, we regard a GADT data constructor as infix if
a) it is an operator symbol
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -31,9 +31,9 @@ import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.Zonk
import GHC.Builtin.Types.Prim
import GHC.Types.Name
+import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Core.PatSyn
-import GHC.Types.Name.Set
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Data.FastString
@@ -422,14 +422,22 @@ tcCheckPatSynDecl psb at PSB{ psb_id = lname@(L _ name), psb_args = details
; tc_patsyn_finish lname dir is_infix lpat'
(univ_bndrs, req_theta, ev_binds, req_dicts)
(ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
- (args', (map scaledThing arg_tys))
+ (args', map scaledThing arg_tys)
pat_ty rec_fields }
where
tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc)
+ -- Look up the variable actually bound by lpat
+ -- and check that it has the expected type
tc_arg subst arg_name arg_ty
- = do { -- Look up the variable actually bound by lpat
- -- and check that it has the expected type
- arg_id <- tcLookupId arg_name
+ = setSrcSpan (nameSrcSpan arg_name) $
+ -- Set the SrcSpan to be the binding site of the Id (#18856)
+ -- e.g. pattern P :: Int -> Maybe (Int,Bool)
+ -- pattern P x = Just (x,True)
+ -- Before unifying x's actual type with its expected type, in tc_arg, set
+ -- location to x's binding site in lpat, namely the 'x' in Just (x,True).
+ -- Else the error message location is wherever tcCheckPat finished,
+ -- namely the right-hand corner of the pattern
+ do { arg_id <- tcLookupId arg_name
; wrap <- tcSubTypeSigma GenSigCtxt
(idType arg_id)
(substTyUnchecked subst arg_ty)
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -631,7 +631,7 @@ cvtConstr (RecGadtC c varstrtys ty)
; rec_flds <- mapM cvt_id_arg varstrtys
; returnL $ mk_gadt_decl c' (RecCon $ noLoc rec_flds) ty' }
-mk_gadt_decl :: [Located RdrName] -> HsConDeclDetails GhcPs -> LHsType GhcPs
+mk_gadt_decl :: [Located RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
-> ConDecl GhcPs
mk_gadt_decl names args res_ty
= ConDeclGADT { con_g_ext = noExtField
@@ -639,7 +639,7 @@ mk_gadt_decl names args res_ty
, con_forall = noLoc False
, con_qvars = []
, con_mb_cxt = Nothing
- , con_args = args
+ , con_g_args = args
, con_res_ty = res_ty
, con_doc = Nothing }
=====================================
docs/users_guide/9.2.1-notes.rst
=====================================
@@ -43,14 +43,63 @@ Compiler
- ``Void#`` is now a type synonym for the unboxed tuple ``(# #)``.
Code using ``Void#`` now has to enable :extension:`UnboxedTuples`.
+``ghc`` library
+~~~~~~~~~~~~~~~
+
+- The ``con_args`` field of ``ConDeclGADT`` has been renamed to ``con_g_args``.
+ This is because the type of ``con_g_args`` is now different from the type of
+ the ``con_args`` field in ``ConDeclH98``: ::
+
+ data ConDecl pass
+ = ConDeclGADT
+ { ...
+ , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never InfixCon
+ , ...
+ }
+
+ | ConDeclH98
+ { ...
+ , con_args :: HsConDeclH98Details pass -- ^ Arguments; can be InfixCon
+ , ...
+ }
+
+ Where: ::
+
+ -- New type synonym introduced in GHC 9.2; equivalent to `HsConDeclDetails`
+ -- in previous versions of GHC
+ type HsConDeclH98Details pass
+ = HsConDeclDetails pass (HsScaled pass (LBangType pass))
+
+ -- New type synonym introduced in GHC 9.2
+ type HsConDeclGADTDetails pass
+ = HsConDeclDetails pass Void
+
+ -- The `inf` type parameter is new in GHC 9.2
+ type HsConDeclDetails pass inf
+ = HsConDetails (HsScaled pass (LBangType pass))
+ (XRec pass [LConDeclField pass])
+ inf
+
+ -- The `inf` type parameter is new in GHC 9.2
+ data HsConDetails arg rec inf
+ = PrefixCon [arg] -- C p1 p2 p3
+ | RecCon rec -- C { x = p1, y = p2 }
+ | InfixCon inf inf -- p1 `C` p2
+
+ The use of ``Void`` in ``HsConDeclGADTDetails`` reflects the fact that GADT
+ constructors cannot use infix syntax like Haskell98-style constructors can.
+
+ As a result of all this, the ``con_args`` field is now partial, so using
+ ``con_args`` as a top-level field selector is discouraged.
+
``base`` library
~~~~~~~~~~~~~~~~
-- It's possible now to promote the ``Natural`` type: ::
-
+- It's possible now to promote the ``Natural`` type: ::
+
data Coordinate = Mk2D Natural Natural
type MyCoordinate = Mk2D 1 10
-
+
The separate kind ``Nat`` is removed and now it is just a type synonym for
``Natural``. As a consequence, one must enable ``TypeSynonymInstances``
in order to define instances for ``Nat``.
=====================================
testsuite/tests/parser/should_compile/T12862.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE TypeFamilies, InstanceSigs #-}
+{-# LANGUAGE BangPatterns #-} -- should parse even with BangPatterns enabled
+
+module T12862 where
+
+import Data.Kind (Type)
+
+class Key key where
+ data TotalMap key :: Type -> Type
+ (!) :: TotalMap key val -> (key -> val)
+
+instance Key Bool where
+ data TotalMap Bool val = BoolMap val val
+ (!) :: TotalMap Bool val -> (Bool -> val)
+ (BoolMap f _) ! False = f -- with parentheses
+ BoolMap f _ ! True = f -- without parentheses
=====================================
testsuite/tests/parser/should_compile/all.T
=====================================
@@ -172,3 +172,4 @@ test('T15730a', normal, compile_and_run, [''])
test('T18130', normal, compile, [''])
test('T18834a', normal, compile, [''])
test('T18834b', normal, compile, [''])
+test('T12862', normal, compile, [''])
=====================================
testsuite/tests/parser/should_fail/T12446.hs
=====================================
@@ -0,0 +1,3 @@
+module T12446 where
+
+x = undefined @(_ ~ _)
=====================================
testsuite/tests/parser/should_fail/T12446.stderr
=====================================
@@ -0,0 +1,4 @@
+
+T12446.hs:3:5: error:
+ Illegal visible type application ‘@(_ ~ _)’
+ Perhaps you intended to use TypeApplications
=====================================
testsuite/tests/parser/should_fail/all.T
=====================================
@@ -173,3 +173,4 @@ test('T18251c', normal, compile_fail, [''])
test('T18251d', normal, compile_fail, [''])
test('T18251e', normal, compile_fail, [''])
test('T18251f', normal, compile_fail, [''])
+test('T12446', normal, compile_fail, [''])
=====================================
testsuite/tests/patsyn/should_fail/T11010.stderr
=====================================
@@ -1,5 +1,5 @@
-T11010.hs:9:36: error:
+T11010.hs:9:34: error:
• Couldn't match type ‘a1’ with ‘Int’
Expected: a -> b
Actual: a1 -> b
@@ -12,3 +12,6 @@ T11010.hs:9:36: error:
• Relevant bindings include
x :: Expr a1 (bound at T11010.hs:9:36)
f :: a1 -> b (bound at T11010.hs:9:34)
+ |
+9 | pattern IntFun str f x = Fun str f x
+ | ^
=====================================
testsuite/tests/patsyn/should_fail/T18856.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+
+module T18856 where
+
+pattern P :: Int -> Bool -> (Int, Bool, [(Bool,Bool)])
+pattern P p q <- (q, p, [(True,False)])
+
=====================================
testsuite/tests/patsyn/should_fail/T18856.stderr
=====================================
@@ -0,0 +1,14 @@
+
+T18856.hs:6:19: error:
+ • Couldn't match expected type ‘Bool’ with actual type ‘Int’
+ • In the declaration for pattern synonym ‘P’
+ |
+6 | pattern P p q <- (q, p, [(True,False)])
+ | ^
+
+T18856.hs:6:22: error:
+ • Couldn't match expected type ‘Int’ with actual type ‘Bool’
+ • In the declaration for pattern synonym ‘P’
+ |
+6 | pattern P p q <- (q, p, [(True,False)])
+ | ^
=====================================
testsuite/tests/patsyn/should_fail/all.T
=====================================
@@ -9,7 +9,7 @@ test('T9705-2', normal, compile_fail, [''])
test('unboxed-bind', normal, compile_fail, [''])
test('unboxed-wrapper-naked', normal, compile_fail, [''])
test('T10873', normal, compile_fail, [''])
-test('T11010', normal, compile_fail, [''])
+test('T11010', normal, compile_fail, ['-fdiagnostics-show-caret'])
test('records-check-sels', normal, compile_fail, [''])
test('records-no-uni-update', normal, compile_fail, [''])
test('records-no-uni-update2', normal, compile_fail, [''])
@@ -47,3 +47,4 @@ test('T15692', normal, compile, ['']) # It has -fdefer-type-errors inside
test('T15694', normal, compile_fail, [''])
test('T16900', normal, compile_fail, ['-fdiagnostics-show-caret'])
test('T14552', normal, compile_fail, [''])
+test('T18856', normal, compile_fail, ['-fdiagnostics-show-caret'])
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit a7d1d8e034d25612d5d08ed8fdbf6f472aded4a1
+Subproject commit 27a4229b2082bc4f55a0e11f2f39f3076b9ea0d8
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3818ba159df0856c5a43689a44513727edf47fe5...04b85ddce6dfe17a319716308b7e5d858477b852
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3818ba159df0856c5a43689a44513727edf47fe5...04b85ddce6dfe17a319716308b7e5d858477b852
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201025/765fb278/attachment-0001.html>
More information about the ghc-commits
mailing list