[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Remove source location information from interface files
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Oct 27 15:14:15 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
b31e0629 by Owen Shepherd at 2022-10-27T11:13:48-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.
- - - - -
0d135f60 by Simon Peyton Jones at 2022-10-27T11:13:49-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
- - - - -
cd8a939a by Evan Relf at 2022-10-27T11:13:49-04:00
Fix broken link to `async` package
- - - - -
13 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/Unit/Module/Warnings.hs
- compiler/GHC/Utils/Binary.hs
- libraries/base/GHC/Conc/Sync.hs
- + 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/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
=====================================
libraries/base/GHC/Conc/Sync.hs
=====================================
@@ -273,7 +273,7 @@ exception handler.
WARNING: Exceptions in the new thread will not be rethrown in the thread that
created it. This means that you might be completely unaware of the problem
if/when this happens. You may want to use the
-<hackage.haskell.org/package/async async> library instead.
+<https://hackage.haskell.org/package/async async> library instead.
-}
forkIO :: IO () -> IO ThreadId
forkIO action = IO $ \ s ->
=====================================
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/5fc9e728b7d890193b852d1027f92ab1d16913d2...cd8a939a8e3324c98ef2731283cc1f8e691055ac
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5fc9e728b7d890193b852d1027f92ab1d16913d2...cd8a939a8e3324c98ef2731283cc1f8e691055ac
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/318042e1/attachment-0001.html>
More information about the ghc-commits
mailing list