diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for `cleff` + +## 0.1.0.0 + +- Initial API diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,128 @@ +# `cleff` - fast and concise extensible effects + +[![GitHub Workflow Status](https://img.shields.io/github/workflow/status/re-xyr/cleff/build)](https://github.com/re-xyr/cleff/actions/workflows/build.yaml) +[![Hackage](https://img.shields.io/hackage/v/cleff)](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`: ![big-stack benchmark result](https://raw.githubusercontent.com/re-xyr/cleff/master/docs/img/effect-zoo-big-stack.png) +- `countdown`: ![countdown benchmark result](https://raw.githubusercontent.com/re-xyr/cleff/master/docs/img/effect-zoo-countdown.png) +- `file-sizes`: ![file-sizes benchmark result](https://raw.githubusercontent.com/re-xyr/cleff/master/docs/img/effect-zoo-file-sizes.png) +- `reinterpretation`: ![reinterpretation benchmark result](https://raw.githubusercontent.com/re-xyr/cleff/master/docs/img/effect-zoo-reinterpretation.png) + +## 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/ diff --git a/cleff.cabal b/cleff.cabal new file mode 100644 --- /dev/null +++ b/cleff.cabal @@ -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 +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 diff --git a/example/Broker.hs b/example/Broker.hs new file mode 100644 --- /dev/null +++ b/example/Broker.hs @@ -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 diff --git a/example/Filesystem.hs b/example/Filesystem.hs new file mode 100644 --- /dev/null +++ b/example/Filesystem.hs @@ -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\"") diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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 diff --git a/example/Teletype.hs b/example/Teletype.hs new file mode 100644 --- /dev/null +++ b/example/Teletype.hs @@ -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 diff --git a/src/Cleff.hs b/src/Cleff.hs new file mode 100644 --- /dev/null +++ b/src/Cleff.hs @@ -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'. diff --git a/src/Cleff/Error.hs b/src/Cleff/Error.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Error.hs @@ -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 #-} diff --git a/src/Cleff/Fail.hs b/src/Cleff/Fail.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Fail.hs @@ -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 #-} diff --git a/src/Cleff/Fresh.hs b/src/Cleff/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Fresh.hs @@ -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 #-} diff --git a/src/Cleff/Input.hs b/src/Cleff/Input.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Input.hs @@ -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 #-} diff --git a/src/Cleff/Internal/Base.hs b/src/Cleff/Internal/Base.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Internal/Base.hs @@ -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 diff --git a/src/Cleff/Internal/Effect.hs b/src/Cleff/Internal/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Internal/Effect.hs @@ -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 :>> diff --git a/src/Cleff/Internal/Interpret.hs b/src/Cleff/Internal/Interpret.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Internal/Interpret.hs @@ -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) diff --git a/src/Cleff/Internal/Monad.hs b/src/Cleff/Internal/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Internal/Monad.hs @@ -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 diff --git a/src/Cleff/Internal/TH.hs b/src/Cleff/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Internal/TH.hs @@ -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) diff --git a/src/Cleff/Mask.hs b/src/Cleff/Mask.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Mask.hs @@ -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 #-} diff --git a/src/Cleff/Output.hs b/src/Cleff/Output.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Output.hs @@ -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 #-} diff --git a/src/Cleff/Reader.hs b/src/Cleff/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Reader.hs @@ -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 #-} diff --git a/src/Cleff/State.hs b/src/Cleff/State.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/State.hs @@ -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 #-} diff --git a/src/Cleff/Trace.hs b/src/Cleff/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Trace.hs @@ -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 #-} diff --git a/src/Cleff/Writer.hs b/src/Cleff/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Writer.hs @@ -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") diff --git a/src/Data/Any.hs b/src/Data/Any.hs new file mode 100644 --- /dev/null +++ b/src/Data/Any.hs @@ -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 #-} diff --git a/src/Data/Mem.hs b/src/Data/Mem.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mem.hs @@ -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 #-} diff --git a/src/Data/Rec.hs b/src/Data/Rec.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rec.hs @@ -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 diff --git a/test/ConcurrencySpec.hs b/test/ConcurrencySpec.hs new file mode 100644 --- /dev/null +++ b/test/ConcurrencySpec.hs @@ -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" diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs new file mode 100644 --- /dev/null +++ b/test/ErrorSpec.hs @@ -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" diff --git a/test/HigherOrderSpec.hs b/test/HigherOrderSpec.hs new file mode 100644 --- /dev/null +++ b/test/HigherOrderSpec.hs @@ -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" diff --git a/test/InterposeSpec.hs b/test/InterposeSpec.hs new file mode 100644 --- /dev/null +++ b/test/InterposeSpec.hs @@ -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] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/MaskSpec.hs b/test/MaskSpec.hs new file mode 100644 --- /dev/null +++ b/test/MaskSpec.hs @@ -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") diff --git a/test/RecSpec.hs b/test/RecSpec.hs new file mode 100644 --- /dev/null +++ b/test/RecSpec.hs @@ -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 diff --git a/test/StateSpec.hs b/test/StateSpec.hs new file mode 100644 --- /dev/null +++ b/test/StateSpec.hs @@ -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 #-} diff --git a/test/ThSpec.hs b/test/ThSpec.hs new file mode 100644 --- /dev/null +++ b/test/ThSpec.hs @@ -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