Simon Peyton Jones pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC
Commits:
-
9af7210e
by Simon Peyton Jones at 2026-04-20T17:41:41+01:00
6 changed files:
- compiler/GHC/Builtin/KnownOccs.hs
- compiler/GHC/Builtin/TH.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Errors/Ppr.hs
- libraries/base/src/GHC/KnownKeyNames.hs
Changes:
| ... | ... | @@ -86,6 +86,11 @@ have the correct one in scope when looking up a known-occ name. |
| 86 | 86 | module GHC.Internal.Base where
|
| 87 | 87 | foldrList = foldr
|
| 88 | 88 | make `foldrList` known-occ, and refer to that in desugaring list comprehensions.
|
| 89 | + |
|
| 90 | +* (>>>). You might think that the known-occ version is the one defined in
|
|
| 91 | + GHC.Internal.Control.Category. But no, it isn't. We have a different one
|
|
| 92 | + (albeit with the same definitino!) in GHC.Internal.Desugar, whose type
|
|
| 93 | + has the right "shape" type for `newKnownOccMethod`. Sigh.
|
|
| 89 | 94 | -}
|
| 90 | 95 | |
| 91 | 96 |
| ... | ... | @@ -903,11 +903,6 @@ forallEIdKey = mkPreludeMiscIdUnique 802 |
| 903 | 903 | forallVisEIdKey = mkPreludeMiscIdUnique 803
|
| 904 | 904 | constrainedEIdKey = mkPreludeMiscIdUnique 804
|
| 905 | 905 | |
| 906 | --- data Guard = ...
|
|
| 907 | -normalGEIdKey, patGEIdKey :: Unique
|
|
| 908 | -normalGEIdKey = mkPreludeMiscIdUnique 310
|
|
| 909 | -patGEIdKey = mkPreludeMiscIdUnique 311
|
|
| 910 | - |
|
| 911 | 906 | -- data Dec = ...
|
| 912 | 907 | funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
|
| 913 | 908 | instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,
|
| ... | ... | @@ -629,7 +629,7 @@ dsLookupKnownKeyName uniq |
| 629 | 629 | Succeeded name -> return name
|
| 630 | 630 | Failed msg -> failIfM (pprDiagnostic msg) } }
|
| 631 | 631 | |
| 632 | -dsLookupKnownKeyThing :: KnownKey -> DsM TyThing
|
|
| 632 | +dsLookupKnownKeyThing :: HasDebugCallStack => KnownKey -> DsM TyThing
|
|
| 633 | 633 | dsLookupKnownKeyThing uniq
|
| 634 | 634 | = do { rebindable_src <- dsGetKnownKeySource
|
| 635 | 635 | ; dsToIfL $
|
| ... | ... | @@ -638,13 +638,13 @@ dsLookupKnownKeyThing uniq |
| 638 | 638 | Succeeded thing -> return thing
|
| 639 | 639 | Failed msg -> failIfM (pprDiagnostic msg) } }
|
| 640 | 640 | |
| 641 | -dsLookupKnownKeyTyCon :: KnownKey -> DsM TyCon
|
|
| 641 | +dsLookupKnownKeyTyCon :: HasDebugCallStack => KnownKey -> DsM TyCon
|
|
| 642 | 642 | dsLookupKnownKeyTyCon uniq = tyThingTyCon <$> dsLookupKnownKeyThing uniq
|
| 643 | 643 | |
| 644 | -dsLookupKnownKeyDataCon :: KnownKey -> DsM DataCon
|
|
| 644 | +dsLookupKnownKeyDataCon :: HasDebugCallStack => KnownKey -> DsM DataCon
|
|
| 645 | 645 | dsLookupKnownKeyDataCon uniq = tyThingDataCon <$> dsLookupKnownKeyThing uniq
|
| 646 | 646 | |
| 647 | -dsLookupKnownKeyId :: KnownKey -> DsM Id
|
|
| 647 | +dsLookupKnownKeyId :: HasDebugCallStack => KnownKey -> DsM Id
|
|
| 648 | 648 | dsLookupKnownKeyId uniq = tyThingId <$> dsLookupKnownKeyThing uniq
|
| 649 | 649 | |
| 650 | 650 | --------------------------------------
|
| ... | ... | @@ -2370,10 +2370,10 @@ lookupType :: KnownOcc -- Name of type constructor (e.g. (M TH.Exp)) |
| 2370 | 2370 | lookupType tc_name = do { tc <- lift $ dsLookupKnownOccTyCon tc_name ;
|
| 2371 | 2371 | return (mkTyConTy tc) }
|
| 2372 | 2372 | |
| 2373 | -lookupKnownKeyType :: Unique -- Unique of type constructor (e.g. (M TH.Exp))
|
|
| 2373 | +lookupKnownOccType :: KnownOcc -- Occ-name of type constructor (e.g. (M TH.Exp))
|
|
| 2374 | 2374 | -> MetaM Type -- The type
|
| 2375 | -lookupKnownKeyType tc_key
|
|
| 2376 | - = do { tc <- lift $ dsLookupKnownKeyTyCon tc_key
|
|
| 2375 | +lookupKnownOccType tc_key
|
|
| 2376 | + = do { tc <- lift $ dsLookupKnownOccTyCon tc_key
|
|
| 2377 | 2377 | ; return (mkTyConApp tc []) }
|
| 2378 | 2378 | |
| 2379 | 2379 | wrapGenSyms :: [GenSymBind]
|
| ... | ... | @@ -3133,7 +3133,7 @@ mk_integer :: Integer -> MetaM (HsLit GhcTc) |
| 3133 | 3133 | mk_integer i = return $ XLit $ HsInteger NoSourceText i integerTy
|
| 3134 | 3134 | |
| 3135 | 3135 | mk_rational :: FractionalLit -> MetaM (HsLit GhcTc)
|
| 3136 | -mk_rational r = do rat_ty <- lookupKnownKeyType rationalTyConKey
|
|
| 3136 | +mk_rational r = do rat_ty <- lookupKnownOccType rationalTyConOcc
|
|
| 3137 | 3137 | return $ XLit $ HsRat r rat_ty
|
| 3138 | 3138 | |
| 3139 | 3139 | mk_string :: FastString -> MetaM (HsLit GhcRn)
|
| ... | ... | @@ -299,7 +299,8 @@ interfaceErrorDiagnostic opts = \ case |
| 299 | 299 | |
| 300 | 300 | MissingKnownKey1 key -> hang (text "Could not find known key" <+> quotes (pprKnownKey key))
|
| 301 | 301 | 2 (vcat [ text "in the exports of GHC.KnownKeys"
|
| 302 | - , text "occname:" <+> pp_occ (knownKeyOccName_maybe key) ])
|
|
| 302 | + , text "occname:" <+> pp_occ (knownKeyOccName_maybe key)
|
|
| 303 | + , text "REMEMBER: for tycons, divide by 2!!"])
|
|
| 303 | 304 | where
|
| 304 | 305 | pp_occ (Just occ) = ppr occ
|
| 305 | 306 | pp_occ Nothing = text "Yikes: that key isn't in the known-key table"
|
| ... | ... | @@ -92,7 +92,7 @@ module GHC.KnownKeyNames |
| 92 | 92 | , error
|
| 93 | 93 | |
| 94 | 94 | -- Numbers
|
| 95 | - , Num, Integral, Real, Fractional, RealFloat, RealFrac
|
|
| 95 | + , Num, Integral, Real, Floating, Fractional, RealFloat, RealFrac
|
|
| 96 | 96 | , (+), (-), (*), negate, fromInteger
|
| 97 | 97 | , divInt#, modInt#
|
| 98 | 98 | |
| ... | ... | @@ -204,6 +204,7 @@ module GHC.KnownKeyNames |
| 204 | 204 | , Clause, clause
|
| 205 | 205 | , Stmt, bindS, letS, noBindS, parS, recS
|
| 206 | 206 | , Body, normalB, guardedB
|
| 207 | + , Guard, normalGE, patGE
|
|
| 207 | 208 | ) where
|
| 208 | 209 | |
| 209 | 210 | import GHC.Internal.Base hiding( foldr )
|
| ... | ... | @@ -226,7 +227,8 @@ import GHC.Internal.IO( seq# ) |
| 226 | 227 | import GHC.Internal.Control.Monad( fail, guard )
|
| 227 | 228 | import GHC.Internal.Control.Monad.Fix( mfix, loop )
|
| 228 | 229 | import GHC.Internal.Control.Monad.Zip( mzip )
|
| 229 | -import GHC.Internal.Control.Arrow( arr, (>>>), first, app, (|||) )
|
|
| 230 | +import GHC.Internal.Control.Arrow( arr, first, app, (|||) )
|
|
| 231 | +import GHC.Internal.Desugar( (>>>) ) -- See Note [Tricky known-occ cases]
|
|
| 230 | 232 | import GHC.Internal.OverloadedLabels( fromLabel )
|
| 231 | 233 | import GHC.Internal.Records
|
| 232 | 234 | import GHC.Internal.CString as CS
|