git.iko.soy/typeable/ether
on master help sign in
Initial commit
commit760a756474d39ffca1e5aa58a315db5cc6ceb5cd authorIndex Int <vlad.z.4096@gmail.com> dateSat 6 Jun 2015, 00:43 (11 years ago)
8 files changed+308
compare with master
unifiedsplit
.gitignore+1 LICENSE+30 Setup.hs+2 ether.cabal+44 src/Control/Ether/Core.hs+6 src/Control/Monad/Ether/Reader.hs+83 src/Control/Monad/Trans/Ether/Reader.hs+72 test/Regression.hs+70
.gitignorenew file+1
@@ -0,0 +1 @@
1+dist
LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c) 2015, Index Int
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Index Int nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
ether.cabalnew file+44
@@ -0,0 +1,44 @@
1+name: ether
2+version: 0.1.0.0
3+synopsis: Monad transformers and classes
4+description:
5+ Ether provides an easy way to create mtl-compatible effects
6+ that do not require you to write O(n) instances.
7+category: Control
8+license: BSD3
9+license-file: LICENSE
10+author: Index Int
11+author: Index Int <vlad.z.4096@gmail.com>
12+build-type: Simple
13+cabal-version: >=1.22
14+
15+library
16+
17+ exposed-modules: Control.Ether.Core
18+ Control.Monad.Trans.Ether.Reader
19+ Control.Monad.Ether.Reader
20+
21+ build-depends: base >=4.8 && <4.9
22+ , transformers >=0.4.0.3
23+ , mtl >=2.2.1
24+
25+ hs-source-dirs: src
26+ default-language: Haskell2010
27+ ghc-options: -Wall
28+
29+
30+test-suite regression
31+
32+ build-depends: base >=4.8 && <4.9
33+ , transformers >=0.4.0.3
34+ , mtl >=2.2.1
35+ , tasty >=0.10
36+ , tasty-quickcheck >=0.8
37+ , QuickCheck >=2.8
38+ , ether
39+
40+ main-is: Regression.hs
41+ type: exitcode-stdio-1.0
42+ hs-source-dirs: test
43+ default-language: Haskell2010
44+ ghc-options: -Wall
src/Control/Ether/Core.hsnew file+6
@@ -0,0 +1,6 @@
1+{-# LANGUAGE TypeFamilies #-}
2+module Control.Ether.Core
3+ ( EtherData
4+ ) where
5+
6+type family EtherData tag :: *
src/Control/Monad/Ether/Reader.hsnew file+83
@@ -0,0 +1,83 @@
1+{-# LANGUAGE MultiParamTypeClasses #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+module Control.Monad.Ether.Reader
8+ ( module Control.Monad.Ether.Reader
9+ , module Control.Monad.Trans.Ether.Reader
10+ ) where
11+
12+import Data.Proxy (Proxy(Proxy))
13+import Control.Monad.Trans (lift)
14+
15+import Control.Ether.Core (EtherData)
16+import Control.Monad.Trans.Ether.Reader
17+
18+-- for mtl instances
19+import qualified Control.Monad.Trans.Cont as Cont (ContT , liftLocal)
20+import qualified Control.Monad.Trans.Except as Except (ExceptT , mapExceptT)
21+import qualified Control.Monad.Trans.Identity as Identity (IdentityT, mapIdentityT)
22+import qualified Control.Monad.Trans.List as List (ListT , mapListT)
23+import qualified Control.Monad.Trans.Maybe as Maybe (MaybeT , mapMaybeT)
24+import qualified Control.Monad.Trans.State.Lazy as State.Lazy (StateT , mapStateT)
25+import qualified Control.Monad.Trans.State.Strict as State.Strict (StateT , mapStateT)
26+import qualified Control.Monad.Trans.Writer.Lazy as Writer.Lazy (WriterT , mapWriterT)
27+import qualified Control.Monad.Trans.Writer.Strict as Writer.Strict (WriterT , mapWriterT)
28+
29+class Monad m => MonadEtherReader tag m where
30+
31+ etherLocal :: proxy tag -> (EtherData tag -> EtherData tag) -> m a -> m a
32+
33+ etherAsk :: proxy tag -> m (EtherData tag)
34+ etherAsk proxy = etherReader proxy id
35+
36+ etherReader :: proxy tag -> (EtherData tag -> a) -> m a
37+ etherReader proxy f = fmap f (etherAsk proxy)
38+
39+instance {-# OVERLAPS #-} Monad m => MonadEtherReader tag (EtherReaderT tag m) where
40+ etherAsk proxy = etherReaderT proxy return
41+ etherLocal proxy f m = etherReaderT proxy (runEtherReaderT proxy m . f)
42+
43+instance MonadEtherReader tag m => MonadEtherReader tag (EtherReaderT tag' m) where
44+ etherAsk proxy = lift (etherAsk proxy)
45+ etherLocal proxy = mapEtherReaderT Proxy . etherLocal proxy
46+
47+-- Instances for mtl transformers
48+
49+instance MonadEtherReader tag m => MonadEtherReader tag (Cont.ContT r m) where
50+ etherAsk proxy = lift (etherAsk proxy)
51+ etherLocal proxy = Cont.liftLocal (etherAsk proxy) (etherLocal proxy)
52+
53+instance MonadEtherReader tag m => MonadEtherReader tag (Except.ExceptT e m) where
54+ etherAsk proxy = lift (etherAsk proxy)
55+ etherLocal proxy = Except.mapExceptT . etherLocal proxy
56+
57+instance MonadEtherReader tag m => MonadEtherReader tag (Identity.IdentityT m) where
58+ etherAsk proxy = lift (etherAsk proxy)
59+ etherLocal proxy = Identity.mapIdentityT . etherLocal proxy
60+
61+instance MonadEtherReader tag m => MonadEtherReader tag (List.ListT m) where
62+ etherAsk proxy = lift (etherAsk proxy)
63+ etherLocal proxy = List.mapListT . etherLocal proxy
64+
65+instance MonadEtherReader tag m => MonadEtherReader tag (Maybe.MaybeT m) where
66+ etherAsk proxy = lift (etherAsk proxy)
67+ etherLocal proxy = Maybe.mapMaybeT . etherLocal proxy
68+
69+instance MonadEtherReader tag m => MonadEtherReader tag (State.Lazy.StateT s m) where
70+ etherAsk proxy = lift (etherAsk proxy)
71+ etherLocal proxy = State.Lazy.mapStateT . etherLocal proxy
72+
73+instance MonadEtherReader tag m => MonadEtherReader tag (State.Strict.StateT s m) where
74+ etherAsk proxy = lift (etherAsk proxy)
75+ etherLocal proxy = State.Strict.mapStateT . etherLocal proxy
76+
77+instance (Monoid w, MonadEtherReader tag m) => MonadEtherReader tag (Writer.Lazy.WriterT w m) where
78+ etherAsk proxy = lift (etherAsk proxy)
79+ etherLocal proxy = Writer.Lazy.mapWriterT . etherLocal proxy
80+
81+instance (Monoid w, MonadEtherReader tag m) => MonadEtherReader tag (Writer.Strict.WriterT w m) where
82+ etherAsk proxy = lift (etherAsk proxy)
83+ etherLocal proxy = Writer.Strict.mapWriterT . etherLocal proxy
src/Control/Monad/Trans/Ether/Reader.hsnew file+72
@@ -0,0 +1,72 @@
1+{-# LANGUAGE MultiParamTypeClasses #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+module Control.Monad.Trans.Ether.Reader where
8+
9+import Data.Proxy (Proxy(Proxy))
10+import Control.Applicative (Alternative)
11+import Control.Monad (MonadPlus)
12+import Control.Monad.Fix (MonadFix)
13+import Control.Monad.Trans.Class (MonadTrans, lift)
14+import Control.Monad.IO.Class (MonadIO)
15+import Control.Ether.Core (EtherData)
16+
17+import qualified Control.Monad.Signatures as Sig
18+import qualified Control.Monad.Trans.Reader as R
19+
20+import qualified Control.Monad.Cont.Class as Class
21+import qualified Control.Monad.Reader.Class as Class
22+import qualified Control.Monad.State.Class as Class
23+import qualified Control.Monad.Writer.Class as Class
24+import qualified Control.Monad.Error.Class as Class
25+
26+newtype EtherReaderT tag m a = EtherReaderT (R.ReaderT (EtherData tag) m a)
27+ deriving ( Functor, Applicative, Alternative, Monad, MonadPlus
28+ , MonadFix, MonadTrans, MonadIO )
29+
30+etherReaderT :: proxy tag -> (EtherData tag -> m a) -> EtherReaderT tag m a
31+etherReaderT _proxy = EtherReaderT . R.ReaderT
32+
33+runEtherReaderT :: proxy tag -> EtherReaderT tag m a -> EtherData tag -> m a
34+runEtherReaderT _proxy (EtherReaderT (R.ReaderT s)) = s
35+
36+mapEtherReaderT :: proxy tag -> (m a -> n b) -> EtherReaderT tag m a -> EtherReaderT tag n b
37+mapEtherReaderT proxy f m = etherReaderT proxy $ f . runEtherReaderT proxy m
38+
39+liftCatch :: proxy tag -> Sig.Catch e m a -> Sig.Catch e (EtherReaderT tag m) a
40+liftCatch proxy f m h = etherReaderT proxy
41+ $ \r -> f (runEtherReaderT proxy m r)
42+ $ \e -> runEtherReaderT proxy (h e) r
43+
44+liftCallCC :: proxy tag -> Sig.CallCC m a b -> Sig.CallCC (EtherReaderT tag m) a b
45+liftCallCC proxy callCC f = etherReaderT proxy
46+ $ \r -> callCC
47+ $ \c -> runEtherReaderT proxy (f (etherReaderT proxy . const . c)) r
48+
49+-- Instances for mtl classes
50+
51+instance Class.MonadCont m => Class.MonadCont (EtherReaderT tag m) where
52+ callCC = liftCallCC Proxy Class.callCC
53+
54+instance Class.MonadReader r m => Class.MonadReader r (EtherReaderT tag m) where
55+ ask = lift Class.ask
56+ local = mapEtherReaderT Proxy . Class.local
57+ reader = lift . Class.reader
58+
59+instance Class.MonadState s m => Class.MonadState s (EtherReaderT tag m) where
60+ get = lift Class.get
61+ put = lift . Class.put
62+ state = lift . Class.state
63+
64+instance Class.MonadWriter w m => Class.MonadWriter w (EtherReaderT tag m) where
65+ writer = lift . Class.writer
66+ tell = lift . Class.tell
67+ listen = mapEtherReaderT Proxy Class.listen
68+ pass = mapEtherReaderT Proxy Class.pass
69+
70+instance Class.MonadError e m => Class.MonadError e (EtherReaderT tag m) where
71+ throwError = lift . Class.throwError
72+ catchError = liftCatch Proxy Class.catchError
test/Regression.hsnew file+70
@@ -0,0 +1,70 @@
1+{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE EmptyDataDecls #-}
4+module Main where
5+
6+import Control.Monad.Ether.Reader
7+
8+import Data.Proxy
9+import Data.Functor.Identity
10+import Control.Ether.Core
11+
12+import Test.Tasty
13+import Test.Tasty.QuickCheck
14+import Test.QuickCheck.Function
15+
16+main :: IO ()
17+main = defaultMain suite
18+
19+suite :: TestTree
20+suite = testGroup "Ether"
21+ [ testGroup "EtherReaderT"
22+ [ testProperty "layered sum (local left)" layeredLocalLeft
23+ , testProperty "layered sum (local right)" layeredLocalRight
24+ ]
25+ ]
26+
27+layeredLocalLeft, layeredLocalRight
28+ :: Fun (Int, Integer) Integer -> Fun Integer Integer -> Int -> Integer -> Property
29+
30+layeredLocalLeft k f a1 a2 = property (direct == indirect)
31+ where
32+ run = runIdentity . flip runAmountT a1 . flip runAmount2T a2
33+ direct = apply k (fromIntegral a1, apply f a2)
34+ indirect = run $ layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
35+
36+layeredLocalRight k f a1 a2 = property (direct == indirect)
37+ where
38+ run = runIdentity . flip runAmount2T a2 . flip runAmountT a1
39+ direct = apply k (fromIntegral a1, apply f a2)
40+ indirect = run $ layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
41+
42+layeredLocalCore
43+ :: (MonadEtherReader AmountTag m, MonadEtherReader Amount2Tag m)
44+ => (Integer -> Integer) -> (Int -> Integer -> a) -> m a
45+layeredLocalCore f g = do
46+ n <- askAmount
47+ m <- etherLocal (Proxy :: Proxy Amount2Tag) f askAmount2
48+ return (g n m)
49+
50+data AmountTag
51+type instance EtherData AmountTag = Int
52+
53+runAmountT :: EtherReaderT AmountTag m a -> EtherData AmountTag -> m a
54+runAmountT = runEtherReaderT (Proxy :: Proxy AmountTag)
55+
56+askAmount :: MonadEtherReader AmountTag m => m (EtherData AmountTag)
57+askAmount = etherAsk (Proxy :: Proxy AmountTag)
58+
59+data Amount2Tag
60+type instance EtherData Amount2Tag = Integer
61+
62+runAmount2T :: EtherReaderT Amount2Tag m a -> EtherData Amount2Tag -> m a
63+runAmount2T = runEtherReaderT (Proxy :: Proxy Amount2Tag)
64+
65+askAmount2 :: MonadEtherReader Amount2Tag m => m (EtherData Amount2Tag)
66+askAmount2 = etherAsk (Proxy :: Proxy Amount2Tag)
67+
68+-- this should not compile
69+z :: IO Int
70+z = runAmountT (runAmountT (runAmountT askAmount 20) 10) 5