bd5c1c9 · typeable/ether

ether.cabal+1−1

compare with master

unifiedsplit

@@ -23,7 +23,7 @@ source-repository head

23

24library

25

26− exposed-modules: Control.Ether.Core

26+ exposed-modules: Control.Ether.Tags

27 Control.Ether.TH

28 Control.Ether.Wrapped

29 Control.Monad.Trans.Ether.Reader

src/Control/Ether/Core.hs → src/Control/Ether/Tags.hsrenamed+1−1

@@ -4,7 +4,7 @@

4{-# LANGUAGE ConstraintKinds #-}

5{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE UndecidableInstances #-}

7−module Control.Ether.Core

7+module Control.Ether.Tags

8 ( Tags

9 , UniqueTag

10 , UniqueTags

src/Control/Ether/Wrapped.hs+6

@@ -12,8 +12,10 @@ import Control.Monad (MonadPlus)

12import Control.Monad.Fix (MonadFix)

13import Control.Monad.IO.Class (MonadIO)

14import Control.Monad.Ether.Reader

15+import Control.Monad.Ether.State

15

16

16import qualified Control.Monad.Reader as Class

17import qualified Control.Monad.Reader as Class

18+import qualified Control.Monad.State as Class

17

19

18newtype WrappedEther tag m a = WrapEther { unwrapEther :: m a }

20newtype WrappedEther tag m a = WrapEther { unwrapEther :: m a }

19 deriving ( Functor, Applicative, Alternative, Monad, MonadPlus

21 deriving ( Functor, Applicative, Alternative, Monad, MonadPlus

@@ -23,5 +25,9 @@ instance MonadReader tag r m => Class.MonadReader r (WrappedEther tag m) where

23 ask = WrapEther $ ask (Proxy :: Proxy tag)

25 ask = WrapEther $ ask (Proxy :: Proxy tag)

24 local f = WrapEther . local (Proxy :: Proxy tag) f . unwrapEther

26 local f = WrapEther . local (Proxy :: Proxy tag) f . unwrapEther

25

27

28+instance MonadState tag s m => Class.MonadState s (WrappedEther tag m) where

29+ get = WrapEther $ get (Proxy :: Proxy tag)

30+ put = WrapEther . put (Proxy :: Proxy tag)

31+

26ethered :: proxy tag -> WrappedEther tag m a -> m a

32ethered :: proxy tag -> WrappedEther tag m a -> m a

27ethered _proxy = unwrapEther

33ethered _proxy = unwrapEther

src/Control/Monad/Ether/Reader.hs+10−10

@@ -11,16 +11,16 @@

11{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE GeneralizedNewtypeDeriving #-}

13module Control.Monad.Ether.Reader

14− ( ReaderT

14+ (

15+ -- * MonadReader class

16+ MonadReader(..)

17+ , asks

18+ -- * The Reader monad

15 , Reader

19 , Reader

16− , runReaderT

17 , runReader

20 , runReader

18− --

21+ -- * The ReaderT monad transformer

19− , MonadReader

22+ , ReaderT

20− , local

23+ , runReaderT

21− , ask

22− , reader

23− , asks

24 ) where

25

26import Data.Proxy (Proxy(Proxy))

@@ -76,8 +76,8 @@ asks

76asks = reader

77

78instance {-# OVERLAPPING #-} Monad m => MonadReader tag r (ReaderT tag r m) where

79− ask proxy = etherReaderT proxy return

79+ ask proxy = readerT proxy return

80− local proxy f m = etherReaderT proxy (runReaderT proxy m . f)

80+ local proxy f m = readerT proxy (runReaderT proxy m . f)

81

82instance (MonadReader tag r m) => MonadReader tag r (ReaderT tag' r' m) where

83 ask proxy = lift (ask proxy)

src/Control/Monad/Ether/State.hs+2−2

@@ -69,8 +69,8 @@ modify :: MonadState tag s m => proxy tag -> (s -> s) -> m ()

69modify proxy f = state proxy $ \ s -> ((), f s)

70

71instance {-# OVERLAPPING #-} Monad m => MonadState tag s (StateT tag s m) where

72− get proxy = etherStateT proxy (\s -> return (s, s))

72+ get proxy = stateT proxy (\s -> return (s, s))

73− put proxy s = etherStateT proxy (\_ -> return ((), s))

73+ put proxy s = stateT proxy (\_ -> return ((), s))

74

75instance (MonadState tag s m) => MonadState tag s (StateT tag' s' m) where

76 get proxy = lift (get proxy)

src/Control/Monad/Trans/Ether/Reader.hs+32−9

@@ -7,12 +7,16 @@

7{-# LANGUAGE TypeOperators #-}

8{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9module Control.Monad.Trans.Ether.Reader

10− ( ReaderT

10+ (

11− , Reader

11+ -- * The Reader monad

12− , runReaderT

12+ Reader

13 , runReader

14− , etherReaderT

14+ -- * The ReaderT monad transformer

15+ , ReaderT

16+ , readerT

17+ , runReaderT

15 , mapReaderT

18 , mapReaderT

19+ -- * Lifting other operations

16 , liftCatch

20 , liftCatch

17 , liftCallCC

21 , liftCallCC

18 ) where

22 ) where

@@ -25,7 +29,7 @@ import Control.Monad (MonadPlus)

25import Control.Monad.Fix (MonadFix)

29import Control.Monad.Fix (MonadFix)

26import Control.Monad.Trans.Class (MonadTrans, lift)

30import Control.Monad.Trans.Class (MonadTrans, lift)

27import Control.Monad.IO.Class (MonadIO)

31import Control.Monad.IO.Class (MonadIO)

28−import Control.Ether.Core

32+import Control.Ether.Tags (Tags)

29

33

30import qualified Control.Monad.Signatures as Sig

34import qualified Control.Monad.Signatures as Sig

31import qualified Control.Monad.Trans.Reader as Trans

35import qualified Control.Monad.Trans.Reader as Trans

@@ -36,29 +40,48 @@ import qualified Control.Monad.State.Class as Class

36import qualified Control.Monad.Writer.Class as Class

40import qualified Control.Monad.Writer.Class as Class

37import qualified Control.Monad.Error.Class as Class

41import qualified Control.Monad.Error.Class as Class

38

42

43+-- | The parameterizable reader monad.

44+--

45+-- Computations are functions of a shared environment.

46+--

47+-- The 'return' function ignores the environment, while '>>=' passes

48+-- the inherited environment to both subcomputations.

49+type Reader tag r = ReaderT tag r Identity

50+

51+-- | The reader monad transformer,

52+-- which adds a read-only environment to the given monad.

53+--

54+-- The 'return' function ignores the environment, while '>>=' passes

55+-- the inherited environment to both subcomputations.

39newtype ReaderT tag r m a = ReaderT (Trans.ReaderT r m a)

56newtype ReaderT tag r m a = ReaderT (Trans.ReaderT r m a)

40 deriving ( Functor, Applicative, Alternative, Monad, MonadPlus

57 deriving ( Functor, Applicative, Alternative, Monad, MonadPlus

41 , MonadFix, MonadTrans, MonadIO )

58 , MonadFix, MonadTrans, MonadIO )

42

59

43type instance Tags (ReaderT tag r m) = tag ': Tags m

60type instance Tags (ReaderT tag r m) = tag ': Tags m

44

61

45−type Reader tag r = ReaderT tag r Identity

62+-- | Constructor for computations in the reader monad transformer.

46−

47−etherReaderT :: proxy tag -> (r -> m a) -> ReaderT tag r m a

63+readerT :: proxy tag -> (r -> m a) -> ReaderT tag r m a

48−etherReaderT _proxy = ReaderT . Trans.ReaderT

64+readerT _proxy = ReaderT . Trans.ReaderT

49

65

66+-- | Runs a 'Reader' and extracts the final value from it.

50runReaderT :: proxy tag -> ReaderT tag r m a -> r -> m a

67runReaderT :: proxy tag -> ReaderT tag r m a -> r -> m a

51runReaderT _proxy (ReaderT (Trans.ReaderT f)) = f

68runReaderT _proxy (ReaderT (Trans.ReaderT f)) = f

52

69

70+-- | Runs a 'Reader' and extracts the final value from it.

53runReader :: proxy tag -> Reader tag r a -> r -> a

71runReader :: proxy tag -> Reader tag r a -> r -> a

54runReader proxy m r = runIdentity (runReaderT proxy m r)

72runReader proxy m r = runIdentity (runReaderT proxy m r)

55

73

74+-- | Transform the computation inside a @ReaderT@.

75+--

76+-- * @'runReaderT' tag ('mapReaderT' tag f m) = f . 'runReaderT' tag m@

56mapReaderT :: proxy tag -> (m a -> n b) -> ReaderT tag r m a -> ReaderT tag r n b

77mapReaderT :: proxy tag -> (m a -> n b) -> ReaderT tag r m a -> ReaderT tag r n b

57mapReaderT _proxy f m = ReaderT $ Trans.mapReaderT f (coerce m)

78mapReaderT _proxy f m = ReaderT $ Trans.mapReaderT f (coerce m)

58

79

80+-- | Lift a @catchE@ operation to the new monad.

59liftCatch :: proxy tag -> Sig.Catch e m a -> Sig.Catch e (ReaderT tag r m) a

81liftCatch :: proxy tag -> Sig.Catch e m a -> Sig.Catch e (ReaderT tag r m) a

60liftCatch _proxy f m h = ReaderT $ Trans.liftCatch f (coerce m) (coerce h)

82liftCatch _proxy f m h = ReaderT $ Trans.liftCatch f (coerce m) (coerce h)

61

83

84+-- | Lift a @callCC@ operation to the new monad.

62liftCallCC :: proxy tag -> Sig.CallCC m a b -> Sig.CallCC (ReaderT tag r m) a b

85liftCallCC :: proxy tag -> Sig.CallCC m a b -> Sig.CallCC (ReaderT tag r m) a b

63liftCallCC _proxy callCC f = ReaderT $ Trans.liftCallCC callCC (coerce f)

86liftCallCC _proxy callCC f = ReaderT $ Trans.liftCallCC callCC (coerce f)

64

87

src/Control/Monad/Trans/Ether/State.hs+4−4

@@ -15,7 +15,7 @@ module Control.Monad.Trans.Ether.State

15 , evalState

16 , execStateT

17 , execState

18− , etherStateT

18+ , stateT

19 , mapStateT

20 , liftCatch

21 , liftCallCC'

@@ -31,7 +31,7 @@ import Control.Monad (MonadPlus)

31import Control.Monad.Fix (MonadFix)

32import Control.Monad.Trans.Class (MonadTrans, lift)

33import Control.Monad.IO.Class (MonadIO)

34−import Control.Ether.Core

34+import Control.Ether.Tags (Tags)

35

36import qualified Control.Monad.Signatures as Sig

37import qualified Control.Monad.Trans.State.Lazy as Trans

@@ -50,8 +50,8 @@ type instance Tags (StateT tag r m) = tag ': Tags m

50

51type State tag r = StateT tag r Identity

52

53−etherStateT :: proxy tag -> (s -> m (a, s)) -> StateT tag s m a

53+stateT :: proxy tag -> (s -> m (a, s)) -> StateT tag s m a

54−etherStateT _proxy = StateT . Trans.StateT

54+stateT _proxy = StateT . Trans.StateT

55

56runStateT :: proxy tag -> StateT tag s m a -> s -> m (a, s)

57runStateT _proxy (StateT (Trans.StateT f)) = f

test/Regression.hs+46−5

@@ -6,13 +6,15 @@

6{-# LANGUAGE ScopedTypeVariables #-}

7module Main where

8

9−import Control.Ether.Core

9+import Control.Ether.Tags

10import Control.Ether.TH

11import Control.Ether.Wrapped

12import Control.Monad.Ether.Reader

13import Control.Monad.Ether.State

14import qualified Control.Monad.Ether.Implicit.Reader as I

15−import qualified Control.Monad.Reader as Tagless

15+import qualified Control.Monad.Ether.Implicit.State as I

16+import qualified Control.Monad.Reader as T

17+import qualified Control.Monad.State as T

16

18

17import Test.Tasty

19import Test.Tasty

18import Test.Tasty.QuickCheck

20import Test.Tasty.QuickCheck

@@ -72,9 +74,28 @@ implicitCore = I.local (succ :: Int -> Int) $ do

72 b <- I.local not I.ask

74 b <- I.local not I.ask

73 return (if b then "" else show n)

75 return (if b then "" else show n)

74

76

77+wrapCore

75−wrapCore :: MonadReader R1 Int m => m Int

78+ :: ( T.MonadReader Int m

79+ , T.MonadState Int m

80+ ) => m Int

76−wrapCore = ethered r1 Tagless.ask

81+wrapCore = do

82+ b <- T.get

83+ a <- T.ask

84+ T.put (a + b)

85+ return (a * b)

77

86

87+wrapCore'

88+ :: ( MonadReader S1 Int m

89+ , MonadState S1 Int m

90+ , MonadReader R1 Int m

91+ ) => m Int

92+wrapCore' = do

93+ a <- ethered s1 wrapCore

94+ c <- ask r1

95+ return (a + c)

96+

97+wrapCore'' :: Int -> (Int, Int)

98+wrapCore'' a = runReader r1 (runStateT s1 (runReaderT s1 wrapCore' a) a) (-1)

78

99

79-- Should not compile with `ensureUniqueTags`

100-- Should not compile with `ensureUniqueTags`

80uniqueTagsCore :: IO ()

101uniqueTagsCore :: IO ()

@@ -87,7 +108,7 @@ uniqueTagsCore = flip (runReaderT r1) (1 :: Int)

87 a :: Integer <- ask r1

108 a :: Integer <- ask r1

88 b :: Int <- ask r1

109 b :: Int <- ask r1

89 c :: Bool <- ask r1

110 c :: Bool <- ask r1

90− Tagless.liftIO $ do

111+ T.liftIO $ do

91 print a

112 print a

92 print b

113 print b

93 print c

114 print c

@@ -99,3 +120,23 @@ stateCore = do

99 a <- ask r1

120 a <- ask r1

100 n <- get s1

121 n <- get s1

101 put s1 (n * a)

122 put s1 (n * a)

123+ modify s1 (subtract 1)

124+

125+recurseCore :: (Num a, Ord a) => (I.MonadReader a m, I.MonadState Int m) => m a

126+recurseCore = do

127+ a <- I.ask

128+ if (a <= 0)

129+ then do

130+ I.put (0 :: Int)

131+ return 1

132+ else do

133+ I.modify (succ :: Int -> Int)

134+ b <- I.runReaderT recurseCore (a - 1)

135+ I.modify (succ :: Int -> Int)

136+ return (a * b)

137+

138+factorial :: (Num a, Ord a) => a -> (a, Int)

139+factorial a = I.runState (I.runReaderT recurseCore a) (0 :: Int)

140+

141+factorial' :: Int -> (Int, Int)

142+factorial' a = factorial (a :: Int)