diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,15 @@ -0.4.2.0 +0.5.0.0 ------- -* Add default MTL instances for DispatchT. +* Support only GHC 8.0 and higher. +* Use the `TypeApplications` extension to get rid of `Proxy`. +* Remove `Control.Ether.TH`. +* Remove `Control.Ether.Abbr`. +* Unify `Dispatch` and `TaggedTrans`. +* Better `MonadBase` and `MonadBaseControl` instances. +* Add flattening for `ReaderT` and `StateT`. +* Add zooming for `MonadState`. +* Simpler module structure. 0.4.1.0 ------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Index Int +Copyright (c) 2017, Vladislav Zavialov All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Index Int nor the names of other + * Neither the name of Vladislav Zavialov nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,202 @@ +{-# OPTIONS -fno-warn-partial-type-signatures #-} + +module Main (main) where + +import Control.DeepSeq +import qualified Control.Lens as L +import qualified Control.Monad.Reader as M +import qualified Control.Monad.State as M +import Criterion.Main +import Ether + +id' :: a -> a +id' = id +{-# NOINLINE id' #-} + +readerCombinerMTL_flat_9 + :: M.MonadReader (Int, Int, Int, Int, Int, Int, Int, Int, Int) m + => m () +readerCombinerMTL_flat_9 = do + rnf <$> sequenceA + [ L.view L._1 + , L.view L._2 + , L.view L._3 + , L.view L._4 + , L.view L._5 + , L.view L._6 + , L.view L._7 + , L.view L._8 + , L.view L._9 ] +{-# NOINLINE readerCombinerMTL_flat_9 #-} + +stateCombinerMTL_flat_9 + :: M.MonadState (Int, Int, Int, Int, Int, Int, Int, Int, Int) m + => m () +stateCombinerMTL_flat_9 = do + M.modify (L.over L._1 id') + M.modify (L.over L._2 id') + M.modify (L.over L._3 id') + M.modify (L.over L._4 id') + M.modify (L.over L._5 id') + M.modify (L.over L._6 id') + M.modify (L.over L._7 id') + M.modify (L.over L._8 id') + M.modify (L.over L._9 id') + rnf <$> sequenceA + [ L.use L._1 + , L.use L._2 + , L.use L._3 + , L.use L._4 + , L.use L._5 + , L.use L._6 + , L.use L._7 + , L.use L._8 + , L.use L._9 ] +{-# NOINLINE stateCombinerMTL_flat_9 #-} + +run_readerCombinerMTL_flat_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> () +run_readerCombinerMTL_flat_9 + (a1, a2, a3, a4, a5, a6, a7, a8, a9) = + M.runReader readerCombinerMTL_flat_9 (a9, a8, a7, a6, a5, a4, a3, a2, a1) + +run_stateCombinerMTL_flat_9 :: + (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> + ((), (Int, Int, Int, Int, Int, Int, Int, Int, Int)) +run_stateCombinerMTL_flat_9 + (a1, a2, a3, a4, a5, a6, a7, a8, a9) = + M.runState stateCombinerMTL_flat_9 (a9, a8, a7, a6, a5, a4, a3, a2, a1) + +readerCombinerEther_sep_9 + :: ( MonadReader 1 Int m + , MonadReader 2 Int m + , MonadReader 3 Int m + , MonadReader 4 Int m + , MonadReader 5 Int m + , MonadReader 6 Int m + , MonadReader 7 Int m + , MonadReader 8 Int m + , MonadReader 9 Int m ) + => m () +readerCombinerEther_sep_9 = rnf <$> sequenceA + [ ask @1 + , ask @2 + , ask @3 + , ask @4 + , ask @5 + , ask @6 + , ask @7 + , ask @8 + , ask @9 ] +{-# NOINLINE readerCombinerEther_sep_9 #-} + +stateCombinerEther_sep_9 + :: ( MonadState 1 Int m + , MonadState 2 Int m + , MonadState 3 Int m + , MonadState 4 Int m + , MonadState 5 Int m + , MonadState 6 Int m + , MonadState 7 Int m + , MonadState 8 Int m + , MonadState 9 Int m ) + => m () +stateCombinerEther_sep_9 = do + modify @1 id' + modify @2 id' + modify @3 id' + modify @4 id' + modify @5 id' + modify @6 id' + modify @7 id' + modify @8 id' + modify @9 id' + rnf <$> sequenceA + [ get @1 + , get @2 + , get @3 + , get @4 + , get @5 + , get @6 + , get @7 + , get @8 + , get @9 ] +{-# NOINLINE stateCombinerEther_sep_9 #-} + +run_readerCombinerEther_nested_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> () +run_readerCombinerEther_nested_9 + (a1, a2, a3, a4, a5, a6, a7, a8, a9) + = flip (runReader @9) a1 + . flip (runReaderT @8) a2 + . flip (runReaderT @7) a3 + . flip (runReaderT @6) a4 + . flip (runReaderT @5) a5 + . flip (runReaderT @4) a6 + . flip (runReaderT @3) a7 + . flip (runReaderT @2) a8 + . flip (runReaderT @1) a9 + $ readerCombinerEther_sep_9 + +run_readerCombinerEther_flatten_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> () +run_readerCombinerEther_flatten_9 + (a1, a2, a3, a4, a5, a6, a7, a8, a9) + = + runReaders + readerCombinerEther_sep_9 + ( Tagged @1 a9, + Tagged @2 a8, + Tagged @3 a7, + Tagged @4 a6, + Tagged @5 a5, + Tagged @6 a4, + Tagged @7 a3, + Tagged @8 a2, + Tagged @9 a1 ) + +run_readerCombinerEther_flattenhalf_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> () +run_readerCombinerEther_flattenhalf_9 + (a1, a2, a3, a4, a5, a6, a7, a8, a9) = + flip runReaders + ( Tagged @1 a9, + Tagged @2 a8, + Tagged @3 a7, + Tagged @4 a6 ) . + flip runReadersT + ( Tagged @5 a5, + Tagged @6 a4, + Tagged @7 a3, + Tagged @8 a2, + Tagged @9 a1 ) $ + readerCombinerEther_sep_9 + +run_stateCombinerEther_flatten_9 :: + (Int, Int, Int, Int, Int, Int, Int, Int, Int) -> + ((), _) +run_stateCombinerEther_flatten_9 + (a1, a2, a3, a4, a5, a6, a7, a8, a9) + = + runStates + stateCombinerEther_sep_9 + ( Tagged @1 a9, + Tagged @2 a8, + Tagged @3 a7, + Tagged @4 a6, + Tagged @5 a5, + Tagged @6 a4, + Tagged @7 a3, + Tagged @8 a2, + Tagged @9 a1 ) + +tuple_9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int) +tuple_9 = (1, -2, 3, -4, 5, -6, 7, -8, 9) + +main :: IO () +main = do + defaultMain + [ bench "readerCombinerMTL_flat_9" $ nf run_readerCombinerMTL_flat_9 tuple_9 + , bench "readerCombinerEther_nested_9" $ nf run_readerCombinerEther_nested_9 tuple_9 + , bench "readerCombinerEther_flatten_9" $ nf run_readerCombinerEther_flatten_9 tuple_9 + , bench "readerCombinerEther_flattenhalf_9" $ + nf run_readerCombinerEther_flattenhalf_9 tuple_9 + , bench "stateCombinerMTL_flat_9" $ nf run_stateCombinerMTL_flat_9 tuple_9 + , bench "stateCombinerEther_flatten_9" $ nf run_stateCombinerEther_flatten_9 tuple_9 + ] diff --git a/ether.cabal b/ether.cabal --- a/ether.cabal +++ b/ether.cabal @@ -1,5 +1,5 @@ name: ether -version: 0.4.2.0 +version: 0.5.0.0 synopsis: Monad transformers and classes description: Ether is a Haskell library that extends @mtl@ and @transformers@ with @@ -10,8 +10,8 @@ category: Control license: BSD3 license-file: LICENSE -author: Index Int -maintainer: Index Int +author: Vladislav Zavialov +maintainer: Vladislav Zavialov homepage: https://int-index.github.io/ether/ bug-reports: https://github.com/int-index/ether/issues build-type: Simple @@ -20,108 +20,188 @@ source-repository head - type: git - location: git@github.com:int-index/ether.git + type: git + location: git@github.com:int-index/ether.git library - exposed-modules: Control.Ether.Abbr - Control.Ether.Implicit.Abbr - 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.Trans.Ether.Dispatch - Control.Monad.Trans.Ether.Tagged - Control.Monad.Ether - 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 - 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 + exposed-modules: + Ether + Ether.Reader + Ether.State + Ether.Writer + Ether.Except + Ether.TaggedTrans + Ether.TagDispatch + Ether.Internal - other-modules: Control.Ether.Util + build-depends: + base >=4.9 && <4.11, + transformers >=0.5.4.0, + transformers-lift >=0.2.0.0, + mtl >=2.2.1, + mmorph >=1.0.4, + monad-control >=1.0.0.4, + transformers-base >=0.4.4, + writer-cps-mtl >= 0.1.1.4, + exceptions >=0.8, + template-haskell >=2.11, + tagged >=0.8.5, + reflection >=2.1 - build-depends: base >=4.7 && <4.10 - , transformers >=0.4.2 - , transformers-lift >=0.1.0.1 - , mtl >=2.2.1 - , mmorph >=1.0.4 - , monad-control >=1.0.0.4 - , transformers-base >=0.4.4 - , exceptions >=0.8 - , template-haskell >=2.9 + default-language: + Haskell2010 - default-language: Haskell2010 - other-extensions: CPP - ConstraintKinds - DataKinds - DefaultSignatures - DeriveGeneric - FlexibleInstances - FunctionalDependencies - GeneralizedNewtypeDeriving - MultiParamTypeClasses - ScopedTypeVariables - TemplateHaskell - TypeFamilies - TypeOperators - UndecidableInstances + default-extensions: + AllowAmbiguousTypes + ConstraintKinds + DataKinds + DeriveGeneric + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + PartialTypeSignatures + PolyKinds + ScopedTypeVariables + RankNTypes + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeInType + TypeOperators + TypeSynonymInstances + UndecidableInstances + UndecidableSuperClasses - hs-source-dirs: src - ghc-options: -Wall + hs-source-dirs: + src + ghc-options: + -Wall -O2 test-suite regression - build-depends: base >=4.7 && <4.10 - , transformers >=0.4.2 - , mtl >=2.2.1 - , tasty >=0.10 - , tasty-quickcheck >=0.8 - , QuickCheck >=2.8 - , ether + build-depends: + base >=4.9 && <4.11, + transformers >=0.4.2, + mtl >=2.2.1, + tasty >=0.10, + tasty-quickcheck >=0.8, + QuickCheck >=2.8, + ghc-prim >=0.3, + lens >=4.14, + ether - main-is: Regression.hs - other-modules: Regression.T1 - Regression.T2 - Regression.T3 - Regression.T4 - Regression.T5 - Regression.T6 - Regression.T7 - Regression.T8 - Regression.T9 - Regression.T10 + main-is: + Regression.hs - type: exitcode-stdio-1.0 - hs-source-dirs: test - default-language: Haskell2010 - default-extensions: ConstraintKinds - DataKinds - EmptyDataDecls - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - PolyKinds - ScopedTypeVariables - TemplateHaskell - TypeFamilies - TypeOperators - ghc-options: -Wall -fno-warn-missing-signatures + other-modules: + Regression.T1 + Regression.T2 + Regression.T3 + Regression.T4 + Regression.T5 + Regression.T6 + Regression.T7 + Regression.T8 + Regression.T9 + Regression.T10 + Regression.T11 + Regression.T12 + + type: + exitcode-stdio-1.0 + + hs-source-dirs: + test + + default-language: + Haskell2010 + + default-extensions: + AllowAmbiguousTypes + ConstraintKinds + DataKinds + DeriveGeneric + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + PartialTypeSignatures + PolyKinds + ScopedTypeVariables + RankNTypes + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeInType + TypeOperators + TypeSynonymInstances + UndecidableInstances + UndecidableSuperClasses + + ghc-options: + -Wall -fno-warn-missing-signatures + + +benchmark bench + + build-depends: + base >=4.9 && <4.11, + mtl >=2.2.1, + transformers >=0.4.2, + criterion >=1.1, + deepseq >=1.4, + lens >=4.14, + ether + + main-is: + Bench.hs + + type: + exitcode-stdio-1.0 + + hs-source-dirs: + bench + + default-language: + Haskell2010 + + default-extensions: + AllowAmbiguousTypes + ConstraintKinds + DataKinds + DeriveGeneric + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + PartialTypeSignatures + PolyKinds + ScopedTypeVariables + RankNTypes + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeInType + TypeOperators + TypeSynonymInstances + UndecidableInstances + UndecidableSuperClasses + + ghc-options: + -Wall -O2 + + ghc-prof-options: + -fprof-auto diff --git a/src/Control/Ether/Abbr.hs b/src/Control/Ether/Abbr.hs deleted file mode 100644 --- a/src/Control/Ether/Abbr.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} - --- | Abbreviations for constraints. - -module Control.Ether.Abbr - ( type (-->) - , type (<--) - , type (<->) - , type (-!-) - , Ether - , ReifyAbbr - ) where - -import GHC.Exts (Constraint) - -import Control.Monad.Ether - --- | Turns an abbreviation into an actual constraint. -type family ReifyAbbr (abbr :: *) (m :: * -> *) :: Constraint - --- | Denotes 'MonadReader'. The mnemonic is that you read values of type @r@ --- from the reader environment tagged by @tag@, thus the arrows points --- from @tag@ to @r@. -data tag --> r -type instance ReifyAbbr (tag --> r) m = MonadReader tag r m - --- | Denotes 'MonadWriter'. The mnemonic is that you write values of type @w@ --- to the writer accumulator tagged by @tag@, thus the arrows points --- from @w@ to @tag@. -data tag <-- w -type instance ReifyAbbr (tag <-- w) m = MonadWriter tag w m - --- | Denotes 'MonadState'. The mnemonic is that you can both read from and --- write into the state, thus the arrow points in both directions. -data tag <-> s -type instance ReifyAbbr (tag <-> s) m = MonadState tag s m - --- | Denotes 'MonadExcept'. -data tag -!- e -type instance ReifyAbbr (tag -!- e) m = MonadExcept tag e m - --- | Reify a list of constraint abbreviations. --- --- > f :: Ether '[Foo --> r, Bar <-- w, Baz <-> s, Quux -!- e] m => m a --- --- expands into --- --- > f :: ( MonadReader Foo r m --- > , MonadWriter Bar w m --- > , MonadState Baz s m --- > , MonadExcept Quux e m --- > ) => m a - -type family Ether (abbrs :: [*]) m :: Constraint where - Ether '[] m = () - Ether (abbr ': abbrs) m = (ReifyAbbr abbr m, Ether abbrs m) diff --git a/src/Control/Ether/Implicit/Abbr.hs b/src/Control/Ether/Implicit/Abbr.hs deleted file mode 100644 --- a/src/Control/Ether/Implicit/Abbr.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - --- | See "Control.Ether.Abbr". - -module Control.Ether.Implicit.Abbr (R, W, S, E) where - -import Control.Ether.Abbr (ReifyAbbr) -import Control.Monad.Ether.Implicit - --- | Denotes 'MonadReader'. -data R r -type instance ReifyAbbr (R r) m = MonadReader r m - --- | Denotes 'MonadWriter'. -data W w -type instance ReifyAbbr (W w) m = MonadWriter w m - --- | Denotes 'MonadState'. -data S s -type instance ReifyAbbr (S s) m = MonadState s m - --- | Denotes 'MonadExcept'. -data E e -type instance ReifyAbbr (E e) m = MonadExcept e m - diff --git a/src/Control/Ether/TH.hs b/src/Control/Ether/TH.hs deleted file mode 100644 --- a/src/Control/Ether/TH.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} - --- | Template Haskell utilities. - -module Control.Ether.TH - ( ethereal - ) where - -import qualified Language.Haskell.TH as TH - -import Data.Proxy - -emptyDataDecl :: TH.Name -> TH.DecQ -#if __GLASGOW_HASKELL__ < 800 -emptyDataDecl name = TH.dataD (return []) name [] [] [] -#else -emptyDataDecl name = TH.dataD (return []) name [] Nothing [] (return []) -#endif - -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] diff --git a/src/Control/Ether/Util.hs b/src/Control/Ether/Util.hs deleted file mode 100644 --- a/src/Control/Ether/Util.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -module Control.Ether.Util - ( fmap - , MonadApplicative - ) where - -import Prelude hiding (fmap) - -#if __GLASGOW_HASKELL__ < 710 -import qualified Control.Applicative -import qualified Control.Monad -#else -import qualified Prelude -#endif - -#if __GLASGOW_HASKELL__ < 710 -fmap :: Monad f => (a -> b) -> f a -> f b -fmap = Control.Monad.liftM -#else -fmap :: Functor f => (a -> b) -> f a -> f b -fmap = Prelude.fmap -#endif - -{-# INLINE fmap #-} - -#if __GLASGOW_HASKELL__ < 710 -type MonadApplicative m = - ( Control.Applicative.Applicative m - , Control.Monad.Monad m ) -#else -type MonadApplicative = Monad -#endif diff --git a/src/Control/Monad/Ether.hs b/src/Control/Monad/Ether.hs deleted file mode 100644 --- a/src/Control/Monad/Ether.hs +++ /dev/null @@ -1,14 +0,0 @@ - --- | This module provides convenience exports of all --- tagged monad classes from Ether. - -module Control.Monad.Ether (module X) where - -import Control.Monad as X -import Control.Monad.Fix as X -import Control.Monad.Ether.Reader as X -import Control.Monad.Ether.Writer as X -import Control.Monad.Ether.State as X -import Control.Monad.Ether.Except as X -import Control.Monad.Trans.Ether.Dispatch as X -import Control.Ether.TH as X (ethereal) diff --git a/src/Control/Monad/Ether/Except.hs b/src/Control/Monad/Ether/Except.hs deleted file mode 100644 --- a/src/Control/Monad/Ether/Except.hs +++ /dev/null @@ -1,30 +0,0 @@ - --- | See "Control.Monad.Except". - -module Control.Monad.Ether.Except - ( - -- * MonadExcept class - MonadExcept(..) - -- * The Except monad - , Except - , runExcept - -- * The ExceptT monad transformer - , ExceptT - , exceptT - , runExceptT - -- * Handle functions - , handleT - , handle - ) where - -import Control.Monad.Ether.Except.Class -import Control.Monad.Trans.Ether.Except hiding (throw, catch) -import Data.Functor.Identity (Identity(..)) - --- | Runs an 'Except' and handles the exception with the given function. -handle :: proxy tag -> (e -> a) -> Except tag e a -> a -handle t h m = runIdentity (handleT t h m) - --- | Runs an 'ExceptT' and handles the exception with the given function. -handleT :: Functor m => proxy tag -> (e -> a) -> ExceptT tag e m a -> m a -handleT t h m = fmap (either h id) (runExceptT t m) diff --git a/src/Control/Monad/Ether/Except/Class.hs b/src/Control/Monad/Ether/Except/Class.hs deleted file mode 100644 --- a/src/Control/Monad/Ether/Except/Class.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} - --- | See "Control.Monad.Except". - -module Control.Monad.Ether.Except.Class - ( MonadExcept(..) - ) where - -import qualified Control.Monad.Trans.Ether.Except as E -import qualified Control.Monad.Trans.Lift.Catch as Lift - - --- | 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 (Monad m, e ~ e') => MonadExcept tag e (E.ExceptT tag e' m) where - throw = E.throw - catch = E.catch - -instance {-# OVERLAPPABLE #-} - ( Lift.LiftCatch t - , Monad (t m) - , MonadExcept tag e m - ) => MonadExcept tag e (t m) where - throw t = Lift.lift . throw t - catch t = Lift.liftCatch (catch t) diff --git a/src/Control/Monad/Ether/Implicit.hs b/src/Control/Monad/Ether/Implicit.hs deleted file mode 100644 --- a/src/Control/Monad/Ether/Implicit.hs +++ /dev/null @@ -1,14 +0,0 @@ - --- | This module provides convenience exports of all --- implicitly tagged monad classes from Ether. - -module Control.Monad.Ether.Implicit (module X) where - -import Control.Monad as X -import Control.Monad.Fix as X -import Control.Monad.Ether.Implicit.Reader as X -import Control.Monad.Ether.Implicit.Writer as X -import Control.Monad.Ether.Implicit.State as X -import Control.Monad.Ether.Implicit.Except as X -import Control.Monad.Trans.Ether.Dispatch as X -import Control.Ether.TH as X (ethereal) diff --git a/src/Control/Monad/Ether/Implicit/Except.hs b/src/Control/Monad/Ether/Implicit/Except.hs deleted file mode 100644 --- a/src/Control/Monad/Ether/Implicit/Except.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# 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 - -- * Handle functions - , handle - , handleT - ) 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.handle'. -handle :: (e -> a) -> Except e a -> a -handle = Explicit.handle Proxy - --- | See 'Control.Monad.Ether.Except.handleT'. -handleT :: Functor m => (e -> a) -> ExceptT e m a -> m a -handleT = Explicit.handleT Proxy diff --git a/src/Control/Monad/Ether/Implicit/Reader.hs b/src/Control/Monad/Ether/Implicit/Reader.hs deleted file mode 100644 --- a/src/Control/Monad/Ether/Implicit/Reader.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# 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 - ) 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.MonadReader'. -type MonadReader r = Explicit.MonadReader r r - --- | See 'Control.Monad.Ether.Reader.local'. -local :: forall r m a . MonadReader r m => (r -> r) -> m a -> m a -local = Explicit.local (Proxy :: Proxy r) - --- | See 'Control.Monad.Ether.Reader.ask'. -ask :: forall r m . MonadReader r m => m r -ask = Explicit.ask (Proxy :: Proxy r) - --- | See 'Control.Monad.Ether.Reader.reader'. -reader :: forall r m a . MonadReader r m => (r -> a) -> m a -reader = Explicit.reader (Proxy :: Proxy r) - --- | See 'Control.Monad.Ether.Reader.asks'. -asks :: forall r m 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 deleted file mode 100644 --- a/src/Control/Monad/Ether/Implicit/State.hs +++ /dev/null @@ -1,8 +0,0 @@ - --- | 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 deleted file mode 100644 --- a/src/Control/Monad/Ether/Implicit/State/Lazy.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# 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 - ) 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.MonadState'. -type MonadState s = Explicit.MonadState s s - --- | See 'Control.Monad.Ether.State.Lazy.get'. -get :: forall s m . MonadState s m => m s -get = Explicit.get (Proxy :: Proxy s) - --- | See 'Control.Monad.Ether.State.Lazy.gets'. -gets :: forall s m a . MonadState s m => (s -> a) -> m a -gets = Explicit.gets (Proxy :: Proxy s) - --- | See 'Control.Monad.Ether.State.Lazy.put'. -put :: forall s m . MonadState s m => s -> m () -put = Explicit.put (Proxy :: Proxy s) - --- | See 'Control.Monad.Ether.State.Lazy.state'. -state :: forall s m a . MonadState s m => (s -> (a, s)) -> m a -state = Explicit.state (Proxy :: Proxy s) - --- | See 'Control.Monad.Ether.State.Lazy.modify'. -modify :: forall s m . 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 deleted file mode 100644 --- a/src/Control/Monad/Ether/Implicit/State/Strict.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# 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 - ) 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.MonadState'. -type MonadState s = Explicit.MonadState s s - --- | See 'Control.Monad.Ether.State.Strict.get'. -get :: forall s m . MonadState s m => m s -get = Explicit.get (Proxy :: Proxy s) - --- | See 'Control.Monad.Ether.State.Strict.gets'. -gets :: forall s m a . MonadState s m => (s -> a) -> m a -gets = Explicit.gets (Proxy :: Proxy s) - --- | See 'Control.Monad.Ether.State.Strict.put'. -put :: forall s m . MonadState s m => s -> m () -put = Explicit.put (Proxy :: Proxy s) - --- | See 'Control.Monad.Ether.State.Strict.state'. -state :: forall s m a . MonadState s m => (s -> (a, s)) -> m a -state = Explicit.state (Proxy :: Proxy s) - --- | See 'Control.Monad.Ether.State.Strict.modify'. -modify :: forall s m . 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 deleted file mode 100644 --- a/src/Control/Monad/Ether/Implicit/Writer.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# 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 w m a . MonadWriter w m => (a, w) -> m a -writer = Explicit.writer (Proxy :: Proxy w) - --- | See 'Control.Monad.Ether.Writer.tell'. -tell :: forall w m . MonadWriter w m => w -> m () -tell = Explicit.tell (Proxy :: Proxy w) - --- | See 'Control.Monad.Ether.Writer.listen'. -listen :: forall w m a . MonadWriter w m => m a -> m (a, w) -listen = Explicit.listen (Proxy :: Proxy w) - --- | See 'Control.Monad.Ether.Writer.pass'. -pass :: forall w m a . MonadWriter w m => m (a, w -> w) -> m a -pass = Explicit.pass (Proxy :: Proxy w) - --- | See 'Control.Monad.Ether.Writer.listens'. -listens :: forall w m 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 w m 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 deleted file mode 100644 --- a/src/Control/Monad/Ether/Reader.hs +++ /dev/null @@ -1,19 +0,0 @@ - --- | 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 - ) 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 deleted file mode 100644 --- a/src/Control/Monad/Ether/Reader/Class.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} - --- | See "Control.Monad.Reader.Class". - -module Control.Monad.Ether.Reader.Class - ( MonadReader(..) - , asks - ) where - -import qualified Control.Monad.Trans.Ether.Reader as R -import qualified Control.Monad.Trans.Lift.Local as Lift -import qualified Control.Ether.Util as Util - --- | 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 = Util.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 (Monad m, r ~ r') => MonadReader tag r (R.ReaderT tag r' m) where - ask = R.ask - local = R.local - reader = R.reader - -instance {-# OVERLAPPABLE #-} - ( Lift.LiftLocal t - , Monad (t m) - , MonadReader tag r m - ) => MonadReader tag r (t m) where - ask t = Lift.lift (ask t) - local t = Lift.liftLocal (ask t) (local t) diff --git a/src/Control/Monad/Ether/State.hs b/src/Control/Monad/Ether/State.hs deleted file mode 100644 --- a/src/Control/Monad/Ether/State.hs +++ /dev/null @@ -1,8 +0,0 @@ - --- | 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 deleted file mode 100644 --- a/src/Control/Monad/Ether/State/Class.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} - --- | See "Control.Monad.State.Class". - -module Control.Monad.Ether.State.Class - ( MonadState(..) - , modify - , gets - ) where - -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 as Lift -import qualified Control.Ether.Util as Util - --- | 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 = Util.fmap f (get t) - -instance (Monad m, s ~ s') => MonadState tag s (S.L.StateT tag s' m) where - get = S.L.get - put = S.L.put - state = S.L.state - -instance (Monad m, s ~ s') => MonadState tag s (S.S.StateT tag s' m) where - get = S.S.get - put = S.S.put - state = S.S.state - -instance {-# OVERLAPPABLE #-} - ( Lift.MonadTrans t - , Monad (t m) - , MonadState tag s m - ) => MonadState tag s (t m) where - get t = Lift.lift (get t) - put t = Lift.lift . put t - state t = Lift.lift . state t diff --git a/src/Control/Monad/Ether/State/Lazy.hs b/src/Control/Monad/Ether/State/Lazy.hs deleted file mode 100644 --- a/src/Control/Monad/Ether/State/Lazy.hs +++ /dev/null @@ -1,24 +0,0 @@ - --- | 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 - ) 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 deleted file mode 100644 --- a/src/Control/Monad/Ether/State/Strict.hs +++ /dev/null @@ -1,24 +0,0 @@ - --- | 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 - ) 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 deleted file mode 100644 --- a/src/Control/Monad/Ether/Writer.hs +++ /dev/null @@ -1,22 +0,0 @@ - --- | 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 - ) 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 deleted file mode 100644 --- a/src/Control/Monad/Ether/Writer/Class.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} - --- | See "Control.Monad.Writer.Class". - -module Control.Monad.Ether.Writer.Class - ( MonadWriter(..) - , listens - , censor - ) where - -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif - -import qualified Control.Monad.Trans.Ether.Writer as W -import qualified Control.Monad.Trans.Lift.Listen as Lift -import qualified Control.Monad.Trans.Lift.Pass as Lift - --- | 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 (Monoid w, Monad m, w ~ w') => MonadWriter tag w (W.WriterT tag w' m) where - writer = W.writer - tell = W.tell - listen = W.listen - pass = W.pass - -instance {-# OVERLAPPABLE #-} - ( Lift.LiftListen t - , Lift.LiftPass t - , Monad (t m) - , MonadWriter tag w m - , Monoid w - ) => MonadWriter tag w (t m) where - writer t = Lift.lift . writer t - tell t = Lift.lift . tell t - listen t = Lift.liftListen (listen t) - pass t = Lift.liftPass (pass t) diff --git a/src/Control/Monad/Trans/Ether/Dispatch.hs b/src/Control/Monad/Trans/Ether/Dispatch.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Ether/Dispatch.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif - -#if __GLASGOW_HASKELL__ >= 710 -{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} -#endif - -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{- | - -Type-level machinery to manipulate constraints on the monad -transformer stack. - -Out of the box it provides the following dispatch strategies: - -* 'tagAttach' to use functions defined using untagged monad classes - as if they were defined using tagged ones. - -* 'tagReplace' to use functions defined using one tag - as if they were defined using another one. - -> import qualified Control.Monad.State as T -> import Control.Ether.TH (ethereal) -> import Control.Monad.Ether.State (MonadState) -> import Control.Monad.Trans.Ether.Dispatch (tagAttach, tagDispatch) -> -> ethereal "Foo" "foo" -> ethereal "Bar" "bar" -> -> f :: T.MonadState Int m => m String -> f = fmap show T.get -> -> g :: MonadState Foo Int m => m String -> g = tagAttach foo f -> -> h :: MonadState Bar Int m => m String -> h = tagReplace foo bar g - --} - -module Control.Monad.Trans.Ether.Dispatch - ( - -- * The DispatchT monad transformer - DispatchT(..) - -- * Dispatch types and functions - , K_TagAttach(..) - , K_TagReplace(..) - , tagAttach - , tagReplace - ) where - -import Control.Applicative -import Control.Monad (MonadPlus) -import Control.Monad.Fix (MonadFix) -import Control.Monad.Trans.Class (MonadTrans) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Morph (MFunctor, MMonad) -import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) -import GHC.Generics (Generic) -import Data.Coerce (coerce) -import Data.Proxy - -import qualified Control.Monad.Base as MB -import qualified Control.Monad.Trans.Control as MC -import qualified Control.Monad.Trans.Identity as Trans - -import qualified Control.Monad.Trans.Lift.StT as Lift -import qualified Control.Monad.Trans.Lift.Local as Lift -import qualified Control.Monad.Trans.Lift.Catch as Lift -import qualified Control.Monad.Trans.Lift.Listen as Lift -import qualified Control.Monad.Trans.Lift.Pass as Lift -import qualified Control.Monad.Trans.Lift.CallCC as Lift - -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.Cont as 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 - --- | Encode type-level information for 'tagAttach'. -data K_TagAttach t = TagAttach t - --- | Encode type-level information for 'tagReplace'. -data K_TagReplace tOld tNew = TagReplace tOld tNew - --- | Wrap a monad to change its tags. Under the hood this is --- simply 'Trans.IdentityT', all the work is happening on the type level. -newtype DispatchT dp m a = DispatchT (Trans.IdentityT m a) - deriving - ( Generic - , Functor, Applicative, Alternative, Monad, MonadPlus - , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad - , MonadThrow, MonadCatch, MonadMask ) - -type DispatchTagAttachT t = DispatchT (TagAttach t) -type DispatchTagReplaceT tOld tNew = DispatchT (TagReplace tOld tNew) - --- | Type-restricted 'coerce'. -pack :: Trans.IdentityT m a -> DispatchT dp m a -pack = coerce - --- | Type-restricted 'coerce'. -unpack :: DispatchT dp m a -> Trans.IdentityT m a -unpack = coerce - -instance MB.MonadBase b m => MB.MonadBase b (DispatchT dp m) where - liftBase = MB.liftBaseDefault - -instance MC.MonadTransControl (DispatchT dp) where - type StT (DispatchT dp) a = MC.StT Trans.IdentityT a - liftWith = MC.defaultLiftWith pack unpack - restoreT = MC.defaultRestoreT pack - -instance MC.MonadBaseControl b m => MC.MonadBaseControl b (DispatchT dp m) where - type StM (DispatchT dp m) a = MC.ComposeSt (DispatchT dp) m a - liftBaseWith = MC.defaultLiftBaseWith - restoreM = MC.defaultRestoreM - -type instance Lift.StT (DispatchT dp) a = MC.StT (DispatchT dp) a - -instance Lift.LiftLocal (DispatchT dp) where - liftLocal = Lift.defaultLiftLocal pack unpack - -instance Lift.LiftCatch (DispatchT dp) where - liftCatch = Lift.defaultLiftCatch pack unpack - -instance Lift.LiftListen (DispatchT dp) where - liftListen = Lift.defaultLiftListen pack unpack - -instance Lift.LiftPass (DispatchT dp) where - liftPass = Lift.defaultLiftPass pack unpack - -instance Lift.LiftCallCC (DispatchT dp) where - liftCallCC = Lift.defaultLiftCallCC pack unpack - liftCallCC' = Lift.defaultLiftCallCC' pack unpack - --- | Attach a tag to untagged transformers. -tagAttach :: proxy t -> DispatchTagAttachT t m a -> m a -tagAttach _ = coerce - --- | Replace a tag with another tag. -tagReplace - :: proxy tOld - -> proxy tNew - -> DispatchTagReplaceT tOld tNew m a - -> m a -tagReplace _ _ = coerce - - --- TagAttach instances - -instance MonadReader tag r m - => Class.MonadReader r (DispatchTagAttachT tag m) where - ask = let t = Proxy :: Proxy tag in Lift.lift (ask t) - local = let t = Proxy :: Proxy tag in Lift.liftLocal (ask t) (local t) - -instance MonadState tag s m - => Class.MonadState s (DispatchTagAttachT tag m) where - get = let t = Proxy :: Proxy tag in Lift.lift (get t) - put = let t = Proxy :: Proxy tag in Lift.lift . put t - -instance MonadExcept tag e m - => Class.MonadError e (DispatchTagAttachT tag m) where - throwError = let t = Proxy :: Proxy tag in Lift.lift . throw t - catchError = let t = Proxy :: Proxy tag in Lift.liftCatch (catch t) - -instance MonadWriter tag w m - => Class.MonadWriter w (DispatchTagAttachT tag m) where - writer = let t = Proxy :: Proxy tag in Lift.lift . writer t - tell = let t = Proxy :: Proxy tag in Lift.lift . tell t - listen = let t = Proxy :: Proxy tag in Lift.liftListen (listen t) - pass = let t = Proxy :: Proxy tag in Lift.liftPass (pass t) - - --- TagReplace instances - -instance MonadReader tNew r m - => MonadReader tOld r (DispatchTagReplaceT tOld tNew m) where - ask _ = let t = Proxy :: Proxy tNew in Lift.lift (ask t) - local _ = let t = Proxy :: Proxy tNew in Lift.liftLocal (ask t) (local t) - -instance MonadState tNew s m - => MonadState tOld s (DispatchTagReplaceT tOld tNew m) where - get _ = let t = Proxy :: Proxy tNew in Lift.lift (get t) - put _ = let t = Proxy :: Proxy tNew in Lift.lift . put t - -instance MonadExcept tNew e m - => MonadExcept tOld e (DispatchTagReplaceT tOld tNew m) where - throw _ = let t = Proxy :: Proxy tNew in Lift.lift . throw t - catch _ = let t = Proxy :: Proxy tNew in Lift.liftCatch (catch t) - -instance MonadWriter tNew w m - => MonadWriter tOld w (DispatchTagReplaceT tOld tNew m) where - writer _ = let t = Proxy :: Proxy tNew in Lift.lift . writer t - tell _ = let t = Proxy :: Proxy tNew in Lift.lift . tell t - listen _ = let t = Proxy :: Proxy tNew in Lift.liftListen (listen t) - pass _ = let t = Proxy :: Proxy tNew in Lift.liftPass (pass t) - - --- Instances for mtl classes - -instance {-# OVERLAPPABLE #-} - ( Class.MonadCont m - ) => Class.MonadCont (DispatchT dp m) - where - callCC = Lift.liftCallCC' Class.callCC - -instance {-# OVERLAPPABLE #-} - ( Class.MonadReader r m - ) => Class.MonadReader r (DispatchT dp m) - where - ask = Class.lift Class.ask - local = Lift.liftLocal Class.ask Class.local - reader = Class.lift . Class.reader - -instance {-# OVERLAPPABLE #-} - ( Class.MonadState s m - ) => Class.MonadState s (DispatchT dp m) - where - get = Class.lift Class.get - put = Class.lift . Class.put - state = Class.lift . Class.state - -instance {-# OVERLAPPABLE #-} - ( Class.MonadWriter w m - ) => Class.MonadWriter w (DispatchT dp m) - where - writer = Class.lift . Class.writer - tell = Class.lift . Class.tell - listen = Lift.liftListen Class.listen - pass = Lift.liftPass Class.pass - -instance {-# OVERLAPPABLE #-} - ( Class.MonadError e m - ) => Class.MonadError e (DispatchT dp m) - where - throwError = Class.lift . Class.throwError - catchError = Lift.liftCatch Class.catchError diff --git a/src/Control/Monad/Trans/Ether/Except.hs b/src/Control/Monad/Trans/Ether/Except.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Ether/Except.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# 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 - -- * Exception operations - , throw - , catch - ) where - -import Data.Functor.Identity (Identity(..)) -import qualified Control.Monad.Trans.Except as Trans -import Control.Monad.Trans.Ether.Tagged - - --- | 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 _ = Trans.runExcept . unpack - --- | The exception monad transformer. --- --- The 'return' function returns a normal value, while '>>=' exits on --- the first exception. -type ExceptT tag e = TaggedTrans tag (Trans.ExceptT e) - --- | Constructor for computations in the exception monad transformer. -exceptT :: proxy tag -> m (Either e a) -> ExceptT tag e m a -exceptT _ = pack . 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 _ = Trans.runExceptT . unpack - --- | Is used within a monadic computation to begin exception processing. -throw :: Monad m => proxy tag -> e -> ExceptT tag e m a -throw _ = pack . 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 _ m h = pack $ Trans.catchE (unpack m) (unpack . h) diff --git a/src/Control/Monad/Trans/Ether/Reader.hs b/src/Control/Monad/Trans/Ether/Reader.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Ether/Reader.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# 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 - -- * Reader operations - , ask - , local - ) where - -import Data.Functor.Identity (Identity(..)) -import qualified Control.Monad.Trans.Reader as Trans -import Control.Monad.Trans.Ether.Tagged - --- | 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. -type ReaderT tag r = TaggedTrans tag (Trans.ReaderT r) - --- | Constructor for computations in the reader monad transformer. -readerT :: proxy tag -> (r -> m a) -> ReaderT tag r m a -readerT _ = pack . 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 _ = pack . Trans.reader - --- | Runs a 'ReaderT' with the given environment --- and returns the final value. -runReaderT :: proxy tag -> ReaderT tag r m a -> r -> m a -runReaderT _ = Trans.runReaderT . unpack - --- | Runs a 'ReaderT' with the given environment --- and returns the final value. -runReader :: proxy tag -> Reader tag r a -> r -> a -runReader _ = Trans.runReader . unpack - --- | Fetch the value of the environment. -ask :: Monad m => proxy tag -> ReaderT tag r m r -ask _ = pack 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 _ f = pack . Trans.withReaderT f . unpack diff --git a/src/Control/Monad/Trans/Ether/State.hs b/src/Control/Monad/Trans/Ether/State.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Ether/State.hs +++ /dev/null @@ -1,8 +0,0 @@ - --- | 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 deleted file mode 100644 --- a/src/Control/Monad/Trans/Ether/State/Lazy.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# 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 - -- * State operations - , get - , put - ) where - -import Data.Functor.Identity (Identity(..)) -import qualified Control.Monad.Trans.State.Lazy as Trans -import Control.Monad.Trans.Ether.Tagged - --- | 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. -type StateT tag s = TaggedTrans tag (Trans.StateT s) - --- | Constructor for computations in the state monad transformer. -stateT :: proxy tag -> (s -> m (a, s)) -> StateT tag s m a -stateT _ = pack . 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 _ = pack . 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 _ = Trans.runStateT . unpack - --- | 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 _ = Trans.evalStateT . unpack - --- | 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 _ = Trans.execStateT . unpack - --- | 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 _ = Trans.runState . unpack - --- | 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 _ = Trans.evalState . unpack - --- | 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 _ = Trans.execState . unpack - --- | Fetch the current value of the state within the monad. -get :: Monad m => proxy tag -> StateT tag s m s -get _ = pack Trans.get - --- | Set the value of the state within the monad. -put :: Monad m => proxy tag -> s -> StateT tag s m () -put _ = pack . Trans.put diff --git a/src/Control/Monad/Trans/Ether/State/Strict.hs b/src/Control/Monad/Trans/Ether/State/Strict.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Ether/State/Strict.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# 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 - -- * State operations - , get - , put - ) where - -import Data.Functor.Identity (Identity(..)) -import qualified Control.Monad.Trans.State.Strict as Trans -import Control.Monad.Trans.Ether.Tagged - --- | 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. -type StateT tag s = TaggedTrans tag (Trans.StateT s) - --- | Constructor for computations in the state monad transformer. -stateT :: proxy tag -> (s -> m (a, s)) -> StateT tag s m a -stateT _ = pack . 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 _ = pack . 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 _ = Trans.runStateT . unpack - --- | 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 _ = Trans.evalStateT . unpack - --- | 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 _ = Trans.execStateT . unpack - --- | 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 _ = Trans.runState . unpack - --- | 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 _ = Trans.evalState . unpack - --- | 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 _ = Trans.execState . unpack - --- | Fetch the current value of the state within the monad. -get :: Monad m => proxy tag -> StateT tag s m s -get _ = pack Trans.get - --- | Set the value of the state within the monad. -put :: Monad m => proxy tag -> s -> StateT tag s m () -put _ = pack . Trans.put diff --git a/src/Control/Monad/Trans/Ether/Tagged.hs b/src/Control/Monad/Trans/Ether/Tagged.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Ether/Tagged.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} - --- | This module defines the core data type of Ether, 'TaggedTrans', --- and a bunch of instances for it. 'TaggedTrans' attaches a tag to --- an existing monad transformer. - -module Control.Monad.Trans.Ether.Tagged where - -import Control.Applicative -import Control.Monad (MonadPlus) -import Control.Monad.Fix (MonadFix) -import Control.Monad.Trans.Class (MonadTrans, lift) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Morph (MFunctor, MMonad) -import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) - -import qualified Control.Monad.Base as MB -import qualified Control.Monad.Trans.Control as MC - -import qualified Control.Monad.Trans.Lift.StT as Lift -import qualified Control.Monad.Trans.Lift.Local as Lift -import qualified Control.Monad.Trans.Lift.Catch as Lift -import qualified Control.Monad.Trans.Lift.Listen as Lift -import qualified Control.Monad.Trans.Lift.Pass as Lift -import qualified Control.Monad.Trans.Lift.CallCC as Lift - -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 - -import GHC.Generics (Generic) -import Data.Coerce (coerce) - -import Control.Ether.Util (MonadApplicative) - --- | Tagged monad transformer. -newtype TaggedTrans tag trans (m :: * -> *) a = TaggedTrans (trans m a) - deriving - ( Generic - , Functor, Applicative, Alternative, Monad, MonadPlus - , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad - , MonadThrow, MonadCatch, MonadMask ) - --- | Type-restricted 'coerce'. -pack :: trans m a -> TaggedTrans tag trans m a -pack = coerce - --- | Type-restricted 'coerce'. -unpack :: TaggedTrans tag trans m a -> trans m a -unpack = coerce - -instance - ( MB.MonadBase b m - , MonadTrans trans - , MonadApplicative (trans m) - ) => MB.MonadBase b (TaggedTrans tag trans m) - where - liftBase = MB.liftBaseDefault - -instance - ( MC.MonadTransControl trans - ) => MC.MonadTransControl (TaggedTrans tag trans) - where - type StT (TaggedTrans tag trans) a = MC.StT trans a - liftWith = MC.defaultLiftWith pack unpack - restoreT = MC.defaultRestoreT pack - -instance - ( MC.MonadBaseControl b m - , MC.MonadTransControl trans - , MonadApplicative (trans m) - ) => MC.MonadBaseControl b (TaggedTrans tag trans m) - where - type StM (TaggedTrans tag trans m) a = MC.ComposeSt trans m a - liftBaseWith = MC.defaultLiftBaseWith - restoreM = MC.defaultRestoreM - -type instance Lift.StT (TaggedTrans tag trans) a = Lift.StT trans a - -instance Lift.LiftLocal trans => Lift.LiftLocal (TaggedTrans tag trans) where - liftLocal = Lift.defaultLiftLocal pack unpack - -instance Lift.LiftCatch trans => Lift.LiftCatch (TaggedTrans tag trans) where - liftCatch = Lift.defaultLiftCatch pack unpack - -instance Lift.LiftListen trans => Lift.LiftListen (TaggedTrans tag trans) where - liftListen = Lift.defaultLiftListen pack unpack - -instance Lift.LiftPass trans => Lift.LiftPass (TaggedTrans tag trans) where - liftPass = Lift.defaultLiftPass pack unpack - -instance Lift.LiftCallCC trans => Lift.LiftCallCC (TaggedTrans tag trans) where - liftCallCC = Lift.defaultLiftCallCC pack unpack - liftCallCC' = Lift.defaultLiftCallCC' pack unpack - --- Instances for mtl classes - -instance - ( Class.MonadCont m - , Lift.LiftCallCC trans - , Monad (trans m) - ) => Class.MonadCont (TaggedTrans tag trans m) - where - callCC = Lift.liftCallCC' Class.callCC - -instance - ( Class.MonadReader r m - , Lift.LiftLocal trans - , Monad (trans m) - ) => Class.MonadReader r (TaggedTrans tag trans m) - where - ask = lift Class.ask - local = Lift.liftLocal Class.ask Class.local - reader = lift . Class.reader - -instance - ( Class.MonadState s m - , MonadTrans trans - , Monad (trans m) - ) => Class.MonadState s (TaggedTrans tag trans m) - where - get = lift Class.get - put = lift . Class.put - state = lift . Class.state - -instance - ( Class.MonadWriter w m - , Lift.LiftListen trans - , Lift.LiftPass trans - , Monad (trans m) - ) => Class.MonadWriter w (TaggedTrans tag trans m) - where - writer = lift . Class.writer - tell = lift . Class.tell - listen = Lift.liftListen Class.listen - pass = Lift.liftPass Class.pass - -instance - ( Class.MonadError e m - , Lift.LiftCatch trans - , Monad (trans m) - ) => Class.MonadError e (TaggedTrans tag trans m) - where - throwError = lift . Class.throwError - catchError = Lift.liftCatch Class.catchError diff --git a/src/Control/Monad/Trans/Ether/Writer.hs b/src/Control/Monad/Trans/Ether/Writer.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Ether/Writer.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# 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 - -- * Writer operations - , tell - , listen - , pass - ) where - -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif - -import Data.Functor.Identity (Identity(..)) -import qualified Control.Monad.Trans.Writer.Lazy as Trans -import Control.Monad.Trans.Ether.Tagged - --- | 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'. -type WriterT tag w = TaggedTrans tag (Trans.WriterT w) - --- | Constructor for computations in the writer monad transformer. -writerT :: proxy tag -> m (a, w) -> WriterT tag w m a -writerT _ = pack . 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 _ = pack . 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 _ = Trans.runWriterT . unpack - --- | Runs a 'Writer' and returns both the normal value --- and the final accumulator. -runWriter :: proxy tag -> Writer tag w a -> (a, w) -runWriter _ = Trans.runWriter . unpack - --- | 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 _ = Trans.execWriterT . unpack - --- | Runs a 'Writer' and returns the final accumulator, --- discarding the normal value. -execWriter :: proxy tag -> Writer tag w a -> w -execWriter _ = Trans.execWriter . unpack - --- | 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 -#if __GLASGOW_HASKELL__ < 800 - :: (Monad m, Monoid w) -#else - :: Monad m -#endif - => proxy tag -> WriterT tag w m a -> WriterT tag w m (a, w) -listen _ = pack . Trans.listen . unpack - --- | Executes an action which returns a value and a function, and returns the --- value, applying the function to the accumulator. -pass -#if __GLASGOW_HASKELL__ < 800 - :: (Monad m, Monoid w) -#else - :: Monad m -#endif - => proxy tag -> WriterT tag w m (a, w -> w) -> WriterT tag w m a -pass _ = pack . Trans.pass . unpack diff --git a/src/Ether.hs b/src/Ether.hs new file mode 100644 --- /dev/null +++ b/src/Ether.hs @@ -0,0 +1,25 @@ +module Ether + ( module Control.Monad + , module Control.Monad.Fix + , module Control.Monad.Trans.Identity + , module Data.Functor.Identity + , module Data.Tagged + , module Ether.Reader + , module Ether.Writer + , module Ether.State + , module Ether.Except + , module Ether.TagDispatch + , module Ether.TaggedTrans + ) where + +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Trans.Identity +import Data.Functor.Identity +import Data.Tagged +import Ether.Reader +import Ether.Writer +import Ether.State +import Ether.Except +import Ether.TagDispatch +import Ether.TaggedTrans diff --git a/src/Ether/Except.hs b/src/Ether/Except.hs new file mode 100644 --- /dev/null +++ b/src/Ether/Except.hs @@ -0,0 +1,141 @@ +module Ether.Except + ( + -- * MonadExcept class + MonadExcept + , throw + , catch + -- * The Except monad + , Except + , runExcept + -- * The ExceptT monad transformer + , ExceptT + , exceptT + , runExceptT + -- * MonadExcept class (implicit) + , MonadExcept' + , throw' + , catch' + -- * The Except monad (implicit) + , Except' + , runExcept' + -- * The ExceptT monad transformer (implicit) + , ExceptT' + , exceptT' + , runExceptT' + -- * Internal labels + , TAGGED + , EXCEPT + ) where + +import qualified Control.Monad.Except as T +import Control.Monad.Signatures (Catch) +import qualified Control.Monad.Trans.Lift.Catch as Lift +import Data.Coerce +import Data.Functor.Identity + +import Ether.TaggedTrans +import Ether.Internal + +class Monad m => MonadExcept tag e m | m tag -> e where + + -- | Is used within a monadic computation to begin exception processing. + throw :: e -> m a + + -- | A TaggedTrans function to handle previous exceptions and return to + -- normal execution. + catch :: m a -> (e -> m a) -> m a + +instance {-# OVERLAPPABLE #-} + ( Lift.LiftCatch t + , Monad (t m) + , MonadExcept tag e m + ) => MonadExcept tag e (t m) where + + throw = Lift.lift . throw @tag + {-# INLINE throw #-} + + catch = Lift.liftCatch (catch @tag) + {-# INLINE catch #-} + +-- | Encode type-level information for 'ExceptT'. +data EXCEPT + +-- | 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 + +-- | The exception monad transformer. +-- +-- The 'return' function returns a normal value, while '>>=' exits on +-- the first exception. +type ExceptT tag e = TaggedTrans (TAGGED EXCEPT tag) (T.ExceptT e) + +-- | Runs an 'Except' and returns either an exception or a normal value. +runExcept :: forall tag e a . Except tag e a -> Either e a +runExcept = coerce (T.runExcept @e @a) +{-# INLINE runExcept #-} + +-- | Runs an 'ExceptT' and returns either an exception or a normal value. +runExceptT :: forall tag e m a . ExceptT tag e m a -> m (Either e a) +runExceptT = coerce (T.runExceptT @e @m @a) +{-# INLINE runExceptT #-} + +-- | Constructor for computations in the exception monad transformer. +exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a +exceptT = coerce (T.ExceptT @e @m @a) +{-# INLINE exceptT #-} + +type instance HandleSuper EXCEPT e trans = () +type instance HandleConstraint EXCEPT e trans m = + T.MonadError e (trans m) + +instance Handle EXCEPT e (T.ExceptT e) where + handling r = r + {-# INLINE handling #-} + +instance + ( Handle EXCEPT e trans + , Monad m, Monad (trans m) + ) => MonadExcept tag e (TaggedTrans (TAGGED EXCEPT tag) trans m) + where + throw = + handling @EXCEPT @e @trans @m $ + coerce (T.throwError @e @(trans m) @a) :: + forall eff a . e -> TaggedTrans eff trans m a + {-# INLINE throw #-} + + catch = + handling @EXCEPT @e @trans @m $ + coerce (T.catchError @e @(trans m) @a) :: + forall eff a . Catch e (TaggedTrans eff trans m) a + {-# INLINE catch #-} + +type MonadExcept' e = MonadExcept e e + +throw' :: forall e m a . MonadExcept' e m => e -> m a +throw' = throw @e +{-# INLINE throw' #-} + +catch' :: forall e m a . MonadExcept' e m => m a -> (e -> m a) -> m a +catch' = catch @e +{-# INLINE catch' #-} + +type Except' e = Except e e + +runExcept' :: Except' e a -> Either e a +runExcept' = runExcept +{-# INLINE runExcept' #-} + +type ExceptT' e = ExceptT e e + +exceptT' :: m (Either e a) -> ExceptT' e m a +exceptT' = exceptT +{-# INLINE exceptT' #-} + +runExceptT' :: ExceptT' e m a -> m (Either e a) +runExceptT' = runExceptT +{-# INLINE runExceptT' #-} diff --git a/src/Ether/Internal.hs b/src/Ether/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Ether/Internal.hs @@ -0,0 +1,179 @@ +module Ether.Internal + ( Tagged(..) + , TagsK + , Tags + , HasLens(..) + , LensLike + , Lens + , Lens' + , ReifiedLens(..) + , ReifiedLens' + , view + , over + , HList(..) + , KindOf + , TAGGED + , HandleSuper + , HandleConstraint + , Handle(..) + ) where + +import Control.Applicative +import Control.Monad +import Data.Coerce +import Data.Functor.Identity +import Data.Kind +import Data.List as List +import Data.Tagged +import Data.Traversable +import GHC.Exts (Constraint) +import qualified Language.Haskell.TH as TH + +data TAGGED e t + +type K_Monad = Type -> Type + +type K_Trans = K_Monad -> K_Monad + +type family + HandleSuper + (eff :: keff) + (p :: kp) + (trans :: K_Trans) + :: Constraint + +type family + HandleConstraint + (eff :: keff) + (p :: kp) + (trans :: K_Trans) (m :: K_Monad) + :: Constraint + +class + HandleSuper eff p trans => + Handle eff p (trans :: K_Trans) | eff trans -> p + where + handling :: Monad m => (HandleConstraint eff p trans m => r) -> r + +type LensLike f s t a b = (a -> f b) -> s -> f t + +type Lens s t a b = forall f. Functor f => LensLike f s t a b + +type Lens' s a = Lens s s a a + +newtype ReifiedLens s t a b = Lens (Lens s t a b) + +type ReifiedLens' s a = ReifiedLens s s a a + +class HasLens tag outer inner | tag outer -> inner where + lensOf :: Lens' outer inner + +instance HasLens a a a where + lensOf = id + {-# INLINE lensOf #-} + +view :: LensLike (Const a) s t a b -> s -> a +view l = coerce (l Const) +{-# INLINE view #-} + +over :: LensLike Identity s t a b -> (a -> b) -> s -> t +over = coerce +{-# INLINE over #-} + +data HList xs where + HNil :: HList '[] + HCons :: x -> HList xs -> HList (x ': xs) + +type KindOf (a :: k) = k + +type family TagsK (p :: Type) :: [Type] +type family Tags (p :: Type) :: HList (TagsK p) + +return [] + +type instance TagsK () = '[] +type instance TagsK (Tagged t a) = '[KindOf t] +type instance TagsK (Tagged t0 a, Tagged t1 b) = '[KindOf t0, KindOf t1] + +return [] + +type instance Tags () = 'HNil +type instance Tags (Tagged t a) = 'HCons t 'HNil +type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil) + +do + let + tupCount = 62 + names = [1..] >>= flip replicateM ['a'..'z'] + varNames <- traverse TH.newName (take tupCount names) + fmap List.concat $ + for (List.drop 2 (List.inits varNames)) $ + \varNames' -> do + let n = List.length varNames' + tagsInstances <- for [() | n > 2] $ \() -> do + tag <- TH.newName "tag" + let + (cur:rest) = varNames' + tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n)) + ( TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur : + map TH.VarT rest ) + tupTy' = foldl TH.AppT (TH.ConT (TH.tupleTypeName (n-1))) + (map TH.VarT rest) + return $ + TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy] + ( TH.PromotedConsT `TH.AppT` (TH.ConT ''KindOf `TH.AppT` TH.VarT tag) `TH.AppT` + (TH.ConT ''TagsK `TH.AppT` tupTy') )) + return tagsInstances +do + let + tupCount = 62 + names = [1..] >>= flip replicateM ['a'..'z'] + varNames <- traverse TH.newName (take tupCount names) + fmap List.concat $ + for (List.drop 2 (List.inits varNames)) $ + \varNames' -> do + let n = List.length varNames' + tagsInstances <- for [() | n > 2] $ \() -> do + tag <- TH.newName "tag" + let + (cur:rest) = varNames' + tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n)) + ( TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur : + map TH.VarT rest ) + tupTy' = foldl TH.AppT (TH.ConT (TH.tupleTypeName (n-1))) + (map TH.VarT rest) + tagsInst = + TH.TySynInstD ''Tags (TH.TySynEqn [tupTy] + ( TH.PromotedT 'HCons `TH.AppT` TH.VarT tag `TH.AppT` + (TH.ConT ''Tags `TH.AppT` tupTy') )) + return tagsInst + hasLensInstances <- for [0..n-1] $ \k -> do + tag <- TH.newName "tag" + let + (prev, cur:next) = List.splitAt k varNames' + tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n)) + ( map TH.VarT prev ++ + [TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] ++ + map TH.VarT next ) + cur' <- TH.newName "x" + f <- TH.newName "f" + return $ + TH.InstanceD Nothing [] + (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur) + [ TH.FunD 'lensOf + [ TH.Clause + [TH.VarP f, TH.TupP + ( map TH.VarP prev ++ + [TH.ConP 'Tagged [TH.VarP cur]] ++ + map TH.VarP next )] + (TH.NormalB $ + TH.VarE 'fmap `TH.AppE` + (TH.LamE [TH.VarP cur'] + (TH.TupE + ( map TH.VarE prev ++ + [TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] ++ + map TH.VarE next ))) `TH.AppE` + (TH.VarE f `TH.AppE` TH.VarE cur) ) + [] ], + TH.PragmaD (TH.InlineP 'lensOf TH.Inline TH.FunLike TH.AllPhases) ] + return $ tagsInstances ++ hasLensInstances diff --git a/src/Ether/Reader.hs b/src/Ether/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Ether/Reader.hs @@ -0,0 +1,264 @@ +module Ether.Reader + ( + -- * MonadReader class + MonadReader + , ask + , local + , reader + , asks + -- * The Reader monad + , Reader + , runReader + -- * The ReaderT monad transformer + , ReaderT + , readerT + , runReaderT + -- * The Reader monad (flattened) + , Readers + , runReaders + -- * The ReaderT monad transformer (flattened) + , ReadersT + , runReadersT + -- * MonadReader class (implicit) + , MonadReader' + , local' + , ask' + , reader' + , asks' + -- * The Reader monad (implicit) + , Reader' + , runReader' + -- * The ReaderT monad transformer (implicit) + , ReaderT' + , readerT' + , runReaderT' + -- * Internal labels + , TAGGED + , READER + , READERS + ) where + +import qualified Control.Monad.Reader as T +import qualified Control.Monad.Trans.Lift.Local as Lift +import Control.Monad.Trans.Lift.Local (Local) +import Data.Coerce +import Data.Functor.Identity +import Data.Kind + +import Ether.TaggedTrans +import Ether.Internal + +class Monad m => MonadReader tag r m | m tag -> r where + + {-# MINIMAL (ask | reader), local #-} + + -- | Retrieves the monad environment. + ask :: m r + ask = reader @tag id + + -- | Executes a computation in a modified environment. + local + :: (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 + :: (r -> a) + -- ^ The selector function to apply to the environment. + -> m a + reader f = fmap f (ask @tag) + +instance {-# OVERLAPPABLE #-} + ( Lift.LiftLocal t + , Monad (t m) + , MonadReader tag r m + ) => MonadReader tag r (t m) + where + + ask = Lift.lift (ask @tag) + {-# INLINE ask #-} + + local = Lift.liftLocal (ask @tag) (local @tag) + {-# INLINE local #-} + + reader = Lift.lift . reader @tag + {-# INLINE reader #-} + +instance {-# OVERLAPPABLE #-} + ( Monad (trans m) + , MonadReader tag r (TaggedTrans effs trans m) + ) => MonadReader tag r (TaggedTrans (eff ': effs) trans (m :: Type -> Type)) + where + + ask = + (coerce :: + TaggedTrans effs trans m r -> + TaggedTrans (eff ': effs) trans m r) + (ask @tag) + {-# INLINE ask #-} + + local = + (coerce :: forall a . + Lift.Local r (TaggedTrans effs trans m) a -> + Lift.Local r (TaggedTrans (eff ': effs) trans m) a) + (local @tag) + {-# INLINE local #-} + + reader = + (coerce :: forall a . + ((r -> a) -> TaggedTrans effs trans m a) -> + ((r -> a) -> TaggedTrans (eff ': effs) trans m a)) + (reader @tag) + {-# INLINE reader #-} + +-- | Retrieves a function of the current environment. +asks + :: forall tag r m a + . MonadReader tag r m + => (r -> a) + -- ^ The selector function to apply to the environment. + -> m a +asks = reader @tag +{-# INLINE asks #-} + +-- | Encode type-level information for 'ReaderT'. +data READER + +-- | 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. +type ReaderT tag r = TaggedTrans (TAGGED READER tag) (T.ReaderT r) + +-- | Constructor for computations in the reader monad transformer. +readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a +readerT = coerce (T.ReaderT @r @m @a) +{-# INLINE readerT #-} + +-- | Runs a 'ReaderT' with the given environment +-- and returns the final value. +runReaderT :: forall tag r m a . ReaderT tag r m a -> r -> m a +runReaderT = coerce (T.runReaderT @r @_ @m @a) +{-# INLINE runReaderT #-} + +-- | Runs a 'ReaderT' with the given environment +-- and returns the final value. +runReader :: forall tag r a . Reader tag r a -> r -> a +runReader = coerce (T.runReader @r @a) +{-# INLINE runReader #-} + +type instance HandleSuper READER r trans = () +type instance HandleConstraint READER r trans m = + T.MonadReader r (trans m) + +instance Handle READER r (T.ReaderT r) where + handling r = r + {-# INLINE handling #-} + +instance + ( Handle READER r trans + , Monad m, Monad (trans m) + ) => MonadReader tag r (TaggedTrans (TAGGED READER tag) trans m) + where + + ask = + handling @READER @r @trans @m $ + coerce (T.ask @r @(trans m)) + {-# INLINE ask #-} + + local = + handling @READER @r @trans @m $ + coerce (T.local @r @(trans m) @a) :: + forall eff a . Local r (TaggedTrans eff trans m) a + {-# INLINE local #-} + + reader = + handling @READER @r @trans @m $ + coerce (T.reader @r @(trans m) @a) :: + forall eff a . (r -> a) -> TaggedTrans eff trans m a + {-# INLINE reader #-} + +instance + ( HasLens tag payload r + , Handle READER payload trans + , Monad m, Monad (trans m) + ) => MonadReader tag r (TaggedTrans (TAGGED READER tag ': effs) trans m) + where + + ask = + handling @READER @payload @trans @m $ + (coerce :: forall eff a . + trans m a -> + TaggedTrans eff trans m a) + (T.asks (view (lensOf @tag @payload @r))) + {-# INLINE ask #-} + + local f = + handling @READER @payload @trans @m $ + (coerce :: forall eff a . + (trans m a -> trans m a) -> + (TaggedTrans eff trans m a -> TaggedTrans eff trans m a)) + (T.local (over (lensOf @tag @payload @r) f)) + {-# INLINE local #-} + +type family READERS (ts :: HList xs) :: [Type] where + READERS 'HNil = '[] + READERS ('HCons t ts) = TAGGED READER t ': READERS ts + +type ReadersT r = TaggedTrans (READERS (Tags r)) (T.ReaderT r) + +type Readers r = ReadersT r Identity + +runReadersT :: forall p m a . ReadersT p m a -> p -> m a +runReadersT = coerce (T.runReaderT @p @_ @m @a) +{-# INLINE runReadersT #-} + +runReaders :: forall p a . Readers p a -> p -> a +runReaders = coerce (T.runReader @p @a) +{-# INLINE runReaders #-} + +type ReaderT' r = ReaderT r r + +readerT' :: (r -> m a) -> ReaderT' r m a +readerT' = readerT +{-# INLINE readerT' #-} + +runReaderT' :: ReaderT' r m a -> r -> m a +runReaderT' = runReaderT +{-# INLINE runReaderT' #-} + +type Reader' r = Reader r r + +runReader' :: Reader' r a -> r -> a +runReader' = runReader +{-# INLINE runReader' #-} + +type MonadReader' r = MonadReader r r + +local' :: forall r m a . MonadReader' r m => (r -> r) -> m a -> m a +local' = local @r +{-# INLINE local' #-} + +ask' :: forall r m . MonadReader' r m => m r +ask' = ask @r +{-# INLINE ask' #-} + +reader' :: forall r m a . MonadReader' r m => (r -> a) -> m a +reader' = reader @r +{-# INLINE reader' #-} + +asks' :: forall r m a . MonadReader' r m => (r -> a) -> m a +asks' = asks @r +{-# INLINE asks' #-} diff --git a/src/Ether/State.hs b/src/Ether/State.hs new file mode 100644 --- /dev/null +++ b/src/Ether/State.hs @@ -0,0 +1,471 @@ +module Ether.State + ( + -- * MonadState class + MonadState + , get + , put + , state + , modify + , gets + -- * The State monad + , State + , runState + , evalState + , execState + -- * The StateT monad transformer + , StateT + , stateT + , runStateT + , evalStateT + , execStateT + -- * The State monad (lazy) + , LazyState + , runLazyState + , evalLazyState + , execLazyState + -- * The StateT monad transformer (lazy) + , LazyStateT + , lazyStateT + , runLazyStateT + , evalLazyStateT + , execLazyStateT + -- * The State monad (flattened) + , States + , runStates + -- * The StateT monad transformer (flattened) + , StatesT + , runStatesT + -- * MonadState class (implicit) + , MonadState' + , get' + , put' + , state' + , modify' + , gets' + -- * The State monad (implicit) + , State' + , runState' + , evalState' + , execState' + -- * The StateT monad transformer (implicit) + , StateT' + , stateT' + , runStateT' + , evalStateT' + , execStateT' + -- * The State monad (lazy, implicit) + , LazyState' + , runLazyState' + , evalLazyState' + , execLazyState' + -- * The StateT monad transformer (lazy, implicit) + , LazyStateT' + , lazyStateT' + , runLazyStateT' + , evalLazyStateT' + , execLazyStateT' + -- * Zoom + , ZoomT + , zoom + -- * Internal labels + , TAGGED + , STATE + , STATES + , ZOOM + ) where + +import qualified Control.Monad.State.Class as T +import qualified Control.Monad.Trans as Lift +import Control.Monad.Trans.Identity +import qualified Control.Monad.Trans.State.Lazy as T.Lazy +import qualified Control.Monad.Trans.State.Strict as T.Strict +import Data.Coerce +import Data.Functor.Identity +import Data.Kind +import Data.Proxy +import Data.Reflection + +import Ether.Internal +import Ether.TaggedTrans + +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 :: m s + get = state @tag (\s -> (s, s)) + + -- | Replace the state inside the monad. + put :: s -> m () + put s = state @tag (\_ -> ((), s)) + + -- | Embed a simple state action into the monad. + state :: (s -> (a, s)) -> m a + state f = do + s <- get @tag + let ~(a, s') = f s + put @tag s' + return a + +instance {-# OVERLAPPABLE #-} + ( Lift.MonadTrans t + , Monad (t m) + , MonadState tag s m + ) => MonadState tag s (t m) + where + + get = Lift.lift (get @tag) + {-# INLINE get #-} + + put = Lift.lift . put @tag + {-# INLINE put #-} + + state = Lift.lift . state @tag + {-# INLINE state #-} + +instance {-# OVERLAPPABLE #-} + ( Monad (trans m) + , MonadState tag s (TaggedTrans effs trans m) + ) => MonadState tag s (TaggedTrans (eff ': effs) trans (m :: Type -> Type)) + where + + get = + (coerce :: + TaggedTrans effs trans m s -> + TaggedTrans (eff ': effs) trans m s) + (get @tag) + {-# INLINE get #-} + + put = + (coerce :: + (s -> TaggedTrans effs trans m ()) -> + (s -> TaggedTrans (eff ': effs) trans m ())) + (put @tag) + {-# INLINE put #-} + + state = + (coerce :: forall a . + ((s -> (a, s)) -> TaggedTrans effs trans m a) -> + ((s -> (a, s)) -> TaggedTrans (eff ': effs) trans m a)) + (state @tag) + {-# INLINE state #-} + +-- | Modifies the state inside a state monad. +modify :: forall tag s m . MonadState tag s m => (s -> s) -> m () +modify f = state @tag (\s -> ((), f s)) +{-# INLINABLE modify #-} + +-- | Gets specific component of the state, using a projection function supplied. +gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a +gets f = fmap f (get @tag) +{-# INLINABLE gets #-} + +-- | Encode type-level information for 'StateT'. +data STATE + +type instance HandleSuper STATE s trans = () +type instance HandleConstraint STATE s trans m = + T.MonadState s (trans m) + +instance Handle STATE s (T.Strict.StateT s) where + handling r = r + {-# INLINE handling #-} + +instance Handle STATE s (T.Lazy.StateT s) where + handling r = r + {-# INLINE handling #-} + +instance + ( Handle STATE s trans + , Monad m, Monad (trans m) + ) => MonadState tag s (TaggedTrans (TAGGED STATE tag) trans m) + where + + get = + handling @STATE @s @trans @m $ + coerce (T.get @s @(trans m)) + {-# INLINE get #-} + + put = + handling @STATE @s @trans @m $ + coerce (T.put @s @(trans m)) + {-# INLINE put #-} + + state = + handling @STATE @s @trans @m $ + coerce (T.state @s @(trans m) @a) :: + forall eff a . (s -> (a, s)) -> TaggedTrans eff trans m a + {-# INLINE state #-} + +instance + ( HasLens tag payload s + , Handle STATE payload trans + , Monad m, Monad (trans m) + ) => MonadState tag s (TaggedTrans (TAGGED STATE tag ': effs) trans m) + where + + get = + handling @STATE @payload @trans @m $ + (coerce :: forall eff a . + trans m a -> + TaggedTrans eff trans m a) + (T.gets (view (lensOf @tag @payload @s))) + {-# INLINE get #-} + + put s = + handling @STATE @payload @trans @m $ + (coerce :: forall eff a . + trans m a -> + TaggedTrans eff trans m a) + (T.modify (over (lensOf @tag @payload @s) (const s))) + {-# INLINE put #-} + + state f = + handling @STATE @payload @trans @m $ + (coerce :: forall eff a . + trans m a -> + TaggedTrans eff trans m a) + (T.state (lensOf @tag @payload @s f)) + {-# INLINE state #-} + +-- | 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. +type StateT tag s = TaggedTrans (TAGGED STATE tag) (T.Strict.StateT s) + +-- | Constructor for computations in the state monad transformer. +stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a +stateT = coerce (T.Strict.StateT @s @m @a) +{-# INLINE stateT #-} + +-- | Runs a 'StateT' with the given initial state +-- and returns both the final value and the final state. +runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s) +runStateT = coerce (T.Strict.runStateT @s @m @a) +{-# INLINE runStateT #-} + +-- | Runs a 'StateT' with the given initial state +-- and returns the final value, discarding the final state. +evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a +evalStateT = coerce (T.Strict.evalStateT @m @s @a) +{-# INLINE evalStateT #-} + +-- | Runs a 'StateT' with the given initial state +-- and returns the final state, discarding the final value. +execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s +execStateT = coerce (T.Strict.execStateT @m @s @a) +{-# INLINE execStateT #-} + +-- | Runs a 'State' with the given initial state +-- and returns both the final value and the final state. +runState :: forall tag s a . State tag s a -> s -> (a, s) +runState = coerce (T.Strict.runState @s @a) +{-# INLINE runState #-} + +-- | Runs a 'State' with the given initial state +-- and returns the final value, discarding the final state. +evalState :: forall tag s a . State tag s a -> s -> a +evalState = coerce (T.Strict.evalState @s @a) +{-# INLINE evalState #-} + +-- | Runs a 'State' with the given initial state +-- and returns the final state, discarding the final value. +execState :: forall tag s a . State tag s a -> s -> s +execState = coerce (T.Strict.execState @s @a) +{-# INLINE execState #-} + +-- | 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 LazyState tag r = LazyStateT 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. +type LazyStateT tag s = TaggedTrans (TAGGED STATE tag) (T.Lazy.StateT s) + +-- | Constructor for computations in the state monad transformer. +lazyStateT :: forall tag s m a . (s -> m (a, s)) -> LazyStateT tag s m a +lazyStateT = coerce (T.Lazy.StateT @s @m @a) +{-# INLINE lazyStateT #-} + +-- | Runs a 'StateT' with the given initial state +-- and returns both the final value and the final state. +runLazyStateT :: forall tag s m a . LazyStateT tag s m a -> s -> m (a, s) +runLazyStateT = coerce (T.Lazy.runStateT @s @m @a) +{-# INLINE runLazyStateT #-} + +-- | Runs a 'StateT' with the given initial state +-- and returns the final value, discarding the final state. +evalLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m a +evalLazyStateT = coerce (T.Lazy.evalStateT @m @s @a) +{-# INLINE evalLazyStateT #-} + +-- | Runs a 'StateT' with the given initial state +-- and returns the final state, discarding the final value. +execLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m s +execLazyStateT = coerce (T.Lazy.execStateT @m @s @a) +{-# INLINE execLazyStateT #-} + +-- | Runs a 'State' with the given initial state +-- and returns both the final value and the final state. +runLazyState :: forall tag s a . LazyState tag s a -> s -> (a, s) +runLazyState = coerce (T.Lazy.runState @s @a) +{-# INLINE runLazyState #-} + +-- | Runs a 'State' with the given initial state +-- and returns the final value, discarding the final state. +evalLazyState :: forall tag s a . LazyState tag s a -> s -> a +evalLazyState = coerce (T.Lazy.evalState @s @a) +{-# INLINE evalLazyState #-} + +-- | Runs a 'State' with the given initial state +-- and returns the final state, discarding the final value. +execLazyState :: forall tag s a . LazyState tag s a -> s -> s +execLazyState = coerce (T.Lazy.execState @s @a) +{-# INLINE execLazyState #-} + +type family STATES (ts :: HList xs) :: [Type] where + STATES 'HNil = '[] + STATES ('HCons t ts) = TAGGED STATE t ': STATES ts + +type StatesT s = TaggedTrans (STATES (Tags s)) (T.Strict.StateT s) + +type States s = StatesT s Identity + +runStatesT :: forall p m a . StatesT p m a -> p -> m (a, p) +runStatesT = coerce (T.Strict.runStateT @p @m @a) +{-# INLINE runStatesT #-} + +runStates :: forall p a . States p a -> p -> (a, p) +runStates = coerce (T.Strict.runState @p @a) +{-# INLINE runStates #-} + +type StateT' s = StateT s s + +stateT' :: (s -> m (a, s)) -> StateT' s m a +stateT' = stateT +{-# INLINE stateT' #-} + +runStateT' :: StateT' s m a -> s -> m (a, s) +runStateT' = runStateT +{-# INLINE runStateT' #-} + +runState' :: State' s a -> s -> (a, s) +runState' = runState +{-# INLINE runState' #-} + +evalStateT' :: Monad m => StateT' s m a -> s -> m a +evalStateT' = evalStateT +{-# INLINE evalStateT' #-} + +type State' s = State s s + +evalState' :: State' s a -> s -> a +evalState' = evalState +{-# INLINE evalState' #-} + +execStateT' :: Monad m => StateT' s m a -> s -> m s +execStateT' = execStateT +{-# INLINE execStateT' #-} + +execState' :: State' s a -> s -> s +execState' = execState +{-# INLINE execState' #-} + +type LazyStateT' s = LazyStateT s s + +lazyStateT' :: (s -> m (a, s)) -> LazyStateT' s m a +lazyStateT' = lazyStateT +{-# INLINE lazyStateT' #-} + +runLazyStateT' :: LazyStateT' s m a -> s -> m (a, s) +runLazyStateT' = runLazyStateT +{-# INLINE runLazyStateT' #-} + +runLazyState' :: LazyState' s a -> s -> (a, s) +runLazyState' = runLazyState +{-# INLINE runLazyState' #-} + +evalLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m a +evalLazyStateT' = evalLazyStateT +{-# INLINE evalLazyStateT' #-} + +type LazyState' s = LazyState s s + +evalLazyState' :: LazyState' s a -> s -> a +evalLazyState' = evalLazyState +{-# INLINE evalLazyState' #-} + +execLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m s +execLazyStateT' = execLazyStateT +{-# INLINE execLazyStateT' #-} + +execLazyState' :: LazyState' s a -> s -> s +execLazyState' = execLazyState +{-# INLINE execLazyState' #-} + +type MonadState' s = MonadState s s + +get' :: forall s m . MonadState' s m => m s +get' = get @s +{-# INLINE get' #-} + +gets' :: forall s m a . MonadState' s m => (s -> a) -> m a +gets' = gets @s +{-# INLINE gets' #-} + +put' :: forall s m . MonadState' s m => s -> m () +put' = put @s +{-# INLINE put' #-} + +state' :: forall s m a . MonadState' s m => (s -> (a, s)) -> m a +state' = state @s +{-# INLINE state' #-} + +modify' :: forall s m . MonadState' s m => (s -> s) -> m () +modify' = modify @s +{-# INLINE modify' #-} + +-- | Encode type-level information for 'zoom'. +data ZOOM t z + +type ZoomT t (z :: Type) = TaggedTrans (ZOOM t z) IdentityT + +-- | Zoom into a part of a state using a lens. +zoom + :: forall tag sOuter sInner m a + . Lens' sOuter sInner + -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => ZoomT tag z m a) + -> m a +zoom l m = reify (Lens l) (\(_ :: Proxy z) -> coerce (m @z)) +{-# INLINE zoom #-} + +instance + ( MonadState tag sOuter m + , Reifies z (ReifiedLens' sOuter sInner) + , trans ~ IdentityT + ) => MonadState tag sInner (TaggedTrans (ZOOM tag z) trans m) + where + state = + (coerce :: forall eff r a . + (r -> m a) -> + (r -> TaggedTrans eff trans m a)) + (state @tag . l) + where + Lens l = reflect (Proxy :: Proxy z) + {-# INLINE state #-} diff --git a/src/Ether/TagDispatch.hs b/src/Ether/TagDispatch.hs new file mode 100644 --- /dev/null +++ b/src/Ether/TagDispatch.hs @@ -0,0 +1,188 @@ +{- | + +Type-level machinery to manipulate constraints on the monad +transformer stack. + +Out of the box it provides the following dispatch strategies: + +* 'tagAttach' to use functions defined using untagged monad classes + as if they were defined using tagged ones. + +* 'tagReplace' to use functions defined using one tag + as if they were defined using another one. + +> import Ether +> import Control.Monad.State as Mtl +> +> data Foo +> data Bar +> +> f :: Mtl.MonadState Int m => m String +> f = fmap show Mtl.get +> +> g :: Ether.MonadState Foo Int m => m String +> g = tagAttach @Foo f +> +> h :: Ether.MonadState Bar Int m => m String +> h = tagReplace @Foo @Bar g + +-} + +module Ether.TagDispatch + ( + -- * The Tag Attach monad transformer + TagAttachT + , tagAttach + -- * The Tag Replace monad transformer + , TagReplaceT + , tagReplace + -- * Internal labels + , TAG_ATTACH + , TAG_REPLACE + ) where + +import qualified Control.Monad.Error.Class as Mtl +import qualified Control.Monad.Reader.Class as Mtl +import qualified Control.Monad.State.Class as Mtl +import qualified Control.Monad.Writer.Class as Mtl + +import Ether.Except +import Ether.Reader +import Ether.State +import Ether.Writer +import Ether.TaggedTrans + +import Control.Monad.Trans.Identity +import Data.Coerce + +-- | Encode type-level information for 'tagAttach'. +data TAG_ATTACH t + +type TagAttachT t = TaggedTrans (TAG_ATTACH t) IdentityT + +-- | Attach a tag to untagged transformers. +tagAttach :: forall tag m a . TagAttachT tag m a -> m a +tagAttach = coerce (runIdentityT @_ @m @a) +{-# INLINE tagAttach #-} + +instance {-# OVERLAPPING #-} + ( MonadReader tag r m, trans ~ IdentityT + ) => Mtl.MonadReader r (TaggedTrans (TAG_ATTACH tag) trans m) + where + + ask = ask @tag + {-# INLINE ask #-} + + local = local @tag + {-# INLINE local #-} + + reader = reader @tag + {-# INLINE reader #-} + +instance {-# OVERLAPPING #-} + ( MonadState tag s m, trans ~ IdentityT + ) => Mtl.MonadState s (TaggedTrans (TAG_ATTACH tag) trans m) + where + + get = get @tag + {-# INLINE get #-} + + put = put @tag + {-# INLINE put #-} + + state = state @tag + {-# INLINE state #-} + +instance {-# OVERLAPPING #-} + ( MonadExcept tag e m, trans ~ IdentityT + ) => Mtl.MonadError e (TaggedTrans (TAG_ATTACH tag) trans m) + where + + throwError = throw @tag + {-# INLINE throwError #-} + + catchError = catch @tag + {-# INLINE catchError #-} + +instance {-# OVERLAPPING #-} + ( MonadWriter tag w m, trans ~ IdentityT + ) => Mtl.MonadWriter w (TaggedTrans (TAG_ATTACH tag) trans m) + where + + writer = writer @tag + {-# INLINE writer #-} + + tell = tell @tag + {-# INLINE tell #-} + + listen = listen @tag + {-# INLINE listen #-} + + pass = pass @tag + {-# INLINE pass #-} + +-- | Encode type-level information for 'tagReplace'. +data TAG_REPLACE tOld tNew + +type TagReplaceT tOld tNew = TaggedTrans (TAG_REPLACE tOld tNew) IdentityT + +-- | Replace a tag with another tag. +tagReplace :: forall tOld tNew m a . TagReplaceT tOld tNew m a -> m a +tagReplace = coerce (runIdentityT @_ @m @a) +{-# INLINE tagReplace #-} + +instance + ( MonadReader tNew r m, trans ~ IdentityT + ) => MonadReader tOld r (TaggedTrans (TAG_REPLACE tOld tNew) trans m) + where + + ask = ask @tNew + {-# INLINE ask #-} + + local = local @tNew + {-# INLINE local #-} + + reader = reader @tNew + {-# INLINE reader #-} + +instance + ( MonadState tNew s m, trans ~ IdentityT + ) => MonadState tOld s (TaggedTrans (TAG_REPLACE tOld tNew) trans m) + where + + get = get @tNew + {-# INLINE get #-} + + put = put @tNew + {-# INLINE put #-} + + state = state @tNew + {-# INLINE state #-} + +instance + ( MonadExcept tNew e m, trans ~ IdentityT + ) => MonadExcept tOld e (TaggedTrans (TAG_REPLACE tOld tNew) trans m) + where + + throw = throw @tNew + {-# INLINE throw #-} + + catch = catch @tNew + {-# INLINE catch #-} + +instance + ( MonadWriter tNew w m, trans ~ IdentityT + ) => MonadWriter tOld w (TaggedTrans (TAG_REPLACE tOld tNew) trans m) + where + + writer = writer @tNew + {-# INLINE writer #-} + + tell = tell @tNew + {-# INLINE tell #-} + + listen = listen @tNew + {-# INLINE listen #-} + + pass = pass @tNew + {-# INLINE pass #-} diff --git a/src/Ether/TaggedTrans.hs b/src/Ether/TaggedTrans.hs new file mode 100644 --- /dev/null +++ b/src/Ether/TaggedTrans.hs @@ -0,0 +1,182 @@ +module Ether.TaggedTrans + ( TaggedTrans(..) + ) where + +import Control.Applicative +import Control.Monad (MonadPlus) +import Control.Monad.Fix (MonadFix) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Morph (MFunctor, MMonad) +import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) + +import qualified Control.Monad.Base as MB +import qualified Control.Monad.Trans.Control as MC + +import qualified Control.Monad.Trans.Lift.StT as Lift +import qualified Control.Monad.Trans.Lift.Local as Lift +import qualified Control.Monad.Trans.Lift.Catch as Lift +import qualified Control.Monad.Trans.Lift.Listen as Lift +import qualified Control.Monad.Trans.Lift.Pass as Lift +import qualified Control.Monad.Trans.Lift.CallCC as Lift + +import qualified Control.Monad.Cont.Class as Mtl +import qualified Control.Monad.Reader.Class as Mtl +import qualified Control.Monad.State.Class as Mtl +import qualified Control.Monad.Writer.Class as Mtl +import qualified Control.Monad.Error.Class as Mtl + +import GHC.Generics (Generic) +import Data.Coerce (coerce) + +newtype TaggedTrans tag trans m a = TaggedTrans (trans m a) + deriving + ( Generic + , Functor, Applicative, Alternative, Monad, MonadPlus + , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad + , MonadThrow, MonadCatch, MonadMask ) + +type Pack tag trans m a = trans m a -> TaggedTrans tag trans m a + +type Unpack tag trans m a = TaggedTrans tag trans m a -> trans m a + +instance + ( MB.MonadBase b (trans m) + ) => MB.MonadBase b (TaggedTrans tag trans m) + where + liftBase = + (coerce :: forall a . + (b a -> trans m a) -> + (b a -> TaggedTrans tag trans m a)) + MB.liftBase + {-# INLINE liftBase #-} + +instance + ( MC.MonadTransControl trans + ) => MC.MonadTransControl (TaggedTrans tag trans) + where + type StT (TaggedTrans tag trans) a = MC.StT trans a + + liftWith = MC.defaultLiftWith + (coerce :: Pack tag trans m a) + (coerce :: Unpack tag trans m a) + {-# INLINE liftWith #-} + + restoreT = MC.defaultRestoreT + (coerce :: Pack tag trans m a) + {-# INLINE restoreT #-} + +type LiftBaseWith b m a = (MC.RunInBase m b -> b a) -> m a + +newtype LiftBaseWith' b m a = LBW { unLBW :: LiftBaseWith b m a } + +coerceLiftBaseWith :: + LiftBaseWith b (trans m) a -> + LiftBaseWith b (TaggedTrans tag trans m) a +coerceLiftBaseWith lbw = + unLBW (coerce (LBW lbw)) +{-# INLINE coerceLiftBaseWith #-} + +instance + ( MC.MonadBaseControl b (trans m) + ) => MC.MonadBaseControl b (TaggedTrans tag trans m) + where + type StM (TaggedTrans tag trans m) a = MC.StM (trans m) a + + liftBaseWith = coerceLiftBaseWith MC.liftBaseWith + {-# INLINE liftBaseWith #-} + + restoreM = + (coerce :: forall a . + (MC.StM (trans m) a -> trans m a) -> + (MC.StM (trans m) a -> TaggedTrans tag trans m a)) + MC.restoreM + {-# INLINE restoreM #-} + +type instance Lift.StT (TaggedTrans tag trans) a = Lift.StT trans a + +instance Lift.LiftLocal trans => Lift.LiftLocal (TaggedTrans tag trans) where + liftLocal = + Lift.defaultLiftLocal + (coerce :: Pack tag trans m a) + (coerce :: Unpack tag trans m a) + +instance Lift.LiftCatch trans => Lift.LiftCatch (TaggedTrans tag trans) where + liftCatch = + Lift.defaultLiftCatch + (coerce :: Pack tag trans m a) + (coerce :: Unpack tag trans m a) + +instance Lift.LiftListen trans => Lift.LiftListen (TaggedTrans tag trans) where + liftListen = + Lift.defaultLiftListen + (coerce :: Pack tag trans m a) + (coerce :: Unpack tag trans m a) + +instance Lift.LiftPass trans => Lift.LiftPass (TaggedTrans tag trans) where + liftPass = + Lift.defaultLiftPass + (coerce :: Pack tag trans m a) + (coerce :: Unpack tag trans m a) + +instance Lift.LiftCallCC trans => Lift.LiftCallCC (TaggedTrans tag trans) where + liftCallCC = + Lift.defaultLiftCallCC + (coerce :: Pack tag trans m a) + (coerce :: Unpack tag trans m a) + liftCallCC' = + Lift.defaultLiftCallCC' + (coerce :: Pack tag trans m a) + (coerce :: Unpack tag trans m a) + + +-- Instances for mtl classes + +instance + ( Mtl.MonadCont m + , Lift.LiftCallCC trans + , Monad (trans m) + ) => Mtl.MonadCont (TaggedTrans tag trans m) + where + callCC = Lift.liftCallCC' Mtl.callCC + +instance + ( Mtl.MonadReader r m + , Lift.LiftLocal trans + , Monad (trans m) + ) => Mtl.MonadReader r (TaggedTrans tag trans m) + where + ask = lift Mtl.ask + local = Lift.liftLocal Mtl.ask Mtl.local + reader = lift . Mtl.reader + +instance + ( Mtl.MonadState s m + , MonadTrans trans + , Monad (trans m) + ) => Mtl.MonadState s (TaggedTrans tag trans m) + where + get = lift Mtl.get + put = lift . Mtl.put + state = lift . Mtl.state + +instance + ( Mtl.MonadWriter w m + , Lift.LiftListen trans + , Lift.LiftPass trans + , Monad (trans m) + ) => Mtl.MonadWriter w (TaggedTrans tag trans m) + where + writer = lift . Mtl.writer + tell = lift . Mtl.tell + listen = Lift.liftListen Mtl.listen + pass = Lift.liftPass Mtl.pass + +instance + ( Mtl.MonadError e m + , Lift.LiftCatch trans + , Monad (trans m) + ) => Mtl.MonadError e (TaggedTrans tag trans m) + where + throwError = lift . Mtl.throwError + catchError = Lift.liftCatch Mtl.catchError diff --git a/src/Ether/Writer.hs b/src/Ether/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Ether/Writer.hs @@ -0,0 +1,327 @@ +module Ether.Writer + ( + -- * MonadWriter class + MonadWriter + , writer + , tell + , listen + , pass + , listens + , censor + -- * The Writer monad + , Writer + , runWriter + , execWriter + -- * The WriterT monad transformer + , WriterT + , writerT + , runWriterT + , execWriterT + -- * The Writer monad (lazy) + , LazyWriter + , runLazyWriter + , execLazyWriter + -- * The WriterT monad transformer (lazy) + , LazyWriterT + , lazyWriterT + , runLazyWriterT + , execLazyWriterT + -- * MonadWriter class (implicit) + , MonadWriter' + , writer' + , tell' + , listen' + , pass' + , listens' + , censor' + -- * The Writer monad (implicit) + , Writer' + , runWriter' + , execWriter' + -- * The WriterT monad transformer (implicit) + , WriterT' + , writerT' + , runWriterT' + , execWriterT' + -- * The Writer monad (lazy, implicit) + , LazyWriter' + , runLazyWriter' + , execLazyWriter' + -- * The WriterT monad transformer (lazy, implicit) + , LazyWriterT' + , lazyWriterT' + , runLazyWriterT' + , execLazyWriterT' + -- * Internal labels + , TAGGED + , WRITER + ) where + +import Control.Monad.Signatures (Listen, Pass) +import qualified Control.Monad.Trans.Lift.Listen as Lift +import qualified Control.Monad.Trans.Lift.Pass as Lift +import qualified Control.Monad.Writer.Class as T +import qualified Control.Monad.Writer.CPS as T.CPS +import qualified Control.Monad.Writer.Lazy as T.Lazy +import Data.Coerce +import Data.Functor.Identity + +import Ether.Internal +import Ether.TaggedTrans + +class (Monoid w, Monad m) => MonadWriter tag w m | m tag -> w where + + {-# MINIMAL (writer | tell), listen, pass #-} + + -- | Embed a simple writer action. + writer :: (a, w) -> m a + writer ~(a, w) = a <$ tell @tag w + + -- | Append a value to the accumulator within the monad. + tell :: w -> m () + tell w = writer @tag ((),w) + + -- | Execute an action and add its accumulator + -- to the value of the computation. + listen :: 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 :: m (a, w -> w) -> m a + +instance {-# OVERLAPPABLE #-} + ( Lift.LiftListen t + , Lift.LiftPass t + , Monad (t m) + , MonadWriter tag w m + , Monoid w + ) => MonadWriter tag w (t m) where + + writer = Lift.lift . writer @tag + {-# INLINE writer #-} + + tell = Lift.lift . tell @tag + {-# INLINE tell #-} + + listen = Lift.liftListen (listen @tag) + {-# INLINE listen #-} + + pass = Lift.liftPass (pass @tag) + {-# INLINE pass #-} + +-- | Execute an action and add the result of applying the given function to +-- its accumulator to the value of the computation. +listens :: forall tag w m a b . MonadWriter tag w m => (w -> b) -> m a -> m (a, b) +listens f m = do + ~(a, w) <- listen @tag m + return (a, f w) + +-- | Execute an action and apply a function to its accumulator. +censor :: forall tag w m a . MonadWriter tag w m => (w -> w) -> m a -> m a +censor f m = pass @tag $ do + a <- m + return (a, f) + +-- | Encode type-level information for 'WriterT'. +data WRITER + +type instance HandleSuper WRITER w trans = Monoid w +type instance HandleConstraint WRITER w trans m = + T.MonadWriter w (trans m) + +instance Monoid w => Handle WRITER w (T.CPS.WriterT w) where + handling r = r + {-# INLINE handling #-} + +instance Monoid w => Handle WRITER w (T.Lazy.WriterT w) where + handling r = r + {-# INLINE handling #-} + +instance + ( Handle WRITER w trans + , Monad m, Monad (trans m) + ) => MonadWriter tag w (TaggedTrans (TAGGED WRITER tag) trans m) + where + + writer = + handling @WRITER @w @trans @m $ + coerce (T.writer @w @(trans m) @a) :: + forall eff a . (a, w) -> TaggedTrans eff trans m a + {-# INLINE writer #-} + + tell = + handling @WRITER @w @trans @m $ + coerce (T.tell @w @(trans m)) + {-# INLINE tell #-} + + listen = + handling @WRITER @w @trans @m $ + coerce (T.listen @w @(trans m) @a) :: + forall eff a . Listen w (TaggedTrans eff trans m) a + {-# INLINE listen #-} + + pass = + handling @WRITER @w @trans @m $ + coerce (T.pass @w @(trans m) @a) :: + forall eff a . Pass w (TaggedTrans eff trans m) a + {-# INLINE pass #-} + +-- | 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'. +type WriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.CPS.WriterT w) + +-- | Constructor for computations in the writer monad transformer. +writerT :: forall tag w m a . (Functor m, Monoid w) => m (a, w) -> WriterT tag w m a +writerT = coerce (T.CPS.writerT @m @w @a) +{-# INLINE writerT #-} + +-- | Runs a 'WriterT' and returns both the normal value +-- and the final accumulator. +runWriterT :: forall tag w m a . Monoid w => WriterT tag w m a -> m (a, w) +runWriterT = coerce (T.CPS.runWriterT @w @m @a) +{-# INLINE runWriterT #-} + +-- | Runs a 'Writer' and returns both the normal value +-- and the final accumulator. +runWriter :: forall tag w a . Monoid w => Writer tag w a -> (a, w) +runWriter = coerce (T.CPS.runWriter @w @a) +{-# INLINE runWriter #-} + +-- | Runs a 'WriterT' and returns the final accumulator, +-- discarding the normal value. +execWriterT :: forall tag w m a . (Monad m, Monoid w) => WriterT tag w m a -> m w +execWriterT = coerce (T.CPS.execWriterT @m @w @a) +{-# INLINE execWriterT #-} + +-- | Runs a 'Writer' and returns the final accumulator, +-- discarding the normal value. +execWriter :: forall tag w a . Monoid w => Writer tag w a -> w +execWriter = coerce (T.CPS.execWriter @w @a) +{-# INLINE execWriter #-} + +-- | 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 LazyWriter tag w = LazyWriterT tag w Identity + +-- | The writer monad transformer. +-- +-- The 'return' function produces the output 'mempty', while '>>=' combines +-- the outputs of the subcomputations using 'mappend'. +type LazyWriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.Lazy.WriterT w) + +-- | Constructor for computations in the writer monad transformer. +lazyWriterT :: forall tag w m a . m (a, w) -> LazyWriterT tag w m a +lazyWriterT = coerce (T.Lazy.WriterT @w @m @a) +{-# INLINE lazyWriterT #-} + +-- | Runs a 'WriterT' and returns both the normal value +-- and the final accumulator. +runLazyWriterT :: forall tag w m a . LazyWriterT tag w m a -> m (a, w) +runLazyWriterT = coerce (T.Lazy.runWriterT @w @m @a) +{-# INLINE runLazyWriterT #-} + +-- | Runs a 'Writer' and returns both the normal value +-- and the final accumulator. +runLazyWriter :: forall tag w a . LazyWriter tag w a -> (a, w) +runLazyWriter = coerce (T.Lazy.runWriter @w @a) +{-# INLINE runLazyWriter #-} + +-- | Runs a 'WriterT' and returns the final accumulator, +-- discarding the normal value. +execLazyWriterT :: forall tag w m a . Monad m => LazyWriterT tag w m a -> m w +execLazyWriterT = coerce (T.Lazy.execWriterT @m @w @a) +{-# INLINE execLazyWriterT #-} + +-- | Runs a 'Writer' and returns the final accumulator, +-- discarding the normal value. +execLazyWriter :: forall tag w a . LazyWriter tag w a -> w +execLazyWriter = coerce (T.Lazy.execWriter @w @a) +{-# INLINE execLazyWriter #-} + +type Writer' w = Writer w w + +runWriter' :: Monoid w => Writer' w a -> (a, w) +runWriter' = runWriter +{-# INLINE runWriter' #-} + +execWriter' :: Monoid w => Writer' w a -> w +execWriter' = execWriter +{-# INLINE execWriter' #-} + +type WriterT' w = WriterT w w + +writerT' :: (Functor m, Monoid w) => m (a, w) -> WriterT' w m a +writerT' = writerT +{-# INLINE writerT' #-} + +runWriterT' :: Monoid w => WriterT' w m a -> m (a, w) +runWriterT' = runWriterT +{-# INLINE runWriterT' #-} + +execWriterT' :: (Monad m, Monoid w) => WriterT' w m a -> m w +execWriterT' = execWriterT +{-# INLINE execWriterT' #-} + +type LazyWriter' w = LazyWriter w w + +runLazyWriter' :: LazyWriter' w a -> (a, w) +runLazyWriter' = runLazyWriter +{-# INLINE runLazyWriter' #-} + +execLazyWriter' :: LazyWriter' w a -> w +execLazyWriter' = execLazyWriter +{-# INLINE execLazyWriter' #-} + +type LazyWriterT' w = LazyWriterT w w + +lazyWriterT' :: m (a, w) -> LazyWriterT' w m a +lazyWriterT' = lazyWriterT +{-# INLINE lazyWriterT' #-} + +runLazyWriterT' :: LazyWriterT' w m a -> m (a, w) +runLazyWriterT' = runLazyWriterT +{-# INLINE runLazyWriterT' #-} + +execLazyWriterT' :: Monad m => LazyWriterT' w m a -> m w +execLazyWriterT' = execLazyWriterT +{-# INLINE execLazyWriterT' #-} + +type MonadWriter' w = MonadWriter w w + +writer' :: forall w m a . MonadWriter' w m => (a, w) -> m a +writer' = writer @w +{-# INLINE writer' #-} + +tell' :: forall w m . MonadWriter' w m => w -> m () +tell' = tell @w +{-# INLINE tell' #-} + +listen' :: forall w m a . MonadWriter' w m => m a -> m (a, w) +listen' = listen @w +{-# INLINE listen' #-} + +pass' :: forall w m a . MonadWriter' w m => m (a, w -> w) -> m a +pass' = pass @w +{-# INLINE pass' #-} + +listens' :: forall w m a b . MonadWriter' w m => (w -> b) -> m a -> m (a, b) +listens' = listens @w +{-# INLINE listens' #-} + +censor' :: forall w m a . MonadWriter' w m => (w -> w) -> m a -> m a +censor' = censor @w +{-# INLINE censor' #-} diff --git a/test/Regression.hs b/test/Regression.hs --- a/test/Regression.hs +++ b/test/Regression.hs @@ -12,6 +12,8 @@ import Regression.T8 import Regression.T9 import Regression.T10 +import Regression.T11 +import Regression.T12 main :: IO () main = defaultMain suite @@ -28,4 +30,6 @@ , test8 , test9 , test10 + , test11 + , test12 ] diff --git a/test/Regression/T1.hs b/test/Regression/T1.hs --- a/test/Regression/T1.hs +++ b/test/Regression/T1.hs @@ -1,30 +1,34 @@ module Regression.T1 (test1) where -import Control.Monad.Ether -import Control.Ether.Abbr +import Ether +import Data.List (group) import Test.Tasty import Test.Tasty.QuickCheck -ethereal "Tag1" "tag1" -ethereal "Tag2" "tag2" +data Tag1 +data Tag2 testEther - :: Ether '[Tag1 --> String, Tag2 --> String] m + :: (MonadReader Tag1 String m, MonadReader Tag2 String m) => m ((String, String), (String, String)) testEther = do - s1 <- ask tag1 - s2 <- ask tag2 + s1 <- ask @Tag1 + s2 <- ask @Tag2 let s1s2 = (s1, s2) - s1s2' <- local tag2 (map succ) $ do - s1' <- ask tag1 - s2' <- ask tag2 + s1s2' <- local @Tag2 (map succ) $ do + s1' <- ask @Tag1 + s2' <- ask @Tag2 return (s1', s2') return (s1s2, s1s2') -runner1 s1 s2 = flip (runReader tag1) s1 . flip (runReaderT tag2) s2 -runner2 s1 s2 = flip (runReader tag2) s2 . flip (runReaderT tag1) s1 +runner1 s1 s2 = flip (runReader @Tag1) s1 . flip (runReaderT @Tag2) s2 +runner2 s1 s2 = flip (runReader @Tag2) s2 . flip (runReaderT @Tag1) s1 +runner3 s1 s2 = flip runReaders (Tagged @Tag1 s1, Tagged @Tag2 s2) +same :: Eq a => [a] -> Bool +same = (<=1) . length . group + test1 :: TestTree test1 = testGroup "T1: Reader local environment" [ testProperty "runner₁ works" @@ -33,7 +37,13 @@ , testProperty "runner₂ works" $ \s1 s2 -> property $ runner2 s1 s2 testEther == ((s1, s2), (s1, map succ s2)) - , testProperty "runner₁ == runner₂" + , testProperty "runner₃ works" $ \s1 s2 -> property - $ runner1 s1 s2 testEther == runner2 s1 s2 testEther + $ runner3 s1 s2 testEther == ((s1, s2), (s1, map succ s2)) + , testProperty "runner₁ == runner₂ == runner₃" + $ \s1 s2 -> property + $ same + [ runner1 s1 s2 testEther + , runner2 s1 s2 testEther + , runner3 s1 s2 testEther ] ] diff --git a/test/Regression/T10.hs b/test/Regression/T10.hs --- a/test/Regression/T10.hs +++ b/test/Regression/T10.hs @@ -2,22 +2,23 @@ import Control.Applicative import Data.Functor.Identity -import qualified Control.Monad.Ether.Implicit as I +import Ether + import Test.Tasty import Test.Tasty.QuickCheck -testEther :: Integer -> I.StateT Integer Maybe [Integer] +testEther :: Integer -> StateT' Integer Maybe [Integer] testEther m = range where range = liftA2 (:) yield (range <|> pure []) - yield = I.stateT $ \n -> do - I.guard (n <= m) + yield = stateT' $ \n -> do + guard (n <= m) Just (n, n + 1) -testEther' :: Integer -> I.State Integer [Integer] +testEther' :: Integer -> State' Integer [Integer] testEther' m = - I.stateT $ Identity . maybe ([], m + 1) id . I.runStateT (testEther m) + stateT' $ Identity . maybe ([], m + 1) id . runStateT' (testEther m) next1 :: Integer -> Integer -> Maybe Integer next1 m n @@ -32,11 +33,11 @@ test10 :: TestTree test10 = testGroup "T10: Alternative instance" [ testProperty "execStateT works" - $ \m n -> I.execStateT (testEther m) n == next1 m n + $ \m n -> execStateT' (testEther m) n == next1 m n , testProperty "evalStateT works" - $ \m n -> I.evalStateT (testEther m) n == range1 m n + $ \m n -> evalStateT' (testEther m) n == range1 m n , testProperty "execState works" - $ \m n -> I.execState (testEther' m) n == m + 1 + $ \m n -> execState' (testEther' m) n == m + 1 , testProperty "evalState works" - $ \m n -> I.evalState (testEther' m) n == [n..m] + $ \m n -> evalState' (testEther' m) n == [n..m] ] diff --git a/test/Regression/T11.hs b/test/Regression/T11.hs new file mode 100644 --- /dev/null +++ b/test/Regression/T11.hs @@ -0,0 +1,50 @@ +module Regression.T11 (test11) where + +import Ether + +import Data.Bool +import qualified Control.Monad.State as T +import qualified Control.Monad.Reader as T + +import Test.Tasty +import Test.Tasty.QuickCheck + +data STag + +testEther + :: ( MonadState STag [Integer] m + , T.MonadState Bool m + , T.MonadReader Integer m ) + => m () +testEther = do + T.modify not + f <- bool negate id <$> T.get + n <- T.ask + T.local succ testEther + modify @STag (f n:) + +model :: Integer -> [Integer] +model n = zipWith ($) (cycle [id, negate]) [n..] + +runner1 n + = flip (T.runReader) n + . flip (execLazyStateT @STag) [] + . flip T.evalStateT False + +runner2 n + = flip T.evalState False + . flip (execLazyStateT @STag) [] + . flip T.runReaderT n + +test11 :: TestTree +test11 = testGroup "T11: Lazy sequence" + [ testProperty "runner₁ works" + $ \l n -> property + $ take l (runner1 n testEther) == take l (model n) + , testProperty "runner₂ works" + $ \l n -> property + $ take l (runner2 n testEther) == take l (model n) + , testProperty "runner₁ == runner₂" + $ \l n -> property + $ take l (runner1 n testEther) == take l (runner2 n testEther) + ] diff --git a/test/Regression/T12.hs b/test/Regression/T12.hs new file mode 100644 --- /dev/null +++ b/test/Regression/T12.hs @@ -0,0 +1,30 @@ +module Regression.T12 (test12) where + +import Ether +import Control.Lens + +import Test.Tasty +import Test.Tasty.QuickCheck + +data Foo + +succState :: Enum a => MonadState Foo a m => m () +succState = modify @Foo succ + +testEther :: (Enum a, MonadState Foo (a, a) m) => m (a, a) +testEther = do + Ether.zoom @Foo _1 succState + Ether.zoom @Foo _2 $ modify @Foo pred + get @Foo + +model :: Enum a => (a, a) -> (a, a) +model (a1, a2) = (succ a1, pred a2) + +runner = evalState @Foo + +test12 :: TestTree +test12 = testGroup "T12: State zooming" + [ testProperty "runner works" + $ \(a1 :: Integer, a2 :: Integer) -> property + $ runner testEther (a1, a2) == model (a1, a2) + ] diff --git a/test/Regression/T2.hs b/test/Regression/T2.hs --- a/test/Regression/T2.hs +++ b/test/Regression/T2.hs @@ -1,29 +1,27 @@ module Regression.T2 (test2) where -import Control.Ether.Abbr -import qualified Control.Monad.Ether.Implicit as I -import qualified Control.Ether.Implicit.Abbr as I +import Ether import Test.Tasty import Test.Tasty.QuickCheck -testEther :: Ether '[I.R Integer, I.R Bool] m => m String -testEther = I.local (succ :: Integer -> Integer) $ do - n :: Integer <- I.ask - b <- I.local not I.ask +testEther :: (MonadReader' Integer m, MonadReader' Bool m) => m String +testEther = local' (succ :: Integer -> Integer) $ do + n :: Integer <- asks' (*2) + b <- local' not ask' return (if b then "" else show n) -runner1 (n :: Integer) = flip I.runReader n . flip I.runReaderT True -runner2 (n :: Integer) = flip I.runReader True . flip I.runReaderT n +runner1 (n :: Integer) = flip runReader' n . flip runReaderT' True +runner2 (n :: Integer) = flip runReader' True . flip runReaderT' n test2 :: TestTree test2 = testGroup "T2: Implicit tags" [ testProperty "runner₁ works" $ \n -> property - $ runner1 n testEther == show (succ n) + $ runner1 n testEther == show (succ n * 2) , testProperty "runner₂ works" $ \n -> property - $ runner2 n testEther == show (succ n) + $ runner2 n testEther == show (succ n * 2) , testProperty "runner₁ == runner₂" $ \n -> property $ runner1 n testEther == runner2 n testEther diff --git a/test/Regression/T3.hs b/test/Regression/T3.hs --- a/test/Regression/T3.hs +++ b/test/Regression/T3.hs @@ -1,7 +1,6 @@ module Regression.T3 (test3) where -import Control.Ether.Abbr -import Control.Monad.Ether +import Ether import qualified Control.Monad.Reader as T import qualified Control.Monad.State as T @@ -9,8 +8,8 @@ import Test.Tasty import Test.Tasty.QuickCheck -ethereal "RTag" "rTag" -ethereal "STag" "sTag" +data RTag +data STag testMTL :: (T.MonadReader Int m, T.MonadState Int m) => m Int testMTL = do @@ -20,23 +19,23 @@ return (a * b) testEther - :: Ether '[STag --> Int, STag <-> Int, RTag --> Int] m + :: (MonadReader STag Int m, MonadState STag Int m, MonadReader RTag Int m) => m (Int, Int, Int) -testEther = local rTag (*2) $ do - a_mul_b <- tagAttach sTag testMTL - a_add_b <- get sTag - modify sTag negate - c <- ask rTag +testEther = local @RTag (*2) $ do + a_mul_b <- tagAttach @STag testMTL + a_add_b <- get @STag + modify @STag negate + c <- ask @RTag return (a_mul_b, a_add_b, c) runner1 s r - = flip (runReader rTag) (negate r) - . flip (runReaderT sTag) r - . flip (runStateT sTag) s + = flip (runReader @RTag) (negate r) + . flip (runReaderT @STag) r + . flip (runStateT @STag) s runner2 s r - = flip (runReader rTag) (negate r) - . flip (runStateT sTag) s - . flip (runReaderT sTag) r + = flip (runReader @RTag) (negate r) + . flip (runStateT @STag) s + . flip (runReaderT @STag) r test3 :: TestTree test3 = testGroup "T3: Tag attachement" diff --git a/test/Regression/T4.hs b/test/Regression/T4.hs --- a/test/Regression/T4.hs +++ b/test/Regression/T4.hs @@ -1,19 +1,18 @@ module Regression.T4 (test4) where -import Control.Ether.Abbr -import Control.Monad.Ether +import Ether import Test.Tasty import Test.Tasty.QuickCheck -ethereal "RTag" "rTag" +data RTag -testEther :: Ether '[RTag --> Int] m => m Int -testEther = ask rTag +testEther :: MonadReader RTag Int m => m Int +testEther = ask @RTag runner r - = flip (runReader rTag) (r' :: Int) - . flip (runReaderT rTag) (r :: Int) + = flip (runReader @RTag) (r' :: Int) + . flip (runReaderT @RTag) (r :: Int) where r' = negate r diff --git a/test/Regression/T5.hs b/test/Regression/T5.hs --- a/test/Regression/T5.hs +++ b/test/Regression/T5.hs @@ -1,9 +1,6 @@ module Regression.T5 (test5) where -import Control.Ether.Abbr - -import qualified Control.Monad.Ether.Implicit as I -import qualified Control.Ether.Implicit.Abbr as I +import Ether import Test.Tasty import Test.Tasty.QuickCheck @@ -16,22 +13,22 @@ testEther :: (Num a, Ord a) - => Ether '[I.R a, I.S Counter] m + => (MonadReader' a m, MonadState' Counter m) => m a testEther = do - a <- I.ask + a <- ask' if a <= 0 then do - I.put (0 :: Counter) + put' (0 :: Counter) return 1 else do - I.modify incCounter -- overriden in the base case - b <- I.runReaderT testEther (a - 1) - I.modify incCounter + modify' incCounter -- overriden in the base case + b <- runReaderT' testEther (a - 1) + modify' incCounter return (a * b) runner :: (Num a, Ord a) => a -> (a, Counter) -runner a = I.runState (I.runReaderT testEther a) (0 :: Counter) +runner a = runState' (runReaderT' testEther a) (0 :: Counter) factorial :: (Num a, Enum a) => a -> a factorial a = product [1..a] diff --git a/test/Regression/T6.hs b/test/Regression/T6.hs --- a/test/Regression/T6.hs +++ b/test/Regression/T6.hs @@ -1,10 +1,7 @@ module Regression.T6 (test6) where -import Control.Monad -import Control.Ether.Abbr - -import qualified Control.Monad.Ether.Implicit as I -import qualified Control.Ether.Implicit.Abbr as I +import Data.Function +import Ether import Test.Tasty import Test.Tasty.QuickCheck @@ -17,32 +14,33 @@ testEther :: (Floating a, Ord a) - => Ether '[I.E DivideByZero, I.E (NegativeLog a)] m + => (MonadExcept' DivideByZero m, MonadExcept' (NegativeLog a) m) => a -> a -> m a testEther a b = do - when (b == 0) (I.throw DivideByZero) + when (b == 0) (throw' DivideByZero) let d = a / b - when (d < 0) (I.throw (NegativeLog d)) + when (d < 0) (throw' (NegativeLog d)) return (log d) --- Copied verbatim from "Data.Function" to support @base < 4.8@. -(&) :: a -> (a -> b) -> b -x & f = f x - handleNegativeLog (NegativeLog (x :: Double)) = "nl: " ++ show x handleDivideByZero DivideByZero = "dz" +handleT' :: Functor m => (e -> a) -> ExceptT' e m a -> m a +handleT' h m = fmap (either h id) (runExceptT' m) + runner1 :: Double -> Double -> String runner1 a b = do (show `fmap` testEther a b) - & I.handleT handleNegativeLog - & I.handle handleDivideByZero + & handleT' handleNegativeLog + & handleT' handleDivideByZero + & runIdentity runner2 :: Double -> Double -> String runner2 a b = do (show `fmap` testEther a b) - & I.handleT handleDivideByZero - & I.handle handleNegativeLog + & handleT' handleDivideByZero + & handleT' handleNegativeLog + & runIdentity logDiv :: Double -> Double -> String logDiv a b diff --git a/test/Regression/T7.hs b/test/Regression/T7.hs --- a/test/Regression/T7.hs +++ b/test/Regression/T7.hs @@ -3,13 +3,13 @@ import Data.Monoid import Control.Monad -import Control.Monad.Ether +import Ether import qualified Control.Monad.Writer as T import Test.Tasty import Test.Tasty.QuickCheck -ethereal "WTag" "wTag" +data WTag testEther :: Num a @@ -18,17 +18,18 @@ => [a] -> m () testEther xs = do forM_ xs $ \x -> do - T.tell (Sum x) - tell wTag (Sum 1) + u1 <- T.tell (Sum x) + u2 <- tell @WTag (Sum 1) + when (u1 /= u2) $ error "Impossible" runner1 :: Num a => [a] -> (a, a) runner1 xs = - let (s, c) = T.runWriter . execWriterT wTag $ testEther xs + let (s, c) = T.runWriter . execWriterT @WTag $ testEther xs in (getSum s, getSum c) runner2 :: Num a => [a] -> (a, a) runner2 xs = - let (c, s) = runWriter wTag . T.execWriterT $ testEther xs + let (c, s) = runWriter @WTag . T.execWriterT $ testEther xs in (getSum s, getSum c) triangular :: Integral a => a -> a diff --git a/test/Regression/T8.hs b/test/Regression/T8.hs --- a/test/Regression/T8.hs +++ b/test/Regression/T8.hs @@ -1,15 +1,14 @@ module Regression.T8 (test8) where -import Control.Ether.Abbr -import Control.Monad.Ether +import Ether import qualified Control.Monad.State as T import Test.Tasty import Test.Tasty.QuickCheck -ethereal "Foo" "foo" -ethereal "Bar" "bar" +data Foo +data Bar testMTL1 :: T.MonadState Int m => m () testMTL1 = T.modify negate @@ -18,25 +17,25 @@ testMTL2 = T.modify not testEther - :: Ether '[Foo <-> Int, Bar <-> Bool] m + :: (MonadState Foo Int m, MonadState Bar Bool m) => m String testEther = do - tagAttach foo testMTL1 - tagAttach bar testMTL2 - a <- gets foo show - b <- gets bar show + tagAttach @Foo testMTL1 + tagAttach @Bar testMTL2 + a <- gets @Foo show + b <- gets @Bar show return (a ++ b) model :: Int -> Bool -> String model a b = show (negate a) ++ show (not b) runner1 a b - = flip (evalState foo) a - . flip (evalStateT bar) b + = flip (evalState @Foo) a + . flip (evalStateT @Bar) b runner2 a b - = flip (evalState bar) b - . flip (evalStateT foo) a + = flip (evalState @Bar) b + . flip (evalStateT @Foo) a test8 :: TestTree test8 = testGroup "T8: Multiple tag attachements" diff --git a/test/Regression/T9.hs b/test/Regression/T9.hs --- a/test/Regression/T9.hs +++ b/test/Regression/T9.hs @@ -1,25 +1,23 @@ module Regression.T9 (test9) where -import Control.Ether.Abbr -import Control.Monad.Ether +import Ether import Test.Tasty import Test.Tasty.QuickCheck -ethereal "Foo" "foo" -ethereal "Bar" "bar" - +data Foo +data Bar -testEther1 :: Ether '[Foo <-> Int] m => m String +testEther1 :: MonadState Foo Int m => m String testEther1 = do - modify foo negate - gets foo show + modify @Foo negate + gets @Foo show -testEther2 :: Ether '[Bar <-> Int] m => m String -testEther2 = tagReplace foo bar testEther1 +testEther2 :: MonadState Bar Int m => m String +testEther2 = tagReplace @Foo @Bar testEther1 testEther - :: Ether '[Foo <-> Int, Bar <-> Int] m + :: (MonadState Foo Int m, MonadState Bar Int m) => m String testEther = do a <- testEther1 @@ -30,12 +28,12 @@ model a b = show (negate a) ++ show (negate b) runner1 a b - = flip (evalState foo) a - . flip (evalStateT bar) b + = flip (evalState @Foo) a + . flip (evalStateT @Bar) b runner2 a b - = flip (evalState bar) b - . flip (evalStateT foo) a + = flip (evalState @Bar) b + . flip (evalStateT @Foo) a test9 :: TestTree test9 = testGroup "T9: Tag replacement"