[Git][ghc/ghc][wip/T21909] 4 commits: Don't allow . in overloaded labels
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Tue Feb 7 23:49:48 UTC 2023
Apoorv Ingle pushed to branch wip/T21909 at Glasgow Haskell Compiler / GHC
Commits:
b17fb3d9 by sheaf at 2023-02-07T10:51:33-05:00
Don't allow . in overloaded labels
This patch removes . from the list of allowed characters in a non-quoted
overloaded label, as it was realised this steals syntax, e.g. (#.).
Users who want this functionality will have to add quotes around the
label, e.g. `#"17.28"`.
Fixes #22821
- - - - -
5dce04ee by romes at 2023-02-07T10:52:10-05:00
Update kinds in comments in GHC.Core.TyCon
Use `Type` instead of star kind (*)
Fix comment with incorrect kind * to have kind `Constraint`
- - - - -
92916194 by Ben Gamari at 2023-02-07T10:52:48-05:00
Revert "Use fix-sized equality primops for fixed size boxed types"
This reverts commit 024020c38126f3ce326ff56906d53525bc71690c.
This was never applied to master/9.6 originally.
See #20405 for why using these primops is a bad idea.
(cherry picked from commit b1d109ad542e4c37ae5af6ace71baf2cb509d865)
- - - - -
a201cc18 by Apoorv Ingle at 2023-02-07T23:49:40+00:00
Fixes #21909
Constraint simplification loop now depends on `ExpansionFuel` instead of a boolean flag in `CDictCan.cc_pend_sc`.
Pending Givens get a fuel of 3 to start of with while Wanted constraints get a fuel of 1.
This helps pending given constraints to keep up with pending wanted constraints.
Added tests T21909, T21909b
- - - - -
14 changed files:
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Canonical.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Constraint.hs
- docs/users_guide/9.6.1-notes.rst
- libraries/base/GHC/Int.hs
- libraries/base/GHC/Word.hs
- testsuite/tests/overloadedrecflds/should_run/T11671_run.hs
- testsuite/tests/printer/Test22771.hs
- + testsuite/tests/typecheck/should_compile/T21909.hs
- + testsuite/tests/typecheck/should_compile/T21909b.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -194,7 +194,7 @@ Note [Type synonym families]
* Type synonym families, also known as "type functions", map directly
onto the type functions in FC:
- type family F a :: *
+ type family F a :: Type
type instance F Int = Bool
..etc...
@@ -210,11 +210,11 @@ Note [Type synonym families]
type instance F (F Int) = ... -- BAD!
* Translation of type family decl:
- type family F a :: *
+ type family F a :: Type
translates to
a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon
- type family G a :: * where
+ type family G a :: Type where
G Int = Bool
G Bool = Char
G a = ()
@@ -229,7 +229,7 @@ Note [Data type families]
See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make
* Data type families are declared thus
- data family T a :: *
+ data family T a :: Type
data instance T Int = T1 | T2 Bool
Here T is the "family TyCon".
@@ -321,7 +321,7 @@ See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make
should not think of a data family T as a *type function* at all, not
even an injective one! We can't allow even injective type functions
on the LHS of a type function:
- type family injective G a :: *
+ type family injective G a :: Type
type instance F (G Int) = Bool
is no good, even if G is injective, because consider
type instance G Int = Bool
@@ -572,21 +572,21 @@ Since they are user-callable we must get their type-argument visibility
information right; and that info is in the TyConBinders.
Here is an example:
- data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> *
+ data App a b = MkApp (a b) -- App :: forall {k}. (k->Type) -> k -> Type
The TyCon has
- tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ]
+ tyConTyBinders = [ Named (Bndr (k :: Type) Inferred), Anon (k->Type), Anon k ]
The TyConBinders for App line up with App's kind, given above.
But the DataCon MkApp has the type
- MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b
+ MkApp :: forall {k} (a:k->Type) (b:k). a b -> App k a b
That is, its ForAllTyBinders should be
- dataConUnivTyVarBinders = [ Bndr (k:*) Inferred
- , Bndr (a:k->*) Specified
+ dataConUnivTyVarBinders = [ Bndr (k:Type) Inferred
+ , Bndr (a:k->Type) Specified
, Bndr (b:k) Specified ]
So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders:
@@ -620,8 +620,8 @@ They fit together like so:
type App a (b :: k) = a b
- tyConBinders = [ Bndr (k::*) (NamedTCB Inferred)
- , Bndr (a:k->*) AnonTCB
+ tyConBinders = [ Bndr (k::Type) (NamedTCB Inferred)
+ , Bndr (a:k->Type) AnonTCB
, Bndr (b:k) AnonTCB ]
Note that there are three binders here, including the
@@ -636,13 +636,13 @@ They fit together like so:
that TyVar may scope over some other part of the TyCon's definition. Eg
type T a = a -> a
we have
- tyConBinders = [ Bndr (a:*) AnonTCB ]
+ tyConBinders = [ Bndr (a:Type) AnonTCB ]
synTcRhs = a -> a
So the 'a' scopes over the synTcRhs
* From the tyConBinders and tyConResKind we can get the tyConKind
E.g for our App example:
- App :: forall k. (k->*) -> k -> *
+ App :: forall k. (k->Type) -> k -> Type
We get a 'forall' in the kind for each NamedTCB, and an arrow
for each AnonTCB
@@ -725,15 +725,15 @@ instance Binary TyConBndrVis where
-- things such as:
--
-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of
--- kind @*@
+-- kind @Type@
--
-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor
--
-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor
--- of kind @* -> *@
+-- of kind @Type -> Type@
--
-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor
--- of kind @*@
+-- of kind @Constraint@
--
-- This data type also encodes a number of primitive, built in type constructors
-- such as those for function and tuple types.
@@ -1252,16 +1252,16 @@ data FamTyConFlav
--
-- These are introduced by either a top level declaration:
--
- -- > data family T a :: *
+ -- > data family T a :: Type
--
-- Or an associated data type declaration, within a class declaration:
--
-- > class C a b where
- -- > data T b :: *
+ -- > data T b :: Type
DataFamilyTyCon
TyConRepName
- -- | An open type synonym family e.g. @type family F x y :: * -> *@
+ -- | An open type synonym family e.g. @type family F x y :: Type -> Type@
| OpenSynFamilyTyCon
-- | A closed type synonym family e.g.
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -163,7 +163,6 @@ $small = [$ascsmall $unismall \_]
$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].
$idchar = [$small $large $digit $uniidchar \']
-$labelchar = [$small $large $digit $uniidchar \' \.]
$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].
$graphic = [$small $large $symbol $digit $idchar $special $unigraphic \"\']
@@ -455,7 +454,7 @@ $unigraphic / { isSmartQuote } { smart_quote_error }
}
<0> {
- "#" $labelchar+ / { ifExtension OverloadedLabelsBit } { skip_one_varid_src ITlabelvarid }
+ "#" $idchar+ / { ifExtension OverloadedLabelsBit } { skip_one_varid_src ITlabelvarid }
"#" \" / { ifExtension OverloadedLabelsBit } { lex_quoted_label }
}
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -2338,6 +2338,10 @@ maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples })
do { new_given <- makeSuperClasses pending_given
; new_wanted <- makeSuperClasses pending_wanted
; solveSimpleGivens new_given -- Add the new Givens to the inert set
+ ; traceTcS "maybe_simplify_again" (vcat [ text "pending_given" <+> ppr pending_given
+ , text "new_given" <+> ppr new_given
+ , text "pending_wanted" <+> ppr pending_wanted
+ , text "new_wanted" <+> ppr new_wanted ])
; simplify_loop n limit (not (null pending_given)) $
wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } }
-- (not (null pending_given)): see Note [Superclass iteration]
=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -153,9 +153,9 @@ canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)
-- Precondition: EvVar is class evidence
canClassNC ev cls tys
| isGiven ev -- See Note [Eagerly expand given superclasses]
- = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys
+ = do { sc_cts <- mkStrictSuperClasses defaultFuelGivens ev [] [] cls tys
; emitWork sc_cts
- ; canClass ev cls tys False }
+ ; canClass ev cls tys doNotExpand }
| CtWanted { ctev_rewriters = rewriters } <- ev
, Just ip_name <- isCallStackPred cls tys
@@ -181,14 +181,16 @@ canClassNC ev cls tys
(ctLocSpan loc) (ctEvExpr new_ev)
; solveCallStack ev ev_cs
- ; canClass new_ev cls tys False -- No superclasses
+ ; canClass new_ev cls tys doNotExpand -- No superclasses
}
| otherwise
- = canClass ev cls tys (has_scs cls)
+ = canClass ev cls tys fuel
where
- has_scs cls = not (null (classSCTheta cls))
+ fuel | cls_has_scs = defaultFuelWanteds
+ | otherwise = doNotExpand
+ cls_has_scs = not (null (classSCTheta cls))
loc = ctEvLoc ev
orig = ctLocOrigin loc
pred = ctEvPred ev
@@ -205,7 +207,7 @@ solveCallStack ev ev_cs = do
canClass :: CtEvidence
-> Class -> [Type]
- -> Bool -- True <=> un-explored superclasses
+ -> ExpansionFuel -- n > 0 <=> un-explored superclasses
-> TcS (StopOrContinue Ct)
-- Precondition: EvVar is class evidence
@@ -497,34 +499,35 @@ makeSuperClasses :: [Ct] -> TcS [Ct]
-- least produce the immediate superclasses
makeSuperClasses cts = concatMapM go cts
where
- go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
- = mkStrictSuperClasses ev [] [] cls tys
+ go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys, cc_pend_sc = fuel })
+ = assertPpr (fuel > 0) (ppr cls) $ -- fuel needs to be more than 0 always
+ mkStrictSuperClasses (consumeFuel fuel) ev [] [] cls tys
go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))
= assertPpr (isClassPred pred) (ppr pred) $ -- The cts should all have
-- class pred heads
- mkStrictSuperClasses ev tvs theta cls tys
+ mkStrictSuperClasses defaultFuelQC ev tvs theta cls tys
where
(tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)
go ct = pprPanic "makeSuperClasses" (ppr ct)
mkStrictSuperClasses
- :: CtEvidence
+ :: ExpansionFuel -> CtEvidence
-> [TyVar] -> ThetaType -- These two args are non-empty only when taking
-- superclasses of a /quantified/ constraint
-> Class -> [Type] -> TcS [Ct]
-- Return constraints for the strict superclasses of
-- ev :: forall as. theta => cls tys
-mkStrictSuperClasses ev tvs theta cls tys
- = mk_strict_superclasses (unitNameSet (className cls))
+mkStrictSuperClasses fuel ev tvs theta cls tys
+ = mk_strict_superclasses fuel (unitNameSet (className cls))
ev tvs theta cls tys
-mk_strict_superclasses :: NameSet -> CtEvidence
+mk_strict_superclasses :: ExpansionFuel -> NameSet -> CtEvidence
-> [TyVar] -> ThetaType
-> Class -> [Type] -> TcS [Ct]
-- Always return the immediate superclasses of (cls tys);
-- and expand their superclasses, provided none of them are in rec_clss
-- nor are repeated
-mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
+mk_strict_superclasses fuel rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
tvs theta cls tys
= concatMapM do_one_given $
classSCSelIds cls
@@ -542,7 +545,7 @@ mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
| otherwise
= do { given_ev <- newGivenEvVar sc_loc $
mk_given_desc sel_id sc_pred
- ; mk_superclasses rec_clss given_ev tvs theta sc_pred }
+ ; mk_superclasses fuel rec_clss given_ev tvs theta sc_pred }
where
sc_pred = classMethodInstTy sel_id tys
@@ -603,7 +606,7 @@ mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
newly_blocked (InstSkol _ head_size) = isJust (this_size `ltPatersonSize` head_size)
newly_blocked _ = False
-mk_strict_superclasses rec_clss ev tvs theta cls tys
+mk_strict_superclasses fuel rec_clss ev tvs theta cls tys
| all noFreeVarsOfType tys
= return [] -- Wanteds with no variables yield no superclass constraints.
-- See Note [Improvement from Ground Wanteds]
@@ -618,7 +621,7 @@ mk_strict_superclasses rec_clss ev tvs theta cls tys
do_one sc_pred
= do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred)
; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred
- ; mk_superclasses rec_clss sc_ev [] [] sc_pred }
+ ; mk_superclasses fuel rec_clss sc_ev [] [] sc_pred }
{- Note [Improvement from Ground Wanteds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -633,29 +636,29 @@ dependencies. See Note [Why adding superclasses can help] above.
But no variables means no improvement; case closed.
-}
-mk_superclasses :: NameSet -> CtEvidence
+mk_superclasses :: ExpansionFuel -> NameSet -> CtEvidence
-> [TyVar] -> ThetaType -> PredType -> TcS [Ct]
-- Return this constraint, plus its superclasses, if any
-mk_superclasses rec_clss ev tvs theta pred
+mk_superclasses fuel rec_clss ev tvs theta pred
| ClassPred cls tys <- classifyPredType pred
- = mk_superclasses_of rec_clss ev tvs theta cls tys
+ = mk_superclasses_of fuel rec_clss ev tvs theta cls tys
| otherwise -- Superclass is not a class predicate
= return [mkNonCanonical ev]
-mk_superclasses_of :: NameSet -> CtEvidence
+mk_superclasses_of :: ExpansionFuel -> NameSet -> CtEvidence
-> [TyVar] -> ThetaType -> Class -> [Type]
-> TcS [Ct]
-- Always return this class constraint,
-- and expand its superclasses
-mk_superclasses_of rec_clss ev tvs theta cls tys
+mk_superclasses_of fuel rec_clss ev tvs theta cls tys
| loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)
; return [this_ct] } -- cc_pend_sc of this_ct = True
| otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys
, ppr (isCTupleClass cls)
, ppr rec_clss
])
- ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys
+ ; sc_cts <- mk_strict_superclasses fuel rec_clss' ev tvs theta cls tys
; return (this_ct : sc_cts) }
-- cc_pend_sc of this_ct = False
where
@@ -664,9 +667,12 @@ mk_superclasses_of rec_clss ev tvs theta cls tys
-- Tuples never contribute to recursion, and can be nested
rec_clss' = rec_clss `extendNameSet` cls_nm
+ this_cc_pend | loop_found = fuel
+ | otherwise = 0
+
this_ct | null tvs, null theta
= CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys
- , cc_pend_sc = loop_found }
+ , cc_pend_sc = this_cc_pend }
-- NB: If there is a loop, we cut off, so we have not
-- added the superclasses, hence cc_pend_sc = True
| otherwise
@@ -827,7 +833,7 @@ canForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType
canForAllNC ev tvs theta pred
| isGiven ev -- See Note [Eagerly expand given superclasses]
, Just (cls, tys) <- cls_pred_tys_maybe
- = do { sc_cts <- mkStrictSuperClasses ev tvs theta cls tys
+ = do { sc_cts <- mkStrictSuperClasses defaultFuelGivens ev tvs theta cls tys
; emitWork sc_cts
; canForAll ev False }
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -513,10 +513,13 @@ getInertGivens
; return (filter isGivenCt all_cts) }
getPendingGivenScs :: TcS [Ct]
--- Find all inert Given dictionaries, or quantified constraints,
--- whose cc_pend_sc flag is True
--- and that belong to the current level
--- Set their cc_pend_sc flag to False in the inert set, and return that Ct
+-- Find all inert Given dictionaries, or quantified constraints, such that
+-- 1. cc_pend_sc flag has fuel strictly > 0
+-- 2. belongs to the current level
+-- For each such dictionary:
+-- * Return it (with unmodified cc_pend_sc) in sc_pending
+-- * Modify the dict in the inert set to have cc_pend_sc = doNotExpand
+-- to record that we have expanded superclasses for this dict
getPendingGivenScs = do { lvl <- getTcLevel
; updRetInertCans (get_sc_pending lvl) }
@@ -530,23 +533,24 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
sc_pending = sc_pend_insts ++ sc_pend_dicts
sc_pend_dicts = foldDicts get_pending dicts []
- dicts' = foldr add dicts sc_pend_dicts
+ dicts' = foldr exhaustAndAdd dicts sc_pend_dicts
(sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts
- get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc = True
- -- but flipping the flag
+ get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc > 0
get_pending dict dicts
- | Just dict' <- pendingScDict_maybe dict
+ | isPendingScDict dict
, belongs_to_this_level (ctEvidence dict)
- = dict' : dicts
+ = dict : dicts
| otherwise
= dicts
- add :: Ct -> DictMap Ct -> DictMap Ct
- add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
- = addDict dicts cls tys ct
- add ct _ = pprPanic "getPendingScDicts" (ppr ct)
+ exhaustAndAdd :: Ct -> DictMap Ct -> DictMap Ct
+ exhaustAndAdd ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
+ -- exhaust the fuel for this constraint before adding it as
+ -- we don't want to expand these constraints again
+ = addDict dicts cls tys (ct {cc_pend_sc = doNotExpand})
+ exhaustAndAdd ct _ = pprPanic "getPendingScDicts" (ppr ct)
get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)
get_pending_inst cts qci@(QCI { qci_ev = ev })
=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -11,6 +11,8 @@ module GHC.Tc.Types.Constraint (
-- Canonical constraints
Xi, Ct(..), Cts,
+ ExpansionFuel, doNotExpand, defaultFuelGivens, defaultFuelWanteds,
+ defaultFuelQC, consumeFuel,
emptyCts, andCts, andManyCts, pprCts,
singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
isEmptyCts,
@@ -191,6 +193,19 @@ type Xi = TcType
type Cts = Bag Ct
+-- | Says how many layers of superclasses can we expand.
+-- see T21909
+type ExpansionFuel = Int
+
+doNotExpand, defaultFuelGivens, defaultFuelWanteds, defaultFuelQC :: ExpansionFuel
+doNotExpand = 0
+defaultFuelQC = 1
+defaultFuelWanteds = 1
+defaultFuelGivens = 3
+
+consumeFuel :: ExpansionFuel -> ExpansionFuel
+consumeFuel fuel = fuel - 1
+
data Ct
-- Atomic canonical constraints
= CDictCan { -- e.g. Num ty
@@ -199,11 +214,10 @@ data Ct
cc_class :: Class,
cc_tyargs :: [Xi], -- cc_tyargs are rewritten w.r.t. inerts, so Xi
- cc_pend_sc :: Bool
+ cc_pend_sc :: ExpansionFuel
-- See Note [The superclass story] in GHC.Tc.Solver.Canonical
- -- True <=> (a) cc_class has superclasses
- -- (b) we have not (yet) added those
- -- superclasses as Givens
+ -- n > 0 <=> (a) cc_class has superclasses
+ -- (b) we have not (yet) explored those superclasses
}
| CIrredCan { -- These stand for yet-unusable predicates
@@ -673,8 +687,8 @@ instance Outputable Ct where
CEqCan {} -> text "CEqCan"
CNonCanonical {} -> text "CNonCanonical"
CDictCan { cc_pend_sc = psc }
- | psc -> text "CDictCan(psc)"
- | otherwise -> text "CDictCan"
+ | psc > 0 -> text "CDictCan" <> parens (text "psc" <+> ppr psc)
+ | otherwise -> text "CDictCan"
CIrredCan { cc_reason = reason } -> text "CIrredCan" <> ppr reason
CQuantCan (QCI { qci_pend_sc = pend_sc })
| pend_sc -> text "CQuantCan(psc)"
@@ -893,16 +907,17 @@ isUserTypeError pred = case getUserTypeErrorMsg pred of
_ -> False
isPendingScDict :: Ct -> Bool
-isPendingScDict (CDictCan { cc_pend_sc = psc }) = psc
--- Says whether this is a CDictCan with cc_pend_sc is True;
+isPendingScDict (CDictCan { cc_pend_sc = psc }) = psc > 0
+-- Says whether this is a CDictCan with cc_pend_sc has positive fuel;
-- i.e. pending un-expanded superclasses
isPendingScDict _ = False
pendingScDict_maybe :: Ct -> Maybe Ct
--- Says whether this is a CDictCan with cc_pend_sc is True,
+-- Says whether this is a CDictCan with cc_pend_sc has fuel left,
-- AND if so flips the flag
-pendingScDict_maybe ct@(CDictCan { cc_pend_sc = True })
- = Just (ct { cc_pend_sc = False })
+pendingScDict_maybe ct@(CDictCan { cc_pend_sc = n })
+ | n > 0 = Just (ct { cc_pend_sc = doNotExpand })
+ | otherwise = Nothing
pendingScDict_maybe _ = Nothing
pendingScInst_maybe :: QCInst -> Maybe QCInst
@@ -932,7 +947,7 @@ getPendingWantedScs simples
= mapAccumBagL get [] simples
where
get acc ct | Just ct' <- pendingScDict_maybe ct
- = (ct':acc, ct')
+ = (ct:acc, ct')
| otherwise
= (acc, ct)
=====================================
docs/users_guide/9.6.1-notes.rst
=====================================
@@ -84,7 +84,7 @@ Language
This extends the variety syntax for constructing labels under :extension:`OverloadedLabels`.
Examples of newly allowed syntax:
- Leading capital letters: `#Foo` equivalant to `getLabel @"Foo"`
- - Numeric characters: `#3.14` equivalent to `getLabel @"3.14"`
+ - Numeric characters: `#1728` equivalent to `getLabel @"1728"`
- Arbitrary strings: `#"Hello, World!"` equivalent to `getLabel @"Hello, World!"`
Compiler
=====================================
libraries/base/GHC/Int.hs
=====================================
@@ -69,8 +69,8 @@ instance Eq Int8 where
(/=) = neInt8
eqInt8, neInt8 :: Int8 -> Int8 -> Bool
-eqInt8 (I8# x) (I8# y) = isTrue# (x `eqInt8#` y)
-neInt8 (I8# x) (I8# y) = isTrue# (x `neInt8#` y)
+eqInt8 (I8# x) (I8# y) = isTrue# ((int8ToInt# x) ==# (int8ToInt# y))
+neInt8 (I8# x) (I8# y) = isTrue# ((int8ToInt# x) /=# (int8ToInt# y))
{-# INLINE [1] eqInt8 #-}
{-# INLINE [1] neInt8 #-}
@@ -280,8 +280,8 @@ instance Eq Int16 where
(/=) = neInt16
eqInt16, neInt16 :: Int16 -> Int16 -> Bool
-eqInt16 (I16# x) (I16# y) = isTrue# (x `eqInt16#` y)
-neInt16 (I16# x) (I16# y) = isTrue# (x `neInt16#` y)
+eqInt16 (I16# x) (I16# y) = isTrue# ((int16ToInt# x) ==# (int16ToInt# y))
+neInt16 (I16# x) (I16# y) = isTrue# ((int16ToInt# x) /=# (int16ToInt# y))
{-# INLINE [1] eqInt16 #-}
{-# INLINE [1] neInt16 #-}
@@ -488,8 +488,8 @@ instance Eq Int32 where
(/=) = neInt32
eqInt32, neInt32 :: Int32 -> Int32 -> Bool
-eqInt32 (I32# x) (I32# y) = isTrue# (x `eqInt32#` y)
-neInt32 (I32# x) (I32# y) = isTrue# (x `neInt32#` y)
+eqInt32 (I32# x) (I32# y) = isTrue# ((int32ToInt# x) ==# (int32ToInt# y))
+neInt32 (I32# x) (I32# y) = isTrue# ((int32ToInt# x) /=# (int32ToInt# y))
{-# INLINE [1] eqInt32 #-}
{-# INLINE [1] neInt32 #-}
=====================================
libraries/base/GHC/Word.hs
=====================================
@@ -78,8 +78,8 @@ instance Eq Word8 where
(/=) = neWord8
eqWord8, neWord8 :: Word8 -> Word8 -> Bool
-eqWord8 (W8# x) (W8# y) = isTrue# (x `eqWord8#` y)
-neWord8 (W8# x) (W8# y) = isTrue# (x `neWord8#` y)
+eqWord8 (W8# x) (W8# y) = isTrue# ((word8ToWord# x) `eqWord#` (word8ToWord# y))
+neWord8 (W8# x) (W8# y) = isTrue# ((word8ToWord# x) `neWord#` (word8ToWord# y))
{-# INLINE [1] eqWord8 #-}
{-# INLINE [1] neWord8 #-}
@@ -268,8 +268,8 @@ instance Eq Word16 where
(/=) = neWord16
eqWord16, neWord16 :: Word16 -> Word16 -> Bool
-eqWord16 (W16# x) (W16# y) = isTrue# (x `eqWord16#` y)
-neWord16 (W16# x) (W16# y) = isTrue# (x `neWord16#` y)
+eqWord16 (W16# x) (W16# y) = isTrue# ((word16ToWord# x) `eqWord#` (word16ToWord# y))
+neWord16 (W16# x) (W16# y) = isTrue# ((word16ToWord# x) `neWord#` (word16ToWord# y))
{-# INLINE [1] eqWord16 #-}
{-# INLINE [1] neWord16 #-}
@@ -500,8 +500,8 @@ instance Eq Word32 where
(/=) = neWord32
eqWord32, neWord32 :: Word32 -> Word32 -> Bool
-eqWord32 (W32# x) (W32# y) = isTrue# (x `eqWord32#` y)
-neWord32 (W32# x) (W32# y) = isTrue# (x `neWord32#` y)
+eqWord32 (W32# x) (W32# y) = isTrue# ((word32ToWord# x) `eqWord#` (word32ToWord# y))
+neWord32 (W32# x) (W32# y) = isTrue# ((word32ToWord# x) `neWord#` (word32ToWord# y))
{-# INLINE [1] eqWord32 #-}
{-# INLINE [1] neWord32 #-}
=====================================
testsuite/tests/overloadedrecflds/should_run/T11671_run.hs
=====================================
@@ -12,8 +12,9 @@ import GHC.Prim (Addr#)
instance KnownSymbol symbol => IsLabel symbol String where
fromLabel = symbolVal (Proxy :: Proxy symbol)
-(#) :: String -> Int -> String
+(#), (#.) :: String -> Int -> String
(#) _ i = show i
+_ #. i = show i
f :: Addr# -> Int -> String
f _ i = show i
@@ -26,13 +27,13 @@ main = traverse_ putStrLn
, #type
, #Foo
, #3
- , #199.4
+ , #"199.4"
, #17a23b
, #f'a'
, #'a'
, #'
, #''notTHSplice
- , #...
+ , #"..."
, #привет
, #こんにちは
, #"3"
=====================================
testsuite/tests/printer/Test22771.hs
=====================================
@@ -14,8 +14,9 @@ import GHC.Prim (Addr#)
instance KnownSymbol symbol => IsLabel symbol String where
fromLabel = symbolVal (Proxy :: Proxy symbol)
-(#) :: String -> Int -> String
+(#), (#.) :: String -> Int -> String
(#) _ i = show i
+_ #. i = show i
f :: Addr# -> Int -> String
f _ i = show i
@@ -28,13 +29,13 @@ main = traverse_ putStrLn
, #type
, #Foo
, #3
- , #199.4
+ , #"199.4"
, #17a23b
, #f'a'
, #'a'
, #'
, #''notTHSplice
- , #...
+ , #"..."
, #привет
, #こんにちは
, #"3"
=====================================
testsuite/tests/typecheck/should_compile/T21909.hs
=====================================
@@ -0,0 +1,24 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+module T21909 where
+
+import Data.Kind
+
+class (Monad m, MyMonad (Inner m)) => MyMonad m where
+ type Inner m :: Type -> Type
+ foo :: m Int
+
+works :: MyMonad m => m String
+works = show <$> ((+ 1) <$> foo)
+
+fails :: MyMonad m => m String
+fails = show <$> fooPlusOne
+ where
+ fooPlusOne = (+ 1) <$> foo
+
+alsoFails :: MyMonad m => m String
+alsoFails =
+ let fooPlusOne = (+ 1) <$> foo
+ in show <$> fooPlusOne
=====================================
testsuite/tests/typecheck/should_compile/T21909b.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableSuperClasses, FunctionalDependencies, MultiParamTypeClasses, GADTs #-}
+
+module T21909b where
+
+import Data.Kind
+
+class C [a] => C a where
+ foo :: a -> Int
+
+should_work :: C a => a -> Int
+should_work x = foolocal x
+ where
+ foolocal a = foo a
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -857,3 +857,5 @@ test('T22647', normal, compile, [''])
test('T19577', normal, compile, [''])
test('T22383', normal, compile, [''])
test('T21501', normal, compile, [''])
+test('T21909', normal, compile, [''])
+test('T21909b', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bd4624de94c4d526e83fff095e4139dceb7f39a4...a201cc18a0c7d7ffb5154fcac573cfc3ca6dd458
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bd4624de94c4d526e83fff095e4139dceb7f39a4...a201cc18a0c7d7ffb5154fcac573cfc3ca6dd458
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/20230207/b77d8fc7/attachment-0001.html>
More information about the ghc-commits
mailing list