summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormniip <>2020-08-10 16:22:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-08-10 16:22:00 (GMT)
commitefc5887ab8620e0ab0c14ee73e82fca7b920aa0f (patch)
tree380b795082b7d5ee89620703535bfe10b0e0801f
version 0.1.0.0HEAD0.1.0.0master
-rw-r--r--LICENSE30
-rw-r--r--Setup.hs2
-rw-r--r--monad-introspect.cabal24
-rw-r--r--src/Control/Monad/Introspect/Class.hs187
-rw-r--r--src/Control/Monad/Trans/Introspect.hs122
5 files changed, 365 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..893d84d
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2019, mniip
+
+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 mniip 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
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/monad-introspect.cabal b/monad-introspect.cabal
new file mode 100644
index 0000000..3d29504
--- /dev/null
+++ b/monad-introspect.cabal
@@ -0,0 +1,24 @@
+name: monad-introspect
+version: 0.1.0.0
+synopsis: A reader monad that gives the environment access to the entire transformer stack
+description: A reader monad that gives the environment access to the entire transformer stack.
+homepage: https://github.com/mniip/monad-introspect
+license: BSD3
+license-file: LICENSE
+author: mniip
+maintainer: mniip@mniip.com
+copyright: (C) mniip 2019
+category: Control
+build-type: Simple
+cabal-version: >=1.10
+
+library
+ exposed-modules: Control.Monad.Introspect.Class
+ , Control.Monad.Trans.Introspect
+ build-depends: base >= 4.12 && < 4.15,
+ coercion-extras,
+ mmorph,
+ mtl,
+ transformers
+ hs-source-dirs: src
+ default-language: Haskell2010
diff --git a/src/Control/Monad/Introspect/Class.hs b/src/Control/Monad/Introspect/Class.hs
new file mode 100644
index 0000000..a43bbaf
--- /dev/null
+++ b/src/Control/Monad/Introspect/Class.hs
@@ -0,0 +1,187 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-deprecations #-}
+
+module Control.Monad.Introspect.Class where
+
+import Control.Applicative
+import Control.Monad hiding (fail)
+import Control.Monad.Error (ErrorT(..), mapErrorT)
+import Control.Monad.Error.Class
+import Control.Monad.Except (ExceptT(..), mapExceptT)
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Compose
+import Control.Monad.Trans.Cont (ContT(..), mapContT)
+import Control.Monad.Trans.Identity (IdentityT(..), mapIdentityT)
+import Control.Monad.Trans.List (ListT(..), mapListT)
+import Control.Monad.Trans.Maybe (MaybeT(..), mapMaybeT)
+import Control.Monad.Trans.Reader (ReaderT(..), mapReaderT)
+import Control.Monad.Trans.RWS (RWST(..), mapRWST)
+import qualified Control.Monad.Trans.State.Lazy as L
+import qualified Control.Monad.Trans.State.Strict as S
+import qualified Control.Monad.Trans.Writer.Lazy as L
+import qualified Control.Monad.Trans.Writer.Strict as S
+import Data.Coerce
+import Prelude hiding (fail)
+import Data.Type.Role.Representational
+
+-- * Abstract interface
+
+-- | A monad with introspection capability is able to query an environment @r@
+-- that is parameterized by the monad itself, i.e. can contain effectful
+-- functions.
+--
+-- The caveat is that sometimes the monad changes (e.g. we locally run a
+-- transformer, or we globally run our transformer steck), so the monad in the
+-- environment can "desync" from the ambient monad. This warrants a more general
+-- class: 'MonadIntrospectTrans', of which 'MonadIntrospect' is a special case.
+--
+-- The machinery sometimes requires newtype wrapping/unwrapping the monad that
+-- goes to the environment. We use/require 'Coercible' for that, as the
+-- "functorial" operations are deemed expensive. The constraint
+-- @'Representational' r@ ensures that the environment can be coerced provided
+-- the monad can be coerced.
+--
+-- Otherwise the interface is identical to that of
+-- 'Control.Monad.Reader.Class.MonadReader'.
+class (Representational r, MonadIntrospectTrans IdentityT r m)
+ => MonadIntrospect (r :: (* -> *) -> *) (m :: * -> *) where
+ -- | Essentially 'Control.Monad.Reader.Class.ask'.
+ introspect :: m (r m)
+ -- | Essentially 'Control.Monad.Reader.Class.local'.
+ substitute :: (r m -> r m) -> m a -> m a
+
+-- | If the ambient monad is @m@ and the environment @r@ has additional effects
+-- @t@, we can ask for that environment, or substitute it. Multiple (or zero)
+-- effects can be combined into a single @t@ with 'ComposeT' (or 'IdentityT').
+class (Monad m, MonadTrans t) => MonadIntrospectTrans
+ (t :: (* -> *) -> * -> *)
+ (r :: (* -> *) -> *)
+ (m :: * -> *)
+ | m -> t where
+ -- | Essentially 'Control.Monad.Reader.Class.ask'.
+ introspectTrans :: m (r (t m))
+ -- | Essentially 'Control.Monad.Reader.Class.local'.
+ substituteTrans :: (r (t m) -> r (t m)) -> m a -> m a
+
+instance (Representational r, MonadIntrospectTrans IdentityT r m)
+ => MonadIntrospect r m where
+ introspect = liftTransEnv <$> introspectTrans
+ substitute = substituteTrans . liftTransMapper
+
+-- * Utility functions for coercing environments
+
+liftTransEnv :: (Representational r, Coercible m n) => r m -> r n
+liftTransEnv = coerce
+
+liftTransMapper :: (Representational r, Coercible m n)
+ => (r m -> r m) -> r n -> r n
+liftTransMapper = coerce
+
+-- Other effects proxy MonadIntrospect
+
+instance
+ ( Representational r
+ , MonadTrans t
+ , MonadIntrospectTrans (ComposeT t IdentityT) r m )
+ => MonadIntrospectTrans t r (IdentityT m) where
+ introspectTrans = lift $ liftTransEnv <$> introspectTrans
+ substituteTrans = mapIdentityT . substituteTrans . liftTransMapper
+
+instance
+ ( Representational r
+ , MonadTrans t
+ , MonadIntrospectTrans (ComposeT t ListT) r m )
+ => MonadIntrospectTrans t r (ListT m) where
+ introspectTrans = lift $ liftTransEnv <$> introspectTrans
+ substituteTrans = mapListT . substituteTrans . liftTransMapper
+
+instance
+ ( Representational r
+ , MonadTrans t
+ , MonadIntrospectTrans (ComposeT t (ContT e)) r m )
+ => MonadIntrospectTrans t r (ContT e m) where
+ introspectTrans = lift $ liftTransEnv <$> introspectTrans
+ substituteTrans = mapContT . substituteTrans . liftTransMapper
+
+instance
+ ( Representational r
+ , MonadTrans t
+ , MonadIntrospectTrans (ComposeT t (ExceptT e)) r m )
+ => MonadIntrospectTrans t r (ExceptT e m) where
+ introspectTrans = lift $ liftTransEnv <$> introspectTrans
+ substituteTrans = mapExceptT . substituteTrans . liftTransMapper
+
+instance
+ ( Representational r
+ , Error e
+ , MonadTrans t
+ , MonadIntrospectTrans (ComposeT t (ErrorT e)) r m )
+ => MonadIntrospectTrans t r (ErrorT e m) where
+ introspectTrans = lift $ liftTransEnv <$> introspectTrans
+ substituteTrans = mapErrorT . substituteTrans . liftTransMapper
+
+instance
+ ( Representational r
+ , MonadTrans t
+ , MonadIntrospectTrans (ComposeT t (ReaderT e)) r m )
+ => MonadIntrospectTrans t r (ReaderT e m) where
+ introspectTrans = lift $ liftTransEnv <$> introspectTrans
+ substituteTrans = mapReaderT . substituteTrans . liftTransMapper
+
+instance
+ ( Representational r
+ , MonadTrans t
+ , MonadIntrospectTrans (ComposeT t MaybeT) r m )
+ => MonadIntrospectTrans t r (MaybeT m) where
+ introspectTrans = lift $ liftTransEnv <$> introspectTrans
+ substituteTrans = mapMaybeT . substituteTrans . liftTransMapper
+
+instance
+ ( Representational r
+ , MonadTrans t
+ , MonadIntrospectTrans (ComposeT t (L.StateT s)) r m )
+ => MonadIntrospectTrans t r (L.StateT s m) where
+ introspectTrans = lift $ liftTransEnv <$> introspectTrans
+ substituteTrans = L.mapStateT . substituteTrans . liftTransMapper
+
+instance
+ ( Representational r
+ , MonadTrans t
+ , MonadIntrospectTrans (ComposeT t (S.StateT s)) r m )
+ => MonadIntrospectTrans t r (S.StateT s m) where
+ introspectTrans = lift $ liftTransEnv <$> introspectTrans
+ substituteTrans = S.mapStateT . substituteTrans . liftTransMapper
+
+instance
+ ( Representational r
+ , Monoid w
+ , MonadTrans t
+ , MonadIntrospectTrans (ComposeT t (L.WriterT w)) r m )
+ => MonadIntrospectTrans t r (L.WriterT w m) where
+ introspectTrans = lift $ liftTransEnv <$> introspectTrans
+ substituteTrans = L.mapWriterT . substituteTrans . liftTransMapper
+
+instance
+ ( Representational r
+ , Monoid w
+ , MonadTrans t
+ , MonadIntrospectTrans (ComposeT t (S.WriterT w)) r m )
+ => MonadIntrospectTrans t r (S.WriterT w m) where
+ introspectTrans = lift $ liftTransEnv <$> introspectTrans
+ substituteTrans = S.mapWriterT . substituteTrans . liftTransMapper
+
+instance
+ ( Representational r
+ , Monoid w
+ , MonadTrans t
+ , MonadIntrospectTrans (ComposeT t (RWST e w s)) r m )
+ => MonadIntrospectTrans t r (RWST e w s m) where
+ introspectTrans = lift $ liftTransEnv <$> introspectTrans
+ substituteTrans = mapRWST . substituteTrans . liftTransMapper
diff --git a/src/Control/Monad/Trans/Introspect.hs b/src/Control/Monad/Trans/Introspect.hs
new file mode 100644
index 0000000..dd216df
--- /dev/null
+++ b/src/Control/Monad/Trans/Introspect.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-deprecations #-}
+
+module Control.Monad.Trans.Introspect where
+
+import Control.Applicative
+import Control.Monad hiding (fail)
+import Control.Monad.Cont.Class
+import Control.Monad.Error.Class
+import Control.Monad.Fail
+import Control.Monad.Fix
+import Control.Monad.IO.Class
+import Control.Monad.Reader.Class
+import Control.Monad.Signatures
+import Control.Monad.State.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Writer.Class
+import Control.Monad.Zip
+import Data.Coerce
+import Prelude hiding (fail)
+import Control.Monad.Introspect.Class
+import Data.Type.Role.Representational
+
+-- * Concrete interface
+
+-- | @'IntrospectT' t r m a@ extends the monad @m@ with access to an environment
+-- @r@ parameterized by @m@ with additional effects @t@ on top.
+newtype IntrospectT
+ (t :: (* -> *) -> * -> *)
+ (r :: (* -> *) -> *)
+ (m :: * -> *)
+ (a :: *)
+ = IntrospectT { runIntrospectT :: r (t (IntrospectT t r m)) -> m a }
+
+-- | Run an 'IntrospectT'. If introspection is the outermost effect then you
+-- will likely have @t ~ 'Control.Monad.Trans.Identity.IdentityT'@ and thus you
+-- can pick @n ~ 'IntrospectT' t r m@.
+runIntrospect :: (Representational r, Coercible (t (IntrospectT t r m)) n)
+ => r n -> IntrospectT t r m a -> m a
+runIntrospect e (IntrospectT h) = h $ liftTransEnv e
+
+instance Functor m => Functor (IntrospectT t r m) where
+ fmap f (IntrospectT h) = IntrospectT $ fmap f . h
+
+instance Applicative m => Applicative (IntrospectT t r m) where
+ pure x = IntrospectT $ const $ pure x
+ IntrospectT f <*> IntrospectT x = IntrospectT $ liftA2 (<*>) f x
+
+instance Alternative m => Alternative (IntrospectT t r m) where
+ empty = IntrospectT $ const empty
+ IntrospectT f <|> IntrospectT g = IntrospectT $ liftA2 (<|>) f g
+
+instance Monad m => Monad (IntrospectT t r m) where
+ IntrospectT k >>= f = IntrospectT $ \e -> k e >>= \x -> runIntrospectT (f x) e
+
+instance MonadPlus m => MonadPlus (IntrospectT t r m) where
+ mzero = IntrospectT $ const mzero
+ mplus (IntrospectT f) (IntrospectT g) = IntrospectT $ liftA2 mplus f g
+
+instance MonadTrans (IntrospectT t r) where
+ lift k = IntrospectT $ const k
+
+instance (Monad m, MonadTrans t)
+ => MonadIntrospectTrans t r (IntrospectT t r m) where
+ introspectTrans = IntrospectT return
+ substituteTrans f (IntrospectT h) = IntrospectT $ h . f
+
+-- * Utility functions for proxying other effects
+
+mapIntrospectT :: (m a -> m b) -> IntrospectT t r m a -> IntrospectT t r m b
+mapIntrospectT f (IntrospectT h) = IntrospectT $ f . h
+
+liftCallCC :: CallCC m a b -> CallCC (IntrospectT t r m) a b
+liftCallCC cCC f = IntrospectT $ \r ->
+ cCC $ \c -> runIntrospectT (f (IntrospectT . const . c)) r
+
+liftCatch :: Catch e m a -> Catch e (IntrospectT t r m) a
+liftCatch f m h = IntrospectT $ \r ->
+ f (runIntrospectT m r) $ \e -> runIntrospectT (h e) r
+
+-- IntrospectT proxies other effects
+
+instance MonadError e m => MonadError e (IntrospectT t r m) where
+ throwError = lift . throwError
+ catchError = liftCatch catchError
+
+instance MonadReader e m => MonadReader e (IntrospectT t r m) where
+ ask = lift ask
+ local = mapIntrospectT . local
+ reader = lift . reader
+
+instance MonadState s m => MonadState s (IntrospectT t r m) where
+ get = lift get
+ put = lift . put
+ state = lift . state
+
+instance MonadWriter w m => MonadWriter w (IntrospectT t r m) where
+ writer = lift . writer
+ tell = lift . tell
+ listen = mapIntrospectT listen
+ pass = mapIntrospectT pass
+
+instance MonadCont m => MonadCont (IntrospectT t r m) where
+ callCC = liftCallCC callCC
+
+instance MonadFix m => MonadFix (IntrospectT t r m) where
+ mfix f = IntrospectT $ \r -> mfix $ \a -> runIntrospectT (f a) r
+
+instance MonadFail m => MonadFail (IntrospectT t r m) where
+ fail = lift . fail
+
+instance MonadZip m => MonadZip (IntrospectT t r m) where
+ mzip (IntrospectT f) (IntrospectT g) = IntrospectT $ \r -> mzip (f r) (g r)
+ mzipWith h (IntrospectT f) (IntrospectT g) = IntrospectT $ \r ->
+ mzipWith h (f r) (g r)
+
+instance MonadIO m => MonadIO (IntrospectT t r m) where
+ liftIO = lift . liftIO