-- | Utilities related to Monad and Applicative classes -- Mostly for backwards compatibility. module GHC.Utils.Monad ( Applicative(..) , (<$>) , MonadFix(..) , MonadIO(..) , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M , mapAccumLM , liftFstM, liftSndM , mapSndM , concatMapM , mapMaybeM , fmapMaybeM, fmapEitherM , anyM, allM, orM , foldlM, foldlM_, foldrM , maybeMapM , whenM, unlessM , filterOutM ) where ------------------------------------------------------------------------------- -- Imports ------------------------------------------------------------------------------- import GHC.Prelude import Control.Applicative import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class import Data.Foldable (sequenceA_, foldlM, foldrM) import Data.List (unzip4, unzip5, zipWith4) ------------------------------------------------------------------------------- -- Common functions -- These are used throughout the compiler ------------------------------------------------------------------------------- {- Note [Inline @zipWithNM@ functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The inline principle for 'zipWith3M', 'zipWith4M' and 'zipWith3M_' is the same as for 'zipWithM' and 'zipWithM_' in "Control.Monad", see Note [Fusion for zipN/zipWithN] in GHC/List.hs for more details. The 'zipWithM'/'zipWithM_' functions are inlined so that the `zipWith` and `sequenceA` functions with which they are defined have an opportunity to fuse. Furthermore, 'zipWith3M'/'zipWith4M' and 'zipWith3M_' have been explicitly rewritten in a non-recursive way similarly to 'zipWithM'/'zipWithM_', and for more than just uniformity: after [D5241](https://phabricator.haskell.org/D5241) for issue #14037, all @zipN@/@zipWithN@ functions fuse, meaning 'zipWith3M'/'zipWIth4M' and 'zipWith3M_'@ now behave like 'zipWithM' and 'zipWithM_', respectively, with regards to fusion. As such, since there are not any differences between 2-ary 'zipWithM'/ 'zipWithM_' and their n-ary counterparts below aside from the number of arguments, the `INLINE` pragma should be replicated in the @zipWithNM@ functions below as well. -} zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] {-# INLINE zipWith3M #-} -- Inline so that fusion with 'zipWith3' and 'sequenceA' has a chance to fire. -- See Note [Inline @zipWithNM@ functions] above. zipWith3M :: forall (m :: * -> *) a b c d. Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] zipWith3M a -> b -> c -> m d f [a] xs [b] ys [c] zs = forall (t :: * -> *) (f :: * -> *) a. (Traversable t, Applicative f) => t (f a) -> f (t a) sequenceA (forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3 a -> b -> c -> m d f [a] xs [b] ys [c] zs) zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m () {-# INLINE zipWith3M_ #-} -- Inline so that fusion with 'zipWith4' and 'sequenceA' has a chance to fire. -- See Note [Inline @zipWithNM@ functions] above. zipWith3M_ :: forall (m :: * -> *) a b c d. Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m () zipWith3M_ a -> b -> c -> m d f [a] xs [b] ys [c] zs = forall (t :: * -> *) (f :: * -> *) a. (Foldable t, Applicative f) => t (f a) -> f () sequenceA_ (forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] zipWith3 a -> b -> c -> m d f [a] xs [b] ys [c] zs) zipWith4M :: Monad m => (a -> b -> c -> d -> m e) -> [a] -> [b] -> [c] -> [d] -> m [e] {-# INLINE zipWith4M #-} -- Inline so that fusion with 'zipWith5' and 'sequenceA' has a chance to fire. -- See Note [Inline @zipWithNM@ functions] above. zipWith4M :: forall (m :: * -> *) a b c d e. Monad m => (a -> b -> c -> d -> m e) -> [a] -> [b] -> [c] -> [d] -> m [e] zipWith4M a -> b -> c -> d -> m e f [a] xs [b] ys [c] ws [d] zs = forall (t :: * -> *) (f :: * -> *) a. (Traversable t, Applicative f) => t (f a) -> f (t a) sequenceA (forall a b c d e. (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] zipWith4 a -> b -> c -> d -> m e f [a] xs [b] ys [c] ws [d] zs) zipWithAndUnzipM :: Monad m => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) {-# INLINABLE zipWithAndUnzipM #-} -- this allows specialization to a given monad zipWithAndUnzipM :: forall (m :: * -> *) a b c d. Monad m => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) zipWithAndUnzipM a -> b -> m (c, d) f (a x:[a] xs) (b y:[b] ys) = do { (c c, d d) <- a -> b -> m (c, d) f a x b y ; ([c] cs, [d] ds) <- forall (m :: * -> *) a b c d. Monad m => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) zipWithAndUnzipM a -> b -> m (c, d) f [a] xs [b] ys ; forall (m :: * -> *) a. Monad m => a -> m a return (c cforall a. a -> [a] -> [a] :[c] cs, d dforall a. a -> [a] -> [a] :[d] ds) } zipWithAndUnzipM a -> b -> m (c, d) _ [a] _ [b] _ = forall (m :: * -> *) a. Monad m => a -> m a return ([], []) {- Note [Inline @mapAndUnzipNM@ functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The inline principle is the same as 'mapAndUnzipM' in "Control.Monad". The 'mapAndUnzipM' function is inlined so that the `unzip` and `traverse` functions with which it is defined have an opportunity to fuse, see Note [Inline @unzipN@ functions] in Data/OldList.hs for more details. Furthermore, the @mapAndUnzipNM@ functions have been explicitly rewritten in a non-recursive way similarly to 'mapAndUnzipM', and for more than just uniformity: after [D5249](https://phabricator.haskell.org/D5249) for Trac ticket #14037, all @unzipN@ functions fuse, meaning 'mapAndUnzip3M', 'mapAndUnzip4M' and 'mapAndUnzip5M' now behave like 'mapAndUnzipM' with regards to fusion. As such, since there are not any differences between 2-ary 'mapAndUnzipM' and its n-ary counterparts below aside from the number of arguments, the `INLINE` pragma should be replicated in the @mapAndUnzipNM@ functions below as well. -} -- | mapAndUnzipM for triples mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) {-# INLINE mapAndUnzip3M #-} -- Inline so that fusion with 'unzip3' and 'traverse' has a chance to fire. -- See Note [Inline @mapAndUnzipNM@ functions] above. mapAndUnzip3M :: forall (m :: * -> *) a b c d. Monad m => (a -> m (b, c, d)) -> [a] -> m ([b], [c], [d]) mapAndUnzip3M a -> m (b, c, d) f [a] xs = forall a b c. [(a, b, c)] -> ([a], [b], [c]) unzip3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse a -> m (b, c, d) f [a] xs mapAndUnzip4M :: Monad m => (a -> m (b,c,d,e)) -> [a] -> m ([b],[c],[d],[e]) {-# INLINE mapAndUnzip4M #-} -- Inline so that fusion with 'unzip4' and 'traverse' has a chance to fire. -- See Note [Inline @mapAndUnzipNM@ functions] above. mapAndUnzip4M :: forall (m :: * -> *) a b c d e. Monad m => (a -> m (b, c, d, e)) -> [a] -> m ([b], [c], [d], [e]) mapAndUnzip4M a -> m (b, c, d, e) f [a] xs = forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d]) unzip4 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse a -> m (b, c, d, e) f [a] xs mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f]) {-# INLINE mapAndUnzip5M #-} -- Inline so that fusion with 'unzip5' and 'traverse' has a chance to fire. -- See Note [Inline @mapAndUnzipNM@ functions] above. mapAndUnzip5M :: forall (m :: * -> *) a b c d e f. Monad m => (a -> m (b, c, d, e, f)) -> [a] -> m ([b], [c], [d], [e], [f]) mapAndUnzip5M a -> m (b, c, d, e, f) f [a] xs = forall a b c d e. [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e]) unzip5 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse a -> m (b, c, d, e, f) f [a] xs -- TODO: mapAccumLM is used in many places. Surely most of -- these don't actually want to be lazy. We should add a strict -- variant and use it where appropriate. -- | Monadic version of mapAccumL mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -- ^ combining function -> acc -- ^ initial state -> [x] -- ^ inputs -> m (acc, [y]) -- ^ final state, outputs mapAccumLM :: forall (m :: * -> *) acc x y. Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y]) mapAccumLM acc -> x -> m (acc, y) f acc s [x] xs = acc -> [x] -> m (acc, [y]) go acc s [x] xs where go :: acc -> [x] -> m (acc, [y]) go acc s (x x:[x] xs) = do (acc s1, y x') <- acc -> x -> m (acc, y) f acc s x x (acc s2, [y] xs') <- acc -> [x] -> m (acc, [y]) go acc s1 [x] xs forall (m :: * -> *) a. Monad m => a -> m a return (acc s2, y x' forall a. a -> [a] -> [a] : [y] xs') go acc s [] = forall (m :: * -> *) a. Monad m => a -> m a return (acc s, []) -- | Monadic version of mapSnd mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] mapSndM :: forall (m :: * -> *) b c a. Monad m => (b -> m c) -> [(a, b)] -> m [(a, c)] mapSndM b -> m c f [(a, b)] xs = [(a, b)] -> m [(a, c)] go [(a, b)] xs where go :: [(a, b)] -> m [(a, c)] go [] = forall (m :: * -> *) a. Monad m => a -> m a return [] go ((a a,b b):[(a, b)] xs) = do { c c <- b -> m c f b b; [(a, c)] rs <- [(a, b)] -> m [(a, c)] go [(a, b)] xs; forall (m :: * -> *) a. Monad m => a -> m a return ((a a,c c)forall a. a -> [a] -> [a] :[(a, c)] rs) } liftFstM :: Monad m => (a -> b) -> m (a, r) -> m (b, r) liftFstM :: forall (m :: * -> *) a b r. Monad m => (a -> b) -> m (a, r) -> m (b, r) liftFstM a -> b f m (a, r) thing = do { (a a,r r) <- m (a, r) thing; forall (m :: * -> *) a. Monad m => a -> m a return (a -> b f a a, r r) } liftSndM :: Monad m => (a -> b) -> m (r, a) -> m (r, b) liftSndM :: forall (m :: * -> *) a b r. Monad m => (a -> b) -> m (r, a) -> m (r, b) liftSndM a -> b f m (r, a) thing = do { (r r,a a) <- m (r, a) thing; forall (m :: * -> *) a. Monad m => a -> m a return (r r, a -> b f a a) } -- | Monadic version of concatMap concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM :: forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM a -> m [b] f [a] xs = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat (forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM a -> m [b] f [a] xs) -- | Applicative version of mapMaybe mapMaybeM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM :: forall (m :: * -> *) a b. Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM a -> m (Maybe b) f = forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr a -> m [b] -> m [b] g (forall (f :: * -> *) a. Applicative f => a -> f a pure []) where g :: a -> m [b] -> m [b] g a a = forall (f :: * -> *) a b c. Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 (forall b a. b -> (a -> b) -> Maybe a -> b maybe forall a. a -> a id (:)) (a -> m (Maybe b) f a a) -- | Monadic version of fmap fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b) fmapMaybeM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m (Maybe b) fmapMaybeM a -> m b _ Maybe a Nothing = forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing fmapMaybeM a -> m b f (Just a x) = a -> m b f a x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. a -> Maybe a Just) -- | Monadic version of fmap fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) fmapEitherM :: forall (m :: * -> *) a b c d. Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) fmapEitherM a -> m b fl c -> m d _ (Left a a) = a -> m b fl a a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. a -> Either a b Left) fmapEitherM a -> m b _ c -> m d fr (Right c b) = c -> m d fr c b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. b -> Either a b Right) -- | Monadic version of 'any', aborts the computation at the first @True@ value anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool anyM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool anyM a -> m Bool f [a] xs = [a] -> m Bool go [a] xs where go :: [a] -> m Bool go [] = forall (m :: * -> *) a. Monad m => a -> m a return Bool False go (a x:[a] xs) = do Bool b <- a -> m Bool f a x if Bool b then forall (m :: * -> *) a. Monad m => a -> m a return Bool True else [a] -> m Bool go [a] xs -- | Monad version of 'all', aborts the computation at the first @False@ value allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool allM a -> m Bool f [a] bs = [a] -> m Bool go [a] bs where go :: [a] -> m Bool go [] = forall (m :: * -> *) a. Monad m => a -> m a return Bool True go (a b:[a] bs) = (a -> m Bool f a b) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (\Bool bv -> if Bool bv then [a] -> m Bool go [a] bs else forall (m :: * -> *) a. Monad m => a -> m a return Bool False) -- | Monadic version of or orM :: Monad m => m Bool -> m Bool -> m Bool orM :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool orM m Bool m1 m Bool m2 = m Bool m1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \Bool x -> if Bool x then forall (m :: * -> *) a. Monad m => a -> m a return Bool True else m Bool m2 -- | Monadic version of foldl that discards its result foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () foldlM_ :: forall (m :: * -> *) (t :: * -> *) a b. (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () foldlM_ = forall (t :: * -> *) (m :: * -> *) b a. (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m () foldM_ -- | Monadic version of fmap specialised for Maybe maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) maybeMapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m (Maybe b) maybeMapM a -> m b _ Maybe a Nothing = forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing maybeMapM a -> m b m (Just a x) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r liftM forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ a -> m b m a x -- | Monadic version of @when@, taking the condition in the monad whenM :: Monad m => m Bool -> m () -> m () whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m () whenM m Bool mb m () thing = do { Bool b <- m Bool mb ; forall (f :: * -> *). Applicative f => Bool -> f () -> f () when Bool b m () thing } -- | Monadic version of @unless@, taking the condition in the monad unlessM :: Monad m => m Bool -> m () -> m () unlessM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m () unlessM m Bool condM m () acc = do { Bool cond <- m Bool condM ; forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool cond m () acc } -- | Like 'filterM', only it reverses the sense of the test. filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] filterOutM :: forall (m :: * -> *) a. Applicative m => (a -> m Bool) -> [a] -> m [a] filterOutM a -> m Bool p = forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (\ a x -> forall (f :: * -> *) a b c. Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 (\ Bool flg -> if Bool flg then forall a. a -> a id else (a xforall a. a -> [a] -> [a] :)) (a -> m Bool p a x)) (forall (f :: * -> *) a. Applicative f => a -> f a pure []) {- Note [The one-shot state monad trick] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Summary: many places in GHC use a state monad, and we really want those functions to be eta-expanded (#18202). The problem ~~~~~~~~~~~ Consider newtype M a = MkM (State -> (State, a)) instance Monad M where mf >>= k = MkM (\s -> case mf of MkM f -> case f s of (s',r) -> case k r of MkM g -> g s') fooM :: Int -> M Int fooM x = g y >>= \r -> h r where y = expensive x Now suppose you say (repeat 20 (fooM 4)), where repeat :: Int -> M Int -> M Int performs its argument n times. You would expect (expensive 4) to be evaluated only once, not 20 times. So foo should have arity 1 (not 2); it should look like this (modulo casts) fooM x = let y = expensive x in \s -> case g y of ... But creating and then repeating, a monadic computation is rare. If you /aren't/ re-using (M a) value, it's /much/ more efficient to make foo have arity 2, thus: fooM x s = case g (expensive x) of ... Why more efficient? Because now foo takes its argument both at once, rather than one at a time, creating a heap-allocated function closure. See https://www.joachim-breitner.de/blog/763-Faster_Winter_5__Eta-Expanding_ReaderT for a very good explanation of the issue which led to these optimisations into GHC. The trick ~~~~~~~~~ With state monads like M the general case is that we *aren't* reusing (M a) values so it is much more efficient to avoid allocating a function closure for them. So the state monad trick is a way to keep the monadic syntax but to make GHC eta-expand functions like `fooM`. To do that we use the "oneShot" magic function. Here is the trick: * Define a "smart constructor" mkM :: (State -> (State,a)) -> M a mkM f = MkM (oneShot m) * Never call MkM directly, as a constructor. Instead, always call mkM. And that's it! The magic 'oneShot' function does this transformation: oneShot (\s. e) ==> \s{os}. e which pins a one-shot flag {os} onto the binder 's'. That tells GHC that it can assume the lambda is called only once, and thus can freely float computations in and out of the lambda. To be concrete, let's see what happens to fooM: fooM = \x. g (expensive x) >>= \r -> h r = \x. let mf = g (expensive x) k = \r -> h r in MkM (oneShot (\s -> case mf of MkM' f -> case f s of (s',r) -> case k r of MkM' g -> g s')) -- The MkM' are just newtype casts nt_co = \x. let mf = g (expensive x) k = \r -> h r in (\s{os}. case (mf |> nt_co) s of (s',r) -> (k r) |> nt_co s') |> sym nt_co -- Crucial step: float let-bindings into that \s{os} = \x. (\s{os}. case (g (expensive x) |> nt_co) s of (s',r) -> h r |> nt_co s') |> sym nt_co and voila! fooM has arity 2. The trick is very similar to the built-in "state hack" (see Note [The state-transformer hack] in "GHC.Core.Opt.Arity") but is applicable on a monad-by-monad basis under programmer control. Using pattern synonyms ~~~~~~~~~~~~~~~~~~~~~~ Using a smart constructor is fine, but there is no way to check that we have found *all* uses, especially if the uses escape a single module. A neat (but more sophisticated) alternative is to use pattern synonyms: -- We rename the existing constructor. newtype M a = MkM' (State -> (State, a)) -- The pattern has the old constructor name. pattern MkM f <- MkM' f where MkM f = MkM' (oneShot f) Now we can simply grep to check that there are no uses of MkM' /anywhere/, to guarantee that we have not missed any. (Using the smart constructor alone we still need the data constructor in patterns.) That's the advantage of the pattern-synonym approach, but it is more elaborate. The pattern synonym approach is due to Sebastian Graaf (#18238) Do note that for monads for multiple arguments more than one oneShot function might be required. For example in FCode we use: newtype FCode a = FCode' { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) } pattern FCode :: (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a pattern FCode m <- FCode' m where FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state)) Derived instances ~~~~~~~~~~~~~~~~~ One caveat of both approaches is that derived instances don't use the smart constructor /or/ the pattern synonym. So they won't benefit from the automatic insertion of "oneShot". data M a = MkM' (State -> (State,a)) deriving (Functor) <-- Functor implementation will use MkM'! Conclusion: don't use 'derviving' in these cases. Multi-shot actions (cf #18238) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sometimes we really *do* want computations to be shared! Remember our example (repeat 20 (fooM 4)). See Note [multiShotIO] in GHC.Types.Unique.Supply We can force fooM to have arity 1 using multiShot: fooM :: Int -> M Int fooM x = multiShotM (g y >>= \r -> h r) where y = expensive x multiShotM :: M a -> M a {-# INLINE multiShotM #-} multiShotM (MkM m) = MkM (\s -> inline m s) -- Really uses the data constructor, -- not the smart constructor! Now we can see how fooM optimises (ignoring casts) multiShotM (g y >>= \r -> h r) ==> {inline (>>=)} multiShotM (\s{os}. case g y s of ...) ==> {inline multiShotM} let m = \s{os}. case g y s of ... in \s. inline m s ==> {inline m} \s. (\s{os}. case g y s of ...) s ==> \s. case g y s of ... and voila! the one-shot flag has gone. It's possible that y has been replaced by (expensive x), but full laziness should pull it back out. (This part seems less robust.) The magic `inline` function does two things * It prevents eta reduction. If we wrote just multiShotIO (IO m) = IO (\s -> m s) the lamda would eta-reduce to 'm' and all would be lost. * It helps ensure that 'm' really does inline. Note that 'inline' evaporates in phase 0. See Note [inlineIdMagic] in GHC.Core.Opt.ConstantFold.match_inline. The INLINE pragma on multiShotM is very important, else the 'inline' call will evaporate when compiling the module that defines 'multiShotM', before it is ever exported. -}