cleff (empty) → 0.1.0.0
raw patch · 36 files changed
+3093/−0 lines, 36 filesdep +QuickCheckdep +atomic-primopsdep +base
Dependencies added: QuickCheck, atomic-primops, base, cleff, containers, exceptions, extra, hspec, lifted-base, microlens, monad-control, primitive, template-haskell, th-abstraction, transformers, transformers-base, unliftio
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +128/−0
- cleff.cabal +238/−0
- example/Broker.hs +31/−0
- example/Filesystem.hs +50/−0
- example/Main.hs +8/−0
- example/Teletype.hs +77/−0
- src/Cleff.hs +160/−0
- src/Cleff/Error.hs +142/−0
- src/Cleff/Fail.hs +35/−0
- src/Cleff/Fresh.hs +36/−0
- src/Cleff/Input.hs +47/−0
- src/Cleff/Internal/Base.hs +181/−0
- src/Cleff/Internal/Effect.hs +26/−0
- src/Cleff/Internal/Interpret.hs +201/−0
- src/Cleff/Internal/Monad.hs +59/−0
- src/Cleff/Internal/TH.hs +126/−0
- src/Cleff/Mask.hs +57/−0
- src/Cleff/Output.hs +48/−0
- src/Cleff/Reader.hs +46/−0
- src/Cleff/State.hs +68/−0
- src/Cleff/Trace.hs +52/−0
- src/Cleff/Writer.hs +68/−0
- src/Data/Any.hs +19/−0
- src/Data/Mem.hs +78/−0
- src/Data/Rec.hs +390/−0
- test/ConcurrencySpec.hs +44/−0
- test/ErrorSpec.hs +38/−0
- test/HigherOrderSpec.hs +36/−0
- test/InterposeSpec.hs +30/−0
- test/Main.hs +1/−0
- test/MaskSpec.hs +190/−0
- test/RecSpec.hs +100/−0
- test/StateSpec.hs +119/−0
- test/ThSpec.hs +129/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for `cleff`++## 0.1.0.0++- Initial API
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Xy Ren (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Xy Ren nor the names of other contributors+ may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,128 @@+# `cleff` - fast and concise extensible effects++[](https://github.com/re-xyr/cleff/actions/workflows/build.yaml)+[](https://hackage.haskell.org/package/cleff)++`cleff` is an extensible effects library for Haskell, with a focus on the balance of performance, expressiveness and ease of use. It provides a set of predefined effects that you can conveniently reuse in your program, as well as low-boilerplate mechanisms for defining and interpreting new domain-specific effects on your own.++## Overview++Different from [many](`polysemy`) [previous](`fused-effects`) [libraries](`freer-simple`), `cleff` does not use techniques like Freer monads or monad transformers. Instead, the `Eff` monad is esentially a `ReaderT IO`, which provides predictable semantics and reliable performance. The only caveat is that `cleff` does not support nondeterminism and continuations in the `Eff` monad - but after all, [most effects libraries has broken nondeterminism support](https://github.com/polysemy-research/polysemy/issues/246), and we encourage users to wrap another monad transformer with support of nondeterminism (e.g. `ListT`) over the main `Eff` monad in such cases.++### Performance++`cleff`'s `Eff` monad is esentially implemented as a `ReaderT IO`. This concrete formulation [allows more GHC optimizations to fire][alexis-talk], and brings lower performance overhead. This is first done by [`eff`], and then [`effectful`]; it proved to work, so we followed this path.++[In microbenchmarks](#benchmarks), `cleff` outperforms [`polysemy`], and is slightly behind [`effectful`]. However, note that `effectful` and `cleff` have very different design principles. While `effectful` prioritizes performance over anything else (by [providing static dispatch](https://github.com/arybczak/effectful/blob/master/effectful-core/src/Effectful/Reader/Static.hs)), `cleff` focuses on balancing expressivity and performance. If you would like minimal performance overhead, consider [`effectful`].++### Low-boilerplate++`cleff` supports user-defined effects and provides simple yet flexible API for that. Users familiar with [`polysemy`], [`freer-simple`] or [`effectful`] will find it very easy to get along with `cleff`. `cleff`'s effect interpretation API include:++- Arbitrary lifting and subsumption of effects+- Interpreting and reinterpreting, without needing to distinguish first-order and higher-order interpreters like `polysemy`+- *Translation* of effects, i.e. handling an effect in terms of a simple transformation into another effect, as seen in `polysemy`'s `rewrite` and `freer-simple`'s `translate`++### Predictable semantics++Traditional effect libraries have many surprising behaviors, such as [`mtl` reverts state when an error is thrown][alexis-talk-2], and [more so when interacting with `IO`][readert]. By implementing `State` and `Writer` as `IORef` operations, and `Error` as `Exceptions`, `cleff` is able to interact well with `IO` and provide semantics that are predictable in the presence of concurrency and exceptions. Moreover, any potentially surprising behavior is carefully documented for each effect.++### Higher-order effects++*Higher-order* effects are effects that take monadic computations. They are often useful in real world applications, as examples of higher-order effect operations include `local`, `catchError` and `mask`. Implementing higher-order effects is often tedious, or even not supported in some effect libraries. `polysemy` is the first library that aims to provide easy higher-order effects mechanicsm with its [`Tactics`](https://hackage.haskell.org/package/polysemy-1.7.1.0/docs/Polysemy.html#g:16) API. Following its path, `cleff` provides a set of combinators that can be used to implement higher-order effects. These combinators are as expressive as `polysemy`'s, and are also easier to use correctly.++## Example++This is the code that defines `Teletype` effect. It only takes 20 lines to define the effect and two interpretations, one using stdio and another reading from and writing to a list:++```haskell+import Cleff+import Cleff.Input+import Cleff.Output+import Cleff.State+import Data.Maybe (fromMaybe)++-- Effect definition+data Teletype :: Effect where+ ReadTTY :: Teletype m String+ WriteTTY :: String -> Teletype m ()+makeEffect ''Teletype++-- Effect Interpretation via IO+runTeletypeIO :: IOE :> es => Eff (Teletype ': es) a -> Eff es a+runTeletypeIO = interpretIO \case+ ReadTTY -> getLine+ WriteTTY s -> putStrLn s++-- Effect interpretation via other pure effects+runTeletypePure :: [String] -> Eff (Teletype ': es) w -> Eff es [String]+runTeletypePure tty = fmap (reverse . snd)+ . runState [] . outputToListState+ . runState tty . inputToListState+ . reinterpret2 \case+ ReadTTY -> fromMaybe "" <$> input+ WriteTTY msg -> output msg++-- Using the effect++echo :: Teletype :> es => Eff es ()+echo = do+ x <- readTTY+ if null x then pure ()+ else writeTTY x >> echo++echoPure :: [String] -> [String]+echoPure input = runPure $ runTeletypePure input echo++main :: IO ()+main = runIOE $ runTeletypeIO echo+```++See [`example/`](https://github.com/re-xyr/cleff/tree/master/example/) for more examples.++## Benchmarks++These are the results of the [effect-zoo](https://github.com/ocharles/effect-zoo) microbenchmarks, compiled by GHC 8.10.7. Keep in mind that these are *very short and synthetic programs*, and may or may not tell the accurate performance characteristics of different effect libraries in real use:++- `big-stack`: +- `countdown`: +- `file-sizes`: +- `reinterpretation`: ++## References++These are the useful resourses that inspired this library's design and implementation.++Papers:++- [Extensible Effect: An Alternative to Monad Transformers](https://okmij.org/ftp/Haskell/extensible/exteff.pdf) by Oleg Kiselyov, Amr Sabry, and Cameron Swords.+- [Freer Monads, More Extensible Effects](https://okmij.org/ftp/Haskell/extensible/more.pdf) by Oleg Kiselyov, and Hiromi Ishii.++Libraries:++- [`eff`] by Alexis King and contributors.+- [`effectful`] by Andrzej Rybczak and contributors.+- [`freer-simple`] by Alexis King and contributors.+- [`polysemy`] by Sandy Maguire and contributors.++Talks:++- [Effects for Less][alexis-talk] by Alexis King.+- [Unresolved challenges of scoped effects, and what that means for `eff`][alexis-talk-2] by Alexis King.++Blog posts:++- [Asynchronous Exception Handling in Haskell](https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/) by Michael Snoyman.+- [Polysemy: Mea Culpa](https://reasonablypolymorphic.com/blog/mea-culpa/) by Sandy Maguire.+- [Polysemy Internals: The Effect-Interpreter Effect](https://reasonablypolymorphic.com/blog/tactics/) by Sandy Maguire.+- [ReaderT design pattern][readert] by Michael Snoyman.+- [Safe exception handling](https://www.fpcomplete.com/haskell/tutorial/exceptions/) by Michael Snoyman.++[`polysemy`]: https://hackage.haskell.org/package/polysemy+[`fused-effects`]: https://hackage.haskell.org/package/fused-effects+[`effectful`]: https://github.com/arybczak/effectful+[`eff`]: https://github.com/hasura/eff+[`freer-simple`]: https://hackage.haskell.org/package/freer-simple+[alexis-talk]: https://www.youtube.com/watch?v=0jI-AlWEwYI+[alexis-talk-2]: https://www.twitch.tv/videos/1163853841+[readert]: https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/
+ cleff.cabal view
@@ -0,0 +1,238 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: cleff+version: 0.1.0.0+synopsis: Fast and concise extensible effects+description: Please see the README on GitHub at <https://github.com/re-xyr/cleff#readme>+category: Control, Effect, Language+homepage: https://github.com/re-xyr/cleff#readme+bug-reports: https://github.com/re-xyr/cleff/issues+author: Xy Ren+maintainer: xy.r@outlook.com+copyright: 2021 Xy Ren+license: BSD3+license-file: LICENSE+build-type: Simple+tested-with:+ GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+extra-source-files:+ CHANGELOG.md+ README.md++source-repository head+ type: git+ location: https://github.com/re-xyr/cleff++flag dynamic-ioe+ description: Make @IOE@ a real effect. This is only for reference purposes and should not be enabled in production code.++ manual: True+ default: False++library+ exposed-modules:+ Cleff+ Cleff.Error+ Cleff.Fail+ Cleff.Fresh+ Cleff.Input+ Cleff.Internal.Base+ Cleff.Internal.Effect+ Cleff.Internal.Interpret+ Cleff.Internal.Monad+ Cleff.Internal.TH+ Cleff.Mask+ Cleff.Output+ Cleff.Reader+ Cleff.State+ Cleff.Trace+ Cleff.Writer+ Data.Any+ Data.Mem+ Data.Rec+ other-modules:+ Paths_cleff+ hs-source-dirs:+ src+ default-extensions:+ BangPatterns+ BlockArguments+ ConstraintKinds+ DataKinds+ DerivingVia+ EmptyCase+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ NoStarIsType+ PatternSynonyms+ PolyKinds+ QuantifiedConstraints+ RankNTypes+ RoleAnnotations+ ScopedTypeVariables+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ UnicodeSyntax+ ViewPatterns+ ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wpartial-fields -Wunused-type-patterns -Wmissing-export-lists+ build-depends:+ atomic-primops ==0.8.*+ , base >=4.12 && <5+ , containers ==0.6.*+ , exceptions ==0.10.*+ , microlens >=0.4.9 && <0.5+ , monad-control >=1 && <1.1+ , primitive >=0.6 && <0.8+ , template-haskell >=2.14 && <3+ , th-abstraction >=0.2.11 && <0.5+ , transformers >=0.5 && <0.7+ , transformers-base >=0.4.5 && <0.5+ , unliftio >=0.2.8 && <0.3+ if flag(dynamic-ioe)+ cpp-options: -DDYNAMIC_IOE+ default-language: Haskell2010++test-suite cleff-example+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Broker+ Filesystem+ Teletype+ Paths_cleff+ hs-source-dirs:+ example+ default-extensions:+ BangPatterns+ BlockArguments+ ConstraintKinds+ DataKinds+ DerivingVia+ EmptyCase+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ NoStarIsType+ PatternSynonyms+ PolyKinds+ QuantifiedConstraints+ RankNTypes+ RoleAnnotations+ ScopedTypeVariables+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ UnicodeSyntax+ ViewPatterns+ DeriveAnyClass+ ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wpartial-fields -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ atomic-primops ==0.8.*+ , base >=4.12 && <5+ , cleff+ , containers ==0.6.*+ , exceptions ==0.10.*+ , extra+ , microlens >=0.4.9 && <0.5+ , monad-control >=1 && <1.1+ , primitive >=0.6 && <0.8+ , template-haskell >=2.14 && <3+ , th-abstraction >=0.2.11 && <0.5+ , transformers >=0.5 && <0.7+ , transformers-base >=0.4.5 && <0.5+ , unliftio >=0.2.8 && <0.3+ if flag(dynamic-ioe)+ cpp-options: -DDYNAMIC_IOE+ default-language: Haskell2010++test-suite cleff-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ ConcurrencySpec+ ErrorSpec+ HigherOrderSpec+ InterposeSpec+ MaskSpec+ RecSpec+ StateSpec+ ThSpec+ Paths_cleff+ hs-source-dirs:+ test+ default-extensions:+ BangPatterns+ BlockArguments+ ConstraintKinds+ DataKinds+ DerivingVia+ EmptyCase+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ NoStarIsType+ PatternSynonyms+ PolyKinds+ QuantifiedConstraints+ RankNTypes+ RoleAnnotations+ ScopedTypeVariables+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ UnicodeSyntax+ ViewPatterns+ DeriveAnyClass+ DeriveGeneric+ ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wpartial-fields -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , atomic-primops ==0.8.*+ , base >=4.12 && <5+ , cleff+ , containers ==0.6.*+ , exceptions ==0.10.*+ , extra+ , hspec+ , lifted-base+ , microlens >=0.4.9 && <0.5+ , monad-control >=1 && <1.1+ , primitive >=0.6 && <0.8+ , template-haskell >=2.14 && <3+ , th-abstraction >=0.2.11 && <0.5+ , transformers >=0.5 && <0.7+ , transformers-base >=0.4.5 && <0.5+ , unliftio >=0.2.8 && <0.3+ if flag(dynamic-ioe)+ cpp-options: -DDYNAMIC_IOE+ default-language: Haskell2010
+ example/Broker.hs view
@@ -0,0 +1,31 @@+module Broker where++import Cleff+import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (void)++nestedImpl :: Int -> (String -> (Bool -> IO ()) -> IO ()) -> IO ()+nestedImpl i cb = void . forkIO $ do+ threadDelay $ 1 * 1000 * 1000+ cb (show i) \b -> putStrLn $ "result " ++ show b++data Broker :: Effect where+ Subscribe :: Int -> (String -> m Bool) -> Broker m ()++subscribe :: Broker :> es => Int -> (String -> Eff es Bool) -> Eff es ()+subscribe channel = send . Subscribe channel++runBroker :: IOE :> es => Eff (Broker : es) a -> Eff es a+runBroker = interpret \case+ Subscribe channel cb -> withToIO \toIO -> do+ putStrLn $ "Subscribe: " ++ show channel+ nestedImpl channel \s icb -> icb =<< toIO (cb s)++prog :: (IOE :> es, Broker :> es) => Eff es ()+prog = do+ subscribe 1 \_ -> pure True+ subscribe 2 \_ -> pure False+ liftIO $ threadDelay $ 3 * 1000 * 1000++runProg :: IO ()+runProg = runIOE $ runBroker prog
+ example/Filesystem.hs view
@@ -0,0 +1,50 @@+-- | This module is adapted from https://github.com/arybczak/effectful/blob/master/effectful/examples/FileSystem.hs,+-- originally BSD3 license, authors Andrzej Rybczak et al.+module Filesystem where++import Cleff+import Cleff.Error+import Cleff.State+import Control.Monad.Extra (maybeM)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import qualified System.IO as IO+import UnliftIO.Exception++-- * Effect++-- | An effect for reading and writing files.+data Filesystem :: Effect where+ ReadFile :: FilePath -> Filesystem m String+ WriteFile :: FilePath -> String -> Filesystem m ()++-- * Operations++makeEffect ''Filesystem++-- * Interpretations++-- | File system error.+newtype FsError = FsError String+ deriving stock (Show)+ deriving anyclass (Exception)++-- | Run the 'Filesystem' effect with actual file IO.+runFilesystemIO :: '[IOE, Error FsError] :>> es => Eff (Filesystem ': es) a -> Eff es a+runFilesystemIO = interpret \case+ ReadFile path -> adapt $ IO.readFile path+ WriteFile path contents -> adapt $ IO.writeFile path contents+ where+ adapt m = liftIO m `catch` \(e :: IOException) -> throwError $ FsError $ show e++-- | Run the 'Filesystem' effect with a faked filesystem.+runFilesystemPure :: Error FsError :> es => Map FilePath String -> Eff (Filesystem ': es) a -> Eff es a+runFilesystemPure fs = fmap fst . runState fs . reinterpret \case+ ReadFile path -> maybeM (throwError $ FsError $ "File not found: " ++ show path) pure $ gets (M.lookup path)+ WriteFile path contents -> modify $ M.insert path contents++f :: Either FsError (Either FsError String)+f = runPure $ runError @FsError $ runFilesystemPure M.empty $ runError @FsError $ Filesystem.readFile "nonexistent"++-- >>> f+-- Left (FsError "File not found: \"nonexistent\"")
+ example/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import Broker (runProg)++main :: IO ()+main = do+ putStrLn "This is cleff's example module! Browse /example to get started with the library."+ runProg
+ example/Teletype.hs view
@@ -0,0 +1,77 @@+-- | This module is adapted from https://github.com/polysemy-research/polysemy/blob/master/README.md,+-- originally BSD3 license, authors Sandy Maguire et al.+module Teletype where++import Cleff+import Cleff.Error+import Cleff.Input+import Cleff.Mask+import Cleff.Output+import Cleff.State+import Control.Exception (Exception)+import Control.Monad (unless)+import Data.Maybe (fromMaybe)++-- * Effect++-- | An effect for reading and writing lines to a tty.+data Teletype :: Effect where+ ReadTTY :: Teletype m String+ WriteTTY :: String -> Teletype m ()++-- * Operations++makeEffect ''Teletype++-- * Interpretations++-- | Run 'Teletype' via stdio.+runTeletypeIO :: IOE :> es => Eff (Teletype ': es) a -> Eff es a+runTeletypeIO = interpretIO \case+ ReadTTY -> getLine+ WriteTTY s -> putStrLn s++-- | Run 'Teletype' from a fixed input list.+runTeletypePure :: [String] -> Eff (Teletype ': es) w -> Eff es [String]+runTeletypePure tty = fmap (reverse . snd)+ . runState [] . outputToListState+ . runState tty . inputToListState+ . reinterpret2 \case+ ReadTTY -> fromMaybe "" <$> input+ WriteTTY msg -> output msg++-- * Examples++-- | An echoing program.+echo :: Teletype :> es => Eff es ()+echo = do+ x <- readTTY+ unless (null x) $+ writeTTY x >> echo++-- | The pure interpretation of 'echo', via 'runTeletypePure'.+-- >>> echoPure ["abc", "def", "ghci"]+-- ["abc","def","ghci"]+echoPure :: [String] -> [String]+echoPure tty = runPure $ runTeletypePure tty echo++-- | The impure interpretation of 'echo', via 'runTeletypeIO'.+echoIO :: IO ()+echoIO = runIOE $ runTeletypeIO echo++data CustomException = ThisException | ThatException+ deriving stock (Show)+ deriving anyclass (Exception)++program :: '[Mask, Teletype, Error CustomException] :>> es => Eff es ()+program = catchError @CustomException work \e -> writeTTY $ "Caught " ++ show e+ where+ work = bracket readTTY (const $ writeTTY "exiting bracket") \next -> do+ writeTTY "entering bracket"+ case next of+ "explode" -> throwError ThisException+ "weird stuff" -> writeTTY next *> throwError ThatException+ _ -> writeTTY next *> writeTTY "no exceptions"++main :: IO (Either CustomException ())+main = runIOE $ runMask $ runError @CustomException $ runTeletypeIO program
+ src/Cleff.hs view
@@ -0,0 +1,160 @@+-- | This library implements an /extensible effects system/, where sets of monadic actions ("effects") are encoded as+-- datatypes, tracked at the type level and can have multiple different implementations. This means you can swap out+-- implementations of certain monadic actions in mock tests or in different environments. The notion of "effect" is+-- general here: it can be an 'IO'-performing side effect, or just obtaining the value of a static global environment.+--+-- In particular, this library consists of+--+-- * The 'Eff' monad, which is the core of an extensible effects system. All effects are performed within it and it+-- will be the "main" monad of your application. This monad tracks effects at the type level.+-- * A set of predefined general effects, like 'Cleff.Reader.Reader' and 'Cleff.State.State' that can be used out of+-- the box.+-- * Combinators for defining new effects and interpreting them /on your own/. These effects can be translated in terms+-- of other already existing effects, or into operations in the 'IO' monad.+--+-- So, this library allows you to do two things:+--+-- * __Effect management:__ The 'Eff' monad tracks what effects are used explicitly at the type level, therefore you+-- are able to be certain about what effects are involved in each function.+-- * __Effect decoupling:__ You can decouple the implementation of the effects from your application and swap them+-- easily.+module Cleff+ ( -- * Using effects+ Eff, (:>), (:>>), Effect, IOE+ , -- ** Running effects+ -- $runningEffects+ runPure, runIOE+ , -- * Defining effects+ -- $definingEffects+ send, makeEffect, makeEffect_+ , -- * Trivial effects handling+ raise, raiseN, inject, subsume, subsumeN, KnownList, Subset+ , -- * Interpreting effects+ -- $interpretingEffects+ Handler, interpret, reinterpret, reinterpret2, reinterpret3, reinterpretN, interpose, impose, imposeN+ , -- ** Interpreting in terms of 'IO'+ HandlerIO, interpretIO+ , -- ** Translating effects+ Translator, transform, translate+ , -- * Combinators for interpreting higher order effects+ -- $higherOrderEffects+ Handling, toEff, toEffWith, withFromEff+ , -- ** Interpreting 'IO'-related higher order effects+ withToIO, fromIO+ , -- * Miscellaneous+ type (~>), type (++), MonadIO (..), MonadUnliftIO (..)+ ) where++import Cleff.Internal.Base+import Cleff.Internal.Effect+import Cleff.Internal.Interpret+import Cleff.Internal.Monad+import Cleff.Internal.TH+import UnliftIO (MonadIO (liftIO), MonadUnliftIO (withRunInIO))++-- $runningEffects+-- To run an effect @T@, we should use an /interpreter/ of @T@, which is a function that has type like this:+--+-- @+-- runT :: 'Eff' (T ': es) a -> 'Eff' es a+-- @+--+-- Such an interpreter provides an implementation of @T@ and eliminates @T@ from the effect stack. All builtin effects+-- in @cleff@ have interpreters coming together with them.+--+-- By applying interpreters to an 'Eff' computation, you can eventually obtain an /end computation/, where there are no+-- more effects present on the effect stack. There are two kinds of end computations:+--+-- * A /pure computation/ with the type @'Eff' '[] a@, which you can obtain the value via 'Cleff.runPure'; or,+-- * An /impure computation/ with type @'Eff' '['Cleff.IOE'] a@ that can be transformed into an IO computation via+-- 'Cleff.runIOE'.++-- $definingEffects+-- An effect should be defined as a GADT and have the kind 'Effect'. Each operation in the effect is a constructor of+-- the effect type. For example, an effect supporting reading/writing files can be as following:+--+-- @+-- data Filesystem :: 'Effect' where+-- ReadFile :: 'FilePath' -> Filesystem m 'String'+-- WriteFile :: 'FilePath' -> 'String' -> Filesystem m ()+-- @+--+-- Operations constructed with these constructors can be performed via the 'send' function. You can also use the+-- Template Haskell function 'makeEffect' to automatically generate definitions of functions that perform the effects.+-- For example,+--+-- @+-- 'makeEffect' ''Filesystem+-- @+--+-- generates the following definitions:+--+-- @+-- readFile :: Filesystem ':>' es => 'FilePath' -> 'Eff' es 'String'+-- readFile x = 'send' (ReadFile x)+-- writeFile :: Filesystem ':>' es => 'FilePath' -> 'String' -> 'Eff' es ()+-- writeFile x y = 'send' (WriteFile x y)+-- @++-- $interpretingEffects+-- An effect can be understood as the "grammar" (or /syntax/) of a small language; however we also need to define the+-- "meaning" (or /semantics/) of the language. In other words, we need to specify the implementation of effects.+--+-- In an extensible effects system, this is achieved by writing /effect handlers/, which are functions that transforms+-- operations of one effect into other "more primitive" effects. These handlers can then be used to make interpreters+-- with library functions that we'll now see.+--+-- This is very easy to do. For example, for the @Filesystem@ effect+--+-- @+-- data Filesystem :: 'Effect' where+-- ReadFile :: 'FilePath' -> Filesystem m 'String'+-- WriteFile :: 'FilePath' -> 'String' -> Filesystem m ()+-- @+--+-- We can easily handle it in terms of 'IO' operations via 'interpretIO', by pattern matching on the effect+-- constructors:+--+-- @+-- runFilesystemIO :: 'IOE' ':>' es => 'Eff' (Filesystem ': es) a -> 'Eff' es a+-- runFilesystemIO = 'interpretIO' \\case+-- ReadFile path -> 'readFile' path+-- WriteFile path contents -> 'writeFile' path contents+-- @+--+-- Alternatively, we can also construct an in-memory filesystem in terms of the 'Cleff.State.State' effect via+-- the 'reinterpret' function.+--+-- @+-- runFilesystemPure :: 'Cleff.Fail.Fail' ':>' es => 'Data.Map.Map' 'FilePath' 'String' -> 'Eff' (Filesystem ': es) a -> 'Eff' es a+-- runFilesystemPure fs = 'fmap' 'fst' '.' 'Cleff.State.runState' fs '.' 'reinterpret' \\case+-- ReadFile path -> 'Cleff.State.gets' ('Data.Map.lookup' path) >>= \\case+-- 'Nothing' -> 'fail' ("File not found: " ++ 'show' path)+-- 'Just' contents -> 'pure' contents+-- WriteFile path contents -> 'Cleff.State.modify' ('Data.Map.insert' path contents)+-- @+--+-- These interpreters can then be applied to computations with the @Filesystem@ effect to give different implementations+-- to the effect.++-- $higherOrderEffects+-- /Higher order effects/ are effects whose operations take other effect computations as arguments. For example, the+-- 'Cleff.Error.Error' effect is a higher order effect, because its 'Cleff.Error.CatchError' operation takes an effect+-- computation that may throw errors and also an error handler that returns an effect computation:+--+-- @+-- data Error e :: 'Effect' where+-- ThrowError :: e -> Error e m a+-- CatchError :: m a -> (e -> m a) -> Error e m a+-- @+--+-- More literally, an high order effect makes use of the monad type paramenter @m@, while a first order effect, like+-- 'Cleff.State.State', does not.+--+-- It is harder to write interpreters for higher order effects, because we need to transform computations from+-- arbitrary effect stacks into a specific stack that the effect is currently interpreted into. In other words, they+-- need to thread other effects through themselves. This is why Cleff also provides convenient combinators for doing so.+--+-- In a 'Handler', you can temporarily "unlift" a computation from an arbitrary effect stack into the current stack via+-- 'toEff', explicitly change the current effect interpretation in the computation via 'toEffWith', or directly express+-- the effect in terms of 'IO' via 'withToIO'.
+ src/Cleff/Error.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+module Cleff.Error+ ( -- * Effect+ Error (..)+ , -- * Operations+ throwError, catchError, fromEither, fromException, fromExceptionVia, fromExceptionEff, fromExceptionEffVia,+ note, catchErrorJust, catchErrorIf, handleError, handleErrorJust, handleErrorIf, tryError, tryErrorJust+ , -- * Interpretations+ runError, mapError+ ) where++import Cleff+import Cleff.Internal.Base+import Control.Exception (Exception)+import Data.Any (Any, fromAny, toAny)+import Data.Bool (bool)+import Data.Unique (Unique, hashUnique, newUnique)+import qualified UnliftIO.Exception as Exc++-- * Effect++-- | An effect capable of breaking out of current control flow by raising an exceptional value @e@. This effect roughly+-- corresponds to the @MonadError@ typeclass and @ExceptT@ monad transformer in @mtl@.+data Error e :: Effect where+ ThrowError :: e -> Error e m a+ CatchError :: m a -> (e -> m a) -> Error e m a++-- * Operations++makeEffect ''Error++-- | Lift an 'Either' value into the 'Error' effect.+fromEither :: Error e :> es => Either e a -> Eff es a+fromEither = either throwError pure++-- | Lift exceptions generated by an 'IO' computation into the 'Error' effect.+fromException :: ∀ e es a. (Exc.Exception e, '[Error e, IOE] :>> es) => IO a -> Eff es a+fromException m = Exc.catch (liftIO m) (throwError @e)++-- | Like 'fromException', but allows to transform the exception into another error type.+fromExceptionVia :: (Exc.Exception ex, '[Error er, IOE] :>> es) => (ex -> er) -> IO a -> Eff es a+fromExceptionVia f m = Exc.catch (liftIO m) (throwError . f)++-- | Lift exceptions generated by an 'Eff' computation into the 'Error' effect.+fromExceptionEff :: ∀ e es a. (Exc.Exception e, '[Error e, IOE] :>> es) => Eff es a -> Eff es a+fromExceptionEff m = withRunInIO \unlift -> Exc.catch (unlift m) (unlift . throwError @e)++-- | Like 'fromExceptionEff', but allows to transform the exception into another error type.+fromExceptionEffVia :: (Exc.Exception ex, '[Error er, IOE] :>> es) => (ex -> er) -> Eff es a -> Eff es a+fromExceptionEffVia f m = withRunInIO \unlift -> Exc.catch (unlift m) (unlift . throwError . f)++-- | Try to extract a value from 'Maybe', throw an error otherwise.+note :: Error e :> es => e -> Maybe a -> Eff es a+note e = maybe (throwError e) pure++-- | A variant of 'catchError' that allows a predicate to choose whether to catch ('Just') or rethrow ('Nothing') the+-- error.+catchErrorJust :: Error e :> es => (e -> Maybe b) -> Eff es a -> (b -> Eff es a) -> Eff es a+catchErrorJust f m h = m `catchError` \e -> maybe (throwError e) h $ f e++-- | A variant of 'catchError' that allows a predicate to choose whether to catch ('True') or rethrow ('False') the+-- error.+catchErrorIf :: Error e :> es => (e -> Bool) -> Eff es a -> (e -> Eff es a) -> Eff es a+catchErrorIf f m h = m `catchError` \e -> bool (throwError e) (h e) $ f e++-- | Flipped version of 'catchError'.+handleError :: Error e :> es => (e -> Eff es a) -> Eff es a -> Eff es a+handleError = flip catchError++-- | Flipped version of 'catchErrorJust'.+handleErrorJust :: Error e :> es => (e -> Maybe b) -> (b -> Eff es a) -> Eff es a -> Eff es a+handleErrorJust = flip . catchErrorJust++-- | Flipped version of 'catchErrorIf'.+handleErrorIf :: Error e :> es => (e -> Bool) -> (e -> Eff es a) -> Eff es a -> Eff es a+handleErrorIf = flip . catchErrorIf++-- | Runs a computation, returning a 'Left' value if an error was thrown.+tryError :: Error e :> es => Eff es a -> Eff es (Either e a)+tryError m = (Right <$> m) `catchError` (pure . Left)++-- | A variant of 'tryError' that allows a predicate to choose whether to catch ('True') or rethrow ('False') the+-- error.+tryErrorJust :: Error e :> es => (e -> Maybe b) -> Eff es a -> Eff es (Either b a)+tryErrorJust f m = (Right <$> m) `catchError` \e -> maybe (throwError e) (pure . Left) $ f e++-- * Interpretations++-- | Exception wrapper used in 'runError' in order not to conflate error types with exception types.+data ErrorExc = ErrorExc !Unique Any++instance Exception ErrorExc++instance Show ErrorExc where+ showsPrec _ (ErrorExc uid _) =+ ("Cleff.Error.runError: Escaped error (error UID hash: " <>) . shows (hashUnique uid) . ("). This is possibly due \+ \to trying to 'throwError' in a forked thread, or trying to 'wait' on an error-throwing \'Async' computation out \+ \of the effect scope where it is created. Refer to the haddock of 'runError' for details on the caveats. If all \+ \those shenanigans mentioned or other similar ones seem unlikely, please report this as a bug." <>)++catch' :: ∀ e m a. MonadUnliftIO m => Unique -> m a -> (e -> m a) -> m a+catch' eid m h = m `Exc.catch` \ex@(ErrorExc eid' e) -> if eid == eid' then h (fromAny e) else Exc.throwIO ex+{-# INLINE catch' #-}++try' :: ∀ e m a. MonadUnliftIO m => Unique -> m a -> m (Either e a)+try' eid m = catch' eid (Right <$> m) (pure . Left)+{-# INLINE try' #-}++errorHandler :: Unique -> Handler (Error e) (IOE ': es)+errorHandler eid = \case+ ThrowError e -> Exc.throwIO $ ErrorExc eid (toAny e)+ CatchError m' h' -> withToIO \toIO -> liftIO $ catch' eid (toIO m') (toIO . h')+{-# INLINE errorHandler #-}++-- | Run an 'Error' effect.+--+-- __Caveat__: 'runError' is implemented with 'Exc.Exception's therefore inherits some of its unexpected behavoirs.+-- Errors thrown in forked threads will /not/ be directly caught by 'catchError's in the parent thread. Instead it will+-- incur an exception, and we won't be quite able to display the details of that exception properly at that point.+-- Therefore please properly handle the errors in the forked threads separately.+--+-- However if you use @async@ and @wait@ for the action in the same effect scope (i.e. they get to be interpreted by+-- the same 'runError' handler), the error /will/ be caught in the parent thread even if you don't deal with it in the+-- forked thread. But if you passed the @Async@ value out of the effect scope and @wait@ed for it elsewhere, the error+-- will again not be caught. The best choice is /not to pass @Async@ values around randomly/.+runError :: ∀ e es a. Eff (Error e ': es) a -> Eff es (Either e a)+runError m = thisIsPureTrustMe do+ eid <- liftIO newUnique+ try' eid $ reinterpret (errorHandler eid) m+{-# INLINE runError #-}++-- | Transform an 'Error' into another. This is useful for aggregating multiple errors into one type.+mapError :: ∀ e e' es. Error e' :> es => (e -> e') -> Eff (Error e ': es) ~> Eff es+mapError f = thisIsPureTrustMe . reinterpret \case+ ThrowError e -> throwError $ f e+ CatchError m h -> do+ eid <- liftIO newUnique+ res <- try' @e eid $ toEffWith (errorHandler eid) m+ case res of+ Left e -> toEff (h e)+ Right a -> pure a+{-# INLINE mapError #-}
+ src/Cleff/Fail.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Cleff.Fail+ ( -- * Effect+ Fail (..)+ , -- * Interpretations+ runFail, runFailIO+ ) where++import Cleff+import Cleff.Error+import qualified Control.Monad.Fail as Fail++-- * Effect++-- | An effect that expresses failure with a message. This effect allows the use of the 'MonadFail' class.+data Fail :: Effect where+ Fail :: String -> Fail m a++instance Fail :> es => Fail.MonadFail (Eff es) where+ fail = send . Fail++-- * Interpretations++-- | Run a 'Fail' effect in terms of 'Error'.+runFail :: Eff (Fail ': es) a -> Eff es (Either String a)+runFail = runError . reinterpret \case+ Fail msg -> throwError msg+{-# INLINE runFail #-}++-- | Run a 'Fail' effect in terms of throwing exceptions in 'IO'.+runFailIO :: IOE :> es => Eff (Fail ': es) ~> Eff es+runFailIO = interpret \case+ Fail msg -> liftIO $ Fail.fail msg+{-# INLINE runFailIO #-}
+ src/Cleff/Fresh.hs view
@@ -0,0 +1,36 @@+module Cleff.Fresh+ ( -- * Effect+ Fresh (..)+ , -- * Operations+ fresh+ , -- * Interpretations+ freshIntToState, runFreshUnique+ ) where++import Cleff+import Cleff.State+import Data.Unique (Unique, newUnique)++-- * Effect++-- | An effect capable of generating unique values. This effect can be useful in generating variable indices.+data Fresh u :: Effect where+ Fresh :: Fresh u m u++-- * Operations++makeEffect ''Fresh++-- * Interpretations++-- | Interpret a @'Fresh' 'Int'@ effect in terms of @'State' 'Int'@.+freshIntToState :: Eff (Fresh Int ': es) ~> Eff (State Int ': es)+freshIntToState = reinterpret \case+ Fresh -> state \s -> (s, s + 1)+{-# INLINE freshIntToState #-}++-- | Interpret a @'Fresh' 'Unique'@ effect in terms of IO actions.+runFreshUnique :: IOE :> es => Eff (Fresh Unique ': es) ~> Eff es+runFreshUnique = interpret \case+ Fresh -> liftIO newUnique+{-# INLINE runFreshUnique #-}
+ src/Cleff/Input.hs view
@@ -0,0 +1,47 @@+module Cleff.Input+ ( -- * Effect+ Input (..)+ , -- * Operations+ input, inputs+ , -- * Interpretations+ runInputConst, inputToListState, runInputEff+ ) where++import Cleff+import Cleff.State++-- * Effect++-- | An effect that is capable of reading from some input source, such as an input stream.+data Input i :: Effect where+ Input :: Input i m i++-- * Operations++makeEffect ''Input++-- | Apply a function to the result of 'input'.+inputs :: Input i :> es => (i -> i') -> Eff es i'+inputs f = f <$> input++-- * Interpretations++-- | Run an 'Input' effect by giving a constant input value.+runInputConst :: i -> Eff (Input i ': es) ~> Eff es+runInputConst x = interpret \case+ Input -> pure x+{-# INLINE runInputConst #-}++-- | Run an 'Input' effect by going through a list of values.+inputToListState :: Eff (Input (Maybe i) ': es) ~> Eff (State [i] ': es)+inputToListState = reinterpret \case+ Input -> get >>= \case+ [] -> pure Nothing+ x : xs' -> Just x <$ put xs'+{-# INLINE inputToListState #-}++-- | Run an 'Input' effect by performing a computation for each input request.+runInputEff :: Eff es i -> Eff (Input i ': es) ~> Eff es+runInputEff m = interpret \case+ Input -> m+{-# INLINE runInputEff #-}
+ src/Cleff/Internal/Base.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -Wno-orphans #-}+-- | This module contains the 'IOE' effect together with a few primitives for using it, as well as interpretation+-- combinators for 'IO'-related effects. It is not usually needed because safe functionalities are re-exported in the+-- "Cleff" module.+--+-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be+-- extra careful if you're to depend on this module.+module Cleff.Internal.Base+ ( -- * The 'IOE' Effect+ IOE+ , -- * Primitive 'IO' functions+ primLiftIO, primUnliftIO+ , -- * Unwrapping 'Eff'+ thisIsPureTrustMe, runIOE, runPure+ , -- * Effect interpretation+ HandlerIO, interpretIO+ , -- * Combinators for interpreting higher-order effects+ withToIO, fromIO+ ) where++import Cleff.Internal.Effect+import Cleff.Internal.Interpret+import Cleff.Internal.Monad+import Control.Monad.Base (MonadBase (liftBase))+import Control.Monad.Catch (ExitCase (ExitCaseException, ExitCaseSuccess), MonadCatch, MonadMask,+ MonadThrow)+import qualified Control.Monad.Catch as Catch+import Control.Monad.Primitive (PrimMonad (PrimState, primitive), RealWorld)+import Control.Monad.Trans.Control (MonadBaseControl (StM, liftBaseWith, restoreM))+import qualified Data.Mem as Mem+import GHC.IO (IO (IO))+import System.IO.Unsafe (unsafeDupablePerformIO)+import UnliftIO (MonadIO (liftIO), MonadUnliftIO (withRunInIO), throwIO)+import qualified UnliftIO++-- * The 'IOE' effect++-- | The effect for lifting and unlifting the 'IO' monad, allowing you to use 'MonadIO', 'MonadUnliftIO', 'PrimMonad',+-- 'MonadCatch', 'MonadThrow' and 'MonadMask' functionalities. This is the "final" effect that most effects eventually+-- are interpreted into. For example, you can do:+--+-- @+-- log :: 'IOE' :> es => 'Eff' es ()+-- log = 'liftIO' ('putStrLn' "Test logging")+-- @+--+-- It is not recommended to use this effect in application code, as it is too liberal and allows arbitrary IO. Ideally,+-- this is only used in interpreting more fine-grained effects.+--+-- Note that this is /not/ a real effect and cannot be interpreted in any way besides 'thisIsPureTrustMe' and+-- 'runIOE'. It is similar to Polysemy's @Final@ effect which also cannot be interpreted. This is mainly for+-- performance concern, but also that there doesn't really exist reasonable interpretations other than the current one,+-- given the underlying implementation of the 'Eff' monad.+--+-- 'IOE' can be a real effect though, and you can enable the @dynamic-ioe@ build flag to have that. However it is only+-- for reference purposes and should not be used in production code.+data IOE :: Effect where+#ifdef DYNAMIC_IOE+ Lift :: IO a -> IOE m a+ Unlift :: ((m ~> IO) -> IO a) -> IOE m a+#endif++-- * Primitive 'IO' functions++-- | Lift an 'IO' computation into 'Eff'. This function is /highly unsafe/ and should not be used directly; use 'liftIO'+-- instead, or if you're interpreting higher-order effects, use 'fromIO'.+primLiftIO :: IO a -> Eff es a+primLiftIO = Eff . const+{-# INLINE primLiftIO #-}++-- | Give a runner function a way to run 'Eff' actions as an 'IO' computation. This function is /highly unsafe/ and+-- should not be used directly; use 'withRunInIO' instead, or if you're interpreting higher-order effects, use+-- 'withToIO'.+primUnliftIO :: ((Eff es ~> IO) -> IO a) -> Eff es a+primUnliftIO f = Eff \es -> f (`unEff` es)+{-# INLINE primUnliftIO #-}++instance IOE :> es => MonadIO (Eff es) where+#ifdef DYNAMIC_IOE+ liftIO = send . Lift+#else+ liftIO = primLiftIO+ {-# INLINE liftIO #-}+#endif++instance IOE :> es => MonadUnliftIO (Eff es) where+#ifdef DYNAMIC_IOE+ withRunInIO f = send $ Unlift f+#else+ withRunInIO = primUnliftIO+ {-# INLINE withRunInIO #-}+#endif++instance IOE :> es => MonadThrow (Eff es) where+ throwM = throwIO++instance IOE :> es => MonadCatch (Eff es) where+ catch = UnliftIO.catch++instance IOE :> es => MonadMask (Eff es) where+ mask = UnliftIO.mask+ uninterruptibleMask = UnliftIO.uninterruptibleMask+ generalBracket ma mz m = UnliftIO.mask \restore -> do+ a <- ma+ x <- restore (m a) `UnliftIO.catch` \e -> do+ _ <- mz a (ExitCaseException e)+ throwIO e+ z <- mz a (ExitCaseSuccess x)+ pure (x, z)++-- | Compatibility instance; use 'MonadIO' if possible.+instance IOE :> es => MonadBase IO (Eff es) where+ liftBase = liftIO++-- | Compatibility instance; use 'MonadUnliftIO' if possible.+instance IOE :> es => MonadBaseControl IO (Eff es) where+ type StM (Eff es) a = a+ liftBaseWith = withRunInIO+ restoreM = pure++instance IOE :> es => PrimMonad (Eff es) where+ type PrimState (Eff es) = RealWorld+ primitive = liftIO . IO++-- * Unwrapping 'Eff'++-- | Unsafely eliminate an 'IOE' effect from the top of the effect stack. This is mainly for implementing effects that+-- uses 'IO' but does not do anything really /impure/ (i.e. can be safely used 'unsafeDupablePerformIO' on), such as a+-- State effect.+thisIsPureTrustMe :: Eff (IOE ': es) ~> Eff es+thisIsPureTrustMe = interpret \case+#ifdef DYNAMIC_IOE+ Lift m -> primLiftIO m+ Unlift f -> primUnliftIO \runInIO -> f (runInIO . toEff)+#endif+{-# INLINE thisIsPureTrustMe #-}++-- | Extract the 'IO' computation out of an 'Eff' given no effect remains on the stack.+runEff :: Eff '[] a -> IO a+runEff m = unEff m Mem.empty+{-# INLINE runEff #-}++-- | Unwrap an 'Eff' computation with side effects into an 'IO' computation, given that all effects other than 'IOE' are+-- interpreted.+runIOE :: Eff '[IOE] ~> IO+runIOE = runEff . thisIsPureTrustMe+{-# INLINE runIOE #-}++-- | Unwrap a pure 'Eff' computation into a pure value, given that all effects are interpreted.+runPure :: Eff '[] a -> a+runPure = unsafeDupablePerformIO . runEff+{-# NOINLINE runPure #-}++-- * Effect interpretation++-- | The type of an /'IO' effect handler/, which is a function that transforms an effect @e@ into 'IO' computations.+-- This is used for 'interpretIO'.+type HandlerIO e es = ∀ esSend. (Handling e es esSend) => e (Eff esSend) ~> IO++-- | Interpret an effect in terms of 'IO', by transforming an effect into 'IO' computations.+--+-- @+-- 'interpretIO' f = 'interpret' ('liftIO' '.' f)+-- @+interpretIO :: IOE :> es => HandlerIO e es -> Eff (e ': es) ~> Eff es+interpretIO f = interpret (liftIO . f)+{-# INLINE interpretIO #-}++-- * Combinators for interpreting higher-order effects++-- | Temporarily gain the ability to unlift an @'Eff' esSend@ computation into 'IO'. This is useful for dealing with+-- higher-order effects that involves 'IO'.+withToIO :: (Handling e es esSend, IOE :> es) => ((Eff esSend ~> IO) -> IO a) -> Eff es a+withToIO f = Eff \es -> f \m -> unEff m (Mem.update es sendEnv)++-- | Lift an 'IO' computation into @'Eff' esSend@. This is useful for dealing with effect operations with the monad type in+-- the negative position within 'Cleff.IOE', like 'UnliftIO.mask'ing.+fromIO :: (Handling e es esSend, IOE :> es) => IO ~> Eff esSend+fromIO = Eff . const
+ src/Cleff/Internal/Effect.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_HADDOCK not-home #-}+-- | This module contains definitions of some basic types related to effects. You won't need this module directly;+-- these functionalities are reexported in the "Cleff" module.+--+-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be+-- extra careful if you're to depend on this module.+module Cleff.Internal.Effect (Effect, (:>), (:>>), type (++), type (~>)) where++import Data.Kind (Constraint, Type)+import Data.Rec (Elem, type (++), type (~>))++-- | The type of effects. An effect @e m a@ takes an effect monad type @m :: 'Type' -> 'Type'@ and a result type+-- @a :: 'Type'@.+type Effect = (Type -> Type) -> Type -> Type++-- | @e ':>' es@ means the effect @e@ is present in the effect stack @es@, and therefore can be used in an+-- @'Cleff.Eff' es@ computation.+type (:>) = Elem+infix 0 :>++-- | @xs ':>>' es@ means the list of effects @xs@ are all present in the effect stack @es@. This is a convenient type+-- alias for @(e1 ':>' es, ..., en ':>' es)@.+type family xs :>> es :: Constraint where+ '[] :>> _ = ()+ (x ': xs) :>> es = (x :> es, xs :>> es)+infix 0 :>>
+ src/Cleff/Internal/Interpret.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK not-home #-}+-- | This module contains functions for interpreting effects. Most of the times you won't need to import this directly;+-- the module "Cleff" reexports most of the functionalities.+--+-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be+-- extra careful if you're to depend on this module.+module Cleff.Internal.Interpret+ ( -- * Trivial handling+ raise, raiseN, inject, subsume, subsumeN+ , -- * Handler types+ Handling, sendEnv, Handler, Translator+ , -- * Interpreting effects+ interpret, reinterpret, reinterpret2, reinterpret3, reinterpretN, interpose, impose, imposeN+ , -- * Translating effects+ transform, translate+ , -- * Combinators for interpreting higher effects+ toEff, toEffWith, withFromEff+ ) where++import Cleff.Internal.Effect+import Cleff.Internal.Monad+import Data.Mem (MemPtr)+import qualified Data.Mem as Mem+import Data.Rec (pattern (:++:))+import qualified Data.Rec as Env+import Unsafe.Coerce (unsafeCoerce)++-- * Trivial handling++-- | Lift a computation into a bigger effect stack with one more effect. For a more general version see 'raiseN'.+raise :: ∀ e es. Eff es ~> Eff (e ': es)+raise = raiseN @'[e]++-- | Lift a computation into a bigger effect stack with arbitrarily more effects. This function requires+-- @TypeApplications@.+raiseN :: ∀ es' es. KnownList es' => Eff es ~> Eff (es' ++ es)+raiseN m = Eff (unEff m . Mem.adjust (Env.drop @es'))++-- | Lift a computation with a fixed, known effect stack into some superset of the stack.+inject :: ∀ es' es. Subset es' es => Eff es' ~> Eff es+inject m = Eff (unEff m . Mem.adjust (Env.pick @es'))++-- | Eliminate a duplicate effect from the top of the effect stack. For a more general version see 'subsumeN'.+subsume :: ∀ e es. e :> es => Eff (e ': es) ~> Eff es+subsume = subsumeN @'[e]++-- | Eliminate several duplicate effects from the top of the effect stack. This function requires @TypeApplications@.+subsumeN :: ∀ es' es. Subset es' es => Eff (es' ++ es) ~> Eff es+subsumeN m = Eff (unEff m . Mem.adjust (\re -> Env.pick @es' re :++: re))++-- * Handler types++-- | The send-site environment.+data SendSite e esSend = SendSite+ {-# UNPACK #-} !(MemPtr InternalHandler e) -- ^ The pointer to the effect handler of the effect being handled.+ {-# UNPACK #-} !(Env esSend) -- ^ The send-site 'Env'.++-- | The typeclass that indicates a handler scope, handling effect @e@ sent from the effect stack @esSend@ in the+-- effect stack @es@.+--+-- You should not define instances for this typeclass whatsoever.+class Handling e es esSend | e -> es esSend, es -> e esSend, esSend -> e es where+ -- | Obtain the send-site environment.+ sendSite :: SendSite e esSend+ sendSite = error+ "Cleff.Internal.Interpret.sendSite: Attempting to access the send site without a reflected value. This is perhaps \+ \because you are trying to define an instance for the 'Handling' typeclass, which you should not be doing \+ \whatsoever. If that or other shenanigans seem unlikely, please report this as a bug."++-- | Get the pointer to the current effect handler itself.+hdlPtr :: Handling e es esSend => MemPtr InternalHandler e+hdlPtr = let SendSite ptr _ = sendSite in ptr+{-# INLINE hdlPtr #-}++-- | Get the send-site 'Env'.+sendEnv :: Handling e es esSend => Env esSend+sendEnv = let SendSite _ env = sendSite in env+{-# INLINE sendEnv #-}++-- | Newtype wrapper for instantiating the 'Handling' typeclass locally, a la the reflection trick. We do not use+-- the @reflection@ library directly so as not to expose this piece of implementation detail to the user.+newtype InstHandling e es esSend a = InstHandling (Handling e es esSend => a)++-- | Instantiate an 'Handling' typeclass, i.e. pass an implicit send-site environment in. This function shouldn't+-- be directly used anyhow.+instHandling :: ∀ e es esSend a. (Handling e es esSend => a) -> SendSite e esSend -> a+instHandling x = unsafeCoerce (InstHandling x :: InstHandling e es esSend a)+{-# INLINE instHandling #-}++-- | The type of an /effect handler/, which is a function that transforms an effect @e@ from an arbitrary effect stack+-- into computations in the effect stack @es@.+type Handler e es = ∀ esSend. Handling e es esSend => e (Eff esSend) ~> Eff es++-- | The type of a simple transformation function from effect @e@ to @e'@.+type Translator e e' = ∀ esSend. e (Eff esSend) ~> e' (Eff esSend)++-- * Interpreting effects++-- | Transform a 'Handler' into an 'InternalHandler' given a pointer that is going to point to the 'InternalHandler'+-- and the current 'Env'.+mkInternalHandler :: MemPtr InternalHandler e -> Env es -> Handler e es -> InternalHandler e+mkInternalHandler ptr es handle = InternalHandler \eff -> Eff \esSend ->+ unEff (instHandling handle (SendSite ptr esSend) eff) (Mem.update esSend es)++-- | Interpret an effect @e@ in terms of effects in the effect stack @es@ with an effect handler.+interpret :: ∀ e es. Handler e es -> Eff (e ': es) ~> Eff es+interpret = reinterpretN @'[]++-- | Like 'interpret', but adds a new effect @e'@ that can be used in the handler.+reinterpret :: ∀ e' e es. Handler e (e' ': es) -> Eff (e ': es) ~> Eff (e' ': es)+reinterpret = reinterpretN @'[e']++-- | Like 'reinterpret', but adds two new effects.+reinterpret2 :: ∀ e' e'' e es. Handler e (e' ': e'' ': es) -> Eff (e ': es) ~> Eff (e' ': e'' ': es)+reinterpret2 = reinterpretN @'[e', e'']++-- | Like 'reinterpret', but adds three new effects.+reinterpret3 :: ∀ e' e'' e''' e es. Handler e (e' ': e'' ': e''' ': es) -> Eff (e ': es) ~> Eff (e' ': e'' ': e''' ': es)+reinterpret3 = reinterpretN @'[e', e'', e''']++-- | Like 'reinterpret', but adds arbitrarily many new effects. This function requires @TypeApplications@.+reinterpretN :: ∀ es' e es. KnownList es' => Handler e (es' ++ es) -> Eff (e ': es) ~> Eff (es' ++ es)+reinterpretN handle m = Eff \es ->+ let (# ptr, es' #) = Mem.alloca es+ in unEff m $ Mem.append ptr (mkInternalHandler ptr es' handle) $ Mem.adjust (Env.drop @es') es'++-- | Respond to an effect while being able to leave it unhandled (i.e. you can resend the effects in the handler).+interpose :: ∀ e es. e :> es => Handler e es -> Eff es ~> Eff es+interpose = imposeN @'[]++-- | Like 'interpose', but allows to introduce one new effect to use in the handler.+impose :: ∀ e' e es. e :> es => Handler e (e' ': es) -> Eff es ~> Eff (e' ': es)+impose = imposeN @'[e']++-- | Like 'impose', but allows introducing arbitrarily many effects. This requires @TypeApplications@.+imposeN :: ∀ es' e es. (KnownList es', e :> es) => Handler e (es' ++ es) -> Eff es ~> Eff (es' ++ es)+imposeN handle m = Eff \es ->+ let (# ptr, es' #) = Mem.alloca es+ in unEff m $ Mem.replace ptr (mkInternalHandler ptr es' handle) $ Mem.adjust (Env.drop @es') es'++-- * Translating effects++-- | Interpret an effect in terms of another effect in the stack via a simple 'Translator'.+transform :: ∀ e' e es. e' :> es => Translator e e' -> Eff (e ': es) ~> Eff es+transform = translateN @'[]++-- | Like 'transform', but instead of using an effect in stack, add a new one to the top of it.+translate :: ∀ e' e es. Translator e e' -> Eff (e ': es) ~> Eff (e' ': es)+translate = translateN @'[e']++-- | Common implementation of 'transform' and 'translate'. It is overly general on its own so it is not exported in+-- "Cleff".+translateN :: ∀ es' e' e es. (KnownList es', e' :> es' ++ es) => Translator e e' -> Eff (e ': es) ~> Eff (es' ++ es)+translateN trans m = Eff \es ->+ let (# ptr, es' #) = Mem.alloca es+ in let handler = InternalHandler (runHandler (Mem.read es') . trans)+ in unEff m $ Mem.append ptr handler $ Mem.adjust (Env.drop @es') es'++-- * Combinators for interpreting higher effects++-- | Run a computation in the current effect stack. This is useful for interpreting higher-order effects, like a+-- bracketing effect:+--+-- @+-- data Resource m a where+-- Bracket :: m a -> (a -> m ()) -> (a -> m b) -> Resource m b+-- @+--+-- @+-- Bracket alloc dealloc use ->+-- 'UnliftIO.bracket'+-- ('toEff' alloc)+-- ('toEff' . dealloc)+-- ('toEff' . use)+-- @+toEff :: Handling e es esSend => Eff esSend ~> Eff es+toEff m = Eff \es -> unEff m (Mem.update es sendEnv)++-- | Run a computation in the current effect stack, but handles the current effect inside the computation differently+-- by providing a new 'Handler'. This is useful for interpreting effects with local contexts, like 'Cleff.Reader.Local':+--+-- @+-- runReader :: r -> 'Eff' ('Cleff.Reader.Reader' r ': es) '~>' 'Eff' es+-- runReader x = 'interpret' (handle x)+-- where+-- handle :: r -> 'Handler' ('Cleff.Reader.Reader' r) es+-- handle r = \\case+-- 'Cleff.Reader.Ask' -> 'pure' r+-- 'Cleff.Reader.Local' f m -> 'toEffWith' (handle $ f r) m+-- @+toEffWith :: Handling e es esSend => Handler e es -> Eff esSend ~> Eff es+toEffWith handle m = Eff \es -> unEff m $+ Mem.write hdlPtr (mkInternalHandler hdlPtr es handle) $ Mem.update es sendEnv++-- | Temporarily gain the ability to lift some @'Eff' es@ actions into @'Eff' esSend@. This is useful for dealing with+-- effect operations with the monad type in the negative position, which means it's unlikely that you need to use this+-- function in implementing your effects.+withFromEff :: Handling e es esSend => ((Eff es ~> Eff esSend) -> Eff esSend a) -> Eff es a+withFromEff f = Eff \es -> unEff (f \m -> Eff \esSend -> unEff m (Mem.update esSend es)) (Mem.update es sendEnv)
+ src/Cleff/Internal/Monad.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_HADDOCK not-home #-}+-- | This module contains the definition of the 'Eff' monad, which is basically an @'Env' es -> 'IO' a@, as well as+-- functions for manipulating the effect environment type 'Env'. Most of the times, you won't need to use this module+-- directly; user-facing functionalities are all exported via the "Cleff" module.+--+-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be+-- extra careful if you're to depend on this module.+module Cleff.Internal.Monad+ ( -- * Core types+ InternalHandler (InternalHandler, runHandler), Env, Eff (Eff, unEff)+ , -- * Performing effect operations+ KnownList, Subset, send+ ) where++import Cleff.Internal.Effect+import Control.Monad.Fix (MonadFix)+import Control.Monad.Trans.Reader (ReaderT (ReaderT))+import Data.Mem (Mem)+import qualified Data.Mem as Mem+import Data.Rec (KnownList, Subset)+import Type.Reflection (Typeable, typeRep)++-- | The internal representation of effect handlers. This is just a natural transformation from the effect type+-- @e ('Eff' es)@ to the effect monad @'Eff' es@ for any effect stack @es@.+--+-- In interpreting functions (see "Cleff.Internal.Interpret"), the user-facing 'Cleff.Handler' type is transformed into+-- this type.+newtype InternalHandler e = InternalHandler+ { runHandler :: ∀ es. e (Eff es) ~> Eff es }++-- | @+-- 'show' (handler :: 'InternalHandler' E) == "Handler E"+-- @+instance Typeable e => Show (InternalHandler e) where+ showsPrec p _ = ("Handler " ++) . showsPrec p (typeRep @e)++-- | The effect memironment that stores handlers of any effect present in the stack @es@.+type Env = Mem InternalHandler++-- | The extensible effect monad. A monad @'Eff' es@ is capable of performing any effect in the /effect stack/ @es@,+-- which is a type-level list that holds all effects available. However, most of the times, for flexibility, @es@+-- should be a polymorphic type variable, and you should use the '(:>)' and '(:>>)' operators in constraints to+-- indicate what effects are in the stack. For example,+--+-- @+-- 'Cleff.Reader.Reader' 'String' ':>' es, 'Cleff.State.State' 'Bool' ':>' es => 'Eff' es 'Integer'+-- @+--+-- allows you to perform operations of the @'Cleff.Reader.Reader' 'String'@ effect and the @'Cleff.State.State' 'Bool'@+-- effect in a computation returning an 'Integer'.+type role Eff nominal representational+newtype Eff es a = Eff { unEff :: Env es -> IO a }+ deriving newtype (Semigroup, Monoid)+ deriving (Functor, Applicative, Monad, MonadFix) via (ReaderT (Env es) IO)++-- | Perform an effect operation, /i.e./ a value of an effect type @e :: 'Effect'@. This requires @e@ to be in the+-- effect stack.+send :: e :> es => e (Eff es) ~> Eff es+send eff = Eff \handlers -> unEff (runHandler (Mem.read handlers) eff) handlers
+ src/Cleff/Internal/TH.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK not-home #-}+-- | This module contains Template Haskell functions for generating definitions of functions that send effect+-- operations. You mostly won't want to import this module directly; The "Cleff" module reexports the main+-- functionalities of this module.+--+-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be+-- extra careful if you're to depend on this module.+module Cleff.Internal.TH (makeEffect, makeEffect_) where++import Cleff.Internal.Effect+import Cleff.Internal.Monad+import Control.Monad (join)+import Data.Char (toLower)+import Data.Foldable (foldl')+import qualified Data.Map.Strict as Map+import Data.Maybe (maybeToList)+import Language.Haskell.TH+import Language.Haskell.TH.Datatype (ConstructorInfo (constructorName), DatatypeInfo (datatypeCons),+ TypeSubstitution (applySubstitution), reifyDatatype)+import Language.Haskell.TH.PprLib (text, (<>))+import Prelude hiding ((<>))++-- | For a datatype @T@ representing an effect, @'makeEffect' T@ generates functions defintions for performing the+-- operations of @T@ via 'send'. The naming rule is changing the first uppercase letter in the constructor name to+-- lowercase or removing the @:@ symbol in the case of operator constructors. Also, this function will preserve any+-- fixity declarations defined on the constructors.+--+-- Because of the limitations of Template Haskell, all constructors of @T@ should be /polymorphic in the monad type/,+-- if they are to be used by 'makeEffect'. For example, this is not OK:+--+-- @+-- data Limited :: 'Effect' where+-- Noop :: Limited ('Eff' es) ()+-- @+--+-- because the monad type @'Eff' es@ is not a fully polymorphic type variable.+--+-- This function is also "weaker" than @polysemy@'s @makeSem@, because this function cannot properly handle some+-- cases involving complex higher order effects. Those cases are rare, though. See the tests for more details.+makeEffect :: Name -> Q [Dec]+makeEffect = makeSmartCons True++-- | Like 'makeEffect', but doesn't generate type signatures. This is useful when you want to attach Haddock+-- documentation to the function signature, /e.g./:+--+-- @+-- data Identity :: 'Effect' where+-- Noop :: Identity m ()+-- 'makeEffect_' ''Identity+--+-- -- | Perform nothing at all.+-- noop :: Identity ':>' es => 'Eff' es ()+-- @+--+-- Be careful that the function signatures must be added /after/ the 'makeEffect_' call.+makeEffect_ :: Name -> Q [Dec]+makeEffect_ = makeSmartCons False++-- | This is the function underlying 'makeEffect' and 'makeEffect_'. You can switch between the behavior of two by+-- changing the 'Bool' parameter to 'True' (generating signatures) or 'False' (not generating signatures).+makeSmartCons :: Bool -> Name -> Q [Dec]+makeSmartCons makeSig effName = do+ info <- reifyDatatype effName+ join <$> traverse (makeCon makeSig) (constructorName <$> reverse (datatypeCons info))++-- | Make a single function definition of a certain effect operation.+makeCon :: Bool -> Name -> Q [Dec]+makeCon makeSig name = do+ fixity <- reifyFixity name+ typ <- reify name >>= \case+ DataConI _ typ _ -> pure typ+ _ -> fail $ show+ $ text "'" <> ppr name <> text "' is not a constructor"++ effVar <- VarT <$> newName "es"++ let actionCtx = extractCtx typ+ (actionPar, (effTy, monadVar, resTy)) <- extractPar typ++ let fnName = mkName $ toSmartConName $ nameBase name+ fnArgs <- traverse (const $ newName "x") actionPar++ let+ fnBody = VarE 'send `AppE` foldl' (\f -> AppE f . VarE) (ConE name) fnArgs+ fnSig = ForallT [] (UInfixT effTy ''(:>) effVar : actionCtx)+ (makeTyp actionPar effVar effTy monadVar resTy)++ pure $+ maybeToList ((`InfixD` name) <$> fixity) +++ [ SigD fnName fnSig | makeSig ] +++ [ FunD fnName [Clause (VarP <$> fnArgs) (NormalB fnBody) []] ]++ where+ toSmartConName (':' : xs) = xs+ toSmartConName (x : xs) = toLower x : xs+ toSmartConName _ = error "Cleff.makeEffect: Empty constructor name. Please report this as a bug."++ extractCtx (ForallT _ ctx t) = ctx ++ extractCtx t+ extractCtx _ = []++ extractPar (ForallT _ _ t) = extractPar t+ extractPar (SigT t _) = extractPar t+ extractPar (ParensT t) = extractPar t+ extractPar (ArrowT `AppT` a `AppT` t) = do+ (args, ret) <- extractPar t+ pure (a : args, ret)+#if MIN_VERSION_template_haskell(2,17,0)+ extractPar (MulArrowT `AppT` _ `AppT` a `AppT` t) = do+ (args, ret) <- extractPar t+ pure (a : args, ret)+#endif++ extractPar (effTy `AppT` VarT monadVar `AppT` resTy) = pure ([], (effTy, monadVar, resTy))+ extractPar ty@(_ `AppT` m `AppT` _) = fail $ show+ $ text "The effect monad argument '" <> ppr m+ <> text "' in the effect '" <> ppr ty <> text "' is not a type variable"+ extractPar t = fail $ show+ $ text "The type '" <> ppr t+ <> text "' does not have the shape of an effect (i.e. has a polymorphic monad type and a result type)"++ makeTyp [] effVar _ _ resTy = ConT ''Eff `AppT` effVar `AppT` resTy+ makeTyp (parTy : pars) effVar effTy monadVar resTy =+ ArrowT `AppT` substMnd monadVar effVar parTy `AppT` makeTyp pars effVar effTy monadVar resTy++ substMnd monadVar effVar = applySubstitution (Map.singleton monadVar $ ConT ''Eff `AppT` effVar)
+ src/Cleff/Mask.hs view
@@ -0,0 +1,57 @@+module Cleff.Mask+ ( -- * Effect+ Mask (..)+ , -- * Operations+ mask, uninterruptibleMask, bracket, bracketOnError, mask_, uninterruptibleMask_, bracket_, finally, onError+ , -- * Interpretations+ runMask+ ) where++import Cleff+import Cleff.Internal.Base+import qualified UnliftIO.Exception as Exc++-- * Effect++-- | An effect capable of 'Exc.mask'ing and specifically, 'Exc.bracket'ing operations, /i.e./ allowing cleanup after+-- operations that my raise exceptions.+data Mask :: Effect where+ Mask :: ((m ~> m) -> m a) -> Mask m a+ UninterruptibleMask :: ((m ~> m) -> m a) -> Mask m a+ Bracket :: m a -> (a -> m c) -> (a -> m b) -> Mask m b+ BracketOnError :: m a -> (a -> m c) -> (a -> m b) -> Mask m b++-- * Operations++makeEffect ''Mask++-- | Variant of 'mask' that does not provide a restoring function.+mask_ :: Mask :> es => Eff es a -> Eff es a+mask_ m = mask \_ -> m++-- | Variant of 'uninterruptibleMask' that does not provide a restoring function.+uninterruptibleMask_ :: Mask :> es => Eff es a -> Eff es a+uninterruptibleMask_ m = uninterruptibleMask \_ -> m++-- | Variant of 'bracket' that does not pass the allocated resource to the cleanup action.+bracket_ :: Mask :> es => Eff es a -> Eff es c -> (a -> Eff es b) -> Eff es b+bracket_ ma = bracket ma . const++-- | Attach a cleanup action that will always run to a potentially throwing computation.+finally :: Mask :> es => Eff es a -> Eff es b -> Eff es a+finally m mz = bracket_ (pure ()) mz (const m)++-- | Attach an action that runs if the main computation throws an exception.+onError :: Mask :> es => Eff es a -> Eff es b -> Eff es a+onError m mz = bracketOnError (pure ()) (const mz) (const m)++-- * Interpretations++-- | Interpret the 'Mask' effect in terms of primitive 'IO' actions.+runMask :: Eff (Mask ': es) ~> Eff es+runMask = thisIsPureTrustMe . reinterpret \case+ Mask f -> withToIO \toIO -> Exc.mask \restore -> toIO $ f (fromIO . restore . toIO)+ UninterruptibleMask f -> withToIO \toIO -> Exc.uninterruptibleMask \restore -> toIO $ f (fromIO . restore . toIO)+ Bracket ma mz m -> withToIO \toIO -> Exc.bracket (toIO ma) (toIO . mz) (toIO . m)+ BracketOnError ma mz m -> withToIO \toIO -> Exc.bracketOnError (toIO ma) (toIO . mz) (toIO . m)+{-# INLINE runMask #-}
+ src/Cleff/Output.hs view
@@ -0,0 +1,48 @@+module Cleff.Output+ ( -- * Effect+ Output (..)+ , -- * Operations+ output+ , -- * Interpretations+ outputToListState, outputToWriter, ignoreOutput, runOutputEff+ ) where++import Cleff+import Cleff.State+import Cleff.Writer++-- * Effect++-- | An effect that is capable of sending outputs, for example to a log file or an output stream.+data Output o :: Effect where+ Output :: o -> Output o m ()++-- * Operations++makeEffect ''Output++-- * Interpretations++-- | Run an 'Output' effect by accumulating a list.+outputToListState :: Eff (Output o ': es) ~> Eff (State [o] ': es)+outputToListState = reinterpret \case+ Output x -> modify (x :)+{-# INLINE outputToListState #-}++-- | Run an 'Output' effect by translating it into a 'Writer'.+outputToWriter :: (o -> o') -> Eff (Output o ': es) ~> Eff (Writer o' ': es)+outputToWriter f = reinterpret \case+ Output x -> tell $ f x+{-# INLINE outputToWriter #-}++-- | Ignore outputs of an 'Output' effect altogether.+ignoreOutput :: Eff (Output o ': es) ~> Eff es+ignoreOutput = interpret \case+ Output _ -> pure ()+{-# INLINE ignoreOutput #-}++-- | Run an 'Output' effect by performing a computation for each output.+runOutputEff :: (o -> Eff es ()) -> Eff (Output o ': es) ~> Eff es+runOutputEff m = interpret \case+ Output x -> m x+{-# INLINE runOutputEff #-}
+ src/Cleff/Reader.hs view
@@ -0,0 +1,46 @@+module Cleff.Reader+ ( -- * Effect+ Reader (..)+ , -- * Operations+ ask, local, asks+ , -- * Interpretations+ runReader, magnify+ ) where++import Cleff+import Lens.Micro (Lens', (%~), (&), (^.))++-- * Effect++-- | An effect capable of providing an immutable environment @r@ that can be read. This roughly corresponds to the+-- @MonadReader@ typeclass and @ReaderT@ monad transformer in the @mtl@ approach.+data Reader r :: Effect where+ Ask :: Reader r m r+ Local :: (r -> r) -> m a -> Reader r m a++-- * Operations++makeEffect ''Reader++-- | Apply a function on the result of 'ask'.+asks :: Reader r :> es => (r -> s) -> Eff es s+asks = (<$> ask)++-- * Interpretations++-- | Run a 'Reader' effect with a given environment value.+runReader :: r -> Eff (Reader r ': es) ~> Eff es+runReader x = interpret (h x)+ where+ h :: r -> Handler (Reader r) es+ h r = \case+ Ask -> pure r+ Local f m -> toEffWith (h (f r)) m+{-# INLINE runReader #-}++-- | Run a 'Reader' effect in terms of a larger 'Reader' via a 'Lens''.+magnify :: Reader t :> es => Lens' t r -> Eff (Reader r ': es) ~> Eff es+magnify field = interpret \case+ Ask -> asks (^. field)+ Local f m -> local (& field %~ f) $ toEff m+{-# INLINE magnify #-}
+ src/Cleff/State.hs view
@@ -0,0 +1,68 @@+module Cleff.State+ ( -- * Effect+ State (..)+ , -- * Operations+ get, put, state, gets, modify+ , -- * Interpretations+ runState, zoom+ ) where++import Cleff+import Cleff.Internal.Base+import Data.Atomics (atomicModifyIORefCAS)+import Data.Tuple (swap)+import Lens.Micro (Lens', (&), (.~), (^.))+import UnliftIO.IORef (newIORef, readIORef, writeIORef)++-- * Effect++-- | An effect capable of providing a mutable state @s@ that can be read and written. This roughly corresponds to the+-- @MonadState@ typeclass and @StateT@ monad transformer in the @mtl@ approach.+data State s :: Effect where+ Get :: State s m s+ Put :: s -> State s m ()+ State :: (s -> (a, s)) -> State s m a++-- * Operations++makeEffect ''State++-- | Apply a function to the result of 'get'.+gets :: State s :> es => (s -> t) -> Eff es t+gets = (<$> get)++-- | Modify the value of the state via a function.+modify :: State s :> es => (s -> s) -> Eff es ()+modify f = state (((), ) . f)++-- * Interpretations++-- | Run the 'State' effect.+--+-- __Caveat__: The 'runState' interpreter is implemented with 'Data.IORef.IORef's and there is no way to do arbitrary+-- atomic transactions. The 'state' operation is atomic though and it is implemented with 'atomicModifyIORefCAS', which+-- can be faster than @atomicModifyIORef@ in contention. For any more complicated cases of atomicity, please build your+-- own effect that uses either @MVar@s or @TVar@s based on your need.+--+-- Unlike @mtl@, in @cleff@ the state /will not revert/ when an error is thrown.+--+-- 'runState' will stop taking care of state operations done on forked threads as soon as the main thread finishes its+-- computation. Any state operation done /before main thread finishes/ is still taken into account.+runState :: s -> Eff (State s ': es) a -> Eff es (a, s)+runState s m = thisIsPureTrustMe do+ rs <- newIORef s+ x <- reinterpret (\case+ Get -> readIORef rs+ Put s' -> writeIORef rs s'+ State f -> liftIO $ atomicModifyIORefCAS rs (swap . f)) m+ s' <- readIORef rs+ pure (x, s')+{-# INLINE runState #-}++-- | Run a 'State' effect in terms of a larger 'State' via a 'Lens''.+zoom :: State t :> es => Lens' t s -> Eff (State s ': es) ~> Eff es+zoom field = interpret \case+ Get -> gets (^. field)+ Put s -> modify (& field .~ s)+ State f -> state \t -> let (a, !s) = f (t ^. field) in (a, t & field .~ s)+{-# INLINE zoom #-}
+ src/Cleff/Trace.hs view
@@ -0,0 +1,52 @@+module Cleff.Trace+ ( -- * Effect+ Trace (..)+ , -- * Operations+ trace+ , -- * Interpretations+ runTraceHandle, runTraceStdout, runTraceStderr, ignoreTrace, traceToOutput+ ) where++import Cleff+import Cleff.Output+import System.IO (Handle, hPutStrLn, stderr, stdout)++-- * Effect++-- | An effect capable of logging messages, mostly for debugging purposes.+data Trace :: Effect where+ Trace :: String -> Trace m ()++-- * Operations++makeEffect ''Trace++-- * Interpretations++-- | Run the 'Trace' effect by writing to a 'Handle'.+runTraceHandle :: IOE :> es => Handle -> Eff (Trace ': es) a -> Eff es a+runTraceHandle h = interpretIO \case+ Trace s -> hPutStrLn h s+{-# INLINE runTraceHandle #-}++-- | Run the 'Trace' effect by writing to 'stdout'.+runTraceStdout :: IOE :> es => Eff (Trace ': es) ~> Eff es+runTraceStdout = runTraceHandle stdout+{-# INLINE runTraceStdout #-}++-- | Run the 'Trace' effect by writing to 'stderr'.+runTraceStderr :: IOE :> es => Eff (Trace ': es) ~> Eff es+runTraceStderr = runTraceHandle stderr+{-# INLINE runTraceStderr #-}++-- | Run the 'Trace' effect by ignoring all outputs altogether.+ignoreTrace :: Eff (Trace ': es) ~> Eff es+ignoreTrace = interpret \case+ Trace _ -> pure ()+{-# INLINE ignoreTrace #-}++-- | Transform the 'Trace' effect into an @'Output' 'String'@ effect.+traceToOutput :: Eff (Trace ': es) ~> Eff (Output String ': es)+traceToOutput = reinterpret \case+ Trace s -> output s+{-# INLINE traceToOutput #-}
+ src/Cleff/Writer.hs view
@@ -0,0 +1,68 @@+module Cleff.Writer+ ( -- * Effect+ Writer (..)+ , -- * Operations+ tell, listen, listens+ , -- * Interpretations+ runWriter+ ) where++import Cleff+import Cleff.Internal.Base+import Data.Atomics (atomicModifyIORefCAS_)+import Data.Foldable (traverse_)+import UnliftIO.IORef (IORef, newIORef, readIORef)++-- * Effect++-- | An effect capable of accumulating outputs. This roughly corresponds to the @MonadWriter@ typeclass and @WriterT@+-- monad transformer in the @mtl@ approach.+--+-- However, note that this does not have a @pass@ operation as we are not sure what its semantics should be. In fact,+-- the @pass@ semantics in @mtl@ is also unclear and will change when handlers are put in different orders. To avoid+-- any confusion we decided it is best that we don't include it because no one seems to be relying on it anyway.+data Writer w :: Effect where+ Tell :: w -> Writer w m ()+ Listen :: m a -> Writer w m (a, w)++-- * Operations++makeEffect ''Writer++-- | Apply a function to the accumulated output of 'listen'.+listens :: Writer w :> es => (w -> x) -> Eff es a -> Eff es (a, x)+listens f m = do+ (a, w) <- listen m+ pure (a, f w)++-- * Interpretations++-- | Run a monoidal 'Writer' effect.+--+-- __Caveat__: Both 'runWriter' and 'listen's under 'runWriter' will stop taking care of writer operations done on+-- forked threads as soon as the main thread finishes its computation. Any writer operation done+-- /before main thread finishes/ is still taken into account.+runWriter :: ∀ w es a. Monoid w => Eff (Writer w ': es) a -> Eff es (a, w)+runWriter m = thisIsPureTrustMe do+ rw <- newIORef mempty+ x <- reinterpret (h [rw]) m+ w' <- readIORef rw+ pure (x, w')+ where+ h :: [IORef w] -> Handler (Writer w) (IOE ': es)+ h rws = \case+ Tell w' -> traverse_ (\rw -> liftIO $ atomicModifyIORefCAS_ rw (<> w')) rws+ Listen m' -> do+ rw' <- newIORef mempty+ x <- toEffWith (h $ rw' : rws) m'+ w' <- readIORef rw'+ pure (x, w')+{-# INLINE runWriter #-}++-- f :: Writer String :> es => Int -> Eff es [String]+-- f 0 = tell "0" >> pure []+-- f n = do+-- tell (show n) >> uncurry (flip (:)) <$> listen (f $ n - 1)++-- >>> runPure $ runWriter @String $ f 10+-- (["9876543210","876543210","76543210","6543210","543210","43210","3210","210","10","0"],"109876543210")
+ src/Data/Any.hs view
@@ -0,0 +1,19 @@+-- | This module contains utility functions for 'Any'.+--+-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be+-- extra careful if you're to depend on this module.+module Data.Any (Any, fromAny, toAny) where++import GHC.Exts (Any)+import Unsafe.Coerce (unsafeCoerce)++-- | Coerce any boxed value into 'Any'.+toAny :: a -> Any+toAny = unsafeCoerce+{-# INLINE toAny #-}++-- | Coerce 'Any' to a boxed value. This is /generally unsafe/ and it is your responsibility to ensure that the type+-- you're coercing into is the original type that the 'Any' is coerced from.+fromAny :: Any -> a+fromAny = unsafeCoerce+{-# INLINE fromAny #-}
+ src/Data/Mem.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE UnboxedTuples #-}+-- | 'Mem' is a data structure that is a simulation of an array of thread-local pointers. This structure supports:+--+-- * \( O(n) \) creation of a new pointer;+-- * \( O(n) \) changing the pointer in an array cell;+-- * \( O(1) \) modification of the memory a pointer points to;+-- * \( O(1) \) read.+--+-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be+-- extra careful if you're to depend on this module.+module Data.Mem (Mem, MemPtr, empty, adjust, alloca, read, write, replace, append, update) where++import Data.Any+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as Map+import Data.Kind (Type)+import Data.Rec (Rec, pattern (:~:))+import qualified Data.Rec as Rec+import Prelude hiding (read)++-- | The representation of a pointer in a 'Mem'.+type role MemPtr representational nominal+newtype MemPtr (f :: k -> Type) (a :: k) = MemPtr { unMemPtr :: Int }+ deriving newtype+ ( Eq -- ^ Pointer equality.+ , Ord -- ^ An arbitrary total order on the pointers.+ )++-- | A simulated array of thread-local pointers. This means for each array cell, you can either change the pointer or+-- change the memory the pointer points to.+--+-- Note that like real memory, any of the operations provided is not generally safe and it is your responsibility to+-- ensure the correctness of your calls.+type role Mem representational nominal+data Mem (f :: k -> Type) (es :: [k]) = Mem+ {-# UNPACK #-} !(Rec (MemPtr f) es) -- ^ The array.+ {-# UNPACK #-} !Int -- ^ The next memory address to allocate.+ !(IntMap Any) -- ^ The simulated memory.++-- | Create a 'Mem' with no pointers.+empty :: Mem f '[]+empty = Mem Rec.empty 0 Map.empty+{-# INLINE empty #-}++-- | Adjust the array of pointers.+adjust :: ∀ es' es f. (Rec (MemPtr f) es -> Rec (MemPtr f) es') -> Mem f es -> Mem f es'+adjust f (Mem re n mem) = Mem (f re) n mem+{-# INLINE adjust #-}++-- | Allocate a new address. \( O(1) \).+alloca :: ∀ e es f. Mem f es -> (# MemPtr f e, Mem f es #)+alloca (Mem re n mem) = (# MemPtr n, Mem re (succ n) mem #)+{-# INLINE alloca #-}++-- | Read a pointer. \( O(1) \).+read :: ∀ e es f. Rec.Elem e es => Mem f es -> f e+read (Mem re _ mem) = fromAny $ mem Map.! unMemPtr (Rec.index @e re)+{-# INLINE read #-}++-- | Write to the memory a pointer points to. \( O(1) \).+write :: ∀ e es f. MemPtr f e -> f e -> Mem f es -> Mem f es+write (MemPtr m) x (Mem re n mem) = Mem re n (Map.insert m (toAny x) mem)+{-# INLINE write #-}++-- | Replace a pointer with a new one. \( O(n) \).+replace :: ∀ e es f. Rec.Elem e es => MemPtr f e -> f e -> Mem f es -> Mem f es+replace (MemPtr m) x (Mem re n mem) = Mem (Rec.modify @e (MemPtr m) re) n (Map.insert m (toAny x) mem)+{-# INLINE replace #-}++-- | Add a new pointer to the array. \( O(n) \).+append :: ∀ e es f. MemPtr f e -> f e -> Mem f es -> Mem f (e ': es)+append (MemPtr m) x (Mem re n mem) = Mem (MemPtr m :~: re) n (Map.insert m (toAny x) mem)+{-# INLINE append #-}++-- | Use the memory of LHS as a newer version for the memory of RHS. \( O(1) \).+update :: ∀ es es' f. Mem f es' -> Mem f es -> Mem f es+update (Mem _ n mem) (Mem re' _ _) = Mem re' n mem+{-# INLINE update #-}
+ src/Data/Rec.hs view
@@ -0,0 +1,390 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_HADDOCK not-home #-}+-- | This module defines an immutable extensible record type, similar to @vinyl@ and @data-diverse@. However this+-- implementation focuses on fast reads, hence has very different performance characteristics from other libraries:+--+-- * Lookup: Amortized \( O(1) \).+-- * Update: \( O(n) \).+-- * Shrink: \( O(1) \).+-- * Append: \( O(n) \).+--+-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be+-- extra careful if you're to depend on this module.+module Data.Rec+ ( Rec, length+ , -- * Construction+ empty, singleton+ , -- * Addition+ cons, pattern (:~:), type (++), concat, pattern (:++:)+ , -- * Deletion+ tail, KnownList, drop+ , -- * Retrieval+ head, take, Elem, index, Subset, pick+ , -- * Modification+ modify, (/~/), batch, (/++/)+ , -- * Mapping+ type (~>), natural, (<#>), zipWith, all, any, degenerate, extract+ , -- * Debugging+ invariant, sizeInvariant, allAccessible+ ) where++import Control.Arrow ((&&&))+import Control.Monad.Primitive (PrimMonad (PrimState))+import Data.Any+import Data.Functor.Const (Const (Const, getConst))+import Data.Kind (Type)+import Data.List (intersperse)+import Data.Primitive.SmallArray (SmallArray, SmallMutableArray, copySmallArray, indexSmallArray,+ newSmallArray, runSmallArray, sizeofSmallArray, writeSmallArray)+import GHC.TypeLits (ErrorMessage (ShowType, Text, (:<>:)), TypeError)+import Prelude hiding (all, any, concat, drop, head, length, tail, take, zipWith)+import Text.Read (readPrec)+import qualified Text.Read as R+import qualified Text.Read.Lex as RL++-- | Extensible record type supporting efficient \( O(1) \) reads. The underlying implementation is 'SmallArray'+-- slices, therefore suits small numbers of entries (/i.e./ less than 128).+type role Rec representational nominal+data Rec (f :: k -> Type) (es :: [k]) = Rec+ {-# UNPACK #-} !Int -- ^ The offset.+ {-# UNPACK #-} !Int -- ^ The length.+ {-# UNPACK #-} !(SmallArray Any) -- ^ The array content.++instance Eq (Rec f '[]) where+ _ == _ = True++instance (Eq (Rec f xs), Eq (f x)) => Eq (Rec f (x ': xs)) where+ x :~: xs == y :~: ys = x == y && xs == ys++instance {-# OVERLAPPABLE #-} (∀ x. Eq (f x)) => Eq (Rec f xs) where+ xs == ys = all (== Const True) $ zipWith (\x y -> Const $ x == y) xs ys++-- | @+-- 'show' 'empty' == "empty"+-- @+instance Show (Rec f '[]) where+ show _ = "empty"++-- | @+-- 'read' \"empty\" == 'empty'+-- @+instance Read (Rec f '[]) where+ readPrec = R.parens $ R.prec appPrec $+ empty <$ R.lift (RL.expect (R.Ident "empty"))+ where appPrec = 10++-- | @+-- 'show' ('Data.Functor.Identity.Identity' 'True' ':~:' 'Data.Functor.Identity.Identity' \"Hi\" ':~:' 'empty')+-- == "Identity True :~: Identity \\"Hi\\" :~: empty"+-- @+instance (Show (f x), Show (Rec f xs)) => Show (Rec f (x ': xs)) where+ showsPrec p (x :~: xs) = showParen (p > consPrec) $+ showsPrec (consPrec + 1) x . showString " :~: " . showsPrec consPrec xs++-- | @+-- 'read' "Identity True :~: Identity \\"Hi\\" :~: empty"+-- == 'Data.Functor.Identity.Identity' 'True' ':~:' 'Data.Functor.Identity.Identity' \"Hi\" ':~:' 'empty'+-- @+instance (Read (f x), Read (Rec f xs)) => Read (Rec f (x ': xs)) where+ readPrec = R.parens $ R.prec consPrec $+ cons <$> R.step (readPrec @(f x)) <* R.lift (RL.expect (R.Symbol ":~:")) <*> readPrec @(Rec f xs)++-- | @+-- 'show' ('Const' 'False' ':~:' 'Const' 'True' ':~:' 'empty')+-- == "Const False :~: Const True :~: empty"+-- @+instance {-# OVERLAPPABLE #-} (∀ x. Show (f x)) => Show (Rec f xs) where+ showsPrec p xs = showParen (p > consPrec) $+ foldr (.) id $ intersperse (showString " :~: ") $ extract (showsPrec (consPrec + 1)) xs++instance Semigroup (Rec f '[]) where+ xs <> _ = xs++-- | One-by-one semigroup operation instead of concatenation.+--+-- @+-- (x ':~:' xs) '<>' (y ':~:' ys) == x '<>' y ':~:' xs '<>' ys+-- @+instance (Semigroup (f x), Semigroup (Rec f xs)) => Semigroup (Rec f (x ': xs)) where+ (x :~: xs) <> (y :~: ys) = x <> y :~: xs <> ys++instance {-# OVERLAPPABLE #-} (∀ x. Semigroup (f x)) => Semigroup (Rec f xs) where+ xs <> ys = zipWith (<>) xs ys++-- | @+-- 'mempty' == 'empty'+-- @+instance Monoid (Rec f '[]) where+ mempty = empty++-- | The unit of a record type are the units of its element types:+--+-- @+-- 'mempty' == 'mempty' ':~:' 'mempty'+-- @+instance (Monoid (f x), Monoid (Rec f xs)) => Monoid (Rec f (x ': xs)) where+ mempty = mempty :~: mempty++-- | Get the length of the record.+length :: Rec f es -> Int+length (Rec _ len _) = len++-- | Create a new 'SmallMutableArray' with no contents.+newArr :: PrimMonad m => Int -> m (SmallMutableArray (PrimState m) a)+newArr len = newSmallArray len $ error+ "Data.Rec.newArr: Attempting to read an element of the underlying array of a 'Rec'. Please report this as a bug."++-- | Create an empty record. \( O(1) \).+empty :: Rec f '[]+empty = Rec 0 0 $ runSmallArray $ newArr 0++-- | Create a record with one entry. \( O(1) \).+singleton :: f e -> Rec f '[e]+singleton x = Rec 0 1 $ runSmallArray do+ marr <- newArr 1+ writeSmallArray marr 0 (toAny x)+ pure marr++-- | Prepend one entry to the record. \( O(n) \).+cons :: f e -> Rec f es -> Rec f (e ': es)+cons x (Rec off len arr) = Rec 0 (len + 1) $ runSmallArray do+ marr <- newArr (len + 1)+ writeSmallArray marr 0 (toAny x)+ copySmallArray marr 1 arr off len+ pure marr++-- | Infix version of 'cons' that also supports destructuring.+pattern (:~:) :: f e -> Rec f es -> Rec f (e ': es)+pattern x :~: xs <- (head &&& tail -> (x, xs))+ where (:~:) = cons+infixr 5 :~:+{-# COMPLETE (:~:) #-}++-- | @infixr 5 :~:@+consPrec :: Int+consPrec = 5++-- | Type level list concatenation.+type family xs ++ ys where+ '[] ++ ys = ys+ (x ': xs) ++ ys = x ': (xs ++ ys)+infixr 5 ++++-- | Concatenate two records. \( O(m+n) \).+concat :: Rec f es -> Rec f es' -> Rec f (es ++ es')+concat (Rec off len arr) (Rec off' len' arr') = Rec 0 (len + len') $ runSmallArray do+ marr <- newArr (len + len')+ copySmallArray marr 0 arr off len+ copySmallArray marr len arr' off' len'+ pure marr++-- | Infix version of 'concat' that also supports destructuring.+pattern (:++:) :: ∀ es es' f. KnownList es => Rec f es -> Rec f es' -> Rec f (es ++ es')+pattern xs :++: xs' <- (take @es @es' &&& drop @es @es' -> (xs, xs'))+ where (:++:) = concat+infixr 5 :++:+{-# COMPLETE (:++:) #-}++-- | Slice off one entry from the top of the record. \( O(1) \).+tail :: Rec f (e ': es) -> Rec f es+tail (Rec off len arr) = Rec (off + 1) (len - 1) arr++unreifiable :: String -> String -> String -> a+unreifiable clsName funName comp = error $+ funName <> ": Attempting to access " <> comp <> " without a reflected value. This is perhaps because you are trying \+ \to define an instance for the '" <> clsName <> "' typeclass, which you should not be doing whatsoever. If that or \+ \other shenanigans seem unlikely, please report this as a bug."++-- | The list @es@ list is concrete, i.e. is of the form @'[a1, a2, ..., an]@, i.e. is not a type variable.+class KnownList (es :: [k]) where+ -- | Get the length of the list.+ reifyLen :: Int+ reifyLen = unreifiable "KnownList" "Data.Rec.reifyLen" "the length of a type-level list"++instance KnownList '[] where+ reifyLen = 0++instance KnownList es => KnownList (e ': es) where+ reifyLen = 1 + reifyLen @_ @es++-- | Slice off several entries from the top of the record. \( O(1) \).+drop :: ∀ es es' f. KnownList es => Rec f (es ++ es') -> Rec f es'+drop (Rec off len arr) = Rec (off + len') (len - len') arr+ where len' = reifyLen @_ @es++-- | Get the head of the record. \( O(1) \).+head :: Rec f (e ': es) -> f e+head (Rec off _ arr) = fromAny $ indexSmallArray arr off++-- | Take elements from the top of the record. \( O(m) \).+take :: ∀ es es' f. KnownList es => Rec f (es ++ es') -> Rec f es+take (Rec off _ arr) = Rec 0 len $ runSmallArray do+ marr <- newArr len+ copySmallArray marr 0 arr off (off + len)+ pure marr+ where len = reifyLen @_ @es++-- | The element @e@ is present in the list @es@.+class Elem (e :: k) (es :: [k]) where+ -- | Get the index of the element.+ reifyIndex :: Int+ reifyIndex = unreifiable "Elem" "Data.Rec.reifyIndex" "the index of an element of a type-level list"++instance {-# OVERLAPPING #-} Elem e (e ': es) where+ reifyIndex = 0++instance Elem e es => Elem e (e' ': es) where+ reifyIndex = 1 + reifyIndex @_ @e @es++type ElemNotFound e = 'Text "The element '" ':<>: 'ShowType e ':<>: 'Text "' is not present in the constraint"++instance TypeError (ElemNotFound e) => Elem e '[] where+ reifyIndex = error "Data.Rec.reifyIndex: Attempting to refer to a nonexistent member. Please report this as a bug."++-- | Get an element in the record. Amortized \( O(1) \).+index :: ∀ e es f. Elem e es => Rec f es -> f e+index (Rec off _ arr) = fromAny $ indexSmallArray arr (off + reifyIndex @_ @e @es)++-- | @es@ is a subset of @es'@.+class KnownList es => Subset (es :: [k]) (es' :: [k]) where+ -- | Get a list of indices of the elements.+ reifyIndices :: [Int]+ reifyIndices = unreifiable "Subset" "Data.Rec.reifyIndices" "the index of multiple elements of a type-level list"++instance Subset '[] es where+ reifyIndices = []++instance (Subset es es', Elem e es') => Subset (e ': es) es' where+ reifyIndices = reifyIndex @_ @e @es' : reifyIndices @_ @es @es'++-- | Get a subset of the record. Amortized \( O(m) \).+pick :: ∀ es es' f. Subset es es' => Rec f es' -> Rec f es+pick (Rec off _ arr) = Rec 0 (reifyLen @_ @es) $ runSmallArray do+ marr <- newArr (reifyLen @_ @es)+ go marr 0 (reifyIndices @_ @es @es')+ pure marr+ where+ go :: PrimMonad m => SmallMutableArray (PrimState m) Any -> Int -> [Int] -> m ()+ go _ _ [] = pure ()+ go marr newIx (ix : ixs) = do+ writeSmallArray marr newIx (indexSmallArray arr (off + ix))+ go marr (newIx + 1) ixs++-- | Modify an entry in the record. \( O(n) \).+modify :: ∀ e es f. Elem e es => f e -> Rec f es -> Rec f es+modify x (Rec off len arr) = Rec 0 len $ runSmallArray do+ marr <- newArr len+ copySmallArray marr 0 arr off len+ writeSmallArray marr (reifyIndex @_ @e @es) (toAny x)+ pure marr++-- | Infix version of 'modify'.+(/~/) :: Elem e es => f e -> Rec f es -> Rec f es+(/~/) = modify+infixl 9 /~/++-- | Merge a subset into the original record, updating several entries at once. \( O(m+n) \).+batch :: ∀ es es' f. Subset es es' => Rec f es -> Rec f es' -> Rec f es'+batch (Rec off _ arr) (Rec off' len' arr') = Rec 0 len' $ runSmallArray do+ marr <- newArr len'+ copySmallArray marr 0 arr' off' len'+ go marr 0 (reifyIndices @_ @es @es')+ pure marr+ where+ go :: PrimMonad m => SmallMutableArray (PrimState m) Any -> Int -> [Int] -> m ()+ go _ _ [] = pure ()+ go marr updIx (ix : ixs) = do+ writeSmallArray marr ix (indexSmallArray arr (off + updIx))+ go marr (updIx + 1) ixs++-- | Infix version of 'batch'.+(/++/) :: Subset es es' => Rec f es -> Rec f es' -> Rec f es'+(/++/) = batch+infixl 9 /++/++-- | The type of natural transformations from functor @f@ to @g@.+type f ~> g = ∀ a. f a -> g a+infixr 0 ~>++-- | Apply a natural transformation to the record. \( O(n) \).+natural :: (f ~> g) -> Rec f es -> Rec g es+natural f (Rec off len arr) = Rec 0 len $ runSmallArray do+ marr <- newArr len+ go marr 0+ pure marr+ where+ go :: PrimMonad m => SmallMutableArray (PrimState m) Any -> Int -> m ()+ go marr n+ | n == len = pure ()+ | otherwise = do+ writeSmallArray marr n (toAny $ f $ fromAny $ indexSmallArray arr (off + n))+ go marr (n + 1)++-- | Infix version of 'natural'.+(<#>) :: (f ~> g) -> Rec f es -> Rec g es+(<#>) = natural+infixl 4 <#>++-- | Zip two records with a natural transformation. \( O(n) \).+zipWith :: (∀ x. f x -> g x -> h x) -> Rec f es -> Rec g es -> Rec h es+zipWith f (Rec off len arr) (Rec off' _ arr') = Rec 0 len $ runSmallArray do+ marr <- newArr len+ go marr (0 :: Int)+ pure marr+ where+ go :: PrimMonad m => SmallMutableArray (PrimState m) Any -> Int -> m ()+ go marr n+ | n == len = pure ()+ | otherwise = do+ writeSmallArray marr n+ (toAny $ f (fromAny $ indexSmallArray arr (off + n)) (fromAny $ indexSmallArray arr' (off' + n)))+ go marr (n + 1)++-- | Check if a predicate is true on all elements. \( O(n) \).+all :: (∀ x. f x -> Bool) -> Rec f es -> Bool+all f (Rec off len arr) = go 0+ where+ go n+ | n == len = True+ | otherwise = f (fromAny $ indexSmallArray arr (off + n)) && go (n + 1)++-- | Check if a predicate is true on at least one element. \( O(n) \).+any :: (∀ x. f x -> Bool) -> Rec f es -> Bool+any f (Rec off len arr) = go 0+ where+ go n+ | n == len = False+ | otherwise = f (fromAny $ indexSmallArray arr (off + n)) || go (n + 1)++-- | Convert a record that effectively contains a fixed type into a list of the fixed type. \( O(n) \).+degenerate :: Rec (Const a) es -> [a]+degenerate (Rec off len arr) = go 0+ where+ go n+ | n == len = []+ | otherwise = getConst (fromAny $ indexSmallArray arr (off + n)) : go (n + 1)++-- | Map each element to a fixed type. \( O(n) \).+extract :: (∀ x. f x -> a) -> Rec f es -> [a]+extract f xs = degenerate $ natural (Const . f) xs++-- | Test the size invariant of 'Rec'.+sizeInvariant :: Rec f es -> Rec f es+sizeInvariant xs@(Rec off len arr)+ | tracked == actual = xs+ | otherwise = error $ "Data.Rec.sizeInvariant: tracked size " <> show tracked <> ", actual size " <> show actual+ where+ tracked = len + off+ actual = sizeofSmallArray arr++-- | Test whether all fields of 'Rec' are really set.+allAccessible :: Rec f es -> Rec f es+allAccessible xs@(Rec off len arr) = go 0+ where+ go n+ | n == len = xs+ | otherwise = indexSmallArray arr (off + n) `seq` go (n + 1)++-- | Test all invariants.+invariant :: Rec f es -> Rec f es+invariant = allAccessible . sizeInvariant
+ test/ConcurrencySpec.hs view
@@ -0,0 +1,44 @@+module ConcurrencySpec where++import Cleff+import Cleff.Error (runError, throwError)+import Cleff.State+import Control.Monad (when)+import Data.Set (Set)+import qualified Data.Set as Set+import Test.Hspec+import UnliftIO (concurrently_)+import UnliftIO.Concurrent (threadDelay)++spec :: Spec+spec = do+ sharedState+ errorHandling++sharedState :: Spec+sharedState = it "should have shared state" do+ (_, set) <- runIOE $ runState (Set.empty @Int) do+ concurrently_ (addWhen even x) (addWhen odd x)+ set `shouldBe` Set.fromList [1..x]+ where+ x :: Int = 100+ addWhen :: State (Set Int) :> es => (Int -> Bool) -> Int -> Eff es ()+ addWhen f = \case+ 0 -> pure ()+ n -> do+ when (f n) $ do+ modify $ Set.insert n+ addWhen f $ n - 1++errorHandling :: Spec+errorHandling = it "should handle errors properly" do+ (r, s) <- runIOE $ runState (0 :: Int) $ runError @String $ concurrently_+ (liftIO (threadDelay 10000) >> throwError err)+ (modify (+x))+ case r of+ Left e -> e `shouldBe` err+ Right _ -> expectationFailure "no error caught - or error escaped"+ s `shouldBe` x+ where+ x :: Int = 67+ err = "error"
+ test/ErrorSpec.hs view
@@ -0,0 +1,38 @@+-- | This module is adapted from https://github.com/polysemy-research/polysemy/blob/master/test/ErrorSpec.hs,+-- originally BSD3 license, authors Sandy Maguire et al.+module ErrorSpec where++import Cleff+import Cleff.Error+import Cleff.Fail+import Cleff.Mask+import Control.Monad.Fail (fail)+import Prelude hiding (fail)+import Test.Hspec+import qualified UnliftIO.Exception as Exc++newtype MyExc = MyExc String+ deriving stock (Show, Eq)+ deriving anyclass (Exc.Exception)++spec :: Spec+spec = parallel do+ it "should catch exceptions" do+ a <- runIOE $ runError $ fromException @MyExc do+ _ <- Exc.throwIO $ MyExc "hello"+ pure ()+ a `shouldBe` Left (MyExc "hello")++ it "should not catch non-exceptions" do+ a <- runIOE $ runError @MyExc $ fromException @MyExc $ pure ()+ a `shouldBe` Right ()++ it "should interact well with Mask" do+ a <- runIOE $ runMask $ runError @MyExc $ onError (do+ _ <- throwError $ MyExc "hello"+ pure ()) $ throwError (MyExc "goodbye")+ a `shouldBe` Left (MyExc "hello")++ it "should not catch prematurely" do+ b <- runIOE $ runFail $ runError @String $ fail "Boom" >> pure ()+ b `shouldBe` Left "Boom"
+ test/HigherOrderSpec.hs view
@@ -0,0 +1,36 @@+-- | This module is adapted from https://github.com/polysemy-research/polysemy/blob/master/test/HigherOrderSpec.hs,+-- originally BSD3 license, authors Sandy Maguire et al.+module HigherOrderSpec where++import Cleff+import Cleff.Error+import Cleff.Reader+import Test.Hspec++data SomeEff :: Effect where+ SomeAction :: SomeEff m String+makeEffect ''SomeEff++data Ex = Ex+ deriving stock (Eq, Show)++spec :: Spec+spec = describe "Reader local" $ do+ it "should nest with itself" $ do+ let foo = runPure . runReader "hello" $ do+ local (++ " world") $ do+ local (++ "!") $ do+ ask+ foo `shouldBe` "hello world!"++ it "should local for other interpreted effects" do+ let+ localed = runPure $ runReader "unlocaled" $ interpret (\SomeAction -> ask) do+ local (const "localed") someAction+ localed `shouldBe` "localed"++ it "should catch errors indirectly thrown from interpreted effects" do+ let+ caught = runPure $ runError @Ex $ interpret (\SomeAction -> throwError Ex) do+ someAction `catchError` \Ex -> return "caught"+ caught `shouldBe` Right "caught"
+ test/InterposeSpec.hs view
@@ -0,0 +1,30 @@+module InterposeSpec where++import Cleff+import Cleff.Output+import Cleff.Reader+import Cleff.State+import Cleff.Trace+import Test.Hspec++annoy :: ∀ es. '[Reader Int, Trace] :>> es => Eff es ~> Eff es+annoy = interpose @(Reader Int) h+ where+ h :: Handler (Reader Int) es+ h = \case+ Ask -> do+ x <- ask+ trace $ show x+ pure x+ Local f m -> local f (toEff m)++countdown :: Reader Int :> es => Eff es ()+countdown = do+ x <- asks (== (0 :: Int))+ if x then pure () else local (subtract (1 :: Int)) countdown++spec :: Spec+spec = do+ it "should thread in effect environment correctly" do+ let (_, msgs) = runPure $ runState [] $ outputToListState $ traceToOutput $ runReader (100 :: Int) $ annoy countdown+ msgs `shouldBe` map show [0..100 :: Int]
+ test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/MaskSpec.hs view
@@ -0,0 +1,190 @@+-- | This module is adapted from https://github.com/polysemy-research/polysemy/blob/master/test/ResourceSpec.hs,+-- originally BSD3 license, authors Sandy Maguire et al.+{-# OPTIONS_GHC -Wno-orphans #-}+module MaskSpec where++import Cleff+import Cleff.Error+import Cleff.Mask+import Cleff.Output+import Cleff.State+import Cleff.Trace+import Cleff.Writer+import Control.Exception (Exception)+import Control.Monad (void)+import Data.Tuple.Extra (second)+import Test.Hspec++spec :: Spec+spec = parallel $ do+ testBoth "persist state and call the finalizer"+ (\((e, s), ts) -> do+ s `shouldBe` "finalized"+ e `shouldBe` Left ()+ ts `shouldBe` ["allocated", "starting block"]+ ) $ do+ bracket+ (put "allocated" >> pure ())+ (\() -> do+ get >>= trace+ put "finalized"+ )+ (\() -> do+ get >>= trace+ put "starting block"+ _ <- throwError ()+ put "don't get here"+ )++ testBoth "persist state and call the finalizer with bracketOnError"+ (\((e, s), ts) -> do+ ts `shouldContain` ["allocated"]+ ts `shouldContain` ["starting block"]+ s `shouldBe` "finalized"+ e `shouldBe` Left ()+ ) $ do+ bracketOnError+ (put "allocated" >> pure ())+ (\() -> do+ get >>= trace+ put "finalized"+ )+ (\() -> do+ get >>= trace+ put "starting block"+ _ <- throwError ()+ put "don't get here"+ )++ testBoth "should not call the finalizer if there no error"+ (\((e, s), ts) -> do+ ts `shouldContain` ["allocated"]+ ts `shouldNotContain` ["starting block"]+ s `shouldBe` "don't get here"+ e `shouldBe` Right ()+ ) $ do+ bracketOnError+ (put "allocated" >> pure ())+ (\() -> do+ get >>= trace+ put "finalized"+ )+ (\() -> do+ get >>= trace+ put "starting block"+ put "don't get here"+ )++ testBoth "should call the finalizer on Error"+ (\((e, s), ts) -> do+ ts `shouldContain` ["beginning transaction"]+ ts `shouldContain` ["rolling back transaction"]+ s `shouldBe` ""+ e `shouldBe` Left ()+ ) $ do+ withTransaction $ do+ void $ throwError ()+ pure "hello"++ testBoth "io dispatched bracket"+ (\((e, s), ts) -> do+ ts `shouldContain` ["allocated"]+ ts `shouldContain` ["starting block"]+ s `shouldBe` "finalized"+ e `shouldBe` Left ()+ ) $ do+ bracket+ (put "allocated" >> pure ())+ (\() -> do+ get >>= trace+ put "finalized"+ )+ (\() -> do+ get >>= trace+ put "starting block"+ _ <- throwError ()+ put "don't get here"+ )++ testBoth "should not lock when done recursively"+ (\((e, s), ts) -> do+ ts `shouldContain` [ "hello 1"+ , "hello 2"+ , "RUNNING"+ , "goodbye 2"+ ]+ s `shouldBe` "finished"+ e `shouldBe` Left ()+ ) $ do+ bracket+ (put "hello 1")+ (\() -> do+ get >>= trace+ put "finished"+ )+ (\() -> do+ get >>= trace+ void $+ bracket (put "hello 2")+ (const $ do+ get >>= trace+ put "goodbye 2"+ )+ (const $ do+ get >>= trace+ put "RUNNING"+ throwError ()+ )+ -- This doesn't run due to the thrown error above+ get >>= trace+ put "goodbye 1"+ )++instance Exception ()++runTest+ :: Eff '[Error (), Mask, State [Char], Trace, Output String] a+ -> IO ((Either () a, [Char]), [String])+runTest = pure+ . runPure+ . fmap (second reverse) . runState []+ . outputToListState+ . subsume @(Output String)+ . traceToOutput+ . runState ""+ . runMask+ . runError @()++runTest2+ :: Eff '[Error (), Mask, State [Char], Trace, Output String] a+ -> IO ((Either () a, [Char]), [String])+runTest2 = pure+ . runPure+ . runWriter+ . outputToWriter (:[])+ . subsume @(Output String)+ . traceToOutput+ . runState ""+ . runMask+ . runError @()++testBoth+ :: String+ -> (((Either () a, [Char]), [String]) -> Expectation)+ -> Eff '[Error (), Mask, State [Char], Trace, Output String] a+ -> Spec+testBoth name k m = do+ describe name $ do+ it "via outputToListState" $ do+ z <- runTest m+ k z+ it "via outputToWriter" $ do+ z <- runTest2 m+ k z++withTransaction :: '[Mask, Trace] :>> r => Eff r a -> Eff r a+withTransaction m =+ bracketOnError+ (trace "beginning transaction")+ (const $ trace "rolling back transaction")+ (const $ m <* trace "committing transaction")
+ test/RecSpec.hs view
@@ -0,0 +1,100 @@+module RecSpec where++import Data.Functor.Identity (Identity (Identity))+import Data.Rec (Rec, invariant, pattern (:++:), pattern (:~:), (/++/), (/~/), (<#>))+import qualified Data.Rec as Rec+import Data.Typeable (cast)+import Test.Hspec++type I = Identity+i :: a -> Identity a+i = Identity++spec :: Spec+spec = parallel do+ it "is Typeable" do+ let+ x = i (5 :: Int) :~: i False :~: Rec.empty+ y = cast x :: Maybe (Rec I '[Int, String])+ z = cast x :: Maybe (Rec I '[Int, Bool])+ y `shouldBe` Nothing+ z `shouldBe` Just x++ it "is Read & Show" do+ let+ s = "Identity 5 :~: Identity False :~: Identity 'X' :~: Identity (Just 'O') :~: empty"+ s' = "Identity 5 :~: Identity False :~: Identity 'X' :~: (Identity (Just 'O') :~: (empty))"+ x = invariant $ read s :: Rec Identity '[Int, Bool, Char, Maybe Char]+ x' = invariant $ read s' :: Rec Identity '[Int, Bool, Char, Maybe Char]+ show x `shouldBe` s+ show x' `shouldBe` s++ it "is Eq" do+ let+ x = i (5 :: Int) :~: i False :~: i 'X' :~: i (Just 'O') :~: Rec.empty+ y = invariant $ id <#> x+ z = invariant $ read "Identity 5 :~: Identity False :~: Identity 'X' :~: Identity (Just 'O') :~: empty"+ :: Rec Identity '[Int, Bool, Char, Maybe Char]+ x `shouldBe` y+ y `shouldBe` z++ it "can be constructed with 'empty', 'singleton', 'cons', 'concat'" do+ let+ x = invariant $ i (5 :: Int) :~: i False :~: i 'X' :~: i (Just 'O') :~: Rec.empty+ y = invariant $ Rec.singleton (i (5 :: Int)) :++: Rec.singleton (i False)+ :++: Rec.singleton (i 'X') :++: Rec.singleton (i (Just 'O'))+ a = invariant $ i (5 :: Int) :~: Rec.singleton (i False)+ b = invariant $ Rec.singleton (i 'X') :++: Rec.singleton (i (Just 'O'))+ x `shouldBe` y+ invariant (a :++: b) `shouldBe` x++ it "can contain multiple fields of the same type" do+ let+ x = i (5 :: Int) :~: i False :~: i 'X' :~: i (Just 'O') :~: Rec.empty+ y = i (5 :: Int) :~: i False :~: i 'X' :~: i (Just 'O') :~: i (6 :: Int) :~: i (Just 'A') :~: Rec.empty+ invariant (x :++: 6 :~: i (Just 'A') :~: Rec.empty) `shouldBe` y++ it "can be destructed via 'head', 'tail', 'take', 'drop'" do+ let+ a = (x :~: y) :++: Rec.singleton z+ x = i (5 :: Int)+ y = i (Rec.singleton $ i False) :~: i 'X' :~: Rec.empty+ z = i (Just 'O')+ Rec.head a `shouldBe` x+ invariant (Rec.drop @'[Int, Rec I '[Bool], Char] a) `shouldBe` Rec.singleton z+ invariant (Rec.tail a) `shouldBe` invariant (y :++: Rec.singleton z)+ invariant (Rec.take @'[Int, Rec I '[Bool], Char] a) `shouldBe` (x :~: y)++ it "can get elements via 'index'" do+ let x = i (5 :: Int) :~: i False :~: i 'X' :~: i (Just 'O') :~: Rec.empty+ Rec.index @Int x `shouldBe` 5+ Rec.index @Bool x `shouldBe` i False+ Rec.index @Char x `shouldBe` i 'X'+ Rec.index @(Maybe Char) x `shouldBe` i (Just 'O')++ it "can get the topmost element among the duplicate ones" do+ let y = i (5 :: Int) :~: i False :~: i 'X' :~: i (Just 'O') :~: i (6 :: Int) :~: i (Just 'A') :~: Rec.empty+ Rec.index @Int y `shouldBe` 5+ Rec.index @Bool y `shouldBe` i False+ Rec.index @Char y `shouldBe` i 'X'+ Rec.index @(Maybe Char) y `shouldBe` i (Just 'O')++ it "can set elements via 'modify'" do+ let x = i (5 :: Int) :~: i False :~: i 'X' :~: i (Just 'O') :~: Rec.empty+ invariant (Rec.modify @Int 6 x) `shouldBe` 6 :~: i False :~: i 'X' :~: i (Just 'O') :~: Rec.empty+ invariant (i True /~/ x) `shouldBe` 5 :~: i True :~: i 'X' :~: i (Just 'O') :~: Rec.empty+ invariant (i 'O' /~/ x) `shouldBe` 5 :~: i False :~: i 'O' :~: i (Just 'O') :~: Rec.empty+ invariant (i (Just 'P') /~/ x) `shouldBe` 5 :~: i False :~: i 'X' :~: i (Just 'P') :~: Rec.empty++ it "can get multiple elements via 'pick'" do+ let x = i (5 :: Int) :~: i False :~: i 'X' :~: i (Just 'O') :~: Rec.empty+ invariant (Rec.pick @'[Int, Maybe Char] x) `shouldBe` 5 :~: i (Just 'O') :~: Rec.empty++ it "can reorder elements via 'pick'" do+ let x = i (5 :: Int) :~: i False :~: i 'X' :~: i (Just 'O') :~: Rec.empty+ invariant (Rec.pick @'[Bool, Int, Maybe Char] x) `shouldBe` i False :~: 5 :~: i (Just 'O') :~: Rec.empty++ it "can set multiple fields via 'batch'" do+ let x = i (5 :: Int) :~: i False :~: i 'X' :~: i (Just 'O') :~: Rec.empty+ invariant ((i (6 :: Int) :~: i (Just 'X') :~: Rec.empty) /++/ x)+ `shouldBe` 6 :~: i False :~: i 'X' :~: i (Just 'X') :~: Rec.empty
+ test/StateSpec.hs view
@@ -0,0 +1,119 @@+-- | This module is adapted from https://github.com/arybczak/effectful/blob/master/effectful/tests/StateTests.hs,+-- originally BSD3 license, authors Andrzej Rybczak et al.+module StateSpec where++import Cleff+import Cleff.State+import qualified Control.Exception.Lifted as LE+import qualified Control.Monad.Catch as E+import Test.Hspec+import UnliftIO.Exception+import qualified UnliftIO.Exception as UE++spec :: Spec+spec = parallel do+ it "should run with correct results" basic+ it "should run in a deep stack" deepStack+ it "should interact well with exceptions" exceptionInteract+ it "should run in nested cases" nested++basic, deepStack, exceptionInteract, nested :: IO ()++basic = do+ (end, len) <- runIOE . runState (0::Int) . fmap snd . runState collatzStart $ collatz+ end `shouldBe` 1+ len `shouldBe` collatzLength++deepStack = do+ n <- runIOE . fmap fst . runState () . fmap snd . runState (0::Int) $ do+ fmap fst . runState () . fmap fst . runState () $ do+ fmap fst . runState () $ do+ fmap fst . runState () . fmap fst . runState () . fmap fst . runState () $ do+ modify @Int (+1)+ modify @Int (+2)+ modify @Int (+4)+ modify @Int (+8)+ n `shouldBe` 15++exceptionInteract = do+ testTry E.try+ testCatch E.catch+ testTry LE.try+ testCatch LE.catch+ testTry UE.try+ testCatch UE.catch+ where+ testTry+ :: (∀ a es. IOE :> es => Eff es a -> Eff es (Either Ex a))+ -> IO ()+ testTry tryImpl = do+ e <- runIOE $ tryImpl $ runState (0::Int) action+ e `shouldBe` Left Ex+ s <- runIOE $ fmap snd $ runState (0::Int) $ tryImpl action+ s `shouldBe` 1+ testCatch+ :: (∀ a es. IOE :> es => Eff es a -> (Ex -> Eff es a) -> Eff es a)+ -> IO ()+ testCatch catchImpl = do+ s <- runIOE . fmap snd . runState (0::Int) $ do+ _ <- (fmap fst . runState () $ action) `catchImpl` \Ex -> modify @Int (+4)+ modify @Int (+8)+ s `shouldBe` 13+ action :: '[State Int, IOE] :>> es => Eff es ()+ action = do+ modify @Int (+1)+ _ <- throwIO Ex+ modify @Int (+2)++nested = do+ x <- runIOE do+ runHasInt 0 do+ putInt 1+ fmap snd . runState () $ do+ putInt 2+ fmap snd . runState () $ do+ putInt expected+ getInt+ x `shouldBe` expected+ where+ expected :: Int+ expected = 4++data HasInt :: Effect where+ GetInt :: HasInt m Int+ PutInt :: Int -> HasInt m ()++getInt :: HasInt :> es => Eff es Int+getInt = send GetInt++putInt :: HasInt :> es => Int -> Eff es ()+putInt = send . PutInt++runHasInt :: Int -> Eff (HasInt : es) a -> Eff es a+runHasInt n =+ fmap fst . runState () . fmap fst . runState n . fmap fst . runState True . reinterpret3 \case+ GetInt -> get+ PutInt i -> put i++data Ex = Ex+ deriving stock (Eq, Show)+ deriving anyclass (Exception)++collatzStart :: Integer+collatzStart = 9780657630++collatzLength :: Int+collatzLength = 1132++-- | Tests multiple 'State'S, 'put', 'get' and 'modify'.+collatz :: (State Integer :> es, State Int :> es) => Eff es ()+collatz = get @Integer >>= \case+ 1 -> pure ()+ n -> if even n+ then do put $ n `div` 2+ modify @Int (+1)+ collatz+ else do put $ 3*n + 1+ modify @Int (+1)+ collatz+{-# NOINLINE collatz #-}
+ test/ThSpec.hs view
@@ -0,0 +1,129 @@++-- | This module is adapted from https://github.com/arybczak/effectful/blob/master/effectful/tests/ThEffectSpec.hs,+-- originally BSD3 license, authors Andrzej Rybczak et al.+module ThSpec where++import Cleff+import Data.Kind (Type)+import GHC.TypeLits+import Test.Hspec++spec :: Spec+spec = it "should compile" True++data SimpleADT m a = SimpleADTC1 Int | SimpleADTC2 String++makeEffect ''SimpleADT++data GADTSyntax m a where+ GADTSyntaxC1 :: Int -> GADTSyntax m a+ GADTSyntaxC2 :: String -> GADTSyntax m a++makeEffect ''GADTSyntax++data ADTSyntax1 m a = a ~ Int => ADTSyntax1C String++makeEffect ''ADTSyntax1++data ADTSyntax2 m a+ = a ~ Int => ADTSyntax2C1 Int+ | a ~ String => ADTSyntax2C2 String++makeEffect ''ADTSyntax2++data ADTSyntax3 m a = Show a => ADTSyntax3C a++makeEffect ''ADTSyntax3++data Fields m a = FieldsC { fieldsCF1 :: Int, fieldsCF2 :: String }++makeEffect ''Fields++newtype Newtype1 m a = Newtype1C Int++makeEffect ''Newtype1++newtype Newtype2 m a where+ Newtype2C :: String -> Newtype2 m a++makeEffect ''Newtype2++data Instance = ADTI | GADTI | NTI | MMI++data family Family (s :: Instance) (m :: Type -> Type) a++data instance Family 'ADTI _ _ = ADTIC1 Int | ADTIC2 String++makeEffect 'ADTIC1++data instance Family 'GADTI _ _ where+ GADTIC1 :: Int -> Family 'GADTI m Int+ GADTIC2 :: String -> Family 'GADTI m String++makeEffect 'GADTIC1++newtype instance Family 'NTI _ _ = NTIC Int++makeEffect 'NTIC++data instance Family 'MMI m (_ m) where+ MMIC1 :: f m -> Family 'MMI m (f m)+ MMIC2 :: (∀ x. m x -> m (f m)) -> Family 'MMI m (f m)++-- TODO(daylily): This cannot produce desired result.+-- makeEffect 'MMIC1++data Complex m a where+ Mono :: Int -> Complex m Bool+ Poly :: a -> Complex m a+ PolyIn :: a -> Complex m Bool+ PolyOut :: Int -> Complex m a+ Lots :: a -> b -> c -> d -> e -> f -> Complex m ()+ Nested :: Maybe b -> Complex m (Maybe a)+ MultiNested :: (Maybe a, [b]) -> Complex m (Maybe a, [b])+ Existential :: (∀ e. e -> Maybe e) -> Complex m a+ LotsNested :: Maybe a -> [b] -> (c, c) -> Complex m (a, b, c)+ Dict :: Ord a => a -> Complex m a+ MultiDict :: (Eq a, Ord b, Enum a, Num c)+ => a -> b -> c -> Complex m ()+ IndexedMono :: f 0 -> Complex m Int+ IndexedPoly :: ∀ f (n :: Nat) m . f n -> Complex m (f (n + 1))+ IndexedPolyDict :: KnownNat n => f n -> Complex m Int++makeEffect ''Complex++data HOEff m a where+ EffArgMono :: m () -> HOEff m ()+ EffArgPoly :: m a -> HOEff m a+ EffArgComb :: m a -> (m a -> m b) -> HOEff m b+ EffRank2 :: (∀ x. m x -> m (Maybe x)) -> HOEff m a++makeEffect ''HOEff++data ComplexEffArgs b c m a where+ EffMono :: Int -> ComplexEffArgs Int String m Bool+ EffPoly1 :: a -> ComplexEffArgs a b m a+ EffPoly2 :: a -> ComplexEffArgs a (Maybe a) m Bool+ EffPolyFree :: String -> ComplexEffArgs a b m Int+ EffSame1 :: ComplexEffArgs a a m a+ EffSame2 :: ComplexEffArgs b b m a+ EffHO :: m b -> ComplexEffArgs b Int m String++-- TODO(daylily): This cannot produce desired result. This is almost certainly caused by us not annotating types+-- explicitly, but that's too much effort.+-- makeEffect ''ComplexEffArgs++data HKEffArgs f g m a where+ HKRank2 :: (∀ x . f x -> g x) -> HKEffArgs f g m a++makeEffect ''HKEffArgs++data ByCon m a where+ ByConC :: Int -> ByCon m String++makeEffect 'ByConC++data ByField m a where+ ByFieldC :: { byFieldCF :: Int } -> ByField m Int++makeEffect 'byFieldCF