diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Index Int + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Index Int nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ether.cabal b/ether.cabal new file mode 100644 --- /dev/null +++ b/ether.cabal @@ -0,0 +1,80 @@ +name: ether +version: 0.1.0.0 +synopsis: Monad transformers and classes +description: + Ether is a Haskell library that extends @mtl@ and @transformers@ with + tagged monad transformers and classes in a compatible way. + +category: Control +license: BSD3 +license-file: LICENSE +author: Index Int +maintainer: Index Int +homepage: https://int-index.github.io/ether/ +bug-reports: https://github.com/int-index/ether/issues +build-type: Simple +cabal-version: >=1.22 + +source-repository head + + type: git + location: git@github.com:int-index/ether.git + + +library + + exposed-modules: Control.Ether.Tagged + Control.Ether.Wrapped + Control.Ether.TH + Control.Monad.Trans.Ether.Reader + Control.Monad.Trans.Ether.Writer + Control.Monad.Trans.Ether.State + Control.Monad.Trans.Ether.State.Lazy + Control.Monad.Trans.Ether.State.Strict + Control.Monad.Trans.Ether.Except + Control.Monad.Ether.Reader + Control.Monad.Ether.Reader.Class + Control.Monad.Ether.Writer + Control.Monad.Ether.Writer.Class + Control.Monad.Ether.State + Control.Monad.Ether.State.Class + Control.Monad.Ether.State.Lazy + Control.Monad.Ether.State.Strict + Control.Monad.Ether.Except + Control.Monad.Ether.Except.Class + Control.Monad.Ether.Implicit.Reader + Control.Monad.Ether.Implicit.Writer + Control.Monad.Ether.Implicit.State + Control.Monad.Ether.Implicit.State.Lazy + Control.Monad.Ether.Implicit.State.Strict + Control.Monad.Ether.Implicit.Except + Control.Monad.Ether.Implicit.Except.TH + + other-modules: Control.Ether.Util + + build-depends: base >=4.8 && <4.9 + , transformers >=0.4.0.3 + , mtl >=2.2.1 + , template-haskell >=2.10 + , newtype-generics >=0.4.1 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + + +test-suite regression + + build-depends: base >=4.8 && <4.9 + , transformers >=0.4.0.3 + , mtl >=2.2.1 + , tasty >=0.10 + , tasty-quickcheck >=0.8 + , QuickCheck >=2.8 + , ether + + main-is: Regression.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Control/Ether/TH.hs b/src/Control/Ether/TH.hs new file mode 100644 --- /dev/null +++ b/src/Control/Ether/TH.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Template haskell utilities. + +module Control.Ether.TH + ( ethereal + , fmapN + , deepN + ) where + +import qualified Language.Haskell.TH as TH + +import Data.Proxy + +emptyDataDecl :: TH.Name -> TH.DecQ +emptyDataDecl name = TH.dataD (return []) name [] [] [] + +funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ +funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ] + +proxySimple :: TH.Name -> TH.TypeQ -> TH.Q (TH.Dec, TH.Dec) +proxySimple name ty = do + sig <- TH.sigD name [t| Proxy $ty |] + val <- funSimple name [e| Proxy |] + return (sig, val) + +-- | +-- Creates a tag and a value-level proxy for it. +-- +-- @'ethereal' \"Foo\" \"foo\"@ generates the following code: +-- +-- > data Foo +-- > foo :: Proxy Foo +-- > foo = Proxy +ethereal :: String -> String -> TH.DecsQ +ethereal strTagName strTagProxyName = do + let tagName = TH.mkName strTagName + tag = TH.conT tagName + tagProxyName = TH.mkName strTagProxyName + tagDecl <- emptyDataDecl tagName + (tagProxySig, tagProxyVal) <- proxySimple tagProxyName tag + return [tagDecl, tagProxySig, tagProxyVal] + +-- | +-- Compose 'fmap' @n@ times. +-- +-- @$('fmapN' 5) = fmap.fmap.fmap.fmap.fmap@ +fmapN :: Int -> TH.ExpQ +fmapN 0 = [|id|] +fmapN n = TH.infixApp [|fmap|] [|(.)|] (fmapN (n - 1)) + +-- | +-- 'fmap' a function @n@ levels deep. +-- +-- @$('deepN' 3 [| f |]) = $('fmapN' 3) f ($('fmapN' 2) f ($('fmapN' 1) f id))@ +deepN :: Int -> TH.ExpQ -> TH.ExpQ +deepN 0 _ = [|id|] +deepN n f = [| $(fmapN n) $f $(deepN (n-1) f) |] diff --git a/src/Control/Ether/Tagged.hs b/src/Control/Ether/Tagged.hs new file mode 100644 --- /dev/null +++ b/src/Control/Ether/Tagged.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DefaultSignatures #-} + +-- | Type-level machinery for tag manipulation. + +module Control.Ether.Tagged + ( Taggable(..) + , Tagged(..) + , Tags + , Inners + , UniqueTag + , UniqueTags + , ensureUniqueTags + ) where + +import Data.Proxy (Proxy) +import Data.Functor.Identity (Identity) +import Data.Monoid (First, Last) +import qualified Control.Monad.ST.Strict as Strict (ST) +import qualified Control.Monad.ST.Lazy as Lazy (ST) +import GHC.Conc (STM) +import GHC.Exts (Constraint) +import qualified Control.Newtype as NT +import Control.Ether.Util (type (++), MaybeToList) + +import qualified Control.Monad.Trans.Cont as Trans +import qualified Control.Monad.Trans.Except as Trans +import qualified Control.Monad.Trans.Identity as Trans +import qualified Control.Monad.Trans.List as Trans +import qualified Control.Monad.Trans.Maybe as Trans +import qualified Control.Monad.Trans.Reader as Trans +import qualified Control.Monad.Trans.State.Lazy as Trans.Lazy +import qualified Control.Monad.Trans.State.Strict as Trans.Strict +import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy +import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict + +-- | +-- The main purpose of the 'UniqueTag' class is to provide clear error +-- messages when the tag uniqueness property is violated. You should never +-- write instances for it unless you know what you're doing. +class UniqueTag a + +type family IsUnique (x :: k) (as :: [k]) :: Constraint where + IsUnique x (x ': as) = UniqueTag x + IsUnique x (a ': as) = IsUnique x as + IsUnique x '[] = () + +type family Unique (as :: [k]) :: Constraint where + Unique '[] = () + Unique (a ': as) = (IsUnique a as, Unique as) + +-- | +-- The 'UniqueTags` constraint placed on a type variable representing a +-- monad transformer stack ensures that every tag in the stack appears +-- only once. +type family UniqueTags (m :: * -> *) :: Constraint where + UniqueTags m = Unique (Tags m) + +-- | +-- Type-restricted version of 'id' that adds a 'UniqueTags' constraint to +-- the provided monadic value. +ensureUniqueTags :: UniqueTags m => m a -> m a +ensureUniqueTags = id + +type family ListMapTag (as :: [* -> *]) :: [*] where + ListMapTag '[] = '[] + ListMapTag (a ': as) = MaybeToList (Tag a) ++ ListMapTag as + +-- | The 'Taggable' class defines the type families to manage tags in monad +-- transformer stacks. Its kind is restricted to @* -> *@ to prevent incorrect +-- instances. +class Taggable (m :: * -> *) where + + -- | The 'Tag' type family equals @Nothing@ for most types, but for tagged + -- monad transformers it equals @Just tag@. + type Tag m :: Maybe * + type instance Tag m = 'Nothing + + -- | The 'Inner' type family equals @Nothing@ for most types, but for + -- monad transformers with inner monad @m@ it equals @Just m@. + type Inner m :: Maybe (* -> *) + type instance Inner m = 'Nothing + +type family Inners' m where + Inners' 'Nothing = '[] + Inners' ('Just n) = n ': Inners n + +-- | The 'Inners' type function recursively applies 'Inner' and returns the +-- results in a type-level list. +type Inners m = Inners' (Inner m) + +instance Taggable IO +instance Taggable Identity + +instance Taggable Maybe +instance Taggable Last +instance Taggable First +instance Taggable ((->) r) +instance Taggable STM +instance Taggable (Either e) +instance Taggable Proxy +instance Taggable (Strict.ST s) +instance Taggable (Lazy.ST s) + +instance Taggable (Trans.ContT r m) where + type Inner (Trans.ContT r m) = 'Just m + +instance Taggable (Trans.ExceptT e m) where + type Inner (Trans.ExceptT e m) = 'Just m + +instance Taggable (Trans.IdentityT m) where + type Inner (Trans.IdentityT m) = 'Just m + +instance Taggable (Trans.ListT m) where + type Inner (Trans.ListT m) = 'Just m + +instance Taggable (Trans.MaybeT m) where + type Inner (Trans.MaybeT m) = 'Just m + +instance Taggable (Trans.ReaderT r m) where + type Inner (Trans.ReaderT r m) = 'Just m + +instance Taggable (Trans.Lazy.StateT s m) where + type Inner (Trans.Lazy.StateT s m) = 'Just m + +instance Taggable (Trans.Strict.StateT s m) where + type Inner (Trans.Strict.StateT s m) = 'Just m + +instance Taggable (Trans.Lazy.WriterT w m) where + type Inner (Trans.Lazy.WriterT w m) = 'Just m + +instance Taggable (Trans.Strict.WriterT w m) where + type Inner (Trans.Strict.WriterT w m) = 'Just m + +-- | The 'Tags' type function returns a type-level list of all tags in +-- a monad transformer stack. Requires 'Taggable' instances. +type Tags (m :: * -> *) = MaybeToList (Tag m) ++ ListMapTag (Inners m) + +-- | The 'Tagged' type class establishes a relationship between a tagged +-- monad transformer and its untagged counterpart. +class (Taggable m, Tag m ~ 'Just tag) => Tagged m tag | m -> tag where + + type Untagged m :: * -> * + + tagged :: proxy tag -> Untagged m a -> m a + default tagged :: NT.Newtype (m a) => proxy tag -> NT.O (m a) -> m a + tagged _ = NT.pack + + untagged :: proxy tag -> m a -> Untagged m a + default untagged :: NT.Newtype (m a) => proxy tag -> m a -> NT.O (m a) + untagged _ = NT.unpack diff --git a/src/Control/Ether/Util.hs b/src/Control/Ether/Util.hs new file mode 100644 --- /dev/null +++ b/src/Control/Ether/Util.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +module Control.Ether.Util + ( liftCatch_ExceptT + , liftListen_WriterT + , liftPass_WriterT + , type (++) + , MaybeToList + ) where + +import qualified Control.Monad.Signatures as Sig +import qualified Control.Monad.Trans.Except as Trans +import qualified Control.Monad.Trans.Writer as Trans + +type family (as :: [*]) ++ (bs :: [*]) :: [*] where + '[] ++ bs = bs + (a ': as) ++ bs = a ': (as ++ bs) + +type family MaybeToList (mt :: Maybe k) :: [k] where + MaybeToList 'Nothing = '[] + MaybeToList ('Just t) = '[t] + +liftCatch_ExceptT :: Sig.Catch e m (Either e' a) -> Sig.Catch e (Trans.ExceptT e' m) a +liftCatch_ExceptT catchE m h = Trans.ExceptT $ catchE (Trans.runExceptT m) (Trans.runExceptT . h) + +-- TODO: Not sure if correct +liftListen_WriterT :: Monad m => Sig.Listen w' m (a, w) -> Sig.Listen w' (Trans.WriterT w m) a +liftListen_WriterT listen m = Trans.WriterT $ do + ~((a, w'), w) <- listen (Trans.runWriterT m) + return ((a, w), w') + +-- TODO: Not sure if correct +liftPass_WriterT :: Monad m => Sig.Pass w' m (a, w) -> Sig.Pass w' (Trans.WriterT w m) a +liftPass_WriterT pass m = Trans.WriterT $ pass $ do + ~((a, f), w) <- Trans.runWriterT m + return ((a, w), f) diff --git a/src/Control/Ether/Wrapped.hs b/src/Control/Ether/Wrapped.hs new file mode 100644 --- /dev/null +++ b/src/Control/Ether/Wrapped.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | +Annotating monads with tags to turn untagged constraints into tagged ones. + +> import qualified Control.Monad.State as T +> import Control.Ether.TH (ethereal) +> import Control.Monad.Ether.State (MonadState) +> import Control.Ether.Wrapped (ethered) +> +> ethereal "Foo" "foo" +> +> f :: T.MonadState Int m => m String +> f = fmap show T.get +> +> g :: MonadState Foo Int m => m String +> g = ethered foo f +-} + +module Control.Ether.Wrapped + ( WrappedEther(..) + , ethered + ) where + +import Data.Proxy (Proxy(Proxy)) +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus) +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Ether.Reader.Class +import Control.Monad.Ether.State.Class +import Control.Monad.Ether.Except.Class +import Control.Monad.Ether.Writer.Class + +import qualified Control.Monad.Reader as Class +import qualified Control.Monad.State as Class +import qualified Control.Monad.Except as Class +import qualified Control.Monad.Writer as Class + +-- | Wrap a monad to attach a tag to it. +newtype WrappedEther tag m a = WrapEther { unwrapEther :: m a } + deriving ( Functor, Applicative, Alternative, Monad, MonadPlus + , MonadFix, MonadIO ) + +-- | Annotate a polymorphic monadic computation with a tag. +ethered :: proxy tag -> WrappedEther tag m a -> m a +ethered _proxy = unwrapEther + +instance MonadReader tag r m => Class.MonadReader r (WrappedEther tag m) where + ask = WrapEther $ ask (Proxy :: Proxy tag) + local f = WrapEther . local (Proxy :: Proxy tag) f . unwrapEther + +instance MonadReader tag r m => MonadReader tag r (WrappedEther tag' m) where + ask t = WrapEther $ ask t + local t f = WrapEther . local t f . unwrapEther + +instance MonadState tag s m => Class.MonadState s (WrappedEther tag m) where + get = WrapEther $ get (Proxy :: Proxy tag) + put = WrapEther . put (Proxy :: Proxy tag) + +instance MonadState tag s m => MonadState tag s (WrappedEther tag' m) where + get t = WrapEther $ get t + put t = WrapEther . put t + +instance MonadExcept tag e m => Class.MonadError e (WrappedEther tag m) where + throwError = WrapEther . throw (Proxy :: Proxy tag) + catchError m h = WrapEther $ catch (Proxy :: Proxy tag) (unwrapEther m) (unwrapEther . h) + +instance MonadExcept tag e m => MonadExcept tag e (WrappedEther tag' m) where + throw t = WrapEther . throw t + catch t m h = WrapEther $ catch t (unwrapEther m) (unwrapEther . h) + +instance MonadWriter tag w m => Class.MonadWriter w (WrappedEther tag m) where + tell = WrapEther . tell (Proxy :: Proxy tag) + listen = WrapEther . listen (Proxy :: Proxy tag) . unwrapEther + pass = WrapEther . pass (Proxy :: Proxy tag) . unwrapEther + +instance MonadWriter tag w m => MonadWriter tag w (WrappedEther tag' m) where + tell t = WrapEther . tell t + listen t = WrapEther . listen t . unwrapEther + pass t = WrapEther . pass t . unwrapEther diff --git a/src/Control/Monad/Ether/Except.hs b/src/Control/Monad/Ether/Except.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Except.hs @@ -0,0 +1,19 @@ + +-- | See "Control.Monad.Except". + +module Control.Monad.Ether.Except + ( + -- * MonadExcept class + MonadExcept(..) + -- * The Except monad + , Except + , runExcept + -- * The ExceptT monad transformer + , ExceptT + , exceptT + , runExceptT + , mapExceptT + ) where + +import Control.Monad.Ether.Except.Class +import Control.Monad.Trans.Ether.Except hiding (throw, catch) diff --git a/src/Control/Monad/Ether/Except/Class.hs b/src/Control/Monad/Ether/Except/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Except/Class.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | See "Control.Monad.Except". + +module Control.Monad.Ether.Except.Class + ( MonadExcept(..) + ) where + +import Data.Proxy (Proxy(Proxy)) +import Control.Monad.Trans (lift) + +import Control.Monad.Trans.Ether.Except hiding (throw, catch) +import qualified Control.Monad.Trans.Ether.Except as E +import qualified Control.Monad.Trans.Ether.Reader as R +import qualified Control.Monad.Trans.Ether.Writer as W +import qualified Control.Monad.Trans.Ether.State.Lazy as S.L +import qualified Control.Monad.Trans.Ether.State.Strict as S.S +import qualified Control.Ether.Util as Util + +-- for mtl instances +import qualified Control.Monad.Trans.Except as Trans.E +import qualified Control.Monad.Trans.Identity as Trans.I +import qualified Control.Monad.Trans.List as Trans.L +import qualified Control.Monad.Trans.Maybe as Trans.M +import qualified Control.Monad.Trans.Reader as Trans.R +import qualified Control.Monad.Trans.State.Lazy as Trans.S.Lazy +import qualified Control.Monad.Trans.State.Strict as Trans.S.Strict +import qualified Control.Monad.Trans.Writer.Lazy as Trans.W.Lazy +import qualified Control.Monad.Trans.Writer.Strict as Trans.W.Strict + + +-- | See 'Control.Monad.Except.MonadError'. +class Monad m => MonadExcept tag e m | m tag -> e where + + -- | Is used within a monadic computation to begin exception processing. + throw :: proxy tag -> e -> m a + + -- | A handler function to handle previous exceptions and return to + -- normal execution. + catch :: proxy tag -> m a -> (e -> m a) -> m a + +instance {-# OVERLAPPING #-} Monad m => MonadExcept tag e (ExceptT tag e m) where + throw = E.throw + catch = E.catch + +instance MonadExcept tag e m => MonadExcept tag e (ExceptT tag' e' m) where + throw t = lift . throw t + catch t = liftCatch Proxy (catch t) + +-- Instances for other tagged transformers + +instance MonadExcept tag e m => MonadExcept tag e (R.ReaderT tag' r m) where + throw t = lift . throw t + catch t = R.liftCatch Proxy (catch t) + +instance (Monoid w, MonadExcept tag e m) => MonadExcept tag e (W.WriterT tag' w m) where + throw t = lift . throw t + catch t = W.liftCatch Proxy (catch t) + +instance MonadExcept tag e m => MonadExcept tag e (S.L.StateT tag' s m) where + throw t = lift . throw t + catch t = S.L.liftCatch Proxy (catch t) + +instance MonadExcept tag e m => MonadExcept tag e (S.S.StateT tag' s m) where + throw t = lift . throw t + catch t = S.S.liftCatch Proxy (catch t) + + +-- Instances for mtl transformers + +instance MonadExcept tag e m => MonadExcept tag e (Trans.E.ExceptT e' m) where + throw t = lift . throw t + catch t = Util.liftCatch_ExceptT (catch t) + +instance MonadExcept tag e m => MonadExcept tag e (Trans.I.IdentityT m) where + throw t = lift . throw t + catch t = Trans.I.liftCatch (catch t) + +instance MonadExcept tag e m => MonadExcept tag e (Trans.L.ListT m) where + throw t = lift . throw t + catch t = Trans.L.liftCatch (catch t) + +instance MonadExcept tag e m => MonadExcept tag e (Trans.M.MaybeT m) where + throw t = lift . throw t + catch t = Trans.M.liftCatch (catch t) + +instance MonadExcept tag e m => MonadExcept tag e (Trans.R.ReaderT r m) where + throw t = lift . throw t + catch t = Trans.R.liftCatch (catch t) + +instance MonadExcept tag e m => MonadExcept tag e (Trans.S.Lazy.StateT s m) where + throw t = lift . throw t + catch t = Trans.S.Lazy.liftCatch (catch t) + +instance MonadExcept tag e m => MonadExcept tag e (Trans.S.Strict.StateT s m) where + throw t = lift . throw t + catch t = Trans.S.Strict.liftCatch (catch t) + +instance (Monoid w, MonadExcept tag e m) => MonadExcept tag e (Trans.W.Lazy.WriterT w m) where + throw t = lift . throw t + catch t = Trans.W.Lazy.liftCatch (catch t) + +instance (Monoid w, MonadExcept tag e m) => MonadExcept tag e (Trans.W.Strict.WriterT w m) where + throw t = lift . throw t + catch t = Trans.W.Strict.liftCatch (catch t) diff --git a/src/Control/Monad/Ether/Implicit/Except.hs b/src/Control/Monad/Ether/Implicit/Except.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Implicit/Except.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | See "Control.Monad.Ether.Except". + +module Control.Monad.Ether.Implicit.Except + ( + -- * MonadExcept class + MonadExcept + , throw + , catch + -- * The Except monad + , Except + , runExcept + -- * The ExceptT monad transformer + , ExceptT + , exceptT + , runExceptT + , mapExceptT + ) where + +import Data.Proxy +import qualified Control.Monad.Ether.Except as Explicit + +-- | See 'Control.Monad.Ether.Except.MonadExcept'. +type MonadExcept e = Explicit.MonadExcept e e + +-- | See 'Control.Monad.Ether.Except.throw'. +throw :: forall e m a . MonadExcept e m => e -> m a +throw = Explicit.throw (Proxy :: Proxy e) + +-- | See 'Control.Monad.Ether.Except.catch'. +catch :: forall e m a . MonadExcept e m => m a -> (e -> m a) -> m a +catch = Explicit.catch (Proxy :: Proxy e) + +-- | See 'Control.Monad.Ether.Except.Except'. +type Except e = Explicit.Except e e + +-- | See 'Control.Monad.Ether.Except.runExcept'. +runExcept :: Except e a -> Either e a +runExcept = Explicit.runExcept Proxy + +-- | See 'Control.Monad.Ether.Except.ExceptT'. +type ExceptT e = Explicit.ExceptT e e + +-- | See 'Control.Monad.Ether.Except.exceptT'. +exceptT :: m (Either e a) -> ExceptT e m a +exceptT = Explicit.exceptT Proxy + +-- | See 'Control.Monad.Ether.Except.runExceptT'. +runExceptT :: ExceptT e m a -> m (Either e a) +runExceptT = Explicit.runExceptT Proxy + +-- | See 'Control.Monad.Ether.Except.mapExceptT'. +-- Note that due to implicit tagging the exception type cannot be changed. +mapExceptT :: (m (Either e a) -> n (Either e b)) -> ExceptT e m a -> ExceptT e n b +mapExceptT = Explicit.mapExceptT Proxy diff --git a/src/Control/Monad/Ether/Implicit/Except/TH.hs b/src/Control/Monad/Ether/Implicit/Except/TH.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Implicit/Except/TH.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Template Haskell utilities for exception handling. + +module Control.Monad.Ether.Implicit.Except.TH (try', try) where + +import qualified Language.Haskell.TH as TH +import Control.Ether.TH (deepN) +import Control.Monad.Ether.Implicit.Except + +-- | Basic building block for 'try'. Runs an 'ExceptT' with a handler. +try' :: Functor m => ExceptT e m a -> (e -> a) -> m a +try' m h = either h id <$> runExceptT m + +-- | Handle @n@ exceptions with supplied handlers. +-- +-- > $(try 3) monadicComputation +-- > (\Exception1 -> ...) +-- > (\Exception2 -> ...) +-- > (\Exception3 -> ...) +try :: Int -> TH.ExpQ +try n = deepN n [|try'|] diff --git a/src/Control/Monad/Ether/Implicit/Reader.hs b/src/Control/Monad/Ether/Implicit/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Implicit/Reader.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | See "Control.Monad.Ether.Reader". + +module Control.Monad.Ether.Implicit.Reader + ( + -- * MonadReader class + MonadReader + , local + , ask + , reader + , asks + -- * The Reader monad + , Reader + , runReader + -- * The ReaderT monad transformer + , ReaderT + , readerT + , runReaderT + , mapReaderT + ) where + +import Data.Proxy +import qualified Control.Monad.Ether.Reader as Explicit + +-- | See 'Control.Monad.Ether.Reader.ReaderT'. +type ReaderT r = Explicit.ReaderT r r + +-- | See 'Control.Monad.Ether.Reader.Reader'. +type Reader r = Explicit.Reader r r + +-- | See 'Control.Monad.Ether.Reader.readerT'. +readerT :: (r -> m a) -> ReaderT r m a +readerT = Explicit.readerT Proxy + +-- | See 'Control.Monad.Ether.Reader.runReaderT'. +runReaderT :: ReaderT r m a -> r -> m a +runReaderT = Explicit.runReaderT Proxy + +-- | See 'Control.Monad.Ether.Reader.runReader'. +runReader :: Reader r a -> r -> a +runReader = Explicit.runReader Proxy + +-- | See 'Control.Monad.Ether.Reader.mapReaderT'. +mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b +mapReaderT = Explicit.mapReaderT Proxy + +-- | See 'Control.Monad.Ether.Reader.MonadReader'. +type MonadReader r = Explicit.MonadReader r r + +-- | See 'Control.Monad.Ether.Reader.local'. +local :: forall m r a . MonadReader r m => (r -> r) -> m a -> m a +local = Explicit.local (Proxy :: Proxy r) + +-- | See 'Control.Monad.Ether.Reader.ask'. +ask :: forall m r . MonadReader r m => m r +ask = Explicit.ask (Proxy :: Proxy r) + +-- | See 'Control.Monad.Ether.Reader.reader'. +reader :: forall m r a . MonadReader r m => (r -> a) -> m a +reader = Explicit.reader (Proxy :: Proxy r) + +-- | See 'Control.Monad.Ether.Reader.asks'. +asks :: forall m r a . MonadReader r m => (r -> a) -> m a +asks = Explicit.asks (Proxy :: Proxy r) diff --git a/src/Control/Monad/Ether/Implicit/State.hs b/src/Control/Monad/Ether/Implicit/State.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Implicit/State.hs @@ -0,0 +1,8 @@ + +-- | See "Control.Monad.Ether.State". + +module Control.Monad.Ether.Implicit.State + ( module Control.Monad.Ether.Implicit.State.Lazy + ) where + +import Control.Monad.Ether.Implicit.State.Lazy diff --git a/src/Control/Monad/Ether/Implicit/State/Lazy.hs b/src/Control/Monad/Ether/Implicit/State/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Implicit/State/Lazy.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | See "Control.Monad.Ether.State.Lazy". + +module Control.Monad.Ether.Implicit.State.Lazy + ( + -- * MonadState class + MonadState + , get + , put + , state + , modify + , gets + -- * The State monad + , State + , runState + , evalState + , execState + -- * The StateT monad transformer + , StateT + , stateT + , runStateT + , evalStateT + , execStateT + , mapStateT + ) where + +import Data.Proxy +import qualified Control.Monad.Ether.State.Lazy as Explicit + +-- | See 'Control.Monad.Ether.State.Lazy.StateT'. +type StateT s = Explicit.StateT s s + +-- | See 'Control.Monad.Ether.State.Lazy.State'. +type State s = Explicit.State s s + +-- | See 'Control.Monad.Ether.State.Lazy.stateT'. +stateT :: (s -> m (a, s)) -> StateT s m a +stateT = Explicit.stateT Proxy + +-- | See 'Control.Monad.Ether.State.Lazy.runStateT'. +runStateT :: StateT s m a -> s -> m (a, s) +runStateT = Explicit.runStateT Proxy + +-- | See 'Control.Monad.Ether.State.Lazy.runState'. +runState :: State s a -> s -> (a, s) +runState = Explicit.runState Proxy + +-- | See 'Control.Monad.Ether.State.Lazy.evalStateT'. +evalStateT :: Monad m => StateT s m a -> s -> m a +evalStateT = Explicit.evalStateT Proxy + +-- | See 'Control.Monad.Ether.State.Lazy.evalState'. +evalState :: State s a -> s -> a +evalState = Explicit.evalState Proxy + +-- | See 'Control.Monad.Ether.State.Lazy.execStateT'. +execStateT :: Monad m => StateT s m a -> s -> m s +execStateT = Explicit.execStateT Proxy + +-- | See 'Control.Monad.Ether.State.Lazy.execState'. +execState :: State s a -> s -> s +execState = Explicit.execState Proxy + +-- | See 'Control.Monad.Ether.State.Lazy.mapStateT'. +mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b +mapStateT = Explicit.mapStateT Proxy + +-- | See 'Control.Monad.Ether.State.Lazy.MonadState'. +type MonadState s = Explicit.MonadState s s + +-- | See 'Control.Monad.Ether.State.Lazy.get'. +get :: forall m s . MonadState s m => m s +get = Explicit.get (Proxy :: Proxy s) + +-- | See 'Control.Monad.Ether.State.Lazy.gets'. +gets :: forall m s a . MonadState s m => (s -> a) -> m a +gets = Explicit.gets (Proxy :: Proxy s) + +-- | See 'Control.Monad.Ether.State.Lazy.put'. +put :: forall m s . MonadState s m => s -> m () +put = Explicit.put (Proxy :: Proxy s) + +-- | See 'Control.Monad.Ether.State.Lazy.state'. +state :: forall m s a . MonadState s m => (s -> (a, s)) -> m a +state = Explicit.state (Proxy :: Proxy s) + +-- | See 'Control.Monad.Ether.State.Lazy.modify'. +modify :: forall m s . MonadState s m => (s -> s) -> m () +modify = Explicit.modify (Proxy :: Proxy s) diff --git a/src/Control/Monad/Ether/Implicit/State/Strict.hs b/src/Control/Monad/Ether/Implicit/State/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Implicit/State/Strict.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | See "Control.Monad.Ether.State.Strict". + +module Control.Monad.Ether.Implicit.State.Strict + ( + -- * MonadState class + MonadState + , get + , put + , state + , modify + , gets + -- * The State monad + , State + , runState + , evalState + , execState + -- * The StateT monad transformer + , StateT + , stateT + , runStateT + , evalStateT + , execStateT + , mapStateT + ) where + +import Data.Proxy +import qualified Control.Monad.Ether.State.Strict as Explicit + +-- | See 'Control.Monad.Ether.State.Strict.StateT'. +type StateT s = Explicit.StateT s s + +-- | See 'Control.Monad.Ether.State.Strict.State'. +type State s = Explicit.State s s + +-- | See 'Control.Monad.Ether.State.Strict.stateT'. +stateT :: (s -> m (a, s)) -> StateT s m a +stateT = Explicit.stateT Proxy + +-- | See 'Control.Monad.Ether.State.Strict.runStateT'. +runStateT :: StateT s m a -> s -> m (a, s) +runStateT = Explicit.runStateT Proxy + +-- | See 'Control.Monad.Ether.State.Strict.runState'. +runState :: State s a -> s -> (a, s) +runState = Explicit.runState Proxy + +-- | See 'Control.Monad.Ether.State.Strict.evalStateT'. +evalStateT :: Monad m => StateT s m a -> s -> m a +evalStateT = Explicit.evalStateT Proxy + +-- | See 'Control.Monad.Ether.State.Strict.evalState'. +evalState :: State s a -> s -> a +evalState = Explicit.evalState Proxy + +-- | See 'Control.Monad.Ether.State.Strict.execStateT'. +execStateT :: Monad m => StateT s m a -> s -> m s +execStateT = Explicit.execStateT Proxy + +-- | See 'Control.Monad.Ether.State.Strict.execState'. +execState :: State s a -> s -> s +execState = Explicit.execState Proxy + +-- | See 'Control.Monad.Ether.State.Strict.mapStateT'. +mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b +mapStateT = Explicit.mapStateT Proxy + +-- | See 'Control.Monad.Ether.State.Strict.MonadState'. +type MonadState s = Explicit.MonadState s s + +-- | See 'Control.Monad.Ether.State.Strict.get'. +get :: forall m s . MonadState s m => m s +get = Explicit.get (Proxy :: Proxy s) + +-- | See 'Control.Monad.Ether.State.Strict.gets'. +gets :: forall m s a . MonadState s m => (s -> a) -> m a +gets = Explicit.gets (Proxy :: Proxy s) + +-- | See 'Control.Monad.Ether.State.Strict.put'. +put :: forall m s . MonadState s m => s -> m () +put = Explicit.put (Proxy :: Proxy s) + +-- | See 'Control.Monad.Ether.State.Strict.state'. +state :: forall m s a . MonadState s m => (s -> (a, s)) -> m a +state = Explicit.state (Proxy :: Proxy s) + +-- | See 'Control.Monad.Ether.State.Strict.modify'. +modify :: forall m s . MonadState s m => (s -> s) -> m () +modify = Explicit.modify (Proxy :: Proxy s) diff --git a/src/Control/Monad/Ether/Implicit/Writer.hs b/src/Control/Monad/Ether/Implicit/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Implicit/Writer.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | See "Control.Monad.Ether.Writer". + +module Control.Monad.Ether.Implicit.Writer + ( + -- * MonadWriter class + MonadWriter + , writer + , tell + , listen + , pass + , listens + , censor + -- * The Writer monad + , Writer + , runWriter + , execWriter + -- * The WriterT monad transformer + , WriterT + , writerT + , runWriterT + , execWriterT + ) where + +import Data.Proxy +import qualified Control.Monad.Ether.Writer as Explicit + +-- | See 'Control.Monad.Ether.Writer.MonadWriter'. +type MonadWriter w = Explicit.MonadWriter w w + +-- | See 'Control.Monad.Ether.Writer.writer'. +writer :: forall m w a . MonadWriter w m => (a, w) -> m a +writer = Explicit.writer (Proxy :: Proxy w) + +-- | See 'Control.Monad.Ether.Writer.tell'. +tell :: forall m w . MonadWriter w m => w -> m () +tell = Explicit.tell (Proxy :: Proxy w) + +-- | See 'Control.Monad.Ether.Writer.listen'. +listen :: forall m w a . MonadWriter w m => m a -> m (a, w) +listen = Explicit.listen (Proxy :: Proxy w) + +-- | See 'Control.Monad.Ether.Writer.pass'. +pass :: forall m w a . MonadWriter w m => m (a, w -> w) -> m a +pass = Explicit.pass (Proxy :: Proxy w) + +-- | See 'Control.Monad.Ether.Writer.listens'. +listens :: forall m w a b . MonadWriter w m => (w -> b) -> m a -> m (a, b) +listens = Explicit.listens (Proxy :: Proxy w) + +-- | See 'Control.Monad.Ether.Writer.censor'. +censor :: forall m w a . MonadWriter w m => (w -> w) -> m a -> m a +censor = Explicit.censor (Proxy :: Proxy w) + +-- | See 'Control.Monad.Ether.Writer.Writer'. +type Writer w = Explicit.Writer w w + +-- | See 'Control.Monad.Ether.Writer.runWriter'. +runWriter :: Writer w a -> (a, w) +runWriter = Explicit.runWriter Proxy + +-- | See 'Control.Monad.Ether.Writer.execWriter'. +execWriter :: Writer w a -> w +execWriter = Explicit.execWriter Proxy + +-- | See 'Control.Monad.Ether.Writer.WriterT'. +type WriterT w = Explicit.WriterT w w + +-- | See 'Control.Monad.Ether.Writer.writerT'. +writerT :: m (a, w) -> WriterT w m a +writerT = Explicit.writerT Proxy + +-- | See 'Control.Monad.Ether.Writer.runWriterT'. +runWriterT :: WriterT w m a -> m (a, w) +runWriterT = Explicit.runWriterT Proxy + +-- | See 'Control.Monad.Ether.Writer.execWriterT'. +execWriterT :: Monad m => WriterT w m a -> m w +execWriterT = Explicit.execWriterT Proxy diff --git a/src/Control/Monad/Ether/Reader.hs b/src/Control/Monad/Ether/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Reader.hs @@ -0,0 +1,20 @@ + +-- | See "Control.Monad.Reader". + +module Control.Monad.Ether.Reader + ( + -- * MonadReader class + MonadReader(..) + , asks + -- * The Reader monad + , Reader + , runReader + -- * The ReaderT monad transformer + , ReaderT + , readerT + , runReaderT + , mapReaderT + ) where + +import Control.Monad.Ether.Reader.Class +import Control.Monad.Trans.Ether.Reader hiding (reader, ask, local) diff --git a/src/Control/Monad/Ether/Reader/Class.hs b/src/Control/Monad/Ether/Reader/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Reader/Class.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | See "Control.Monad.Reader.Class". + +module Control.Monad.Ether.Reader.Class + ( MonadReader(..) + , asks + ) where + +import Data.Proxy (Proxy(Proxy)) +import Control.Monad.Trans (lift) + +import Control.Monad.Trans.Ether.Writer (WriterT, mapWriterT) +import Control.Monad.Trans.Ether.Except (ExceptT, mapExceptT) +import Control.Monad.Trans.Ether.Reader hiding (reader, ask, local) +import qualified Control.Monad.Trans.Ether.Reader as R +import qualified Control.Monad.Trans.Ether.State.Lazy as S.L +import qualified Control.Monad.Trans.Ether.State.Strict as S.S + +-- for mtl instances +import qualified Control.Monad.Trans.Cont as Trans (ContT , liftLocal) +import qualified Control.Monad.Trans.Except as Trans (ExceptT , mapExceptT) +import qualified Control.Monad.Trans.Identity as Trans (IdentityT, mapIdentityT) +import qualified Control.Monad.Trans.List as Trans (ListT , mapListT) +import qualified Control.Monad.Trans.Maybe as Trans (MaybeT , mapMaybeT) +import qualified Control.Monad.Trans.Reader as Trans (ReaderT , mapReaderT) +import qualified Control.Monad.Trans.State.Lazy as Trans.Lazy (StateT , mapStateT) +import qualified Control.Monad.Trans.State.Strict as Trans.Strict (StateT , mapStateT) +import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy (WriterT , mapWriterT) +import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT , mapWriterT) + +-- | See 'Control.Monad.Reader.MonadReader'. +class Monad m => MonadReader tag r m | m tag -> r where + + {-# MINIMAL (ask | reader), local #-} + + -- | Retrieves the monad environment. + ask :: proxy tag -> m r + ask t = reader t id + + -- | Executes a computation in a modified environment. + local + :: proxy tag + -> (r -> r) + -- ^ The function to modify the environment. + -> m a + -- ^ @Reader@ to run in the modified environment. + -> m a + + -- | Retrieves a function of the current environment. + reader + :: proxy tag + -> (r -> a) + -- ^ The selector function to apply to the environment. + -> m a + reader t f = fmap f (ask t) + +-- | Retrieves a function of the current environment. +asks + :: MonadReader tag r m + => proxy tag + -> (r -> a) + -- ^ The selector function to apply to the environment. + -> m a +asks = reader + +instance {-# OVERLAPPING #-} Monad m => MonadReader tag r (ReaderT tag r m) where + ask = R.ask + local = R.local + reader = R.reader + +instance MonadReader tag r m => MonadReader tag r (ReaderT tag' r' m) where + ask t = lift (ask t) + local t = mapReaderT Proxy . local t + +-- Instances for other tagged transformers + +instance (Monoid w, MonadReader tag r m) => MonadReader tag r (WriterT tag' w m) where + ask t = lift (ask t) + local t = mapWriterT Proxy . local t + +instance (MonadReader tag r m) => MonadReader tag r (S.L.StateT tag' s m) where + ask t = lift (ask t) + local t = S.L.mapStateT Proxy . local t + +instance (MonadReader tag r m) => MonadReader tag r (S.S.StateT tag' s m) where + ask t = lift (ask t) + local t = S.S.mapStateT Proxy . local t + +instance (MonadReader tag r m) => MonadReader tag r (ExceptT tag' e m) where + ask t = lift (ask t) + local t = mapExceptT Proxy . local t + +-- Instances for mtl transformers + +instance MonadReader tag r m => MonadReader tag r (Trans.ContT r' m) where + ask t = lift (ask t) + local t = Trans.liftLocal (ask t) (local t) + +instance MonadReader tag r m => MonadReader tag r (Trans.ExceptT e m) where + ask t = lift (ask t) + local t = Trans.mapExceptT . local t + +instance MonadReader tag r m => MonadReader tag r (Trans.IdentityT m) where + ask t = lift (ask t) + local t = Trans.mapIdentityT . local t + +instance MonadReader tag r m => MonadReader tag r (Trans.ListT m) where + ask t = lift (ask t) + local t = Trans.mapListT . local t + +instance MonadReader tag r m => MonadReader tag r (Trans.MaybeT m) where + ask t = lift (ask t) + local t = Trans.mapMaybeT . local t + +instance MonadReader tag r m => MonadReader tag r (Trans.ReaderT r' m) where + ask t = lift (ask t) + local t = Trans.mapReaderT . local t + +instance MonadReader tag r m => MonadReader tag r (Trans.Lazy.StateT s m) where + ask t = lift (ask t) + local t = Trans.Lazy.mapStateT . local t + +instance MonadReader tag r m => MonadReader tag r (Trans.Strict.StateT s m) where + ask t = lift (ask t) + local t = Trans.Strict.mapStateT . local t + +instance (Monoid w, MonadReader tag r m) => MonadReader tag r (Trans.Lazy.WriterT w m) where + ask t = lift (ask t) + local t = Trans.Lazy.mapWriterT . local t + +instance (Monoid w, MonadReader tag r m) => MonadReader tag r (Trans.Strict.WriterT w m) where + ask t = lift (ask t) + local t = Trans.Strict.mapWriterT . local t diff --git a/src/Control/Monad/Ether/State.hs b/src/Control/Monad/Ether/State.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/State.hs @@ -0,0 +1,8 @@ + +-- | See "Control.Monad.State". + +module Control.Monad.Ether.State + ( module Control.Monad.Ether.State.Lazy + ) where + +import Control.Monad.Ether.State.Lazy diff --git a/src/Control/Monad/Ether/State/Class.hs b/src/Control/Monad/Ether/State/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/State/Class.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | See "Control.Monad.State.Class". + +module Control.Monad.Ether.State.Class + ( MonadState(..) + , modify + , gets + ) where + +import Control.Monad.Trans (lift) + +import Control.Monad.Trans.Ether.Reader (ReaderT) +import Control.Monad.Trans.Ether.Writer (WriterT) +import Control.Monad.Trans.Ether.Except (ExceptT) +import qualified Control.Monad.Trans.Ether.State.Lazy as S.L +import qualified Control.Monad.Trans.Ether.State.Strict as S.S + +-- for mtl instances +import qualified Control.Monad.Trans.Cont as Trans (ContT) +import qualified Control.Monad.Trans.Except as Trans (ExceptT) +import qualified Control.Monad.Trans.Identity as Trans (IdentityT) +import qualified Control.Monad.Trans.List as Trans (ListT) +import qualified Control.Monad.Trans.Maybe as Trans (MaybeT) +import qualified Control.Monad.Trans.Reader as Trans (ReaderT) +import qualified Control.Monad.Trans.State.Lazy as Trans.Lazy (StateT) +import qualified Control.Monad.Trans.State.Strict as Trans.Strict (StateT) +import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy (WriterT) +import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT) + +-- | See 'Control.Monad.State.MonadState'. +class Monad m => MonadState tag s m | m tag -> s where + + {-# MINIMAL state | get, put #-} + + -- | Return the state from the internals of the monad. + get :: proxy tag -> m s + get t = state t (\s -> (s, s)) + + -- | Replace the state inside the monad. + put :: proxy tag -> s -> m () + put t s = state t (\_ -> ((), s)) + + -- | Embed a simple state action into the monad. + state :: proxy tag -> (s -> (a, s)) -> m a + state t f = do + s <- get t + let ~(a, s') = f s + put t s' + return a + +-- | Modifies the state inside a state monad. +modify :: MonadState tag s m => proxy tag -> (s -> s) -> m () +modify t f = state t (\s -> ((), f s)) + +-- | Gets specific component of the state, using a projection function supplied. +gets :: MonadState tag s m => proxy tag -> (s -> a) -> m a +gets t f = fmap f (get t) + +instance {-# OVERLAPPING #-} Monad m => MonadState tag s (S.L.StateT tag s m) where + get = S.L.get + put = S.L.put + state = S.L.state + +instance MonadState tag s m => MonadState tag s (S.L.StateT tag' s' m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +instance {-# OVERLAPPING #-} Monad m => MonadState tag s (S.S.StateT tag s m) where + get = S.S.get + put = S.S.put + state = S.S.state + +instance MonadState tag s m => MonadState tag s (S.S.StateT tag' s' m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +-- Instances for other tagged transformers + +instance (MonadState tag s m) => MonadState tag s (ReaderT tag' r m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +instance (Monoid w, MonadState tag s m) => MonadState tag s (WriterT tag' w m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +instance (MonadState tag s m) => MonadState tag s (ExceptT tag' e m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +-- Instances for mtl transformers + +instance MonadState tag s m => MonadState tag s (Trans.ContT r m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +instance MonadState tag s m => MonadState tag s (Trans.ExceptT e m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +instance MonadState tag s m => MonadState tag s (Trans.IdentityT m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +instance MonadState tag s m => MonadState tag s (Trans.ListT m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +instance MonadState tag s m => MonadState tag s (Trans.MaybeT m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +instance MonadState tag s m => MonadState tag s (Trans.ReaderT r m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +instance MonadState tag s m => MonadState tag s (Trans.Lazy.StateT s' m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +instance MonadState tag s m => MonadState tag s (Trans.Strict.StateT s' m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +instance (Monoid w, MonadState tag s m) => MonadState tag s (Trans.Lazy.WriterT w m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t + +instance (Monoid w, MonadState tag s m) => MonadState tag s (Trans.Strict.WriterT w m) where + get t = lift (get t) + put t = lift . put t + state t = lift . state t diff --git a/src/Control/Monad/Ether/State/Lazy.hs b/src/Control/Monad/Ether/State/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/State/Lazy.hs @@ -0,0 +1,25 @@ + +-- | See "Control.Monad.State.Lazy". + +module Control.Monad.Ether.State.Lazy + ( + -- * MonadState class + MonadState(..) + , modify + , gets + -- * The State monad + , State + , runState + , evalState + , execState + -- * The StateT monad transformer + , StateT + , stateT + , runStateT + , evalStateT + , execStateT + , mapStateT + ) where + +import Control.Monad.Ether.State.Class +import Control.Monad.Trans.Ether.State.Lazy hiding (state, get, put) diff --git a/src/Control/Monad/Ether/State/Strict.hs b/src/Control/Monad/Ether/State/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/State/Strict.hs @@ -0,0 +1,25 @@ + +-- | See "Control.Monad.State.Strict". + +module Control.Monad.Ether.State.Strict + ( + -- * MonadState class + MonadState(..) + , modify + , gets + -- * The State monad + , State + , runState + , evalState + , execState + -- * The StateT monad transformer + , StateT + , stateT + , runStateT + , evalStateT + , execStateT + , mapStateT + ) where + +import Control.Monad.Ether.State.Class +import Control.Monad.Trans.Ether.State.Strict hiding (state, get, put) diff --git a/src/Control/Monad/Ether/Writer.hs b/src/Control/Monad/Ether/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Writer.hs @@ -0,0 +1,23 @@ + +-- | See "Control.Monad.Writer". + +module Control.Monad.Ether.Writer + ( + -- * MonadWriter class + MonadWriter(..) + , listens + , censor + -- * The Writer monad + , Writer + , runWriter + , execWriter + -- * The WriterT monad transformer + , WriterT + , writerT + , runWriterT + , execWriterT + , mapWriterT + ) where + +import Control.Monad.Ether.Writer.Class +import Control.Monad.Trans.Ether.Writer hiding (writer, tell, listen, pass) diff --git a/src/Control/Monad/Ether/Writer/Class.hs b/src/Control/Monad/Ether/Writer/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ether/Writer/Class.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | See "Control.Monad.Writer.Class". + +module Control.Monad.Ether.Writer.Class + ( MonadWriter(..) + , listens + , censor + ) where + +import Data.Proxy (Proxy(Proxy)) +import Control.Monad.Trans (lift) + +import Control.Monad.Trans.Ether.Writer hiding (writer, tell, listen, pass) +import qualified Control.Monad.Trans.Ether.Reader as R +import qualified Control.Monad.Trans.Ether.State.Lazy as S.L +import qualified Control.Monad.Trans.Ether.State.Strict as S.S +import qualified Control.Monad.Trans.Ether.Except as E +import qualified Control.Monad.Trans.Ether.Writer as W +import qualified Control.Ether.Util as Util + +-- for mtl instances +import qualified Control.Monad.Trans.Except as Trans.E +import qualified Control.Monad.Trans.Identity as Trans.I +import qualified Control.Monad.Trans.Maybe as Trans.M +import qualified Control.Monad.Trans.Reader as Trans.R +import qualified Control.Monad.Trans.State.Lazy as Trans.S.Lazy +import qualified Control.Monad.Trans.State.Strict as Trans.S.Strict +import qualified Control.Monad.Trans.Writer.Lazy as Trans.W.Lazy + +-- | See 'Control.Monad.Writer.MonadWriter'. +class (Monoid w, Monad m) => MonadWriter tag w m | m tag -> w where + + {-# MINIMAL (writer | tell), listen, pass #-} + + -- | Embed a simple writer action. + writer :: proxy tag -> (a, w) -> m a + writer t ~(a, w) = do + tell t w + return a + + -- | Append a value to the accumulator within the monad. + tell :: proxy tag -> w -> m () + tell t w = writer t ((),w) + + -- | Execute an action and add its accumulator + -- to the value of the computation. + listen :: proxy tag -> m a -> m (a, w) + + -- | Execute an action which returns a value and a function, + -- and return the value, applying the function to the accumulator. + pass :: proxy tag -> m (a, w -> w) -> m a + +-- | Execute an action and add the result of applying the given function to +-- its accumulator to the value of the computation. +listens :: MonadWriter tag w m => proxy tag -> (w -> b) -> m a -> m (a, b) +listens t f m = do + ~(a, w) <- listen t m + return (a, f w) + +-- | Execute an action and apply a function to its accumulator. +censor :: MonadWriter tag w m => proxy tag -> (w -> w) -> m a -> m a +censor t f m = pass t $ do + a <- m + return (a, f) + +instance {-# OVERLAPPING #-} (Monoid w, Monad m) => MonadWriter tag w (WriterT tag w m) where + writer = W.writer + tell = W.tell + listen = W.listen + pass = W.pass + +instance (Monoid w', MonadWriter tag w m) => MonadWriter tag w (WriterT tag' w' m) where + writer t = lift . writer t + tell t = lift . tell t + listen t = W.liftListen Proxy (listen t) + pass t = W.liftPass Proxy (pass t) + +-- Instances for other tagged transformers + +instance (MonadWriter tag w m) => MonadWriter tag w (R.ReaderT tag' r m) where + writer t = lift . writer t + tell t = lift . tell t + listen t = R.mapReaderT Proxy (listen t) + pass t = R.mapReaderT Proxy (pass t) + +instance (MonadWriter tag w m) => MonadWriter tag w (E.ExceptT tag' e m) where + writer t = lift . writer t + tell t = lift . tell t + listen t = E.liftListen Proxy (listen t) + pass t = E.liftPass Proxy (pass t) + +instance (MonadWriter tag w m) => MonadWriter tag w (S.L.StateT tag' e m) where + writer t = lift . writer t + tell t = lift . tell t + listen t = S.L.liftListen Proxy (listen t) + pass t = S.L.liftPass Proxy (pass t) + +instance (MonadWriter tag w m) => MonadWriter tag w (S.S.StateT tag' e m) where + writer t = lift . writer t + tell t = lift . tell t + listen t = S.S.liftListen Proxy (listen t) + pass t = S.S.liftPass Proxy (pass t) + +-- Instances for mtl transformers + +instance (MonadWriter tag w m) => MonadWriter tag w (Trans.E.ExceptT e m) where + writer t = lift . writer t + tell t = lift . tell t + listen t = Trans.E.liftListen (listen t) + pass t = Trans.E.liftPass (pass t) + +instance (MonadWriter tag w m) => MonadWriter tag w (Trans.I.IdentityT m) where + writer t = lift . writer t + tell t = lift . tell t + listen t = Trans.I.mapIdentityT (listen t) + pass t = Trans.I.mapIdentityT (pass t) + +instance (MonadWriter tag w m) => MonadWriter tag w (Trans.M.MaybeT m) where + writer t = lift . writer t + tell t = lift . tell t + listen t = Trans.M.liftListen (listen t) + pass t = Trans.M.liftPass (pass t) + +instance (MonadWriter tag w m) => MonadWriter tag w (Trans.R.ReaderT r m) where + writer t = lift . writer t + tell t = lift . tell t + listen t = Trans.R.mapReaderT (listen t) + pass t = Trans.R.mapReaderT (pass t) + +instance (MonadWriter tag w m) => MonadWriter tag w (Trans.S.Lazy.StateT s m) where + writer t = lift . writer t + tell t = lift . tell t + listen t = Trans.S.Lazy.liftListen (listen t) + pass t = Trans.S.Lazy.liftPass (pass t) + +instance (MonadWriter tag w m) => MonadWriter tag w (Trans.S.Strict.StateT s m) where + writer t = lift . writer t + tell t = lift . tell t + listen t = Trans.S.Strict.liftListen (listen t) + pass t = Trans.S.Strict.liftPass (pass t) + +instance (Monoid w', MonadWriter tag w m) => MonadWriter tag w (Trans.W.Lazy.WriterT w' m) where + writer t = lift . writer t + tell t = lift . tell t + listen t = Util.liftListen_WriterT (listen t) + pass t = Util.liftPass_WriterT (pass t) diff --git a/src/Control/Monad/Trans/Ether/Except.hs b/src/Control/Monad/Trans/Ether/Except.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Ether/Except.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | See "Control.Monad.Trans.Except". + +module Control.Monad.Trans.Ether.Except + ( + -- * The Except monad + Except + , except + , runExcept + -- * The ExceptT monad transformer + , ExceptT + , exceptT + , runExceptT + , mapExceptT + -- * Exception operations + , throw + , catch + -- * Lifting other operations + , liftCallCC + , liftListen + , liftPass + , liftCatch + ) where + +import Data.Proxy (Proxy(Proxy)) +import Data.Functor.Identity (Identity(..)) +import Data.Coerce (coerce) +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus) +import Control.Monad.Fix (MonadFix) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.IO.Class (MonadIO) +import Control.Ether.Tagged (Taggable(..), Tagged(..)) +import qualified Control.Ether.Util as Util +import GHC.Generics (Generic) +import qualified Control.Newtype as NT + +import qualified Control.Monad.Signatures as Sig +import qualified Control.Monad.Trans.Except as Trans + +import qualified Control.Monad.Cont.Class as Class +import qualified Control.Monad.Reader.Class as Class +import qualified Control.Monad.State.Class as Class +import qualified Control.Monad.Writer.Class as Class +import qualified Control.Monad.Error.Class as Class + + +-- | The parameterizable exception monad. +-- +-- Computations are either exceptions or normal values. +-- +-- The 'return' function returns a normal value, while '>>=' exits on +-- the first exception. +type Except tag e = ExceptT tag e Identity + +-- | Runs an 'Except' and returns either an exception or a normal value. +runExcept :: proxy tag -> Except tag e a -> Either e a +runExcept t = Trans.runExcept . untagged t + +-- | The exception monad transformer. +-- +-- The 'return' function returns a normal value, while '>>=' exits on +-- the first exception. + +newtype ExceptT tag e m a = ExceptT (Trans.ExceptT e m a) + deriving ( Generic + , Functor, Applicative, Alternative, Monad, MonadPlus + , MonadFix, MonadTrans, MonadIO ) + +instance NT.Newtype (ExceptT tag e m a) + +instance Taggable (ExceptT tag e m) where + type Tag (ExceptT tag e m) = 'Just tag + type Inner (ExceptT tag e m) = 'Just m + +instance Tagged (ExceptT tag e m) tag where + type Untagged (ExceptT tag e m) = Trans.ExceptT e m + +-- | Constructor for computations in the exception monad transformer. +exceptT :: proxy tag -> m (Either e a) -> ExceptT tag e m a +exceptT t = tagged t . Trans.ExceptT + +-- | Constructor for computations in the exception monad +-- (the inverse of 'runExcept'). +except :: Monad m => proxy tag -> Either e a -> ExceptT tag e m a +except t = exceptT t . return + +-- | Runs an 'ExceptT' and returns either an exception or a normal value. +runExceptT :: proxy tag -> ExceptT tag e m a -> m (Either e a) +runExceptT t = Trans.runExceptT . untagged t + +-- | Transforms the computation inside an 'ExceptT'. +-- +-- * @'runExceptT' tag ('mapExceptT' tag f m) = f ('runExceptT' tag m)@ +mapExceptT + :: proxy tag + -> (m (Either e a) -> n (Either e' b)) + -> ExceptT tag e m a + -> ExceptT tag e' n b +mapExceptT t f m = tagged t $ Trans.mapExceptT f (coerce m) + +-- | Is used within a monadic computation to begin exception processing. +throw :: Monad m => proxy tag -> e -> ExceptT tag e m a +throw t = tagged t . Trans.throwE + +-- | A handler function to handle previous exceptions and return to normal execution. +catch :: Monad m => proxy tag -> ExceptT tag e m a -> (e -> ExceptT tag e m a) -> ExceptT tag e m a +catch t m h = tagged t $ Trans.catchE (coerce m) (coerce . h) + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: proxy tag -> Sig.CallCC m (Either e a) (Either e b) -> Sig.CallCC (ExceptT tag e m) a b +liftCallCC t callCC f = tagged t $ Trans.liftCallCC callCC (coerce f) + +-- | Lift a @listen@ operation to the new monad. +liftListen :: Monad m => proxy tag -> Sig.Listen w m (Either e a) -> Sig.Listen w (ExceptT tag e m) a +liftListen t listen m = tagged t $ Trans.liftListen listen (coerce m) + +-- | Lift a @pass@ operation to the new monad. +liftPass :: Monad m => proxy tag -> Sig.Pass w m (Either e a) -> Sig.Pass w (ExceptT tag e m) a +liftPass t pass m = tagged t $ Trans.liftPass pass (coerce m) + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: proxy tag -> Sig.Catch e m (Either e' a) -> Sig.Catch e (ExceptT tag e' m) a +liftCatch t catchE m h = tagged t $ Util.liftCatch_ExceptT catchE (coerce m) (coerce h) + +instance Class.MonadCont m => Class.MonadCont (ExceptT tag e m) where + callCC = liftCallCC Proxy Class.callCC + +instance Class.MonadReader r m => Class.MonadReader r (ExceptT tag e m) where + ask = lift Class.ask + local = mapExceptT Proxy . Class.local + reader = lift . Class.reader + +instance Class.MonadState s m => Class.MonadState s (ExceptT tag e m) where + get = lift Class.get + put = lift . Class.put + state = lift . Class.state + +instance Class.MonadWriter w m => Class.MonadWriter w (ExceptT tag e m) where + writer = lift . Class.writer + tell = lift . Class.tell + listen = liftListen Proxy Class.listen + pass = liftPass Proxy Class.pass + +instance Class.MonadError e' m => Class.MonadError e' (ExceptT tag e m) where + throwError = lift . Class.throwError + catchError = liftCatch Proxy Class.catchError diff --git a/src/Control/Monad/Trans/Ether/Reader.hs b/src/Control/Monad/Trans/Ether/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Ether/Reader.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | See "Control.Monad.Trans.Reader". + +module Control.Monad.Trans.Ether.Reader + ( + -- * The Reader monad + Reader + , reader + , runReader + -- * The ReaderT monad transformer + , ReaderT + , readerT + , runReaderT + , mapReaderT + , withReaderT + -- * Reader operations + , ask + , local + -- * Lifting other operations + , liftCatch + , liftCallCC + ) where + +import Data.Proxy (Proxy(Proxy)) +import Data.Functor.Identity (Identity(..)) +import Data.Coerce (coerce) +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus) +import Control.Monad.Fix (MonadFix) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.IO.Class (MonadIO) +import Control.Ether.Tagged (Taggable(..), Tagged(..)) +import GHC.Generics (Generic) +import qualified Control.Newtype as NT + +import qualified Control.Monad.Signatures as Sig +import qualified Control.Monad.Trans.Reader as Trans + +import qualified Control.Monad.Cont.Class as Class +import qualified Control.Monad.Reader.Class as Class +import qualified Control.Monad.State.Class as Class +import qualified Control.Monad.Writer.Class as Class +import qualified Control.Monad.Error.Class as Class + +-- | The parameterizable reader monad. +-- +-- Computations are functions of a shared environment. +-- +-- The 'return' function ignores the environment, while '>>=' passes +-- the inherited environment to both subcomputations. +type Reader tag r = ReaderT tag r Identity + +-- | The reader monad transformer, +-- which adds a read-only environment to the given monad. +-- +-- The 'return' function ignores the environment, while '>>=' passes +-- the inherited environment to both subcomputations. +newtype ReaderT tag r m a = ReaderT (Trans.ReaderT r m a) + deriving ( Generic + , Functor, Applicative, Alternative, Monad, MonadPlus + , MonadFix, MonadTrans, MonadIO ) + +instance NT.Newtype (ReaderT tag r m a) + +instance Taggable (ReaderT tag r m) where + type Tag (ReaderT tag r m) = 'Just tag + type Inner (ReaderT tag r m) = 'Just m + +instance Tagged (ReaderT tag r m) tag where + type Untagged (ReaderT tag r m) = Trans.ReaderT r m + +-- | Constructor for computations in the reader monad transformer. +readerT :: proxy tag -> (r -> m a) -> ReaderT tag r m a +readerT t = tagged t . Trans.ReaderT + +-- | Constructor for computations in the reader monad +-- (the inverse of 'runReader'). +reader :: Monad m => proxy tag -> (r -> a) -> ReaderT tag r m a +reader t = tagged t . Trans.reader + +-- | Runs a 'ReaderT' with the given environment +-- and returns the vinal value. +runReaderT :: proxy tag -> ReaderT tag r m a -> r -> m a +runReaderT t = Trans.runReaderT . untagged t + +-- | Runs a 'ReaderT' with the given environment +-- and returns the vinal value. +runReader :: proxy tag -> Reader tag r a -> r -> a +runReader t = Trans.runReader . untagged t + +-- | Transform the computation inside a 'ReaderT'. +-- +-- * @'runReaderT' tag ('mapReaderT' tag f m) = f . 'runReaderT' tag m@ +mapReaderT :: proxy tag -> (m a -> n b) -> ReaderT tag r m a -> ReaderT tag r n b +mapReaderT t f m = tagged t $ Trans.mapReaderT f (coerce m) + +-- | Execute a computation in a modified environment +-- (a more general version of 'local'). +-- +-- * @'runReaderT' tag ('withReaderT' tag f m) = 'runReaderT' tag m . f@ +withReaderT + :: proxy tag + -> (r' -> r) + -- ^ The function to modify the environment. + -> ReaderT tag r m a + -- ^ Computation to run in the modified environment. + -> ReaderT tag r' m a +withReaderT t f m = tagged t $ Trans.withReaderT f (coerce m) + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: proxy tag -> Sig.Catch e m a -> Sig.Catch e (ReaderT tag r m) a +liftCatch t f m h = tagged t $ Trans.liftCatch f (coerce m) (coerce h) + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: proxy tag -> Sig.CallCC m a b -> Sig.CallCC (ReaderT tag r m) a b +liftCallCC t callCC f = tagged t $ Trans.liftCallCC callCC (coerce f) + +-- | Fetch the value of the environment. +ask :: Monad m => proxy tag -> ReaderT tag r m r +ask t = tagged t Trans.ask + +-- | Execute a computation in a modified environment +-- (a specialization of 'withReaderT'). +-- +-- * @'runReaderT' tag ('local' tag f m) = 'runReaderT' tag m . f@ +local + :: proxy tag + -> (r -> r) + -- ^ The function to modify the environment. + -> ReaderT tag r m a + -- ^ Computation to run in the modified environment. + -> ReaderT tag r m a +local = withReaderT + +-- Instances for mtl classes + +instance Class.MonadCont m => Class.MonadCont (ReaderT tag r m) where + callCC = liftCallCC Proxy Class.callCC + +instance Class.MonadReader r' m => Class.MonadReader r' (ReaderT tag r m) where + ask = lift Class.ask + local = mapReaderT Proxy . Class.local + reader = lift . Class.reader + +instance Class.MonadState s m => Class.MonadState s (ReaderT tag r m) where + get = lift Class.get + put = lift . Class.put + state = lift . Class.state + +instance Class.MonadWriter w m => Class.MonadWriter w (ReaderT tag r m) where + writer = lift . Class.writer + tell = lift . Class.tell + listen = mapReaderT Proxy Class.listen + pass = mapReaderT Proxy Class.pass + +instance Class.MonadError e m => Class.MonadError e (ReaderT tag r m) where + throwError = lift . Class.throwError + catchError = liftCatch Proxy Class.catchError diff --git a/src/Control/Monad/Trans/Ether/State.hs b/src/Control/Monad/Trans/Ether/State.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Ether/State.hs @@ -0,0 +1,8 @@ + +-- | See "Control.Monad.Trans.State". + +module Control.Monad.Trans.Ether.State + ( module Control.Monad.Trans.Ether.State.Lazy + ) where + +import Control.Monad.Trans.Ether.State.Lazy diff --git a/src/Control/Monad/Trans/Ether/State/Lazy.hs b/src/Control/Monad/Trans/Ether/State/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Ether/State/Lazy.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | See "Control.Monad.Trans.State.Lazy". + +module Control.Monad.Trans.Ether.State.Lazy + ( + -- * The State monad + State + , state + , runState + , evalState + , execState + -- * The StateT monad transformer + , StateT + , stateT + , runStateT + , evalStateT + , execStateT + , mapStateT + -- * State operations + , get + , put + -- * Litfing other operations + , liftCatch + , liftCallCC' + , liftListen + , liftPass + ) where + +import Data.Proxy (Proxy(Proxy)) +import Data.Functor.Identity (Identity(..)) +import Data.Coerce (coerce) +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus) +import Control.Monad.Fix (MonadFix) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.IO.Class (MonadIO) +import Control.Ether.Tagged (Taggable(..), Tagged(..)) +import GHC.Generics (Generic) +import qualified Control.Newtype as NT + +import qualified Control.Monad.Signatures as Sig +import qualified Control.Monad.Trans.State.Lazy as Trans + +import qualified Control.Monad.Cont.Class as Class +import qualified Control.Monad.Reader.Class as Class +import qualified Control.Monad.State.Class as Class +import qualified Control.Monad.Writer.Class as Class +import qualified Control.Monad.Error.Class as Class + + +-- | The parametrizable state monad. +-- +-- Computations have access to a mutable state. +-- +-- The 'return' function leaves the state unchanged, while '>>=' uses +-- the final state of the first computation as the initial state of the second. +type State tag r = StateT tag r Identity + +-- | The state monad transformer. +-- +-- The 'return' function leaves the state unchanged, while '>>=' uses +-- the final state of the first computation as the initial state of the second. +newtype StateT tag s m a = StateT (Trans.StateT s m a) + deriving ( Generic + , Functor, Applicative, Alternative, Monad, MonadPlus + , MonadFix, MonadTrans, MonadIO ) + +instance NT.Newtype (StateT tag s m a) + +instance Taggable (StateT tag s m) where + type Tag (StateT tag s m) = 'Just tag + type Inner (StateT tag s m) = 'Just m + +instance Tagged (StateT tag s m) tag where + type Untagged (StateT tag s m) = Trans.StateT s m + +-- | Constructor for computations in the state monad transformer. +stateT :: proxy tag -> (s -> m (a, s)) -> StateT tag s m a +stateT t = tagged t . Trans.StateT + +-- | Constructor for computations in the state monad +-- (the inverse of 'runState'). +state :: Monad m => proxy tag -> (s -> (a, s)) -> StateT tag s m a +state t = tagged t . Trans.state + +-- | Runs a 'StateT' with the given initial state +-- and returns both the final value and the final state. +runStateT :: proxy tag -> StateT tag s m a -> s -> m (a, s) +runStateT t = Trans.runStateT . untagged t + +-- | Runs a 'StateT' with the given initial state +-- and returns the final value, discarding the final state. +evalStateT :: Monad m => proxy tag -> StateT tag s m a -> s -> m a +evalStateT t = Trans.evalStateT . untagged t + +-- | Runs a 'StateT' with the given initial state +-- and returns the final state, discarding the final value. +execStateT :: Monad m => proxy tag -> StateT tag s m a -> s -> m s +execStateT t = Trans.execStateT . untagged t + +-- | Runs a 'State' with the given initial state +-- and returns both the final value and the final state. +runState :: proxy tag -> State tag s a -> s -> (a, s) +runState t = Trans.runState . untagged t + +-- | Runs a 'State' with the given initial state +-- and returns the final value, discarding the final state. +evalState :: proxy tag -> State tag s a -> s -> a +evalState t = Trans.evalState . untagged t + +-- | Runs a 'State' with the given initial state +-- and returns the final state, discarding the final value. +execState :: proxy tag -> State tag s a -> s -> s +execState t = Trans.execState . untagged t + +-- | Transform the computation inside a 'StateT'. +-- +-- * @'runStateT' tag ('mapStateT' tag f m) = f . 'runStateT' tag m@ +mapStateT :: proxy tag -> (m (a, s) -> n (b, s)) -> StateT tag s m a -> StateT tag s n b +mapStateT t f m = tagged t $ Trans.mapStateT f (coerce m) + +-- | Fetch the current value of the state within the monad. +get :: Monad m => proxy tag -> StateT tag s m s +get t = tagged t Trans.get + +-- | Set the value of the state within the monad. +put :: Monad m => proxy tag -> s -> StateT tag s m () +put t = tagged t . Trans.put + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: proxy tag -> Sig.Catch e m (a, s) -> Sig.Catch e (StateT tag s m) a +liftCatch t f m h = tagged t $ Trans.liftCatch f (coerce m) (coerce h) + +-- | Lift a @listen@ operation to the new monad. +liftListen :: Monad m => proxy tag -> Sig.Listen w m (a, s) -> Sig.Listen w (StateT tag s m) a +liftListen t listen m = tagged t $ Trans.liftListen listen (coerce m) + +-- | In-situ lifting of a @callCC@ operation to the new monad. +-- This version uses the current state on entering the continuation. +-- It does not satisfy the uniformity property (see "Control.Monad.Signatures"). +liftCallCC' :: proxy tag -> Sig.CallCC m (a, s) (b, s) -> Sig.CallCC (StateT tag s m) a b +liftCallCC' t callCC f = tagged t $ Trans.liftCallCC' callCC (coerce f) + +-- | Lift a @pass@ operation to the new monad. +liftPass :: Monad m => proxy tag -> Sig.Pass w m (a,s) -> Sig.Pass w (StateT tag s m) a +liftPass t pass m = tagged t $ Trans.liftPass pass (coerce m) + +-- Instances for mtl classes + +instance Class.MonadCont m => Class.MonadCont (StateT tag s m) where + callCC = liftCallCC' Proxy Class.callCC + +instance Class.MonadReader r m => Class.MonadReader r (StateT tag s m) where + ask = lift Class.ask + local = mapStateT Proxy . Class.local + reader = lift . Class.reader + +instance Class.MonadState s' m => Class.MonadState s' (StateT tag s m) where + get = lift Class.get + put = lift . Class.put + state = lift . Class.state + +instance Class.MonadWriter w m => Class.MonadWriter w (StateT tag s m) where + writer = lift . Class.writer + tell = lift . Class.tell + listen = liftListen Proxy Class.listen + pass = liftPass Proxy Class.pass + +instance Class.MonadError e m => Class.MonadError e (StateT tag s m) where + throwError = lift . Class.throwError + catchError = liftCatch Proxy Class.catchError diff --git a/src/Control/Monad/Trans/Ether/State/Strict.hs b/src/Control/Monad/Trans/Ether/State/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Ether/State/Strict.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | See "Control.Monad.Trans.State.Strict". + +module Control.Monad.Trans.Ether.State.Strict + ( + -- * The State monad + State + , state + , runState + , evalState + , execState + -- * The StateT monad transformer + , StateT + , stateT + , runStateT + , evalStateT + , execStateT + , mapStateT + -- * State operations + , get + , put + -- * Litfing other operations + , liftCatch + , liftCallCC' + , liftListen + , liftPass + ) where + +import Data.Proxy (Proxy(Proxy)) +import Data.Functor.Identity (Identity(..)) +import Data.Coerce (coerce) +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus) +import Control.Monad.Fix (MonadFix) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.IO.Class (MonadIO) +import Control.Ether.Tagged (Taggable(..), Tagged(..)) +import GHC.Generics (Generic) +import qualified Control.Newtype as NT + +import qualified Control.Monad.Signatures as Sig +import qualified Control.Monad.Trans.State.Strict as Trans + +import qualified Control.Monad.Cont.Class as Class +import qualified Control.Monad.Reader.Class as Class +import qualified Control.Monad.State.Class as Class +import qualified Control.Monad.Writer.Class as Class +import qualified Control.Monad.Error.Class as Class + + +-- | The parametrizable state monad. +-- +-- Computations have access to a mutable state. +-- +-- The 'return' function leaves the state unchanged, while '>>=' uses +-- the final state of the first computation as the initial state of the second. +type State tag r = StateT tag r Identity + +-- | The state monad transformer. +-- +-- The 'return' function leaves the state unchanged, while '>>=' uses +-- the final state of the first computation as the initial state of the second. +newtype StateT tag s m a = StateT (Trans.StateT s m a) + deriving ( Generic + , Functor, Applicative, Alternative, Monad, MonadPlus + , MonadFix, MonadTrans, MonadIO ) + +instance NT.Newtype (StateT tag s m a) + +instance Taggable (StateT tag s m) where + type Tag (StateT tag s m) = 'Just tag + type Inner (StateT tag s m) = 'Just m + +instance Tagged (StateT tag s m) tag where + type Untagged (StateT tag s m) = Trans.StateT s m + +-- | Constructor for computations in the state monad transformer. +stateT :: proxy tag -> (s -> m (a, s)) -> StateT tag s m a +stateT t = tagged t . Trans.StateT + +-- | Constructor for computations in the state monad +-- (the inverse of 'runState'). +state :: Monad m => proxy tag -> (s -> (a, s)) -> StateT tag s m a +state t = tagged t . Trans.state + +-- | Runs a 'StateT' with the given initial state +-- and returns both the final value and the final state. +runStateT :: proxy tag -> StateT tag s m a -> s -> m (a, s) +runStateT t = Trans.runStateT . untagged t + +-- | Runs a 'StateT' with the given initial state +-- and returns the final value, discarding the final state. +evalStateT :: Monad m => proxy tag -> StateT tag s m a -> s -> m a +evalStateT t = Trans.evalStateT . untagged t + +-- | Runs a 'StateT' with the given initial state +-- and returns the final state, discarding the final value. +execStateT :: Monad m => proxy tag -> StateT tag s m a -> s -> m s +execStateT t = Trans.execStateT . untagged t + +-- | Runs a 'State' with the given initial state +-- and returns both the final value and the final state. +runState :: proxy tag -> State tag s a -> s -> (a, s) +runState t = Trans.runState . untagged t + +-- | Runs a 'State' with the given initial state +-- and returns the final value, discarding the final state. +evalState :: proxy tag -> State tag s a -> s -> a +evalState t = Trans.evalState . untagged t + +-- | Runs a 'State' with the given initial state +-- and returns the final state, discarding the final value. +execState :: proxy tag -> State tag s a -> s -> s +execState t = Trans.execState . untagged t + +-- | Transform the computation inside a 'StateT'. +-- +-- * @'runStateT' tag ('mapStateT' tag f m) = f . 'runStateT' tag m@ +mapStateT :: proxy tag -> (m (a, s) -> n (b, s)) -> StateT tag s m a -> StateT tag s n b +mapStateT t f m = tagged t $ Trans.mapStateT f (coerce m) + +-- | Fetch the current value of the state within the monad. +get :: Monad m => proxy tag -> StateT tag s m s +get t = tagged t Trans.get + +-- | Set the value of the state within the monad. +put :: Monad m => proxy tag -> s -> StateT tag s m () +put t = tagged t . Trans.put + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: proxy tag -> Sig.Catch e m (a, s) -> Sig.Catch e (StateT tag s m) a +liftCatch t f m h = tagged t $ Trans.liftCatch f (coerce m) (coerce h) + +-- | Lift a @listen@ operation to the new monad. +liftListen :: Monad m => proxy tag -> Sig.Listen w m (a, s) -> Sig.Listen w (StateT tag s m) a +liftListen t listen m = tagged t $ Trans.liftListen listen (coerce m) + +-- | In-situ lifting of a @callCC@ operation to the new monad. +-- This version uses the current state on entering the continuation. +-- It does not satisfy the uniformity property (see "Control.Monad.Signatures"). +liftCallCC' :: proxy tag -> Sig.CallCC m (a, s) (b, s) -> Sig.CallCC (StateT tag s m) a b +liftCallCC' t callCC f = tagged t $ Trans.liftCallCC' callCC (coerce f) + +-- | Lift a @pass@ operation to the new monad. +liftPass :: Monad m => proxy tag -> Sig.Pass w m (a,s) -> Sig.Pass w (StateT tag s m) a +liftPass t pass m = tagged t $ Trans.liftPass pass (coerce m) + +-- Instances for mtl classes + +instance Class.MonadCont m => Class.MonadCont (StateT tag s m) where + callCC = liftCallCC' Proxy Class.callCC + +instance Class.MonadReader r m => Class.MonadReader r (StateT tag s m) where + ask = lift Class.ask + local = mapStateT Proxy . Class.local + reader = lift . Class.reader + +instance Class.MonadState s' m => Class.MonadState s' (StateT tag s m) where + get = lift Class.get + put = lift . Class.put + state = lift . Class.state + +instance Class.MonadWriter w m => Class.MonadWriter w (StateT tag s m) where + writer = lift . Class.writer + tell = lift . Class.tell + listen = liftListen Proxy Class.listen + pass = liftPass Proxy Class.pass + +instance Class.MonadError e m => Class.MonadError e (StateT tag s m) where + throwError = lift . Class.throwError + catchError = liftCatch Proxy Class.catchError diff --git a/src/Control/Monad/Trans/Ether/Writer.hs b/src/Control/Monad/Trans/Ether/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Ether/Writer.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | See "Control.Monad.Trans.Writer". + +module Control.Monad.Trans.Ether.Writer + ( + -- * The Writer monad + Writer + , writer + , runWriter + , execWriter + -- * The WriterT monad transformer + , WriterT + , writerT + , runWriterT + , execWriterT + , mapWriterT + -- * Writer operations + , tell + , listen + , pass + -- * Lifting other operations + , liftCallCC + , liftCatch + , liftListen + , liftPass + ) where + +import Data.Proxy (Proxy(Proxy)) +import Data.Functor.Identity (Identity(..)) +import Data.Coerce (coerce) +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus) +import Control.Monad.Fix (MonadFix) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.IO.Class (MonadIO) +import Control.Ether.Tagged (Taggable(..), Tagged(..)) +import qualified Control.Ether.Util as Util +import GHC.Generics (Generic) +import qualified Control.Newtype as NT + +import qualified Control.Monad.Signatures as Sig +import qualified Control.Monad.Trans.Writer.Lazy as Trans + +import qualified Control.Monad.Cont.Class as Class +import qualified Control.Monad.Reader.Class as Class +import qualified Control.Monad.State.Class as Class +import qualified Control.Monad.Writer.Class as Class +import qualified Control.Monad.Error.Class as Class + +-- | The parametrizable writer monad. +-- +-- Computations can accumulate a monoid value. +-- +-- The 'return' function produces the output 'mempty', while '>>=' combines +-- the outputs of the subcomputations using 'mappend'. +type Writer tag w = WriterT tag w Identity + +-- | The writer monad transformer. +-- +-- The 'return' function produces the output 'mempty', while '>>=' combines +-- the outputs of the subcomputations using 'mappend'. +newtype WriterT tag w m a = WriterT (Trans.WriterT w m a) + deriving ( Generic + , Functor, Applicative, Alternative, Monad, MonadPlus + , MonadFix, MonadTrans, MonadIO ) + +instance NT.Newtype (WriterT tag w m a) + +instance Taggable (WriterT tag w m) where + type Tag (WriterT tag w m) = 'Just tag + type Inner (WriterT tag w m) = 'Just m + +instance Tagged (WriterT tag w m) tag where + type Untagged (WriterT tag w m) = Trans.WriterT w m + +-- | Constructor for computations in the writer monad transformer. +writerT :: proxy tag -> m (a, w) -> WriterT tag w m a +writerT t = tagged t . Trans.WriterT + +-- | Constructor for computations in the writer monad +-- (the inverse of 'runWriter'). +writer :: Monad m => proxy tag -> (a, w) -> WriterT tag w m a +writer t = tagged t . Trans.writer + +-- | Runs a 'WriterT' and returns both the normal value +-- and the final accumulator. +runWriterT :: proxy tag -> WriterT tag w m a -> m (a, w) +runWriterT t = Trans.runWriterT . untagged t + +-- | Runs a 'Writer' and returns both the normal value +-- and the final accumulator. +runWriter :: proxy tag -> Writer tag w a -> (a, w) +runWriter t = Trans.runWriter . untagged t + +-- | Runs a 'WriterT' and returns the final accumulator, +-- discarding the normal value. +execWriterT :: Monad m => proxy tag -> WriterT tag w m a -> m w +execWriterT t = Trans.execWriterT . untagged t + +-- | Runs a 'Writer' and returns the final accumulator, +-- discarding the normal value. +execWriter :: proxy tag -> Writer tag w a -> w +execWriter t = Trans.execWriter . untagged t + +-- | Transform the computation inside a 'WriterT'. +-- +-- * @'runWriterT' tag ('mapWriterT' tag f m) = f ('runWriterT' tag m)@ +mapWriterT :: proxy tag -> (m (a, w) -> n (b, w')) -> WriterT tag w m a -> WriterT tag w' n b +mapWriterT t f m = tagged t $ Trans.mapWriterT f (coerce m) + +-- | Appends a value to the accumulator within the monad. +tell :: Monad m => proxy tag -> w -> WriterT tag w m () +tell t w = writer t ((), w) + +-- | Executes an action and adds its accumulator to the value of the computation. +listen :: (Monoid w, Monad m) => proxy tag -> WriterT tag w m a -> WriterT tag w m (a, w) +listen t m = tagged t $ Trans.listen (coerce m) + +-- | Executes an action which returns a value and a function, and returns the +-- value, applying the function to the accumulator. +pass :: (Monoid w, Monad m) => proxy tag -> WriterT tag w m (a, w -> w) -> WriterT tag w m a +pass t m = tagged t $ Trans.pass (coerce m) + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: proxy tag -> Sig.Catch e m (a, w) -> Sig.Catch e (WriterT tag w m) a +liftCatch t f m h = tagged t $ Trans.liftCatch f (coerce m) (coerce h) + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: Monoid w => proxy tag -> Sig.CallCC m (a, w) (b, w) -> Sig.CallCC (WriterT tag w m) a b +liftCallCC t callCC f = tagged t $ Trans.liftCallCC callCC (coerce f) + +-- | Lift a @listen@ operation to the new monad. +liftListen :: Monad m => proxy tag -> Sig.Listen w' m (a, w) -> Sig.Listen w' (WriterT tag w m) a +liftListen t f m = tagged t $ Util.liftListen_WriterT f (coerce m) + +-- | Lift a @pass@ operation to the new monad. +liftPass :: Monad m => proxy tag -> Sig.Pass w' m (a, w) -> Sig.Pass w' (WriterT tag w m) a +liftPass t f m = tagged t $ Util.liftPass_WriterT f (coerce m) + +instance (Monoid w, Class.MonadCont m) => Class.MonadCont (WriterT tag w m) where + callCC = liftCallCC Proxy Class.callCC + +instance (Monoid w, Class.MonadReader r m) => Class.MonadReader r (WriterT tag w m) where + ask = lift Class.ask + local = mapWriterT Proxy . Class.local + reader = lift . Class.reader + +instance (Monoid w, Class.MonadState s m) => Class.MonadState s (WriterT tag w m) where + get = lift Class.get + put = lift . Class.put + state = lift . Class.state + +instance (Monoid w, Class.MonadWriter w' m) => Class.MonadWriter w' (WriterT tag w m) where + writer = lift . Class.writer + tell = lift . Class.tell + listen = liftListen Proxy Class.listen + pass = liftPass Proxy Class.pass + +instance (Monoid w, Class.MonadError e m) => Class.MonadError e (WriterT tag w m) where + throwError = lift . Class.throwError + catchError = liftCatch Proxy Class.catchError diff --git a/test/Regression.hs b/test/Regression.hs new file mode 100644 --- /dev/null +++ b/test/Regression.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +module Main where + +import Data.Functor.Identity +import Data.Monoid +import Data.Foldable +import Control.Ether.Tagged +import Control.Ether.TH +import Control.Ether.Wrapped +import Control.Monad.Ether.Reader +import Control.Monad.Ether.State +import Control.Monad.Ether.Writer +import Control.Monad.Ether.Implicit.Except.TH +import qualified Control.Monad.Ether.Implicit.Reader as I +import qualified Control.Monad.Ether.Implicit.State as I +import qualified Control.Monad.Ether.Implicit.Except as I +import qualified Control.Monad.Reader as T +import qualified Control.Monad.Writer as T +import qualified Control.Monad.State as T + +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.QuickCheck.Function + +ethereal "R1" "r1" +ethereal "R2" "r2" +ethereal "S1" "s1" +ethereal "Foo" "foo" +ethereal "Bar" "bar" + +main :: IO () +main = defaultMain suite + +suite :: TestTree +suite = testGroup "Ether" + [ testGroup "ReaderT" + [ testProperty "layered sum (local left)" layeredLocalLeft + , testProperty "layered sum (local right)" layeredLocalRight + ] + ] + +layeredLocalLeft, layeredLocalRight + :: Fun (Int, Integer) Integer + -> Fun Integer Integer + -> Int -> Integer -> Property + +layeredLocalLeft k f a1 a2 = property (direct == run indirect) + where + run = flip (runReader r1) a1 . flip (runReaderT r2) a2 + (direct, indirect) = layeredLocalCore' k f a1 a2 + +layeredLocalRight k f a1 a2 = property (direct == run indirect) + where + run = flip (runReader r2) a2 . flip (runReaderT r1) a1 + (direct, indirect) = layeredLocalCore' k f a1 a2 + +layeredLocalCore + :: (MonadReader R1 r1 m, MonadReader R2 r2 m) + => (r2 -> r2) -> (r1 -> r2 -> a) -> m a +layeredLocalCore f g = do + n <- ask r1 + m <- local r2 f (ask r2) + return (g n m) + +layeredLocalCore' + :: (MonadReader R1 Int m, MonadReader R2 Integer m) + => Fun (Int, Integer) Integer + -> Fun Integer Integer + -> Int -> Integer -> (Integer, m Integer) +layeredLocalCore' k f a1 a2 = (direct, indirect) + where + direct = apply k (fromIntegral a1, apply f a2) + indirect = layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m)) + +implicitCore :: (I.MonadReader Int m, I.MonadReader Bool m) => m String +implicitCore = I.local (succ :: Int -> Int) $ do + n :: Int <- I.ask + b <- I.local not I.ask + return (if b then "" else show n) + +wrapCore + :: ( T.MonadReader Int m + , T.MonadState Int m + ) => m Int +wrapCore = do + b <- T.get + a <- T.ask + T.put (a + b) + return (a * b) + +wrapCore' + :: ( MonadReader S1 Int m + , MonadState S1 Int m + , MonadReader R1 Int m + ) => m Int +wrapCore' = do + a <- ethered s1 wrapCore + c <- ask r1 + return (a + c) + +wrapCore'' :: Int -> (Int, Int) +wrapCore'' a = runReader r1 (runStateT s1 (runReaderT s1 wrapCore' a) a) (-1) + +-- Should not compile with `ensureUniqueTags` +uniqueTagsCore :: IO () +uniqueTagsCore = flip (runReaderT r1) (1 :: Int) + . flip (runReaderT r1) (True :: Bool) + . flip (runReaderT r1) (2 :: Int) + . flip (runReaderT r1) (3 :: Integer) + {- . ensureUniqueTags -} + $ do + a :: Integer <- ask r1 + b :: Int <- ask r1 + c :: Bool <- ask r1 + T.liftIO $ do + print a + print b + print c + +stateCore :: ( MonadState S1 Int m + , MonadReader R1 Int m + , UniqueTags m ) => m () +stateCore = do + a <- ask r1 + n <- get s1 + put s1 (n * a) + modify s1 (subtract 1) + +recurseCore :: (Num a, Ord a) => (I.MonadReader a m, I.MonadState Int m) => m a +recurseCore = do + a <- I.ask + if (a <= 0) + then do + I.put (0 :: Int) + return 1 + else do + I.modify (succ :: Int -> Int) + b <- I.runReaderT recurseCore (a - 1) + I.modify (succ :: Int -> Int) + return (a * b) + +factorial :: (Num a, Ord a) => a -> (a, Int) +factorial a = I.runState (I.runReaderT recurseCore a) (0 :: Int) + +factorial' :: Int -> (Int, Int) +factorial' a = factorial (a :: Int) + +data DivideByZero = DivideByZero + deriving (Show) +data NegativeLog a = NegativeLog a + deriving (Show) + +exceptCore + :: ( Floating a, Ord a + , I.MonadExcept DivideByZero m + , I.MonadExcept (NegativeLog a) m + ) => a -> a -> m a +exceptCore a b = do + T.when (b == 0) (I.throw DivideByZero) + let d = a /b + T.when (d < 0) (I.throw (NegativeLog d)) + return (log d) + +try0 :: m a -> m a +try0 = $(try 0) + +try1 :: Functor m => I.ExceptT e m a -> (e -> a) -> m a +try1 = $(try 1) + +try2 :: Functor m => I.ExceptT e1 (I.ExceptT e2 m) a -> (e1 -> a) -> (e2 -> a) -> m a +try2 = $(try 2) + +try3 :: Functor m => I.ExceptT e1 (I.ExceptT e2 (I.ExceptT e3 m)) a -> (e1 -> a) -> (e2 -> a) -> (e3 -> a) -> m a +try3 = $(try 3) + +exceptCore' :: Double -> Double -> String +exceptCore' a b = runIdentity $ do + $(try 2) + (show <$> exceptCore a b) + (\(NegativeLog (x::Double)) -> "nl: " ++ show x) + (\DivideByZero -> "dz") + +summatorCore + :: ( Num a + , T.MonadWriter (Sum a) m + , MonadWriter Foo (Sum a) m + ) => [a] -> m () +summatorCore xs = do + for_ xs $ \x -> do + T.tell (Sum x) + tell foo (Sum 1) + +summatorCore' :: Num a => [a] -> (Sum a, Sum a) +summatorCore' = runWriter foo . T.execWriterT . summatorCore + +wrapState_f :: T.MonadState Int m => m String +wrapState_f = fmap show T.get + +wrapState_g :: T.MonadState Bool m => m String +wrapState_g = fmap show T.get + +wrapState_useboth + :: ( MonadState Foo Int m + , MonadState Bar Bool m + ) => m String +wrapState_useboth = do + a <- ethered foo wrapState_f + b <- ethered bar wrapState_g + return (a ++ b) + +wrapStateCore :: Int -> Bool -> String +wrapStateCore int bool = evalState foo (evalStateT bar wrapState_useboth bool) int + +wrapStateBad1_g :: MonadState Foo Int m => m () +wrapStateBad1_g = modify foo (*100) + +wrapStateBad1_useboth :: MonadState Foo Int m => m String +wrapStateBad1_useboth = do + wrapStateBad1_g + ethered foo wrapState_f + +wrapStateBad1 :: Int -> String +wrapStateBad1 = evalState foo wrapStateBad1_useboth + +wrapStateBad2 + :: ( T.MonadState Int m + , MonadState Foo Int m + ) => m Int +wrapStateBad2 = do + modify foo (*100) + T.get + +wrapStateBad2Core :: Int -> Int +wrapStateBad2Core = evalState foo (ensureUniqueTags $ ethered foo wrapStateBad2)