[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Use TcRnVDQInTermType in noNestedForallsContextsErr (#20115)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Oct 27 12:24:00 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
f60a1a62 by Vladislav Zavialov at 2022-10-26T12:17:14-04:00
Use TcRnVDQInTermType in noNestedForallsContextsErr (#20115)
When faced with VDQ in the type of a term, GHC generates the following
error message:
Illegal visible, dependent quantification in the type of a term
(GHC does not yet support this)
Prior to this patch, there were two ways this message could have been
generated and represented:
1. with the dedicated constructor TcRnVDQInTermType
(see check_type in GHC.Tc.Validity)
2. with the transitional constructor TcRnUnknownMessage
(see noNestedForallsContextsErr in GHC.Rename.Utils)
Not only this led to duplication of code generating the final SDoc,
it also made it tricky to track the origin of the error message.
This patch fixes the problem by using TcRnVDQInTermType exclusively.
- - - - -
1ba756c0 by Owen Shepherd at 2022-10-27T08:23:32-04:00
Remove source location information from interface files
This change aims to minimize source location information leaking
into interface files, which makes ABI hashes dependent on the
build location.
The `Binary (Located a)` instance has been removed completely.
It seems that the HIE interface still needs the ability to
serialize SrcSpans, but by wrapping the instances, it should
be a lot more difficult to inadvertently add source location
information.
- - - - -
5fc9e728 by Simon Peyton Jones at 2022-10-27T08:23:33-04:00
Add missing dict binds to specialiser
I had forgotten to add the auxiliary dict bindings to the
/unfolding/ of a specialised function. This caused #22358,
which reports failures when compiling Hackage packages
fixed-vector
indexed-traversable
Regression test T22357 is snarfed from indexed-traversable
- - - - -
20 changed files:
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Unfold/Make.hs
- compiler/GHC/Data/BooleanFormula.hs
- compiler/GHC/Hs/Doc.hs
- compiler/GHC/Hs/DocString.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Types.hs
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/Unit/Module/Warnings.hs
- compiler/GHC/Utils/Binary.hs
- testsuite/tests/dependent/should_fail/T16326_Fail6.stderr
- testsuite/tests/dependent/should_fail/T16326_Fail8.stderr
- testsuite/tests/dependent/should_fail/T18271.stderr
- + testsuite/tests/simplCore/should_compile/T22357.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1627,8 +1627,8 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
; (rhs_body', rhs_uds) <- specExpr rhs_env2 rhs_body
-- Add the { d1' = dx1; d2' = dx2 } usage stuff
-- to the rhs_uds; see Note [Specialising Calls]
- ; let rhs_uds_w_dx = foldr consDictBind rhs_uds dx_binds
- spec_rhs_bndrs = spec_bndrs1 ++ leftover_bndrs
+ ; let rhs_uds_w_dx = dx_binds `consDictBinds` rhs_uds
+ spec_rhs_bndrs = spec_bndrs1 ++ leftover_bndrs
(spec_uds, dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds_w_dx
spec_rhs1 = mkLams spec_rhs_bndrs $
wrapDictBindsE dumped_dbs rhs_body'
@@ -1671,7 +1671,10 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
--------------------------------------
-- Add a suitable unfolding; see Note [Inline specialisations]
- spec_unf = specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args)
+ -- The wrap_unf_body applies the original unfolding to the specialised
+ -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)
+ wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds
+ spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body
rule_lhs_args fn_unf
spec_inl_prag
@@ -3048,11 +3051,6 @@ snocDictBinds uds at MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs
= uds { ud_binds = FDB { fdb_binds = binds `appOL` (toOL dbs)
, fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }
-consDictBind :: DictBind -> UsageDetails -> UsageDetails
-consDictBind db uds at MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs=bs}}
- = uds { ud_binds = FDB { fdb_binds = db `consOL` binds
- , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }
-
consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
consDictBinds dbs uds at MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}
= uds { ud_binds = FDB{ fdb_binds = toOL dbs `appOL` binds
=====================================
compiler/GHC/Core/Unfold/Make.hs
=====================================
@@ -227,14 +227,15 @@ specUnfolding to specialise its unfolding. Some important points:
This happens with Control.Monad.liftM3, and can cause a lot more
allocation as a result (nofib n-body shows this).
- Moreover, keeping the stable unfoldign isn't much help, because
+ Moreover, keeping the stable unfolding isn't much help, because
the specialised function (probably) isn't overloaded any more.
- TL;DR: we simply drop the stable unfolding when specialising. It's
- not really a complete solution; ignoring specialisation for now,
- INLINABLE functions don't get properly strictness analysed, for
- example. But it works well for examples involving specialisation,
- which is the dominant use of INLINABLE.
+ TL;DR: we simply drop the stable unfolding when specialising. It's not
+ really a complete solution; ignoring specialisation for now, INLINABLE
+ functions don't get properly strictness analysed, for example.
+ Moreover, it means that the specialised function has an INLINEABLE
+ pragma, but no stable unfolding. But it works well for examples
+ involving specialisation, which is the dominant use of INLINABLE.
Note [Honour INLINE on 0-ary bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Data/BooleanFormula.hs
=====================================
@@ -25,7 +25,7 @@ import Data.Data
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Binary
-import GHC.Parser.Annotation ( LocatedL )
+import GHC.Parser.Annotation ( LocatedL, noLocA )
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Set
@@ -251,14 +251,14 @@ pprBooleanFormulaNormal = go
instance Binary a => Binary (BooleanFormula a) where
put_ bh (Var x) = putByte bh 0 >> put_ bh x
- put_ bh (And xs) = putByte bh 1 >> put_ bh xs
- put_ bh (Or xs) = putByte bh 2 >> put_ bh xs
- put_ bh (Parens x) = putByte bh 3 >> put_ bh x
+ put_ bh (And xs) = putByte bh 1 >> put_ bh (unLoc <$> xs)
+ put_ bh (Or xs) = putByte bh 2 >> put_ bh (unLoc <$> xs)
+ put_ bh (Parens x) = putByte bh 3 >> put_ bh (unLoc x)
get bh = do
h <- getByte bh
case h of
- 0 -> Var <$> get bh
- 1 -> And <$> get bh
- 2 -> Or <$> get bh
- _ -> Parens <$> get bh
+ 0 -> Var <$> get bh
+ 1 -> And . fmap noLocA <$> get bh
+ 2 -> Or . fmap noLocA <$> get bh
+ _ -> Parens . noLocA <$> get bh
=====================================
compiler/GHC/Hs/Doc.hs
=====================================
@@ -85,9 +85,9 @@ instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where
instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where
put_ bh (WithHsDocIdentifiers s ids) = do
put_ bh s
- put_ bh ids
+ put_ bh $ BinLocated <$> ids
get bh =
- liftA2 WithHsDocIdentifiers (get bh) (get bh)
+ liftA2 WithHsDocIdentifiers (get bh) (fmap unBinLocated <$> get bh)
-- | Extract a mapping from the lexed identifiers to the names they may
-- correspond to.
=====================================
compiler/GHC/Hs/DocString.hs
=====================================
@@ -75,19 +75,19 @@ instance Binary HsDocString where
MultiLineDocString dec xs -> do
putByte bh 0
put_ bh dec
- put_ bh xs
+ put_ bh $ BinLocated <$> xs
NestedDocString dec x -> do
putByte bh 1
put_ bh dec
- put_ bh x
+ put_ bh $ BinLocated x
GeneratedDocString x -> do
putByte bh 2
put_ bh x
get bh = do
tag <- getByte bh
case tag of
- 0 -> MultiLineDocString <$> get bh <*> get bh
- 1 -> NestedDocString <$> get bh <*> get bh
+ 0 -> MultiLineDocString <$> get bh <*> (fmap unBinLocated <$> get bh)
+ 1 -> NestedDocString <$> get bh <*> (unBinLocated <$> get bh)
2 -> GeneratedDocString <$> get bh
t -> fail $ "HsDocString: invalid tag " ++ show t
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -339,10 +339,10 @@ fromHieName nc hie_name = do
putHieName :: BinHandle -> HieName -> IO ()
putHieName bh (ExternalName mod occ span) = do
putByte bh 0
- put_ bh (mod, occ, span)
+ put_ bh (mod, occ, BinSrcSpan span)
putHieName bh (LocalName occName span) = do
putByte bh 1
- put_ bh (occName, span)
+ put_ bh (occName, BinSrcSpan span)
putHieName bh (KnownKeyName uniq) = do
putByte bh 2
put_ bh $ unpkUnique uniq
@@ -353,10 +353,10 @@ getHieName bh = do
case t of
0 -> do
(modu, occ, span) <- get bh
- return $ ExternalName modu occ span
+ return $ ExternalName modu occ $ unBinSrcSpan span
1 -> do
(occ, span) <- get bh
- return $ LocalName occ span
+ return $ LocalName occ $ unBinSrcSpan span
2 -> do
(c,i) <- get bh
return $ KnownKeyName $ mkUnique c i
=====================================
compiler/GHC/Iface/Ext/Types.hs
=====================================
@@ -251,12 +251,12 @@ data HieAST a =
instance Binary (HieAST TypeIndex) where
put_ bh ast = do
put_ bh $ sourcedNodeInfo ast
- put_ bh $ nodeSpan ast
+ put_ bh $ BinSpan $ nodeSpan ast
put_ bh $ nodeChildren ast
get bh = Node
<$> get bh
- <*> get bh
+ <*> (unBinSpan <$> get bh)
<*> get bh
instance Outputable a => Outputable (HieAST a) where
@@ -486,19 +486,19 @@ instance Binary ContextInfo where
putByte bh 3
put_ bh bt
put_ bh sc
- put_ bh msp
+ put_ bh $ BinSpan <$> msp
put_ bh (PatternBind a b c) = do
putByte bh 4
put_ bh a
put_ bh b
- put_ bh c
+ put_ bh $ BinSpan <$> c
put_ bh (ClassTyDecl sp) = do
putByte bh 5
- put_ bh sp
+ put_ bh $ BinSpan <$> sp
put_ bh (Decl a b) = do
putByte bh 6
put_ bh a
- put_ bh b
+ put_ bh $ BinSpan <$> b
put_ bh (TyVarBind a b) = do
putByte bh 7
put_ bh a
@@ -506,13 +506,13 @@ instance Binary ContextInfo where
put_ bh (RecField a b) = do
putByte bh 8
put_ bh a
- put_ bh b
+ put_ bh $ BinSpan <$> b
put_ bh MatchBind = putByte bh 9
put_ bh (EvidenceVarBind a b c) = do
putByte bh 10
put_ bh a
put_ bh b
- put_ bh c
+ put_ bh $ BinSpan <$> c
put_ bh EvidenceVarUse = putByte bh 11
get bh = do
@@ -521,14 +521,14 @@ instance Binary ContextInfo where
0 -> return Use
1 -> IEThing <$> get bh
2 -> return TyDecl
- 3 -> ValBind <$> get bh <*> get bh <*> get bh
- 4 -> PatternBind <$> get bh <*> get bh <*> get bh
- 5 -> ClassTyDecl <$> get bh
- 6 -> Decl <$> get bh <*> get bh
+ 3 -> ValBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)
+ 4 -> PatternBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)
+ 5 -> ClassTyDecl <$> (fmap unBinSpan <$> get bh)
+ 6 -> Decl <$> get bh <*> (fmap unBinSpan <$> get bh)
7 -> TyVarBind <$> get bh <*> get bh
- 8 -> RecField <$> get bh <*> get bh
+ 8 -> RecField <$> get bh <*> (fmap unBinSpan <$> get bh)
9 -> return MatchBind
- 10 -> EvidenceVarBind <$> get bh <*> get bh <*> get bh
+ 10 -> EvidenceVarBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)
11 -> return EvidenceVarUse
_ -> panic "Binary ContextInfo: invalid tag"
@@ -679,14 +679,14 @@ instance Binary Scope where
put_ bh NoScope = putByte bh 0
put_ bh (LocalScope span) = do
putByte bh 1
- put_ bh span
+ put_ bh $ BinSpan span
put_ bh ModuleScope = putByte bh 2
get bh = do
(t :: Word8) <- get bh
case t of
0 -> return NoScope
- 1 -> LocalScope <$> get bh
+ 1 -> LocalScope . unBinSpan <$> get bh
2 -> return ModuleScope
_ -> panic "Binary Scope: invalid tag"
@@ -732,13 +732,13 @@ instance Binary TyVarScope where
put_ bh (UnresolvedScope ns span) = do
putByte bh 1
put_ bh ns
- put_ bh span
+ put_ bh (BinSpan <$> span)
get bh = do
(t :: Word8) <- get bh
case t of
0 -> ResolvedScopes <$> get bh
- 1 -> UnresolvedScope <$> get bh <*> get bh
+ 1 -> UnresolvedScope <$> get bh <*> (fmap unBinSpan <$> get bh)
_ -> panic "Binary TyVarScope: invalid tag"
-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -95,7 +95,6 @@ import GHC.Data.FastString
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Hs.DocString
-import GHC.Utils.Binary
import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Utils.Panic
import qualified GHC.Data.Strict as Strict
@@ -1249,17 +1248,6 @@ instance Outputable AnnSortKey where
instance Outputable IsUnicodeSyntax where
ppr = text . show
-instance Binary a => Binary (LocatedL a) where
- -- We do not serialise the annotations
- put_ bh (L l x) = do
- put_ bh (locA l)
- put_ bh x
-
- get bh = do
- l <- get bh
- x <- get bh
- return (L (noAnnSrcSpan l) x)
-
instance (Outputable a) => Outputable (SrcSpanAnn' a) where
ppr (SrcSpanAnn a l) = text "SrcSpanAnn" <+> ppr a <+> ppr l
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -618,7 +618,8 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
Just (L _ cls) -> Right cls
Nothing -> Left
( getLocA head_ty'
- , hang (text "Illegal head of an instance declaration:"
+ , mkTcRnUnknownMessage $ mkPlainError noHints $
+ hang (text "Illegal head of an instance declaration:"
<+> quotes (ppr head_ty'))
2 (vcat [ text "Instance heads must be of the form"
, nest 2 $ text "C ty_1 ... ty_n"
@@ -681,9 +682,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
-- reach the typechecker, lest we encounter different errors that are
-- hopelessly confusing (such as the one in #16114).
bail_out (l, err_msg) = do
- addErrAt l $
- TcRnWithHsDocContext ctxt $
- mkTcRnUnknownMessage $ mkPlainError noHints err_msg
+ addErrAt l $ TcRnWithHsDocContext ctxt err_msg
pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))
rnFamEqn :: HsDocContext
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -288,7 +288,7 @@ Note [No nested foralls or contexts in instance types] in GHC.Hs.Type).
-- "GHC.Rename.Module" and 'renameSig' in "GHC.Rename.Bind").
-- See @Note [No nested foralls or contexts in instance types]@ in
-- "GHC.Hs.Type".
-noNestedForallsContextsErr :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, SDoc)
+noNestedForallsContextsErr :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, TcRnMessage)
noNestedForallsContextsErr what lty =
case ignoreParens lty of
L l (HsForAllTy { hst_tele = tele })
@@ -297,9 +297,7 @@ noNestedForallsContextsErr what lty =
-- types of terms, so we give a slightly more descriptive error
-- message in the event that they contain visible dependent
-- quantification (currently only allowed in kinds).
- -> Just (locA l, vcat [ text "Illegal visible, dependent quantification" <+>
- text "in the type of a term"
- , text "(GHC does not yet support this)" ])
+ -> Just (locA l, TcRnVDQInTermType Nothing)
| HsForAllInvis{} <- tele
-> Just (locA l, nested_foralls_contexts_err)
L l (HsQualTy {})
@@ -307,6 +305,7 @@ noNestedForallsContextsErr what lty =
_ -> Nothing
where
nested_foralls_contexts_err =
+ mkTcRnUnknownMessage $ mkPlainError noHints $
what <+> text "cannot contain nested"
<+> quotes forAllLit <> text "s or contexts"
@@ -314,9 +313,7 @@ noNestedForallsContextsErr what lty =
addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM ()
addNoNestedForallsContextsErr ctxt what lty =
whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) ->
- addErrAt l $
- TcRnWithHsDocContext ctxt $
- mkTcRnUnknownMessage $ mkPlainError noHints err_msg
+ addErrAt l $ TcRnWithHsDocContext ctxt err_msg
{-
************************************************************************
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -364,12 +364,16 @@ instance Diagnostic TcRnMessage where
2 (text "type:" <+> quotes (ppr ty))
, hang (text "where the body of the forall has this kind:")
2 (quotes (pprKind kind)) ]
- TcRnVDQInTermType ty
+ TcRnVDQInTermType mb_ty
-> mkSimpleDecorated $ vcat
- [ hang (text "Illegal visible, dependent quantification" <+>
- text "in the type of a term:")
- 2 (pprType ty)
+ [ case mb_ty of
+ Nothing -> main_msg
+ Just ty -> hang (main_msg <> char ':') 2 (pprType ty)
, text "(GHC does not yet support this)" ]
+ where
+ main_msg =
+ text "Illegal visible, dependent quantification" <+>
+ text "in the type of a term"
TcRnBadQuantPredHead ty
-> mkSimpleDecorated $
hang (text "Quantified predicate must have a class or type variable head:")
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -915,7 +915,7 @@ data TcRnMessage where
dependent/should_fail/T17687
dependent/should_fail/T18271
-}
- TcRnVDQInTermType :: !Type -> TcRnMessage
+ TcRnVDQInTermType :: !(Maybe Type) -> TcRnMessage
{-| TcRnBadQuantPredHead is an error that occurs whenever a quantified predicate
lacks a class or type variable head.
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -733,7 +733,7 @@ check_type ve (CastTy ty _) = check_type ve ty
--
-- Critically, this case must come *after* the case for TyConApp.
-- See Note [Liberal type synonyms].
-check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt
+check_type ve@(ValidityEnv{ ve_tidy_env = env
, ve_rank = rank, ve_expand = expand }) ty
| not (null tvbs && null theta)
= do { traceTc "check_type" (ppr ty $$ ppr rank)
@@ -745,9 +745,7 @@ check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt
-- Reject forall (a :: Eq b => b). blah
-- In a kind signature we don't allow constraints
- ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs
- || vdqAllowed ctxt)
- (env, TcRnVDQInTermType (tidyType env ty))
+ ; checkVdqOK ve tvbs ty
-- Reject visible, dependent quantification in the type of a
-- term (e.g., `f :: forall a -> a -> Maybe a`)
@@ -938,6 +936,14 @@ checkConstraintsOK ve theta ty
checkTcM (all isEqPred theta) (env, TcRnConstraintInKind (tidyType env ty))
where env = ve_tidy_env ve
+checkVdqOK :: ValidityEnv -> [TyVarBinder] -> Type -> TcM ()
+checkVdqOK ve tvbs ty = do
+ checkTcM (vdqAllowed ctxt || no_vdq)
+ (env, TcRnVDQInTermType (Just (tidyType env ty)))
+ where
+ no_vdq = all (isInvisibleArgFlag . binderArgFlag) tvbs
+ ValidityEnv{ve_tidy_env = env, ve_ctxt = ctxt} = ve
+
{-
Note [Liberal type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -61,21 +61,21 @@ instance Outputable (WarningTxt pass) where
instance Binary (WarningTxt GhcRn) where
put_ bh (WarningTxt s w) = do
putByte bh 0
- put_ bh s
- put_ bh w
+ put_ bh $ unLoc s
+ put_ bh $ unLoc <$> w
put_ bh (DeprecatedTxt s d) = do
putByte bh 1
- put_ bh s
- put_ bh d
+ put_ bh $ unLoc s
+ put_ bh $ unLoc <$> d
get bh = do
h <- getByte bh
case h of
- 0 -> do s <- get bh
- w <- get bh
+ 0 -> do s <- noLoc <$> get bh
+ w <- fmap noLoc <$> get bh
return (WarningTxt s w)
- _ -> do s <- get bh
- d <- get bh
+ _ -> do s <- noLoc <$> get bh
+ d <- fmap noLoc <$> get bh
return (DeprecatedTxt s d)
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -73,6 +73,9 @@ module GHC.Utils.Binary
UserData(..), getUserData, setUserData,
newReadState, newWriteState,
putDictionary, getDictionary, putFS,
+
+ -- * Newtype wrappers
+ BinSpan(..), BinSrcSpan(..), BinLocated(..)
) where
import GHC.Prelude
@@ -1285,18 +1288,23 @@ instance Binary ModuleName where
-- fs <- get bh
-- return (StringLiteral st fs Nothing)
-instance Binary a => Binary (Located a) where
- put_ bh (L l x) = do
- put_ bh l
+newtype BinLocated a = BinLocated { unBinLocated :: Located a }
+
+instance Binary a => Binary (BinLocated a) where
+ put_ bh (BinLocated (L l x)) = do
+ put_ bh $ BinSrcSpan l
put_ bh x
get bh = do
- l <- get bh
+ l <- unBinSrcSpan <$> get bh
x <- get bh
- return (L l x)
+ return $ BinLocated (L l x)
+
+newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan }
-instance Binary RealSrcSpan where
- put_ bh ss = do
+-- See Note [Source Location Wrappers]
+instance Binary BinSpan where
+ put_ bh (BinSpan ss) = do
put_ bh (srcSpanFile ss)
put_ bh (srcSpanStartLine ss)
put_ bh (srcSpanStartCol ss)
@@ -1309,8 +1317,8 @@ instance Binary RealSrcSpan where
sc <- get bh
el <- get bh
ec <- get bh
- return (mkRealSrcSpan (mkRealSrcLoc f sl sc)
- (mkRealSrcLoc f el ec))
+ return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc)
+ (mkRealSrcLoc f el ec))
instance Binary UnhelpfulSpanReason where
put_ bh r = case r of
@@ -1329,24 +1337,44 @@ instance Binary UnhelpfulSpanReason where
3 -> return UnhelpfulGenerated
_ -> UnhelpfulOther <$> get bh
-instance Binary SrcSpan where
- put_ bh (RealSrcSpan ss _sb) = do
+newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan }
+
+-- See Note [Source Location Wrappers]
+instance Binary BinSrcSpan where
+ put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do
putByte bh 0
-- BufSpan doesn't ever get serialised because the positions depend
-- on build location.
- put_ bh ss
+ put_ bh $ BinSpan ss
- put_ bh (UnhelpfulSpan s) = do
+ put_ bh (BinSrcSpan (UnhelpfulSpan s)) = do
putByte bh 1
put_ bh s
get bh = do
h <- getByte bh
case h of
- 0 -> do ss <- get bh
- return (RealSrcSpan ss Strict.Nothing)
+ 0 -> do BinSpan ss <- get bh
+ return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing)
_ -> do s <- get bh
- return (UnhelpfulSpan s)
+ return $ BinSrcSpan (UnhelpfulSpan s)
+
+
+{-
+Note [Source Location Wrappers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Source locations are banned from interface files, to
+prevent filepaths affecting interface hashes.
+
+Unfortunately, we can't remove all binary instances,
+as they're used to serialise .hie files, and we don't
+want to break binary compatibility.
+
+To this end, the Bin[Src]Span newtypes wrappers were
+introduced to prevent accidentally serialising a
+source location as part of a larger structure.
+-}
--------------------------------------------------------------------------------
-- Instances for the containers package
=====================================
testsuite/tests/dependent/should_fail/T16326_Fail6.stderr
=====================================
@@ -1,5 +1,5 @@
-T16326_Fail6.hs:9:12: error:
+T16326_Fail6.hs:9:12: error: [GHC-51580]
Illegal visible, dependent quantification in the type of a term
(GHC does not yet support this)
In the definition of data constructor ‘MkFoo’
=====================================
testsuite/tests/dependent/should_fail/T16326_Fail8.stderr
=====================================
@@ -1,5 +1,5 @@
-T16326_Fail8.hs:7:10: error:
+T16326_Fail8.hs:7:10: error: [GHC-51580]
Illegal visible, dependent quantification in the type of a term
(GHC does not yet support this)
In an instance declaration
=====================================
testsuite/tests/dependent/should_fail/T18271.stderr
=====================================
@@ -1,5 +1,5 @@
-T18271.hs:7:19: error:
+T18271.hs:7:19: error: [GHC-51580]
Illegal visible, dependent quantification in the type of a term
(GHC does not yet support this)
In a deriving declaration
=====================================
testsuite/tests/simplCore/should_compile/T22357.hs
=====================================
@@ -0,0 +1,727 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+#if __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE DefaultSignatures #-}
+#endif
+
+#if __GLASGOW_HASKELL__ >= 706
+{-# LANGUAGE PolyKinds #-}
+#endif
+module WithIndex where
+
+import Prelude
+ (Either (..), Functor (..), Int, Maybe (..), Monad (..), Num (..), error,
+ flip, id, seq, snd, ($!), ($), (.), zip)
+
+import Control.Applicative
+ (Applicative (..), Const (..), ZipList (..), (<$>), liftA2)
+import Control.Applicative.Backwards (Backwards (..))
+import Control.Monad.Trans.Identity (IdentityT (..))
+import Control.Monad.Trans.Reader (ReaderT (..))
+import Data.Array (Array)
+import Data.Foldable (Foldable (..))
+import Data.Functor.Compose (Compose (..))
+import Data.Functor.Constant (Constant (..))
+import Data.Functor.Identity (Identity (..))
+import Data.Functor.Product (Product (..))
+import Data.Functor.Reverse (Reverse (..))
+import Data.Functor.Sum (Sum (..))
+import Data.IntMap (IntMap)
+import Data.Ix (Ix (..))
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Map (Map)
+import Data.Monoid (Dual (..), Endo (..), Monoid (..))
+import Data.Proxy (Proxy (..))
+import Data.Semigroup (Semigroup (..))
+import Data.Sequence (Seq)
+import Data.Traversable (Traversable (..))
+import Data.Tree (Tree (..))
+import Data.Void (Void)
+
+#if __GLASGOW_HASKELL__ >= 702
+import GHC.Generics
+ (K1 (..), Par1 (..), Rec1 (..), U1 (..), V1, (:*:) (..), (:+:) (..),
+ (:.:) (..))
+#else
+import Generics.Deriving
+ (K1 (..), Par1 (..), Rec1 (..), U1 (..), V1, (:*:) (..), (:+:) (..),
+ (:.:) (..))
+#endif
+
+import Data.Type.Equality
+import qualified Data.Array as Array
+import qualified Data.IntMap as IntMap
+import qualified Data.Map as Map
+import qualified Data.Sequence as Seq
+
+#ifdef MIN_VERSION_base_orphans
+import Data.Orphans ()
+#endif
+
+#if __GLASGOW_HASKELL__ >=708
+import Data.Coerce (Coercible, coerce)
+#else
+import Unsafe.Coerce (unsafeCoerce)
+#endif
+
+-------------------------------------------------------------------------------
+-- FunctorWithIndex
+-------------------------------------------------------------------------------
+
+-- | A 'Functor' with an additional index.
+--
+-- Instances must satisfy a modified form of the 'Functor' laws:
+--
+-- @
+-- 'imap' f '.' 'imap' g ≡ 'imap' (\\i -> f i '.' g i)
+-- 'imap' (\\_ a -> a) ≡ 'id'
+-- @
+class Functor f => FunctorWithIndex i f | f -> i where
+ -- | Map with access to the index.
+ imap :: (i -> a -> b) -> f a -> f b
+
+#if __GLASGOW_HASKELL__ >= 704
+ default imap :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b
+ imap = imapDefault
+ {-# INLINE imap #-}
+#endif
+
+imapDefault :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b
+-- imapDefault f = runIdentity #. itraverse (\i a -> Identity (f i a))
+imapDefault f = runIdentity #. itraverse (Identity #.. f)
+{-# INLINE imapDefault #-}
+
+-------------------------------------------------------------------------------
+-- FoldableWithIndex
+-------------------------------------------------------------------------------
+
+-- | A container that supports folding with an additional index.
+class Foldable f => FoldableWithIndex i f | f -> i where
+ --
+ -- | Fold a container by mapping value to an arbitrary 'Monoid' with access to the index @i at .
+ --
+ -- When you don't need access to the index then 'foldMap' is more flexible in what it accepts.
+ --
+ -- @
+ -- 'foldMap' ≡ 'ifoldMap' '.' 'const'
+ -- @
+ ifoldMap :: Monoid m => (i -> a -> m) -> f a -> m
+
+#if __GLASGOW_HASKELL__ >= 704
+ default ifoldMap :: (TraversableWithIndex i f, Monoid m) => (i -> a -> m) -> f a -> m
+ ifoldMap = ifoldMapDefault
+ {-# INLINE ifoldMap #-}
+#endif
+
+ -- | A variant of 'ifoldMap' that is strict in the accumulator.
+ --
+ -- When you don't need access to the index then 'Data.Foldable.foldMap'' is more flexible in what it accepts.
+ --
+ -- @
+ -- 'foldMap'' ≡ 'ifoldMap'' '.' 'const'
+ -- @
+ ifoldMap' :: Monoid m => (i -> a -> m) -> f a -> m
+ ifoldMap' f = ifoldl' (\i acc a -> mappend acc (f i a)) mempty
+ {-# INLINE ifoldMap' #-}
+
+ -- | Right-associative fold of an indexed container with access to the index @i at .
+ --
+ -- When you don't need access to the index then 'Data.Foldable.foldr' is more flexible in what it accepts.
+ --
+ -- @
+ -- 'Data.Foldable.foldr' ≡ 'ifoldr' '.' 'const'
+ -- @
+ ifoldr :: (i -> a -> b -> b) -> b -> f a -> b
+ ifoldr f z t = appEndo (ifoldMap (Endo #.. f) t) z
+ {-# INLINE ifoldr #-}
+
+ -- | Left-associative fold of an indexed container with access to the index @i at .
+ --
+ -- When you don't need access to the index then 'Data.Foldable.foldl' is more flexible in what it accepts.
+ --
+ -- @
+ -- 'Data.Foldable.foldl' ≡ 'ifoldl' '.' 'const'
+ -- @
+ ifoldl :: (i -> b -> a -> b) -> b -> f a -> b
+ ifoldl f z t = appEndo (getDual (ifoldMap (\ i -> Dual #. Endo #. flip (f i)) t)) z
+ {-# INLINE ifoldl #-}
+
+ -- | /Strictly/ fold right over the elements of a structure with access to the index @i at .
+ --
+ -- When you don't need access to the index then 'foldr'' is more flexible in what it accepts.
+ --
+ -- @
+ -- 'foldr'' ≡ 'ifoldr'' '.' 'const'
+ -- @
+ ifoldr' :: (i -> a -> b -> b) -> b -> f a -> b
+ ifoldr' f z0 xs = ifoldl f' id xs z0
+ where f' i k x z = k $! f i x z
+ {-# INLINE ifoldr' #-}
+
+ -- | Fold over the elements of a structure with an index, associating to the left, but /strictly/.
+ --
+ -- When you don't need access to the index then 'Control.Lens.Fold.foldlOf'' is more flexible in what it accepts.
+ --
+ -- @
+ -- 'Data.Foldable.foldl'' l ≡ 'ifoldl'' l '.' 'const'
+ -- @
+ ifoldl' :: (i -> b -> a -> b) -> b -> f a -> b
+ ifoldl' f z0 xs = ifoldr f' id xs z0
+ where f' i x k z = k $! f i z x
+ {-# INLINE ifoldl' #-}
+
+ifoldMapDefault :: (TraversableWithIndex i f, Monoid m) => (i -> a -> m) -> f a -> m
+ifoldMapDefault f = getConst #. itraverse (Const #.. f)
+{-# INLINE ifoldMapDefault #-}
+
+-------------------------------------------------------------------------------
+-- TraversableWithIndex
+-------------------------------------------------------------------------------
+
+-- | A 'Traversable' with an additional index.
+--
+-- An instance must satisfy a (modified) form of the 'Traversable' laws:
+--
+-- @
+-- 'itraverse' ('const' 'Identity') ≡ 'Identity'
+-- 'fmap' ('itraverse' f) '.' 'itraverse' g ≡ 'Data.Functor.Compose.getCompose' '.' 'itraverse' (\\i -> 'Data.Functor.Compose.Compose' '.' 'fmap' (f i) '.' g i)
+-- @
+class (FunctorWithIndex i t, FoldableWithIndex i t, Traversable t) => TraversableWithIndex i t | t -> i where
+ -- | Traverse an indexed container.
+ --
+ -- @
+ -- 'itraverse' ≡ 'itraverseOf' 'itraversed'
+ -- @
+ itraverse :: Applicative f => (i -> a -> f b) -> t a -> f (t b)
+
+#if __GLASGOW_HASKELL__ >= 704
+ default itraverse :: (i ~ Int, Applicative f) => (i -> a -> f b) -> t a -> f (t b)
+ itraverse f s = snd $ runIndexing (traverse (\a -> Indexing (\i -> i `seq` (i + 1, f i a))) s) 0
+ {-# INLINE itraverse #-}
+#endif
+
+-------------------------------------------------------------------------------
+-- base
+-------------------------------------------------------------------------------
+
+instance FunctorWithIndex r ((->) r) where
+ imap f g x = f x (g x)
+ {-# INLINE imap #-}
+
+instance FunctorWithIndex () Maybe where
+ imap f = fmap (f ())
+ {-# INLINE imap #-}
+instance FoldableWithIndex () Maybe where
+ ifoldMap f = foldMap (f ())
+ {-# INLINE ifoldMap #-}
+instance TraversableWithIndex () Maybe where
+ itraverse f = traverse (f ())
+ {-# INLINE itraverse #-}
+
+instance FunctorWithIndex Void Proxy where
+ imap _ Proxy = Proxy
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex Void Proxy where
+ ifoldMap _ _ = mempty
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex Void Proxy where
+ itraverse _ _ = pure Proxy
+ {-# INLINE itraverse #-}
+
+instance FunctorWithIndex k ((,) k) where
+ imap f (k,a) = (k, f k a)
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex k ((,) k) where
+ ifoldMap = uncurry'
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex k ((,) k) where
+ itraverse f (k, a) = (,) k <$> f k a
+ {-# INLINE itraverse #-}
+
+-- | The position in the list is available as the index.
+instance FunctorWithIndex Int [] where
+ imap f = go 0 where
+ go !_ [] = []
+ go !n (x:xs) = f n x : go (n + 1) xs
+ {-# INLINE imap #-}
+instance FoldableWithIndex Int [] where
+ ifoldMap = ifoldMapDefault
+ {-# INLINE ifoldMap #-}
+ ifoldr f z = go 0 where
+ go !_ [] = z
+ go !n (x:xs) = f n x (go (n + 1) xs)
+ {-# INLINE ifoldr #-}
+instance TraversableWithIndex Int [] where
+ itraverse f = traverse (uncurry' f) . zip [0..]
+ {-# INLINE itraverse #-}
+
+-- TODO: we could experiment with streaming framework
+-- imapListFB f xs = build (\c n -> ifoldr (\i a -> c (f i a)) n xs)
+
+-- | Same instance as for @[]@.
+instance FunctorWithIndex Int ZipList where
+ imap f (ZipList xs) = ZipList (imap f xs)
+ {-# INLINE imap #-}
+instance FoldableWithIndex Int ZipList where
+ ifoldMap f (ZipList xs) = ifoldMap f xs
+ {-# INLINE ifoldMap #-}
+instance TraversableWithIndex Int ZipList where
+ itraverse f (ZipList xs) = ZipList <$> itraverse f xs
+ {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- (former) semigroups
+-------------------------------------------------------------------------------
+
+instance FunctorWithIndex Int NonEmpty where
+ imap = imapDefault
+ {-# INLINE imap #-}
+instance FoldableWithIndex Int NonEmpty where
+ ifoldMap = ifoldMapDefault
+ {-# INLINE ifoldMap #-}
+instance TraversableWithIndex Int NonEmpty where
+ itraverse f ~(a :| as) =
+ liftA2 (:|) (f 0 a) (traverse (uncurry' f) (zip [1..] as))
+ {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- Functors (formely) from transformers
+-------------------------------------------------------------------------------
+
+instance FunctorWithIndex () Identity where
+ imap f (Identity a) = Identity (f () a)
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex () Identity where
+ ifoldMap f (Identity a) = f () a
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex () Identity where
+ itraverse f (Identity a) = Identity <$> f () a
+ {-# INLINE itraverse #-}
+
+instance FunctorWithIndex Void (Const e) where
+ imap _ (Const a) = Const a
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex Void (Const e) where
+ ifoldMap _ _ = mempty
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex Void (Const e) where
+ itraverse _ (Const a) = pure (Const a)
+ {-# INLINE itraverse #-}
+
+instance FunctorWithIndex Void (Constant e) where
+ imap _ (Constant a) = Constant a
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex Void (Constant e) where
+ ifoldMap _ _ = mempty
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex Void (Constant e) where
+ itraverse _ (Constant a) = pure (Constant a)
+ {-# INLINE itraverse #-}
+
+instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (i, j) (Compose f g) where
+ imap f (Compose fg) = Compose $ imap (\k -> imap (f . (,) k)) fg
+ {-# INLINE imap #-}
+
+instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (i, j) (Compose f g) where
+ ifoldMap f (Compose fg) = ifoldMap (\k -> ifoldMap (f . (,) k)) fg
+ {-# INLINE ifoldMap #-}
+
+instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (i, j) (Compose f g) where
+ itraverse f (Compose fg) = Compose <$> itraverse (\k -> itraverse (f . (,) k)) fg
+ {-# INLINE itraverse #-}
+
+instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (Sum f g) where
+ imap q (InL fa) = InL (imap (q . Left) fa)
+ imap q (InR ga) = InR (imap (q . Right) ga)
+ {-# INLINE imap #-}
+
+instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (Sum f g) where
+ ifoldMap q (InL fa) = ifoldMap (q . Left) fa
+ ifoldMap q (InR ga) = ifoldMap (q . Right) ga
+ {-# INLINE ifoldMap #-}
+
+instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (Sum f g) where
+ itraverse q (InL fa) = InL <$> itraverse (q . Left) fa
+ itraverse q (InR ga) = InR <$> itraverse (q . Right) ga
+ {-# INLINE itraverse #-}
+
+instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (Product f g) where
+ imap f (Pair a b) = Pair (imap (f . Left) a) (imap (f . Right) b)
+ {-# INLINE imap #-}
+
+instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (Product f g) where
+ ifoldMap f (Pair a b) = ifoldMap (f . Left) a `mappend` ifoldMap (f . Right) b
+ {-# INLINE ifoldMap #-}
+
+instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (Product f g) where
+ itraverse f (Pair a b) = liftA2 Pair (itraverse (f . Left) a) (itraverse (f . Right) b)
+ {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- transformers
+-------------------------------------------------------------------------------
+
+instance FunctorWithIndex i m => FunctorWithIndex i (IdentityT m) where
+ imap f (IdentityT m) = IdentityT $ imap f m
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex i m => FoldableWithIndex i (IdentityT m) where
+ ifoldMap f (IdentityT m) = ifoldMap f m
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex i m => TraversableWithIndex i (IdentityT m) where
+ itraverse f (IdentityT m) = IdentityT <$> itraverse f m
+ {-# INLINE itraverse #-}
+
+instance FunctorWithIndex i m => FunctorWithIndex (e, i) (ReaderT e m) where
+ imap f (ReaderT m) = ReaderT $ \k -> imap (f . (,) k) (m k)
+ {-# INLINE imap #-}
+
+instance FunctorWithIndex i f => FunctorWithIndex i (Backwards f) where
+ imap f = Backwards . imap f . forwards
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex i f => FoldableWithIndex i (Backwards f) where
+ ifoldMap f = ifoldMap f . forwards
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex i f => TraversableWithIndex i (Backwards f) where
+ itraverse f = fmap Backwards . itraverse f . forwards
+ {-# INLINE itraverse #-}
+
+instance FunctorWithIndex i f => FunctorWithIndex i (Reverse f) where
+ imap f = Reverse . imap f . getReverse
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex i f => FoldableWithIndex i (Reverse f) where
+ ifoldMap f = getDual #. ifoldMap (Dual #.. f) . getReverse
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex i f => TraversableWithIndex i (Reverse f) where
+ itraverse f = fmap Reverse . forwards . itraverse (Backwards #.. f) . getReverse
+ {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- array
+-------------------------------------------------------------------------------
+
+instance Ix i => FunctorWithIndex i (Array i) where
+ imap f arr = Array.listArray (Array.bounds arr) . fmap (uncurry' f) $ Array.assocs arr
+ {-# INLINE imap #-}
+
+instance Ix i => FoldableWithIndex i (Array i) where
+ ifoldMap f = foldMap (uncurry' f) . Array.assocs
+ {-# INLINE ifoldMap #-}
+
+instance Ix i => TraversableWithIndex i (Array i) where
+ itraverse f arr = Array.listArray (Array.bounds arr) <$> traverse (uncurry' f) (Array.assocs arr)
+ {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- containers
+-------------------------------------------------------------------------------
+
+instance FunctorWithIndex [Int] Tree where
+ imap f (Node a as) = Node (f [] a) $ imap (\i -> imap (f . (:) i)) as
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex [Int] Tree where
+ ifoldMap f (Node a as) = f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex [Int] Tree where
+ itraverse f (Node a as) = liftA2 Node (f [] a) (itraverse (\i -> itraverse (f . (:) i)) as)
+ {-# INLINE itraverse #-}
+--
+-- | The position in the 'Seq' is available as the index.
+instance FunctorWithIndex Int Seq where
+ imap = Seq.mapWithIndex
+ {-# INLINE imap #-}
+instance FoldableWithIndex Int Seq where
+#if MIN_VERSION_containers(0,5,8)
+ ifoldMap = Seq.foldMapWithIndex
+#else
+ ifoldMap f = Data.Foldable.fold . Seq.mapWithIndex f
+#endif
+ {-# INLINE ifoldMap #-}
+ ifoldr = Seq.foldrWithIndex
+ {-# INLINE ifoldr #-}
+ ifoldl f = Seq.foldlWithIndex (flip f)
+ {-# INLINE ifoldl #-}
+instance TraversableWithIndex Int Seq where
+#if MIN_VERSION_containers(0,6,0)
+ itraverse = Seq.traverseWithIndex
+#else
+ -- Much faster than Seq.traverseWithIndex for containers < 0.6.0, see
+ -- https://github.com/haskell/containers/issues/603.
+ itraverse f = sequenceA . Seq.mapWithIndex f
+#endif
+ {-# INLINE itraverse #-}
+
+instance FunctorWithIndex Int IntMap where
+ imap = IntMap.mapWithKey
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex Int IntMap where
+#if MIN_VERSION_containers(0,5,4)
+ ifoldMap = IntMap.foldMapWithKey
+#else
+ ifoldMap = ifoldMapDefault
+#endif
+ {-# INLINE ifoldMap #-}
+#if MIN_VERSION_containers(0,5,0)
+ ifoldr = IntMap.foldrWithKey
+ ifoldl' = IntMap.foldlWithKey' . flip
+ {-# INLINE ifoldr #-}
+ {-# INLINE ifoldl' #-}
+#endif
+
+instance TraversableWithIndex Int IntMap where
+#if MIN_VERSION_containers(0,5,0)
+ itraverse = IntMap.traverseWithKey
+#else
+ itraverse f = sequenceA . IntMap.mapWithKey f
+#endif
+ {-# INLINE itraverse #-}
+
+instance FunctorWithIndex k (Map k) where
+ imap = Map.mapWithKey
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex k (Map k) where
+#if MIN_VERSION_containers(0,5,4)
+ ifoldMap = Map.foldMapWithKey
+#else
+ ifoldMap = ifoldMapDefault
+#endif
+ {-# INLINE ifoldMap #-}
+#if MIN_VERSION_containers(0,5,0)
+ ifoldr = Map.foldrWithKey
+ ifoldl' = Map.foldlWithKey' . flip
+ {-# INLINE ifoldr #-}
+ {-# INLINE ifoldl' #-}
+#endif
+
+instance TraversableWithIndex k (Map k) where
+#if MIN_VERSION_containers(0,5,0)
+ itraverse = Map.traverseWithKey
+#else
+ itraverse f = sequenceA . Map.mapWithKey f
+#endif
+ {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- GHC.Generics
+-------------------------------------------------------------------------------
+
+instance FunctorWithIndex Void V1 where
+ imap _ v = v `seq` error "imap @V1"
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex Void V1 where
+ ifoldMap _ v = v `seq` error "ifoldMap @V1"
+
+instance TraversableWithIndex Void V1 where
+ itraverse _ v = v `seq` error "itraverse @V1"
+
+instance FunctorWithIndex Void U1 where
+ imap _ U1 = U1
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex Void U1 where
+ ifoldMap _ _ = mempty
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex Void U1 where
+ itraverse _ U1 = pure U1
+ {-# INLINE itraverse #-}
+
+instance FunctorWithIndex () Par1 where
+ imap f = fmap (f ())
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex () Par1 where
+ ifoldMap f (Par1 a) = f () a
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex () Par1 where
+ itraverse f (Par1 a) = Par1 <$> f () a
+ {-# INLINE itraverse #-}
+
+instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (i, j) (f :.: g) where
+ imap q (Comp1 fga) = Comp1 (imap (\k -> imap (q . (,) k)) fga)
+ {-# INLINE imap #-}
+
+instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (i, j) (f :.: g) where
+ ifoldMap q (Comp1 fga) = ifoldMap (\k -> ifoldMap (q . (,) k)) fga
+ {-# INLINE ifoldMap #-}
+
+instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (i, j) (f :.: g) where
+ itraverse q (Comp1 fga) = Comp1 <$> itraverse (\k -> itraverse (q . (,) k)) fga
+ {-# INLINE itraverse #-}
+
+instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (f :*: g) where
+ imap q (fa :*: ga) = imap (q . Left) fa :*: imap (q . Right) ga
+ {-# INLINE imap #-}
+
+instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (f :*: g) where
+ ifoldMap q (fa :*: ga) = ifoldMap (q . Left) fa `mappend` ifoldMap (q . Right) ga
+ {-# INLINE ifoldMap #-}
+
+instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (f :*: g) where
+ itraverse q (fa :*: ga) = liftA2 (:*:) (itraverse (q . Left) fa) (itraverse (q . Right) ga)
+ {-# INLINE itraverse #-}
+
+instance (FunctorWithIndex i f, FunctorWithIndex j g) => FunctorWithIndex (Either i j) (f :+: g) where
+ imap q (L1 fa) = L1 (imap (q . Left) fa)
+ imap q (R1 ga) = R1 (imap (q . Right) ga)
+ {-# INLINE imap #-}
+
+instance (FoldableWithIndex i f, FoldableWithIndex j g) => FoldableWithIndex (Either i j) (f :+: g) where
+ ifoldMap q (L1 fa) = ifoldMap (q . Left) fa
+ ifoldMap q (R1 ga) = ifoldMap (q . Right) ga
+ {-# INLINE ifoldMap #-}
+
+instance (TraversableWithIndex i f, TraversableWithIndex j g) => TraversableWithIndex (Either i j) (f :+: g) where
+ itraverse q (L1 fa) = L1 <$> itraverse (q . Left) fa
+ itraverse q (R1 ga) = R1 <$> itraverse (q . Right) ga
+ {-# INLINE itraverse #-}
+
+instance FunctorWithIndex i f => FunctorWithIndex i (Rec1 f) where
+ imap q (Rec1 f) = Rec1 (imap q f)
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex i f => FoldableWithIndex i (Rec1 f) where
+ ifoldMap q (Rec1 f) = ifoldMap q f
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex i f => TraversableWithIndex i (Rec1 f) where
+ itraverse q (Rec1 f) = Rec1 <$> itraverse q f
+ {-# INLINE itraverse #-}
+
+instance FunctorWithIndex Void (K1 i c) where
+ imap _ (K1 c) = K1 c
+ {-# INLINE imap #-}
+
+instance FoldableWithIndex Void (K1 i c) where
+ ifoldMap _ _ = mempty
+ {-# INLINE ifoldMap #-}
+
+instance TraversableWithIndex Void (K1 i c) where
+ itraverse _ (K1 a) = pure (K1 a)
+ {-# INLINE itraverse #-}
+
+-------------------------------------------------------------------------------
+-- Misc.
+-------------------------------------------------------------------------------
+
+#if __GLASGOW_HASKELL__ >=708
+(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)
+_ #. x = coerce x
+
+(#..) :: Coercible b c => (b -> c) -> (i -> a -> b) -> (i -> a -> c)
+_ #.. x = coerce x
+#else
+(#.) :: (b -> c) -> (a -> b) -> (a -> c)
+_ #. x = unsafeCoerce x
+
+(#..) :: (b -> c) -> (i -> a -> b) -> (i -> a -> c)
+_ #.. x = unsafeCoerce x
+#endif
+infixr 9 #., #..
+{-# INLINE (#.) #-}
+{-# INLINE (#..)#-}
+
+skip :: a -> ()
+skip _ = ()
+{-# INLINE skip #-}
+
+------------------------------------------------------------------------------
+-- Traversed
+------------------------------------------------------------------------------
+
+-- | Used internally by 'Control.Lens.Traversal.traverseOf_' and the like.
+--
+-- The argument 'a' of the result should not be used!
+newtype Traversed a f = Traversed { getTraversed :: f a }
+
+-- See 4.16 Changelog entry for the explanation of "why not Apply f =>"?
+instance Applicative f => Semigroup (Traversed a f) where
+ Traversed ma <> Traversed mb = Traversed (ma *> mb)
+ {-# INLINE (<>) #-}
+
+instance Applicative f => Monoid (Traversed a f) where
+ mempty = Traversed (pure (error "Traversed: value used"))
+ {-# INLINE mempty #-}
+
+------------------------------------------------------------------------------
+-- Sequenced
+------------------------------------------------------------------------------
+
+-- | Used internally by 'Control.Lens.Traversal.mapM_' and the like.
+--
+-- The argument 'a' of the result should not be used!
+--
+-- See 4.16 Changelog entry for the explanation of "why not Apply f =>"?
+newtype Sequenced a m = Sequenced { getSequenced :: m a }
+
+instance Monad m => Semigroup (Sequenced a m) where
+ Sequenced ma <> Sequenced mb = Sequenced (ma >> mb)
+ {-# INLINE (<>) #-}
+
+instance Monad m => Monoid (Sequenced a m) where
+ mempty = Sequenced (return (error "Sequenced: value used"))
+ {-# INLINE mempty #-}
+
+------------------------------------------------------------------------------
+-- Indexing
+------------------------------------------------------------------------------
+
+-- | 'Applicative' composition of @'Control.Monad.Trans.State.Lazy.State' 'Int'@ with a 'Functor', used
+-- by 'Control.Lens.Indexed.indexed'.
+newtype Indexing f a = Indexing { runIndexing :: Int -> (Int, f a) }
+
+instance Functor f => Functor (Indexing f) where
+ fmap f (Indexing m) = Indexing $ \i -> case m i of
+ (j, x) -> (j, fmap f x)
+ {-# INLINE fmap #-}
+
+instance Applicative f => Applicative (Indexing f) where
+ pure x = Indexing $ \i -> (i, pure x)
+ {-# INLINE pure #-}
+ Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of
+ (j, ff) -> case ma j of
+ ~(k, fa) -> (k, ff <*> fa)
+ {-# INLINE (<*>) #-}
+#if __GLASGOW_HASKELL__ >=821
+ liftA2 f (Indexing ma) (Indexing mb) = Indexing $ \ i -> case ma i of
+ (j, ja) -> case mb j of
+ ~(k, kb) -> (k, liftA2 f ja kb)
+ {-# INLINE liftA2 #-}
+#endif
+
+-------------------------------------------------------------------------------
+-- Strict curry
+-------------------------------------------------------------------------------
+
+uncurry' :: (a -> b -> c) -> (a, b) -> c
+uncurry' f (a, b) = f a b
+{-# INLINE uncurry' #-}
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -436,4 +436,5 @@ test('T21851', [grep_errmsg(r'case.*w\$sf') ], multimod_compile, ['T21851', '-O
test('T22097', [grep_errmsg(r'case.*wgoEven') ], multimod_compile, ['T22097', '-O -dno-typeable-binds -dsuppress-uniques'])
test('T13873', [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules'])
+test('T22357', normal, compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c06a478782db9175b3588f352721e0e8fb6ed57c...5fc9e728b7d890193b852d1027f92ab1d16913d2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c06a478782db9175b3588f352721e0e8fb6ed57c...5fc9e728b7d890193b852d1027f92ab1d16913d2
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/20221027/1456fb87/attachment-0001.html>
More information about the ghc-commits
mailing list