0cff774 · typeable/ether

git.iko.soy/typeable/ether

on master help sign in

Add monomorphic inferable MonadReader

0cff774Index Int11 years ago

src/Control/Ether/Core.hs+5

compare with master

unifiedsplit

@@ -8,8 +8,10 @@ module Control.Ether.Core

8 ( EtherTagless

9 , MonadEther

10 , EtherTags

11+ , infer

11 ) where

12 ) where

14+import Data.Proxy (Proxy(Proxy))

13import Data.Functor.Identity

15import Data.Functor.Identity

14import GHC.Exts (Constraint)

16import GHC.Exts (Constraint)

@@ -24,6 +26,9 @@ import qualified Control.Monad.Trans.State.Strict as Trans.Strict

24import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy

26import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy

25import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict

27import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict

29+infer :: (Proxy tag -> a) -> a

30+infer f = f Proxy

31+

27type family OR (a :: Bool) (b :: Bool) :: Bool where

32type family OR (a :: Bool) (b :: Bool) :: Bool where

28 OR 'True a = 'True

33 OR 'True a = 'True

29 OR 'False a = a

34 OR 'False a = a

src/Control/Monad/Ether/Reader.hs+14

@@ -4,12 +4,15 @@

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE UndecidableInstances #-}

6{-# LANGUAGE DataKinds #-}

7+{-# LANGUAGE ConstraintKinds #-}

7{-# LANGUAGE TypeOperators #-}

8{-# LANGUAGE TypeOperators #-}

8{-# LANGUAGE FunctionalDependencies #-}

9{-# LANGUAGE FunctionalDependencies #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE GeneralizedNewtypeDeriving #-}

11{-# LANGUAGE GeneralizedNewtypeDeriving #-}

10module Control.Monad.Ether.Reader

12module Control.Monad.Ether.Reader

11 ( module Control.Monad.Ether.Reader

13 ( module Control.Monad.Ether.Reader

12 , module Control.Monad.Trans.Ether.Reader

14 , module Control.Monad.Trans.Ether.Reader

15+ , infer

13 ) where

16 ) where

15import Data.Proxy (Proxy(Proxy))

18import Data.Proxy (Proxy(Proxy))

@@ -40,6 +43,17 @@ class MonadEther m => MonadEtherReader tag r m | m tag -> r where

40 etherReader :: proxy tag -> (r -> a) -> m a

43 etherReader :: proxy tag -> (r -> a) -> m a

41 etherReader proxy f = fmap f (etherAsk proxy)

44 etherReader proxy f = fmap f (etherAsk proxy)

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+

43instance {-# OVERLAPPING #-} (Monad m, EtherTagless tag m)

57instance {-# OVERLAPPING #-} (Monad m, EtherTagless tag m)

44 => MonadEtherReader tag r (EtherReaderT tag r m) where

58 => MonadEtherReader tag r (EtherReaderT tag r m) where

45 etherAsk proxy = etherReaderT proxy return

59 etherAsk proxy = etherReaderT proxy return

src/Control/Monad/Trans/Ether/Reader.hs+12

@@ -9,6 +9,7 @@

9module Control.Monad.Trans.Ether.Reader where

11import Data.Proxy (Proxy(Proxy))

12+import Data.Functor.Identity (Identity(..))

12import Data.Coerce (coerce)

13import Data.Coerce (coerce)

13import Control.Applicative (Alternative)

14import Control.Applicative (Alternative)

14import Control.Monad (MonadPlus)

15import Control.Monad (MonadPlus)

@@ -30,6 +31,8 @@ newtype EtherReaderT tag r m a = EtherReaderT (R.ReaderT r m a)

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

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

31 , MonadFix, MonadTrans, MonadIO )

32 , MonadFix, MonadTrans, MonadIO )

34+type EtherReader tag r = EtherReaderT tag r Identity

35+

33instance Monad m => MonadEther (EtherReaderT tag r m) where

36instance Monad m => MonadEther (EtherReaderT tag r m) where

34 type EtherTags (EtherReaderT tag r m) = tag ': EtherTags m

37 type EtherTags (EtherReaderT tag r m) = tag ': EtherTags m

@@ -39,6 +42,9 @@ etherReaderT _proxy = EtherReaderT . R.ReaderT

39runEtherReaderT :: proxy tag -> EtherReaderT tag r m a -> r -> m a

42runEtherReaderT :: proxy tag -> EtherReaderT tag r m a -> r -> m a

40runEtherReaderT _proxy (EtherReaderT (R.ReaderT s)) = s

43runEtherReaderT _proxy (EtherReaderT (R.ReaderT s)) = s

45+runEtherReader :: proxy tag -> EtherReader tag r a -> r -> a

46+runEtherReader proxy m r = runIdentity (runEtherReaderT proxy m r)

47+

42mapEtherReaderT :: proxy tag -> (m a -> n b) -> EtherReaderT tag r m a -> EtherReaderT tag r n b

48mapEtherReaderT :: proxy tag -> (m a -> n b) -> EtherReaderT tag r m a -> EtherReaderT tag r n b

43mapEtherReaderT _proxy f m = EtherReaderT $ R.mapReaderT f (coerce m)

49mapEtherReaderT _proxy f m = EtherReaderT $ R.mapReaderT f (coerce m)

@@ -48,6 +54,12 @@ liftCatch _proxy f m h = EtherReaderT $ R.liftCatch f (coerce m) (coerce h)

48liftCallCC :: proxy tag -> Sig.CallCC m a b -> Sig.CallCC (EtherReaderT tag r m) a b

54liftCallCC :: proxy tag -> Sig.CallCC m a b -> Sig.CallCC (EtherReaderT tag r m) a b

49liftCallCC _proxy callCC f = EtherReaderT $ R.liftCallCC callCC (coerce f)

55liftCallCC _proxy callCC f = EtherReaderT $ R.liftCallCC callCC (coerce f)

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+

51-- Instances for mtl classes

63-- Instances for mtl classes

53instance Class.MonadCont m => Class.MonadCont (EtherReaderT tag r m) where

65instance Class.MonadCont m => Class.MonadCont (EtherReaderT tag r m) where

test/Regression.hs+8

@@ -3,9 +3,11 @@

3{-# LANGUAGE EmptyDataDecls #-}

4{-# LANGUAGE TemplateHaskell #-}

5{-# LANGUAGE ConstraintKinds #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

6module Main where

7module Main where

8import Control.Ether.TH

9import Control.Ether.TH

10+import Control.Monad.Ether.Reader

10import Test.Tasty

12import Test.Tasty

11import Test.Tasty.QuickCheck

13import Test.Tasty.QuickCheck

@@ -57,3 +59,9 @@ layeredLocalCore' k f a1 a2 = (direct, indirect)

57 where

59 where

58 direct = apply k (fromIntegral a1, apply f a2)

60 direct = apply k (fromIntegral a1, apply f a2)

59 indirect = layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))

61 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)