monad-effect (empty) → 0.1.0.0
raw patch · 30 files changed
+5611/−0 lines, 30 filesdep +asyncdep +basedep +containers
Dependencies added: async, base, containers, criterion, data-default, data-effects, deepseq, eff, effectful, exceptions, freer-simple, fused-effects, haskell-src-meta, heftia-effects, logict, monad-control, monad-effect, mtl, parsec, polysemy, resourcet, stm, tasty-bench, template-haskell, text, transformers-base, unix
Files
- CHANGELOG.md +5/−0
- LICENSE +29/−0
- README.md +550/−0
- bench/BenchCatch.hs +144/−0
- bench/BenchCoroutine.hs +81/−0
- bench/BenchCountdown.hs +225/−0
- bench/BenchFileSizes.hs +653/−0
- bench/BenchLocal.hs +159/−0
- bench/BenchPyth.hs +139/−0
- bench/Main.hs +229/−0
- monad-effect.cabal +245/−0
- src/Control/Monad/Effect.hs +719/−0
- src/Control/Monad/RS/Class.hs +39/−0
- src/Control/System.hs +206/−0
- src/Control/System/EventLoop.hs +24/−0
- src/Data/Result.hs +98/−0
- src/Data/TypeList.hs +164/−0
- src/Data/TypeList/ConsFData.hs +57/−0
- src/Data/TypeList/ConsFData/Pattern.hs +17/−0
- src/Data/TypeList/FData.hs +207/−0
- src/Data/TypeList/FData/TH.hs +305/−0
- src/Data/TypeList/FList.hs +73/−0
- src/Data/TypeList/Families.hs +150/−0
- src/Data/TypeList/UList.hs +9/−0
- src/Module/RS.hs +158/−0
- src/Module/RS/QQ.hs +622/−0
- src/Module/Resource.hs +33/−0
- test/Examples.hs +61/−0
- test/Main.hs +194/−0
- test/TH.hs +16/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for monad-effect++## 0.1.0.0 -- 2025-09-20++* First release of monad-effect
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2025, Eiko+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,550 @@+# A lightweight, fast, and algebraic effect system that makes sense++This project is in experimental beta, it may change relatively quickly. I will definitely improve it when I use it more in other projects. Feedbacks and contributions are welcome!++## The `EffT` Monad Transformer++The core type of the library is the `EffT` monad transformer, which can be understood as follows:++```haskell+newtype EffT (mods :: [Type]) (es :: [Type]) (m :: Type -> Type) a+ = EffT { SystemRead mods -> SystemState mods -> m (Result es a, SystemState mods) }+```++(This is a simplification of the actual type, but basically the same idea, see the later sections for explanation.)++It is a single layer of reader and state monad together with composable error handling.++* The unit of effect is a `Module`, which just has some custom data families defining its Read and State types.++* `mods` is a list of modules that the effect uses.++* `es` is the list of errors that the effect can throw, which is explicit and algebraic.++* `SystemRead mods` is a data family that holds all the read-only data for the modules in `mods`.++* `SystemState mods` is a data family that holds all the pure-states for the modules in `mods`.++Algebraic exceptions are a key feature of this library, it is easy to throw ad-hoc exception types and the type system will make sure you deal with them or acknowledge their existence.++## Key Features++### **Algebraic Exceptions**++I'm a believer in algebraic data structures and I think exceptions should be made explicit and algebraic. In classic Haskell and other languages like Rust, exceptions are made algebraic using `Maybe` or `Either` types. Haskell provides monadic supports and a `ExceptT` monad transformer for these types, making them joyful to use, I surely love them!++But there are some problems with `Maybe` and `Either`:++* `Maybe` gives you no information about the error, it is composable but not informative. The same problem with `MaybeT`.++* `Either e` gives you information of type `e`, but if you have multiple different `Either e_i` types in your program, there is no obvious way to compose them except by using `Either Text`, `Either SomeException` or `Either e0 (Either e1 (Either e2 e3))`. The former is tempting to use but it gives us no obvious way to catch specific errors (you don't want to parse the Text message to find out what went wrong), and the latter is not ergonomic at all.++* `ExceptT` has the same problem as `Either` and it also has a *small pitfall*, the order of composing monad transformers matters. Think about what `StateT s (ExceptT e m) a` and `ExceptT e (StateT s m) a` mean.++ - `ExceptT e m` is isomorphic to `m (Either e a)`, so `StateT s (m (Either e *)) a` 'desugars' to++ `s -> m (Either e (a, s))`. Depending on what you want the computation to be, this might not be what you want, because once you have an algebraic exception `e`, not only the result `a` is lost, the state during the computation until the exception step is also lost. You will need to start over with an initial state. Maybe this is the behavior you want to have, but it is not obvious what behavior you are using by looking at the type signature.++ - On the other hand, `ExceptT e (StateT s m) a` is isomorphic to `StateT s m (Either e a)`, which desugars to++ `s -> m (Either e a, s)`. This is the more 'correct' behavior, during the computation once you have an exception, the state until the exception step is preserved.++To solve all these problems, we made the following designs:++* A `Result es a` type that is a sum type of all the exception types in the type level list `es` and return type `a`. This is achieved not by using `Either` but a custom GADT:++ ```haskell+ data Result (es :: [Type]) a where+ RSuccess :: a -> Result '[] a+ RFailure :: !(EList es) -> Result es a++ data EList (es :: [Type]) where+ EHead :: !e -> EList (e ': es)+ ETail :: !(EList es) -> EList (e ': es)+ ```++ Here `EList es` is a sum type that has value in exactly one of the types in `es` and is by construction must be non-empty.++ `Result es a` behaves like `Either (EList es) a`, but better: if `es = '[]`, then `Result '[] a` is just isomorphic to `a`, there is no `RFailure` case!+ +* The type inside `EffT` is `SystemRead mods -> SystemState mods -> m (Result es a, SystemState mods)`, which means that the state is preserved when an algebraic exception is thrown. This is the same as `StateT s m (Either e a)`.++ Note if you have a blowup in the base monad `m`, then you will still lose everything in `(Result es a, SystemState mods)` since blowing up `m` can be thought as branching a `Left` case in `m`. The idea is that you should wrap your low-level routine in algebraic exceptions so that everything goes explicit and algebraic.++### **Purity**++Instead of giving up purity and using `IORef` or `TVar` for every state, we allow the possibility of having pure states in the effect modules. We also provide two built-in modules: `SModule s` is a module that holds a pure state of type `s`, and `RModule r` is a module that holds a read-only value of type `r`. You can use these modules to store pure states and read-only values in the effect system. There are also template haskell functions for easily generating modules in `Module.RS.QQ`.++Let's see a simple example that combines the use of `SModule` and algebraic exceptions:++```haskell+import Control.Monad.Effect -- the EffT types and useful combinators+import qualified Data.Map as M+import qualified Data.Text as T++-- | Wraps your effectul routine into EffT monad transformer+myLookup :: (Show k, Ord k, Monad m) => k -> EffT '[SModule (M.Map k v)] '[ErrorText "Map.keyNotFound"] m v+myLookup k+ = effMaybeInWith (errorText @"Map.keyNotFound" $ " where key = " <> T.pack (show k)) -- wraps Maybe into an exception+ $ getsS (M.lookup k) -- this just returns a monadic value of type `Maybe v`++-- | This effect can run as a pure function! Put m = Identity for example.+lookups :: forall v m. (Monad m) => EffT '[SModule (M.Map T.Text v)] '[ErrorText "Map.keyNotFound"] m (v, v, v)+lookups = do+ foo <- myLookup "foo" -- this will throw an exception if "foo" is not found+ bar <- myLookup "bar" -- instead of Nothing, you get an algebraic exception `ErrorText "Map.keyNotFound"` explaining what went wrong+ baz <- myLookup "baz" -- just like Maybe and Either, when an exception is thrown, the computation stops and immediately returns+ return (foo, bar, baz)+```++Here `ErrorText (s :: k)` is a newtype wrapper for `Text` is for you to create ad-hoc exception types very easily. We also provided `ErrorValue (s :: k) (v :: Type)` that is a newtype wrapping `v` if you want a more concrete type.++### **Performant**++In fact the library defines a more general `EffT'` type that is also polymorphic in the container that holds the list of types++```haskell+newtype EffT' (c :: (Type -> Type) -> [Type] -> Type) (mods :: [Type]) (es :: [Type]) (m :: Type -> Type) a+ = EffT' { SystemRead c mods -> SystemState c mods -> m (Result es a, SystemState c mods) }++-- | Short hand monads, recommended, uses FData under the hood+type Eff mods es = EffT' FData mods es IO+type EffT mods es = EffT' FData mods es+type Pure mods es = EffT' FData mods es Identity+type In mods es = In' FData mods es++-- | Short hand monads which uses FList instead of FData as the data structure+type EffL mods es = EffT' FList mods es IO+type EffLT mods es = EffT' FList mods es+type PureL mods es = EffT' FList mods es Identity+type InL mods es = In' FList mods es+```++And we have two containers implemented, a standard heterogeneous list `c = FList`++```haskell+data FList (f :: Type -> Type) (ts :: [Type]) where+ FNil :: FList f '[]+ FCons :: !(f t) -> !(FList f ts) -> FList f (t : ts)+infixr 5 `FCons`+```++And a more performant data family `c = FData`. The `FData` container is used by default, instead of storing a list as your data structure, it creates a data container that is indexed by the list++```haskell+data family FData (f :: Type -> Type) (ts :: [Type]) :: Type++data instance FData f '[] = FData0+data instance FData f '[t] = FData1+ { fdata1_0 :: !(f t)+ }+data instance FData f '[t1, t2] = FData2+ { fdata2_0 :: !(f t1)+ , fdata2_1 :: !(f t2)+ }+data instance FData f '[t1, t2, t3] = FData3+ { fdata3_0 :: !(f t1)+ , fdata3_1 :: !(f t2)+ , fdata3_2 :: !(f t3)+ }+data instance FData f '[t1, t2, t3, t4] = FData4+ { fdata4_0 :: !(f t1)+ , fdata4_1 :: !(f t2)+ , fdata4_2 :: !(f t3)+ , fdata4_3 :: !(f t4)+ }+data instance FData f '[t1, t2, t3, t4, t5] = FData5+ { fdata5_0 :: !(f t1)+ , fdata5_1 :: !(f t2)+ , fdata5_2 :: !(f t3)+ , fdata5_3 :: !(f t4)+ , fdata5_4 :: !(f t5)+ }+```++This is much more performant than a list (which GHC cannot inline recursive functions operating on it), and GHC optimizes it very well. The performance of `FData` over `FList` is about `5~100` times faster!++Of course we did not write the instances by hand, rather we used Template Haskell to generate all the instances including the methods to extract values from the data structure and to update/compose them. Currently we generated instances up to 19 types in the list, which should be more than enough. (Remark: the error type `es` does not live in `FData` and have no limit).++A count-down benchmark shows that `EffT` is 25 times faster than `StateT` without optimization, and as fast as a `StateT` with correct optimization (`-O2 -flate-dmd-anal`, for which both optimizes to a really fast simple loop!)++```haskell+{-# LANGUAGE DataKinds, PartialTypeSignatures #-}+module Main (main) where++import Control.Monad.Effect+import Criterion.Main+import Data.TypeList+import Data.TypeList.FData+import Module.RS+import qualified Control.Monad.State as S++testEffStateFPoly :: _ => EffT' flist '[RModule (), SModule Int, SModule Bool] NoError IO ()+testEffStateFPoly = do+ x <- getS @Int+ modifyS not+ if x < 1_000_000+ then putS (x + 1) >> testEffStateFPoly+ else return ()++testMtlState :: S.StateT ((), Int, Bool) IO ()+testMtlState = do+ x <- S.gets (\(_, x, _) -> x)+ S.modify (\(_, x', b) -> ((), x', not b))+ if x < 1_000_000+ then do+ S.modify (\(_, _, b) -> ((), x + 1, b))+ testMtlState+ else return ()++main = defaultMain+ [ bgroup "State Effect Eff"+ [ bench "FList" $ whnfIO $ runEffTNoError+ (RRead () :*** SRead :*** SRead :*** FNil)+ (RState :*** SState 0 :*** SState False :*** FNil)+ testEffStateFPoly+ , bench "FData" $ whnfIO $ runEffTNoError+ (FData3 (RRead ()) SRead SRead)+ (FData3 (RState) (SState 0) (SState False))+ testEffStateFPoly+ ]+ , bgroup "Mtl State"+ [ bench "StateT" $ whnfIO $ S.runStateT testMtlState ((), 0, False)+ ]+ ]+```++Here `:***` is a pattern synonym, you can use it to replace `FCons` and even use it in pattern matching `FData` or constructing `FData`, with `fNil` being a polymorphic empty container.++Tested on my laptop with GHC 9.12.2:++```plain+-------- With -O2 -flate-dmd-anal++benchmarking State Effect Eff/FList+time 4.971 ms (4.031 ms .. 5.956 ms)+ 0.887 R² (0.843 R² .. 0.985 R²)+mean 5.264 ms (4.919 ms .. 5.648 ms)+std dev 1.239 ms (975.3 μs .. 1.412 ms)+variance introduced by outliers: 90% (severely inflated)++benchmarking State Effect Eff/FData+time 117.6 μs (117.5 μs .. 117.7 μs)+ 1.000 R² (1.000 R² .. 1.000 R²)+mean 117.5 μs (117.2 μs .. 117.7 μs)+std dev 865.3 ns (639.9 ns .. 1.398 μs)++benchmarking Mtl State/StateT+time 117.1 μs (116.8 μs .. 117.3 μs)+ 1.000 R² (1.000 R² .. 1.000 R²)+mean 117.3 μs (117.2 μs .. 117.5 μs)+std dev 463.5 ns (345.5 ns .. 691.4 ns)+```++The optimization friendly design of the library allows you to use it in performance critical code without sacrificing purity and composability, it can be used as a drop-in replacement (upgrade!) for `StateT`, `ExceptT`, `ReaderT`, or even `IO` monad, which is more performant and composable!++### Flexible++#### Represents Common Monads++The `EffT` monad can be easily transformed into other monads, making it really a more flexible and composable replacement for `StateT`, `ExceptT`, `ReaderT`, or even `IO` monad.++For example,++* the type `EffT '[] '[] m a` is just isomorphic to `m a`++* the type `EffT '[] '[e] m a` is isomorphic to `m (Either e a)`++* the type `EffT '[] es m a` is isomorphic to `m (Result es a)`++```haskell+type NoError = '[] -- just a synonym++-- | runs the EffT' with no modules and no error+runEffT00 :: (Monad m, ConsFNil c) => EffT' c '[] NoError m a -> m a+runEffT00 = fmap resultNoError . runEffT0++-- | runs the EffT' with no modules and a single possible error type, return as classic Either type+runEffT01 :: (Monad m, ConsFNil c) => EffT' c '[] '[e] m a -> m (Either e a)+runEffT01 = fmap (first fromElistSingleton . resultToEither) . runEffT0++-- | runs the EffT' with no modules+runEffT0 :: (Monad m, ConsFNil c) => EffT' c '[] es m a -> m (Result es a)+runEffT0 = fmap fst . runEffT fNil fNil++-- | Convert the first error in the effect to Either+errorToEither :: Monad m => EffT' c mods (e : es) m a -> EffT' c mods es m (Either e a)++-- | Convert all errors to Either+errorToEitherAll :: Monad m => EffT' c mods es m a -> EffT' c mods NoError m (Either (EList es) a)+-- (... more functions to convert EffT between common types ...)+```++#### Eliminate Effects++Effects can be eliminated! Imagine if you have 5 reader modules, you should be able to give a reader value and eliminate it from the effect type. This is achieved by the following functions:++```haskell+-- | Runs a EffT' computation and eliminate the most outer effect with its input given+--+-- Warning: `ModuleState mod` will be lost when the outer EffT' returns an exception+runEffTOuter :: forall mod mods es m c a. (ConsFDataList c (mod : mods), ConsFData1 c mods, Monad m)+ => ModuleRead mod -> ModuleState mod -> EffT' c (mod : mods) es m a -> EffT' c mods es m (a, ModuleState mod)++-- | the same as runEffTOuter, but discards the state+runEffTOuter_ :: forall mod mods es m c a. (ConsFDataList c (mod : mods), ConsFData1 c mods, Monad m)+ => ModuleRead mod -> ModuleState mod -> EffT' c (mod : mods) es m a -> EffT' c mods es m a++-- | Running an inner module of EffT, eliminates it+runEffTIn :: forall mod mods es m c a. (RemoveElem c mods, Monad m, In' c mod mods)+ => ModuleRead mod -> ModuleState mod -> EffT' c mods es m a+ -> EffT' c (Remove (FirstIndex mod mods) mods) es m (a, ModuleState mod)++-- | The same as runEffTIn, but discards the state+runEffTIn_ :: forall mod mods es m c a. (RemoveElem c mods, Monad m, In' c mod mods)+ => ModuleRead mod -> ModuleState mod -> EffT' c mods es m a+ -> EffT' c (Remove (FirstIndex mod mods) mods) es m a+```++#### Throw Algebraic and Catch Algebraic Exceptions++You can throw algebraic exceptions in the effect system using `effThrowIn` and catch them using `effCatch`. After they are caught, the error type is removed from the error list.++```haskell+```haskell+-- | Throw into the error list+effThrowIn :: (Monad m, InList e es) => e -> EffT' c mods es m a++-- | Throw into the error list+effThrow :: (Monad m, InList e es) => e -> EffT' c mods es m a+effThrow = effThrowIn++-- | Catch the first error in the error list, and handle it with a handler function+effCatch :: Monad m => EffT' c mods (e : es) m a -> (e -> EffT' c mods es m a) -> EffT' c mods es m a++-- | Catch a specific error type in the error list, and handle it with a handler function.+-- This will remove the error type from the error list.+effCatchIn:: forall e es mods m c a es'. (Monad m, InList e es, es' ~ Remove (FirstIndex e es) es)+ => EffT' c mods es m a -> (e -> EffT' c mods es' m a) -> EffT' c mods es' m a+```++## An Example++```haskell+module Examples where++import Control.Exception+import Control.Monad+import Control.Monad.Effect -- the EffT types and useful combinators+import Module.RS -- built in modules, a reader module and a state module+import System.IO+import qualified Data.Map as M+import qualified Data.Text as T++-- $ our monad-effect provides **module management** and **composable exceptions**+-- it's algebraic, performant, make sense, without sacrificing purity++-- | Wraps your effectul routine into EffT monad transformer+myLookup :: (Show k, Ord k, Monad m) => k -> EffT '[SModule (M.Map k v)] '[ErrorText "Map.keyNotFound"] m v+myLookup k+ = effMaybeInWith (ErrorText @"Map.keyNotFound" $ " where key = " <> T.pack (show k)) -- wraps Maybe into an exception+ $ getsS (M.lookup k) -- this just returns a monadic value of type `Maybe v`++-- | This effect can run in pure monads! like Identity+lookups :: forall v m. (Monad m) => EffT '[SModule (M.Map T.Text v)] '[ErrorText "Map.keyNotFound"] m (v, v, v)+lookups = do+ foo <- myLookup "foo" -- this will throw an exception if "foo" is not found+ bar <- myLookup "bar" -- instead of Nothing, you get an algebraic exception `ErrorText "Map.keyNotFound"` explaining what went wrong+ baz <- myLookup "baz" -- just like Maybe and Either, when an exception is thrown, the computation stops and immediately returns+ return (foo, bar, baz)++parse :: String -> Maybe [Double]+parse = undefined -- some parsing logic that returns `Nothing` on failure++computeAverageFromFile+ :: FilePath+ -> Eff -- a synonym, Eff mods es a = EffT mods es IO a+ '[SModule (M.Map T.Text Int)] -- this effect can read and modify a value of type (Map Text Int)+ [ IOException -- composable and explicit exceptions+ , ErrorText "empty-file" -- you know what types of error this effect can produce+ , ErrorText "zero-numbers" -- just by observing its type signature+ , ErrorText "Map.keyNotFound"+ ]+ Double -- return type+computeAverageFromFile fp = do+ -- | the `liftIOException :: IO a -> Eff '[] '[IOException] a` captures `IOException`+ content <- embedError . liftIOException $ readFile' fp++ -- | throw an Algebraic error instead of an exception that you have no idea+ when (null content) $ do+ effThrowIn ("file is empty" :: ErrorText "empty-file")++ -- | this `pureMaybeInWith :: In e es => e -> Maybe a -> Eff mods es a` turns a Maybe value into an ad-hoc exception type!+ parsed <- pureMaybeInWith ("parse error" :: ErrorText "parse-error") (parse content) + `effCatch` (\(_ :: ErrorText "parse-error") -> return [0])+ -- ^ you can catch exception and deal with it, so the error is eliminated from the list++ -- | The type system will check whether you have the module needed to perform this action+ _ <- embedEffT $ lookups @Int++ -- | The type system will force you remember that we can return an exception with an custom type `ErrorText "zero-numbers"`+ when (null parsed) $ do+ effThrowIn ("zero numbers" :: ErrorText "zero-numbers")++ return $ sum parsed / fromIntegral (length parsed)+```++## Template Haskell Utilities For Simple Effect Modules++In `Module.RS.QQ`, we provide some Template Haskell utilities for easily generating simple reader modules, state modules, and reader-state modules.++The `makeRModule` function generates a reader module, for example++given the following information:++```haskell+[makeRModule|MyModule+ myRecord1 :: !MyType1+ myRecord2 :: MyType2+|]+```++it should generate++```haskell+data MyModule++type MyModuleRead = ModuleRead MyModule++instance Module MyModule where+ data ModuleRead MyModule = MyModuleRead { myRecord1 :: !MyType1, myRecord2 :: MyType2 }+ data ModuleState MyModule = MyModuleState deriving (Generic, NFData)++runMyModule :: (ConsFDataList c mods, Monad m) => ModuleRead MyModule -> EffT' c (MyModule : mods) errs m a -> EffT' mods errs m a+runMyModule r = runEffTOuter_ r MyModuleState+{-# INLINE runMyModule #-}++runRModuleIn :: (ConsFDataList c mods, RemoveElem c mods, Monad m, In' c MyModule mods) => ModuleRead MyModule -> EffT' c mods es m a -> EffT' c (Remove (FirstIndex MyModule mods) mods) es m a+runRModuleIn r = runEffTIn_ r MyModuleState+{-# INLINE runMyModuleIn #-}++-- It also generates obvious instances for `ModuleEvent` and `ModuleInitData`.+-- If this is to be avoided (for example you want to write your own instances), use `makeRModule__` instead.+```++If you don't want the `derive (Generic, NFData)`, use `makeRModule_` instead.++Another function `makeRSModule` generates a reader-state module, for example++```haskell+[makeRSModule|+MyRSModule+ Read myField1 :: !MyType1+ Read myField2 :: MyType2+ State myStateField1 :: !MyStateType1+ State myStateField2 :: MyStateType2+|]+```++it should generate++* data MyRSModule+* generate data instances for Module `<MyModule>`+* generate `run<MyModule>, run<MyModule>', run<MyModule>_ and run<MyModule>In, run<MyModule>In', run<MyModule>In_` functions+* generate type synonym for `type MyModuleRead = ModuleRead <MyModule>` and `type MyModuleState = ModuleState <MyModule>`++Similarly, if you don't want the deriving behavior, use `makeRSModule_` instead.++Caveat: unfortunately, currently you can't have type variables in the module type constructor when you use the template haskell utilitys, currently you have to write your own module declaration. We wish to add support for this in the future.++## Style++`monad-effect` does not make the choice of how you should structure your effects. You can put configs, pure states, enviroments, handlers, into your effect module. You can make the effect module coupled to a particular implementation for convenience and speed, or if you want to enforce the algebraic effect style where the effects and interpreters are decoupled, it can be written this way for example, it is all up to you:++```haskell+{-# LANGUAGE DataKinds, TypeFamilies, RequiredTypeArguments #-}+module Module.Prometheus.Counter where++import Control.Monad.Effect+import System.Metrics.Prometheus.Metric.Counter as C++-- | A prometheus counter module that has a name+data PrometheusCounter (name :: k)++-- | Counter effects written in algebraic effect style+data PrometheusCounterEffect a where+ AddAndSampleCounter :: Int -> PrometheusCounterEffect CounterSample+ AddCounter :: Int -> PrometheusCounterEffect ()+ IncCounter :: PrometheusCounterEffect ()+ SetCounter :: Int -> PrometheusCounterEffect ()+ SampleCounter :: PrometheusCounterEffect CounterSample++-- | The effect handler type for a prometheus counter with given counter name+type PrometheusCounterHandler (name :: k) = forall c mods es m a. (In' c (PrometheusCounter name) mods, MonadIO m) => PrometheusCounterEffect a -> EffT' c mods es m a++-- | The module is declared as a reader module that carries a counter handler+instance Module (PrometheusCounter name) where+ newtype ModuleRead (PrometheusCounter name) = PrometheusCounterRead { prometheusCounterHandler :: PrometheusCounterHandler name }+ data ModuleState (PrometheusCounter name) = PrometheusCounterState++-- | Specify / interpret a counter effect with given counter name+runPrometheusCounter+ :: forall name+ -> ( ConsFDataList c (PrometheusCounter name : mods)+ , Monad m+ )+ => PrometheusCounterHandler name -> EffT' c (PrometheusCounter name ': mods) es m a -> EffT' c mods es m a+runPrometheusCounter name handler = runEffTOuter_ (PrometheusCounterRead @_ @name handler) PrometheusCounterState+{-# INLINE runPrometheusCounter #-}++-- | Carry out a counter effect with given counter name+prometheusCounterEffect :: forall name -> (In' c (PrometheusCounter name) mods, MonadIO m) => PrometheusCounterEffect a -> EffT' c mods es m a+prometheusCounterEffect name eff = do+ PrometheusCounterRead handler <- askModule @(PrometheusCounter name)+ handler eff+{-# INLINE prometheusCounterEffect #-}++-- | Use a specific counter to carry out a counter effect+useCounter :: Counter -> PrometheusCounterHandler name+useCounter counter IncCounter = liftIO $ C.inc counter+useCounter counter (AddCounter n) = liftIO $ C.add n counter+useCounter counter (SetCounter n) = liftIO $ C.set n counter+useCounter counter (AddAndSampleCounter n) = liftIO $ C.addAndSample n counter+useCounter counter SampleCounter = liftIO $ C.sample counter+{-# INLINE useCounter #-}++-- | A counter handler that does nothing+noCounter :: Monad m => PrometheusCounterEffect a -> EffT mods es m a+noCounter IncCounter = pure ()+noCounter (AddCounter _) = pure ()+noCounter (SetCounter _) = pure ()+noCounter (AddAndSampleCounter _) = pure (CounterSample 0)+noCounter SampleCounter = pure (CounterSample 0)+{-# INLINE noCounter #-}+```++## Flags++Use `-fconstraint-solver-iterations=16` or `19` to avoid some type checker issues.++## Some Benchmarks++See the `benchmark` folder for more benchmarks. The benchmarks are copied from `heftia`, another effect system library and I added some modified versions.++#### Countdown `-O2`+++#### Countdown `-O0`+++#### Deep Catch `-O2`+++#### Deep Catch `-O0`+++#### Local State `-O2`+++#### Local State `-O0`+
+ bench/BenchCatch.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE CPP #-}++-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2022 Xy Ren; 2024 Sayo contributors++-- Benchmarking higher-order effects #1: Catching errors++module BenchCatch where++import Data.Bifunctor (first)++import Control.Monad.Effect as ME+import Module.RS as ME+import Data.TypeList.FData as ME++import Control.Carrier.Error.Either qualified as F+import Control.Carrier.Reader qualified as F+import Control.Monad.Except qualified as M+import Control.Monad.Hefty qualified as H+import Control.Monad.Hefty.Except qualified as H+import Control.Monad.Hefty.Reader qualified as H+import Control.Monad.Identity qualified as M+import Control.Monad.Reader qualified as M+import Effectful qualified as EL+import Effectful.Error.Dynamic qualified as EL+import Effectful.Reader.Dynamic qualified as EL+import Polysemy qualified as P+import Polysemy.Error qualified as P+import Polysemy.Reader qualified as P+++++programMonadEffect :: Int -> ME.EffT mods '[ErrorValue "()" ()] ME.Identity ()+programMonadEffect = \case+ 0 -> ME.effThrow (ErrorValue @"()" ())+ n -> ME.effCatchIn' (programMonadEffect (n - 1)) $ \(ErrorValue @"()" ()) -> ME.effThrow (ErrorValue @"()" ())+{-# NOINLINE programMonadEffect #-}++catchMonadEffect :: Int -> Either () ()+catchMonadEffect n = first (\(ErrorValue s) -> s) . ME.runIdentity . ME.runEffT01 $ programMonadEffect n++catchMonadEffectDeep :: Int -> Result '[ErrorValue "()" ()] ()+catchMonadEffectDeep n = ME.runIdentity $ ME.runEffT_+ (FData10 (RRead ()) (RRead ()) (RRead ()) (RRead ()) (RRead ())+ (RRead ()) (RRead ()) (RRead ()) (RRead ()) (RRead ())+ )+ (FData10 RState RState RState RState RState+ RState RState RState RState RState+ )+ (programMonadEffect n)++programHeftia :: (H.Throw () H.:> es, H.Catch () H.:> es) => Int -> H.Eff es a+programHeftia = \case+ 0 -> H.throw ()+ n -> H.catch (programHeftia (n - 1)) \() -> H.throw ()+{-# NOINLINE programHeftia #-}++catchHeftia :: Int -> Either () ()+catchHeftia n = H.runPure $ H.runThrow $ H.runCatch @() $ programHeftia n++catchHeftiaDeep0, catchHeftiaDeep1, catchHeftiaDeep2, catchHeftiaDeep3, catchHeftiaDeep4, catchHeftiaDeep5 :: Int -> Either () ()+catchHeftiaDeep0 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runThrow $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runCatch @() $ programHeftia n+catchHeftiaDeep1 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runThrow $ hrun $ hrun $ hrun $ hrun $ H.runCatch @() $ hrun $ programHeftia n+catchHeftiaDeep2 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runThrow $ hrun $ hrun $ hrun $ H.runCatch @() $ hrun $ hrun $ programHeftia n+catchHeftiaDeep3 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runThrow $ hrun $ hrun $ H.runCatch @() $ hrun $ hrun $ hrun $ programHeftia n+catchHeftiaDeep4 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runThrow $ hrun $ H.runCatch @() $ hrun $ hrun $ hrun $ hrun $ programHeftia n+catchHeftiaDeep5 n = H.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runThrow $ H.runCatch @() $ hrun $ hrun $ hrun $ hrun $ hrun $ programHeftia n++hrun :: H.Eff (H.Ask () ': es) a -> H.Eff es a+hrun = H.runAsk ()++programSem :: (P.Error () `P.Member` es) => Int -> P.Sem es a+programSem = \case+ 0 -> P.throw ()+ n -> P.catch (programSem (n - 1)) \() -> P.throw ()+{-# NOINLINE programSem #-}++catchSem :: Int -> Either () ()+catchSem n = P.run $ P.runError $ programSem n++catchSemDeep :: Int -> Either () ()+catchSemDeep n = P.run $ run $ run $ run $ run $ run $ P.runError $ run $ run $ run $ run $ run $ programSem n+ where+ run = P.runReader ()++programFused :: (F.Has (F.Error ()) sig m) => Int -> m a+programFused = \case+ 0 -> F.throwError ()+ n -> F.catchError (programFused (n - 1)) \() -> F.throwError ()+{-# NOINLINE programFused #-}++catchFused :: Int -> Either () ()+catchFused n = F.run $ F.runError $ programFused n++catchFusedDeep :: Int -> Either () ()+catchFusedDeep n = F.run $ run $ run $ run $ run $ run $ F.runError $ run $ run $ run $ run $ run $ programFused n+ where+ run = F.runReader ()++programEffectful :: (EL.Error () EL.:> es) => Int -> EL.Eff es a+programEffectful = \case+ 0 -> EL.throwError ()+ n -> EL.catchError (programEffectful (n - 1)) \_ () -> EL.throwError ()+{-# NOINLINE programEffectful #-}++catchEffectful :: Int -> Either (EL.CallStack, ()) ()+catchEffectful n = EL.runPureEff $ EL.runError $ programEffectful n++catchEffectfulDeep :: Int -> Either (EL.CallStack, ()) ()+catchEffectfulDeep n =+ EL.runPureEff $ run $ run $ run $ run $ run $ EL.runError $ run $ run $ run $ run $ run $ programEffectful n+ where+ run = EL.runReader ()++++++++++++++++++programMtl :: (M.MonadError () m) => Int -> m a+programMtl = \case+ 0 -> M.throwError ()+ n -> M.catchError (programMtl (n - 1)) \() -> M.throwError ()+{-# NOINLINE programMtl #-}++catchMtl :: Int -> Either () ()+catchMtl n = M.runExcept $ programMtl n++catchMtlDeep :: Int -> Either () ()+catchMtlDeep n = M.runIdentity $ run $ run $ run $ run $ run $ M.runExceptT $ run $ run $ run $ run $ run $ programMtl n+ where+ run = (`M.runReaderT` ())
+ bench/BenchCoroutine.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE CPP #-}++-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2022 Xy Ren; 2024 Sayo contributors++module BenchCoroutine where++import Control.Monad (forM)+#ifdef VERSION_freer_simple+import Control.Monad.Freer qualified as FS+import Control.Monad.Freer.Coroutine qualified as FS+import Control.Monad.Freer.Reader qualified as FS+#endif+import Control.Monad.Hefty qualified as H+import Control.Monad.Hefty.Coroutine qualified as H+import Control.Monad.Hefty.Reader qualified as H+#ifdef VERSION_eff+import "eff" Control.Effect qualified as E+#endif++#ifdef VERSION_freer_simple+programFreer :: (FS.Member (FS.Yield Int Int) es) => Int -> FS.Eff es [Int]+programFreer upbound =+ forM [1 .. upbound] (`FS.yield` id)+{-# NOINLINE programFreer #-}++loopStatusFreer :: FS.Status es Int Int r -> FS.Eff es r+loopStatusFreer = \case+ FS.Done r -> pure r+ FS.Continue i f -> loopStatusFreer =<< f (i + 100)+{-# NOINLINE loopStatusFreer #-}++coroutineFreer :: Int -> [Int]+coroutineFreer n = FS.run $ loopStatusFreer =<< FS.runC (programFreer n)++coroutineFreerDeep :: Int -> [Int]+coroutineFreerDeep n = FS.run $ run $ run $ run $ run $ run $ loopStatusFreer =<< FS.runC (run $ run $ run $ run $ run $ programFreer n)+ where+ run = FS.runReader ()+#endif++programHeftia :: (H.Yield Int Int H.:> es) => Int -> H.Eff es [Int]+programHeftia upbound =+ forM [1 .. upbound] H.yield+{-# NOINLINE programHeftia #-}++loopStatusHeftia :: H.Status (H.Eff es) Int Int r -> H.Eff es r+loopStatusHeftia = \case+ H.Done r -> pure r+ H.Continue i f -> loopStatusHeftia =<< f (i + 100)+{-# NOINLINE loopStatusHeftia #-}++coroutineHeftia :: Int -> [Int]+coroutineHeftia n = H.runPure $ loopStatusHeftia =<< H.runCoroutine (programHeftia n)++coroutineHeftiaDeep :: Int -> [Int]+coroutineHeftiaDeep n = H.runPure $ run $ run $ run $ run $ run $ loopStatusHeftia =<< H.runCoroutine (run $ run $ run $ run $ run $ programHeftia n)+ where+ run :: H.Eff (H.Ask () ': es) a -> H.Eff es a+ run = H.runAsk ()++#ifdef VERSION_eff+programEff :: (E.Coroutine Int Int E.:< es) => Int -> E.Eff es [Int]+programEff upbound =+ forM [1 .. upbound] $ E.yield @Int @Int+{-# NOINLINE programEff #-}++loopStatusEff :: E.Status es Int Int r -> E.Eff es r+loopStatusEff = \case+ E.Done r -> pure r+ E.Yielded i f -> loopStatusEff =<< E.runCoroutine (f (i + 100))+{-# NOINLINE loopStatusEff #-}++coroutineEff :: Int -> [Int]+coroutineEff n = E.run $ loopStatusEff =<< E.runCoroutine (programEff n)++coroutineEffDeep :: Int -> [Int]+coroutineEffDeep n = E.run $ run $ run $ run $ run $ run $ loopStatusEff =<< E.runCoroutine (run $ run $ run $ run $ run $ programEff n)+ where+ run = E.runReader ()+#endif
+ bench/BenchCountdown.hs view
@@ -0,0 +1,225 @@+{-# OPTIONS_GHC -funfolding-use-threshold=1000 -fmax-worker-args=16 #-}+{-# LANGUAGE CPP, PartialTypeSignatures #-}++-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2022 Xy Ren; 2024 Sayo contributors++-- Benchmarking effect invocation and monadic bind+module BenchCountdown where++import Control.Monad.Effect as ME+import Module.RS as ME+import Data.TypeList.FData as ME++import Control.Carrier.Reader qualified as F+import Control.Carrier.State.Strict qualified as F+#ifdef VERSION_freer_simple+import Control.Monad.Freer qualified as FS+import Control.Monad.Freer.Reader qualified as FS+import Control.Monad.Freer.State qualified as FS+#endif+import Control.Monad.Hefty qualified as H+import Control.Monad.Hefty.Reader qualified as H+import Control.Monad.Hefty.State qualified as H+import Control.Monad.Identity qualified as M+import Control.Monad.Reader qualified as M+import Control.Monad.State.Strict qualified as M+import Effectful qualified as EL+import Effectful.Reader.Dynamic qualified as EL+import Effectful.State.Dynamic qualified as EL+import Polysemy qualified as P+import Polysemy.Reader qualified as P+import Polysemy.State qualified as P+#ifdef VERSION_eff+import "eff" Control.Effect qualified as EF+#endif++programMonadEffect :: ME.In (ME.SModule Int) mods => ME.EffT mods ME.NoError ME.Identity Int+programMonadEffect = do+ x <- ME.getS @Int+ if x == 0+ then pure x+ else do+ ME.putS (x - 1)+ programMonadEffect+#ifdef NOINLINE+{-# NOINLINE programMonadEffect #-}+#endif++programMonadEffectDeep :: ME.EffT + [ ME.RModule (), ME.RModule (), ME.RModule (), ME.RModule (), ME.RModule ()+ , ME.SModule Int+ , ME.RModule (), ME.RModule (), ME.RModule (), ME.RModule (), ME.RModule ()+ ] ME.NoError ME.Identity Int+programMonadEffectDeep = do+ x <- ME.getS @Int+ if x == 0+ then pure x+ else do+ ME.putS (x - 1)+ programMonadEffectDeep++countdownMonadEffect :: Int -> (Int, _)+countdownMonadEffect n =+ ME.runIdentity $ ME.runEffTNoError (ME.FData1 ME.SRead) (ME.FData1 $ ME.SState n) $ programMonadEffect++countdownMonadEffectDeep :: Int -> (Int, _)+countdownMonadEffectDeep n = ME.runIdentity $+ ME.runEffTNoError+ (ME.FData11 readUnit readUnit readUnit readUnit readUnit SRead readUnit readUnit readUnit readUnit readUnit)+ (ME.FData11 rStateUnit rStateUnit rStateUnit rStateUnit rStateUnit (ME.SState n) rStateUnit rStateUnit rStateUnit rStateUnit rStateUnit)+ $ programMonadEffectDeep+ where readUnit = ME.RRead ()+ rStateUnit = ME.RState++programHeftia :: (H.State Int H.:> es) => H.Eff es Int+programHeftia = do+ x <- H.get @Int+ if x == 0+ then pure x+ else do+ H.put (x - 1)+ programHeftia+#ifdef NOINLINE+{-# NOINLINE programHeftia #-}+#endif++countdownHeftia :: Int -> (Int, Int)+countdownHeftia n = H.runPure $ H.runState n programHeftia++countdownHeftiaDeep :: Int -> (Int, Int)+countdownHeftiaDeep n = H.runPure $ hrunR $ hrunR $ hrunR $ hrunR $ hrunR $ H.runState n $ hrunR $ hrunR $ hrunR $ hrunR $ hrunR $ programHeftia++countdownHeftiaNaive :: Int -> (Int, Int)+countdownHeftiaNaive n = H.runPure $ H.runStateNaive n programHeftia++countdownHeftiaNaiveDeep :: Int -> (Int, Int)+countdownHeftiaNaiveDeep n = H.runPure $ hrunR $ hrunR $ hrunR $ hrunR $ hrunR $ H.runStateNaive n $ hrunR $ hrunR $ hrunR $ hrunR $ hrunR $ programHeftia++hrunR :: H.Eff (H.Ask () ': es) a -> H.Eff es a+hrunR = H.runAsk ()++#ifdef VERSION_freer_simple+programFreer :: (FS.Member (FS.State Int) es) => FS.Eff es Int+programFreer = do+ x <- FS.get @Int+ if x == 0+ then pure x+ else do+ FS.put (x - 1)+ programFreer+#ifdef NOINLINE+{-# NOINLINE programFreer #-}+#endif++countdownFreer :: Int -> (Int, Int)+countdownFreer n = FS.run $ FS.runState n programFreer++countdownFreerDeep :: Int -> (Int, Int)+countdownFreerDeep n = FS.run $ runR $ runR $ runR $ runR $ runR $ FS.runState n $ runR $ runR $ runR $ runR $ runR $ programFreer+ where+ runR = FS.runReader ()+#endif++programSem :: (P.Member (P.State Int) es) => P.Sem es Int+programSem = do+ x <- P.get @Int+ if x == 0+ then pure x+ else do+ P.put (x - 1)+ programSem+#ifdef NOINLINE+{-# NOINLINE programSem #-}+#endif++countdownSem :: Int -> (Int, Int)+countdownSem n = P.run $ P.runState n programSem++countdownSemDeep :: Int -> (Int, Int)+countdownSemDeep n = P.run $ runR $ runR $ runR $ runR $ runR $ P.runState n $ runR $ runR $ runR $ runR $ runR $ programSem+ where+ runR = P.runReader ()++programFused :: (F.Has (F.State Int) sig m) => m Int+programFused = do+ x <- F.get @Int+ if x == 0+ then pure x+ else do+ F.put (x - 1)+ programFused+#ifdef NOINLINE+{-# NOINLINE programFused #-}+#endif++countdownFused :: Int -> (Int, Int)+countdownFused n = F.run $ F.runState n programFused++countdownFusedDeep :: Int -> (Int, Int)+countdownFusedDeep n = F.run $ runR $ runR $ runR $ runR $ runR $ F.runState n $ runR $ runR $ runR $ runR $ runR $ programFused+ where+ runR = F.runReader ()++programEffectful :: (EL.State Int EL.:> es) => EL.Eff es Int+programEffectful = do+ x <- EL.get @Int+ if x == 0+ then pure x+ else do+ EL.put (x - 1)+ programEffectful+#ifdef NOINLINE+{-# NOINLINE programEffectful #-}+#endif++countdownEffectful :: Int -> (Int, Int)+countdownEffectful n = EL.runPureEff $ EL.runStateLocal n programEffectful++countdownEffectfulDeep :: Int -> (Int, Int)+countdownEffectfulDeep n =+ EL.runPureEff $ runR $ runR $ runR $ runR $ runR $ EL.runStateLocal n $ runR $ runR $ runR $ runR $ runR $ programEffectful+ where+ runR = EL.runReader ()++#ifdef VERSION_eff+programEff :: (EF.State Int EF.:< es) => EF.Eff es Int+programEff = do+ x <- EF.get @Int+ if x == 0+ then pure x+ else do+ EF.put (x - 1)+ programEff+#ifdef NOINLINE+{-# NOINLINE programEff #-}+#endif++countdownEff :: Int -> (Int, Int)+countdownEff n = EF.run $ EF.runState n programEff++countdownEffDeep :: Int -> (Int, Int)+countdownEffDeep n = EF.run $ runR $ runR $ runR $ runR $ runR $ EF.runState n $ runR $ runR $ runR $ runR $ runR $ programEff+ where+ runR = EF.runReader ()+#endif++programMtl :: (M.MonadState Int m) => m Int+programMtl = do+ x <- M.get @Int+ if x == 0+ then pure x+ else do+ M.put (x - 1)+ programMtl+#ifdef NOINLINE+{-# NOINLINE programMtl #-}+#endif++countdownMtl :: Int -> (Int, Int)+countdownMtl = M.runState programMtl++countdownMtlDeep :: Int -> (Int, Int)+countdownMtlDeep n = M.runIdentity $ runR $ runR $ runR $ runR $ runR $ M.runStateT (runR $ runR $ runR $ runR $ runR $ programMtl) n+ where+ runR = (`M.runReaderT` ())
+ bench/BenchFileSizes.hs view
@@ -0,0 +1,653 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# HLINT ignore "Use camelCase" #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2021-2022, Andrzej Rybczak; 2024 Sayo contributors++module BenchFileSizes where++import Control.Exception (IOException, try)+import Control.Monad.IO.Class (MonadIO (..))+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.Text (Text)+import Data.Text qualified as T+import System.Posix (fileSize, getFileStatus)++import qualified Control.Monad.Effect as ME++-- effectful+import Effectful qualified as E+import Effectful.Dispatch.Dynamic qualified as E+import Effectful.Reader.Static qualified as E+import Effectful.State.Static.Local qualified as E++-- eff+#ifdef VERSION_eff+import "eff" Control.Effect qualified as L+#endif++-- cleff+#ifdef VERSION_cleff+import Cleff qualified as C+import Cleff.Reader qualified as C+import Cleff.State qualified as C+#endif++-- freer-simple+#ifdef VERSION_freer_simple+import Control.Monad.Freer qualified as FS+import Control.Monad.Freer.Reader qualified as FS+import Control.Monad.Freer.State qualified as FS+#endif++-- fused-effects+#ifdef VERSION_fused_effects+import Control.Algebra qualified as FE+import Control.Effect.Sum qualified as FE+import Control.Carrier.Reader qualified as FE+import Control.Carrier.State.Strict qualified as FE+#endif++-- mtl+#ifdef VERSION_mtl+import Control.Monad.State qualified as M+import Control.Monad.Reader qualified as M+#endif++-- polysemy+#ifdef VERSION_polysemy+import Polysemy qualified as P+import Polysemy.Reader qualified as P+import Polysemy.State qualified as P+#endif++-- heftia+import Control.Monad.Hefty qualified as H+import Control.Monad.Hefty.Reader qualified as H+import Control.Monad.Hefty.State qualified as H++tryGetFileSize :: FilePath -> IO (Maybe Int)+tryGetFileSize path =+ try @IOException (getFileStatus path) >>= \case+ Left _ -> pure Nothing+ Right stat -> pure . Just . fromIntegral $ fileSize stat++----------------------------------------+-- reference++ref_calculateFileSize :: IORef [Text] -> FilePath -> IO Int+ref_calculateFileSize logs path = do+ logToIORef logs $ "Calculating the size of " ++ path+ tryGetFileSize path >>= \case+ Nothing -> 0 <$ logToIORef logs ("Could not calculate the size of " ++ path)+ Just size -> size <$ logToIORef logs (path ++ " is " ++ show size ++ " bytes")+ where+ logToIORef :: IORef [Text] -> String -> IO ()+ logToIORef r msgS = do+ let msg = T.pack msgS+ msg `seq` modifyIORef' r (msg :)+{-# NOINLINE ref_calculateFileSize #-}++ref_program :: IORef [Text] -> [FilePath] -> IO Int+ref_program logs files = do+ sizes <- traverse (ref_calculateFileSize logs) files+ pure $ sum sizes+{-# NOINLINE ref_program #-}++ref_calculateFileSizes :: [FilePath] -> IO (Int, [Text])+ref_calculateFileSizes files = do+ logs <- newIORef []+ size <- ref_program logs files+ finalLogs <- readIORef logs+ pure (size, finalLogs)++----------------------------------------+-- heftia++data Heftia_File :: H.Effect where+ Heftia_tryFileSize :: FilePath -> Heftia_File f (Maybe Int)+H.makeEffectF ''Heftia_File++heftia_runFile :: (H.Emb IO H.:> es) => H.Eff (Heftia_File : es) a -> H.Eff es a+heftia_runFile = H.interpret \case+ Heftia_tryFileSize path -> liftIO $ tryGetFileSize path++data Heftia_Logging :: H.Effect where+ Heftia_logMsg :: !Text -> Heftia_Logging f ()+H.makeEffectF ''Heftia_Logging++heftia_runLogging :: (H.FOEs es) => H.Eff (Heftia_Logging : es) a -> H.Eff es ([Text], a)+heftia_runLogging =+ H.runState [] . H.reinterpret \case+ Heftia_logMsg msg -> H.modify (msg :)++----------++heftia_calculateFileSize+ :: (Heftia_File H.:> es, Heftia_Logging H.:> es)+ => FilePath+ -> H.Eff es Int+heftia_calculateFileSize path = do+ heftia_logMsg $ T.pack $ "Calculating the size of " ++ path+ heftia_tryFileSize path >>= \case+ Nothing -> 0 <$ heftia_logMsg (T.pack $ "Could not calculate the size of " ++ path)+ Just size -> size <$ heftia_logMsg (T.pack $ path ++ " is " ++ show size ++ " bytes")+{-# NOINLINE heftia_calculateFileSize #-}++heftia_program+ :: (Heftia_File H.:> es, Heftia_Logging H.:> es)+ => [FilePath]+ -> H.Eff es Int+heftia_program files = do+ sizes <- traverse heftia_calculateFileSize files+ pure $ sum sizes+{-# NOINLINE heftia_program #-}++heftia_calculateFileSizes :: [FilePath] -> IO ([Text], Int)+heftia_calculateFileSizes =+ H.runEff . heftia_runFile . heftia_runLogging . heftia_program++heftia_calculateFileSizesDeep :: [FilePath] -> IO ([Text], Int)+heftia_calculateFileSizesDeep =+ H.runEff+ . runR+ . runR+ . runR+ . runR+ . runR+ . heftia_runFile+ . heftia_runLogging+ . runR+ . runR+ . runR+ . runR+ . runR+ . heftia_program+ where+ runR = H.runAsk ()++----------------------------------------+-- effectful++data Effectful_File :: E.Effect where+ Effectful_tryFileSize :: FilePath -> Effectful_File m (Maybe Int)++type instance E.DispatchOf Effectful_File = 'E.Dynamic++effectful_tryFileSize :: (Effectful_File E.:> es) => FilePath -> E.Eff es (Maybe Int)+effectful_tryFileSize = E.send . Effectful_tryFileSize++effectful_runFile :: (E.IOE E.:> es) => E.Eff (Effectful_File : es) a -> E.Eff es a+effectful_runFile = E.interpret_ \case+ Effectful_tryFileSize path -> liftIO $ tryGetFileSize path++data Effectful_Logging :: E.Effect where+ Effectful_logMsg :: !Text -> Effectful_Logging m ()++type instance E.DispatchOf Effectful_Logging = 'E.Dynamic++effectful_logMsg :: (Effectful_Logging E.:> es) => String -> E.Eff es ()+effectful_logMsg = E.send . Effectful_logMsg . T.pack++effectful_runLogging+ :: E.Eff (Effectful_Logging : es) a+ -> E.Eff es (a, [Text])+effectful_runLogging = E.reinterpret_ (E.runState []) \case+ Effectful_logMsg msg -> E.modify (msg :)++----------++effectful_calculateFileSize+ :: (Effectful_File E.:> es, Effectful_Logging E.:> es)+ => FilePath+ -> E.Eff es Int+effectful_calculateFileSize path = do+ effectful_logMsg $ "Calculating the size of " ++ path+ effectful_tryFileSize path >>= \case+ Nothing -> 0 <$ effectful_logMsg ("Could not calculate the size of " ++ path)+ Just size -> size <$ effectful_logMsg (path ++ " is " ++ show size ++ " bytes")+{-# NOINLINE effectful_calculateFileSize #-}++effectful_program+ :: (Effectful_File E.:> es, Effectful_Logging E.:> es)+ => [FilePath]+ -> E.Eff es Int+effectful_program files = do+ sizes <- traverse effectful_calculateFileSize files+ pure $ sum sizes+{-# NOINLINE effectful_program #-}++effectful_calculateFileSizes :: [FilePath] -> IO (Int, [Text])+effectful_calculateFileSizes =+ E.runEff . effectful_runFile . effectful_runLogging . effectful_program++effectful_calculateFileSizesDeep :: [FilePath] -> IO (Int, [Text])+effectful_calculateFileSizesDeep =+ E.runEff+ . runR+ . runR+ . runR+ . runR+ . runR+ . effectful_runFile+ . effectful_runLogging+ . runR+ . runR+ . runR+ . runR+ . runR+ . effectful_program+ where+ runR = E.runReader ()++----------------------------------------+-- eff++#ifdef VERSION_eff++data Eff_File :: L.Effect where+ Eff_tryFileSize :: FilePath -> Eff_File m (Maybe Int)++eff_tryFileSize :: Eff_File L.:< es => FilePath -> L.Eff es (Maybe Int)+eff_tryFileSize = L.send . Eff_tryFileSize++eff_runFile :: L.IOE L.:< es => L.Eff (Eff_File : es) a -> L.Eff es a+eff_runFile = L.interpret \case+ Eff_tryFileSize path -> liftIO $ tryGetFileSize path++data Eff_Logging :: L.Effect where+ Eff_logMsg :: !Text -> Eff_Logging m ()++eff_logMsg :: Eff_Logging L.:< es => String -> L.Eff es ()+eff_logMsg = L.send . Eff_logMsg . T.pack++eff_runLogging+ :: L.Eff (Eff_Logging : es) a+ -> L.Eff es ([Text], a)+eff_runLogging+ = L.runState [] . L.interpret \case+ Eff_logMsg msg -> L.modify (msg :)+ . L.lift++----------++eff_calculateFileSize+ :: (Eff_File L.:< es, Eff_Logging L.:< es)+ => FilePath+ -> L.Eff es Int+eff_calculateFileSize path = do+ eff_logMsg $ "Calculating the size of " ++ path+ eff_tryFileSize path >>= \case+ Nothing -> 0 <$ eff_logMsg ("Could not calculate the size of " ++ path)+ Just size -> size <$ eff_logMsg (path ++ " is " ++ show size ++ " bytes")+{-# NOINLINE eff_calculateFileSize #-}++eff_program+ :: (Eff_File L.:< es, Eff_Logging L.:< es)+ => [FilePath]+ -> L.Eff es Int+eff_program files = do+ sizes <- traverse eff_calculateFileSize files+ pure $ sum sizes+{-# NOINLINE eff_program #-}++eff_calculateFileSizes :: [FilePath] -> IO ([Text], Int)+eff_calculateFileSizes =+ L.runIO . eff_runFile . eff_runLogging . eff_program++eff_calculateFileSizesDeep :: [FilePath] -> IO ([Text], Int)+eff_calculateFileSizesDeep = L.runIO+ . runR . runR . runR . runR . runR+ . eff_runFile . eff_runLogging+ . runR . runR . runR . runR . runR+ . eff_program+ where+ runR = L.runReader ()++#endif++----------------------------------------+-- cleff++#ifdef VERSION_cleff++data Cleff_File :: C.Effect where+ Cleff_tryFileSize :: FilePath -> Cleff_File m (Maybe Int)++cleff_tryFileSize :: Cleff_File C.:> es => FilePath -> C.Eff es (Maybe Int)+cleff_tryFileSize = C.send . Cleff_tryFileSize++cleff_runFile :: C.IOE C.:> es => C.Eff (Cleff_File : es) a -> C.Eff es a+cleff_runFile = C.interpret \case+ Cleff_tryFileSize path -> liftIO $ tryGetFileSize path++data Cleff_Logging :: C.Effect where+ Cleff_logMsg :: !Text -> Cleff_Logging m ()++cleff_logMsg :: Cleff_Logging C.:> es => String -> C.Eff es ()+cleff_logMsg = C.send . Cleff_logMsg . T.pack++cleff_runLogging+ :: C.Eff (Cleff_Logging : es) a+ -> C.Eff es (a, [Text])+cleff_runLogging = C.runState [] . C.reinterpret \case+ Cleff_logMsg msg -> C.modify (msg :)++----------++cleff_calculateFileSize+ :: (Cleff_File C.:> es, Cleff_Logging C.:> es)+ => FilePath+ -> C.Eff es Int+cleff_calculateFileSize path = do+ cleff_logMsg $ "Calculating the size of " ++ path+ cleff_tryFileSize path >>= \case+ Nothing -> 0 <$ cleff_logMsg ("Could not calculate the size of " ++ path)+ Just size -> size <$ cleff_logMsg (path ++ " is " ++ show size ++ " bytes")+{-# NOINLINE cleff_calculateFileSize #-}++cleff_program+ :: (Cleff_File C.:> es, Cleff_Logging C.:> es)+ => [FilePath]+ -> C.Eff es Int+cleff_program files = do+ sizes <- traverse cleff_calculateFileSize files+ pure $ sum sizes+{-# NOINLINE cleff_program #-}++cleff_calculateFileSizes :: [FilePath] -> IO (Int, [Text])+cleff_calculateFileSizes =+ C.runIOE . cleff_runFile . cleff_runLogging . cleff_program++cleff_calculateFileSizesDeep :: [FilePath] -> IO (Int, [Text])+cleff_calculateFileSizesDeep = C.runIOE+ . runR . runR . runR . runR . runR+ . cleff_runFile . cleff_runLogging+ . runR . runR . runR . runR . runR+ . cleff_program+ where+ runR = C.runReader ()++#endif++----------------------------------------+-- freer-simple++#ifdef VERSION_freer_simple++data FS_File r where+ FS_tryFileSize :: FilePath -> FS_File (Maybe Int)++fs_tryFileSize :: FS.Member FS_File es => FilePath -> FS.Eff es (Maybe Int)+fs_tryFileSize = FS.send . FS_tryFileSize++fs_runFile :: FS.LastMember IO es => FS.Eff (FS_File : es) a -> FS.Eff es a+fs_runFile = FS.interpret \case+ FS_tryFileSize path -> liftIO $ tryGetFileSize path++data FS_Logging r where+ FS_logMsg :: !Text -> FS_Logging ()++fs_logMsg :: FS.Member FS_Logging es => String -> FS.Eff es ()+fs_logMsg = FS.send . FS_logMsg . T.pack++fs_runLogging+ :: FS.Eff (FS_Logging : es) a+ -> FS.Eff es (a, [Text])+fs_runLogging = FS.runState [] . FS.reinterpret \case+ FS_logMsg msg -> FS.modify (msg :)++----------++fs_calculateFileSize+ :: (FS.Member FS_File es, FS.Member FS_Logging es)+ => FilePath+ -> FS.Eff es Int+fs_calculateFileSize path = do+ fs_logMsg $ "Calculating the size of " ++ path+ fs_tryFileSize path >>= \case+ Nothing -> 0 <$ fs_logMsg ("Could not calculate the size of " ++ path)+ Just size -> size <$ fs_logMsg (path ++ " is " ++ show size ++ " bytes")+{-# NOINLINE fs_calculateFileSize #-}++fs_program+ :: (FS.Member FS_File es, FS.Member FS_Logging es)+ => [FilePath]+ -> FS.Eff es Int+fs_program files = do+ sizes <- traverse fs_calculateFileSize files+ pure $ sum sizes+{-# NOINLINE fs_program #-}++fs_calculateFileSizes :: [FilePath] -> IO (Int, [Text])+fs_calculateFileSizes =+ FS.runM . fs_runFile . fs_runLogging . fs_program++fs_calculateFileSizesDeep :: [FilePath] -> IO (Int, [Text])+fs_calculateFileSizesDeep = FS.runM+ . runR . runR . runR . runR . runR+ . fs_runFile . fs_runLogging+ . runR . runR . runR . runR . runR+ . fs_program+ where+ runR = FS.runReader ()++#endif++----------------------------------------+-- fused-effects++#ifdef VERSION_fused_effects++data FE_File :: E.Effect where+ FE_tryFileSize :: FilePath -> FE_File m (Maybe Int)++fe_tryFileSize :: FE.Has FE_File sig m => FilePath -> m (Maybe Int)+fe_tryFileSize = FE.send . FE_tryFileSize++newtype FE_FileC m a = FE_FileC { fe_runFileC :: m a }+ deriving newtype (Applicative, Functor, Monad, MonadIO)++instance+ ( MonadIO m+ , FE.Algebra sig m+ ) => FE.Algebra (FE_File FE.:+: sig) (FE_FileC m) where+ alg hdl sig ctx = case sig of+ FE.L (FE_tryFileSize path) -> (<$ ctx) <$> liftIO (tryGetFileSize path)+ FE.R other -> FE_FileC $ FE.alg (fe_runFileC . hdl) other ctx++data FE_Logging :: E.Effect where+ FE_logMsg :: !Text -> FE_Logging m ()++fe_logMsg :: FE.Has FE_Logging sig m => String -> m ()+fe_logMsg = FE.send . FE_logMsg . T.pack++newtype FE_LoggingC m a = FE_LoggingC { fe_runLoggingC :: FE.StateC [Text] m a }+ deriving newtype (Applicative, Functor, Monad)++instance+ ( FE.Algebra sig m+ ) => FE.Algebra (FE_Logging FE.:+: sig) (FE_LoggingC m) where+ alg hdl sig ctx = case sig of+ FE.L (FE_logMsg msg) -> FE_LoggingC $ ctx <$ FE.modify (msg :)+ FE.R other -> FE_LoggingC $ FE.alg (fe_runLoggingC . hdl) (FE.R other) ctx++fe_runLogging :: FE_LoggingC m a -> m ([Text], a)+fe_runLogging = FE.runState [] . fe_runLoggingC++----------++fe_calculateFileSize+ :: (FE.Member FE_File sig, FE.Member FE_Logging sig, FE.Algebra sig m)+ => FilePath+ -> m Int+fe_calculateFileSize path = do+ fe_logMsg $ "Calculating the size of " ++ path+ fe_tryFileSize path >>= \case+ Nothing -> 0 <$ fe_logMsg ("Could not calculate the size of " ++ path)+ Just size -> size <$ fe_logMsg (path ++ " is " ++ show size ++ " bytes")+{-# NOINLINE fe_calculateFileSize #-}++fe_program+ :: (FE.Member FE_File sig, FE.Member FE_Logging sig, FE.Algebra sig m)+ => [FilePath]+ -> m Int+fe_program files = do+ sizes <- traverse fe_calculateFileSize files+ pure $ sum sizes+{-# NOINLINE fe_program #-}++fe_calculateFileSizes :: [FilePath] -> IO ([Text], Int)+fe_calculateFileSizes = fe_runFileC . fe_runLogging . fe_program++fe_calculateFileSizesDeep :: [FilePath] -> IO ([Text], Int)+fe_calculateFileSizesDeep+ = runR . runR . runR . runR . runR+ . fe_runFileC . fe_runLogging+ . runR . runR . runR . runR . runR+ . fe_program+ where+ runR = FE.runReader ()++#endif++----------------------------------------+-- mtl++#ifdef VERSION_mtl++class Monad m => MonadFile m where+ mtl_tryFileSize :: FilePath -> m (Maybe Int)++newtype FileT m a = FileT { runFileT :: m a }+ deriving newtype (Functor, Applicative, Monad, MonadIO)++instance M.MonadTrans FileT where+ lift = FileT++instance {-# OVERLAPPABLE #-}+ ( MonadFile m+ , Monad (t m)+ , M.MonadTrans t+ ) => MonadFile (t m) where+ mtl_tryFileSize = M.lift . mtl_tryFileSize++instance MonadIO m => MonadFile (FileT m) where+ mtl_tryFileSize path = liftIO $ tryGetFileSize path++class Monad m => MonadLog m where+ mtl_logMsg :: String -> m ()++newtype LoggingT m a = LoggingT (M.StateT [Text] m a)+ deriving newtype (Functor, Applicative, Monad, MonadIO, M.MonadTrans)++instance {-# OVERLAPPABLE #-}+ ( MonadLog m+ , Monad (t m)+ , M.MonadTrans t+ ) => MonadLog (t m) where+ mtl_logMsg = M.lift . mtl_logMsg++instance MonadIO m => MonadLog (LoggingT m) where+ mtl_logMsg msgS = do+ let msg = T.pack msgS+ msg `seq` LoggingT (M.modify (msg :))++runLoggingT :: LoggingT m a -> m (a, [Text])+runLoggingT (LoggingT m) = M.runStateT m []++----------++mtl_calculateFileSize :: (MonadLog m, MonadFile m) => FilePath -> m Int+mtl_calculateFileSize path = do+ mtl_logMsg $ "Calculating the size of " ++ path+ mtl_tryFileSize path >>= \case+ Nothing -> 0 <$ mtl_logMsg ("Could not calculate the size of " ++ path)+ Just size -> size <$ mtl_logMsg (path ++ " is " ++ show size ++ " bytes")+{-# NOINLINE mtl_calculateFileSize #-}++mtl_program :: (MonadLog m, MonadFile m) => [FilePath] -> m Int+mtl_program files = do+ sizes <- traverse mtl_calculateFileSize files+ pure $ sum sizes+{-# NOINLINE mtl_program #-}++mtl_calculateFileSizes :: [FilePath] -> IO (Int, [Text])+mtl_calculateFileSizes = runFileT . runLoggingT . mtl_program++mtl_calculateFileSizesDeep :: [FilePath] -> IO (Int, [Text])+mtl_calculateFileSizesDeep+ = runR . runR . runR . runR . runR+ . runFileT . runLoggingT+ . runR . runR . runR . runR . runR+ . mtl_program+ where+ runR = flip M.runReaderT ()++#endif++----------------------------------------+-- polysemy++#ifdef VERSION_polysemy++data Poly_File :: E.Effect where+ Poly_tryFileSize :: FilePath -> Poly_File m (Maybe Int)++poly_tryFileSize :: P.Member Poly_File es => FilePath -> P.Sem es (Maybe Int)+poly_tryFileSize = P.send . Poly_tryFileSize++poly_runFile :: P.Member (P.Embed IO) es => P.Sem (Poly_File : es) a -> P.Sem es a+poly_runFile = P.interpret \case+ Poly_tryFileSize path -> P.embed $ tryGetFileSize path++data Poly_Logging :: E.Effect where+ Poly_logMsg :: !Text -> Poly_Logging m ()++poly_logMsg :: P.Member Poly_Logging es => String -> P.Sem es ()+poly_logMsg = P.send . Poly_logMsg . T.pack++poly_runLogging :: P.Sem (Poly_Logging : es) a -> P.Sem es ([Text], a)+poly_runLogging = P.runState [] . P.reinterpret \case+ Poly_logMsg msg -> P.modify (msg :)++----------++poly_calculateFileSize+ :: (P.Member Poly_File es, P.Member Poly_Logging es)+ => FilePath+ -> P.Sem es Int+poly_calculateFileSize path = do+ poly_logMsg $ "Calculating the size of " ++ path+ poly_tryFileSize path >>= \case+ Nothing -> 0 <$ poly_logMsg ("Could not calculate the size of " ++ path)+ Just size -> size <$ poly_logMsg (path ++ " is " ++ show size ++ " bytes")+{-# NOINLINE poly_calculateFileSize #-}++poly_program+ :: (P.Member Poly_File es, P.Member Poly_Logging es)+ => [FilePath]+ -> P.Sem es Int+poly_program files = do+ sizes <- traverse poly_calculateFileSize files+ pure $ sum sizes+{-# NOINLINE poly_program #-}++poly_calculateFileSizes :: [FilePath] -> IO ([Text], Int)+poly_calculateFileSizes =+ P.runM . poly_runFile . poly_runLogging . poly_program++poly_calculateFileSizesDeep :: [FilePath] -> IO ([Text], Int)+poly_calculateFileSizesDeep = P.runM+ . runR . runR . runR . runR . runR+ . poly_runFile . poly_runLogging+ . runR . runR . runR . runR . runR+ . poly_program+ where+ runR = P.runReader ()+#endif
+ bench/BenchLocal.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE CPP, PartialTypeSignatures #-}++-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2022 Xy Ren; 2024 Sayo contributors++-- Benchmarking higher-order effects #2: Local environments++module BenchLocal where++import Control.Monad.Effect as ME+import Module.RS as ME+import Data.TypeList.FData as ME++import Control.Carrier.Reader qualified as F+import Control.Monad.Hefty qualified as H+import Data.Effect.Reader qualified as H+import Effectful qualified as EL+import Effectful.Reader.Dynamic qualified as EL+import Polysemy qualified as P+import Polysemy.Reader qualified as P+import "data-effects" Control.Effect.Interpret qualified as HD+#ifdef VERSION_eff+import "eff" Control.Effect qualified as E+#endif++programMonadEffect :: Int -> ME.EffT '[ME.RModule Int] ME.NoError ME.Identity Int+programMonadEffect = \case+ 0 -> ME.askR @Int+ n -> ME.localR @Int (+ 1) (programMonadEffect (n - 1))+{-# NOINLINE programMonadEffect #-}++programMonadEffectDeep :: Int -> ME.EffT+ [ ME.RModule (), ME.RModule (), ME.RModule (), ME.RModule (), ME.RModule ()+ , ME.RModule Int+ , ME.RModule (), ME.RModule (), ME.RModule (), ME.RModule (), ME.RModule ()+ ] ME.NoError Identity Int+programMonadEffectDeep = \case+ 0 -> ME.askR @Int+ n -> ME.localR @Int (+ 1) (programMonadEffectDeep (n - 1))+{-# NOINLINE programMonadEffectDeep #-}++localMonadEffect :: Int -> Int+localMonadEffect n = fst . ME.runIdentity . ME.runEffTNoError+ (FData1 $ RRead (0 :: Int))+ (FData1 RState)+ $ programMonadEffect n++localMonadEffectDeep :: Int -> Int+localMonadEffectDeep n = fst . ME.runIdentity . ME.runEffTNoError+ (FData11 (RRead ()) (RRead ()) (RRead ()) (RRead ()) (RRead ()) + (RRead (0 :: Int))+ (RRead ()) (RRead ()) (RRead ()) (RRead ()) (RRead ())+ )+ (FData11 RState RState RState RState RState+ RState+ RState RState RState RState RState+ )+ $ programMonadEffectDeep n++programHeftia :: (H.Ask Int `H.In` es, H.Local Int `H.In` es) => Int -> H.Eff es Int+programHeftia = \case+ 0 -> H.ask'_+ n -> H.local'_ @Int (+ 1) (programHeftia (n - 1))+{-# NOINLINE programHeftia #-}++localHeftia :: Int -> Int+localHeftia n = HD.runPure $ H.runAsk @Int 0 $ H.runLocal @Int $ programHeftia n++localHeftiaDeep0, localHeftiaDeep1, localHeftiaDeep2, localHeftiaDeep3, localHeftiaDeep4, localHeftiaDeep5 :: Int -> Int+localHeftiaDeep0 n = HD.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runAsk @Int 0 $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runLocal @Int $ programHeftia n+localHeftiaDeep1 n = HD.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runAsk @Int 0 $ hrun $ hrun $ hrun $ hrun $ H.runLocal @Int $ hrun $ programHeftia n+localHeftiaDeep2 n = HD.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runAsk @Int 0 $ hrun $ hrun $ hrun $ H.runLocal @Int $ hrun $ hrun $ programHeftia n+localHeftiaDeep3 n = HD.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runAsk @Int 0 $ hrun $ hrun $ H.runLocal @Int $ hrun $ hrun $ hrun $ programHeftia n+localHeftiaDeep4 n = HD.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runAsk @Int 0 $ hrun $ H.runLocal @Int $ hrun $ hrun $ hrun $ hrun $ programHeftia n+localHeftiaDeep5 n = HD.runPure $ hrun $ hrun $ hrun $ hrun $ hrun $ H.runAsk @Int 0 $ H.runLocal @Int $ hrun $ hrun $ hrun $ hrun $ hrun $ programHeftia n++hrun :: H.Eff (H.Ask () ': es) a -> H.Eff es a+hrun = H.runAsk ()++programSem :: (P.Reader Int `P.Member` es) => Int -> P.Sem es Int+programSem = \case+ 0 -> P.ask+ n -> P.local @Int (+ 1) (programSem (n - 1))+{-# NOINLINE programSem #-}++localSem :: Int -> Int+localSem n = P.run $ P.runReader @Int 0 $ programSem n++localSemDeep :: Int -> Int+localSemDeep n = P.run $ run $ run $ run $ run $ run $ P.runReader @Int 0 $ run $ run $ run $ run $ run $ programSem n+ where+ run = P.runReader ()++programFused :: (F.Has (F.Reader Int) sig m) => Int -> m Int+programFused = \case+ 0 -> F.ask+ n -> F.local @Int (+ 1) (programFused (n - 1))+{-# NOINLINE programFused #-}++localFused :: Int -> Int+localFused n = F.run $ F.runReader @Int 0 $ programFused n++localFusedDeep :: Int -> Int+localFusedDeep n = F.run $ run $ run $ run $ run $ run $ F.runReader @Int 0 $ run $ run $ run $ run $ run $ programFused n+ where+ run = F.runReader ()++programEffectful :: (EL.Reader Int EL.:> es) => Int -> EL.Eff es Int+programEffectful = \case+ 0 -> EL.ask+ n -> EL.local @Int (+ 1) (programEffectful (n - 1))+{-# NOINLINE programEffectful #-}++localEffectful :: Int -> Int+localEffectful n = EL.runPureEff $ EL.runReader @Int 0 $ programEffectful n++localEffectfulDeep :: Int -> Int+localEffectfulDeep n =+ EL.runPureEff $ run $ run $ run $ run $ run $ EL.runReader @Int 0 $ run $ run $ run $ run $ run $ programEffectful n+ where+ run = EL.runReader ()++#ifdef VERSION_eff+programEff :: (E.Reader Int E.:< es) => Int -> E.Eff es Int+programEff = \case+ 0 -> E.ask+ n -> E.local @Int (+ 1) (programEff (n - 1))+{-# NOINLINE programEff #-}++localEff :: Int -> Int+localEff n = E.run $ E.runReader @Int 0 $ programEff n++localEffDeep :: Int -> Int+localEffDeep n = E.run $ run $ run $ run $ run $ run $ E.runReader @Int 0 $ run $ run $ run $ run $ run $ programEff n+ where+ run = E.runReader ()+#endif++{-+The MTL case is disabled because of conflicting functional dependencies.++When using something other than Reader to build up the stack, it is considered+that the performance degradation caused by the pure stack factor cannot be+measured.++programMtl :: (M.MonadReader Int m) => Int -> m Int+programMtl = \case+ 0 -> M.ask+ n -> M.local (+ 1) (programMtl (n - 1))+{-# NOINLINE programMtl #-}++localMtl :: Int -> Int+localMtl n = M.runReader 0 $ programMtl n++localMtlDeep :: Int -> Int+localMtlDeep n = M.runIdentity $ run $ run $ run $ run $ run $ M.runReader 0 $ run $ run $ run $ run $ run $ programMtl n+ where+ run = (`M.runReaderT` ())+-}
+ bench/BenchPyth.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE CPP #-}++-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2022 Xy Ren; 2024 Sayo contributors++-- Benchmarking yield-intensive code++module BenchPyth where++import Control.Algebra qualified as F+import Control.Applicative (Alternative (empty, (<|>)))+import Control.Carrier.NonDet.Church qualified as F+import Control.Carrier.Reader qualified as F+import Control.Monad (MonadPlus)+#ifdef VERSION_freer_simple+import Control.Monad.Freer qualified as FS+import Control.Monad.Freer.NonDet qualified as FS+import Control.Monad.Freer.Reader qualified as FS+#endif+import Control.Monad.Hefty qualified as H+import Control.Monad.Hefty.NonDet qualified as H+import Control.Monad.Hefty.Reader qualified as H+import Control.Monad.Hefty.Shift qualified as H+import Control.Monad.Identity qualified as M+import Control.Monad.Logic qualified as M+import Control.Monad.Reader qualified as M+import Data.List (singleton)+#ifdef VERSION_eff+import "eff" Control.Effect qualified as EF+#endif++#ifdef VERSION_freer_simple+programFreer :: (FS.Member FS.NonDet es) => Int -> FS.Eff es (Int, Int, Int)+programFreer upbound = do+ x <- choice upbound+ y <- choice upbound+ z <- choice upbound+ if x * x + y * y == z * z then return (x, y, z) else empty+ where+ choice 0 = empty+ choice n = choice (n - 1) <|> pure n+{-# NOINLINE programFreer #-}++pythFreer :: Int -> [(Int, Int, Int)]+pythFreer n = FS.run $ FS.makeChoiceA $ programFreer n++pythFreerDeep :: Int -> [(Int, Int, Int)]+pythFreerDeep n = FS.run $ run $ run $ run $ run $ run $ FS.makeChoiceA $ run $ run $ run $ run $ run $ programFreer n+ where+ run = FS.runReader ()+#endif++programHeftia :: (H.Choose H.:> es, H.Empty H.:> es) => Int -> H.Eff es (Int, Int, Int)+programHeftia upbound = do+ x <- choice upbound+ y <- choice upbound+ z <- choice upbound+ if x * x + y * y == z * z then return (x, y, z) else H.empty+ where+ choice :: (H.Choose H.:> es, H.Empty H.:> es) => Int -> H.Eff es Int+ choice 0 = H.empty+ choice n = choice (n - 1) `H.branch` pure n+{-# NOINLINE programHeftia #-}++pythHeftia :: Int -> [(Int, Int, Int)]+pythHeftia n = H.runPure $ H.runNonDet $ programHeftia n++pythHeftiaDeep :: Int -> [(Int, Int, Int)]+pythHeftiaDeep n = H.runPure $ run $ run $ run $ run $ run $ H.runNonDet $ run $ run $ run $ run $ run $ programHeftia n+ where+ run :: H.Eff (H.Ask () ': es) a -> H.Eff es a+ run = H.runAsk ()++pythHeftiaShift :: Int -> [(Int, Int, Int)]+pythHeftiaShift n = H.runPure $ H.evalShift $ H.runNonDetShift $ singleton <$> programHeftia n++pythHeftiaShiftDeep :: Int -> [(Int, Int, Int)]+pythHeftiaShiftDeep n = H.runPure $ H.evalShift $ run $ run $ run $ run $ run $ H.runNonDetShift $ run $ run $ run $ run $ run $ singleton <$> programHeftia n+ where+ run :: H.Eff (H.Ask () ': es) a -> H.Eff es a+ run = H.runAsk ()++programFused :: (Monad m, Alternative m) => Int -> m (Int, Int, Int)+programFused upbound = do+ x <- choice upbound+ y <- choice upbound+ z <- choice upbound+ if x * x + y * y == z * z then return (x, y, z) else empty+ where+ choice x = F.oneOf [1 .. x]+{-# NOINLINE programFused #-}++pythFused :: Int -> [(Int, Int, Int)]+pythFused n = F.run $ F.runNonDetA $ programFused n++pythFusedDeep :: Int -> [(Int, Int, Int)]+pythFusedDeep n = F.run $ run $ run $ run $ run $ run $ F.runNonDetA $ run $ run $ run $ run $ run $ programFused n+ where+ run = F.runReader ()++#ifdef VERSION_eff+programEff :: (EF.NonDet EF.:< es) => Int -> EF.Eff es (Int, Int, Int)+programEff upbound = do+ x <- choice upbound+ y <- choice upbound+ z <- choice upbound+ if x * x + y * y == z * z then return (x, y, z) else empty+ where+ choice 0 = empty+ choice n = choice (n - 1) <|> pure n+{-# NOINLINE programEff #-}++pythEff :: Int -> [(Int, Int, Int)]+pythEff n = EF.run $ EF.runNonDetAll $ programEff n++pythEffDeep :: Int -> [(Int, Int, Int)]+pythEffDeep n = EF.run $ run $ run $ run $ run $ run $ EF.runNonDetAll $ run $ run $ run $ run $ run $ programEff n+ where+ run = EF.runReader ()+#endif++programMtl :: (MonadPlus m) => Int -> m (Int, Int, Int)+programMtl upbound = do+ x <- choice upbound+ y <- choice upbound+ z <- choice upbound+ if x * x + y * y == z * z then return (x, y, z) else empty+ where+ choice 0 = empty+ choice n = choice (n - 1) <|> pure n+{-# NOINLINE programMtl #-}++pythLogict :: Int -> [(Int, Int, Int)]+pythLogict n = M.observeAll $ programMtl n++pythLogictDeep :: Int -> [(Int, Int, Int)]+pythLogictDeep n = M.runIdentity $ runR $ runR $ runR $ runR $ runR $ M.observeAllT $ runR $ runR $ runR $ runR $ runR $ programMtl n+ where+ runR = (`M.runReaderT` ())
+ bench/Main.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE CPP #-}++-- SPDX-License-Identifier: BSD-3-Clause+-- (c) 2022 Xy Ren; 2021-2022, Andrzej Rybcza; 2024 Sayo contributors++module Main where++import BenchCatch+import BenchCoroutine+import BenchCountdown+import BenchLocal+import BenchPyth+import Data.Functor ((<&>))+import Test.Tasty.Bench+import BenchFileSizes++main :: IO ()+main =+ defaultMain+ [ bgroup "countdown.shallow" $+ [10000] <&> \x ->+ bgroup+ (show x)+ [ bench "heftia" $ nf countdownHeftia x+ -- , bench "heftia.naive" $ nf countdownHeftiaNaive x -- no optimization+#ifdef VERSION_freer_simple+ , bench "freer" $ nf countdownFreer x+#endif+ , bench "polyemy" $ nf countdownSem x+ , bench "fused" $ nf countdownFused x+ , bench "effectful" $ nf countdownEffectful x+#ifdef VERSION_eff+ , bench "eff" $ nf countdownEff x+#endif+ , bench "mtl" $ nf countdownMtl x+ , bench "monad-effect" $ nf countdownMonadEffect x+ ]+ , bgroup "countdown.deep" $+ [10000] <&> \x ->+ bgroup+ (show x)+ [ bench "heftia.5+5" $ nf countdownHeftiaDeep x+ -- , bench "heftia.naive.5+5" $ nf countdownHeftiaNaiveDeep x -- no optimization+#ifdef VERSION_freer_simple+ , bench "freer.5+5" $ nf countdownFreerDeep x+#endif+ , bench "polysemy.5+5" $ nf countdownSemDeep x+ , bench "fused.5+5" $ nf countdownFusedDeep x+ , bench "effectful.5+5" $ nf countdownEffectfulDeep x+#ifdef VERSION_eff+ , bench "eff.5+5" $ nf countdownEffDeep x+#endif+ , bench "mtl.5+5" $ nf countdownMtlDeep x+ , bench "monad-effect.5+5" $ nf countdownMonadEffectDeep x+ ]+ , bgroup "catch.shallow" $+ [10000] <&> \x ->+ bgroup+ (show x)+ [ bench "heftia" $ nf catchHeftia x+ , bench "polysemy" $ nf catchSem x+ , bench "fused" $ nf catchFused x+ , bench "effectful" $ nf catchEffectful x+ , -- , bench "eff" $ nf catchEff x+ -- `eff` is x500 slow in this case, so it is excluded because it makes the graph hard to read.+ bench "mtl" $ nf catchMtl x+ , bench "monad-effect" $ nf catchMonadEffect x+ ]+ , bgroup "catch.deep" $+ [10000] <&> \x ->+ bgroup+ (show x)+ [ bench "heftia.5+5+0" $ nf catchHeftiaDeep0 x+ , bench "heftia.5+4+1" $ nf catchHeftiaDeep1 x+ , bench "heftia.5+3+2" $ nf catchHeftiaDeep2 x+ , bench "heftia.5+2+3" $ nf catchHeftiaDeep3 x+ , bench "heftia.5+1+4" $ nf catchHeftiaDeep4 x+ , bench "heftia.5+0+5" $ nf catchHeftiaDeep5 x+ , bench "polysemy.5+5" $ nf catchSemDeep x+ , bench "fused.5+5" $ nf catchFusedDeep x+ , bench "effectful.5+5" $ nf catchEffectfulDeep x+ , -- , bench "eff.5+5" $ nf catchEffDeep x+ bench "mtl.5+5" $ nf catchMtlDeep x+ , bench "monad-effect.10" $ whnf catchMonadEffectDeep x+ ]+ , bgroup "local.shallow" $+ [10000] <&> \x ->+ bgroup+ (show x)+ [ bench "heftia" $ nf localHeftia x+ , bench "polysemy" $ nf localSem x+ , bench "fused" $ nf localFused x+ , bench "effectful" $ nf localEffectful x+ , bench "monad-effect" $ nf localMonadEffect x+ -- , bench "eff" $ nf localEff x+ -- `eff` is x500 slow in this case, so it is excluded because it makes the graph hard to read.+ -- bench "mtl" $ nf localMtl x+ ]+ , bgroup "local.deep" $+ [10000] <&> \x ->+ bgroup+ (show x)+ [ bench "heftia.5+5+0" $ nf localHeftiaDeep0 x+ , bench "heftia.5+4+1" $ nf localHeftiaDeep1 x+ , bench "heftia.5+3+2" $ nf localHeftiaDeep2 x+ , bench "heftia.5+2+3" $ nf localHeftiaDeep3 x+ , bench "heftia.5+1+4" $ nf localHeftiaDeep4 x+ , bench "heftia.5+0+5" $ nf localHeftiaDeep5 x+ , bench "polysemy.5+5" $ nf localSemDeep x+ , bench "fused.5+5" $ nf localFusedDeep x+ , bench "effectful.5+5" $ nf localEffectfulDeep x+ -- bench "eff.5+5" $ nf localEffDeep x+ -- bench "mtl.5+5" $ nf localMtlDeep x+ , bench "monad-effect.5+5" $ nf localMonadEffectDeep x+ ]+ , bgroup "nondet.shallow" $+ [32] <&> \x ->+ bgroup+ (show x)+ [ bench "heftia" $ nf pythHeftia x+ -- , bench "heftia.shift" $ nf pythHeftiaShift x -- tricky, slow method+#ifdef VERSION_freer_simple+ , bench "freer" $ nf pythFreer x+#endif+ , bench "fused" $ nf pythFused x+#ifdef VERSION_eff+ , bench "eff" $ nf pythEff x+#endif+ , bench "mtl-logict" $ nf pythLogict x+ ] -- Polysemy case is excluded because of incorrect semantics.+ , bgroup "nondet.deep" $+ [32] <&> \x ->+ bgroup+ (show x)+ [ bench "heftia.5+5" $ nf pythHeftiaDeep x+ , bench "heftia.shift.5+5" $ nf pythHeftiaShiftDeep x -- tricky, slow method+#ifdef VERSION_freer_simple+ , bench "freer.5+5" $ nf pythFreerDeep x+#endif+ , bench "fused.5+5" $ nf pythFusedDeep x+#ifdef VERSION_eff+ , bench "eff.5+5" $ nf pythEffDeep x+#endif+ , bench "mtl-logict.5+5" $ nf pythLogictDeep x+ ]+ , bgroup "coroutine.shallow" $+ [1000] <&> \x ->+ bgroup+ (show x)+ [ bench "heftia" $ nf coroutineHeftia x+#ifdef VERSION_freer_simple+ , bench "freer" $ nf coroutineFreer x+#endif+#ifdef VERSION_eff+ , bench "eff" $ nf coroutineEff x+#endif+ -- `eff` is O(n^2) slow probably because of: https://dl.acm.org/doi/10.1145/2633357.2633360+ ] -- add mtl?+ , bgroup "coroutine.deep" $+ [1000] <&> \x ->+ bgroup+ (show x)+ [ bench "heftia.5+5" $ nf coroutineHeftiaDeep x+#ifdef VERSION_freer_simple+ , bench "freer.5+5" $ nf coroutineFreerDeep x+#endif+#ifdef VERSION_eff+ , bench "eff.5+5" $ nf coroutineEffDeep x+#endif+ ]+ , bgroup "filesize.shallow" $ map filesizeShallow [1000, 2000, 3000]+ , bgroup "filesize.deep" $ map filesizeDeep [1000, 2000, 3000]+ ]++filesizeShallow :: Int -> Benchmark+filesizeShallow n = bgroup (show n)+ [ bench "reference" $ nfAppIO ref_calculateFileSizes (take n files)+ , bench "heftia" $ nfAppIO heftia_calculateFileSizes (take n files)+ , bench "effectful" $ nfAppIO effectful_calculateFileSizes (take n files)+#ifdef VERSION_cleff+ , bench "cleff" $ nfAppIO cleff_calculateFileSizes (take n files)+#endif+#ifdef VERSION_freer_simple+ , bench "freer-simple" $ nfAppIO fs_calculateFileSizes (take n files)+#endif+#ifdef VERSION_eff+ , bench "eff" $ nfAppIO eff_calculateFileSizes (take n files)+#endif+#ifdef VERSION_mtl+ , bench "mtl" $ nfAppIO mtl_calculateFileSizes (take n files)+#endif+#ifdef VERSION_fused_effects+ , bench "fused-effects" $ nfAppIO fe_calculateFileSizes (take n files)+#endif+#ifdef VERSION_polysemy+ , bench "polysemy" $ nfAppIO poly_calculateFileSizes (take n files)+#endif+ ]+ where+ files :: [FilePath]+ files = repeat "heftia-effects.cabal"++filesizeDeep :: Int -> Benchmark+filesizeDeep n = bgroup (show n)+ [ bench "reference" $ nfAppIO ref_calculateFileSizes (take n files)+ , bench "heftia" $ nfAppIO heftia_calculateFileSizesDeep (take n files)+ , bench "effectful" $ nfAppIO effectful_calculateFileSizesDeep (take n files)+#ifdef VERSION_cleff+ , bench "cleff" $ nfAppIO cleff_calculateFileSizesDeep (take n files)+#endif+#ifdef VERSION_freer_simple+ , bench "freer-simple" $ nfAppIO fs_calculateFileSizesDeep (take n files)+#endif+#ifdef VERSION_eff+ , bench "eff" $ nfAppIO eff_calculateFileSizesDeep (take n files)+#endif+#ifdef VERSION_mtl+ , bench "mtl" $ nfAppIO mtl_calculateFileSizesDeep (take n files)+#endif+#ifdef VERSION_fused_effects+ , bench "fused-effects" $ nfAppIO fe_calculateFileSizesDeep (take n files)+#endif+#ifdef VERSION_polysemy+ , bench "polysemy" $ nfAppIO poly_calculateFileSizesDeep (take n files)+#endif+ ]+ where+ files :: [FilePath]+ files = repeat "heftia-effects.cabal"
+ monad-effect.cabal view
@@ -0,0 +1,245 @@+cabal-version: 2.4+-- The name of the package.+name: monad-effect++-- The package version.+-- https://pvp.haskell.org+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: A fast and lightweight effect system.++-- A longer description of the package.+description:+ A fast and lightweight effect system.+ It provides a way to define and handle effects and exceptions in a modular and composable way.+ Main features: moduled effects, algebraic exceptions, pure states, and good performance.++-- The license under which the package is released.+license: BSD-3-Clause++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Eiko++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer: eikochanowo@outlook.com++-- A copyright notice.+-- copyright:+category: Control, Monads, Effect+build-type: Simple++-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files: CHANGELOG.md+ , README.md++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:++source-repository head+ type: git+ location: https://github.com/Eiko-Tokura/monad-effect.git++flag benchO0+ description: Compile benchmarks with -O0+ default: False+ manual: True+flag benchO1+ description: Compile benchmarks with -O1+ default: False+ manual: True+flag benchO2+ description: Compile benchmarks with -O2+ default: False+ manual: True+flag noinline+ description: Disable inlining for Countdown benchmark+ default: False+ manual: True++common warnings+ ghc-options: -Wall++library+ -- Import common warning flags.+ import: warnings++ -- | This is a small library that gets benefit from inlining and specialisation.+ -- therefore we turn on these optimisations+ ghc-options: -O2 -fexpose-all-unfoldings -fspecialise-aggressively -flate-dmd-anal++ -- Modules exported by the library.+ exposed-modules: Control.Monad.Effect+ , Control.System+ , Control.System.EventLoop+ , Data.Result+ , Data.TypeList+ , Data.TypeList.FData+ , Data.TypeList.FData.TH+ , Data.TypeList.Families+ , Module.RS+ , Module.RS.QQ+ , Module.Resource+ , Control.Monad.RS.Class++ -- , Control.Monad.Effect.Concurrent+ -- Modules included in this library but not exported.+ other-modules: Data.TypeList.ConsFData+ , Data.TypeList.ConsFData.Pattern+ , Data.TypeList.FList+ , Data.TypeList.UList+ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- Other library packages from which modules are imported.+ build-depends: base >= 4 && < 5+ , async < 2.4+ , data-default >= 0.8.0 && < 0.9+ , mtl < 2.4+ , stm < 2.6+ , text < 2.2+ , exceptions < 0.11+ , monad-control >= 1.0.3 && < 1.1+ , resourcet >= 1.3.0 && < 1.4+ , transformers-base >= 0.4.6 && < 0.5+ , template-haskell < 2.24+ , deepseq < 1.6+ , parsec >=3 && < 4+ , haskell-src-meta >= 0.8 && < 0.9++ -- Directories containing source files.+ hs-source-dirs: src++ -- Base language which the package is written in.+ default-language: GHC2021++ default-extensions: OverloadedStrings+ , DerivingStrategies+ , DeriveAnyClass+ , DerivingVia+ , DataKinds+ , GADTs+ , LambdaCase+ , LinearTypes+ , TypeFamilies+ , TypeApplications+ , TemplateHaskell+test-suite monad-effect-test+ -- Import common warning flags.+ import: warnings++ ghc-options: -flate-dmd-anal+ -- -ddump-simpl -ddump-to-file -dsuppress-all -ddump-splices++ -- Base language which the package is written in.+ default-language: GHC2021++ -- Modules included in this executable, other than Main.+ other-modules: Examples+ TH++ -- LANGUAGE extensions used by modules in this package.+ default-extensions: OverloadedStrings+ , DerivingStrategies+ , DerivingVia+ , DataKinds+ , GADTs+ , LambdaCase+ , TypeFamilies+ , TypeApplications+ , TemplateHaskell+ , QuasiQuotes++ -- The interface type and version of the test suite.+ type: exitcode-stdio-1.0++ -- Directories containing source files.+ hs-source-dirs: test++ -- The entrypoint to the test suite.+ main-is: Main.hs++ -- Test dependencies.+ build-depends:+ base >= 4 && < 5+ , monad-effect+ , criterion+ , containers+ , text+ , mtl+ , parsec++benchmark monad-effect-bench+ -- Import common warning flags.+ import: warnings++ ghc-options: -fconstraint-solver-iterations=16+ -- -ddump-simpl -ddump-to-file -dsuppress-all ++ if flag(benchO2)+ ghc-options: -O2 -flate-dmd-anal -fmax-worker-args=16+ if flag(benchO1)+ ghc-options: -fmax-worker-args=16+ if flag(benchO0)+ ghc-options: -O0 -fmax-worker-args=16+ if flag(noinline)+ cpp-options: -DNOINLINE++ -- Base language which the package is written in.+ default-language: GHC2021++ -- LANGUAGE extensions used by modules in this package.+ default-extensions: OverloadedStrings+ , DerivingStrategies+ , DerivingVia+ , DataKinds+ , GADTs+ , LambdaCase+ , TypeFamilies+ , TypeApplications+ , TemplateHaskell+ , PackageImports+ , BlockArguments++ -- The interface type and version of the benchmark suite.+ type: exitcode-stdio-1.0++ -- Directories containing source files.+ hs-source-dirs: bench++ -- The entrypoint to the benchmark suite.+ main-is: Main.hs+++ build-depends: heftia-effects+ , polysemy ^>= 1.9+ , fused-effects ^>= 1.1+ , effectful >= 2.3 && < 2.6+ , mtl >= 2.2 && < 2.4+ , logict >= 0.7.0.3 && < 0.9+ , tasty-bench >= 0.3 && < 0.5+ , unix+ , monad-effect+ , base+ , text+ , data-effects++ if impl(ghc >= 9.6) && impl(ghc < 9.10)+ build-depends: eff++ if impl(ghc < 9.10)+ build-depends: freer-simple ^>= 1.2++ other-modules:+ BenchCountdown+ BenchCatch+ BenchLocal+ BenchCoroutine+ BenchPyth+ BenchFileSizes
+ src/Control/Monad/Effect.hs view
@@ -0,0 +1,719 @@+{-# LANGUAGE DerivingVia, AllowAmbiguousTypes, UndecidableInstances, PatternSynonyms, LinearTypes #-}+-- | Module: Control.Monad.Effect+-- Description: The module you should import to use for effectful computation+--+-- This module provides the EffT monad transformer and various functions to work with it.+module Control.Monad.Effect+ ( -- * EffTectful computation+ EffT', Eff, Pure, EffT, EffL, PureL, EffLT+ , ErrorText(..), errorText, ErrorValue(..), errorValue, MonadThrowError(..)+ , embedEffT, embedMods, embedError+ , runEffT, runEffT_, runEffT0, runEffT01, runEffT00+ , runEffTNoError+ , runEffTOuter, runEffTOuter', runEffTOuter_+ , runEffTIn, runEffTIn', runEffTIn_+ , effCatch, effCatchAll, effCatchSystem+ , effCatchIn, effCatchIn'+ , effThrow, effThrowIn+ , effTryIO, effTryIOIn, effTryIOWith, effTryIOInWith+ , effEither, effEitherWith+ , effEitherIn, effEitherInWith+ , effMaybeWith, effMaybeInWith+ , pureMaybeInWith, pureEitherInWith+ , baseEitherIn, baseEitherInWith, baseMaybeInWith+ , errorToEither, errorToEitherAll, eitherAllToEffect+ , liftIOException, liftIOAt, liftIOSafeWith, liftIOText, liftIOPrepend+ , effEitherSystemException++ -- * Concurrency+ , forkEffT, forkEffTSafe, asyncEffT++ -- * No Error+ , declareNoError+ , checkNoError+ , NoError++ -- * Modules+ , Module(..), SystemModule(..)+ , queryModule, queriesModule, askModule, asksModule+ , localModule+ , getModule, getsModule+ , putModule, modifyModule++ -- * System types+ , SystemState, SystemRead, SystemEvent, SystemInitData+ , SystemError(..)++ -- * Re-exports+ , MonadIO(..)+ , ConsFDataList, FList, FData+ , Identity(..)+ , InList, In'+ , In, InL+ , module Data.TypeList.ConsFData.Pattern+ , fNil+ -- * Result types+ , Result(..), EList(..)+ ) where++-- import Control.Parallel.Strategies+import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception as E hiding (TypeError)+import Control.Monad+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.RS.Class+import Control.Monad.Trans+import Control.Monad.Trans.Control+import Data.Bifunctor+import Data.Functor.Identity+import Data.Kind+import Data.Proxy+import Data.String (IsString)+import Data.Text (Text, unpack, pack)+import Data.Type.Equality+import Data.TypeList+import Data.TypeList.ConsFData.Pattern+import Data.TypeList.FData+import GHC.TypeError+import GHC.TypeLits++-- | EffTectful computation, using modules as units of effect+-- the tick is used to indicate the polymorphic type c which is the data structure used to store the modules.+--+-- The idea is that most user should just use EffT or Eff by default, and does not need this polymorphic type c.+newtype EffT' (c :: (Type -> Type) -> [Type] -> Type) (mods :: [Type]) (es :: [Type]) m a+ = EffT' { unEffT' :: SystemRead c mods -> SystemState c mods -> m (Result es a, SystemState c mods) }++-- | Short hand monads, recommended, uses FData under the hood+type Eff mods es = EffT' FData mods es IO+type EffT mods es = EffT' FData mods es+type Pure mods es = EffT' FData mods es Identity+type In mods es = In' FData mods es++-- | Short hand monads which uses FList instead of FData as the data structure+type EffL mods es = EffT' FList mods es IO+type EffLT mods es = EffT' FList mods es+type PureL mods es = EffT' FList mods es Identity+type InL mods es = In' FList mods es++-- | A constraint that checks the error list is empty in EffT+type family MonadNoError m :: Constraint where+ MonadNoError (EffT' c mods NoError m) = ()+ MonadNoError (EffT' c mods es m) = TypeError ('Text "MonadNoError: the effect has error, catch them")+ MonadNoError _ = TypeError ('Text "MonadNoError: not an EffT' type")++-- | identity function that checks a MonadNoError constraint+checkNoError :: MonadNoError m => m a -> m a+checkNoError = id+{-# INLINE checkNoError #-}++-- | a newtype wrapper ErrorText that wraps a Text with a name (for example Symbol type)+-- useful for creating ad-hoc error type+--+-- @+-- ErrorText @_ @"FileNotFound" "information : file not found"+-- @+newtype ErrorText (s :: k) = ErrorText Text+ deriving newtype (IsString)++-- | Can be used to construct an ErrorText value, use type application to give the name+--+-- @+-- errorText @"FileNotFound" "file not found"+-- @+errorText :: forall s. Text -> ErrorText s+errorText = ErrorText+{-# INLINE errorText #-}++-- | a newtype wrapper ErrorValue that wraps a custom value type v with a name (for example Symbol type)+-- useful for creating ad-hoc error type+newtype ErrorValue (a :: k) (v :: Type) = ErrorValue v++-- | Can be used to construct an ErrorValue value, use type application to give the name+errorValue :: forall s v. v -> ErrorValue s v+errorValue = ErrorValue+{-# INLINE errorValue #-}++-- | A wrapper dedicated for errors living in MonadThrow and MonadCatch+newtype MonadThrowError = MonadThrowError SomeException+ deriving Show++instance KnownSymbol s => Show (ErrorText s) where+ show (ErrorText t) = "ErrorText of type " ++ symbolVal (Proxy @s) ++ ": " ++ unpack t++instance (KnownSymbol s, Show v) => Show (ErrorValue s v) where+ show (ErrorValue v) = "ErrorValue of type " <> symbolVal (Proxy @s) <> ": " <> show v++instance Functor m => Functor (EffT' c mods es m) where+ fmap f (EffT' eff) = EffT' $ \rs ss -> first (fmap f) <$> eff rs ss+ {-# INLINE fmap #-}++instance Monad m => Applicative (EffT' c mods es m) where+ pure a = EffT' $ \_ ss -> pure (RSuccess a, ss)+ {-# INLINE pure #-}++ EffT' effF <*> EffT' effA = EffT' $ \rs ss -> do+ (eF, ss1) <- effF rs ss+ case eF of+ RSuccess f -> do+ (eA, ss2) <- effA rs ss1+ case eA of+ RSuccess a -> return (RSuccess (f a), ss2)+ RFailure es -> return (RFailure es, ss2)+ RFailure es -> return (RFailure es, ss1)+ {-# INLINE (<*>) #-}++instance Monad m => Monad (EffT' c mods es m) where+ EffT' eff >>= f = EffT' $ \rs ss -> do+ (eResult, ss1) <- eff rs ss+ case eResult of+ RSuccess a -> unEffT' (f a) rs ss1+ RFailure es -> return (RFailure es, ss1)+ {-# INLINE (>>=) #-}++instance MonadIO m => MonadIO (EffT' c mods es m) where+ liftIO io = EffT' $ \_ ss -> do+ a <- liftIO io+ return (RSuccess a, ss)+ {-# INLINE liftIO #-}++instance Monad m => MonadReadable (SystemRead c mods) (EffT' c mods es m) where+ query = EffT' $ \rs ss -> return (RSuccess rs, ss)+ {-# INLINE query #-}+ local f (EffT' eff) = EffT' $ \rs ss -> eff (f rs) ss+ {-# INLINE local #-}++instance Monad m => MonadStateful (SystemState c mods) (EffT' c mods es m) where+ get = EffT' $ \_ ss -> return (RSuccess ss, ss)+ {-# INLINE get #-}+ put ss = EffT' $ \_ _ -> return (RSuccess (), ss)+ {-# INLINE put #-}+ modify f = EffT' $ \_ ss -> return (RSuccess (), f ss)+ {-# INLINE modify #-}++instance MonadTrans (EffT' c mods es) where+ lift ma = EffT' $ \_ ss -> do+ a <- ma+ return (RSuccess a, ss)+ {-# INLINE lift #-}++instance MonadTransControl (EffT' c mods es) where+ type StT (EffT' c mods es) a = (Result es a, SystemState c mods)+ liftWith f = EffT' $ \rs ss -> fmap (\a -> (RSuccess a, ss)) $ f $ runEffT rs ss+ {-# INLINE liftWith #-}++ restoreT mRes = EffT' $ \_ _ -> mRes+ {-# INLINE restoreT #-}++instance MonadBase b m => MonadBase b (EffT' c mods es m) where+ liftBase = lift . liftBase+ {-# INLINE liftBase #-}++instance MonadBaseControl b m => MonadBaseControl b (EffT' c mods es m) where+ type StM (EffT' c mods es m) a = StM m (Result es a, SystemState c mods)+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM+ {-# INLINE liftBaseWith #-}+ {-# INLINE restoreM #-}+ -- f = EffT' $ \rs ss -> do+ -- let ma = liftBaseWith @b @m $ \runInBase -> runInBase $ runEffT rs ss _+ -- _++-- | The error in throwM is thrown as MonadThrowError, which is a wrapper for SomeException.+instance (Monad m, ConsFDataList c mods, InList MonadThrowError es) => MonadThrow (EffT' c mods es m) where+ throwM = effThrowIn . MonadThrowError . toException+ {-# INLINE throwM #-}++-- | this can only catch MonadThrowError, other errors are algebraic and should be caught by effCatch, effCatchIn, effCatchAll+instance (Monad m, ConsFDataList c mods, InList MonadThrowError es) => MonadCatch (EffT' c mods es m) where+ catch ma handler = effCatchIn' ma $ \(MonadThrowError e) ->+ case fromException e of+ Just e' -> handler e'+ Nothing -> effThrowIn $ MonadThrowError e+ {-# INLINE catch #-}++-- | The states on the separate thread will diverge, and will be discarded.+-- when exception occurs, the thread quits+forkEffT :: forall c mods es m. (MonadIO m, MonadBaseControl IO m) => EffT' c mods es m () -> EffT' c mods NoError m ThreadId+forkEffT eff = EffT' $ \rs ss -> do+ -- run the EffT' computation in a separate thread+ forkedEff <- liftBaseWith $ \runInBase -> forkIO (void $ runInBase $ unEffT' eff rs ss)+ -- return the ThreadId and the original state+ return (RSuccess forkedEff, ss)+{-# INLINE forkEffT #-}++-- | The states on the separate thread will diverge, and will be discarded.+-- forces you to deal with all the exceptions inside the thread, so the thread won't die in an unexpected way.+forkEffTSafe :: forall c mods m. (MonadIO m, MonadBaseControl IO m) => EffT' c mods NoError m () -> EffT' c mods NoError m ThreadId+forkEffTSafe = forkEffT+{-# INLINE forkEffTSafe #-}++-- | The states on the separate thread will diverge, and will be returned as an Async type.+asyncEffT+ :: forall c mods es m a. (MonadIO m, MonadBaseControl IO m)+ => EffT' c mods es m a -> EffT' c mods NoError m (Async (StM m (Result es a, SystemState c mods)))+asyncEffT eff = EffT' $ \rs ss -> do+ asyncEff <- liftBaseWith $ \runInBase -> async (runInBase $ unEffT' eff rs ss)+ return (RSuccess asyncEff, ss)+{-# INLINE asyncEffT #-}++-- | embed smaller effect into larger effect+embedEffT :: forall mods mods' m c es es' a. (SubList c mods mods', SubListEmbed es es', Monad m)+ => EffT' c mods es m a -> EffT' c mods' es' m a+embedEffT eff = EffT' $ \rs' ss' -> do+ let rs = getSubListF rs'+ ss = getSubListF @_ @mods ss'+ modsEffT' = unEffT' eff+ (emods, ss1) <- modsEffT' rs ss+ returnStrict (subListResultEmbed emods, subListUpdateF ss' ss1)+{-# INLINE embedEffT #-}++returnStrict :: Monad m => (a, b) -> m (a, b)+returnStrict (!a, !b) = return (a, b)+{-# INLINE returnStrict #-}++-- | embed effect, but only change the mods list, the error list remains the same. The (inner) mods type variable is the first type parameter, suitable for type application.+embedMods :: forall mods mods' c es m a. (Monad m, ConsFDataList c mods', SubListEmbed es es, SubList c mods mods') => EffT' c mods es m a -> EffT' c mods' es m a+embedMods = embedEffT+{-# INLINE embedMods #-}++-- | embed effect, but only change the error list, the mods list remains the same. The (inner) es type variable is the first type parameter, suitable for type application.+embedError :: forall es es' c mods m a. (Monad m, SubList c mods mods, SubListEmbed es es') => EffT' c mods es m a -> EffT' c mods es' m a+embedError = embedEffT+{-# INLINE embedError #-}++-- | Run the EffT' computation with data needed, returns the potential error result and the new state in the base monad.+runEffT :: forall mods es m c a. Monad m => SystemRead c mods -> SystemState c mods -> EffT' c mods es m a -> m (Result es a, SystemState c mods)+runEffT rs ss = \eff -> unEffT' eff rs ss+{-# INLINE runEffT #-}++-- | Same as runEff but ignores the new state+runEffT_ :: forall mods es m c a+ . Monad m+ => SystemRead c mods+ -> SystemState c mods+ -> EffT' c mods es m a+ -> m (Result es a)+runEffT_ rs ss = fmap fst . runEffT rs ss+{-# INLINE runEffT_ #-}++-- | same as runEff, but get rid of the Result wrapper when you have empty error list+runEffTNoError :: forall mods m c a+ . Monad m+ => SystemRead c mods+ -> SystemState c mods+ -> EffT' c mods NoError m a+ -> m (a, SystemState c mods)+runEffTNoError rs ss = fmap (first resultNoError) . runEffT rs ss+{-# INLINE runEffTNoError #-}++-- | runs the EffT' with no modules+runEffT0 :: (Monad m, ConsFNil c) => EffT' c '[] es m a -> m (Result es a)+runEffT0 = fmap fst . runEffT fNil fNil+{-# INLINE runEffT0 #-}++-- | runs the EffT' with no modules and a single possible error type, return as classic Either type+runEffT01 :: (Monad m, ConsFNil c) => EffT' c '[] '[e] m a -> m (Either e a)+runEffT01 = fmap (first fromElistSingleton . resultToEither) . runEffT0+{-# INLINE runEffT01 #-}++-- | runs the EffT' with no modules and no error+runEffT00 :: (Monad m, ConsFNil c) => EffT' c '[] NoError m a -> m a+runEffT00 = fmap resultNoError . runEffT0+{-# INLINE runEffT00 #-}++-- | Runs a EffT' computation and eliminate the most outer effect with its input given+--+-- Note: `ModuleState mod` will be lost (because nothing will be returned) when the outer EffT' monad returns an exception. This should not be a problem and is expected from the type signature. But if you want to avoid it, you can catch the exceptions or use `errorToEitherAll` or `runEffTOuter'`+runEffTOuter :: forall mod mods es m c a. (ConsFDataList c (mod : mods), ConsFData1 c mods, Monad m)+ => ModuleRead mod -> ModuleState mod -> EffT' c (mod : mods) es m a -> EffT' c mods es m (a, ModuleState mod)+runEffTOuter mread mstate eff = EffT' $ \modsRead modsState ->+ (\(ea, s :*** ss) -> ((,s) <$> ea, ss)) <$> unEffT' @_ @(mod:mods) eff (mread `consF1` modsRead) (mstate `consF1` modsState)+{-# INLINE runEffTOuter #-}++-- | Runs a EffT' computation and eliminate the most outer effect with its input given, returning the result as Result type.+--+-- This makes sure the `ModuleState mod` up until exception or completion is always returned.+runEffTOuter' :: forall mod mods es m c a. (ConsFDataList c (mod : mods), ConsFData1 c mods, Monad m)+ => ModuleRead mod -> ModuleState mod -> EffT' c (mod : mods) es m a -> EffT' c mods NoError m (Result es a, ModuleState mod)+runEffTOuter' r s = runEffTOuter r s . errorToResult+{-# INLINE runEffTOuter' #-}++-- | the same as `runEffTOuter`, but discards the state+runEffTOuter_ :: forall mod mods es m c a. (ConsFDataList c (mod : mods), ConsFData1 c mods, Monad m)+ => ModuleRead mod -> ModuleState mod -> EffT' c (mod : mods) es m a -> EffT' c mods es m a+runEffTOuter_ mread mstate eff = fst <$> runEffTOuter @mod @mods mread mstate eff+{-# INLINE runEffTOuter_ #-}++-- | Running an inner module of EffT, eliminates it+runEffTIn :: forall mod mods es m c a. (RemoveElem c mods, Monad m, In' c mod mods)+ => ModuleRead mod -> ModuleState mod -> EffT' c mods es m a+ -> EffT' c (Remove (FirstIndex mod mods) mods) es m (a, ModuleState mod)+runEffTIn mread mstate eff = EffT' $ \modsRead modsState -> do+ let rs = unRemoveElem (singFirstIndex @mod @mods) mread modsRead+ ss = unRemoveElem (singFirstIndex @mod @mods) mstate modsState+ (ea, ss') <- unEffT' eff rs ss+ case ea of+ RSuccess a -> returnStrict (RSuccess (a, getIn ss'), removeElem (singFirstIndex @mod @mods) ss')+ RFailure es -> returnStrict (RFailure es, removeElem (singFirstIndex @mod @mods) ss')+{-# INLINE runEffTIn #-}++-- | Runs an inner EffT' module and eliminate it, returning the result as Result type.+--+-- This makes sure the `ModuleState mod` up until exception or completion is always returned.+runEffTIn' :: forall mod mods es m c a. (RemoveElem c mods, Monad m, In' c mod mods)+ => ModuleRead mod -> ModuleState mod -> EffT' c mods es m a+ -> EffT' c (Remove (FirstIndex mod mods) mods) NoError m (Result es a, ModuleState mod)+runEffTIn' mread mstate = runEffTIn mread mstate . errorToResult+{-# INLINE runEffTIn' #-}++-- | The same as runEffTIn, but discards the state+runEffTIn_ :: forall mod mods es m c a. (RemoveElem c mods, Monad m, In' c mod mods)+ => ModuleRead mod -> ModuleState mod -> EffT' c mods es m a+ -> EffT' c (Remove (FirstIndex mod mods) mods) es m a+runEffTIn_ mread mstate eff = fst <$> runEffTIn @mod @mods mread mstate eff+{-# INLINE runEffTIn_ #-}+-------------------------------------- instances --------------------------------------++-- | The unit of Effect, a module is a type with certain associated data family types+class Module mod where+ data ModuleRead mod :: Type+ data ModuleState mod :: Type++-- | A module that can be placed into a system, has some init data required to initialize it, and can have some events+class Module mod => SystemModule mod where+ data ModuleEvent mod :: Type+ data ModuleInitData mod :: Type++type SystemState c mods = c ModuleState mods+type SystemRead c mods = c ModuleRead mods++type SystemEvent mods = UList ModuleEvent mods+type SystemInitData c mods = c ModuleInitData mods++data SystemError+ = SystemErrorException SomeException+ | SystemErrorText Text+ deriving Show++-- | NoError is just a synonym for empty list+type NoError = '[]++-- | Queries the module read inside the EffT' monad+queryModule :: forall mod mods c m es. (Monad m, In' c mod mods, Module mod) => EffT' c mods es m (ModuleRead mod)+queryModule = queries @(SystemRead c mods) (getIn @c @mod)+{-# INLINE queryModule #-}++-- | The same as qeuryModule, just a synonym+askModule :: forall mod mods c m es. (Monad m, In' c mod mods, Module mod) => EffT' c mods es m (ModuleRead mod)+askModule = queryModule+{-# INLINE askModule #-}++-- | Queries the module read inside the EffT' monad, using a function to extract the value+queriesModule :: forall mod mods es m c a. (Monad m, In' c mod mods, Module mod) => (ModuleRead mod -> a) -> EffT' c mods es m a+queriesModule f = f <$> queryModule @mod @mods @c+{-# INLINE queriesModule #-}++-- | The same as queriesModule, just a synonym+asksModule :: forall mod mods es m c a. (Monad m, In' c mod mods, Module mod) => (ModuleRead mod -> a) -> EffT' c mods es m a+asksModule = queriesModule+{-# INLINE asksModule #-}++-- | Run the EffT' computation with a modified module read+localModule :: forall mod mods es m c a. (Monad m, In' c mod mods, Module mod) => (ModuleRead mod -> ModuleRead mod) -> EffT' c mods es m a -> EffT' c mods es m a+localModule f eff = EffT' $ \rs ss -> do+ let rs' = modifyIn @c @mod f rs+ unEffT' eff rs' ss+{-# INLINE localModule #-}++-- | Get the module state inside the EffT' monad+getModule :: forall mod mods es m c. (Monad m, In' c mod mods, Module mod) => EffT' c mods es m (ModuleState mod)+getModule = gets @(SystemState c mods) (getIn @c @mod)+{-# INLINE getModule #-}++-- | Get the module state inside the EffT' monad, using a function to extract the value+getsModule :: forall mod mods es m c a. (Monad m, In' c mod mods, Module mod) => (ModuleState mod -> a) -> EffT' c mods es m a+getsModule f = f <$> getModule @mod+{-# INLINE getsModule #-}++-- | Put the module state inside the EffT' monad+putModule :: forall mod mods es m c. (Monad m, In' c mod mods, Module mod) => ModuleState mod -> EffT' c mods es m ()+putModule x = modify @(SystemState c mods) (modifyIn $ const x)+{-# INLINE putModule #-}++-- | Modify the module state inside the EffT' monad+modifyModule :: forall mod mods es m c. (Monad m, In' c mod mods, Module mod) => (ModuleState mod -> ModuleState mod) -> EffT' c mods es m ()+modifyModule f = modify @(SystemState c mods) (modifyIn f)+{-# INLINE modifyModule #-}++-- | Declare that the computation has no error, it just discards the error types. When the error actually happen it will be runtime exception.+declareNoError :: Monad m => EffT' c mods es m a -> EffT' c mods NoError m a+declareNoError eff = eff `effCatchAll` \_es -> error "declareNoError: declared NoError, but got errors"+{-# INLINE declareNoError #-}++-- | lift IO action into EffT, catch IOException and return as Left, synonym for effIOSafe+liftIOException :: MonadIO m => IO a -> EffT' c mods '[IOException] m a+liftIOException = liftIOAt+{-# INLINE liftIOException #-}++-- | lift IO and catch a specific type of exception+liftIOAt :: (Exception e, MonadIO m) => IO a -> EffT' c mods '[e] m a+liftIOAt = liftIOSafeWith id+{-# INLINE liftIOAt #-}++-- | Capture SomeException in IO and turn it into a ErrorText+liftIOText :: forall s mods m c a. MonadIO m => (Text -> Text) -> IO a -> EffT' c mods '[ErrorText s] m a+liftIOText err = liftIOSafeWith (\(e :: SomeException) -> ErrorText $ err $ pack $ show e)+{-# INLINE liftIOText #-}++-- | lift IO action into EffT, catch SomeException, turn it into Text+-- and prepend error message into ErrorText s. The type `s` is a type level string and at the first type parameter, suitable for type application.+--+-- example: `liftIOPrepend @"File" "File error:" $ readFile' "file.txt"`+liftIOPrepend :: forall s mods c a. Text -> IO a -> EffT' c mods '[ErrorText s] IO a+liftIOPrepend err = liftIOText (err <>)+{-# INLINE liftIOPrepend #-}++-- | lift IO action into EffT, catch specific type of exception e' into a custom error e+liftIOSafeWith :: (Exception e', MonadIO m) => (e' -> e) -> IO a -> EffT' c mods '[e] m a+liftIOSafeWith f io = EffT' $ \_ s -> do+ a :: Either e' a <- liftIO $ E.try io+ case a of+ Right a' -> return (RSuccess a', s)+ Left e' -> return (RFailure $ EHead $ f e', s)+{-# INLINE liftIOSafeWith #-}++-- | @try@ on the Base monad IO, adding as the first error in the error list.+-- It is recommended that you wrap low-level routines into algebraic error in the first place instead of using this function.+effTryIO :: Exception e => EffT' c mods es IO a -> EffT' c mods (e : es) IO a+effTryIO = effTryIOWith id+{-# INLINE effTryIO #-}++-- | @try@ on the Base monad IO, put into the error list.+-- It is recommended that you wrap low-level routines into algebraic error in the first place instead of using this function.+effTryIOIn :: forall e es c mods a. (Exception e, InList e es) => EffT' c mods es IO a -> EffT' c mods es IO a+effTryIOIn = effTryIOInWith @e id+{-# INLINE effTryIOIn #-}++-- | @try@ on the Base monad IO with the given function, adding as the first error in the error list.+-- It is recommended that you wrap low-level routines into algebraic error in the first place instead of using this function.+effTryIOWith :: Exception e => (e -> e') -> EffT' c mods es IO a -> EffT' c mods (e' : es) IO a+effTryIOWith f eff = EffT' $ \rs ss -> do+ ePair <- E.try (unEffT' eff rs ss)+ case ePair of+ Left e -> return (RFailure $ EHead $ f e, ss)+ Right (eResult, stateMods) -> return (resultMapErrors ETail eResult, stateMods)+{-# INLINE effTryIOWith #-}++-- | @try@ on the Base monad IO with the given function, adding as the first error in the error list.+-- It is recommended that you wrap low-level routines into algebraic error in the first place instead of using this function.+effTryIOInWith :: (Exception e, InList e' es) => (e -> e') -> EffT' c mods es IO a -> EffT' c mods es IO a+effTryIOInWith f eff = EffT' $ \rs ss -> do+ ePair <- E.try (unEffT' eff rs ss)+ case ePair of+ Left e -> return (RFailure $ embedE $ f e, ss)+ Right (eResult, stateMods) -> return (eResult, stateMods)+{-# INLINE effTryIOInWith #-}++-- | Convert the first error in the effect to Either+errorToEither :: Monad m => EffT' c mods (e : es) m a -> EffT' c mods es m (Either e a)+errorToEither eff = EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case eResult of+ RSuccess a -> return (RSuccess (Right a), stateMods)+ RFailure (EHead e) -> return (RSuccess (Left e), stateMods)+ RFailure (ETail es) -> return (RFailure es, stateMods)+{-# INLINE errorToEither #-}++-- | Convert all errors to Either+errorToEitherAll :: Monad m => EffT' c mods es m a -> EffT' c mods NoError m (Either (EList es) a)+errorToEitherAll eff = EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case eResult of+ RSuccess a -> return (RSuccess (Right a), stateMods)+ RFailure es -> return (RSuccess (Left es), stateMods)+{-# INLINE errorToEitherAll #-}++-- | Convert all errors to Result+errorToResult :: Monad m => EffT' c mods es m a -> EffT' c mods NoError m (Result es a)+errorToResult eff = EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case eResult of+ RSuccess a -> return (pure $ RSuccess a, stateMods)+ RFailure es -> return (pure $ RFailure es, stateMods)+{-# INLINE errorToResult #-}++-- | The reverse of errorToEither, convert Either (EList es) into the error list.+eitherAllToEffect :: Monad m => EffT' c mods NoError m (Either (EList es) a) -> EffT' c mods es m a+eitherAllToEffect eff = EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case eResult of+ RSuccess (Right a) -> return (RSuccess a, stateMods)+ RSuccess (Left es) -> return (RFailure es, stateMods)+{-# INLINE eitherAllToEffect #-}++-- | Catch SystemError+effCatchSystem :: (Monad m, In' c SystemError es) => EffT' c mods es m a -> (SystemError -> EffT' c mods es m a) -> EffT' c mods es m a+effCatchSystem eff h = EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case eResult of+ RSuccess a -> return (RSuccess a, stateMods)+ RFailure es | Just e@(SystemErrorException _) <- getEMaybe es -> do+ unEffT' (h e) rs ss+ RFailure es -> return (RFailure es, stateMods)+{-# INLINE effCatchSystem #-}++-- | Catch the first error in the error list, and handle it with a handler function+effCatch :: Monad m => EffT' c mods (e : es) m a -> (e -> EffT' c mods es m a) -> EffT' c mods es m a+effCatch eff h = EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case eResult of+ RSuccess a -> return (RSuccess a, stateMods)+ RFailure (EHead e) -> (unEffT' $ h e) rs ss+ RFailure (ETail es) -> return (RFailure es, stateMods)+{-# INLINE effCatch #-}++-- | Catch a specific error type in the error list, and handle it with a handler function.+-- This will remove the error type from the error list.+--+-- the error type is the first type parameter, suitable for type application.+effCatchIn:: forall e es mods m c a es'. (Monad m, InList e es, es' ~ Remove (FirstIndex e es) es)+ => EffT' c mods es m a -> (e -> EffT' c mods es' m a) -> EffT' c mods es' m a+effCatchIn eff h = EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case getElemRemoveResult (singIndex @e @es) eResult of+ Left e -> case proofIndex @e @es of+ Refl -> unEffT' (h e) rs ss+ Right eResult' -> return (eResult', stateMods)+{-# INLINE effCatchIn #-}++-- | Same as effCatchIn, but Does Not remove the error type+effCatchIn' :: forall e es mods m c a. (Monad m, InList e es)+ => EffT' c mods es m a -> (e -> EffT' c mods es m a) -> EffT' c mods es m a+effCatchIn' eff h = EffT' $ \rs ss -> do+ r@(eResult, _) <- unEffT' eff rs ss+ case eResult of+ RSuccess _ -> return r+ RFailure es -> case getEMaybe @e @es es of+ Just e' -> unEffT' (h e') rs ss+ Nothing -> return r+{-# INLINE effCatchIn' #-}++-- | Catch all errors in the error list, and handle it with a handler function. You can pattern match on `EList es` to handle the errors.+-- Removes all errors from the error list.+effCatchAll :: Monad m => EffT' c mods es m a -> (EList es -> EffT' c mods NoError m a) -> EffT' c mods NoError m a+effCatchAll eff h = EffT' $ \rs ss -> do+ (er, stateMods) <- unEffT' eff rs ss+ case er of+ RSuccess a -> return (RSuccess a, stateMods)+ RFailure es -> (unEffT' $ h es) rs ss+{-# INLINE effCatchAll #-}++-- | Throw into the error list+effThrowIn :: (Monad m, InList e es) => e -> EffT' c mods es m a+effThrowIn e = EffT' $ \_ s -> pure (RFailure $ embedE e, s)+{-# INLINE effThrowIn #-}++-- | Throw into the error list+effThrow :: (Monad m, InList e es) => e -> EffT' c mods es m a+effThrow = effThrowIn+{-# INLINE effThrow #-}++-- | Turn an Either return type into the error list with a function, adding the error type if it is not already in the error list.+-- The inner monad type needs to be precise due to the way type inference works.+effEitherWith :: forall e e' es mods c m a. (CheckIfElem e' es, Monad m)+ => (e -> e') -> EffT' c mods es m (Either e a) -> EffT' c mods (AddIfNotElem e' es) m a+effEitherWith f eff = case singIfElem @e' @es of+ Left Refl -> EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case eResult of+ RSuccess (Right a) -> return (RSuccess a, stateMods)+ RSuccess (Left e) -> return (RFailure $ EHead $ f e, stateMods)+ RFailure es -> return (RFailure $ ETail es, stateMods)+ Right (Refl, index) -> EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case eResult of+ RSuccess (Right a) -> return (RSuccess a, stateMods)+ RSuccess (Left e) -> return (RFailure $ embedES index $ f e, stateMods)+ RFailure es -> return (RFailure es, stateMods)+{-# INLINE effEitherWith #-}++-- | Turn an Either return type into the error list, adding the error type if it is not already in the error list.+-- The inner monad type needs to be precise due to the way type inference works.+effEither :: (CheckIfElem e es, Monad m) => EffT' c mods es m (Either e a) -> EffT' c mods (AddIfNotElem e es) m a+effEither = effEitherWith id+{-# INLINE effEither #-}++-- | Lift an Either return type in the base monad into EffT+baseEitherIn :: (Monad m, InList e es) => m (Either e a) -> EffT' c mods es m a+baseEitherIn = effEitherIn . lift+{-# INLINE baseEitherIn #-}++-- | Lift an Either return type in the base monad into EffT with the given function+baseEitherInWith :: (Monad m, InList e' es) => (e -> e') -> m (Either e a) -> EffT' c mods es m a+baseEitherInWith f = effEitherInWith f . lift+{-# INLINE baseEitherInWith #-}++-- | Turn an Either return type into the error list with a function+effEitherInWith :: (Monad m, InList e' es) => (e -> e') -> EffT' c mods es m (Either e a) -> EffT' c mods es m a+effEitherInWith f eff = EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case eResult of+ RSuccess (Right a) -> return (RSuccess a, stateMods)+ RSuccess (Left e) -> return (RFailure $ embedE $ f e, stateMods)+ RFailure sysE -> return (RFailure sysE, stateMods)+{-# INLINE effEitherInWith #-}++-- | Turn an Either return type into the error list+effEitherIn :: (Monad m, InList e es) => EffT' c mods es m (Either e a) -> EffT' c mods es m a+effEitherIn = effEitherInWith id+{-# INLINE effEitherIn #-}++-- | Turn a pure Maybe value into error with the given error type.+pureMaybeInWith :: forall e es m mods c a. (In' c e es, Monad m) => e -> Maybe a -> EffT' c mods es m a+pureMaybeInWith e = effMaybeInWith e . lift . pure+{-# INLINE pureMaybeInWith #-}++-- | Lift a Maybe return type in the base monad into EffT with the given error type.+baseMaybeInWith :: forall e es m mods c a. (In' c e es, Monad m) => e -> m (Maybe a) -> EffT' c mods es m a+baseMaybeInWith f = effMaybeInWith f . lift+{-# INLINE baseMaybeInWith #-}++-- | Turn a pure Either value into error with the given error type.+pureEitherInWith :: forall e' e es m mods c a. (In' c e' es, Monad m) => (e -> e') -> Either e a -> EffT' c mods es m a+pureEitherInWith f = effEitherInWith f . lift . pure+{-# INLINE pureEitherInWith #-}++-- | Turn an Either return type into the error list, adding the error type if it is not already in the error list.+-- The inner monad type needs to be precise due to the way type inference works.+effMaybeWith :: forall e es m mods c a. (CheckIfElem e es, Monad m) => e -> EffT' c mods es m (Maybe a) -> EffT' c mods (AddIfNotElem e es) m a+effMaybeWith e eff = case singIfElem @e @es of+ Left Refl -> EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case eResult of+ RSuccess (Just a) -> return (RSuccess a, stateMods)+ RSuccess Nothing -> return (RFailure $ EHead e, stateMods)+ RFailure sysE -> return (RFailure $ ETail sysE, stateMods)+ Right (Refl, index) -> EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case eResult of+ RSuccess (Just a) -> return (RSuccess a, stateMods)+ RSuccess Nothing -> return (RFailure $ embedES index e, stateMods)+ RFailure es -> return (RFailure es, stateMods)+{-# INLINE effMaybeWith #-}++-- | Turn an Maybe return type into the error list+effMaybeInWith :: forall e es m mods c a. (In' c e es, Monad m) => e -> EffT' c mods es m (Maybe a) -> EffT' c mods es m a+effMaybeInWith e eff = EffT' $ \rs ss -> do+ (eResult, stateMods) <- unEffT' eff rs ss+ case eResult of+ RSuccess (Just a) -> return (RSuccess a, stateMods)+ RSuccess Nothing -> return (RFailure $ embedE e, stateMods)+ RFailure sysE -> return (RFailure sysE, stateMods)+{-# INLINE effMaybeInWith #-}++effEitherSystemException :: (Monad m, Exception e, InList SystemError es) => EffT' c mods es m (Either e a) -> EffT' c mods es m a+effEitherSystemException = effEitherInWith $ SystemErrorException . toException
+ src/Control/Monad/RS/Class.hs view
@@ -0,0 +1,39 @@+-- This module provides two interface MonadReadable and MonadStateful, unlike MonadReader+-- and MonadState, these interfaces do not have functional dependencies, allowing for+-- simple and extensible state and read effects.+module Control.Monad.RS.Class where++-- | A class for monads that can read a value of type 'r'.+-- without the functional dependencies, so you can read different types of values+class Monad m => MonadReadable r m where+ {-# MINIMAL query, local #-}+ -- | Query the monad for a value of type 'r'.+ query :: m r++ -- | Transform the result of a query using a function.+ queries :: (r -> r') -> m r'+ queries f = f <$> query+ {-# INLINE queries #-}++ local :: (r -> r) -> m a -> m a++-- | A class for monads that can maintain a state of type 's'.+-- without the functional dependencies, so you can have different types of states+class Monad m => MonadStateful s m where+ {-# MINIMAL get, put #-}+ -- | Get the current state.+ get :: m s++ gets :: (s -> a) -> m a+ gets f = f <$> get+ {-# INLINE gets #-}++ -- | Set the state to a new value.+ put :: s -> m ()++ -- | Modify the current state using a function.+ modify :: (s -> s) -> m ()+ modify f = do+ s <- get+ put (f s)+ {-# INLINE modify #-}
+ src/Control/System.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances #-}+module Control.System+ (+ -- * Module and System+ Module(..)++ , System(..), Loadable(..)++ , runSystemWithInitData++ , askModule, asksModule+ , queryModule, queriesModule+ , localModule+ , getModule, getsModule+ , putModule, modifyModule++ -- * Loadable+ , ModuleInitDataHardCode+ + , LoadableEnv(..), LoadableArgs(..), SystemEnv(..), SystemArgs(..)+ , SystemInitDataHardCode'+ , SystemInitDataHardCode+ , SystemInitDataHardCodeL+ , Dependency++ ) where++import Control.Applicative+import Control.Concurrent.STM+import Control.Monad.Effect+import Data.Kind+import Data.TypeList++type family DependencyW (mod :: Type) (deps :: [Type]) (mods :: [Type]) :: Constraint where+ DependencyW mod '[] mods = mod `In` (mod : mods)+ DependencyW mod (dep ': deps) mods = (dep `In` mods, dep `In` (mod : mods), DependencyW mod deps mods)++-- | A type family that can be used to generate the constraints+-- to make specifying module dependencies easier+type family Dependency (mod :: Type) (deps :: [Type]) (mods :: [Type]) :: Constraint where+ Dependency mod deps mods = (ConsFDataList FData (mod : mods), DependencyW mod deps mods)++type SystemInitDataHardCode' c mods = c ModuleInitDataHardCode mods+type SystemInitDataHardCode mods = SystemInitDataHardCode' FData mods+type SystemInitDataHardCodeL mods = SystemInitDataHardCode' FList mods++-- | Run a System of EffT' given initData+--+-- If error happens at initialization, it will return Left SystemError+-- If error happens during normal flow, it will return Right (RFailure SystemError)+runSystemWithInitData :: forall mods es m c a. (ConsFDataList c mods, System c mods, MonadIO m)+ => SystemInitData c mods+ -> EffT' c mods es m a+ -> m+ (Either SystemError -- ^ if error happens at initialization+ ( Result es a -- ^ if error happens during event loop+ , SystemState c mods)+ )+runSystemWithInitData initData eff = do+ liftIO (runEffT0 (initAllModules @c @mods initData)) >>= \case+ RSuccess (rs, ss) -> Right <$> runEffT rs ss eff+ RFailure (EHead e) -> return $ Left e++-- | Specifies that the module can load after mods are loaded+-- in practice we could use+-- instance SomeModuleWeNeed `In` mods => Loadable mods SomeModuleToLoad+class Loadable c mod mods where+ {-# MINIMAL initModule #-}+ initModule :: ModuleInitData mod -> EffT' c mods '[SystemError] IO (ModuleRead mod, ModuleState mod)++ beforeEvent :: EffT' c (mod : mods) NoError IO ()+ beforeEvent = return ()+ {-# INLINE beforeEvent #-}++ afterEvent :: EffT' c (mod : mods) NoError IO ()+ afterEvent = return ()+ {-# INLINE afterEvent #-}++ moduleEvent :: EffT' c (mod : mods) NoError IO (STM (ModuleEvent mod))+ moduleEvent = return empty+ {-# INLINE moduleEvent #-}++ handleEvent :: ModuleEvent mod -> EffT' c (mod : mods) NoError IO ()+ handleEvent _ = return ()+ {-# INLINE handleEvent #-}++ releaseModule :: EffT' c (mod : mods) NoError IO () -- ^ release resources, quit module+ releaseModule = return ()+ {-# INLINE releaseModule #-}++data family ModuleInitDataHardCode mod :: Type++class Loadable c mod mods => LoadableEnv c mod mods where+ readInitDataFromEnv :: ModuleInitDataHardCode mod -> EffT' c '[] '[SystemError] IO (ModuleInitData mod)+ -- ^ Read module init data from environment, or other means+ -- one can change this to SystemInitData mods -> IO (ModuleInitData mod)++class Loadable c mod mods => LoadableArgs c mod mods where+ readInitDataFromArgs :: ModuleInitDataHardCode mod -> [String] -> EffT' c '[] '[SystemError] IO (ModuleInitData mod)+ -- ^ Read module init data from command line arguments, or using comand line arguments to read other things+ -- one can change this to SystemInitData mods -> [String] -> IO (ModuleInitData mod)++------------------------------------------system : a list of modules------------------------------------------+-- | System is a list of modules loaded in sequence with dependency verification+--+-- the last module in the list is the first to be loaded+-- and also the first to execute beforeEvent and afterEvent+class System c mods where+ initAllModules :: ConsFDataList c mods => SystemInitData c mods -> EffT' c '[] '[SystemError] IO (SystemRead c mods, SystemState c mods)++ listenToEvents :: ConsFDataList c mods => EffT' c mods '[] IO (STM (SystemEvent mods))++ handleEvents :: ConsFDataList c mods => SystemEvent mods -> EffT' c mods '[] IO ()++ beforeSystem :: ConsFDataList c mods => EffT' c mods '[] IO ()++ afterSystem :: ConsFDataList c mods => EffT' c mods '[] IO ()++ releaseSystem :: ConsFDataList c mods => EffT' c mods '[] IO ()+ -- ^ safely release all resources system acquired+ -- Warning: releaseSystem is done in reverse order of initAllModules+ -- i.e. the head of the list is the first to be released++class System c mods => SystemEnv c mods where+ readSystemInitDataFromEnv :: ConsFDataList c mods => SystemInitDataHardCode' c mods -> EffT' c '[] '[SystemError] IO (SystemInitData c mods)++class System c mods => SystemArgs c mods where+ readSystemInitDataFromArgs :: ConsFDataList c mods => SystemInitDataHardCode' c mods -> [String] -> EffT' c '[] '[SystemError] IO (SystemInitData c mods)++-- | base case for system+instance System c '[] where+ initAllModules _ = return (fNil, fNil)+ {-# INLINE initAllModules #-}++ listenToEvents = return empty+ {-# INLINE listenToEvents #-}++ handleEvents _ = return ()+ {-# INLINE handleEvents #-}++ beforeSystem = return ()+ {-# INLINE beforeSystem #-}++ afterSystem = return ()+ {-# INLINE afterSystem #-}++ releaseSystem = return ()+ {-# INLINE releaseSystem #-}++instance SystemEnv c '[] where+ readSystemInitDataFromEnv _ = return fNil+ {-# INLINE readSystemInitDataFromEnv #-}++instance SystemArgs c '[] where+ readSystemInitDataFromArgs _ _ = do+ return fNil+ {-# INLINE readSystemInitDataFromArgs #-}++-- | Inductive instance for system+instance (SystemModule mod, System c mods, Loadable c mod mods) => System c (mod ': mods) where+ initAllModules (x :*** xs) = do+ (rs, ss) <- initAllModules xs+ (er, ss') <- liftIO $ runEffT rs ss $ initModule @c @mod x+ case er of+ RSuccess (r', s') -> return (r' :*** rs, s' :*** ss')+ RFailure (EHead e) -> effThrowIn e+ {-# INLINE initAllModules #-}++ beforeSystem = do+ embedEffT $ beforeSystem @c @mods+ beforeEvent @c @mod+ {-# INLINE beforeSystem #-}++ afterSystem = do+ embedEffT $ afterSystem @c @mods+ afterEvent @c @mod+ {-# INLINE afterSystem #-}++ listenToEvents = do+ tailEvents <- embedEffT $ listenToEvents @c @mods+ headEvent <- moduleEvent @c @mod+ return $ UHead <$> headEvent <|> UTail <$> tailEvents+ {-# INLINE listenToEvents #-}++ handleEvents (UHead x) = handleEvent @c @mod x+ handleEvents (UTail xs) = embedEffT $ handleEvents @_ @mods xs+ {-# INLINE handleEvents #-}++ releaseSystem = do+ releaseModule @c @mod+ embedEffT $ releaseSystem @c @mods+ {-# INLINE releaseSystem #-}++instance (SubList c mods (mod:mods), SystemModule mod, SystemEnv c mods, Loadable c mod mods, LoadableEnv c mod mods) => SystemEnv c (mod ': mods) where+ readSystemInitDataFromEnv (im :*** ims) = do+ xs <- readSystemInitDataFromEnv @c @mods ims+ x <- readInitDataFromEnv @c @mod @mods im+ return $ x :*** xs+ {-# INLINE readSystemInitDataFromEnv #-}++instance (SubList c mods (mod:mods), SystemModule mod, SystemArgs c mods, Loadable c mod mods, LoadableArgs c mod mods) => SystemArgs c (mod ': mods) where+ readSystemInitDataFromArgs (im :*** ims) args = do+ xs <- readSystemInitDataFromArgs @c @mods ims args+ x <- readInitDataFromArgs @c @mod @mods im args+ return $ x :*** xs+ {-# INLINE readSystemInitDataFromArgs #-}
+ src/Control/System/EventLoop.hs view
@@ -0,0 +1,24 @@+module Control.System.EventLoop where++import Control.System+import Control.Monad.Effect+import Control.Concurrent.STM++eventLoop :: forall mods . (ConsFDataList FData mods, System FData mods) => Eff mods NoError ()+eventLoop = do+ beforeSystem+ listenToEvents >>= liftIO . atomically >>= handleEvents @_ @mods+ afterSystem+ eventLoop++-- | Avoid runtime error (IO) though, make sure every loop breaking error is in SystemError+eventLoopWithRelease :: forall mods. (ConsFDataList FData mods, System FData mods) => Eff mods NoError ()+eventLoopWithRelease = do+ eventLoop+ releaseSystem++-- | When restart, the state is reset to the initial state+eventLoopWithReleaseRestartIO :: forall mods. (ConsFDataList FData mods, System FData mods) => SystemInitData FData mods -> IO ()+eventLoopWithReleaseRestartIO initData = do+ _ <- runSystemWithInitData @mods initData eventLoopWithRelease+ eventLoopWithReleaseRestartIO initData
+ src/Data/Result.hs view
@@ -0,0 +1,98 @@+-- | Module : Data.Result+-- Description : A module that provides a Result type for handling errors in a non-empty list of types.+--+-- This module defines a non-empty sum type `EList` parametrized by a list of types,+-- and a `Result es a` type that can either represent a successful computation or a failure in one of the types in the list.+-- +-- When es is [], it is equivalent to a, there is no redundant constructors or pattern matching.+module Data.Result where++import Data.Kind (Type)+import Data.TypeList.Families++-- | Sum of types, but non-empty by construction.+-- You cannot construct EList '[]+data EList (ts :: [Type]) where+ EHead :: !t -> EList (t : ts)+ ETail :: !(EList ts) -> EList (t : ts)++instance {-# OVERLAPPING #-} Show t => Show (EList '[t]) where+ show (EHead x) = "EHead (" ++ show x ++ ")"+instance (Show t, Show (EList ts)) => Show (EList (t : ts)) where+ show (EHead x) = "EHead (" ++ show x ++ ")"+ show (ETail xs) = "ETail (" ++ show xs ++ ")"++embedES :: SFirstIndex e ts -> e -> EList ts+embedES SFirstIndexZero e = EHead e+embedES (SFirstIndexSucc _ n) e = ETail (embedES n e)+{-# INLINE embedES #-}++-- | Error type that adapt to the type-level list of errors.+data Result (es :: [Type]) (a :: Type) where+ RSuccess :: a -> Result es a+ RFailure :: !(EList es) -> Result es a++instance {-# OVERLAPPING #-} Show a => Show (Result '[] a) where+ show (RSuccess a) = "RSuccess (" ++ show a ++ ")"+instance (Show (EList es), Show a) => Show (Result es a) where+ show (RSuccess a) = "RSuccess (" ++ show a ++ ")"+ show (RFailure es) = "RFailure (" ++ show es ++ ")"++instance Functor (Result es) where+ fmap f (RSuccess a) = RSuccess (f a)+ fmap _ (RFailure es) = RFailure es+ {-# INLINE fmap #-}++instance Applicative (Result es) where+ pure = RSuccess+ RSuccess f <*> RSuccess a = RSuccess (f a)+ RFailure es <*> _ = RFailure es+ _ <*> RFailure es = RFailure es+ {-# INLINE pure #-}+ {-# INLINE (<*>) #-}++instance Monad (Result es) where+ RSuccess a >>= f = f a+ RFailure es >>= _ = RFailure es+ {-# INLINE (>>=) #-}+ return = pure+ {-# INLINE return #-}++getEMaybeS :: SFirstIndex e es -> EList es -> Maybe e+getEMaybeS SFirstIndexZero = \case+ EHead x -> Just x+ ETail _ -> Nothing+getEMaybeS (SFirstIndexSucc _ n) = \case+ EHead _ -> Nothing+ ETail es -> getEMaybeS n es+{-# INLINE getEMaybeS #-}++resultNoError :: Result '[] a -> a+resultNoError (RSuccess a) = a+{-# INLINE resultNoError #-}++resultToEither :: Result (e ': es) a -> Either (EList (e ': es)) a+resultToEither (RSuccess a) = Right a+resultToEither (RFailure es) = Left es+{-# INLINE resultToEither #-}++resultMapErrors :: (EList es -> EList es') -> Result es a -> Result es' a+resultMapErrors _ (RSuccess a) = RSuccess a+resultMapErrors f (RFailure es) = RFailure (f es)+{-# INLINE resultMapErrors #-}++fromElistSingleton :: EList '[s] -> s+fromElistSingleton (EHead x) = x+{-# INLINE fromElistSingleton #-}++getElemRemoveResult :: SNat n -> Result es a -> Either (AtIndex es n) (Result (Remove n es) a)+getElemRemoveResult _ (RSuccess a) = Right (RSuccess a)+getElemRemoveResult SZero (RFailure (EHead e)) = Left e+getElemRemoveResult SZero (RFailure (ETail es)) = Right (RFailure es)+getElemRemoveResult (SSucc _) (RFailure (EHead e)) = Right $ RFailure $ EHead e+getElemRemoveResult (SSucc n) (RFailure (ETail es)) =+ case getElemRemoveResult n (RFailure es) of+ Left e -> Left e+ Right (RFailure es') -> Right (RFailure $ ETail es')+ Right (RSuccess a) -> Right (RSuccess a)+{-# INLINE getElemRemoveResult #-}
+ src/Data/TypeList.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE UndecidableSuperClasses, DefaultSignatures, AllowAmbiguousTypes, UndecidableInstances, DataKinds, TypeFamilies #-}+-- | This module provides utilities for working with type-level lists in Haskell.+-- It defines various types and functions to manipulate type-level lists, including+-- finite lists, constrained lists, and dynamic lists.+--+-- This module is considered INTERNAL, you can use it but be aware that the API may change without major version bumps.+module Data.TypeList+ ( module Data.TypeList.FList+ , module Data.TypeList.UList+ , module Data.TypeList.Families+ , module Data.TypeList.ConsFData+ , module Data.TypeList+ , module Data.Result+ ) where++import Data.TypeList.Families+import Data.TypeList.FList+import Data.TypeList.UList+import Data.TypeList.ConsFData+import Data.TypeList.ConsFData.Pattern+import Data.Type.Equality+import Data.Result+import Data.Kind+import Unsafe.Coerce++-- | A class carrying the proof of the existence of an element in a list.+class InList (e :: Type) (es :: [Type]) where+ singIndex :: SNat (FirstIndex e es)+ singFirstIndex :: SFirstIndex e es+ proofIndex :: AtIndex es (FirstIndex e es) :~: e+ elemIndex :: Elem e es++ getEMaybe :: EList es -> Maybe e+ getEMaybe = getEMaybeS (singFirstIndex @e @es)+ {-# INLINE getEMaybe #-}++ embedE :: e -> EList es+ embedE = embedES (singFirstIndex @e @es)+ {-# INLINE embedE #-}++class InList e es => In' flist e es where+ getIn :: flist f es -> f e+ default getIn :: (ConsFData flist) => flist f es -> f e+ getIn = getInS (singFirstIndex @e @es)+ {-# INLINE getIn #-}++ modifyIn :: (f e -> f e) -> flist f es -> flist f es+ default modifyIn :: (ConsFData flist) => (f e -> f e) -> flist f es -> flist f es+ modifyIn f = modifyInS (singFirstIndex @e @es) f+ {-# INLINE modifyIn #-}++-- | Axiom+firstIndexTraverseNotEqElem :: forall e t ts. (NotEq e t, InList e ts) => FirstIndex e (t : ts) :~: Succ (FirstIndex e ts)+firstIndexTraverseNotEqElem = unsafeCoerce Refl+{-# INLINE firstIndexTraverseNotEqElem #-}++-- | Axiom+axiomInImpliesNonEmpty :: InList e ts => NonEmpty ts :~: True+axiomInImpliesNonEmpty = unsafeCoerce Refl+{-# INLINE axiomInImpliesNonEmpty #-}++-- | Base case for the InList class. NotIn e ts => +instance InList e (e : ts) where+ singIndex = SZero+ {-# INLINE singIndex #-}+ singFirstIndex = SFirstIndexZero+ {-# INLINE singFirstIndex #-}+ proofIndex = Refl+ {-# INLINE proofIndex #-}+ elemIndex = EZ+ {-# INLINE elemIndex #-}+ embedE = EHead+ {-# INLINE embedE #-}+ getEMaybe = \case+ EHead x -> Just x+ ETail _ -> Nothing+ {-# INLINE getEMaybe #-}++instance In' FList e (e : ts) where+ getIn = \(e :** _) -> e+ {-# INLINE getIn #-}+ modifyIn f = \(x :** xs) -> f x :** xs+ {-# INLINE modifyIn #-}+ +-- | InListductive case for the In class. UniqueIn e (t : ts), +instance {-# OVERLAPPABLE #-} (NotEq e t, InList e ts) => InList e (t : ts) where+ singIndex = case firstIndexTraverseNotEqElem @e @t @ts of+ Refl -> SSucc (singIndex @e @ts)+ {-# INLINE singIndex #-}+ singFirstIndex = case firstIndexTraverseNotEqElem @e @t @ts of+ Refl -> case axiomInImpliesNonEmpty @e @ts of+ Refl -> SFirstIndexSucc Refl (singFirstIndex @e @ts)+ {-# INLINE singFirstIndex #-}+ proofIndex = case firstIndexTraverseNotEqElem @e @t @ts of+ Refl -> case proofIndex @e @ts of Refl -> Refl+ {-# INLINE proofIndex #-}+ elemIndex = ES elemIndex+ {-# INLINE elemIndex #-}+ embedE = ETail . embedE+ {-# INLINE embedE #-}+ getEMaybe = \case+ EHead _ -> Nothing+ ETail es -> getEMaybe es+ {-# INLINE getEMaybe #-}++instance {-# OVERLAPPABLE #-} (flist ~ FList, NonEmpty ts ~ True, FDataConstraint flist e (t : ts), ConsFDataList flist (t:ts), NotEq e t, In' flist e ts) => In' FList e (t : ts) where+ getIn = \(_ :*** xs) -> getIn xs+ {-# INLINE getIn #-}+ modifyIn f = \(x :*** xs) -> x :*** modifyIn f xs+ {-# INLINE modifyIn #-}++instance {-# INCOHERENT #-} InList e es => In' FList e es++class SubList (flist :: (Type -> Type) -> [Type] -> Type) (ys :: [Type]) (xs :: [Type]) where+ getSubListF :: flist f xs -> flist f ys -- ^ Get the sublist from the FList.+ subListModifyF :: (flist f ys -> flist f ys) -> flist f xs -> flist f xs -- ^ Modify the sublist in the FList.++class SubListEmbed (ys :: [Type]) (xs :: [Type]) where+ subListResultEmbed :: Result ys a -> Result xs a -- ^ Embed the result of a sublist operation.++subListUpdateF :: (SubList flist ys xs) => flist f xs -> flist f ys -> flist f xs+subListUpdateF xs ys = subListModifyF (const ys) xs+{-# INLINE subListUpdateF #-}++instance ConsFNil c => SubList c '[] xs where+ getSubListF _ = fNil+ {-# INLINE getSubListF #-}+ subListModifyF _ xs = xs+ {-# INLINE subListModifyF #-}++instance SubListEmbed '[] xs where+ subListResultEmbed (RSuccess a) = RSuccess a+ {-# INLINE subListResultEmbed #-}++instance (InList y xs, SubListEmbed ys xs) => SubListEmbed (y:ys) xs where+ subListResultEmbed (RSuccess a) = RSuccess a+ subListResultEmbed (RFailure (EHead y)) = RFailure (embedE y)+ subListResultEmbed (RFailure (ETail ys)) = subListResultEmbed (RFailure ys)+ {-# INLINE subListResultEmbed #-}++-- | Induction case for the SubList class.+instance (In' c y xs, ConsFDataList c (y:ys), SubList c ys xs) => SubList c (y : ys) xs where+ getSubListF xs = consF0 (getIn xs) (getSubListF xs)+ {-# INLINE getSubListF #-}+ subListModifyF f xs =+ let hy :*** hys = f (getSubListF xs)+ in modifyIn (const hy) $ subListUpdateF xs hys+ {-# INLINE subListModifyF #-}++instance {-# INCOHERENT #-} ConsFDataList c (x:xs) => SubList c xs (x:xs) where+ getSubListF (_ :*** xs) = xs+ {-# INLINE getSubListF #-}+ subListModifyF f (x :*** xs) = x :*** f xs+ {-# INLINE subListModifyF #-}++instance {-# INCOHERENT #-} SubList c xs xs where+ getSubListF = id+ {-# INLINE getSubListF #-}+ subListModifyF = id+ {-# INLINE subListModifyF #-}++instance {-# INCOHERENT #-} SubListEmbed xs xs where+ subListResultEmbed = id+ {-# INLINE subListResultEmbed #-}
+ src/Data/TypeList/ConsFData.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE PatternSynonyms, ViewPatterns, UndecidableSuperClasses #-}+-- | This module is internal+module Data.TypeList.ConsFData where++import Data.TypeList.Families+import Data.Type.Equality+import Data.Kind (Type)++class ConsFNil (flist :: (Type -> Type) -> [Type] -> Type) where+ fNil :: flist f '[]++class When (NonEmpty (Tail ts)) (UnConsFData flist (Tail ts)) => UnConsFData flist ts where+ unConsFData :: flist f ts -> (f (Head ts), flist f (Tail ts))++class When (NonEmpty ts) (ConsFData1 flist (Tail ts)) => ConsFData1 flist ts where+ consF1 :: f t -> flist f ts -> flist f (t : ts)++class When (NonEmpty (Tail ts)) (ConsFData0 flist (Tail ts)) => ConsFData0 flist ts where+ consF0 :: f (Head ts) -> flist f (Tail ts) -> flist f ts++class When (NonEmpty (Tail ts)) (RemoveElem flist (Tail ts)) => RemoveElem flist (ts :: [Type]) where+ removeElem :: SFirstIndex t ts -> flist f ts -> flist f (Remove (FirstIndex t ts) ts)++ unRemoveElem :: SFirstIndex t ts -> f t -> flist f (Remove (FirstIndex t ts) ts) -> flist f ts++class ConsFNil flist => ConsFData flist where+ unConsF :: flist f (t : ts) -> (f t, flist f ts)++ consF :: f t -> flist f ts -> flist f (t : ts)++ getInS :: SFirstIndex t ts -> flist f ts -> f t+ getInS SFirstIndexZero (unConsF -> (x, _)) = x+ getInS (SFirstIndexSucc Refl n) (unConsF -> (_, xs)) = getInS n xs+ {-# INLINE getInS #-}+ + modifyInS :: SFirstIndex t ts -> (f t -> f t) -> flist f ts -> flist f ts+ modifyInS SFirstIndexZero f (unConsF -> (x, xs)) = f x `consF` xs+ modifyInS (SFirstIndexSucc Refl n) f (unConsF -> (x, xs)) = x `consF` modifyInS n f xs+ {-# INLINE modifyInS #-}++class+ ( WhenNonEmpty ts (ConsFDataList flist (Tail ts))+ , ConsFNil flist+ , WhenNonEmpty ts (UnConsFData flist ts)+ , WhenNonEmpty ts (ConsFData0 flist ts)+ , ConsFData1 flist ts+ )+ => ConsFDataList flist ts++-- | Get an element from a finite list using an element proof.+getE :: ConsFData flist => Elem e l -> flist f l -> f e+getE EZ = \(unConsF -> (x, _)) -> x+getE (ES n) = \(unConsF -> (_, xs)) -> getE n xs++putE :: ConsFData flist => Elem e l -> f e -> flist f l -> flist f l+putE EZ x' (unConsF -> (_, xs)) = x' `consF` xs+putE (ES n) y' (unConsF -> (x, xs)) = x `consF` putE n y' xs
+ src/Data/TypeList/ConsFData/Pattern.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+module Data.TypeList.ConsFData.Pattern where++import Data.TypeList.ConsFData+import Data.TypeList.Families++pattern (:**) :: ConsFData flist => f t -> flist f ts -> flist f (t : ts)+pattern (:**) x xs <- (unConsF -> (x, xs)) where+ y :** ys = consF y ys+{-# COMPLETE (:**) #-}+infixr 1 :**++pattern (:***) :: (NonEmpty ts ~ True, ConsFDataList flist ts) => f (Head ts) -> flist f (Tail ts) -> flist f ts+pattern (:***) x xs <- (unConsFData -> (x, xs)) where+ y :*** ys = consF0 y ys+{-# COMPLETE (:***) #-}+infixr 1 :***
+ src/Data/TypeList/FData.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE UndecidableInstances, DeriveAnyClass #-}+-- | The `FData` type family is a fast replacement for `FList`, the heterogeneous list.+-- it builds a data structure using data family instead of GADT, which is very efficient+--+-- instances are generated using Template Haskell for up to 20 elements.+--+-- This module is considered INTERNAL, you can use it but be aware that the API may change without major version bumps.+module Data.TypeList.FData+ ( FData(..), FDataByIndex(..)+ , module Data.TypeList+ ) where++import GHC.Generics (Generic)+import Control.DeepSeq (NFData(..))+import Data.TypeList+import Data.TypeList.FData.TH+import Data.Kind (Type)+import Data.Type.Equality+import Data.Proxy+import Data.Default++data family FData (f :: k -> Type) (ts :: [k]) :: Type+data instance FData f '[] = FData0++$(generateFDataInstances [1..20])++type instance FDataConstraint FData e ts = (FDataByIndex (FirstIndex e ts) ts)++instance (FDataConstraint FData e es, InList e es) => In' FData e es where+ getIn = case proofIndex @e @es of Refl -> getFDataByIndex (Proxy @(FirstIndex e es))+ modifyIn f = case proofIndex @e @es of Refl -> modifyFDataByIndex (Proxy @(FirstIndex e es)) f+ {-# INLINE getIn #-}+ {-# INLINE modifyIn #-}++class FDataByIndex (n :: Nat) (ts :: [Type]) where+ getFDataByIndex :: Proxy n -> FData f ts -> f (AtIndex ts n)+ modifyFDataByIndex :: Proxy n -> (f (AtIndex ts n) -> f (AtIndex ts n)) -> FData f ts -> FData f ts++instance+ ( WhenNonEmpty ts (ConsFDataList FData (Tail ts))+ , ConsFNil FData+ , WhenNonEmpty ts (UnConsFData FData ts)+ , WhenNonEmpty ts (ConsFData0 FData ts)+ , ConsFData1 FData ts+ ) => ConsFDataList FData ts ++instance ConsFNil FData where+ fNil = FData0+ {-# INLINE fNil #-}++$(generateUnconsFDataInstances [1..20])+$(generateConsFData0Instances [1..20])+$(generateConsFData1Instances [0..19])+$(generateRemoveElemInstances [1..20])+$(generateFDataByIndexInstances [(j, i) | i <- [1..20], j <- [0..i-1]])++-- for reference, the generated instances look like this:+--+-- data instance FData f '[t] = FData1 { fdata1_0 :: !(f t) }+-- data instance FData f '[t1, t2] = FData2 { fdata2_0 :: !(f t1), fdata2_1 :: !(f t2) }+-- data instance FData f '[t1, t2, t3] = FData3 { fdata3_0 :: !(f t1), fdata3_1 :: !(f t2), fdata3_2 :: !(f t3) }+-- data instance FData f '[t1, t2, t3, t4] = FData4+-- { fdata4_0 :: !(f t1)+-- , fdata4_1 :: !(f t2)+-- , fdata4_2 :: !(f t3)+-- , fdata4_3 :: !(f t4)+-- }+-- data instance FData f '[t1, t2, t3, t4, t5] = FData5+-- { fdata5_0 :: !(f t1)+-- , fdata5_1 :: !(f t2)+-- , fdata5_2 :: !(f t3)+-- , fdata5_3 :: !(f t4)+-- , fdata5_4 :: !(f t5)+-- }+-- data FData (f :: Type -> Type) (ts :: [Type]) where+-- FData0 :: FData f '[]+-- FData1 :: { fdata1_0 :: !(f t) } -> FData f '[t]+-- FData2 :: { fdata2_0 :: !(f t1), fdata2_1 :: !(f t2) } -> FData f '[t1, t2]+-- FData3 :: { fdata3_0 :: !(f t1), fdata3_1 :: !(f t2), fdata3_2 :: !(f t3) } -> FData f '[t1, t2, t3]+-- FData4 ::+-- { fdata4_0 :: !(f t1)+-- , fdata4_1 :: !(f t2)+-- , fdata4_2 :: !(f t3)+-- , fdata4_3 :: !(f t4) +-- } -> FData f '[t1, t2, t3, t4]+-- FData5 ::+-- { fdata5_0 :: !(f t1)+-- , fdata5_1 :: !(f t2)+-- , fdata5_2 :: !(f t3)+-- , fdata5_3 :: !(f t4)+-- , fdata5_4 :: !(f t5)+-- } -> FData f '[t1, t2, t3, t4, t5]++-- class InList e ts => FDataAccess (e :: Type) (ts :: [Type]) where+-- getFData :: FData f ts -> f e+-- modifyFData :: (f e -> f e) -> FData f ts -> FData f ts++-- instance FDataByIndex Zero '[x1] where+-- getFDataByIndex _ (FData1 x) = x+-- modifyFDataByIndex _ f (FData1 x) = FData1 (f x)+-- {-# INLINE getFDataByIndex #-}+-- {-# INLINE modifyFDataByIndex #-}+--+-- instance FDataByIndex Zero '[x1, x2] where+-- getFDataByIndex _ (FData2 x1 _ ) = x1+-- modifyFDataByIndex _ f (FData2 x1 x2) = FData2 (f x1) x2+-- {-# INLINE getFDataByIndex #-}+-- {-# INLINE modifyFDataByIndex #-}+-- +-- instance FDataByIndex (Succ Zero) '[x1, x2] where+-- getFDataByIndex _ (FData2 _ x2) = x2+-- modifyFDataByIndex _ f (FData2 x1 x2) = FData2 x1 (f x2)+-- {-# INLINE getFDataByIndex #-}+-- {-# INLINE modifyFDataByIndex #-}+-- +-- instance FDataByIndex Zero '[x1, x2, x3] where+-- getFDataByIndex _ (FData3 x1 _ _) = x1+-- modifyFDataByIndex _ f (FData3 x1 x2 x3) = FData3 (f x1) x2 x3+-- {-# INLINE getFDataByIndex #-}+-- {-# INLINE modifyFDataByIndex #-}+-- +-- instance FDataByIndex Zero '[x1, x2, x3, x4] where+-- getFDataByIndex _ (FData4 x1 _ _ _) = x1+-- modifyFDataByIndex _ f (FData4 x1 x2 x3 x4) = FData4 (f x1) x2 x3 x4+-- {-# INLINE getFDataByIndex #-}+-- {-# INLINE modifyFDataByIndex #-}+-- +-- instance FDataByIndex Zero '[x1, x2, x3, x4, x5] where+-- getFDataByIndex _ (FData5 x1 _ _ _ _) = x1+-- modifyFDataByIndex _ f (FData5 x1 x2 x3 x4 x5) = FData5 (f x1) x2 x3 x4 x5+-- {-# INLINE getFDataByIndex #-}+-- {-# INLINE modifyFDataByIndex #-}+--+-- instance UnConsFData FData '[x1] where+-- unConsFData (FData1 x1) = (x1, FData0)+-- {-# INLINE unConsFData #-}+-- instance UnConsFData FData '[x1, x2] where+-- unConsFData (FData2 x1 x2) = (x1, FData1 x2)+-- {-# INLINE unConsFData #-}+-- instance UnConsFData FData '[x1, x2, x3] where+-- unConsFData (FData3 x1 x2 x3) = (x1, FData2 x2 x3)+-- {-# INLINE unConsFData #-}+-- instance UnConsFData FData '[x1, x2, x3, x4] where+-- unConsFData (FData4 x1 x2 x3 x4) = (x1, FData3 x2 x3 x4)+-- {-# INLINE unConsFData #-}+-- instance UnConsFData FData '[x1, x2, x3, x4, x5] where+-- unConsFData (FData5 x1 x2 x3 x4 x5) = (x1, FData4 x2 x3 x4 x5)+-- {-# INLINE unConsFData #-}+-- +-- instance ConsFData0 FData '[x1] where+-- consF0 x (FData0) = FData1 x+-- {-# INLINE consF0 #-}+-- instance ConsFData0 FData '[x1, x2] where+-- consF0 x (FData1 x1) = FData2 x x1+-- {-# INLINE consF0 #-}+-- instance ConsFData0 FData '[x1, x2, x3] where+-- consF0 x (FData2 x1 x2) = FData3 x x1 x2+-- {-# INLINE consF0 #-}+-- instance ConsFData0 FData '[x1, x2, x3, x4] where+-- consF0 x (FData3 x1 x2 x3) = FData4 x x1 x2 x3+-- {-# INLINE consF0 #-}+-- instance ConsFData0 FData '[x1, x2, x3, x4, x5] where+-- consF0 x (FData4 x1 x2 x3 x4) = FData5 x x1 x2 x3 x4+-- {-# INLINE consF0 #-}+-- +-- instance ConsFData1 FData '[] where+-- consF1 x (FData0) = FData1 x+-- {-# INLINE consF1 #-}+-- instance ConsFData1 FData '[x1] where+-- consF1 x (FData1 x1) = FData2 x x1+-- {-# INLINE consF1 #-}+-- instance ConsFData1 FData '[x1, x2] where+-- consF1 x (FData2 x1 x2) = FData3 x x1 x2+-- {-# INLINE consF1 #-}+-- instance ConsFData1 FData '[x1, x2, x3] where+-- consF1 x (FData3 x1 x2 x3) = FData4 x x1 x2 x3+-- {-# INLINE consF1 #-}+-- instance ConsFData1 FData '[x1, x2, x3, x4] where+-- consF1 x (FData4 x1 x2 x3 x4) = FData5 x x1 x2 x3 x4+-- {-# INLINE consF1 #-}+--+-- instance RemoveElem FData '[x1] where+-- removeElem SFirstIndexZero (FData1 _x1) = FData0+-- {-# INLINE removeElem #-}+-- +-- unRemoveElem SFirstIndexZero x (FData0) = FData1 x+-- {-# INLINE unRemoveElem #-}+-- +-- instance RemoveElem FData '[x1, x2] where+-- removeElem SFirstIndexZero (FData2 _x1 x2) = FData1 x2+-- removeElem (SFirstIndexSucc Refl SFirstIndexZero) (FData2 x1 _x2) = FData1 x1+-- {-# INLINE removeElem #-}+-- +-- unRemoveElem SFirstIndexZero x (FData1 x2) = FData2 x x2+-- unRemoveElem (SFirstIndexSucc Refl SFirstIndexZero) x (FData1 x1) = FData2 x1 x+-- {-# INLINE unRemoveElem #-}+-- +-- instance RemoveElem FData '[x1, x2, x3] where+-- removeElem SFirstIndexZero (FData3 _x1 x2 x3) = FData2 x2 x3+-- removeElem (SFirstIndexSucc Refl SFirstIndexZero) (FData3 x1 _x2 x3) = FData2 x1 x3+-- removeElem (SFirstIndexSucc Refl (SFirstIndexSucc Refl SFirstIndexZero)) (FData3 x1 x2 _x3) = FData2 x1 x2+-- {-# INLINE removeElem #-}+-- +-- unRemoveElem SFirstIndexZero x (FData2 x2 x3) = FData3 x x2 x3+-- unRemoveElem (SFirstIndexSucc Refl SFirstIndexZero) x (FData2 x1 x3) = FData3 x1 x x3+-- unRemoveElem (SFirstIndexSucc Refl (SFirstIndexSucc Refl SFirstIndexZero)) x (FData2 x1 x2) = FData3 x1 x2 x+-- {-# INLINE unRemoveElem #-}
+ src/Data/TypeList/FData/TH.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE AllowAmbiguousTypes, ViewPatterns #-}+-- | This module provides Template Haskell utilities for generating instances of FData, including+-- FDataByIndex, UnConsFData, ConsFData0, ConsFData1, and RemoveElem.+--+-- This module is internal+module Data.TypeList.FData.TH where++import Data.TypeList.Families (Nat(..))+import Language.Haskell.TH.Syntax hiding (Type)+import qualified Language.Haskell.TH.Syntax as TH+import Control.Monad (when)++generateFDataInstance :: Int -> Q Dec+generateFDataInstance n = do+ Just fdataName <- lookupTypeName "FData"+ let fName = mkName "f"+ tNames = [mkName ("t" ++ show i) | i <- [1 .. n]]++ fVar = VarT fName+ tVars = map VarT tNames++ listTy = foldr (\t acc -> AppT (AppT PromotedConsT t) acc)+ PromotedNilT+ tVars++ instHead = AppT (AppT (ConT fdataName) fVar) listTy++ conName = mkName ("FData" ++ show n)++ mkField :: Int -> TH.Type -> (Name, Bang, TH.Type)+ mkField idx t =+ ( mkName ("fdata" ++ show n ++ "_" ++ show idx)+ , Bang NoSourceUnpackedness SourceStrict+ , AppT fVar t+ )++ -- Chosen constructor (record for n>0, plain for n==0)+ con | n == 0 = NormalC conName []+ | otherwise =+ RecC conName (zipWith mkField [0 ..] tVars)++ return $ DataInstD+ [] -- No context+ Nothing -- No explicit binders+ instHead+ Nothing -- Kind signature*+ [con]+ [ DerivClause (Just StockStrategy) $ ConT <$> [mkName "Generic"]+ , DerivClause (Just AnyclassStrategy) $ ConT <$> [mkName "NFData"]+ , DerivClause (Just AnyclassStrategy) $ ConT <$> [mkName "Default"]+ ] -- No deriving clauses++generateFDataInstances :: [Int] -> Q [Dec]+generateFDataInstances = mapM generateFDataInstance++--------------------------------------------------------------------------------+-- helpers ---------------------------------------------------------------------+--------------------------------------------------------------------------------++zeroName, succName :: Name+zeroName = 'Zero+succName = 'Succ++fDataCon :: Int -> Name+fDataCon n = mkName $ "FData" ++ show n++-- Promoted Nat at the type level: 0 -> 'Zero, 3 -> 'Succ ('Succ ('Succ 'Zero))+natTy :: Int -> TH.Type+natTy 0 = PromotedT zeroName+natTy n = AppT (PromotedT succName) (natTy (n-1))++-- A promoted type-level list '[t1 ... tn]+promotedListTy :: [TH.Type] -> TH.Type+promotedListTy = foldr (\t acc -> AppT (AppT PromotedConsT t) acc) PromotedNilT++-- Type names for x1, x2, ..., xn+xTypeNames :: [Int] -> [Name]+xTypeNames = map (\i -> mkName ("x" ++ show i))++-- Field patterns for “get” (only the target gets a variable, others are _)+mkGetPats :: Int -> Int -> Name -> [Pat]+mkGetPats len idx var =+ [ if i == idx then VarP var else WildP | i <- [0 .. len-1] ]++-- Field patterns for “modify” (every field bound to xi)+mkModPats :: Int -> [Name] -> [Pat]+mkModPats len vars = [ VarP (vars !! i) | i <- [0 .. len-1] ]++inline :: Name -> Pragma+inline f = InlineP f Inline FunLike AllPhases++--------------------------------------------------------------------------------+-- | @generateFDataByIndexInstance idx len@+-- produces+-- > instance FDataByIndex (Nat idx) '[x1 .. xlen]+generateFDataByIndexInstance :: Int -> Int -> Q Dec+generateFDataByIndexInstance idx len = do+ when (idx < 0 || idx >= len) $+ fail $ "generateFDataByIndexInstance: index " ++ show idx+ ++ " out of bounds for list length " ++ show len++ let conName = mkName ("FData" ++ show len) -- FData1 .. FData5 …+ className = mkName "FDataByIndex" --''FDataByIndex+ fName = mkName "f" -- the function arg+ -- x1 .. xn (term vars)+ xNames = [ mkName ("x" ++ show i) | i <- [1 .. len] ]+ xiName = xNames !! idx -- xi (to be focused)+ -- x1 .. xn (type vars)+ tNames = [ mkName ("x" ++ show i) | i <- [1 .. len] ]+ tVars = map VarT tNames++ fGetFDataByIndex = mkName "getFDataByIndex" -- getFDataByIndex+ fModifyFDataByIndex = mkName "modifyFDataByIndex" -- modifyFDataByIndex++ let instHead = AppT+ (AppT (ConT className) (natTy idx))+ (promotedListTy tVars)++ ----------------------------------------------------------------------+ -- method: getFDataByIndex ------------------------------------------+ ----------------------------------------------------------------------+ getClause =+ Clause [ WildP+ , ConP conName [] (mkGetPats len idx xiName)+ ]+ (NormalB (VarE xiName))+ []++ ----------------------------------------------------------------------+ -- method: modifyFDataByIndex ---------------------------------------+ ----------------------------------------------------------------------+ patVars = mkModPats len xNames -- (FDataN x1 .. xn)+ fieldExs = [ if i == idx+ then AppE (VarE fName) (VarE (xNames !! i))+ else VarE (xNames !! i)+ | i <- [0 .. len-1] ]++ modifyBody = foldl AppE (ConE conName) fieldExs++ modifyClause =+ Clause [ WildP+ , VarP fName+ , ConP conName [] patVars+ ]+ (NormalB modifyBody)+ []++ pure $ InstanceD+ Nothing+ []+ instHead+ [ FunD fGetFDataByIndex [getClause]+ , FunD fModifyFDataByIndex [modifyClause]+ , PragmaD $ inline fGetFDataByIndex+ , PragmaD $ inline fModifyFDataByIndex+ ]++generateFDataByIndexInstances :: [(Int, Int)] -> Q [Dec]+generateFDataByIndexInstances = mapM (uncurry generateFDataByIndexInstance)++-- | @generateUnconsFDataInstance n@ produces an instance of UnConsFData FData '[x1, ..., xn]+generateUnconsFDataInstance :: Int -> Q Dec+generateUnconsFDataInstance ((<1) -> True) = fail "generateUnconsFDataInstance: length must be at least 1"+generateUnconsFDataInstance n = do+ let className = mkName "UnConsFData"+ fData = mkName "FData"+ fDataNConName = fDataCon n+ fDataN'ConName = fDataCon (n-1)+ xNames = xTypeNames [1 .. n]+ x1Name = mkName "x1"+ fUnConsFData = mkName "unConsFData" -- unConsFData+ pure $ InstanceD Nothing [] (ConT className `AppT` ConT fData `AppT` promotedListTy (VarT <$> xNames))+ [ FunD+ fUnConsFData+ [ Clause+ [ ConP fDataNConName [] (VarP <$> xNames) ]+ (NormalB $ TupE+ [ Just (VarE x1Name)+ , Just $ foldl' AppE (ConE fDataN'ConName) (VarE <$> drop 1 xNames)+ ]+ )+ []+ ]+ , PragmaD $ inline fUnConsFData+ ]+ +generateUnconsFDataInstances :: [Int] -> Q [Dec]+generateUnconsFDataInstances = mapM generateUnconsFDataInstance++-- | @generateConsFData0Instance n@ produces an instance of ConsFData0 FData '[x1, ..., xn]+generateConsFData0Instance :: Int -> Q Dec+generateConsFData0Instance ((<1) -> True) = fail "generateConsFData0Instance: length must be at least 1"+generateConsFData0Instance n = do+ let className = mkName "ConsFData0"+ fData = mkName "FData"+ fDataNConName = fDataCon n+ fDataN'ConName = fDataCon (n-1)+ xTyNames = xTypeNames [1 .. n]+ xNames = xTypeNames [1 .. n-1]+ xName = mkName "x"+ fConsFData0 = mkName "consF0" -- consF0+ pure $ InstanceD Nothing [] (ConT className `AppT` ConT fData `AppT` promotedListTy (VarT <$> xTyNames))+ [ FunD+ fConsFData0+ [ Clause+ [ VarP xName+ , ConP fDataN'ConName [] (VarP <$> xNames)+ ]+ (NormalB $ foldl' AppE (ConE fDataNConName) (VarE xName : fmap VarE xNames))+ []+ ]+ , PragmaD $ inline fConsFData0+ ]++generateConsFData0Instances :: [Int] -> Q [Dec]+generateConsFData0Instances = mapM generateConsFData0Instance++-- | @generateConsFData1Instance n@ produces an instance of ConsFData1 FData '[x1, ..., xn]+generateConsFData1Instance :: Int -> Q Dec+generateConsFData1Instance ((<0) -> True) = fail "generateConsFData1Instance: length must be at least 0"+generateConsFData1Instance n = do+ let className = mkName "ConsFData1"+ fData = mkName "FData"+ fDataNConName = fDataCon n+ fDataN'ConName = fDataCon (n+1)+ xTyNames = xTypeNames [1 .. n]+ xNames = xTypeNames [1 .. n]+ xName = mkName "x"+ fConsFData1 = mkName "consF1" -- consF1+ pure $ InstanceD Nothing [] (ConT className `AppT` ConT fData `AppT` promotedListTy (VarT <$> xTyNames))+ [ FunD+ fConsFData1+ [ Clause+ [ VarP xName+ , ConP fDataNConName [] (VarP <$> xNames)+ ]+ (NormalB $ foldl' AppE (ConE fDataN'ConName) (VarE xName : fmap VarE xNames))+ []+ ]+ , PragmaD $ inline fConsFData1+ ]++generateConsFData1Instances :: [Int] -> Q [Dec]+generateConsFData1Instances = mapM generateConsFData1Instance++-- | @generateRemoveElemInstance n@ produces an instance of RemoveElem FData '[x1, ..., xn]+generateRemoveElemInstance :: Int -> Q Dec+generateRemoveElemInstance ((<1) -> True) = fail "generateRemoveElemInstance: length must be at least 1"+generateRemoveElemInstance n = do+ when (n < 1) $+ fail "generateRemoveElemInstance: list length must be ≥ 1"++ let tNames = xTypeNames [1 .. n]+ tVars = map VarT tNames+ listTy = promotedListTy tVars++ fRemoveElem = mkName "removeElem" -- removeElem+ cRemoveElem = mkName "RemoveElem" -- RemoveElem, the class name+ fUnRemoveElem = mkName "unRemoveElem" -- unRemoveElem++ instHead = ConT cRemoveElem `AppT` ConT (mkName "FData") `AppT` listTy++ clausesRemove = [ mkRemoveClause i | i <- [0 .. n-1] ]+ clausesUnRem = [ mkUnRemoveClause i | i <- [0 .. n-1] ]++ mkRemoveClause i =+ let conN = fDataCon n+ xs = xTypeNames [1 .. n] -- x1, x2, ..., xn+ patSFirstIndex = sFirstIndexPat i+ patFData = ConP conN [] $+ [ if j == i then WildP else VarP (xs !! j)+ | j <- [0 .. n-1] ]+ result = foldl AppE (ConE (fDataCon (n-1)))+ [ VarE (xs !! j) | j <- [0 .. n-1], j /= i ]+ in Clause [patSFirstIndex, patFData] (NormalB result) []++ mkUnRemoveClause i =+ let xNew = mkName "x" -- the element being re-inserted+ ys = xTypeNames [1 .. n-1] -- x1, x2, ..., xn-1+ tailCon = fDataCon (n-1)+ patSFirstIndex = sFirstIndexPat i+ patTail = ConP tailCon [] (map VarP ys)++ -- rebuild FData<n> with x inserted at position i+ fields = [ if j == i+ then VarE xNew+ else VarE (ys !! (if j < i then j else j-1))+ | j <- [0 .. n-1] ]+ result = foldl AppE (ConE (fDataCon n)) fields+ in Clause [patSFirstIndex, VarP xNew, patTail] (NormalB result) []++ pure $ InstanceD Nothing [] instHead+ [ FunD fRemoveElem clausesRemove+ , FunD fUnRemoveElem clausesUnRem+ , PragmaD $ inline fRemoveElem+ , PragmaD $ inline fUnRemoveElem+ ]+ where+ sFirstIndexPat :: Int -> Pat+ sFirstIndexPat 0 = ConP (mkName "SFirstIndexZero") [] []+ sFirstIndexPat i =+ ConP (mkName "SFirstIndexSucc") [] [ ConP (mkName "Refl") [] [] , sFirstIndexPat (i-1) ]++generateRemoveElemInstances :: [Int] -> Q [Dec]+generateRemoveElemInstances = mapM generateRemoveElemInstance
+ src/Data/TypeList/FList.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE UndecidableInstances #-}+module Data.TypeList.FList where++import Data.Coerce+import Data.Kind (Constraint, Type)+import Data.Type.Equality+import Data.TypeList.ConsFData+import Data.TypeList.Families++-- | A type-level list applied to a type-level function, representing a product.+-- It has a strict head and tail.+-- the ! bang pattern here is to make it strict because it might cause trouble when putting in a stateful monad.+data FList (f :: Type -> Type) (ts :: [Type]) where+ FNil :: FList f '[]+ FCons :: !(f t) -> !(FList f ts) -> FList f (t : ts)+infixr 5 `FCons`++newtype HBox a = HBox { unHBox :: a }++type HList = FList HBox++liftHBox :: (a -> b) -> HBox a -> HBox b+liftHBox = coerce+{-# INLINE liftHBox #-}++-- CList also becomes an example of FList+data CBox (constraint :: Type -> Constraint) (t :: Type) where+ CBox :: constraint t => !t -> CBox constraint t++type CList constraint = FList (CBox constraint)++type instance FDataConstraint FList e ts = ()++instance ConsFNil FList where+ fNil = FNil+ {-# INLINE fNil #-}++instance ConsFData FList where+ unConsF (x `FCons` xs) = (x, xs)+ {-# INLINE unConsF #-}++ consF x xs = x `FCons` xs+ {-# INLINE consF #-}++instance WhenNonEmpty ts (UnConsFData FList ts) => UnConsFData FList (t:ts) where+ unConsFData (x `FCons` xs) = (x, xs)+ {-# INLINE unConsFData #-}++instance WhenNonEmpty ts (ConsFData0 FList ts) => ConsFData0 FList (t:ts) where+ consF0 x xs = x `FCons` xs+ {-# INLINE consF0 #-}++instance When (NonEmpty ts) (ConsFData1 FList (Tail ts)) => ConsFData1 FList ts where+ consF1 x xs = x `FCons` xs+ {-# INLINE consF1 #-}++instance+ ( flist ~ FList+ , WhenNonEmpty ts (ConsFDataList flist (Tail ts))+ , ConsFNil flist+ , WhenNonEmpty ts (UnConsFData flist ts)+ , WhenNonEmpty ts (ConsFData0 flist ts)+ , ConsFData1 flist ts+ ) => ConsFDataList FList ts ++instance WhenNonEmpty ts (RemoveElem FList ts) => RemoveElem FList (t : ts) where+ removeElem SFirstIndexZero (_ `FCons` xs) = xs+ removeElem (SFirstIndexSucc Refl n) (x `FCons` xs) = x `FCons` removeElem n xs+ {-# INLINE removeElem #-}++ unRemoveElem SFirstIndexZero x xs = x `FCons` xs+ unRemoveElem (SFirstIndexSucc Refl n) x (y `FCons` ys) = y `FCons` unRemoveElem n x ys+ {-# INLINE unRemoveElem #-}
+ src/Data/TypeList/Families.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE UndecidableSuperClasses, PatternSynonyms, ViewPatterns, AllowAmbiguousTypes, UndecidableInstances, DataKinds, TypeOperators, LinearTypes, TypeFamilies, GADTs, PolyKinds, ScopedTypeVariables, ImpredicativeTypes #-}+-- | This module provides the fundational types and type families+--+-- This module is considered INTERNAL, you can use it but be aware that the API may change without major version bumps.+module Data.TypeList.Families where++import Data.Kind (Type, Constraint)+import Data.Type.Equality ((:~:)(..))+import GHC.TypeError+import Unsafe.Coerce (unsafeCoerce)++data Nat where+ Zero :: Nat+ Succ :: Nat -> Nat++data SNat (n :: Nat) where+ SZero :: SNat 'Zero+ SSucc :: SNat n -> SNat ('Succ n)++type family Head (ts :: [Type]) :: Type where+ Head (t ': ts) = t+ Head '[] = TypeError ('Text "Head: Empty list")++type family Tail (ts :: [Type]) :: [Type] where+ Tail (t ': ts) = ts+ Tail '[] = TypeError ('Text "Tail: Empty list")++-- | Proof of the existence of an element in a list.+data Elem e l where+ EZ :: Elem x (x : xs) -- ^ Base case: the element is the head of the list.+ ES :: Elem x ys -> Elem x (y : ys) -- ^ Inductive case: the element is in the tail of the list.++-- | A type-level function that concatenates two type-level lists.+type family (xs :: [Type]) ++ (ys :: [Type]) :: [Type] where+ '[] ++ bs = bs+ (a:as) ++ bs = a : (as ++ bs)++type family IfBool (b :: Bool) (t :: k) (e :: k) :: k where+ IfBool 'True a _ = a+ IfBool 'False _ b = b++type family When (b :: Bool) (c :: Constraint) :: Constraint where+ When bool c = IfBool bool c (() :: Constraint)++type WhenNonEmpty ts c = When (NonEmpty ts) c++type family AddIfNotElem (a :: Type) (bs :: [Type]) :: [Type] where+ AddIfNotElem a bs = IfBool (ElemIn a bs) bs (a ': bs)++class CheckIfElem (a :: Type) (bs :: [Type]) where+ singIfElem :: Either (ElemIn a bs :~: False) (ElemIn a bs :~: True, SFirstIndex a bs)++instance CheckIfElem a '[] where+ singIfElem = Left Refl+ {-# INLINE singIfElem #-}++instance CheckIfElem a (a ': xs) where+ singIfElem = Right (Refl, SFirstIndexZero)+ {-# INLINE singIfElem #-}++-- | Axiom, validity relies only on the instance resolution+axiomNotEqElem :: (NotEq a b) => ElemIn a bs :~: bool -> ElemIn a (b : bs) :~: bool+axiomNotEqElem _ = unsafeCoerce Refl+{-# INLINE axiomNotEqElem #-}++-- | Axiom, validity relies only on the instance resolution+firstIndexTraverseNotEqElemIn :: forall e t ts. (NotEq e t, ElemIn e ts ~ True) => FirstIndex e (t : ts) :~: Succ (FirstIndex e ts)+firstIndexTraverseNotEqElemIn = unsafeCoerce Refl+{-# INLINE firstIndexTraverseNotEqElemIn #-}++instance {-# OVERLAPPABLE #-} (NotEq a b, CheckIfElem a bs) => CheckIfElem a (b ': bs) where+ singIfElem = case singIfElem @a @bs of+ Left r@Refl -> case axiomNotEqElem @a @b @bs r of Refl -> Left Refl++ Right (r@Refl, SFirstIndexZero) -> case axiomNotEqElem @a @b @bs r of+ Refl -> case firstIndexTraverseNotEqElemIn @a @b @bs of+ Refl -> Right (Refl, SFirstIndexSucc Refl SFirstIndexZero)++ Right (r@Refl, SFirstIndexSucc Refl i) -> case axiomNotEqElem @a @b @bs r of+ Refl -> case firstIndexTraverseNotEqElemIn @a @b @bs of+ Refl -> Right (Refl, SFirstIndexSucc Refl (SFirstIndexSucc Refl i))+ {-# INLINE singIfElem #-}++type family ElemIn (a :: Type) (bs :: [Type]) :: Bool where+ ElemIn a '[] = 'False+ ElemIn a (a ': _) = 'True+ ElemIn a (_ ': xs) = ElemIn a xs++type family NotEq (a :: Type) (b :: Type) :: Constraint where+ NotEq a a = TypeError ('Text "Type " ':<>: 'ShowType a ':<>: 'Text " duplicated")+ NotEq a b = ()++type family NotIn (e :: Type) (ts :: [Type]) :: Constraint where+ NotIn e '[] = ()+ NotIn e (e ': ts) = TypeError ('Text "Type " ':<>: 'ShowType e ':<>: 'Text " is already in the list")+ NotIn e (t ': ts) = NotIn e ts++type family UniqueIn (e :: Type) (ts :: [Type]) :: Constraint where+ UniqueIn e '[] = ()+ UniqueIn e (e ': ts) = NotIn e ts+ UniqueIn e (t ': ts) = UniqueIn e ts++type family UniqueList (ts :: [Type]) :: Constraint where+ UniqueList '[] = ()+ UniqueList (t ': ts) = (NotIn t ts, UniqueList ts)++type family NonEmpty (ts :: [Type]) :: Bool where+ NonEmpty '[] = 'False+ NonEmpty (t ': ts) = 'True++type family Remove (e :: Nat) (ts :: [Type]) :: [Type] where+ Remove e '[] = '[]+ Remove Zero (t ': ts) = ts+ Remove (Succ n) (t ': ts) = t : Remove n ts++type family AtIndex (ts :: [Type]) (n :: Nat) :: Type where+ AtIndex (t ': ts) 'Zero = t+ AtIndex (t ': ts) ('Succ n) = AtIndex ts n+ AtIndex '[] _ = TypeError ('Text "AtIndex: Index out of bounds")++-- | Calculate the first index+type family FirstIndex (e :: Type) (ts :: [Type]) :: Nat where+ FirstIndex e (e ': ts) = 'Zero+ FirstIndex e (t ': ts) = 'Succ (FirstIndex e ts)+ FirstIndex e '[] = TypeError ('Text "Error evaluating Index: Type " ':<>: 'ShowType e ':<>: 'Text " is not in the list")++-- | due to unsaturated type family not implemented yet, please note that arr can only be data / data family+type family FmapMaybe (arr :: a -> b) (ma :: Maybe a) :: Maybe b where + FmapMaybe _ 'Nothing = 'Nothing+ FmapMaybe arr ('Just x) = 'Just (arr x)++type family FirstIndexMaybe (e :: Type) (ts :: [Type]) :: Maybe Nat where+ FirstIndexMaybe e (e ': ts) = 'Just 'Zero+ FirstIndexMaybe e (t ': ts) = FmapMaybe 'Succ (FirstIndexMaybe e ts)+ FirstIndexMaybe e '[] = 'Nothing++data SFirstIndex (e' :: Type) (ts' :: [Type]) where+ SFirstIndexZero :: SFirstIndex e (e ': ts) -- ^ Base case: the element is the head of the list.+ SFirstIndexSucc+ :: NonEmpty ts ~ 'True+ => !(FirstIndex e (t ': ts) :~: Succ (FirstIndex e ts)) -- ^ Takes a proof that the first index of e in (t ': ts) is one more than in ts.+ -> !(SFirstIndex e ts)+ -> SFirstIndex e (t ': ts) -- ^ Inductive case: the element is in the tail of the list.++singFirstIndexToSNat :: SFirstIndex e ts -> SNat (FirstIndex e ts)+singFirstIndexToSNat SFirstIndexZero = SZero+singFirstIndexToSNat (SFirstIndexSucc Refl s) = SSucc (singFirstIndexToSNat s)+{-# INLINE singFirstIndexToSNat #-}++type family FDataConstraint (flist :: (Type -> Type) -> [Type] -> Type) (e :: Type) (es :: [Type]) :: Constraint
+ src/Data/TypeList/UList.hs view
@@ -0,0 +1,9 @@+module Data.TypeList.UList where++import Data.Kind (Type)++-- | A type-level list applied to a type-level function, representing a sum.+data UList (f :: Type -> Type) (ts :: [Type]) where+ UNil :: UList f '[]+ UHead :: f t -> UList f (t : ts)+ UTail :: UList f ts -> UList f (t : ts)
+ src/Module/RS.hs view
@@ -0,0 +1,158 @@+-- | This module defines two modules (unit of effect) that provides reader and state functionality.+--+-- it can be used in the EffT monad transformer+module Module.RS where++import GHC.Generics (Generic)+import Control.DeepSeq (NFData)++import Control.Monad.Effect+import Data.Kind+import Data.TypeList+import Data.Bifunctor (second)+import GHC.TypeLits+import qualified Control.Monad.State as S++-- | A module that provides reader functionality+data RModule (r :: Type)++instance Module (RModule r) where+ newtype ModuleRead (RModule r) = RRead { rRead :: r }+ data ModuleState (RModule r) = RState deriving (Generic, NFData)++instance SystemModule (RModule r) where+ newtype ModuleInitData (RModule r) = RInitData { rInitRead :: r }+ data ModuleEvent (RModule r) = REvent++-- | A reader module that has a name+data RNamed (name :: Symbol) (r :: Type)++instance Module (RNamed name r) where+ newtype ModuleRead (RNamed name r) = RNamedRead { rNamedRead :: r }+ data ModuleState (RNamed name r) = RNamedState deriving (Generic, NFData)++instance SystemModule (RNamed name r) where+ newtype ModuleInitData (RNamed name r) = RNamedInitData { rNamedInitRead :: r }+ data ModuleEvent (RNamed name r) = RNamedEvent++-- | A module that provides state functionality+data SModule (s :: Type)++instance Module (SModule s) where+ data ModuleRead (SModule s) = SRead+ newtype ModuleState (SModule s) = SState { sState :: s } deriving newtype (Generic, NFData)++instance SystemModule (SModule s) where+ newtype ModuleInitData (SModule s) = SInitData { sInitState :: s }+ data ModuleEvent (SModule s) = SEvent++-- | A state module that has a name+data SNamed (name :: Symbol) (s :: Type)+instance Module (SNamed name s) where+ data ModuleRead (SNamed name s) = SNamedRead+ newtype ModuleState (SNamed name s) = SNamedState { sNamedState :: s } deriving newtype (Generic, NFData)++instance SystemModule (SNamed name s) where+ newtype ModuleInitData (SNamed name s) = SNamedInitData { sNamedInitState :: s }+ data ModuleEvent (SNamed name s) = SNamedEvent++embedStateT :: forall s mods errs m c a. (Monad m, In' c (SModule s) mods) => S.StateT s (EffT' c mods errs m) a -> EffT' c mods errs m a+embedStateT action = do+ SState s <- getModule @(SModule s)+ (a, s') <- S.runStateT action s+ putModule @(SModule s) (SState s')+ return a+{-# INLINE embedStateT #-}++addStateT :: forall s mods errs m c a.+ ( SubList c mods (SModule s : mods)+ , SModule s `NotIn` mods+ , In' c (SModule s) (SModule s : mods)+ , Monad m+ )+ => S.StateT s (EffT' c mods errs m) a -> EffT' c (SModule s : mods) errs m a+addStateT action = do+ SState s <- getModule @(SModule s)+ (a, s') <- embedEffT $ S.runStateT action s+ putModule (SState s')+ return a+{-# INLINE addStateT #-}++asStateT :: forall s mods errs m c a.+ ( In' c (SModule s) mods+ , SModule s `UniqueIn` mods+ , SubList c (Remove (FirstIndex (SModule s) mods) mods) mods+ , Monad m+ )+ => S.StateT s (EffT' c (Remove (FirstIndex (SModule s) mods) mods) errs m) a -> EffT' c mods errs m a+asStateT action = do+ SState s <- getModule+ (a, s') <- embedEffT $ S.runStateT action s+ putModule (SState s')+ return a+{-# INLINE asStateT #-}++runRModule :: (ConsFDataList c (RModule r : mods), Monad m) => r -> EffT' c (RModule r : mods) errs m a -> EffT' c mods errs m a+runRModule r = runEffTOuter_ (RRead r) RState+{-# INLINE runRModule #-}++runRModuleIn :: (ConsFDataList c mods, RemoveElem c mods, Monad m, In' c (RModule r) mods) => r -> EffT' c mods es m a -> EffT' c (Remove (FirstIndex (RModule r) mods) mods) es m a+runRModuleIn r = runEffTIn_ (RRead r) RState+{-# INLINE runRModuleIn #-}++-- | Warning: state will lose when you have an error+runSModule :: (ConsFDataList c (SModule s : mods), Monad m) => s -> EffT' c (SModule s : mods) errs m a -> EffT' c mods errs m (a, s)+runSModule s+ = fmap (second $ \(SState s') -> s')+ . runEffTOuter SRead (SState s)+{-# INLINE runSModule #-}++runSModuleIn :: (ConsFDataList c mods, RemoveElem c mods, Monad m, In' c (SModule s) mods) => s -> EffT' c mods es m a -> EffT' c (Remove (FirstIndex (SModule s) mods) mods) es m (a, s)+runSModuleIn s+ = fmap (second (\(SState s') -> s'))+ . runEffTIn SRead (SState s)+{-# INLINE runSModuleIn #-}++runSModule_ :: (ConsFDataList c (SModule s : mods), Monad m) => s -> EffT' c (SModule s : mods) errs m a -> EffT' c mods errs m a+runSModule_ s = runEffTOuter_ SRead (SState s)+{-# INLINE runSModule_ #-}++askR :: forall r mods errs m c. (Monad m) => (In' c (RModule r) mods) => EffT' c mods errs m r+askR = do+ RRead r <- askModule @(RModule r)+ return r+{-# INLINE askR #-}++asksR :: forall r mods errs m c a. (Monad m) => (In' c (RModule r) mods) => (r -> a) -> EffT' c mods errs m a+asksR f = do+ RRead r <- askModule @(RModule r)+ return (f r)+{-# INLINE asksR #-}++localR :: forall r mods errs m c a. (Monad m, In' c (RModule r) mods) => (r -> r) -> EffT' c mods errs m a -> EffT' c mods errs m a+localR f = localModule (\(RRead r) -> RRead (f r))+{-# INLINE localR #-}++getS :: forall s mods errs m c. (Monad m, In' c (SModule s) mods) => EffT' c mods errs m s+getS = do+ SState s <- getModule @(SModule s)+ return s+{-# INLINE getS #-}++getsS :: forall s mods errs m c a. (Monad m, In' c (SModule s) mods) => (s -> a) -> EffT' c mods errs m a+getsS f = do+ SState s <- getModule @(SModule s)+ return (f s)+{-# INLINE getsS #-}++putS :: forall s mods errs c m. (Monad m, In' c (SModule s) mods) => s -> EffT' c mods errs m ()+putS s = do+ SState _ <- getModule @(SModule s)+ putModule @(SModule s) (SState s)+{-# INLINE putS #-}++modifyS :: forall s mods errs c m. (Monad m, In' c (SModule s) mods) => (s -> s) -> EffT' c mods errs m ()+modifyS f = do+ s <- getS+ putS (f s)+{-# INLINE modifyS #-}
+ src/Module/RS/QQ.hs view
@@ -0,0 +1,622 @@+{-# LANGUAGE RecordWildCards, OverloadedRecordDot #-}+-- | This module provides Template Haskell utilities for generating RModules and SModules with fixed type+--+-- The `makeRModule` function generates a reader module, for example+--+-- given the following information:+--+-- [makeRModule|MyModule+-- myRecord1 :: !MyType1+-- myRecord2 :: MyType2+-- |]+--+-- it should generate+--+-- @+-- data MyModule+--+-- type MyModuleRead = ModuleRead MyModule+--+-- instance Module MyModule where+-- data ModuleRead MyModule = MyModuleRead { myRecord1 :: !MyType1, myRecord2 :: MyType2 }+-- data ModuleState MyModule = MyModuleState deriving (Generic, NFData)+--+-- runMyModule :: (ConsFDataList c mods, Monad m) => ModuleRead MyModule -> EffT' c (MyModule : mods) errs m a -> EffT' mods errs m a+-- runMyModule r = runEffTOuter_ r MyModuleState+-- {-# INLINE runMyModule #-}+--+-- runRModuleIn :: (ConsFDataList c mods, RemoveElem c mods, Monad m, In' c MyModule mods) => ModuleRead MyModule -> EffT' c mods es m a -> EffT' c (Remove (FirstIndex MyModule mods) mods) es m a+-- runRModuleIn r = runEffTIn_ r MyModuleState+-- {-# INLINE runMyModuleIn #-}+-- @+--+--+-- @+-- [makeRSModule|+-- MyRSModule+-- Read myField1 :: !MyType1+-- Read myField2 :: MyType2+-- State myStateField1 :: !MyStateType1+-- State myStateField2 :: MyStateType2+-- |]+-- @+--+-- it should generate+--+-- * data MyRSModule+-- * generate data instances for Module <MyModule>+-- * generate run<MyModule>, run<MyModule>', run<MyModule>_ and run<MyModule>In, run<MyModule>In', run<MyModule>In_ functions+-- * generate type synonym for ModuleRead <MyModule> and ModuleState <MyModule>+module Module.RS.QQ+ ( makeRModule, makeRModule_, makeRModule__+ , makeRSModule, makeRSModule_+ ) where++import Control.DeepSeq (NFData)+import Control.Monad+import Control.Monad.Effect+import Data.Default+import Data.Either+import Data.TypeList+import GHC.Generics (Generic)+import Language.Haskell.Meta.Parse+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Text.Parsec++data DataConsSpec = DataConsSpec+ { dataConsName :: Name+ , dataFields :: [(Name, Bool, Type)] -- ^ (fieldName, strictness, fieldType)+ }+ deriving Show++data RSModuleSpec = RSModuleSpec+ { typeName :: Name+ , readSpec :: DataConsSpec+ , stateSpec :: DataConsSpec+ }+ deriving Show++data GenerationConfig = GenerationConfig+ { deriveConfigs :: [DeriveConfig]+ , generateSystemInstance :: Bool -- ^ Only for RModule+ }++instance Default GenerationConfig where+ def = GenerationConfig+ { deriveConfigs = [ConfigDeriveGeneric, ConfigDeriveNFData]+ , generateSystemInstance = True+ }++-- | Generates all the boilerplate declarations for a reader-like module.+--+-- Includes:+--+-- * data MyModule+--+-- * instance Module MyModule+--+-- * instance SystemModule MyModule+--+-- * runMyModule+--+-- * runMyModuleIn+--+-- * A type synonym `type MyModuleRead = ModuleRead MyModule`+--+makeRModuleConf :: GenerationConfig -> QuasiQuoter+makeRModuleConf conf = QuasiQuoter+ { quoteExp = error "makeRModule: should be used as top-level declaration only, not as an expression"+ , quotePat = error "makeRModule: should be used as top-level declaration only, not as a pattern"+ , quoteType = error "makeRModule: should be used as top-level declaration only, not as a type"+ , quoteDec = parseRModule conf+ }++makeRSModuleConf :: GenerationConfig -> QuasiQuoter+makeRSModuleConf conf = QuasiQuoter+ { quoteExp = error "makeRSModule: should be used as top-level declaration only, not as an expression"+ , quotePat = error "makeRSModule: should be used as top-level declaration only, not as a pattern"+ , quoteType = error "makeRSModule: should be used as top-level declaration only, not as a type"+ , quoteDec = parseRSModule conf+ }++makeRModule, makeRModule_, makeRModule__, makeRSModule, makeRSModule_ :: QuasiQuoter+-- | Make RModule with Generic and NFData derivations, and SystemModule instance+makeRModule = makeRModuleConf $ GenerationConfig [ConfigDeriveGeneric, ConfigDeriveNFData] True+-- | Make RModule without any derivations, but with SystemModule instance+makeRModule_ = makeRModuleConf $ GenerationConfig [] True+-- | Make RModule without any derivations and without SystemModule instance+makeRModule__ = makeRModuleConf $ GenerationConfig [] False+-- | Make RSModule with Generic and NFData derivations+makeRSModule = makeRSModuleConf $ GenerationConfig [ConfigDeriveGeneric, ConfigDeriveNFData] False+-- | Make RSModule without any derivations+makeRSModule_ = makeRSModuleConf $ GenerationConfig [] False++data DeriveConfig = ConfigDeriveGeneric | ConfigDeriveNFData+ deriving (Show, Eq)++parseRModule :: GenerationConfig -> String -> Q [Dec]+parseRModule conf input = do+ let spec = runIdentity $ runParserT (many parseDataConsSpec) () "parseRModule" input+ case spec of+ Left err -> fail $ "Failed to parse RModule: " ++ show err+ Right rModuleSpecs -> concat <$> mapM (generateRModule conf) rModuleSpecs++parseRSModule :: GenerationConfig -> String -> Q [Dec]+parseRSModule conf input = do+ let spec = runIdentity $ runParserT parseRSModuleSpec () "parseRSModule" input+ case spec of+ Left err -> fail $ "Failed to parse RSModule: " ++ show err+ Right rsModuleSpec -> generateRSModule conf rsModuleSpec++parseDataConsSpec :: ParsecT String () Identity DataConsSpec+parseDataConsSpec = do+ spaces+ name <- parseModuleName+ void $ manyTill space endOfLine+ fields <- many (many1 space >> parseField)+ return $ DataConsSpec name fields++-- @+-- MyRSModule+-- Read myField1 :: !MyType1+-- Read myField2 :: MyType2+-- State myStateField1 :: !MyStateType1+-- State myStateField2 :: MyStateType2+-- @+parseRSModuleSpec :: ParsecT String () Identity RSModuleSpec+parseRSModuleSpec = do+ spaces+ modName <- parseModuleName+ let readName = mkName $ nameBase modName ++ "Read"+ stateName = mkName $ nameBase modName ++ "State"+ void $ manyTill space endOfLine+ eitherFields <- many (try (many1 space >> optional (string "Read" >> many1 space) >> Left <$> parseField)+ <|> (many1 space >> string "State" >> many1 space >> Right <$> parseField)+ )+ return $ RSModuleSpec+ { typeName = modName+ , readSpec = DataConsSpec readName $ lefts eitherFields+ , stateSpec = DataConsSpec stateName $ rights eitherFields+ }++parseModuleName :: ParsecT String () Identity Name+parseModuleName = do+ upperHead <- upper+ rest <- many (alphaNum <|> char '_')+ let moduleName = upperHead : rest+ pure $ mkName moduleName++parseField :: ParsecT String () Identity (Name, Bool, Type)+parseField = do+ fieldName <- parseFieldName+ spaces >> char ':' >> char ':' >> spaces+ strictness <- option False (True <$ char '!')+ typeString <- manyTill anyChar (try (eof <|> void endOfLine))+ case parseType typeString of+ Left err -> fail $ "Failed to parse type: " ++ show err+ Right type' -> return (fieldName, strictness, type')+ where+ parseFieldName = mkName <$> do+ lowerHead <- lower+ rest <- many (alphaNum <|> char '_' <|> char '\'')+ pure $ lowerHead : rest++-------------------------------------------------------------------------------+-- Code generation+-------------------------------------------------------------------------------+deriveG :: DerivClause+deriveG = DerivClause (Just StockStrategy) [ConT ''Generic]++deriveNF :: DerivClause+deriveNF = DerivClause (Just AnyclassStrategy) [ConT ''NFData]++mkBang :: Bool -> Bang+mkBang True = Bang NoSourceUnpackedness SourceStrict+mkBang False = Bang NoSourceUnpackedness NoSourceStrictness++updateBang :: (a, Bool, b) -> (a, Bang, b)+updateBang (a, b, c) = (a, mkBang b, c)++appendName :: String -> (Name, a, b) -> (Name, a, b)+appendName suffix (name, a, b) =+ (mkName $ nameBase name ++ suffix, a, b)++inlinePragma :: Name -> Dec+inlinePragma name = PragmaD $ InlineP name Inline FunLike AllPhases++data DataInstanceSpec = DataInstanceSpec+ { dataFamilyType :: Type+ , dataFamilyInputType :: Type+ , dataFamilyConstructor :: DataConsSpec+ , dataFamilyDerivations :: [DerivClause]+ } deriving Show++-- | Generate a data family instance declaration. +-- Automatically switch to newtype if there is only one record field with strictness enabled.+dataInstance :: DataInstanceSpec -> Dec+dataInstance DataInstanceSpec{..} =+ case dataFields dataFamilyConstructor of+ [(_, True, _)] ->+ NewtypeInstD [] Nothing+ (AppT dataFamilyType dataFamilyInputType)+ Nothing+ (RecC (dataConsName dataFamilyConstructor) $ cancelBang <$> dataFields dataFamilyConstructor)+ dataFamilyDerivations+ _ ->+ DataInstD [] Nothing+ (AppT dataFamilyType dataFamilyInputType)+ Nothing+ [RecC (dataConsName dataFamilyConstructor) $ updateBang <$> dataFields dataFamilyConstructor]+ dataFamilyDerivations+ where cancelBang (a, _, c) = (a, mkBang False, c)++-- * generate data instances for Module <MyModule>+-- * generate run<MyModule>, run<MyModule>', run<MyModule>_ and run<MyModule>In, run<MyModule>In', run<MyModule>In_ functions+-- * generate type synonym for ModuleRead <MyModule> and ModuleState <MyModule>+generateRSModule :: GenerationConfig -> RSModuleSpec -> Q [Dec]+generateRSModule GenerationConfig { deriveConfigs = dconf } RSModuleSpec{typeName, readSpec, stateSpec} = do+ let deriveGeneric = [deriveG | ConfigDeriveGeneric `elem` dconf]+ -- deriveNFData = [deriveNF | ConfigDeriveNFData `elem` dconf]++ let warnStateNonStrict = any (\(_, strictness, _) -> not strictness) (dataFields stateSpec)++ when warnStateNonStrict $ reportWarning+ $ "The state record for the module " <> nameBase typeName+ <> " has non-strict fields. This may lead to lazy thunk leaks in case of infinite updates without evaluation."++ let dataTag = DataD [] typeName [] Nothing [] []++ instanceModule = InstanceD Nothing [] (AppT (ConT ''Module) (ConT typeName))+ [ dataInstance DataInstanceSpec+ { dataFamilyType = ConT ''ModuleRead+ , dataFamilyInputType = ConT typeName+ , dataFamilyConstructor = readSpec+ , dataFamilyDerivations = deriveGeneric+ }+ , dataInstance DataInstanceSpec+ { dataFamilyType = ConT ''ModuleState+ , dataFamilyInputType = ConT typeName+ , dataFamilyConstructor = stateSpec+ , dataFamilyDerivations = deriveGeneric+ }+ ]+ typeSynRead = TySynD (dataConsName readSpec) [] (ConT ''ModuleRead `AppT` ConT typeName)+ typeSynState = TySynD (dataConsName stateSpec) [] (ConT ''ModuleState `AppT` ConT typeName)++ runMyModuleName = mkName $ "run" ++ nameBase typeName+ runMyModule'Name = mkName $ "run" ++ nameBase typeName ++ "'"+ runMyModule_Name = mkName $ "run" ++ nameBase typeName ++ "_"+ runMyModuleInName = mkName $ "run" ++ nameBase typeName ++ "In"+ runMyModuleIn'Name = mkName $ "run" ++ nameBase typeName ++ "In'"+ runMyModuleIn_Name = mkName $ "run" ++ nameBase typeName ++ "In_"++{-+runEffTOuter :: forall mod mods es m c a. (ConsFDataList c (mod : mods), ConsFData1 c mods, Monad m)+ => ModuleRead mod -> ModuleState mod -> EffT' c (mod : mods) es m a -> EffT' c mods es m (a, ModuleState mod)+ +runEffTOuter' :: forall mod mods es m c a. (ConsFDataList c (mod : mods), ConsFData1 c mods, Monad m)+ => ModuleRead mod -> ModuleState mod -> EffT' c (mod : mods) es m a -> EffT' c mods NoError m (Result es a, ModuleState mod)++runEffTOuter_ :: forall mod mods es m c a. (ConsFDataList c (mod : mods), ConsFData1 c mods, Monad m)+ => ModuleRead mod -> ModuleState mod -> EffT' c (mod : mods) es m a -> EffT' c mods es m a++runEffTIn :: forall mod mods es m c a. (RemoveElem c mods, Monad m, In' c mod mods)+ => ModuleRead mod -> ModuleState mod -> EffT' c mods es m a+ -> EffT' c (Remove (FirstIndex mod mods) mods) es m (a, ModuleState mod)++runEffTIn' :: forall mod mods es m c a. (RemoveElem c mods, Monad m, In' c mod mods)+ => ModuleRead mod -> ModuleState mod -> EffT' c mods es m a+ -> EffT' c (Remove (FirstIndex mod mods) mods) NoError m (Result es a, ModuleState mod)++runEffTIn_ :: forall mod mods es m c a. (RemoveElem c mods, Monad m, In' c mod mods)+ => ModuleRead mod -> ModuleState mod -> EffT' c mods es m a+ -> EffT' c (Remove (FirstIndex mod mods) mods) es m a+-}++ modsN = mkName "mods"+ errsN = mkName "errs"+ mN = mkName "m"+ cN = mkName "c"+ aN = mkName "a"+ modsT = VarT modsN+ errsT = VarT errsN+ mT = VarT mN+ cT = VarT cN+ aT = VarT aN+ effTTy = ConT ''EffT+ effT'Ty = ConT ''EffT'+ noErrorT = ConT ''NoError+ myModuleAndMods = ConT '(:) `AppT` ConT typeName `AppT` modsT+ moduleReadMyModule = ConT ''ModuleRead `AppT` ConT typeName+ moduleStateMyModule = ConT ''ModuleState `AppT` ConT typeName++ runMyModuleSig = SigD runMyModuleName $+ ForallT [ PlainTV modsN SpecifiedSpec, PlainTV errsN SpecifiedSpec+ , PlainTV mN SpecifiedSpec, PlainTV aN SpecifiedSpec+ ]+ [ AppT (ConT ''Monad) mT+ , ConT ''ConsFDataList `AppT` ConT ''FData `AppT` (ConT '(:) `AppT` ConT typeName `AppT` modsT)+ ]+ ( moduleReadMyModule `arr` moduleStateMyModule `arr` (effTTy `AppT` myModuleAndMods `AppT` errsT `AppT` mT `AppT` aT) `arr`+ (effTTy `AppT` modsT `AppT` errsT `AppT` mT `AppT` (ConT ''(,) `AppT` aT `AppT` moduleStateMyModule))+ )++ runMyModule'Sig = SigD runMyModule'Name $+ ForallT [ PlainTV modsN SpecifiedSpec, PlainTV errsN SpecifiedSpec+ , PlainTV mN SpecifiedSpec, PlainTV aN SpecifiedSpec+ ]+ [ AppT (ConT ''Monad) mT+ , ConT ''ConsFDataList `AppT` ConT ''FData `AppT` (ConT '(:) `AppT` ConT typeName `AppT` modsT)+ ]+ ( moduleReadMyModule `arr` moduleStateMyModule `arr` (effTTy `AppT` myModuleAndMods `AppT` errsT `AppT` mT `AppT` aT) `arr`+ (effTTy `AppT` modsT `AppT` noErrorT `AppT` mT `AppT` (ConT ''(,) `AppT` (ConT ''Result `AppT` errsT `AppT` aT) `AppT` moduleStateMyModule))+ )++ runMyModule_Sig = SigD runMyModule_Name $+ ForallT [ PlainTV modsN SpecifiedSpec, PlainTV errsN SpecifiedSpec+ , PlainTV mN SpecifiedSpec, PlainTV aN SpecifiedSpec+ ]+ [ AppT (ConT ''Monad) mT+ , ConT ''ConsFDataList `AppT` ConT ''FData `AppT` (ConT '(:) `AppT` ConT typeName `AppT` modsT)+ ]+ ( moduleReadMyModule `arr` moduleStateMyModule `arr` (effTTy `AppT` myModuleAndMods `AppT` errsT `AppT` mT `AppT` aT) `arr`+ (effTTy `AppT` modsT `AppT` errsT `AppT` mT `AppT` aT)+ )++ runMyModuleInSig = SigD runMyModuleInName $+ ForallT [ PlainTV modsN SpecifiedSpec, PlainTV errsN SpecifiedSpec+ , PlainTV mN SpecifiedSpec, PlainTV cN SpecifiedSpec, PlainTV aN SpecifiedSpec+ ]+ [ ConT ''RemoveElem `AppT` cT `AppT` modsT+ , ConT ''Monad `AppT` mT+ , ConT ''In' `AppT` cT `AppT` ConT typeName `AppT` modsT+ ]+ ( moduleReadMyModule `arr` moduleStateMyModule `arr`+ (effT'Ty `AppT` cT `AppT` modsT `AppT` errsT `AppT` mT `AppT` aT) `arr`+ (effT'Ty `AppT` cT `AppT` (ConT ''Remove `AppT` (ConT ''FirstIndex `AppT` ConT typeName `AppT` modsT) `AppT` modsT) `AppT`+ errsT `AppT` mT `AppT` (ConT ''(,) `AppT` aT `AppT` moduleStateMyModule))+ )++ runMyModuleIn'Sig = SigD runMyModuleIn'Name $+ ForallT [ PlainTV modsN SpecifiedSpec, PlainTV errsN SpecifiedSpec+ , PlainTV mN SpecifiedSpec, PlainTV cN SpecifiedSpec, PlainTV aN SpecifiedSpec+ ]+ [ ConT ''RemoveElem `AppT` cT `AppT` modsT+ , ConT ''Monad `AppT` mT+ , ConT ''In' `AppT` cT `AppT` ConT typeName `AppT` modsT+ ]+ ( moduleReadMyModule `arr` moduleStateMyModule `arr`+ (effT'Ty `AppT` cT `AppT` modsT `AppT` errsT `AppT` mT `AppT` aT) `arr`+ (effT'Ty `AppT` cT `AppT` (ConT ''Remove `AppT` (ConT ''FirstIndex `AppT` ConT typeName `AppT` modsT) `AppT` modsT) `AppT`+ noErrorT `AppT` mT `AppT` (ConT ''(,) `AppT` (ConT ''Result `AppT` errsT `AppT` aT) `AppT` moduleStateMyModule))+ )++ runMyModuleIn_Sig = SigD runMyModuleIn_Name $+ ForallT [ PlainTV modsN SpecifiedSpec, PlainTV errsN SpecifiedSpec+ , PlainTV mN SpecifiedSpec, PlainTV cN SpecifiedSpec, PlainTV aN SpecifiedSpec+ ]+ [ ConT ''RemoveElem `AppT` cT `AppT` modsT+ , ConT ''Monad `AppT` mT+ , ConT ''In' `AppT` cT `AppT` ConT typeName `AppT` modsT+ ]+ ( moduleReadMyModule `arr` moduleStateMyModule `arr`+ (effT'Ty `AppT` cT `AppT` modsT `AppT` errsT `AppT` mT `AppT` aT) `arr`+ (effT'Ty `AppT` cT `AppT` (ConT ''Remove `AppT` (ConT ''FirstIndex `AppT` ConT typeName `AppT` modsT) `AppT` modsT) `AppT` errsT `AppT` mT `AppT` aT)+ )++ runMyModuleFun = FunD runMyModuleName+ [ Clause [VarP (mkName "r"), VarP (mkName "s")]+ (NormalB (VarE 'runEffTOuter `AppE`+ VarE (mkName "r") `AppE`+ VarE (mkName "s")))+ []+ ]+ runMyModule'Fun = FunD runMyModule'Name+ [ Clause [VarP (mkName "r"), VarP (mkName "s")]+ (NormalB $ VarE 'runEffTOuter' `AppE`+ VarE (mkName "r") `AppE`+ VarE (mkName "s")+ )+ []+ ]+ runMyModule_Fun = FunD runMyModule_Name+ [ Clause [VarP (mkName "r"), VarP (mkName "s")]+ (NormalB $ VarE 'runEffTOuter_ `AppE`+ VarE (mkName "r") `AppE`+ VarE (mkName "s")+ )+ []+ ]+ runMyModuleInFun = FunD runMyModuleInName+ [ Clause [VarP (mkName "r"), VarP (mkName "s")]+ (NormalB $ VarE 'runEffTIn `AppE`+ VarE (mkName "r") `AppE`+ VarE (mkName "s")+ )+ []+ ]+ runMyModuleIn'Fun = FunD runMyModuleIn'Name+ [ Clause [VarP (mkName "r"), VarP (mkName "s")]+ (NormalB $ VarE 'runEffTIn' `AppE`+ VarE (mkName "r") `AppE`+ VarE (mkName "s")+ )+ []+ ]+ runMyModuleIn_Fun = FunD runMyModuleIn_Name+ [ Clause [VarP (mkName "r"), VarP (mkName "s")]+ (NormalB $ VarE 'runEffTIn_ `AppE`+ VarE (mkName "r") `AppE`+ VarE (mkName "s")+ )+ []+ ]++ return [ dataTag+ , instanceModule+ , typeSynRead+ , typeSynState+ , runMyModuleSig , runMyModuleFun , inlinePragma runMyModuleName+ , runMyModule'Sig , runMyModule'Fun , inlinePragma runMyModule'Name+ , runMyModule_Sig , runMyModule_Fun , inlinePragma runMyModule_Name+ , runMyModuleInSig , runMyModuleInFun , inlinePragma runMyModuleInName+ , runMyModuleIn'Sig , runMyModuleIn'Fun , inlinePragma runMyModuleIn'Name+ , runMyModuleIn_Sig , runMyModuleIn_Fun , inlinePragma runMyModuleIn_Name+ ]++generateRModule :: GenerationConfig -> DataConsSpec -> Q [Dec]+generateRModule GenerationConfig{ deriveConfigs = dconf, generateSystemInstance } DataConsSpec{dataConsName = modName, dataFields} = do+ let deriveGeneric = [deriveG | ConfigDeriveGeneric `elem` dconf]+ deriveNFData = [deriveNF | ConfigDeriveNFData `elem` dconf]+ ---------------------------------------------------------------------------+ -- Helper names+ ---------------------------------------------------------------------------+ let readConName = mkName $ nameBase modName ++ "Read"+ readTy = ConT ''ModuleRead `AppT` ConT modName+ stateConName = mkName $ nameBase modName ++ "State"+ eventConName = mkName $ nameBase modName ++ "Event"+ initDataConName = mkName $ nameBase modName ++ "InitData"+ runName = mkName $ "run" ++ nameBase modName+ runInName = mkName $ "run" ++ nameBase modName ++ "In"++ ---------------------------------------------------------------------------+ -- data <MyModule>+ ---------------------------------------------------------------------------+ let tagDec = DataD [] modName [] Nothing [] []++ ---------------------------------------------------------------------------+ -- the associated data instances inside `instance Module <MyModule>`+ --+ -- and `instance SystemModule <MyModule>`+ --+ -- when there is only one record, automatically switch to newtype instead+ ---------------------------------------------------------------------------+ let instanceModule = InstanceD Nothing [] (AppT (ConT ''Module) (ConT modName))+ [ dataInstance DataInstanceSpec+ { dataFamilyType = ConT ''ModuleRead+ , dataFamilyInputType = ConT modName+ , dataFamilyConstructor = DataConsSpec { dataConsName = readConName, dataFields = dataFields }+ , dataFamilyDerivations = deriveGeneric+ }+ , dataInstance DataInstanceSpec+ { dataFamilyType = ConT ''ModuleState+ , dataFamilyInputType = ConT modName+ , dataFamilyConstructor = DataConsSpec { dataConsName = stateConName, dataFields = [] }+ , dataFamilyDerivations = deriveGeneric <> deriveNFData+ }+ ]++ let instanceSystemModule = InstanceD Nothing [] (ConT ''SystemModule `AppT` ConT modName)+ [ dataInstance DataInstanceSpec+ { dataFamilyType = ConT ''ModuleEvent+ , dataFamilyInputType = ConT modName+ , dataFamilyConstructor = DataConsSpec { dataConsName = eventConName, dataFields = [] }+ , dataFamilyDerivations = deriveGeneric <> deriveNFData+ }+ , dataInstance DataInstanceSpec+ { dataFamilyType = ConT ''ModuleInitData+ , dataFamilyInputType = ConT modName+ , dataFamilyConstructor = DataConsSpec { dataConsName = initDataConName, dataFields = appendName "Init" <$> dataFields }+ , dataFamilyDerivations = deriveGeneric+ }+ ]++ ---------------------------------------------------------------------------+ -- run<MyModule>+ ---------------------------------------------------------------------------+ modsTv <- newName "mods"+ errsTv <- newName "errs"+ mTv <- newName "m"+ aTv <- newName "a"++ let modsV = VarT modsTv+ errsV = VarT errsTv+ mV = VarT mTv+ aV = VarT aTv++ consMods = PromotedConsT `AppT` ConT modName `AppT` modsV+ eff4 = foldl AppT (ConT ''EffT)++ runSigType =+ ForallT [ PlainTV modsTv SpecifiedSpec, PlainTV errsTv SpecifiedSpec+ , PlainTV mTv SpecifiedSpec, PlainTV aTv SpecifiedSpec ]+ [ AppT (ConT ''Monad) mV+ , ConT ''ConsFDataList `AppT` ConT ''FData `AppT` (ConT '(:) `AppT` ConT modName `AppT` modsV)+ ]+ (readTy `arr`+ eff4 [consMods, errsV, mV, aV] `arr`+ eff4 [modsV , errsV, mV, aV])++ runSig <- sigD runName (pure runSigType)+ runFun <- funD runName+ [ clause [varP (mkName "r")]+ (normalB (varE 'runEffTOuter_ `appE`+ varE (mkName "r") `appE`+ conE stateConName))+ []+ ]+ runPrag <- pragInlD runName Inline FunLike AllPhases++ ---------------------------------------------------------------------------+ -- run<MyModule>In+ ---------------------------------------------------------------------------+ cTv <- newName "c"+ esTv <- newName "es"++ let cV = VarT cTv+ esV = VarT esTv++ eff5 = foldl AppT (ConT ''EffT')++ removeMods =+ AppT (AppT (ConT ''Remove)+ (AppT (AppT (ConT ''FirstIndex) (ConT modName)) modsV))+ modsV++ ctx = [ AppT (AppT (ConT ''ConsFDataList) cV) modsV+ , AppT (AppT (ConT ''RemoveElem) cV) modsV+ , AppT (ConT ''Monad) mV+ , AppT (AppT (AppT (ConT ''In') cV) (ConT modName)) modsV+ ]++ runInSigType =+ ForallT [ PlainTV modsTv SpecifiedSpec, PlainTV esTv SpecifiedSpec+ , PlainTV mTv SpecifiedSpec, PlainTV cTv SpecifiedSpec, PlainTV aTv SpecifiedSpec ]+ ctx+ (readTy `arr`+ eff5 [cV, modsV, esV, mV, aV] `arr`+ eff5 [cV, removeMods, esV, mV, aV])++ runInSig <- sigD runInName (pure runInSigType)+ runInFun <- funD runInName+ [ clause [varP (mkName "r")]+ (normalB (varE 'runEffTIn_ `appE`+ varE (mkName "r") `appE`+ conE stateConName))+ []+ ]+ runInPrag <- pragInlD runInName Inline FunLike AllPhases++ ---------------------------------------------------------------------------+ -- Type synonym for ModuleRead+ ---------------------------------------------------------------------------++ let typeSyn = TySynD readConName [] readTy++ pure $ [ tagDec+ , instanceModule+ ] <>+ [ instanceSystemModule | generateSystemInstance ]+ <>+ [ runSig , runFun , runPrag+ , runInSig , runInFun, runInPrag+ , typeSyn+ ]++-------------------------------------------------------------------------------+-- Helpers (TH arrow type)+-------------------------------------------------------------------------------+arr :: Type -> Type -> Type+arr = AppT . AppT ArrowT+infixr 5 `arr`
+ src/Module/Resource.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-orphans #-}+-- | Provides ResourceT functionality for managing resources+module Module.Resource where++import Control.Monad.Effect+import Control.Monad.Trans.Resource+import Control.Monad.Trans.Resource.Internal+import Control.System+import Data.Default+import Data.IORef+import GHC.Generics (Generic)++data Resource++instance Module Resource where+ newtype ModuleRead Resource = ResourceRead { resourceRead :: IORef (ReleaseMap) }+ data ModuleState Resource = ResourceState++instance SystemModule Resource where+ data ModuleInitData Resource = ResourceInitData deriving (Generic, Default)+ data ModuleEvent Resource = ResourceEvent++-- | Not really orphan because it is EffT'+instance (In' c Resource mods, MonadIO m) => MonadResource (EffT' c mods es m) where+ liftResourceT = \ResourceT{unResourceT} -> do+ rMap <- asksModule resourceRead+ liftIO $ unResourceT rMap++instance Loadable c Resource mods where+ initModule _ = do+ istate <- createInternalState+ return (ResourceRead istate, ResourceState)
+ test/Examples.hs view
@@ -0,0 +1,61 @@+module Examples where++import Control.Exception+import Control.Monad+import Control.Monad.Effect -- the EffT types and useful combinators+import Module.RS -- built in modules, a reader module and a state module+import System.IO+import qualified Data.Map as M+import qualified Data.Text as T++-- $ our monad-effect provides **module management** and **composable exceptions**+-- it's algebraic, performant, make sense, without sacrificing purity++-- | Wraps your effectul routine into EffT monad transformer+myLookup :: (Show k, Ord k, Monad m) => k -> EffT '[SModule (M.Map k v)] '[ErrorText "Map.keyNotFound"] m v+myLookup k+ = effMaybeInWith (errorText @"Map.keyNotFound" $ " where key = " <> T.show k) -- wraps Maybe into an exception+ $ getsS (M.lookup k) -- this just returns a monadic value of type `Maybe v`++-- | This effect can run in pure monads! like Identity+lookups :: forall v m. (Monad m) => EffT '[SModule (M.Map T.Text v)] '[ErrorText "Map.keyNotFound"] m (v, v, v)+lookups = do+ foo <- myLookup "foo" -- this will throw an exception if "foo" is not found+ bar <- myLookup "bar" -- instead of Nothing, you get an algebraic exception `ErrorText "Map.keyNotFound"` explaining what went wrong+ baz <- myLookup "baz" -- just like Maybe and Either, when an exception is thrown, the computation stops and immediately returns+ return (foo, bar, baz)++parse :: String -> Maybe [Double]+parse = undefined++computeAverageFromFile+ :: FilePath+ -> Eff+ '[SModule (M.Map T.Text Int)] -- this effect can read and modify a value of type (Map Text Int)+ [ IOException -- composable and explicit exceptions+ , ErrorText "empty-file" -- you know what types of error this effect can produce+ , ErrorText "zero-numbers" -- just by observing its type signature+ , ErrorText "Map.keyNotFound"+ ]+ Double -- return type+computeAverageFromFile fp = do+ -- | the `liftIOException :: IO a -> Eff '[] '[IOException] a` captures `IOException`+ content <- embedError . liftIOException $ readFile' fp++ -- | throw an Algebraic error instead of an exception that you have no idea+ when (null content) $ do+ effThrowIn ("file is empty" :: ErrorText "empty-file")++ -- | this `pureMaybeInWith :: In e es => e -> Maybe a -> Eff mods es a` turns a Maybe value into an ad-hoc exception type!+ parsed <- pureMaybeInWith ("parse error" :: ErrorText "parse-error") (parse content) + `effCatch` (\(_ :: ErrorText "parse-error") -> return [0])+ -- ^ you can catch exception and deal with it, so the error is eliminated from the list++ -- | The type system will check whether you have the module needed to perform this action+ _ <- embedEffT $ lookups @Int++ -- | The type system will force you remember that we can return an exception with an custom type `ErrorText "zero-numbers"`+ when (null parsed) $ do+ effThrowIn ("zero numbers" :: ErrorText "zero-numbers")++ return $ sum parsed / fromIntegral (length parsed)
+ test/Main.hs view
@@ -0,0 +1,194 @@+{-# OPTIONS_GHC -fconstraint-solver-iterations=100 -Wno-partial-type-signatures -fmax-worker-args=16 #-}+{-# LANGUAGE DataKinds, GADTs, PartialTypeSignatures #-}+module Main where++import Control.Monad.Effect as ME+import Control.Monad+import Criterion.Main+import Data.TypeList+import Data.TypeList.FData as ME+import Module.RS as ME+import Module.RS.QQ+import qualified Control.Monad.State as S++-- The test result shows that for FList there is around (k+1) ns overhead for fetching the k-th state inside the effect system+-- for typical applications with 8 modules,+-- the expected monad access & bind is around 5 ns, which is around 200000000 access & binds per second.+--+-- This means the overhead is completely neglegible in actual applications with effects.+--+-- But of course, in a very very tight loop, you should avoid using Eff, use a single layer of StateT or+-- embed your computation as pure functions.+--+--+-- For FData, the overhead can be eliminated and GHC optimize it very very well+-- even without any optimizations, the speed is 10 times faster than FList+--+-- with -O2 -flate-dmd-anal it can optimize to a minimal hand-written fast loop!++programMonadEffect :: ME.In (ME.SModule Int) mods => ME.EffT mods ME.NoError ME.Identity Int+programMonadEffect = do+ x <- ME.getS @Int+ if x == 0+ then pure x+ else do+ ME.putS (x - 1)+ programMonadEffect++programMonadEffectTH' :: ME.In Countdown mods => ME.EffT mods ME.NoError ME.Identity Int+programMonadEffectTH' = do+ x <- ME.getsModule countdown+ if x == 0+ then pure x+ else do+ ME.putModule (CountdownState (x - 1))+ programMonadEffectTH'++countdownMonadEffect :: Int -> (Int, _)+countdownMonadEffect n =+ ME.runIdentity $ ME.runEffTNoError (ME.FData1 ME.SRead) (ME.FData1 $ ME.SState n) programMonadEffect++countdownMonadEffectDeep7 :: Int -> (Int, _)+countdownMonadEffectDeep7 n = ME.runIdentity $+ ME.runEffTNoError+ (ME.FData7 readUnit readUnit readUnit SRead readUnit readUnit readUnit) --readUnit SRead readUnit readUnit readUnit readUnit readUnit)+ (ME.FData7 rStateUnit rStateUnit rStateUnit (ME.SState n) rStateUnit rStateUnit rStateUnit) --rStateUnit rStateUnit rStateUnit)+ programMonadEffect+ where readUnit = ME.RRead ()+ rStateUnit = ME.RState++countdownMonadEffectDeep11 :: Int -> (Int, _)+countdownMonadEffectDeep11 n = ME.runIdentity $+ ME.runEffTNoError+ (ME.FData15 readUnit readUnit SRead readUnit readUnit readUnit readUnit readUnit readUnit readUnit readUnit readUnit readUnit readUnit readUnit)+ (ME.FData15 rStateUnit rStateUnit (ME.SState n) rStateUnit rStateUnit rStateUnit rStateUnit rStateUnit rStateUnit rStateUnit rStateUnit rStateUnit rStateUnit rStateUnit rStateUnit)+ programMonadEffect+ where readUnit = ME.RRead ()+ rStateUnit = ME.RState++[makeRSModule|+Countdown+ State countdown :: !Int+|]++countdownMonadEffectTH :: Int -> (Int, _)+countdownMonadEffectTH n = ME.runIdentity $+ ME.runEffTNoError+ (ME.FData1 CountdownRead)+ (ME.FData1 $ CountdownState n)+ programMonadEffectTH'++testEffStateFPoly :: _ => EffT' flist '[RModule (), SModule Int, SModule Bool] NoError IO ()+testEffStateFPoly = do+ x <- getS @Int+ modifyS not+ when (x < 1_000_000) $ putS (x + 1) >> testEffStateFPoly++testMtlState :: S.StateT ((), Int, Bool) IO ()+testMtlState = do+ x <- S.gets (\(_, x, _) -> x)+ S.modify (\(_, x', b) -> ((), x', not b))+ when (x < 1_000_000) $ do+ S.modify (\(_, _, b) -> ((), x + 1, b))+ testMtlState++testEffStateAs :: Eff '[SModule Int] NoError ()+testEffStateAs = asStateT @Int $ S.mapStateT liftIO loop+ where loop = do+ x <- S.get+ when (x < 1_000_000) $ do+ S.put (x + 1)+ loop++testEffEmbed :: _ => EffT' flist '[RModule (), SModule Int, SModule Bool] NoError IO ()+testEffEmbed = do+ x <- embedMods @'[SModule Int] $ do+ x <- getS @Int+ putS (x + 1)+ return x+ when (x < 1_000_000) $ do+ modifyS not+ testEffEmbed++main :: IO ()+main = do+ putStrLn "Some sanity checks"++ let testFList :: FList Maybe '[Int]+ testFList = Just 1 :** FNil++ unConsHead = fst . unConsF $ testFList++ print unConsHead++ print $ getIn @_ @Int testFList++ _ <- runEffTNoError+ (SRead :** FNil)+ (SState (0 :: Int) :** FNil)+ ( do+ liftIO $ putStrLn "Running initial state test"+ x <- getS @Int+ liftIO $ putStrLn $ "Initial state get: " ++ show x+ putS (x + 1)+ liftIO $ putStrLn "State updated"+ y <- getS @Int+ liftIO $ putStrLn $ "State after update: " ++ show y+ if y == x + 1+ then liftIO $ putStrLn "State updated correctly"+ else liftIO $ putStrLn "State updated incorrectly"+ )++ defaultMain+ [ bgroup "Bind"+ [ bench "bind" $ whnfIO $ runEffTNoError+ (SRead :** FNil)+ (SState (0 :: Int) :** FNil)+ ( do+ x <- getS @Int+ putS (x + 1)+ y <- getS @Int+ if y == x + 1+ then return ()+ else liftIO $ putStrLn "State updated incorrectly"+ )+ ]+ , bgroup "Countdown"+ [ bench "Monad Effect" $ nf countdownMonadEffect 1_000_000+ , bench "Monad Effect Deep 7" $ nf countdownMonadEffectDeep7 1_000_000+ , bench "Monad Effect Deep 11" $ nf countdownMonadEffectDeep11 1_000_000+ , bench "Monad Effect TH" $ nf (fst . countdownMonadEffectTH) 1_000_000+ ]+ , bgroup "State Effect Eff"+ [ bench "FList" $ whnfIO $ runEffTNoError+ (RRead () `FCons` SRead `FCons` SRead `FCons` FNil)+ (RState `FCons` SState 0 `FCons` SState False `FCons` FNil)+ testEffStateFPoly+ , bench "FData" $ whnfIO $ runEffTNoError+ (FData3 (RRead ()) SRead SRead)+ (FData3 RState (SState 0) (SState False))+ testEffStateFPoly+ ]+ , bgroup "Embed Eff functionality"+ [ bench "FList" $ whnfIO $ runEffTNoError+ (RRead () `FCons` SRead `FCons` SRead `FCons` FNil)+ (RState `FCons` SState 0 `FCons` SState False `FCons` FNil)+ testEffEmbed+ , bench "FData" $ whnfIO $ runEffTNoError+ (FData3 (RRead ()) SRead SRead)+ (FData3 RState (SState 0) (SState False))+ testEffEmbed+ ]+ , bgroup "Mtl State"+ [ bench "StateT" $ whnfIO $ S.runStateT testMtlState ((), 0, False)+ ]+ , bgroup "Embed tight computation in Eff"+ [ bench "EmbedEff" $ whnfIO $ runEffTNoError FNil FNil $ liftIO $ S.runStateT testMtlState ((), 0, False)+ ]+ , bgroup "State Effect As StateT"+ [ bench "Eff" $ whnfIO $ runEffTNoError+ (FData1 SRead)+ (FData1 $ SState 0)+ testEffStateAs+ ]+ ]
+ test/TH.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE DeriveAnyClass #-}+module TH where++import Module.RS.QQ++[makeRModule|+MyModule+ field1 :: !Int+ field2 :: Bool+|]++[makeRSModule|+MyRSModule+ readField :: !Int+ State stateField :: !Int+|]