[Git][ghc/ghc][wip/T24359] Fix build
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Sep 11 15:41:47 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
c412451f by Simon Peyton Jones at 2024-09-11T16:41:22+01:00
Fix build
- - - - -
8 changed files:
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Types/Error/Codes.hs
- testsuite/tests/typecheck/should_compile/tc186.hs
Changes:
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -293,7 +293,7 @@ deSugar hsc_env
dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
dsImpSpecs imp_specs
- = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
+ = do { spec_prs <- mapMaybeM (dsSpec Nothing . unLoc) imp_specs
; let (spec_binds, spec_rules) = unzip spec_prs
; return (concatOL spec_binds, spec_rules) }
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -805,7 +805,7 @@ dsSpecs :: CoreExpr -- Its rhs
-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig
dsSpecs _ IsDefaultMethod = return (nilOL, [])
dsSpecs poly_rhs (SpecPrags sps)
- = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
+ = do { pairs <- mapMaybeM (dsLSpec (Just poly_rhs)) sps
; let (spec_binds_s, rules) = unzip pairs
; return (concatOL spec_binds_s, rules) }
@@ -829,7 +829,7 @@ dsSpec mb_poly_rhs (SpecPrag poly_id spec_co spec_inl)
-- \spec_bndrs. [] spec_args
-- perhaps with the body of the lambda wrapped in some WpLets
-- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
- = dsHsWrapper spec_app $ \core_app ->
+ = dsHsWrapperForRuleLHS spec_app $ \core_app ->
finishSpecPrag mb_poly_rhs
spec_bndrs (core_app (Var poly_id))
spec_bndrs (\_ poly_rhs -> core_app poly_rhs)
@@ -840,7 +840,7 @@ dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
, spe_id_bndrs = id_bndrs
, spe_lhs_ev_bndrs = lhs_evs
, spe_lhs_binds = lhs_binds
- , spe_call = the_call
+ , spe_lhs_call = the_call
, spe_rhs_ev_bndrs = rhs_evs
, spe_rhs_binds = rhs_binds
, spe_inl = inl })
@@ -869,7 +869,7 @@ failBecauseOfClassOp :: Id -> DsM (Maybe a)
-- There is no point in trying to specialise a class op
-- Moreover, classops don't (currently) have an inl_sat arity set
-- (it would be Just 0) and that in turn makes makeCorePair bleat
-failBecauseOfClassOp loc poly_id
+failBecauseOfClassOp poly_id
= do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)
; return Nothing }
@@ -919,9 +919,7 @@ finishSpecPrag mb_poly_rhs
; tracePm "dsSpec" (vcat
[ text "fun:" <+> ppr poly_id
- , text "spec_co:" <+> ppr spec_co
, text "spec_bndrs:" <+> ppr spec_bndrs
- , text "ds_lhs:" <+> ppr ds_lhs
, text "args:" <+> ppr rule_lhs_args ])
; return (Just (unitOL (spec_id, spec_rhs), rule))
-- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
@@ -1261,7 +1259,7 @@ drop_dicts drops dictionary bindings on the LHS where possible.
Of course, the ($dfEqlist d) in the pattern makes it less likely
to match, but there is no other way to get d:Eq a
- NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
+ NB 2: We do drop_dicts *before* simplOptExpr, so that we expect all
the evidence bindings to be wrapped around the outside of the
LHS. (After simplOptExpr they'll usually have been inlined.)
dsHsWrapper does dependency analysis, so that civilised ones
=====================================
compiler/GHC/Parser/Errors/Ppr.hs
=====================================
@@ -695,7 +695,6 @@ instance Diagnostic PsMessage where
PsErrInvalidPun {} -> ErrorWithoutFlag
PsErrIllegalOrPat{} -> ErrorWithoutFlag
PsErrTypeSyntaxInPat{} -> ErrorWithoutFlag
- PsErrSpecEpxrMultipleTypeAscription{} -> ErrorWithoutFlag
PsErrSpecExprMultipleTypeAscription{} -> ErrorWithoutFlag
diagnosticHints = \case
@@ -866,7 +865,6 @@ instance Diagnostic PsMessage where
PsErrInvalidPun {} -> [suggestExtension LangExt.ListTuplePuns]
PsErrIllegalOrPat{} -> [suggestExtension LangExt.OrPatterns]
PsErrTypeSyntaxInPat{} -> noHints
- PsErrSpecEpxrMultipleTypeAscription {} -> noHints
PsErrSpecExprMultipleTypeAscription {} -> noHints
diagnosticCode = constructorCode
=====================================
compiler/GHC/Parser/Errors/Types.hs
=====================================
@@ -491,7 +491,6 @@ data PsMessage
-- T24159_pat_parse_error_6
| PsErrTypeSyntaxInPat !PsErrTypeSyntaxDetails
- | PsErrSpecEpxrMultipleTypeAscription
| PsErrSpecExprMultipleTypeAscription
deriving Generic
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -24,8 +24,7 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr )
import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )
import GHC.Hs
-import GHC.Types.FieldLabel
-import GHC.Types.Name.Reader
+
import GHC.Rename.HsType
import GHC.Rename.Bind
import GHC.Rename.Doc
@@ -37,6 +36,7 @@ import GHC.Rename.Utils ( mapFvRn, bindLocalNames
, addNoNestedForallsContextsErr, checkInferredVars )
import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) )
import GHC.Rename.Names
+
import GHC.Tc.Errors.Types
import GHC.Tc.Gen.Annotation ( annCtxt )
import GHC.Tc.Utils.Monad
@@ -50,29 +50,28 @@ import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName
, monoidClassName, mappendName
)
+import GHC.Types.FieldLabel
+import GHC.Types.Name.Reader
import GHC.Types.ForeignCall ( CCallTarget(..) )
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
-import GHC.Types.Basic ( TypeOrKind(..), RuleName )
+import GHC.Types.Basic ( Arity, TypeOrKind(..), RuleName )
import GHC.Types.GREInfo (ConLikeInfo (..), ConInfo, mkConInfo, conInfoFields)
-
-
+import GHC.Types.Unique.Set
import GHC.Types.SrcLoc as SrcLoc
+
import GHC.Driver.DynFlags
-import GHC.Utils.Misc ( lengthExceeds, partitionWith )
-import GHC.Utils.Panic
import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
-import GHC.Types.Unique.Set
+import GHC.Utils.Misc ( lengthExceeds, partitionWith )
+import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Data.FastString
-import GHC.Data.Bag
import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses )
import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)
, stronglyConnCompFromEdgedVerticesUniq )
-
import GHC.Data.OrdList
import qualified GHC.LanguageExtensions as LangExt
import GHC.Core.DataCon ( isSrcStrict )
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -938,7 +938,7 @@ tcSpecPrag poly_id (SpecSigE nm bndrs spec_e inl)
, spe_id_bndrs = id_bndrs
, spe_lhs_ev_bndrs = lhs_evs
, spe_lhs_binds = lhs_binds
- , spe_call = spec_e'
+ , spe_lhs_call = spec_e'
, spe_rhs_ev_bndrs = rhs_evs
, spe_rhs_binds = rhs_binds
, spe_inl = inl }] }
@@ -1173,11 +1173,12 @@ tcRule (HsRule { rd_ext = ext
, rd_bndrs = mkTcRuleBndrs bndrs (qtkvs ++ tpl_ids)
, rd_lhs = mkHsDictLet lhs_binds lhs'
, rd_rhs = mkHsDictLet rhs_binds rhs' } }
-
-mkTcRuleBndrs (RuleBndrs { rb_tyvs = tyvs }) vars
- = RuleBndrs { rb_ext = noAnn
- , rb_tyvs = tyvs -- preserved for ppr-ing
- , rb_tmvs = map (noLocA . RuleBndr noAnn . noLocA) vars }
+ where
+ mkTcRuleBndrs (RuleBndrs { rb_tyvs = tyvs }) vars
+ = RuleBndrs { rb_ext = noAnn
+ , rb_tyvs = tyvs -- preserved for ppr-ing
+ , rb_tmvs = map (noLocA . RuleBndr noAnn . noLocA) vars }
+ mkTcRuleBndrs (XRuleBndrs {}) _ = panic "mkTCRuleBndrs"
generateRuleConstraints :: SkolemInfo
-> RuleBndrs GhcRn
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -291,7 +291,6 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "PsErrInvalidPun" = 52943
GhcDiagnosticCode "PsErrIllegalOrPat" = 29847
GhcDiagnosticCode "PsErrTypeSyntaxInPat" = 32181
- GhcDiagnosticCode "PsErrSpecEpxrMultipleTypeAscription" = 62037
GhcDiagnosticCode "PsErrSpecExprMultipleTypeAscription" = 62037
-- Driver diagnostic codes
=====================================
testsuite/tests/typecheck/should_compile/tc186.hs
=====================================
@@ -2,7 +2,7 @@
-- Killed 6.2.2
-- The trouble was that 1 was instantiated to a type (t::?)
-- and the constraint (Foo (t::? -> s::*)) didn't match Foo (a::* -> b::*).
--- Solution is to zap the expected type in TcEpxr.tc_expr(HsOverLit).
+-- Solution is to zap the expected type in TcExpr.tc_expr(HsOverLit).
module ShouldCompile where
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c412451fcf9960df43ecd24b1c8a384a77a1ac31
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c412451fcf9960df43ecd24b1c8a384a77a1ac31
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/20240911/a2a10755/attachment-0001.html>
More information about the ghc-commits
mailing list