mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-12-04 07:46:37 +03:00
6ffb4fd282
This thing was a vestige of the bad old days when you had to write *instances* of classes things in Polysemy. It was a terrible experience, and so we don't do that anymore. As a result, the only two instances of `Effect` were for `Union` and `Yo` --- so I just inlined them.
78 lines
1.9 KiB
Haskell
78 lines
1.9 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# OPTIONS_GHC -O2 #-}
|
|
|
|
|
|
module InlineRecursiveCallsSpec
|
|
( spec
|
|
) where
|
|
|
|
import qualified Control.Monad.Trans.State as S
|
|
import Data.Tuple
|
|
import Polysemy.Internal
|
|
import Polysemy.Internal.Union
|
|
import Test.Hspec
|
|
import Test.Inspection
|
|
|
|
|
|
spec :: Spec
|
|
spec = describe "inlining recursive calls" $ do
|
|
it "should explicitly break recursion" $ do
|
|
shouldSucceed $(inspectTest $ 'recursive === 'mutual)
|
|
|
|
|
|
isSuccess :: Result -> Bool
|
|
isSuccess (Success _) = True
|
|
isSuccess (Failure e) = error e
|
|
|
|
|
|
shouldSucceed :: Result -> Expectation
|
|
shouldSucceed r = r `shouldSatisfy` isSuccess
|
|
|
|
|
|
------------------------------------------------------------------------------
|
|
recursive
|
|
:: (∀ x m. e m x -> S.StateT s (Sem r) x)
|
|
-> s
|
|
-> Sem (e ': r) a
|
|
-> Sem r (s, a)
|
|
recursive f s (Sem m) = Sem $ \k ->
|
|
fmap swap $ flip S.runStateT s $ m $ \u ->
|
|
case decomp u of
|
|
Left x -> S.StateT $ \s' ->
|
|
k . fmap swap
|
|
. weave (s', ())
|
|
(uncurry $ recursive f)
|
|
(Just . snd)
|
|
$ x
|
|
Right (Yo e z _ y _) ->
|
|
fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e
|
|
|
|
|
|
------------------------------------------------------------------------------
|
|
mutual
|
|
:: (∀ x m. e m x -> S.StateT s (Sem r) x)
|
|
-> s
|
|
-> Sem (e ': r) a
|
|
-> Sem r (s, a)
|
|
mutual f s (Sem m) = Sem $ \k ->
|
|
fmap swap $ flip S.runStateT s $ m $ \u ->
|
|
case decomp u of
|
|
Left x -> S.StateT $ \s' ->
|
|
k . fmap swap
|
|
. weave (s', ())
|
|
(uncurry $ mutual2 f)
|
|
(Just . snd)
|
|
$ x
|
|
Right (Yo e z _ y _) ->
|
|
fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e
|
|
{-# INLINE mutual #-}
|
|
|
|
mutual2
|
|
:: (∀ x m. e m x -> S.StateT s (Sem r) x)
|
|
-> s
|
|
-> Sem (e ': r) a
|
|
-> Sem r (s, a)
|
|
mutual2 = mutual
|
|
{-# NOINLINE mutual2 #-}
|
|
|