git.iko.soy/typeable/ether
on master help sign in
Add monomorphic inferable MonadReader
commit0cff774633c018bc9de7c9854374d7ce31350d5c authorIndex Int <vlad.z.4096@gmail.com> dateSun 7 Jun 2015, 02:44 (11 years ago) parent7873b67
4 files changed+39
compare with master
unifiedsplit
src/Control/Ether/Core.hs+5 src/Control/Monad/Ether/Reader.hs+14 src/Control/Monad/Trans/Ether/Reader.hs+12 test/Regression.hs+8
src/Control/Ether/Core.hs+5
@@ -8,8 +8,10 @@ module Control.Ether.Core
88 ( EtherTagless
99 , MonadEther
1010 , EtherTags
11+ , infer
1112 ) where
1213
14+import Data.Proxy (Proxy(Proxy))
1315import Data.Functor.Identity
1416import GHC.Exts (Constraint)
1517
@@ -24,6 +26,9 @@ import qualified Control.Monad.Trans.State.Strict as Trans.Strict
2426import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy
2527import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict
2628
29+infer :: (Proxy tag -> a) -> a
30+infer f = f Proxy
31+
2732type family OR (a :: Bool) (b :: Bool) :: Bool where
2833 OR 'True a = 'True
2934 OR 'False a = a
src/Control/Monad/Ether/Reader.hs+14
@@ -4,12 +4,15 @@
44{-# LANGUAGE FlexibleContexts #-}
55{-# LANGUAGE UndecidableInstances #-}
66{-# LANGUAGE DataKinds #-}
7+{-# LANGUAGE ConstraintKinds #-}
78{-# LANGUAGE TypeOperators #-}
89{-# LANGUAGE FunctionalDependencies #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
911{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1012module Control.Monad.Ether.Reader
1113 ( module Control.Monad.Ether.Reader
1214 , module Control.Monad.Trans.Ether.Reader
15+ , infer
1316 ) where
1417
1518import Data.Proxy (Proxy(Proxy))
@@ -40,6 +43,17 @@ class MonadEther m => MonadEtherReader tag r m | m tag -> r where
4043 etherReader :: proxy tag -> (r -> a) -> m a
4144 etherReader proxy f = fmap f (etherAsk proxy)
4245
46+type MonadReader' r = MonadEtherReader r r
47+
48+local' :: MonadReader' r m => proxy r -> (r -> r) -> m a -> m a
49+local' = etherLocal
50+
51+ask' :: MonadReader' r m => proxy r -> m r
52+ask' = etherAsk
53+
54+reader' :: MonadReader' r m => proxy r -> (r -> a) -> m a
55+reader' = etherReader
56+
4357instance {-# OVERLAPPING #-} (Monad m, EtherTagless tag m)
4458 => MonadEtherReader tag r (EtherReaderT tag r m) where
4559 etherAsk proxy = etherReaderT proxy return
src/Control/Monad/Trans/Ether/Reader.hs+12
@@ -9,6 +9,7 @@
99module Control.Monad.Trans.Ether.Reader where
1010
1111import Data.Proxy (Proxy(Proxy))
12+import Data.Functor.Identity (Identity(..))
1213import Data.Coerce (coerce)
1314import Control.Applicative (Alternative)
1415import Control.Monad (MonadPlus)
@@ -30,6 +31,8 @@ newtype EtherReaderT tag r m a = EtherReaderT (R.ReaderT r m a)
3031 deriving ( Functor, Applicative, Alternative, Monad, MonadPlus
3132 , MonadFix, MonadTrans, MonadIO )
3233
34+type EtherReader tag r = EtherReaderT tag r Identity
35+
3336instance Monad m => MonadEther (EtherReaderT tag r m) where
3437 type EtherTags (EtherReaderT tag r m) = tag ': EtherTags m
3538
@@ -39,6 +42,9 @@ etherReaderT _proxy = EtherReaderT . R.ReaderT
3942runEtherReaderT :: proxy tag -> EtherReaderT tag r m a -> r -> m a
4043runEtherReaderT _proxy (EtherReaderT (R.ReaderT s)) = s
4144
45+runEtherReader :: proxy tag -> EtherReader tag r a -> r -> a
46+runEtherReader proxy m r = runIdentity (runEtherReaderT proxy m r)
47+
4248mapEtherReaderT :: proxy tag -> (m a -> n b) -> EtherReaderT tag r m a -> EtherReaderT tag r n b
4349mapEtherReaderT _proxy f m = EtherReaderT $ R.mapReaderT f (coerce m)
4450
@@ -48,6 +54,12 @@ liftCatch _proxy f m h = EtherReaderT $ R.liftCatch f (coerce m) (coerce h)
4854liftCallCC :: proxy tag -> Sig.CallCC m a b -> Sig.CallCC (EtherReaderT tag r m) a b
4955liftCallCC _proxy callCC f = EtherReaderT $ R.liftCallCC callCC (coerce f)
5056
57+runReaderT' :: EtherReaderT r r m a -> r -> m a
58+runReaderT' = runEtherReaderT Proxy
59+
60+runReader' :: EtherReader r r a -> r -> a
61+runReader' m r = runIdentity (runEtherReaderT Proxy m r)
62+
5163-- Instances for mtl classes
5264
5365instance Class.MonadCont m => Class.MonadCont (EtherReaderT tag r m) where
test/Regression.hs+8
@@ -3,9 +3,11 @@
33{-# LANGUAGE EmptyDataDecls #-}
44{-# LANGUAGE TemplateHaskell #-}
55{-# LANGUAGE ConstraintKinds #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
67module Main where
78
89import Control.Ether.TH
10+import Control.Monad.Ether.Reader
911
1012import Test.Tasty
1113import Test.Tasty.QuickCheck
@@ -57,3 +59,9 @@ layeredLocalCore' k f a1 a2 = (direct, indirect)
5759 where
5860 direct = apply k (fromIntegral a1, apply f a2)
5961 indirect = layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
62+
63+inferCore :: (MonadReader' Int m, MonadReader' Bool m) => m String
64+inferCore = infer local' (succ :: Int -> Int) $ do
65+ n :: Int <- infer ask'
66+ b <- infer local' not (infer ask')
67+ return (if b then "" else show n)