[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: SysTools.Process: Handle exceptions in readCreateProcessWithExitCode'
Marge Bot
gitlab at gitlab.haskell.org
Tue Aug 25 04:07:08 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
e06ba67d by Ben Gamari at 2020-08-25T00:06:53-04:00
SysTools.Process: Handle exceptions in readCreateProcessWithExitCode'
In #18069 we are observing MVar deadlocks from somewhere in ghc.exe.
This use of MVar stood out as being one of the more likely culprits.
Here we make sure that it is exception-safe.
- - - - -
7053cfc0 by Richard Eisenberg at 2020-08-25T00:06:55-04:00
Use tcView, not coreView, in the pure unifier.
Addresses a lingering point within #11715.
- - - - -
ff5ea233 by Simon Peyton Jones at 2020-08-25T00:06:56-04:00
Use LIdP rather than (XRec p (IdP p))
This patch mainly just replaces use of
XRec p (IdP p)
with
LIdP p
One slightly more significant change is to parameterise
HsPatSynDetails over the pass rather than the argument type,
so that it's uniform with HsConDeclDetails and HsConPatDetails.
I also got rid of the dead code GHC.Hs.type.conDetailsArgs
But this is all just minor refactoring. No change in functionality.
- - - - -
b3711405 by Krzysztof Gogolewski at 2020-08-25T00:06:57-04:00
Add a test for #18585
- - - - -
18 changed files:
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Parser.y
- compiler/GHC/SysTools/Process.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/Utils/Zonk.hs
- + testsuite/tests/typecheck/should_compile/T18585.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -358,10 +358,28 @@ But in Core these two are treated as identical.
We implement this by making 'coreView' convert 'Constraint' to 'TYPE
LiftedRep' on the fly. The function tcView (used in the type checker)
-does not do this.
+does not do this. Accordingly, tcView is used in type-checker-oriented
+functions (including the pure unifier, used in instance resolution),
+while coreView is used during e.g. optimisation passes.
See also #11715, which tracks removing this inconsistency.
+The inconsistency actually leads to a potential soundness bug, in that
+Constraint and Type are considered *apart* by the type family engine.
+To wit, we can write
+
+ type family F a
+ type instance F Type = Bool
+ type instance F Constraint = Int
+
+and (because Type ~# Constraint in Core), thus build a coercion between
+Int and Bool. I (Richard E) conjecture that this never happens in practice,
+but it's very uncomfortable. This, essentially, is the root problem
+underneath #11715, which is quite resistant to an easy fix. The best
+idea is to have roles in kind coercions, but that has yet to be implemented.
+See also "A Role for Dependent Types in Haskell", ICFP 2019, which describes
+how roles in kinds might work out.
+
-}
-- | Gives the typechecker view of a type. This unwraps synonyms but
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -957,7 +957,7 @@ unify_ty :: UMEnv
-- Respects newtypes, PredTypes
unify_ty env ty1 ty2 kco
- -- TODO: More commentary needed here
+ -- Use tcView, not coreView. See Note [coreView vs tcView] in GHC.Core.Type.
| Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco
| Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco
| CastTy ty1' co <- ty1 = if um_unif env
@@ -1121,7 +1121,8 @@ uUnrefined :: UMEnv
-- We know that tv1 isn't refined
uUnrefined env tv1' ty2 ty2' kco
- | Just ty2'' <- coreView ty2'
+ -- Use tcView, not coreView. See Note [coreView vs tcView] in GHC.Core.Type.
+ | Just ty2'' <- tcView ty2'
= uUnrefined env tv1' ty2 ty2'' kco -- Unwrap synonyms
-- This is essential, in case we have
-- type Foo a = a
@@ -1412,6 +1413,8 @@ ty_co_match :: MatchEnv -- ^ ambient helpful info
-> Maybe LiftCoEnv
ty_co_match menv subst ty co lkco rkco
| Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco
+ -- why coreView here, not tcView? Because we're firmly after type-checking.
+ -- This function is used only during coercion optimisation.
-- handle Refl case:
| tyCoVarsOfType ty `isNotInDomainOf` subst
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -243,7 +243,7 @@ data HsBindLR idL idR
-- type Int -> forall a'. a' -> a'
-- Notice that the coercion captures the free a'.
- fun_id :: XRec idL (IdP idL), -- Note [fun_id in Match] in GHC.Hs.Expr
+ fun_id :: LIdP idL, -- Note [fun_id in Match] in GHC.Hs.Expr
fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload
@@ -369,9 +369,8 @@ type instance XXABExport (GhcPass p) = NoExtCon
data PatSynBind idL idR
= PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs.
-- See Note [Bind free vars]
- psb_id :: XRec idL (IdP idL), -- ^ Name of the pattern synonym
- psb_args :: HsPatSynDetails (XRec idR (IdP idR)),
- -- ^ Formal parameter names
+ psb_id :: LIdP idL, -- ^ Name of the pattern synonym
+ psb_args :: HsPatSynDetails idR, -- ^ Formal parameter names
psb_def :: LPat idR, -- ^ Right-hand side
psb_dir :: HsPatSynDir idR -- ^ Directionality
}
@@ -893,7 +892,7 @@ data Sig pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
TypeSig
(XTypeSig pass)
- [XRec pass (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah
+ [LIdP pass] -- LHS of the signature; e.g. f,g,h :: blah
(LHsSigWcType pass) -- RHS of the signature; can have wildcards
-- | A pattern synonym type signature
@@ -905,7 +904,7 @@ data Sig pass
-- 'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
- | PatSynSig (XPatSynSig pass) [XRec pass (IdP pass)] (LHsSigType pass)
+ | PatSynSig (XPatSynSig pass) [LIdP pass] (LHsSigType pass)
-- P :: forall a b. Req => Prov => ty
-- | A signature for a class method
@@ -918,7 +917,7 @@ data Sig pass
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDefault',
-- 'GHC.Parser.Annotation.AnnDcolon'
- | ClassOpSig (XClassOpSig pass) Bool [XRec pass (IdP pass)] (LHsSigType pass)
+ | ClassOpSig (XClassOpSig pass) Bool [LIdP pass] (LHsSigType pass)
-- | A type signature in generated code, notably the code
-- generated for record selectors. We simply record
@@ -950,8 +949,8 @@ data Sig pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| InlineSig (XInlineSig pass)
- (XRec pass (IdP pass)) -- Function name
- InlinePragma -- Never defaultInlinePragma
+ (LIdP pass) -- Function name
+ InlinePragma -- Never defaultInlinePragma
-- | A specialisation pragma
--
@@ -966,7 +965,7 @@ data Sig pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| SpecSig (XSpecSig pass)
- (XRec pass (IdP pass)) -- Specialise a function or datatype ...
+ (LIdP pass) -- Specialise a function or datatype ...
[LHsSigType pass] -- ... to these types
InlinePragma -- The pragma on SPECIALISE_INLINE form.
-- If it's just defaultInlinePragma, then we said
@@ -996,7 +995,7 @@ data Sig pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| MinimalSig (XMinimalSig pass)
- SourceText (LBooleanFormula (XRec pass (IdP pass)))
+ SourceText (LBooleanFormula (LIdP pass))
-- Note [Pragma source text] in GHC.Types.Basic
-- | A "set cost centre" pragma for declarations
@@ -1008,8 +1007,8 @@ data Sig pass
-- > {-# SCC funName "cost_centre_name" #-}
| SCCFunSig (XSCCFunSig pass)
- SourceText -- Note [Pragma source text] in GHC.Types.Basic
- (XRec pass (IdP pass)) -- Function name
+ SourceText -- Note [Pragma source text] in GHC.Types.Basic
+ (LIdP pass) -- Function name
(Maybe (XRec pass StringLiteral))
-- | A complete match pragma
--
@@ -1020,8 +1019,8 @@ data Sig pass
-- synonym definitions.
| CompleteMatchSig (XCompleteMatchSig pass)
SourceText
- (XRec pass [XRec pass (IdP pass)])
- (Maybe (XRec pass (IdP pass)))
+ (XRec pass [LIdP pass])
+ (Maybe (LIdP pass))
| XSig !(XXSig pass)
type instance XTypeSig (GhcPass p) = NoExtField
@@ -1041,7 +1040,7 @@ type instance XXSig (GhcPass p) = NoExtCon
type LFixitySig pass = XRec pass (FixitySig pass)
-- | Fixity Signature
-data FixitySig pass = FixitySig (XFixitySig pass) [XRec pass (IdP pass)] Fixity
+data FixitySig pass = FixitySig (XFixitySig pass) [LIdP pass] Fixity
| XFixitySig !(XXFixitySig pass)
type instance XFixitySig (GhcPass p) = NoExtField
@@ -1229,14 +1228,14 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
-}
-- | Haskell Pattern Synonym Details
-type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg]
+type HsPatSynDetails pass = HsConDetails (LIdP pass) [RecordPatSynField (LIdP pass)]
-- See Note [Record PatSyn Fields]
-- | Record Pattern Synonym Field
-data RecordPatSynField a
+data RecordPatSynField fld
= RecordPatSynField {
- recordPatSynSelectorId :: a -- Selector name visible in rest of the file
- , recordPatSynPatVar :: a
+ recordPatSynSelectorId :: fld -- Selector name visible in rest of the file
+ , recordPatSynPatVar :: fld
-- Filled in by renamer, the name used internally
-- by the pattern
} deriving (Data, Functor)
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -592,7 +592,7 @@ data TyClDecl pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs
- , tcdLName :: XRec pass (IdP pass) -- ^ Type constructor
+ , tcdLName :: LIdP pass -- ^ Type constructor
, tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an
-- associated type these
-- include outer binders
@@ -609,7 +609,7 @@ data TyClDecl pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs
- , tcdLName :: XRec pass (IdP pass) -- ^ Type constructor
+ , tcdLName :: LIdP pass -- ^ Type constructor
, tcdTyVars :: LHsQTyVars pass -- ^ Type variables
-- See Note [TyVar binders for associated declarations]
, tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration
@@ -617,7 +617,7 @@ data TyClDecl pass
| ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs
tcdCtxt :: LHsContext pass, -- ^ Context...
- tcdLName :: XRec pass (IdP pass), -- ^ Name of the class
+ tcdLName :: LIdP pass, -- ^ Name of the class
tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables
tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration
tcdFDs :: [LHsFunDep pass], -- ^ Functional deps
@@ -637,7 +637,7 @@ data TyClDecl pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| XTyClDecl !(XXTyClDecl pass)
-type LHsFunDep pass = XRec pass (FunDep (XRec pass (IdP pass)))
+type LHsFunDep pass = XRec pass (FunDep (LIdP pass))
data DataDeclRn = DataDeclRn
{ tcdDataCusk :: Bool -- ^ does this have a CUSK?
@@ -1135,7 +1135,7 @@ type LFamilyDecl pass = XRec pass (FamilyDecl pass)
data FamilyDecl pass = FamilyDecl
{ fdExt :: XCFamilyDecl pass
, fdInfo :: FamilyInfo pass -- type/data, closed/open
- , fdLName :: XRec pass (IdP pass) -- type constructor
+ , fdLName :: LIdP pass -- type constructor
, fdTyVars :: LHsQTyVars pass -- type variables
-- See Note [TyVar binders for associated declarations]
, fdFixity :: LexicalFixity -- Fixity used in the declaration
@@ -1168,7 +1168,7 @@ type LInjectivityAnn pass = XRec pass (InjectivityAnn pass)
--
-- This will be represented as "InjectivityAnn `r` [`a`, `c`]"
data InjectivityAnn pass
- = InjectivityAnn (XRec pass (IdP pass)) [XRec pass (IdP pass)]
+ = InjectivityAnn (LIdP pass) [LIdP pass]
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :
-- 'GHC.Parser.Annotation.AnnRarrow', 'GHC.Parser.Annotation.AnnVbar'
@@ -1364,7 +1364,7 @@ type LStandaloneKindSig pass = XRec pass (StandaloneKindSig pass)
data StandaloneKindSig pass
= StandaloneKindSig (XStandaloneKindSig pass)
- (XRec pass (IdP pass)) -- Why a single binder? See #16754
+ (LIdP pass) -- Why a single binder? See #16754
(LHsSigType pass) -- Why not LHsSigWcType? See Note [Wildcards in standalone kind signatures]
| XStandaloneKindSig !(XXStandaloneKindSig pass)
@@ -1435,7 +1435,7 @@ type LConDecl pass = XRec pass (ConDecl pass)
data ConDecl pass
= ConDeclGADT
{ con_g_ext :: XConDeclGADT pass
- , con_names :: [XRec pass (IdP pass)]
+ , con_names :: [LIdP pass]
-- The following fields describe the type after the '::'
-- See Note [GADT abstract syntax]
@@ -1458,7 +1458,7 @@ data ConDecl pass
| ConDeclH98
{ con_ext :: XConDeclH98 pass
- , con_name :: XRec pass (IdP pass)
+ , con_name :: LIdP pass
, con_forall :: XRec pass Bool
-- ^ True <=> explicit user-written forall
@@ -1849,7 +1849,7 @@ type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass rhs)
data FamEqn pass rhs
= FamEqn
{ feqn_ext :: XCFamEqn pass rhs
- , feqn_tycon :: XRec pass (IdP pass)
+ , feqn_tycon :: LIdP pass
, feqn_bndrs :: Maybe [LHsTyVarBndr () pass] -- ^ Optional quantified type vars
, feqn_pats :: HsTyPats pass
, feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
@@ -2214,13 +2214,13 @@ type LForeignDecl pass = XRec pass (ForeignDecl pass)
data ForeignDecl pass
= ForeignImport
{ fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty
- , fd_name :: XRec pass (IdP pass) -- defines this name
+ , fd_name :: LIdP pass -- defines this name
, fd_sig_ty :: LHsSigType pass -- sig_ty
, fd_fi :: ForeignImport }
| ForeignExport
{ fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty
- , fd_name :: XRec pass (IdP pass) -- uses this name
+ , fd_name :: LIdP pass -- uses this name
, fd_sig_ty :: LHsSigType pass -- sig_ty
, fd_fe :: ForeignExport }
-- ^
@@ -2402,8 +2402,8 @@ type LRuleBndr pass = XRec pass (RuleBndr pass)
-- | Rule Binder
data RuleBndr pass
- = RuleBndr (XCRuleBndr pass) (XRec pass (IdP pass))
- | RuleBndrSig (XRuleBndrSig pass) (XRec pass (IdP pass)) (HsPatSigType pass)
+ = RuleBndr (XCRuleBndr pass) (LIdP pass)
+ | RuleBndrSig (XRuleBndrSig pass) (LIdP pass) (HsPatSigType pass)
| XRuleBndr !(XXRuleBndr pass)
-- ^
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
@@ -2505,7 +2505,7 @@ type instance XXWarnDecls (GhcPass _) = NoExtCon
type LWarnDecl pass = XRec pass (WarnDecl pass)
-- | Warning pragma Declaration
-data WarnDecl pass = Warning (XWarning pass) [XRec pass (IdP pass)] WarningTxt
+data WarnDecl pass = Warning (XWarning pass) [LIdP pass] WarningTxt
| XWarnDecl !(XXWarnDecl pass)
type instance XWarning (GhcPass _) = NoExtField
@@ -2592,7 +2592,7 @@ type LRoleAnnotDecl pass = XRec pass (RoleAnnotDecl pass)
-- | Role Annotation Declaration
data RoleAnnotDecl pass
= RoleAnnotDecl (XCRoleAnnotDecl pass)
- (XRec pass (IdP pass)) -- type constructor
+ (LIdP pass) -- type constructor
[XRec pass (Maybe Role)] -- optional annotations
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',
-- 'GHC.Parser.Annotation.AnnRole'
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -242,9 +242,8 @@ is Less Cool because
-- | A Haskell expression.
data HsExpr p
= HsVar (XVar p)
- (XRec p (IdP p)) -- ^ Variable
-
- -- See Note [Located RdrNames]
+ (LIdP p) -- ^ Variable
+ -- See Note [Located RdrNames]
| HsUnboundVar (XUnboundVar p)
OccName -- ^ Unbound variable; also used for "holes"
@@ -439,7 +438,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| RecordCon
{ rcon_ext :: XRecordCon p
- , rcon_con_name :: XRec p (IdP p) -- The constructor name;
+ , rcon_con_name :: LIdP p -- The constructor name;
-- not used after type checking
, rcon_flds :: HsRecordBinds p } -- The fields
@@ -2987,7 +2986,7 @@ matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused"
matchSeparator PatSyn = panic "unused"
-pprMatchContext :: Outputable (IdP p)
+pprMatchContext :: (Outputable (IdP p), UnXRec p)
=> HsMatchContext p -> SDoc
pprMatchContext ctxt
| want_an ctxt = text "an" <+> pprMatchContextNoun ctxt
@@ -2997,11 +2996,11 @@ pprMatchContext ctxt
want_an ProcExpr = True
want_an _ = False
-pprMatchContextNoun :: Outputable (IdP id)
- => HsMatchContext id -> SDoc
-pprMatchContextNoun (FunRhs {mc_fun=L _ fun})
+pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)
+ => HsMatchContext p -> SDoc
+pprMatchContextNoun (FunRhs {mc_fun=fun})
= text "equation for"
- <+> quotes (ppr fun)
+ <+> quotes (ppr (unXRec @p fun))
pprMatchContextNoun CaseAlt = text "case alternative"
pprMatchContextNoun IfAlt = text "multi-way if alternative"
pprMatchContextNoun RecUpd = text "record-update construct"
@@ -3016,8 +3015,8 @@ pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
pprMatchContextNoun PatSyn = text "pattern synonym declaration"
-----------------
-pprAStmtContext, pprStmtContext :: Outputable (IdP id)
- => HsStmtContext id -> SDoc
+pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)
+ => HsStmtContext p -> SDoc
pprAStmtContext ctxt = article <+> pprStmtContext ctxt
where
pp_an = text "an"
=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -307,7 +307,7 @@ type family IdGhcP pass where
IdGhcP 'Renamed = Name
IdGhcP 'Typechecked = Id
-type LIdP p = Located (IdP p)
+type LIdP p = XRec p (IdP p)
-- | Marks that a field uses the GhcRn variant even when the pass
-- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -93,7 +93,7 @@ data Pat p
-- AZ:TODO above comment needs to be updated
| VarPat (XVarPat p)
- (XRec p (IdP p)) -- ^ Variable Pattern
+ (LIdP p) -- ^ Variable Pattern
-- See Note [Located RdrNames] in GHC.Hs.Expr
| LazyPat (XLazyPat p)
@@ -103,7 +103,7 @@ data Pat p
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| AsPat (XAsPat p)
- (XRec p (IdP p)) (LPat p) -- ^ As pattern
+ (LIdP p) (LPat p) -- ^ As pattern
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt'
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
@@ -224,7 +224,7 @@ data Pat p
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| NPlusKPat (XNPlusKPat p) -- Type of overall pattern
- (XRec p (IdP p)) -- n+k pattern
+ (LIdP p) -- n+k pattern
(XRec p (HsOverLit p)) -- It'll always be an HsIntegral
(HsOverLit p) -- See Note [NPlusK patterns] in GHC.Tc.Gen.Pat
-- NB: This could be (PostTc ...), but that induced a
@@ -313,7 +313,7 @@ type instance XXPat GhcTc = CoPat
type family ConLikeP x
type instance ConLikeP GhcPs = RdrName -- IdP GhcPs
-type instance ConLikeP GhcRn = Name -- IdP GhcRn
+type instance ConLikeP GhcRn = Name -- IdP GhcRn
type instance ConLikeP GhcTc = ConLike
-- ---------------------------------------------------------------------
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -73,7 +73,6 @@ module GHC.Hs.Type (
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
ignoreParens, hsSigType, hsSigWcType, hsPatSigType,
hsTyKindSig,
- hsConDetailsArgs,
setHsTyVarBndrFlag, hsTyVarBndrFlag,
-- Printing
@@ -638,13 +637,13 @@ data HsTyVarBndr flag pass
= UserTyVar -- no explicit kinding
(XUserTyVar pass)
flag
- (XRec pass (IdP pass))
+ (LIdP pass)
-- See Note [Located RdrNames] in GHC.Hs.Expr
| KindedTyVar
(XKindedTyVar pass)
flag
- (XRec pass (IdP pass))
+ (LIdP pass)
(LHsKind pass) -- The user-supplied kind signature
-- ^
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
@@ -705,7 +704,7 @@ data HsType pass
| HsTyVar (XTyVar pass)
PromotionFlag -- Whether explicitly promoted,
-- for the pretty printer
- (XRec pass (IdP pass))
+ (LIdP pass)
-- Type variable, type constructor, or data constructor
-- see Note [Promotions (HsTyVar)]
-- See Note [Located RdrNames] in GHC.Hs.Expr
@@ -755,7 +754,7 @@ data HsType pass
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
| HsOpTy (XOpTy pass)
- (LHsType pass) (XRec pass (IdP pass)) (LHsType pass)
+ (LHsType pass) (LIdP pass) (LHsType pass)
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in GHC.Parser.Annotation
@@ -1116,14 +1115,6 @@ instance (Outputable arg, Outputable rec)
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
-hsConDetailsArgs ::
- HsConDetails (LHsType (GhcPass p)) (Located [LConDeclField (GhcPass p)])
- -> [LHsType (GhcPass p)]
-hsConDetailsArgs details = case details of
- InfixCon a b -> [a,b]
- PrefixCon xs -> xs
- RecCon r -> map (cd_fld_type . unLoc) (unLoc r)
-
{-
Note [ConDeclField passs]
~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -777,7 +777,7 @@ mkVarBind var rhs = L (getLoc rhs) $
VarBind { var_ext = noExtField,
var_id = var, var_rhs = rhs }
-mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
+mkPatSynBind :: Located RdrName -> HsPatSynDetails GhcPs
-> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs
mkPatSynBind name details lpat dir = PatSynBind noExtField psb
where
@@ -990,7 +990,7 @@ collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = ps })) acc
collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc
collect_bind _ (XHsBindsLR _) acc = acc
-collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [XRec idL (IdP idL)]
+collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL]
-- ^ Used exclusively for the bindings of an instance decl which are all
-- 'FunBinds'
collectMethodBinders binds = foldr (get . unXRec @idL) [] binds
@@ -1173,7 +1173,7 @@ hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name)
-------------------
-hsForeignDeclsBinders :: forall pass. (UnXRec pass, MapXRec pass) => [LForeignDecl pass] -> [XRec pass (IdP pass)]
+hsForeignDeclsBinders :: forall pass. (UnXRec pass, MapXRec pass) => [LForeignDecl pass] -> [LIdP pass]
-- ^ See Note [SrcSpan for binders]
hsForeignDeclsBinders foreign_decls
= [ mapXRec @pass (const $ unXRec @pass n) fi
=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -126,7 +126,7 @@ matchPatSyn (var :| vars) ty eqns
PatSynCon psyn -> alt{ alt_pat = psyn }
_ -> panic "matchPatSyn: not PatSynCon"
-type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))
+type ConArgPats = HsConPatDetails GhcTc
matchOneConLike :: [Id]
-> Type
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1840,7 +1840,7 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
; patSynD'' <- wrapGenArgSyms args ss patSynD'
; return (loc, patSynD'') }
where
- mkGenArgSyms :: HsPatSynDetails (Located Name) -> MetaM [GenSymBind]
+ mkGenArgSyms :: HsPatSynDetails GhcRn -> MetaM [GenSymBind]
-- for Record Pattern Synonyms we want to conflate the selector
-- and the pattern-only names in order to provide a nicer TH
-- API. Whereas inside GHC, record pattern synonym selectors and
@@ -1859,7 +1859,7 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
= [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
, sel == sel' ]
- wrapGenArgSyms :: HsPatSynDetails (Located Name)
+ wrapGenArgSyms :: HsPatSynDetails GhcRn
-> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec))
wrapGenArgSyms (RecCon _) _ dec = return dec
wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
@@ -1872,7 +1872,7 @@ repPatSynD :: Core TH.Name
repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
= rep2 patSynDName [syn, args, dir, pat]
-repPatSynArgs :: HsPatSynDetails (Located Name) -> MetaM (Core (M TH.PatSynArgs))
+repPatSynArgs :: HsPatSynDetails GhcRn -> MetaM (Core (M TH.PatSynArgs))
repPatSynArgs (PrefixCon args)
= do { args' <- repList nameTyConName lookupLOcc args
; repPrefixPatSynArgs args' }
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -900,7 +900,7 @@ CPR-friendly. This matters a lot: if you don't get it right, you lose
the tail call property. For example, see #3403.
-}
-dsHandleMonadicFailure :: Outputable (IdP p) => HsStmtContext p -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
+dsHandleMonadicFailure :: HsStmtContext GhcRn -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
dsHandleMonadicFailure ctx pat match m_fail_op =
@@ -921,8 +921,9 @@ dsHandleMonadicFailure ctx pat match m_fail_op =
fail_expr <- dsSyntaxExpr fail_op [fail_msg]
body fail_expr
-mk_fail_msg :: Outputable (IdP p) => DynFlags -> HsStmtContext p -> Located e -> String
-mk_fail_msg dflags ctx pat = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx <+> text "at" <+> ppr (getLoc pat)
+mk_fail_msg :: DynFlags -> HsStmtContext GhcRn -> Located e -> String
+mk_fail_msg dflags ctx pat
+ = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx <+> text "at" <+> ppr (getLoc pat)
{- *********************************************************************
* *
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1491,7 +1491,7 @@ pattern_synonym_decl :: { LHsDecl GhcPs }
(as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) )
}}
-pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) }
+pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails GhcPs, [AddAnn]) }
: con vars0 { ($1, PrefixCon $2, []) }
| varid conop varid { ($2, InfixCon $1 $3, []) }
| con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }
=====================================
compiler/GHC/SysTools/Process.hs
=====================================
@@ -45,6 +45,15 @@ enableProcessJobs opts = opts
enableProcessJobs opts = opts
#endif
+#if !MIN_VERSION_base(4,15,0)
+-- TODO: This can be dropped with GHC 8.16
+hGetContents' :: Handle -> IO String
+hGetContents' hdl = do
+ output <- hGetContents hdl
+ _ <- evaluate $ length output
+ return output
+#endif
+
-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
-- inherited from the parent process, and output to stderr is not captured.
readCreateProcessWithExitCode'
@@ -55,13 +64,19 @@ readCreateProcessWithExitCode' proc = do
createProcess $ enableProcessJobs $ proc{ std_out = CreatePipe }
-- fork off a thread to start consuming the output
- output <- hGetContents outh
outMVar <- newEmptyMVar
- _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
+ let onError :: SomeException -> IO ()
+ onError exc = putMVar outMVar (Left exc)
+ _ <- forkIO $ handle onError $ do
+ output <- hGetContents' outh
+ putMVar outMVar $ Right output
-- wait on the output
- takeMVar outMVar
+ result <- takeMVar outMVar
hClose outh
+ output <- case result of
+ Left exc -> throwIO exc
+ Right output -> return output
-- wait on the process
ex <- waitForProcess pid
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -558,7 +558,7 @@ a pattern synonym. What about the /building/ side?
a bad idea.
-}
-collectPatSynArgInfo :: HsPatSynDetails (Located Name)
+collectPatSynArgInfo :: HsPatSynDetails GhcRn
-> ([Name], [Name], Bool)
collectPatSynArgInfo details =
case details of
=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -626,8 +626,8 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
, psb_dir = dir' } }
zonkPatSynDetails :: ZonkEnv
- -> HsPatSynDetails (Located TcId)
- -> HsPatSynDetails (Located Id)
+ -> HsPatSynDetails GhcTc
+ -> HsPatSynDetails GhcTc
zonkPatSynDetails env (PrefixCon as)
= PrefixCon (map (zonkLIdOcc env) as)
zonkPatSynDetails env (InfixCon a1 a2)
@@ -1450,10 +1450,8 @@ zonk_pat env (XPat (CoPat co_fn pat ty))
zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
---------------------------
-zonkConStuff :: ZonkEnv
- -> HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc))
- -> TcM (ZonkEnv,
- HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc)))
+zonkConStuff :: ZonkEnv -> HsConPatDetails GhcTc
+ -> TcM (ZonkEnv, HsConPatDetails GhcTc)
zonkConStuff env (PrefixCon pats)
= do { (env', pats') <- zonkPats env pats
; return (env', PrefixCon pats') }
=====================================
testsuite/tests/typecheck/should_compile/T18585.hs
=====================================
@@ -0,0 +1,48 @@
+{-# Language DataKinds #-}
+{-# Language FlexibleContexts #-}
+{-# Language PolyKinds #-}
+{-# Language StandaloneKindSignatures #-}
+{-# Language TypeFamilyDependencies #-}
+{-# Language UndecidableInstances #-}
+{-# Language UndecidableSuperClasses #-}
+module T18585 (Functor(..)) where
+
+import Data.Kind (Type)
+import Prelude hiding (Functor(..))
+
+type Cat i = i -> i -> Type
+
+class
+ ( Op (Op k) ~ k
+ , Category (Op k)
+ ) => Category (k :: Cat i) where
+ type Op k :: i -> i -> Type
+ type Op k = Y k
+
+newtype Y k a b = Y (k b a)
+
+instance (Category k, Op k ~ Y k) => Category (Y k) where
+ type Op (Y k) = k
+
+instance Category (->)
+
+type SelfDom :: (i -> j) -> Cat i -> Cat i
+type family SelfDom (f :: i -> j) (k :: Cat i) :: Cat i where
+ SelfDom p p = Op p
+ SelfDom f p = p
+
+type family DefaultCat (i :: Type) = (res :: Cat i) | res -> i
+type instance DefaultCat Type = (->)
+
+class
+ ( Category (Dom f)
+ , Category (Cod f)
+ ) => Functor (f :: i -> j) where
+
+ type Dom f :: Cat i
+ type Dom (f :: i -> j) = SelfDom f (DefaultCat i)
+
+ type Cod f :: Cat j
+ type Cod (f :: i -> j) = DefaultCat j
+
+instance Functor IO
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -721,4 +721,5 @@ test('T18118', normal, multimod_compile, ['T18118', '-v0'])
test('T18412', normal, compile, [''])
test('T18470', normal, compile, [''])
test('T18323', normal, compile, [''])
+test('T18585', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/faae584d4710f987df10243f0b39bf8b54b4b705...b37114051fbc489d32cf7bc72b18950e30a676fb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/faae584d4710f987df10243f0b39bf8b54b4b705...b37114051fbc489d32cf7bc72b18950e30a676fb
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/20200825/4d77b913/attachment-0001.html>
More information about the ghc-commits
mailing list