control (empty) → 0.1.0.0
raw patch · 6 files changed
+259/−0 lines, 6 filesdep +basedep +basicdep +stmsetup-changed
Dependencies added: base, basic, stm, template-haskell, transformers
Files
- Control/Monad/Base/Control.hs +96/−0
- Control/Monad/Trans/Control.hs +82/−0
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- control.cabal +48/−0
+ Control/Monad/Base/Control.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE TemplateHaskell #-}++module Control.Monad.Base.Control where++import Control.Concurrent.STM (STM)+import Control.Monad (replicateM)+import Control.Monad.Trans.Accum+import Control.Monad.Trans.Control+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Lazy as L+import Control.Monad.Trans.State.Strict as S+import Control.Monad.Trans.Writer.Lazy as L+import Control.Monad.Trans.Writer.Strict as S+import Control.Monad.ST.Lazy as L (ST)+import Control.Monad.ST.Strict as S (ST)+import Data.Basic+import Data.Foldable+import Data.Functor.Identity+import Data.List.NonEmpty (NonEmpty)+import Data.Proxy+import Language.Haskell.TH+import Text.ParserCombinators.ReadP (ReadP)+import Text.ParserCombinators.ReadPrec (ReadPrec)++class (Basic1 m, Monad m, Monad (Base m)) => MonadBaseControl m where+ type StM m a+ liftBaseWith :: (RunInBase m -> Base m a) -> m a+ restoreM :: StM m a -> m a++type RunInBase m = ∀ a . m a -> Base m (StM m a)++newtype ComposeSt t m a = ComposeSt { unComposeSt :: StM m (StT t a) }++type RunInBaseDefault t m = ∀ a . t m a -> Base m (ComposeSt t m a)++defaultLiftBaseWith :: (MonadTransControl t, MonadBaseControl m) => (RunInBaseDefault t m -> Base m a) -> t m a+defaultLiftBaseWith = \ f -> liftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ fmap ComposeSt . runInBase . run+{-# INLINABLE defaultLiftBaseWith #-}++defaultRestoreM :: (MonadTransControl t, MonadBaseControl m) => ComposeSt t m a -> t m a+defaultRestoreM = restoreT . restoreM . unComposeSt+{-# INLINABLE defaultRestoreM #-}++$(let f :: Int -> Name -> Q Dec+ f n name =+ [InstanceD Nothing [] (ConT ''MonadBaseControl `AppT` t)+ [TySynInstD ''StM $ TySynEqn [t, VarT u] (VarT u),+ FunD 'liftBaseWith [Clause [VarP v] (NormalB (VarE v `AppE` VarE 'id)) []],+ ValD (VarP 'restoreM) (NormalB (VarE 'pure)) []]+ | t <- foldl' AppT (ConT name) <$> replicateM n (VarT <$> newName "a")+ , u <- newName "a"+ , v <- newName "f"]+ in traverse (uncurry f) [(0, ''IO), (1, ''L.ST), (1, ''S.ST), (0, ''STM),+ (0, ''Maybe), (1, ''Either), (0, ''Identity),+ (0, ''[]), (0, ''NonEmpty), (0, ''Proxy),+ (0, ''ReadP), (0, ''ReadPrec)])++instance Monoid a => MonadBaseControl ((,) a) where+ type StM ((,) a) b = b+ liftBaseWith f = f id+ restoreM = pure++instance MonadBaseControl ((->) a) where+ type StM ((->) a) b = b+ liftBaseWith f = f id+ restoreM = pure++$(let f :: Int -> Name -> Q Dec+ f n name = + [InstanceD Nothing [ConT ''MonadBaseControl `AppT` f] (ConT ''MonadBaseControl `AppT` AppT t f)+ [TySynInstD ''StM $ TySynEqn [AppT t f, a] (foldl' AppT (ConT ''ComposeSt) [t, f, a]),+ ValD (VarP 'liftBaseWith) (NormalB (VarE 'defaultLiftBaseWith)) [],+ ValD (VarP 'restoreM) (NormalB (VarE 'defaultRestoreM)) []]+ | t <- foldl' AppT (ConT name) <$> replicateM n (VarT <$> newName "a")+ , f <- VarT <$> newName "f"+ , a <- VarT <$> newName "a"]+ in traverse (uncurry f) [(0, ''IdentityT), (0, ''MaybeT), (1, ''ReaderT), (1, ''ExceptT),+ (1, ''L.StateT), (1, ''S.StateT)])++instance (MonadBaseControl f, Monoid a) => MonadBaseControl (L.WriterT a f) where+ type StM (L.WriterT a f) b = ComposeSt (L.WriterT a) f b+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++instance (MonadBaseControl f, Monoid a) => MonadBaseControl (S.WriterT a f) where+ type StM (S.WriterT a f) b = ComposeSt (S.WriterT a) f b+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++instance (MonadBaseControl f, Monoid a) => MonadBaseControl (AccumT a f) where+ type StM (AccumT a f) b = ComposeSt (AccumT a) f b+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM
+ Control/Monad/Trans/Control.hs view
@@ -0,0 +1,82 @@+module Control.Monad.Trans.Control where++import Control.Monad.Trans.Accum+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Lazy as L+import Control.Monad.Trans.State.Strict as S+import Control.Monad.Trans.Writer.Lazy as L+import Control.Monad.Trans.Writer.Strict as S++class MonadTrans t => MonadTransControl t where+ type StT t a+ liftWith :: Monad m => (Run t -> m a) -> t m a+ restoreT :: Monad m => m (StT t a) -> t m a++type Run t = ∀ n b . Monad n => t n b -> n (StT t b)++instance MonadTransControl IdentityT where+ type StT IdentityT a = a+ liftWith f = IdentityT $ f runIdentityT+ restoreT = IdentityT+ {-# INLINABLE liftWith #-}+ {-# INLINABLE restoreT #-}++instance MonadTransControl MaybeT where+ type StT MaybeT a = Maybe a+ liftWith f = MaybeT $ fmap pure $ f runMaybeT+ restoreT = MaybeT+ {-# INLINABLE liftWith #-}+ {-# INLINABLE restoreT #-}++instance MonadTransControl (ExceptT e) where+ type StT (ExceptT e) a = Either e a+ liftWith f = ExceptT $ fmap pure $ f runExceptT+ restoreT = ExceptT+ {-# INLINABLE liftWith #-}+ {-# INLINABLE restoreT #-}++instance MonadTransControl (ReaderT r) where+ type StT (ReaderT r) a = a+ liftWith f = ReaderT $ \ r -> f (flip runReaderT r)+ restoreT = ReaderT . pure+ {-# INLINABLE liftWith #-}+ {-# INLINABLE restoreT #-}++instance MonadTransControl (L.StateT s) where+ type StT (L.StateT s) a = (a, s)+ liftWith f = L.StateT $ \ s -> flip (,) s <$> f (flip L.runStateT s)+ restoreT = L.StateT . pure+ {-# INLINABLE liftWith #-}+ {-# INLINABLE restoreT #-}++instance MonadTransControl (S.StateT s) where+ type StT (S.StateT s) a = (a, s)+ liftWith f = S.StateT $ \ s -> flip (,) s <$> f (flip S.runStateT s)+ restoreT = S.StateT . pure+ {-# INLINABLE liftWith #-}+ {-# INLINABLE restoreT #-}++instance Monoid w => MonadTransControl (L.WriterT w) where+ type StT (L.WriterT w) a = (a, w)+ liftWith f = L.WriterT $ flip (,) mempty <$> f L.runWriterT+ restoreT = L.WriterT+ {-# INLINABLE liftWith #-}+ {-# INLINABLE restoreT #-}++instance Monoid w => MonadTransControl (S.WriterT w) where+ type StT (S.WriterT w) a = (a, w)+ liftWith f = S.WriterT $ flip (,) mempty <$> f S.runWriterT+ restoreT = S.WriterT+ {-# INLINABLE liftWith #-}+ {-# INLINABLE restoreT #-}++instance Monoid c => MonadTransControl (AccumT c) where+ type StT (AccumT c) a = (a, c)+ liftWith f = AccumT $ \ c -> flip (,) c <$> f (flip runAccumT c)+ restoreT = AccumT . pure+ {-# INLINABLE liftWith #-}+ {-# INLINABLE restoreT #-}
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright M Farkas-Dyck © 2018++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 M Farkas-Dyck 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.
+ README.md view
@@ -0,0 +1,1 @@+# control
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ control.cabal view
@@ -0,0 +1,48 @@+name: control+version: 0.1.0.0+synopsis: Class of monad transformers which control operations can be lifted thru+-- description:+license: BSD3+license-file: LICENSE+author: M Farkas-Dyck+maintainer: strake888@gmail.com+copyright: 2018 M Farkas-Dyck+category: Control+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ exposed-modules: Control.Monad.Base.Control+ , Control.Monad.Trans.Control+ build-depends: base >= 4.7 && < 5+ , basic >=0.1 && <0.2+ , stm+ , template-haskell+ , transformers >=0.5 && <0.6+ default-language: Haskell2010+ default-extensions: UnicodeSyntax+ , LambdaCase+ , EmptyCase+ , InstanceSigs+ , PartialTypeSignatures+ , PolyKinds+ , ConstraintKinds+ , FlexibleContexts+ , FlexibleInstances+ , RankNTypes+ , TypeFamilies+ , MonadComprehensions+ , StandaloneDeriving+ , DeriveFunctor, DeriveFoldable, DeriveTraversable+ ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing+ -Wincomplete-record-updates -Wincomplete-uni-patterns+ -Werror=incomplete-patterns+ -Werror=incomplete-uni-patterns+ -Werror=incomplete-record-updates+ -Werror=missing-fields+ -Werror=missing-methods++source-repository head+ type: git+ location: https://github.com/strake/control.hs