diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,44 @@ +# Contributor's guide + +## Bug Reports + +Please [open an issue][new-issue]. + +The more detailed your report, the faster it can be resolved. Once the +bug has been resolved, the person responsible will tag the issue as +_needs confirmation_ and assign the issue back to you. Once you have +tested and confirmed that the issue is resolved, close the issue. If +you are not a member of the project, you will be asked for +confirmation and we will close it. + +[new-issue]: https://github.com/tweag/capability/issues/new + +## Code + +1. Explain your idea and discuss your plan with members of the team. + The best way to do this is to create an [issue][issue-tracker] or + comment on an existing issue. +1. Prepare a git commit with your change. Don't forget to + add [tests][tests]. Update [README.md](./README.md) if appropriate. +1. [Create a pull request][create-pull-request]. This will start the + code review process. Enable "Allow edits from maintainers" if the + branch is on a fork, so that reviewers can fix trivial problems + (typos) directly. **All submissions, including submissions by + project members, require review.** +1. You may be asked to make some changes. Continuous integration bots + will test your change automatically on supported platforms. Once + everything looks good, your change will be merged. The minimum + criteria for acceptance are: + + * a patch should be a minimal and accurate answer to exactly one + identified and agreed problem, + * a patch that modifies a stable public API should not break existing + applications unless there is overriding consensus on the value of + doing this. + * A patch must adhere to the [code style guidelines][style-guide] + of the project. + +[issue-tracker]: https://github.com/tweag/capability/issues +[tests]: ./examples +[create-pull-request]: https://help.github.com/articles/creating-a-pull-request/ +[style-guide]: https://github.com/tweag/guides/blob/master/style/ diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for capability + +## 0.1.0.0 -- 2018-10-04 + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018 EURL Tweag + +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 Andreas Herrmann 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,163 @@ +# capability: effects, extensionally + +A capability is a type class that says explicitly which effects +a function is allowed to use. The [`mtl`][mtl] works like this too. +But unlike the `mtl`, this library decouples effects from their +implementation. What this means in practice: + +- You can implement large sets of capabilities using the + efficient [`ReaderT` pattern][readert], rather than a slow monad + transformer stack. +- Capabilities compose well: e.g. it's easy to have multiple reader + effects. +- You can use a writer effect without implementing it as a writer + monad (which is known to [leak space][writer-space-leak]). +- You can reason about effects. For instance, if a monad provides a + reader effect at type `IORef A`, it also provides a state effect at type `A` + +For more on these, you may want to read the announcement [blog + post][blog]. + +This library is an alternative to the [`mtl`][mtl]. It defines a set +of standard, reusable capability type classes, such as the `HasReader` +and `HasState` type classes, which provide the standard reader and +state effects, respectively. + +Where `mtl` instances only need to be defined once and for all, +capability-style programming has traditionally suffered from verbose +boilerplate: rote instance definitions for every new implementation of +the capability. Fortunately GHC 8.6 introduced +the [`DerivingVia`][deriving-via] language extension. We use it to +remove the boilerplate, turning capability-style programming into an +appealing alternative to `mtl`-style programming. The +[`generic-lens`][generic-lens] library is used to access fields of +structure in the style of the [`ReaderT` pattern][readert]. + +An additional benefit of separating capabilities from their +implementation is that they avoid a pitfall of the `mtl`. In the +`mtl`, two different `MonadState` are disambiguated by their types, +which means that it is difficult to have two `MonadState Int` in the +same monad stack. Capability type classes are parameterized by a name +(also known as a *tag*). This makes it possible to combine multiple +versions of the same capability. For example, + +```haskell +twoStates :: (HasState "a" Int m, HasState "b" Int m) => m () +``` + +Here, the tags `"a"` and `"b"` refer to different state spaces. + +In summary, compared to the `mtl`: + +- capabilities represent what effects a function can use, rather than + how the monad is constructed; +- capabilities are named, rather than disambiguated by type; +- capabilites are discharged with deriving-via combinators + and [`generic-lens`][generic-lens], rather than with instance + resolution. + +An example usage looks like this: + +``` haskell +testParity :: (HasReader "foo" Int m, HasState "bar" Bool m) => m () +testParity = do + num <- ask @"foo" + put @"bar" (even num) + +data Ctx = Ctx { foo :: Int, bar :: IORef Bool } + deriving Generic + +newtype M a = M { runM :: Ctx -> IO a } + deriving (Functor, Applicative, Monad) via ReaderT Ctx IO + -- Use DerivingVia to derive a HasReader instance. + deriving (HasReader "foo" Int) via + -- Pick the field foo from the Ctx record in the ReaderT environment. + Field "foo" "ctx" (MonadReader (ReaderT Ctx IO)) + -- Use DerivingVia to derive a HasState instance. + deriving (HasState "bar" Bool) via + -- Convert a reader of IORef to a state capability. + ReaderIORef (Field "bar" "ctx" (MonadReader (ReaderT Ctx IO))) + +example :: IO () +example = do + rEven <- newIORef False + runM testParity (Ctx 2 rEven) + readIORef rEven >>= print + runM testParity (Ctx 3 rEven) + readIORef rEven >>= print +``` + +For more complex examples, see the [Examples section](#examples) and +the [`examples` subtree](./examples). + +This package is not available on Hackage yet, as some of its +dependencies have not been updated to GHC 8.6, yet. + +API documentation can be found in the artifacts tab of any successful +build in the [CircleCI project][circleci]. + +[circleci]: https://circleci.com/gh/tweag/capabilities-via/tree/master +[mtl]: http://hackage.haskell.org/package/mtl +[blog]: https://www.tweag.io/posts/2018-10-04-capability.html +[deriving-via]: https://downloads.haskell.org/~ghc/8.6.1/docs/html/users_guide/glasgow_exts.html#deriving-via +[generic-lens]: https://hackage.haskell.org/package/generic-lens +[readert]: https://www.fpcomplete.com/blog/2017/06/readert-design-pattern +[writer-space-leak]: https://blog.infinitenegativeutility.com/2016/7/writer-monads-and-space-leaks + +## Examples + +An example is provided in [`WordCount`](examples/WordCount.hs). +Execute the following commands to try it out: + +``` +$ nix-shell --pure --run "cabal configure --enable-tests" +$ nix-shell --pure --run "cabal repl examples" + +ghci> :set -XOverloadedStrings +ghci> wordAndLetterCount "ab ba" +Letters +'a': 2 +'b': 2 +Words +"ab": 1 +"ba": 1 +``` + +To execute all examples and see if they produce the expected results run + +``` +$ nix-shell --pure --run "cabal test examples --show-details=streaming --test-option=--color" +``` + +## Build instructions + +### Nix Shell + +Some of this package's dependencies require patches to build with GHC 8.6. +These patches are defined in +[`nix/haskell/default.nix`](nix/haskell/default.nix). +A development environment with all patched dependencies in scope is defined in +[`shell.nix`](shell.nix). + +### Cachix Nix Cache + +A Nix cache for this package's dependencies is provided via [cachix][cachix]. +If you have [cachix][cachix] installed, then you can activate it by executing + +``` +$ cachix use tweag +``` + +[cachix]: https://cachix.org/ + +### Build + +The build instructions assume that you have [Nix][nix] installed. +Execute the following command to build the library. + +``` +$ nix-shell --pure --run "cabal configure" +$ nix-shell --pure --run "cabal build" +``` + +[nix]: https://nixos.org/nix/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/capability.cabal b/capability.cabal new file mode 100644 --- /dev/null +++ b/capability.cabal @@ -0,0 +1,94 @@ +name: capability +version: 0.1.0.0 +homepage: https://github.com/tweag/capability +license: BSD3 +license-file: LICENSE +maintainer: andreas.herrmann@tweag.io +copyright: 2018 EURL Tweag +category: Control +build-type: Simple +extra-source-files: + ChangeLog.md + CONTRIBUTING.md + README.md +cabal-version: 1.18 +tested-with: GHC==8.6.1 +synopsis: Extensional capabilities and deriving combinators +description: + Standard capability type classes for extensional effects and combinators + to derive capability instances with little boilerplate. + +source-repository head + type: git + location: https://github.com/tweag/capability + +flag hspec-jenkins + description: + You can enable the use of the `hspec-jenkins` package using `-fhspec-jenkins`. + . + This package allows JUnit formatted test reporting for CI. + default: False + +library + exposed-modules: + Capability + Capability.Accessors + Capability.Error + Capability.Reader + Capability.Reader.Internal.Class + Capability.Reader.Internal.Strategies + Capability.State + Capability.State.Internal.Class + Capability.State.Internal.Strategies + Capability.Stream + Capability.Writer + Capability.Writer.Discouraged + build-depends: + base >= 4.12 && < 5.0 + , dlist >= 0.8 && < 0.9 + , exceptions >= 0.6 && < 0.11 + , generic-lens >= 1.0 && < 1.1 + , lens >= 4.16 && < 5.0 + , monad-control >= 1.0 && < 1.1 + , monad-unlift >= 0.2 && < 0.3 + , mtl >= 2.0 && < 3.0 + , mutable-containers >= 0.3 && < 0.4 + , primitive >= 0.6 && < 0.7 + , safe-exceptions >= 0.1 && < 0.2 + , streaming >= 0.2 && < 0.3 + , transformers >= 0.5.5 && < 0.6 + , unliftio >= 0.2 && < 0.3 + , unliftio-core >= 0.1 && < 0.2 + ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 + +test-suite examples + type: exitcode-stdio-1.0 + other-modules: + WordCount + CountLog + Error + Reader + State + Stream + Test.Common + Writer + main-is: Test.hs + build-depends: + base >= 4.12 && < 5.0 + , capability + , containers >= 0.6 && < 0.7 + , hspec >= 2.0 && < 3.0 + , lens >= 4.16 && < 5.0 + , mtl >= 2.0 && < 3.0 + , silently >= 1.2 && < 1.3 + , streaming >= 0.2 && < 0.3 + , temporary >= 1.0 && < 1.4 + , text >= 0.2 && < 1.3 + , unliftio >= 0.2 && < 0.3 + if flag(hspec-jenkins) + build-depends: hspec-jenkins + ghc-options: -Wall + hs-source-dirs: examples + default-language: Haskell2010 diff --git a/examples/CountLog.hs b/examples/CountLog.hs new file mode 100644 --- /dev/null +++ b/examples/CountLog.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Demonstrates how to derive user-defined capabilities using this library. +module CountLog where + +import Capability.Reader +import Capability.State +import Control.Monad.IO.Class +import Control.Monad.Reader (ReaderT (..), runReaderT) +-- The @StateT@ constructor has to be imported even though it is not used +-- explicitly. Otherwise, the deriving via of @Counter CounterM@ would fail. +import Control.Monad.State.Strict (State, StateT (..), runState) +import qualified Data.Char +import Data.Coerce (coerce) +import Data.IORef +import GHC.Generics (Generic) +import Test.Common +import Test.Hspec + + +---------------------------------------------------------------------- +-- Logger Capability + + +class Monad m => Logger m where + logStr :: String -> m () + +-- | Any @HasReader "logger" (String -> IO ())@ can be a @Logger@. +newtype TheLoggerReader m a = TheLoggerReader (m a) + deriving (Functor, Applicative, Monad) +instance + (HasReader "logger" (String -> IO ()) m, MonadIO m) + => Logger (TheLoggerReader m) + where + logStr msg = + coerce (ask @"logger" >>= liftIO . ($ msg) :: m ()) + +-- Example program --------------------------------------------------- + +-- | Log the given number. +logNum :: Logger m => Int -> m () +logNum = logStr . ("num: " ++) . show + +-- ReaderT instance -------------------------------------------------- + +data LogCtx = LogCtx { logger :: String -> IO () } + deriving Generic + +regularLogger :: LogCtx +regularLogger = LogCtx { logger = putStrLn } + +loudLogger :: LogCtx +loudLogger = LogCtx { logger = putStrLn . map Data.Char.toUpper } + + +-- | Deriving @HasReader@ from @MonadReader@. +newtype LogM m (a :: *) = LogM (ReaderT LogCtx m a) + deriving (Functor, Applicative, Monad) + deriving Logger via + (TheLoggerReader (Field "logger" () + (MonadReader (ReaderT LogCtx m)))) + +runLogM :: LogCtx -> LogM m a -> m a +runLogM ctx (LogM m) = runReaderT m ctx + + +---------------------------------------------------------------------- +-- Counter Capability + + +class Monad m => Counter m where + count :: m Int + +-- | Any @HasState "counter" Int m@ can be a @Counter@. +newtype TheCounterState m a = TheCounterState (m a) + deriving (Functor, Applicative, Monad) +instance + (HasState "counter" Int m, Monad m) + => Counter (TheCounterState m) + where + count = coerce @(m Int) $ + state @"counter" $ \n -> let !n' = n + 1 in (n', n') + +-- Example program --------------------------------------------------- + +-- | Use a counter to count up twice. +doubleCount :: Counter m => m Int +doubleCount = count >> count + +-- StateT instance --------------------------------------------------- + +-- | Deriving @HasState@ from @MonadState@. +newtype CounterM a = CounterM (State Int a) + deriving (Functor, Applicative, Monad) + deriving Counter via + TheCounterState (MonadState (State Int)) + +runCounterM :: CounterM a -> (a, Int) +runCounterM (CounterM m) = runState m 0 + +-- ReaderT IORef instance -------------------------------------------- + +-- | Deriving @HasState@ from @HasReader@ of an @IORef@. +newtype Counter'M m (a :: *) = Counter'M (ReaderT (IORef Int) m a) + deriving (Functor, Applicative, Monad) + deriving Counter via + TheCounterState (ReaderIORef (MonadReader (ReaderT (IORef Int) m))) + +runCounter'M :: MonadIO m => Counter'M m a -> m a +runCounter'M (Counter'M m) = runReaderT m =<< liftIO (newIORef 0) + + +---------------------------------------------------------------------- +-- Mixed Capabilities + +-- Example program --------------------------------------------------- + +-- | Double count and log the result, repeat once. +mixed :: (Counter m, Logger m) => m () +mixed = do + doubleCount >>= logNum + doubleCount >>= logNum + +-- ReaderT instance -------------------------------------------------- + +data CountLogCtx = CountLogCtx + { countCtx :: IORef Int + , logCtx :: LogCtx + } deriving Generic + + +-- | Deriving two capabilities from the record fields of @MonadReader@. +newtype CountLogM m (a :: *) = CountLogM (ReaderT CountLogCtx m a) + deriving (Functor, Applicative, Monad) + deriving Counter via + TheCounterState (ReaderIORef (Rename "countCtx" (Field "countCtx" () + (MonadReader (ReaderT CountLogCtx m))))) + deriving Logger via + (TheLoggerReader (Field "logger" "logCtx" (Field "logCtx" () + (MonadReader (ReaderT CountLogCtx m))))) + +runCountLogM :: MonadIO m => CountLogM m b -> m b +runCountLogM (CountLogM m) = do + ref <- liftIO $ newIORef 0 + runReaderT m CountLogCtx + { countCtx = ref + , logCtx = regularLogger + } + + +---------------------------------------------------------------------- +-- Test Cases + +spec :: Spec +spec = do + describe "LogM" $ do + context "regularLogger" $ + it "evaluates logNum" $ + runLogM regularLogger (logNum 8) `shouldPrint` "num: 8\n" + context "loudLogger" $ + it "evaluates logNum" $ + runLogM loudLogger (logNum 8) `shouldPrint` "NUM: 8\n" + describe "CounterM" $ + it "evaluates doubleCount" $ + runCounterM doubleCount `shouldBe` (2, 2) + describe "Counter'M" $ + it "evaluates doubleCount" $ + runCounter'M doubleCount `shouldReturn` 2 + describe "CountLogM" $ do + it "evaluates logNum" $ + runCountLogM (logNum 8) `shouldPrint` "num: 8\n" + it "evaluates doubleCount" $ + runCountLogM doubleCount `shouldReturn` 2 + it "evaluates mixed" $ + runCountLogM mixed `shouldPrint` "num: 2\nnum: 4\n" diff --git a/examples/Error.hs b/examples/Error.hs new file mode 100644 --- /dev/null +++ b/examples/Error.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Example uses and instances of the @HasError@ capability. +module Error where + +import Capability.Error +import Control.Monad (when) +import Control.Monad.Except (ExceptT (..)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import GHC.Generics (Generic) +import Test.Common +import Test.Hspec +import Text.Read (readEither) + +---------------------------------------------------------------------- +-- Example Programs + +-- Calculator Example ------------------------------------------------ + +data ParserError + = InvalidInput String + deriving (Show, Typeable) + deriving anyclass Exception + +parseNumber :: HasThrow "parser" ParserError m + => String -> m Int +parseNumber input = case readEither input of + Left err -> throw @"parser" $ InvalidInput err + Right num -> pure num + + +data MathError + = NegativeInput + deriving (Show, Typeable) + deriving anyclass Exception + +sqrtNumber :: HasThrow "math" MathError m + => Int -> m Int +sqrtNumber num + | num < 0 = throw @"math" NegativeInput + | otherwise = pure $ round $ sqrt @Double $ fromIntegral num + + +-- | Errors that can occur in the calculator application. +data CalcError + -- | The parser component failed. + = ParserError ParserError + -- | The math component failed. + | MathError MathError + deriving (Generic, Show, Typeable) + deriving anyclass Exception + +-- | Calculator application +-- +-- Prompts for positive numbers and prints their square roots. +calculator :: + ( HasCatch "calc" CalcError m, MonadIO m ) + => m () +calculator = do + liftIO $ putStr "Enter positive number or 'Q' to quit\n> " + line <- liftIO getLine + case line of + "Q" -> pure () + input -> do + catch @"calc" + do + -- Errors in the parser or math component are converted to a + -- @CalcError@ by wrapping with the corresponding constructor. + let wrapParserError = wrapError @"calc" @"parser" + @(Rename "ParserError" :.: Ctor "ParserError" "calc") + wrapMathError = wrapError @"calc" @"math" + @(Rename "MathError" :.: Ctor "MathError" "calc") + num <- wrapParserError $ parseNumber input + root <- wrapMathError $ sqrtNumber num + liftIO $ putStrLn $ "sqrt = " ++ show root + \e -> liftIO $ putStrLn $ "Error: " ++ show e + calculator + + +-- Nested Example ---------------------------------------------------- + +nested :: (HasThrow "foo" String m, HasThrow "bar" () m) => Int -> m Int +nested n = do + when (n < 0) $ + throw @"foo" "negative number" + when (odd n) $ + throw @"bar" () + pure n + + +---------------------------------------------------------------------- +-- Instances + +-- | Deriving @HasThrow/HasCatch@ from @unliftio@. +newtype Calculator a = Calculator { runCalculator :: IO a } + deriving newtype (Functor, Applicative, Monad, MonadIO) + deriving + ( HasThrow "calc" CalcError + , HasCatch "calc" CalcError + ) via MonadUnliftIO CalcError IO + + +-- | Deriving separate @HasThrow@ capabilities from different transformer +-- layers. +newtype MaybeEither a = + MaybeEither { runMaybeEither :: Maybe (Either String a) } + deriving (Functor, Applicative, Monad) via + ExceptT String Maybe + deriving (HasThrow "foo" String) via + MonadError (ExceptT String Maybe) + deriving (HasThrow "bar" ()) via + Lift (ExceptT String (MonadError Maybe)) + + +---------------------------------------------------------------------- +-- Test Cases + +spec :: Spec +spec = do + describe "Calculator" $ + it "evaluates calculator" $ do + let input = "4\n-1\nxyz\nQ\n" + output = + "Enter positive number or 'Q' to quit\n\ + \> sqrt = 2\n\ + \Enter positive number or 'Q' to quit\n\ + \> Error: MathError NegativeInput\n\ + \Enter positive number or 'Q' to quit\n\ + \> Error: ParserError (InvalidInput \"Prelude.read: no parse\")\n\ + \Enter positive number or 'Q' to quit\n\ + \> " + runCalculator calculator + `withInput` input + `shouldPrint` output + describe "MaybeEither" $ + it "evaluates nested" $ do + runMaybeEither (nested 2) `shouldBe` Just (Right 2) + runMaybeEither (nested (-1)) `shouldBe` Just (Left "negative number") + runMaybeEither (nested 1) `shouldBe` Nothing diff --git a/examples/Reader.hs b/examples/Reader.hs new file mode 100644 --- /dev/null +++ b/examples/Reader.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} + +-- | Example uses and instances of the @HasReader@ capability. +module Reader where + +import Capability.Reader +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (ReaderT (..)) +import GHC.Generics (Generic) +import Test.Common +import Test.Hspec + + +---------------------------------------------------------------------- +-- Example Programs + +-- | Returns the triple of the number in context "foo". +tripleFoo :: HasReader "foo" Int m => m Int +tripleFoo = do + single <- ask @"foo" + double <- asks @"foo" (*2) + pure $ single + double + +-- | Prints the triple and sixfold of the number in context "foo". +fooExample :: (HasReader "foo" Int m, MonadIO m) => m () +fooExample = do + liftIO . print =<< tripleFoo + liftIO . print =<< local @"foo" (*2) tripleFoo + + +-- | Prints the double of "bar" and the triple of "foo". +fooBarExample + :: (HasReader "foo" Int m, HasReader "bar" Int m, MonadIO m) => m () +fooBarExample = do + local @"bar" (*2) $ do + liftIO . print =<< ask @"bar" + liftIO . print =<< tripleFoo + + +---------------------------------------------------------------------- +-- Instances + +-- | @HasReader@ instance derived via @MonadReader@. +newtype FooReaderT m (a :: *) = FooReaderT (ReaderT Int m a) + deriving (Functor, Applicative, Monad, MonadIO) + deriving (HasReader "foo" Int) via MonadReader (ReaderT Int m) + +runFooReaderT :: FooReaderT m a -> m a +runFooReaderT (FooReaderT m) = runReaderT m 1 + + +data FooBar = FooBar + { foo :: Int + , bar :: Int + } deriving Generic + +-- | Multiple @HasReader@ instances derived via record fields in @MonadReader@. +newtype FooBarReader a = FooBarReader (ReaderT FooBar IO a) + deriving (Functor, Applicative, Monad, MonadIO) + deriving (HasReader "foo" Int) via + Field "foo" () (MonadReader (ReaderT FooBar IO)) + deriving (HasReader "bar" Int) via + Field "bar" () (MonadReader (ReaderT FooBar IO)) + +runFooBarReader :: FooBarReader a -> IO a +runFooBarReader (FooBarReader m) = runReaderT m FooBar { foo = 1, bar = 2 } + + +-- | Multiple @HasReader@ instances on the same underlying @MonadReader@. +-- +-- Demonstrates colliding instances. +-- Note, do not do this in practice. The derived @HasReader@ instances interact +-- in unexpected ways. +newtype BadFooBarReader a = BadFooBarReader (ReaderT Int IO a) + deriving (Functor, Applicative, Monad, MonadIO) + deriving (HasReader "foo" Int) via MonadReader (ReaderT Int IO) + deriving (HasReader "bar" Int) via MonadReader (ReaderT Int IO) + +runBadFooBarReader :: BadFooBarReader a -> IO a +runBadFooBarReader (BadFooBarReader m) = runReaderT m 1 + + +---------------------------------------------------------------------- +-- Test Cases + +spec :: Spec +spec = do + describe "FooReaderT" $ + it "evaluates fooExample" $ + runFooReaderT fooExample `shouldPrint` "3\n6\n" + describe "FooBarReader" $ do + it "evaluates fooExample" $ + runFooBarReader fooExample `shouldPrint` "3\n6\n" + it "evaluates fooBarExample" $ + runFooBarReader fooBarExample `shouldPrint` "4\n3\n" + describe "BadFooBarReader" $ do + it "evaluates fooExample" $ + runBadFooBarReader fooExample `shouldPrint` "3\n6\n" + it "evaluates fooBarExample" $ + runBadFooBarReader fooBarExample `shouldNotPrint` "4\n3\n" diff --git a/examples/State.hs b/examples/State.hs new file mode 100644 --- /dev/null +++ b/examples/State.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} + +-- | Example uses and instances of the @HasState@ capability. +module State where + +import Capability.Reader +import Capability.State +import Control.Monad.Reader (ReaderT (..)) +import Control.Monad.State.Strict (State, StateT (..), runState) +import Data.IORef +import GHC.Generics (Generic) +import Test.Hspec + +---------------------------------------------------------------------- +-- Example Programs + +incFoo :: HasState "foo" Int m => m () +incFoo = modify @"foo" (+1) + +twoStates :: (HasState "foo" Int m, HasState "bar" Int m) => m () +twoStates = do + incFoo + modify @"bar" (subtract 1) + + +useZoom :: HasState "foobar" (Int, Int) m => m Int +useZoom = do + put @"foobar" (2, 2) + -- Zoom in on the first element in the current state, rename tag 1 to "foo". + zoom @"foobar" @"foo" @(Rename 1 :.: Pos 1 "foobar") $ + incFoo + gets @"foobar" (\(foo, bar) -> foo + bar) + + +---------------------------------------------------------------------- +-- Instances + +data TwoStates = TwoStates + { tsFoo :: IORef Int + , tsBar :: IORef Int + } deriving Generic + +-- | Deriving @HasState@ from @HasReader@ of an @IORef@. +-- +-- In this case two separate state capabilities are derived from the record +-- fields of the @HasReader@ context. +newtype TwoStatesM a = TwoStatesM (ReaderT TwoStates IO a) + deriving (Functor, Applicative, Monad) + deriving (HasState "foo" Int) via + ReaderIORef (Rename "tsFoo" (Field "tsFoo" () + (MonadReader (ReaderT TwoStates IO)))) + deriving (HasState "bar" Int) via + ReaderIORef (Rename "tsBar" (Field "tsBar" () + (MonadReader (ReaderT TwoStates IO)))) + +runTwoStatesM :: TwoStatesM a -> IO (a, (Int, Int)) +runTwoStatesM (TwoStatesM m) = do + fooRef <- newIORef 0 + barRef <- newIORef 0 + result <- runReaderT m TwoStates + { tsFoo = fooRef + , tsBar = barRef + } + fooVal <- readIORef fooRef + barVal <- readIORef barRef + pure (result, (fooVal, barVal)) + + +-- | Deriving two @HasState@ instances from the components of a tuple in +-- @MonadState@. +newtype PairStateM a = PairStateM (State (Int, Int) a) + deriving (Functor, Applicative, Monad) + deriving (HasState "foo" Int) via + Rename 1 (Pos 1 () (MonadState (State (Int, Int)))) + deriving (HasState "bar" Int) via + Rename 2 (Pos 2 () (MonadState (State (Int, Int)))) + +runPairStateM :: PairStateM a -> (a, (Int, Int)) +runPairStateM (PairStateM m) = runState m (0, 0) + + +-- | Combining the @HasState@ instances from two nested @StateT@ transformers. +-- +-- Note, that this is not the recommended way to provide multiple `HasState` +-- capabilities. Use the approach shown above in 'TwoStatesM' instead. However, +-- this pattern can be useful to transation existing code to this library. +newtype NestedStatesM a = NestedStatesM (StateT Int (State Int) a) + deriving (Functor, Applicative, Monad) + deriving (HasState "foo" Int) via MonadState (StateT Int (State Int)) + deriving (HasState "bar" Int) via Lift (StateT Int (MonadState (State Int))) + +runNestedStatesM :: NestedStatesM a -> ((a, Int), Int) +runNestedStatesM (NestedStatesM m) = runState (runStateT m 0) 0 + + +runFooBarState + :: (forall m. HasState "foobar" (Int, Int) m => m a) + -> (Int, Int) -> (a, (Int, Int)) +runFooBarState (MonadState m) = runState m + + +---------------------------------------------------------------------- +-- Test Cases + +spec :: Spec +spec = do + describe "TwoStatesM" $ + it "evaluates twoStates" $ + runTwoStatesM twoStates `shouldReturn` ((), (1, -1)) + describe "PairStateM" $ + it "evaluates twoStates" $ + runPairStateM twoStates `shouldBe` ((), (1, -1)) + describe "NestedStatesM" $ + it "evaluates twoStates" $ + runNestedStatesM twoStates `shouldBe` (((), 1), -1) + describe "runFooBarState" $ + it "evaluates useZoom" $ + runFooBarState useZoom (0, 0) `shouldBe` (5, (3, 2)) diff --git a/examples/Stream.hs b/examples/Stream.hs new file mode 100644 --- /dev/null +++ b/examples/Stream.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} + +-- | Example uses and instances of the @HasStream@ capability. +module Stream where + +import Capability.State +import Capability.Stream +import Control.Monad.State.Strict (State, StateT (..), evalStateT, runState) +import qualified Data.Set as Set +import Streaming (Stream, Of) +import qualified Streaming.Prelude as S +import Test.Common +import Test.Hspec + +---------------------------------------------------------------------- +-- Example Programs + +iota :: HasStream "nums" Int m => Int -> m () +iota n + | n < 0 = error "negative number passed to iota." + | otherwise = go 0 + where + go i + | i == n = pure () + | otherwise = yield @"nums" i >> go (succ i) + +labelledNodes + :: (HasState "counter" Int m, HasStream "out" (Int, a) m, Foldable t) + => t a -> m () +labelledNodes = mapM_ $ \a -> do + n <- state @"counter" $ \n -> (n, succ n) + yield @"out" (n, a) + + +---------------------------------------------------------------------- +-- Instances + +-- | @HasStream a@ derived from @HasState [a]@. Will produce reversed list. +newtype StreamAccM a = StreamAccM (State [Int] a) + deriving (Functor, Applicative, Monad) + deriving (HasStream "nums" Int) via + StreamStack (MonadState (State [Int])) + +runStreamAccM :: StreamAccM a -> (a, [Int]) +runStreamAccM (StreamAccM m) = runState m [] + + +-- | @'Streaming.Stream' ('Streaming.Of' a)@ has a @HasStream a@ instance. +printStreamOfInt :: Stream (Of Int) IO () -> IO () +printStreamOfInt = S.stdoutLn . S.map show + + +-- | Composed @StateT@ and @Stream@ to provide @HasState@ and @HasStream@. +newtype StateOverStream a = + StateOverStream (StateT Int (Stream (Of (Int, Char)) IO) a) + deriving (Functor, Applicative, Monad) + deriving (HasState "counter" Int) via + MonadState (StateT Int (Stream (Of (Int, Char)) IO)) + deriving (HasStream "out" (Int, Char)) via + Lift (StateT Int (Stream (Of (Int, Char)) IO)) + +printStateOverStream :: StateOverStream () -> IO () +printStateOverStream (StateOverStream m) = do + S.stdoutLn . S.map show $ evalStateT m 0 + +printLabelledNodes :: IO () +printLabelledNodes = + printStateOverStream $ labelledNodes $ + Set.fromList "Hello world!" + + +---------------------------------------------------------------------- +-- Test Cases + +spec :: Spec +spec = do + describe "StreamAccM" $ + it "evaluates iota" $ + runStreamAccM (iota 10) `shouldBe` ((), [9, 8 .. 0]) + describe "Stream (Of Int)" $ + it "evaluates iota" $ + printStreamOfInt (iota 3) `shouldPrint` "0\n1\n2\n" + describe "StateOverStream" $ do + it "evaluates labelledNodes" $ + printLabelledNodes `shouldPrint` + "(0,' ')\n(1,'!')\n(2,'H')\n(3,'d')\n(4,'e')\ + \\n(5,'l')\n(6,'o')\n(7,'r')\n(8,'w')\n" diff --git a/examples/Test.hs b/examples/Test.hs new file mode 100644 --- /dev/null +++ b/examples/Test.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} + +module Main + ( main + ) where + +import Test.Hspec +import Test.Hspec.Runner + +#ifdef MIN_VERSION_hspec_jenkins +import Test.Hspec.Formatters.Jenkins (xmlFormatter) +#endif + +import qualified CountLog +import qualified Error +import qualified Reader +import qualified State +import qualified Stream +import qualified Writer +import qualified WordCount + + +spec :: Spec +spec = do + describe "CountLog" CountLog.spec + describe "Error" Error.spec + describe "Reader" Reader.spec + describe "State" State.spec + describe "Stream" Stream.spec + describe "Writer" Writer.spec + describe "WordCount" WordCount.spec + + +main :: IO () +main = do + let cfg = defaultConfig +#ifdef MIN_VERSION_hspec_jenkins + { configFormatter = Just xmlFormatter } +#endif + hspecWith cfg spec diff --git a/examples/Test/Common.hs b/examples/Test/Common.hs new file mode 100644 --- /dev/null +++ b/examples/Test/Common.hs @@ -0,0 +1,45 @@ +module Test.Common + ( shouldPrint + , shouldNotPrint + , withInput + ) where + +import GHC.IO.Handle (hDuplicate, hDuplicateTo) +import System.IO +import System.IO.Silently (capture_) +import System.IO.Temp (withSystemTempFile) +import Test.Hspec +import UnliftIO.Exception (bracket) + + +shouldPrint :: IO a -> String -> IO () +shouldPrint action expected = do + actual <- capture_ action + actual `shouldBe` expected + + +shouldNotPrint :: IO a -> String -> IO () +shouldNotPrint action expected = do + actual <- capture_ action + actual `shouldNotBe` expected + + +-- | Execute the given action with @stdin@ redirected to read the given input. +withInput :: IO a -> String -> IO a +withInput action input = + withSystemTempFile "capability-mock-input" $ \tmpFile tmpOut -> do + -- write input to temp-file + hPutStr tmpOut input + hClose tmpOut + -- read stdin from temp-file + buffering <- hGetBuffering stdin + withFile tmpFile ReadMode $ \tmpIn -> do + let redirect = do + old <- hDuplicate stdin + hDuplicateTo tmpIn stdin + pure old + restore old = do + hDuplicateTo old stdin + hSetBuffering stdin buffering + hClose old + bracket redirect restore (\_ -> action) diff --git a/examples/WordCount.hs b/examples/WordCount.hs new file mode 100644 --- /dev/null +++ b/examples/WordCount.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} + +module WordCount where + +import Capability.Reader +import Capability.State +import Capability.Writer +import Control.Lens (ifor_) +import Data.Coerce (coerce) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Control.Monad.Reader (ReaderT (..)) +import Data.IORef +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Monoid (Sum (..)) +import GHC.Generics (Generic) +import Test.Common +import Test.Hspec + +-- | Accumulating key-value mapping. +-- +-- The 'Monoid' instance will 'mappend' +-- values to keys that occur on both sides. +newtype Accum map = Accum map + +instance (Ord k, Semigroup v) + => Semigroup (Accum (Map k v)) where + (<>) = coerce $ Map.unionWith @k @v (<>) + +instance (Ord k, Semigroup v) + => Monoid (Accum (Map k v)) where + mempty = coerce $ Map.empty @k @v + mappend = (<>) + + +-- | Counts occurrences of values @k@. +newtype Occurrences k = Occurrences (Map k Int) + deriving (Monoid, Semigroup) via Accum (Map k (Sum Int)) + deriving Show + +-- | A single occurrence of the given value. +oneOccurrence :: k -> Occurrences k +oneOccurrence k = Occurrences $ Map.singleton k 1 + + +-- | Count the occurrence of a single letter. +countLetter :: + HasWriter "letterCount" (Occurrences Char) m + => Char -> m () +countLetter letter = tell @"letterCount" (oneOccurrence letter) + +-- | Count the occurrence of a single word. +countWord :: + HasWriter "wordCount" (Occurrences Text) m + => Text -> m () +countWord word = tell @"wordCount" (oneOccurrence word) + + +-- | Count the occurrence of a single word and all the letters in it. +countWordAndLetters :: + ( HasWriter "letterCount" (Occurrences Char) m + , HasWriter "wordCount" (Occurrences Text) m ) + => Text -> m () +countWordAndLetters word = do + countWord word + mapM_ countLetter (Text.unpack word) + + +-- | Count the occurrences of words and letters in a text, +-- excluding white space. +countWordsAndLettersInText :: + ( HasWriter "letterCount" (Occurrences Char) m + , HasWriter "wordCount" (Occurrences Text) m ) + => Text -> m () +countWordsAndLettersInText text = + mapM_ countWordAndLetters (Text.words text) + + +-- | Counter application context. +data CounterCtx = CounterCtx + { letterCount :: IORef (Occurrences Char) + -- ^ Counting letter occurrences. + , wordCount :: IORef (Occurrences Text) + -- ^ Counting word occurrences. + } deriving Generic + +-- | Counter application monad. +newtype Counter a = Counter { runCounter :: CounterCtx -> IO a } + deriving (Functor, Applicative, Monad) via (ReaderT CounterCtx IO) + deriving (HasWriter "letterCount" (Occurrences Char)) via + (WriterLog -- Generate HasWriter using HasState of Monoid + (ReaderIORef -- Generate HasState from HasReader of IORef + (Field "letterCount" "ctx" -- Focus on the field letterCount + (MonadReader -- Generate HasReader using mtl MonadReader + (ReaderT CounterCtx IO))))) -- Use mtl ReaderT newtype + deriving (HasWriter "wordCount" (Occurrences Text)) via + WriterLog (ReaderIORef + (Field "wordCount" "ctx" (MonadReader (ReaderT CounterCtx IO)))) + + +-- | Given a text count the occurrences of all words and letters in it, +-- excluding white space, and print the outcome to standard output. +wordAndLetterCount :: Text -> IO () +wordAndLetterCount text = do + lettersRef <- newIORef $ Occurrences Map.empty + wordsRef <- newIORef $ Occurrences Map.empty + let ctx = CounterCtx + { letterCount = lettersRef + , wordCount = wordsRef + } + counter :: Counter () + counter = countWordsAndLettersInText text + runCounter counter ctx + let printOccurrencesOf name ref = do + putStrLn name + Occurrences occurrences <- readIORef ref + ifor_ occurrences $ \item num -> + putStrLn $ show item ++ ": " ++ show num + printOccurrencesOf "Letters" lettersRef + printOccurrencesOf "Words" wordsRef + + +---------------------------------------------------------------------- +-- Test Cases + +spec :: Spec +spec = do + describe "Counter" $ do + it "handles the empty text" $ + wordAndLetterCount "" `shouldPrint` + "Letters\n\ + \Words\n" + it "handles one word" $ + wordAndLetterCount "banana" `shouldPrint` + "Letters\n'a': 3\n'b': 1\n'n': 2\n\ + \Words\n\"banana\": 1\n" + it "handles two words" $ + wordAndLetterCount "mississipi river" `shouldPrint` + "Letters\n'e': 1\n'i': 5\n'm': 1\n'p': 1\n'r': 2\n's': 4\n'v': 1\n\ + \Words\n\"mississipi\": 1\n\"river\": 1\n" + it "handles two lines" $ + wordAndLetterCount "banana apple\napple banana" `shouldPrint` + "Letters\n'a': 8\n'b': 2\n'e': 2\n'l': 2\n'n': 4\n'p': 4\n\ + \Words\n\"apple\": 2\n\"banana\": 2\n" diff --git a/examples/Writer.hs b/examples/Writer.hs new file mode 100644 --- /dev/null +++ b/examples/Writer.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} + +-- | Example uses and instances of the @HasWriter@ capability. +module Writer where + +import Capability.State +import Capability.Writer +import Control.Monad.State.Strict (State, StateT (..), runState) +import Data.Monoid (Sum (..)) +import Test.Hspec + +---------------------------------------------------------------------- +-- Example Programs + +-- | Increase a counter using a writer monad. +useWriter :: HasWriter "count" (Sum Int) m => m () +useWriter = do + tell @"count" 1 + tell @"count" 2 + tell @"count" 3 + + +-- | Mix writer and state monad operations on the same tag. +-- +-- Note, mixing capabilities on the same tag like this is inadvisable in +-- real applications. The @HasState@ capability could be used to clear the +-- accumulated outcome of the @HasWriter@ capability. +mixWriterState + :: (HasState "count" Int m, HasWriter "count" (Sum Int) m) + => m Int +mixWriterState = do + tell @"count" 1 + one <- get @"count" + tell @"count" $ Sum one + pure one + + +---------------------------------------------------------------------- +-- Instances + +-- | @HasWriter w@ capability derived from @HasState w@. +-- +-- The monoid instance ('Data.Monoid.Sum') is also selected in the deriving +-- via clause. +newtype WriterM a = WriterM (State Int a) + deriving (Functor, Applicative, Monad) + deriving (HasWriter "count" (Sum Int)) + via WriterLog (Coerce (Sum Int) (MonadState (State Int))) + +runWriterM :: WriterM a -> (a, Int) +runWriterM (WriterM m) = runState m 0 + + +-- | @HasWriter w@ capability derived from @HasState w@, while also exposing +-- the underlying @HasState@. +-- +-- Note, that this is inadvisable in real applications. +-- See caveat on 'mixWriterState'. +newtype BadWriterM a = BadWriterM (State Int a) + deriving (Functor, Applicative, Monad) + deriving (HasWriter "count" (Sum Int)) + via WriterLog (Coerce (Sum Int) (MonadState (State Int))) + deriving (HasState "count" Int) + via MonadState (State Int) + +runBadWriterM :: BadWriterM a -> (a, Int) +runBadWriterM (BadWriterM m) = runState m 0 + + +---------------------------------------------------------------------- +-- Test Cases + +spec :: Spec +spec = do + describe "WriterM" $ + it "evaluates useWriter" $ + runWriterM useWriter `shouldBe` ((), 6) + describe "BadWriterM" $ do + it "evaluates useWriter" $ + runBadWriterM useWriter `shouldBe` ((), 6) + it "evaluates mixWriterState" $ + runBadWriterM mixWriterState `shouldBe` (1, 2) diff --git a/src/Capability.hs b/src/Capability.hs new file mode 100644 --- /dev/null +++ b/src/Capability.hs @@ -0,0 +1,90 @@ +-- | A capability is a type class over a monad which specifies the effects that +-- a function is allowed to perform. Capabilities differ from traditional monad +-- transformer type classes in that they are completely independent of the way +-- the monad is constructed. A state capability can for instance be implemented +-- as a lens on a field in a larger state monad, or an error capability could +-- provide for throwing only a subset of the errors of an error monad. +-- +-- This library defines several standard, reusable capabilities that replace the +-- mtl's monad-transformer type classes. Because capabilities are not tied to +-- a particular implementation of the monad, they cannot be discharged by +-- instance resolution. Instead this library provides combinators in the form of +-- newtypes with instances, to be used with deriving-via. To learn about +-- deriving via, watch Baldur Blondal's introductory video +-- . +-- +-- By way of comparison, with the mtl you would write something like +-- +-- @ +-- foo :: (MonadReader E, MonadState S) => a -> m () +-- @ +-- +-- You can use @foo@ at type @a -> ReaderT E (State S)@. But you can't use @foo@ +-- with the @ReaderT@ pattern +-- . With this +-- library, you would instead have: +-- +-- @ +-- foo :: (HasReader "conf" E, HasState "st" S) => a -> m () +-- @ +-- +-- Where @"conf"@ and @"st"@ are the names (also referred to as tags) of the +-- capabilities demanded by foo. Contrary to the mtl, capabilities are named, +-- rather than disambiguated by the type of their implied state, or exception. +-- This makes it easy to have multiple state capabilities. +-- +-- To /provide/ these capabilities, for instance with the ReaderT pattern, do as +-- follows (for a longer form tutorial, check the +-- ): +-- +-- @ +-- newtype MyM a = MyM (ReaderT (E, IORef s)) +-- deriving (Functor, Applicative, Monad) +-- deriving (HasState "st" Int) via +-- ReaderIORef (Rename 2 (Pos 2 () +-- (MonadReader (ReaderT (E, IORef s) IO)))) +-- deriving (HasReader "conf" Int) via +-- (Rename 1 (Pos 1 () +-- (MonadReader (ReaderT (E, IORef s) IO)))) +-- @ +-- +-- Then you can use @foo@ at type @MyM@. Or any other type which can provide +-- these capabilites. +-- +-- == Module structure +-- +-- Each module introduces a capability type class (or several related type +-- classes). Each class comes with a number of instances on newtypes (each +-- newtype should be seen as a combinator to be used with deriving-via to +-- provide the capability). Many newtypes come from the common +-- "Capability.Accessors" module (re-exported by each of the other modules), +-- which in particular contains a number of ways to address components of a data +-- type using the generic-lens library. +-- +-- * "Capability.Reader" reader effects +-- * "Capability.State" state effects +-- * "Capability.Writer" writer effects +-- * "Capability.Error" throw and catch errors +-- * "Capability.Stream" streaming effect (aka generators) +-- +-- Some of the capability modules have a “discouraged” companion (such as +-- "Capability.Writer.Discouraged"). These modules contain deriving-via +-- combinators which you can use if you absolutely must: they are correct, but +-- inefficient, so we recommend that you do not. +-- +-- == Further considerations +-- +-- The tags of capabilities can be of any kind, they are not restricted to +-- symbols. When exporting functions demanding capabilities in libraries, it is +-- recommended to use a type as follows: +-- +-- @ +-- data Conf +-- +-- foo :: HasReader Conf C => m () +-- @ +-- +-- This way, @Conf@ can be qualified in case of a name conflict with another +-- library. + +module Capability where diff --git a/src/Capability/Accessors.hs b/src/Capability/Accessors.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Accessors.hs @@ -0,0 +1,161 @@ +-- | Defines @newtype@s that serve as combinators +-- to compose deriving via strategies. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} + +module Capability.Accessors + ( Coerce(..) + , Rename(..) + , Field(..) + , Pos(..) + , Ctor(..) + , Lift(..) + , (:.:)(..) + ) where + +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Primitive (PrimMonad) +import GHC.TypeLits (Nat, Symbol) + +-- | Coerce the type in the context @m@ to @to@. +-- +-- Example: +-- +-- @ +-- newtype MyInt = MyInt Int +-- newtype MyReader a = MyReader (Reader Int a) +-- deriving (HasReader "a" MyInt) via +-- Coerce MyInt (MonadReader (Reader Int)) +-- @ +-- +-- Converts the @'Capability.Reader.HasReader' \"a\" Int@ instance of +-- @'Capability.Reader.MonadReader' (Reader Int)@ to a +-- @'Capability.Reader.HasReader' \"a\" MyInt@ +-- instance using @Coercible Int MyInt@. +newtype Coerce (to :: *) m (a :: *) = Coerce (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +-- | Rename the tag. +-- +-- Example: +-- +-- @ +-- newtype MyReader a = MyReader (Reader Int a) +-- deriving (HasReader "foo" Int) via +-- Rename "bar" (MonadReader (Reader Int)) +-- @ +-- +-- Converts the @'Capability.Reader.HasReader' \"bar\" Int@ instance of +-- @'Capability.Reader.MonadReader' (Reader Int)@ to a +-- @'Capability.Reader.HasReader' \"foo\" Int@ instance by renaming the tag. +-- +-- Note, that 'Capability.Reader.MonadReader' itself does not fix a tag, +-- and @Rename@ is redundant in this example. +-- +-- See 'Pos' below for a common use-case. +newtype Rename (oldtag :: k) m (a :: *) = Rename (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +-- | Access the record field @field@ in the context @m@. +-- +-- Example: +-- +-- @ +-- data Foo = Foo { foo :: Int } +-- newtype MyReader a = MyReader (Reader Foo a) +-- deriving (HasReader "foo" Int) via +-- Field "foo" () (MonadReader (Reader Foo)) +-- @ +-- +-- Converts the @'Capability.Reader.HasReader' () Foo@ instance of +-- @'Capability.Reader.MonadReader' (Reader Foo)@ to a +-- @'Capability.Reader.HasReader' \"foo\" Int@ +-- instance by focusing on the field @foo@ in the @Foo@ record. +-- +-- See 'Rename' for a way to change the tag. +newtype Field (field :: Symbol) (oldtag :: k) m (a :: *) = Field (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +-- | Access the value at position @pos@ in the context @m@. +-- +-- Example: +-- +-- @ +-- newtype MyReader a = MyReader (Reader (Int, Bool) a) +-- deriving (HasReader 1 Int) via +-- Pos 1 () (MonadReader (Reader (Int, Bool))) +-- @ +-- +-- Converts the @'Capability.Reader.HasReader' () (Int, Bool)@ instance of +-- @'Capability.Reader.MonadReader' (Reader (Int, Bool))@ to a +-- @'Capability.Reader.HasReader' 1 Int@ instance +-- by focusing on the first element of the tuple. +-- +-- The implied number tag can be renamed to a more descriptive name using +-- the 'Rename' combinator: +-- +-- @ +-- newtype MyReader a = MyReader (Reader (Int, Bool) a) +-- deriving (HasReader "foo" Int) via +-- Rename 1 (Pos 1 () (MonadReader (Reader (Int, Bool)))) +-- @ +newtype Pos (pos :: Nat) (oldtag :: k) m (a :: *) = Pos (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +-- | Choose the given constructor in the sum-type in context @m@. +-- +-- Example: +-- +-- @ +-- data MyError = ErrA String | ErrB String +-- newtype MyExcept a = MyExcept (ExceptT MyError Identity a) +-- deriving (HasThrow \"ErrB" String) via +-- Ctor \"ErrB" () (MonadError (ExceptT MyError Identity)) +-- @ +-- +-- Converts the @'Capability.Error.HasThrow' () \"MyError\"@ instance of +-- @'Capability.Error.MonadError' (ExceptT MyError Identity)@ to a +-- @'Capability.Error.HasThrow' \"ErrB\" String@ +-- instance by wrapping thrown @String@s in the @ErrB@ constructor. +newtype Ctor (ctor :: Symbol) (oldtag :: k) m (a :: *) = Ctor (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +-- | Skip one level in a monad transformer stack. +-- +-- Note, that instances generated with this strategy can incur a performance +-- penalty. +-- +-- Example: +-- +-- @ +-- newtype MyStates a = MyStates (StateT Int (State Bool) a) +-- deriving (HasState "foo" Bool) via +-- Lift (StateT Int (MonadState (State Bool))) +-- @ +-- +-- Uses the 'Control.Monad.Trans.Class.MonadTrans' instance of +-- @StateT Int@ to lift +-- the @'Capability.State.HasState' "\foo\" Bool@ instance of the underlying +-- @'Capability.State.MonadState' (State Bool)@ over the +-- @StateT Int@ monad transformer. +newtype Lift m (a :: *) = Lift (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + + +-- | Compose two accessors. +-- +-- This is not necessary in deriving via clauses, but in places where a +-- transformer is expected as a type argument. E.g. 'HasError.wrapError'. +newtype (:.:) + (t2 :: (* -> *) -> * -> *) + (t1 :: (* -> *) -> * -> *) + (m :: * -> *) + (a :: *) + = (:.:) (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) +infixr 9 :.: diff --git a/src/Capability/Error.hs b/src/Capability/Error.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Error.hs @@ -0,0 +1,423 @@ +-- | Defines capabilities for actions that may fail or throw exceptions, +-- and optionally may catch exceptions. +-- +-- Monads based on @IO@ can use the underlying @IO@ exception mechanism +-- to that end. The details of synchronous and asynchronous exception +-- handling depend on the strategy used. +-- See 'MonadThrow', 'SafeExceptions', 'MonadUnliftIO'. +-- +-- The associated tag can be used to select the exception type, or to +-- select a layer in monad transformer stacks. Note, that it is illegal +-- to have multiple tags refer to overlapping exception types in the same +-- layer. Consider the following example +-- +-- @ +-- newtype M a = M (IO a) +-- deriving (HasThrow "foo" IOException) via +-- MonadUnliftIO IO +-- deriving (HasThrow "bar" SomeException) via +-- MonadUnliftIO IO +-- @ +-- +-- In this case the tags @"foo"@ and @"bar"@ refer to overlapping exception +-- types in the same layer, because @catch \@"bar"@ may also catch an exception +-- thrown under @"foo"@. + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} + +module Capability.Error + ( -- * Interface + HasThrow(..) + , throw + , HasCatch(..) + , catch + , catchJust + , wrapError + -- * Strategies + , MonadError(..) + , MonadThrow(..) + , MonadCatch(..) + , SafeExceptions(..) + , MonadUnliftIO(..) + -- ** Modifiers + , module Capability.Accessors + -- * Re-exported + , Exception(..) + , Typeable + ) where + +import Capability.Accessors +import Control.Exception (Exception(..)) +import qualified Control.Exception.Safe as Safe +import Control.Lens (preview, review) +import Control.Monad ((<=<)) +import qualified Control.Monad.Catch as Catch +import qualified Control.Monad.Except as Except +import Control.Monad.IO.Class (MonadIO) +import qualified Control.Monad.IO.Unlift as UnliftIO +import Control.Monad.Primitive (PrimMonad) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.Trans.Control (MonadTransControl(..)) +import Data.Coerce (Coercible, coerce) +import qualified Data.Generics.Sum.Constructors as Generic +import Data.Typeable (Typeable) +import GHC.Exts (Proxy#, proxy#) +import qualified UnliftIO.Exception as UnliftIO + +-- | Capability to throw exceptions of type @e@ under @tag@. +-- +-- @HasThrow@/@HasCatch@ capabilities at different tags should be independent. +-- See 'HasCatch'. +class Monad m + => HasThrow (tag :: k) (e :: *) (m :: * -> *) | tag m -> e + where + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasReader'. + -- Otherwise, you will want to use 'throw'. + -- See 'throw' for more documentation. + throw_ :: Proxy# tag -> e -> m a + +-- | Throw an exception in the specified exception capability. +throw :: forall tag e m a. HasThrow tag e m => e -> m a +throw = throw_ (proxy# @_ @tag) +{-# INLINE throw #-} + +-- | Capability to catch exceptions of type @e@ under @tag@. +-- +-- @HasThrow@/@HasCatch@ capabilities at different tags should be independent. +-- In particular, the following program should throw @SomeError@ and not +-- return @()@. +-- > example :: +-- > (HasThrow "Left" SomeError m, HasCatch "Right" SomeError m) +-- > => m () +-- > example = +-- > catch @"Left" +-- > (throw @"Right" SomeError) +-- > \_ -> pure () +-- +-- See 'wrapError' for a way to combine multiple exception types into one. +class HasThrow tag e m + => HasCatch (tag :: k) (e :: *) (m :: * -> *) | tag m -> e + where + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasReader'. + -- Otherwise, you will want to use 'catch'. + -- See 'catch' for more documentation. + catch_ :: Proxy# tag -> m a -> (e -> m a) -> m a + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasReader'. + -- Otherwise, you will want to use 'catchJust'. + -- See 'catchJust' for more documentation. + catchJust_ :: Proxy# tag -> (e -> Maybe b) -> m a -> (b -> m a) -> m a + +-- | Provide a handler for exceptions thrown in the given action +-- in the given exception capability. +catch :: forall tag e m a. HasCatch tag e m => m a -> (e -> m a) -> m a +catch = catch_ (proxy# @_ @tag) +{-# INLINE catch #-} + +-- | Like 'catch', but only handle the exception if the provided function +-- returns 'Just'. +catchJust :: forall tag e m a b. HasCatch tag e m + => (e -> Maybe b) -> m a -> (b -> m a) -> m a +catchJust = catchJust_ (proxy# @_ @tag) +{-# INLINE catchJust #-} + +-- | Wrap exceptions @inner@ originating from the given action according to +-- the accessor @t@. +-- +-- Example: +-- +-- > wrapError +-- > @"AppError" @"ComponentError" @(Ctor "ComponentError" "AppError") +-- > component +-- > +-- > component :: HasError "ComponentError" ComponentError m => m () +-- > data AppError = ComponentError ComponentError +-- +-- This function is experimental and subject to change. +-- See . +wrapError :: forall outertag innertag t outer inner m a. + ( forall x. Coercible (t m x) (m x) + , forall m'. HasCatch outertag outer m' + => HasCatch innertag inner (t m') + , HasCatch outertag outer m ) + => (forall m'. HasCatch innertag inner m' => m' a) -> m a +wrapError action = coerce @(t m a) action +{-# INLINE wrapError #-} + +-- XXX: Does it make sense to add a HasMask capability similar to @MonadMask@? +-- What would the meaning of the tag be? + +-- | Derive 'HasError from @m@'s 'Control.Monad.Except.MonadError' instance. +newtype MonadError m (a :: *) = MonadError (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +instance Except.MonadError e m => HasThrow tag e (MonadError m) where + throw_ :: forall a. Proxy# tag -> e -> MonadError m a + throw_ _ = coerce @(e -> m a) $ Except.throwError + {-# INLINE throw_ #-} + +instance Except.MonadError e m => HasCatch tag e (MonadError m) where + catch_ :: forall a. + Proxy# tag -> MonadError m a -> (e -> MonadError m a) -> MonadError m a + catch_ _ = coerce @(m a -> (e -> m a) -> m a) $ Except.catchError + {-# INLINE catch_ #-} + catchJust_ :: forall a b. + Proxy# tag + -> (e -> Maybe b) + -> MonadError m a + -> (b -> MonadError m a) + -> MonadError m a + catchJust_ tag f m h = catch_ tag m $ \e -> maybe (throw_ tag e) h $ f e + {-# INLINE catchJust_ #-} + +-- | Derive 'HasThrow' from @m@'s 'Control.Monad.Catch.MonadThrow' instance. +newtype MonadThrow (e :: *) m (a :: *) = MonadThrow (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +instance (Catch.Exception e, Catch.MonadThrow m) + => HasThrow tag e (MonadThrow e m) + where + throw_ :: forall a. Proxy# tag -> e -> MonadThrow e m a + throw_ _ = coerce @(e -> m a) $ Catch.throwM + {-# INLINE throw_ #-} + +-- | Derive 'HasCatch from @m@'s 'Control.Monad.Catch.MonadCatch instance. +newtype MonadCatch (e :: *) m (a :: *) = MonadCatch (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + deriving (HasThrow tag e) via MonadThrow e m + +instance (Catch.Exception e, Catch.MonadCatch m) + => HasCatch tag e (MonadCatch e m) + where + catch_ :: forall a. + Proxy# tag + -> MonadCatch e m a + -> (e -> MonadCatch e m a) + -> MonadCatch e m a + catch_ _ = coerce @(m a -> (e -> m a) -> m a) $ Catch.catch + {-# INLINE catch_ #-} + catchJust_ :: forall a b. + Proxy# tag + -> (e -> Maybe b) + -> MonadCatch e m a + -> (b -> MonadCatch e m a) + -> MonadCatch e m a + catchJust_ _ = coerce @((e -> Maybe b) -> m a -> (b -> m a) -> m a) $ + Catch.catchJust + {-# INLINE catchJust_ #-} + + +-- | Derive 'HasError' using the functionality from the @safe-exceptions@ +-- package. +newtype SafeExceptions (e :: *) m (a :: *) = SafeExceptions (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +instance (Safe.Exception e, Safe.MonadThrow m) + => HasThrow tag e (SafeExceptions e m) + where + throw_ :: forall a. Proxy# tag -> e -> SafeExceptions e m a + throw_ _ = coerce @(e -> m a) $ Safe.throw + {-# INLINE throw_ #-} + +instance (Safe.Exception e, Safe.MonadCatch m) + => HasCatch tag e (SafeExceptions e m) + where + catch_ :: forall a. + Proxy# tag + -> SafeExceptions e m a + -> (e -> SafeExceptions e m a) + -> SafeExceptions e m a + catch_ _ = coerce @(m a -> (e -> m a) -> m a) $ Safe.catch + {-# INLINE catch_ #-} + catchJust_ :: forall a b. + Proxy# tag + -> (e -> Maybe b) + -> SafeExceptions e m a + -> (b -> SafeExceptions e m a) + -> SafeExceptions e m a + catchJust_ _ = coerce @((e -> Maybe b) -> m a -> (b -> m a) -> m a) $ + Safe.catchJust + {-# INLINE catchJust_ #-} + +-- | Derive 'HasError' using the functionality from the @unliftio@ package. +newtype MonadUnliftIO (e :: *) m (a :: *) = MonadUnliftIO (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +instance (UnliftIO.Exception e, MonadIO m) + => HasThrow tag e (MonadUnliftIO e m) + where + throw_ :: forall a. Proxy# tag -> e -> MonadUnliftIO e m a + throw_ _ = coerce @(e -> m a) $ UnliftIO.throwIO + {-# INLINE throw_ #-} + +instance (UnliftIO.Exception e, UnliftIO.MonadUnliftIO m) + => HasCatch tag e (MonadUnliftIO e m) + where + catch_ :: forall a. + Proxy# tag + -> MonadUnliftIO e m a + -> (e -> MonadUnliftIO e m a) + -> MonadUnliftIO e m a + catch_ _ = coerce @(m a -> (e -> m a) -> m a) $ UnliftIO.catch + {-# INLINE catch_ #-} + catchJust_ :: forall a b. + Proxy# tag + -> (e -> Maybe b) + -> MonadUnliftIO e m a + -> (b -> MonadUnliftIO e m a) + -> MonadUnliftIO e m a + catchJust_ _ = coerce @((e -> Maybe b) -> m a -> (b -> m a) -> m a) $ + UnliftIO.catchJust + {-# INLINE catchJust_ #-} + +-- | Rename the tag. +-- +-- Apply cautiously. See @'HasCatch' newtag e ('Rename' oldtag m)@. +instance HasThrow oldtag e m => HasThrow newtag e (Rename oldtag m) where + throw_ :: forall a. Proxy# newtag -> e -> Rename oldtag m a + throw_ _ = coerce @(e -> m a) $ throw @oldtag + {-# INLINE throw_ #-} + +-- | Rename the tag. +-- +-- Apply cautiously. E.g. the following code produces colliding instances, +-- where exceptions thrown in @\"Foo\"@ cannot be distinguished from exceptions +-- thrown in @\"Bar\"@ and vice-versa. +-- +-- > newtype Bad a = Bad (IO a) +-- > deriving (Functor, Applicative, Monad) +-- > deriving +-- > ( HasThrow "Foo" m +-- > , HasCatch "Foo" m +-- > ) via Rename () (MonadUnliftIO SomeError IO) +-- > deriving +-- > ( HasThrow "Bar" m +-- > , HasCatch "Bar" m +-- > ) via Rename () (MonadUnliftIO SomeError IO) +instance HasCatch oldtag e m => HasCatch newtag e (Rename oldtag m) where + catch_ :: forall a. + Proxy# newtag + -> Rename oldtag m a + -> (e -> Rename oldtag m a) + -> Rename oldtag m a + catch_ _ = coerce @(m a -> (e -> m a) -> m a) $ catch @oldtag + {-# INLINE catch_ #-} + catchJust_ :: forall a b. + Proxy# newtag + -> (e -> Maybe b) + -> Rename oldtag m a + -> (b -> Rename oldtag m a) + -> Rename oldtag m a + catchJust_ _ = coerce @((e -> Maybe b) -> m a -> (b -> m a) -> m a) $ + catchJust @oldtag + {-# INLINE catchJust_ #-} + +-- | Wrap the exception @e@ with the constructor @ctor@ to throw an exception +-- of type @sum@. +instance + -- The constraint raises @-Wsimplifiable-class-constraints@. This could + -- be avoided by instead placing @AsConstructor'@s constraints here. + -- Unfortunately, it uses non-exported symbols from @generic-lens@. + (Generic.AsConstructor' ctor sum e, HasThrow oldtag sum m) + => HasThrow ctor e (Ctor ctor oldtag m) + where + throw_ :: forall a. Proxy# ctor -> e -> Ctor ctor oldtag m a + throw_ _ = coerce @(e -> m a) $ + throw @oldtag . review (Generic._Ctor' @ctor @sum) + {-# INLINE throw_ #-} + +-- | Catch an exception of type @sum@ if its constructor matches @ctor@. +instance + -- The constraint raises @-Wsimplifiable-class-constraints@. This could + -- be avoided by instead placing @AsConstructor'@s constraints here. + -- Unfortunately, it uses non-exported symbols from @generic-lens@. + (Generic.AsConstructor' ctor sum e, HasCatch oldtag sum m) + => HasCatch ctor e (Ctor ctor oldtag m) + where + catch_ :: forall a. + Proxy# ctor + -> Ctor ctor oldtag m a + -> (e -> Ctor ctor oldtag m a) + -> Ctor ctor oldtag m a + catch_ _ = coerce @(m a -> (e -> m a) -> m a) $ + catchJust @oldtag @sum $ preview (Generic._Ctor' @ctor @sum) + {-# INLINE catch_ #-} + catchJust_ :: forall a b. + Proxy# ctor + -> (e -> Maybe b) + -> Ctor ctor oldtag m a + -> (b -> Ctor ctor oldtag m a) + -> Ctor ctor oldtag m a + catchJust_ _ = coerce @((e -> Maybe b) -> m a -> (b -> m a) -> m a) $ \f -> + catchJust @oldtag @sum $ f <=< preview (Generic._Ctor' @ctor @sum) + {-# INLINE catchJust_ #-} + +-- | Lift one layer in a monad transformer stack. +instance + ( HasThrow tag e m, MonadTrans t, Monad (t m) ) + => HasThrow tag e (Lift (t m)) + where + throw_ :: forall a. Proxy# tag -> e -> Lift (t m) a + throw_ tag = coerce @(e -> t m a) $ lift . throw_ tag + {-# INLINE throw_ #-} + +-- | Lift one layer in a monad transformer stack. +instance + ( HasCatch tag e m, MonadTransControl t, Monad (t m) ) + => HasCatch tag e (Lift (t m)) + where + catch_ :: forall a. + Proxy# tag + -> Lift (t m) a + -> (e -> Lift (t m) a) + -> Lift (t m) a + catch_ tag = coerce @(t m a -> (e -> t m a) -> t m a) $ \m h -> + liftWith (\run -> catch_ tag (run m) (run . h)) >>= restoreT . pure + {-# INLINE catch_ #-} + catchJust_ :: forall a b. + Proxy# tag + -> (e -> Maybe b) + -> Lift (t m) a + -> (b -> Lift (t m) a) + -> Lift (t m) a + catchJust_ tag = + coerce @((e -> Maybe b) -> t m a -> (b -> t m a) -> t m a) $ \f m h -> + liftWith (\run -> catchJust_ tag f (run m) (run . h)) >>= restoreT . pure + {-# INLINE catchJust_ #-} + + +-- | Compose two accessors. +deriving via ((t2 :: (* -> *) -> * -> *) ((t1 :: (* -> *) -> * -> *) m)) + instance + ( forall x. Coercible (m x) (t2 (t1 m) x) + , Monad m, HasThrow tag e (t2 (t1 m)) ) + => HasThrow tag e ((t2 :.: t1) m) + + +-- | Compose two accessors. +deriving via ((t2 :: (* -> *) -> * -> *) ((t1 :: (* -> *) -> * -> *) m)) + instance + ( forall x. Coercible (m x) (t2 (t1 m) x) + , Monad m, HasCatch tag e (t2 (t1 m)) ) + => HasCatch tag e ((t2 :.: t1) m) diff --git a/src/Capability/Reader.hs b/src/Capability/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Reader.hs @@ -0,0 +1,18 @@ +-- | Defines a capability type class for a reader effect. A reader provides an +-- environment, say an initialization context or a configuration. The +-- environment held in the reader effect can be changed (with 'local') within +-- the scope of a sub-computation. Contrary to the "Capability.State", such +-- a change is local, and does not persist when the 'local' call ends. + +module Capability.Reader + ( -- * Interface + module Capability.Reader.Internal.Class + -- * Strategies + , module Capability.Reader.Internal.Strategies + -- ** Modifiers + , module Capability.Accessors + ) where + +import Capability.Accessors +import Capability.Reader.Internal.Class +import Capability.Reader.Internal.Strategies diff --git a/src/Capability/Reader/Internal/Class.hs b/src/Capability/Reader/Internal/Class.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Reader/Internal/Class.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} + +{-# OPTIONS_HADDOCK hide #-} + +module Capability.Reader.Internal.Class + ( HasReader(..) + , ask + , asks + , local + , reader + , magnify + ) where + +import Data.Coerce (Coercible, coerce) +import GHC.Exts (Proxy#, proxy#) + +-- | Reader capability +-- +-- An instance should fulfill the following laws. +-- At this point these laws are not definitive, +-- see . +-- +-- prop> k <*> ask @t = ask @t <**> k +-- prop> ask @t *> m = m = m <* ask @t +-- prop> local @t f (ask @t) = fmap f (ask @t) +-- prop> local @t f . local @t g = local @t (g . f) +-- prop> local @t f (pure x) = pure x +-- prop> local @t f (m >>= \x -> k x) = local @t f m >>= \x -> local @t f (k x) +-- prop> reader @t f = f <$> ask @t +class Monad m + => HasReader (tag :: k) (r :: *) (m :: * -> *) | tag m -> r + where + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasReader'. + -- Otherwise, you will want to use 'ask'. + -- See 'ask' for more documentation. + ask_ :: Proxy# tag -> m r + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasReader'. + -- Otherwise, you will want to use 'local'. + -- See 'local' for more documentation. + local_ :: Proxy# tag -> (r -> r) -> m a -> m a + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasReader'. + -- Otherwise, you will want to use 'reader'. + -- See 'reader' for more documentation. + reader_ :: Proxy# tag -> (r -> a) -> m a + +-- | @ask \@tag@ +-- retrieves the environment of the reader capability @tag@. +ask :: forall tag r m. HasReader tag r m => m r +ask = ask_ (proxy# @_ @tag) +{-# INLINE ask #-} + +-- | @asks \@tag@ +-- retrieves the image by @f@ of the environment +-- of the reader capability @tag@. +-- +-- prop> asks @tag f = f <$> ask @tag +asks :: forall tag r m a. HasReader tag r m => (r -> a) -> m a +asks f = f <$> ask @tag +{-# INLINE asks #-} + +-- | @local \@tag f m@ +-- runs the monadic action @m@ in a modified environment @e' = f e@, +-- where @e@ is the environment of the reader capability @tag@. +-- Symbolically: @return e = ask \@tag@. +local :: forall tag r m a. HasReader tag r m => (r -> r) -> m a -> m a +local = local_ (proxy# @_ @tag) +{-# INLINE local #-} + +-- | @reader \@tag act@ +-- lifts a purely environment-dependent action @act@ to a monadic action +-- in an arbitrary monad @m@ with capability @HasReader@. +-- +-- It happens to coincide with @asks@: @reader = asks@. +reader :: forall tag r m a. HasReader tag r m => (r -> a) -> m a +reader = reader_ (proxy# @_ @tag) +{-# INLINE reader #-} + +-- | Execute the given reader action on a sub-component of the current context +-- as defined by the given transformer @t@. +-- +-- See 'Capability.State.zoom'. +-- +-- This function is experimental and subject to change. +-- See . +magnify :: forall outertag innertag t outer inner m a. + ( forall x. Coercible (t m x) (m x) + , forall m'. HasReader outertag outer m' + => HasReader innertag inner (t m') + , HasReader outertag outer m ) + => (forall m'. HasReader innertag inner m' => m' a) -> m a +magnify m = coerce @(t m a) m +{-# INLINE magnify #-} diff --git a/src/Capability/Reader/Internal/Strategies.hs b/src/Capability/Reader/Internal/Strategies.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Reader/Internal/Strategies.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} + +{-# OPTIONS_HADDOCK hide #-} + +module Capability.Reader.Internal.Strategies + ( MonadReader(..) + , ReadStatePure(..) + , ReadState(..) + ) where + +import Capability.Accessors +import Capability.Reader.Internal.Class +import Capability.State.Internal.Class +import Control.Lens (over, view) +import Control.Monad.Catch (MonadMask, bracket) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Primitive (PrimMonad) +import qualified Control.Monad.Reader.Class as Reader +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Control (MonadTransControl(..)) +import Data.Coerce (Coercible, coerce) +import qualified Data.Generics.Product.Fields as Generic +import qualified Data.Generics.Product.Positions as Generic +import GHC.Exts (Proxy#) + +-- | Derive 'HasReader' from @m@'s 'Control.Monad.Reader.Class.MonadReader' +-- instance. +newtype MonadReader (m :: * -> *) (a :: *) = MonadReader (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +instance Reader.MonadReader r m => HasReader tag r (MonadReader m) where + ask_ _ = coerce @(m r) Reader.ask + {-# INLINE ask_ #-} + local_ + :: forall a. Proxy# tag -> (r -> r) -> MonadReader m a -> MonadReader m a + local_ _ = coerce @((r -> r) -> m a -> m a) Reader.local + {-# INLINE local_ #-} + reader_ :: forall a. Proxy# tag -> (r -> a) -> MonadReader m a + reader_ _ = coerce @((r -> a) -> m a) Reader.reader + {-# INLINE reader_ #-} + +-- | Convert a /pure/ state monad into a reader monad. +-- +-- /Pure/ meaning that the monad stack does not allow catching exceptions. +-- Otherwise, an exception occurring in the action passed to 'local' could cause +-- the context to remain modified outside of the call to 'local'. E.g. +-- +-- > local @tag (const r') (throw MyException) +-- > `catch` \MyException -> ask @tag +-- +-- returns @r'@ instead of the previous value. +-- +-- Note, that no @MonadIO@ instance is provided, as this would allow catching +-- exceptions. +-- +-- See 'ReadState'. +newtype ReadStatePure (m :: * -> *) (a :: *) = ReadStatePure (m a) + deriving (Functor, Applicative, Monad) + +instance HasState tag r m => HasReader tag r (ReadStatePure m) where + ask_ _ = coerce @(m r) $ get @tag + {-# INLINE ask_ #-} + local_ :: forall a. + Proxy# tag -> (r -> r) -> ReadStatePure m a -> ReadStatePure m a + local_ _ f = coerce @(m a -> m a) $ \m -> do + r <- state @tag $ \r -> (r, f r) + m <* put @tag r + {-# INLINE local_ #-} + reader_ :: forall a. Proxy# tag -> (r -> a) -> ReadStatePure m a + reader_ _ = coerce @((r -> a) -> m a) $ gets @tag + {-# INLINE reader_ #-} + +-- | Convert a state monad into a reader monad. +-- +-- Use this if the monad stack allows catching exceptions. +-- +-- See 'ReadStatePure'. +newtype ReadState (m :: * -> *) (a :: *) = ReadState (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +instance + (HasState tag r m, MonadMask m) + => HasReader tag r (ReadState m) + where + ask_ _ = coerce @(m r) $ get @tag + {-# INLINE ask_ #-} + local_ :: forall a. + Proxy# tag -> (r -> r) -> ReadState m a -> ReadState m a + local_ _ f = coerce @(m a -> m a) $ \action -> + let + setAndSave = state @tag $ \r -> (r, f r) + restore r = put @tag r + in + bracket setAndSave restore $ \_ -> action + {-# INLINE local_ #-} + reader_ :: forall a. Proxy# tag -> (r -> a) -> ReadState m a + reader_ _ = coerce @((r -> a) -> m a) $ gets @tag + {-# INLINE reader_ #-} + +-- | Convert the environment using safe coercion. +instance + ( Coercible from to, HasReader tag from m + , forall x y. Coercible x y => Coercible (m x) (m y) ) + => HasReader tag to (Coerce to m) + where + ask_ tag = coerce @(m from) $ ask_ tag + {-# INLINE ask_ #-} + local_ + :: forall a. Proxy# tag -> (to -> to) -> Coerce to m a -> Coerce to m a + local_ tag = coerce @((from -> from) -> m a -> m a) $ local_ tag + {-# INLINE local_ #-} + reader_ :: forall a. Proxy# tag -> (to -> a) -> Coerce to m a + reader_ tag = coerce @((from -> a) -> m a) $ reader_ tag + {-# INLINE reader_ #-} + +-- | Rename the tag. +instance HasReader oldtag r m => HasReader newtag r (Rename oldtag m) where + ask_ _ = coerce @(m r) $ ask @oldtag + {-# INLINE ask_ #-} + local_ :: forall a. + Proxy# newtag -> (r -> r) -> Rename oldtag m a -> Rename oldtag m a + local_ _ = coerce @((r -> r) -> m a -> m a) $ local @oldtag + {-# INLINE local_ #-} + reader_ :: forall a. Proxy# newtag -> (r -> a) -> Rename oldtag m a + reader_ _ = coerce @((r -> a) -> m a) $ reader @oldtag + {-# INLINE reader_ #-} + + +-- | Zoom in on the record field @field@ of type @v@ +-- in the environment @record@. +instance + -- The constraint raises @-Wsimplifiable-class-constraints@. + -- This could be avoided by instead placing @HasField'@s constraints here. + -- Unfortunately, it uses non-exported symbols from @generic-lens@. + ( tag ~ field, Generic.HasField' field record v, HasReader oldtag record m ) + => HasReader tag v (Field field oldtag m) + where + ask_ _ = coerce @(m v) $ + asks @oldtag $ view (Generic.field' @field) + {-# INLINE ask_ #-} + local_ :: forall a. + Proxy# tag + -> (v -> v) + -> Field field oldtag m a + -> Field field oldtag m a + local_ _ = coerce @((v -> v) -> m a -> m a) $ + local @oldtag . over (Generic.field' @field) + {-# INLINE local_ #-} + reader_ :: forall a. + Proxy# tag + -> (v -> a) + -> Field field oldtag m a + reader_ _ f = coerce @(m a) $ + reader @oldtag $ f . view (Generic.field' @field) + {-# INLINE reader_ #-} + +-- | Zoom in on the field at position @pos@ of type @v@ +-- in the environment @struct@. +instance + -- The constraint raises @-Wsimplifiable-class-constraints@. + -- This could be avoided by instead placing @HasPosition'@s constraints here. + -- Unfortunately, it uses non-exported symbols from @generic-lens@. + ( tag ~ pos, Generic.HasPosition' pos struct v, HasReader oldtag struct m ) + => HasReader tag v (Pos pos oldtag m) + where + ask_ _ = coerce @(m v) $ + asks @oldtag $ view (Generic.position' @pos) + {-# INLINE ask_ #-} + local_ :: forall a. + Proxy# tag + -> (v -> v) + -> Pos pos oldtag m a + -> Pos pos oldtag m a + local_ _ = coerce @((v -> v) -> m a -> m a) $ + local @oldtag . over (Generic.position' @pos) + {-# INLINE local_ #-} + reader_ :: forall a. + Proxy# tag + -> (v -> a) + -> Pos pos oldtag m a + reader_ _ f = coerce @(m a) $ + reader @oldtag $ f . view (Generic.position' @pos) + {-# INLINE reader_ #-} + +-- | Lift one layer in a monad transformer stack. +instance (HasReader tag r m, MonadTransControl t, Monad (t m)) + => HasReader tag r (Lift (t m)) + where + ask_ _ = coerce $ lift @t @m $ ask @tag @r + {-# INLINE ask_ #-} + local_ + :: forall a. Proxy# tag -> (r -> r) -> Lift (t m) a -> Lift (t m) a + local_ _ f = coerce @(t m a -> t m a) $ + \m -> liftWith (\run -> local @tag f $ run m) >>= restoreT . pure + {-# INLINE local_ #-} + reader_ :: forall a. Proxy# tag -> (r -> a) -> Lift (t m) a + reader_ _ = coerce @((r -> a) -> t m a) $ lift . reader @tag + {-# INLINE reader_ #-} + +-- | Compose two accessors. +deriving via ((t2 :: (* -> *) -> * -> *) ((t1 :: (* -> *) -> * -> *) m)) + instance + ( forall x. Coercible (m x) (t2 (t1 m) x) + , Monad m, HasReader tag r (t2 (t1 m)) ) + => HasReader tag r ((t2 :.: t1) m) diff --git a/src/Capability/State.hs b/src/Capability/State.hs new file mode 100644 --- /dev/null +++ b/src/Capability/State.hs @@ -0,0 +1,22 @@ +-- | Defines a capability type class for a state effect. A state capability +-- provides a state which can be retrieved with 'get' and set with 'put'. As an +-- analogy, each state capability is equivalent to making one @IORef@ available +-- in an @IO@ computation (except, of course, that a state capability does not +-- have to be provided by @IO@). +-- +-- This is a very expressive capability. It is often preferable to restrict to +-- less powerful capabilities such as "Capability.Reader", "Capability.Writer", +-- or "Capability.Stream". + +module Capability.State + ( -- * Interface + module Capability.State.Internal.Class + -- * Strategies + , module Capability.State.Internal.Strategies + -- ** Modifiers + , module Capability.Accessors + ) where + +import Capability.Accessors +import Capability.State.Internal.Class +import Capability.State.Internal.Strategies diff --git a/src/Capability/State/Internal/Class.hs b/src/Capability/State/Internal/Class.hs new file mode 100644 --- /dev/null +++ b/src/Capability/State/Internal/Class.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} + +{-# OPTIONS_HADDOCK hide #-} + +module Capability.State.Internal.Class + ( HasState(..) + , get + , put + , state + , modify + , modify' + , gets + , zoom + ) where + +import Data.Coerce (Coercible, coerce) +import GHC.Exts (Proxy#, proxy#) + +-- | State capability +-- +-- An instance should fulfill the following laws. +-- At this point these laws are not definitive, +-- see . +-- +-- prop> get @t >>= \s1 -> get @t >>= \s2 -> pure (s1, s2) = get @t >>= \s -> pure (s, s) +-- prop> get @t >>= \_ -> put @t s = put @t s +-- prop> put @t s1 >> put @t s2 = put @t s2 +-- prop> put @t s >> get @t = put @t s >> pure s +-- prop> state @t f = get @t >>= \s -> let (a, s') = f s in put @t s' >> pure a +class Monad m + => HasState (tag :: k) (s :: *) (m :: * -> *) | tag m -> s + where + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasState. + -- Otherwise, you will want to use 'get'. + -- See 'get' for more documentation. + get_ :: Proxy# tag -> m s + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasState. + -- Otherwise, you will want to use 'put'. + -- See 'put' for more documentation. + put_ :: Proxy# tag -> s -> m () + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasState. + -- Otherwise, you will want to use 'state'. + -- See 'state' for more documentation. + state_ :: Proxy# tag -> (s -> (a, s)) -> m a + +-- | @get \@tag@ +-- retrieve the current state of the state capability @tag@. +get :: forall tag s m. HasState tag s m => m s +get = get_ (proxy# @_ @tag) +{-# INLINE get #-} + +-- | @put \@tag s@ +-- replace the current state of the state capability @tag@ with @s@. +put :: forall tag s m. HasState tag s m => s -> m () +put = put_ (proxy# @_ @tag) +{-# INLINE put #-} + +-- | @state \@tag f@ +-- lifts a pure state computation @f@ to a monadic action in an arbitrary +-- monad @m@ with capability @HasState@. +-- +-- Given the current state @s@ of the state capability @tag@ +-- and @(a, s') = f s@, update the state to @s'@ and return @a@. +state :: forall tag s m a. HasState tag s m => (s -> (a, s)) -> m a +state = state_ (proxy# @_ @tag) +{-# INLINE state #-} + +-- | @modify \@tag f@ +-- given the current state @s@ of the state capability @tag@ +-- and @s' = f s@, updates the state of the capability @tag@ to @s'@. +modify :: forall tag s m. HasState tag s m => (s -> s) -> m () +modify f = state @tag $ \s -> ((), f s) +{-# INLINE modify #-} + +-- | Same as 'modify' but strict in the new state. +modify' :: forall tag s m. HasState tag s m => (s -> s) -> m () +modify' f = do + s' <- get @tag + put @tag $! f s' +{-# INLINE modify' #-} + +-- | @gets \@tag f@ +-- retrieves the image, by @f@ of the current state +-- of the state capability @tag@. +-- +-- prop> gets @tag f = f <$> get @tag +gets :: forall tag s m a. HasState tag s m => (s -> a) -> m a +gets f = do + s <- get @tag + pure (f s) +{-# INLINE gets #-} + +-- | Execute the given state action on a sub-component of the current state +-- as defined by the given transformer @t@. +-- +-- Example: +-- +-- > zoom @"foobar" @"foo" @(Field "foo" "foobar") foo +-- > :: HasState "foobar" FooBar m => m () +-- > +-- > foo :: HasState "foo" Int m => m () +-- > data FooBar = FooBar { foo :: Int, bar :: String } +-- +-- This function is experimental and subject to change. +-- See . +zoom :: forall outertag innertag t outer inner m a. + ( forall x. Coercible (t m x) (m x) + , forall m'. HasState outertag outer m' + => HasState innertag inner (t m') + , HasState outertag outer m ) + => (forall m'. HasState innertag inner m' => m' a) -> m a +zoom m = coerce @(t m a) m +{-# INLINE zoom #-} diff --git a/src/Capability/State/Internal/Strategies.hs b/src/Capability/State/Internal/Strategies.hs new file mode 100644 --- /dev/null +++ b/src/Capability/State/Internal/Strategies.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} + +{-# OPTIONS_HADDOCK hide #-} + +module Capability.State.Internal.Strategies + ( MonadState(..) + , ReaderIORef(..) + , ReaderRef(..) + ) where + +import Capability.Accessors +import Capability.Reader.Internal.Class +import Capability.State.Internal.Class +import Control.Lens (set, view) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Primitive (PrimMonad) +import qualified Control.Monad.State.Class as State +import Control.Monad.Trans.Class (MonadTrans, lift) +import Data.Coerce (Coercible, coerce) +import qualified Data.Generics.Product.Fields as Generic +import qualified Data.Generics.Product.Positions as Generic +import Data.IORef +import Data.Mutable +import GHC.Exts (Proxy#) + +-- | Derive 'HasState' from @m@'s +-- 'Control.Monad.State.Class.MonadState' instance. +newtype MonadState (m :: * -> *) (a :: *) = MonadState (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +instance State.MonadState s m => HasState tag s (MonadState m) where + get_ _ = coerce @(m s) State.get + {-# INLINE get_ #-} + put_ _ = coerce @(s -> m ()) State.put + {-# INLINE put_ #-} + state_ :: forall a. Proxy# tag -> (s -> (a, s)) -> MonadState m a + state_ _ = coerce @((s -> (a, s)) -> m a) State.state + {-# INLINE state_ #-} + +-- | Convert the state using safe coercion. +instance + ( Coercible from to, HasState tag from m + , forall x y. Coercible x y => Coercible (m x) (m y) ) + => HasState tag to (Coerce to m) + where + get_ tag = coerce @(m from) $ get_ tag + {-# INLINE get_ #-} + put_ tag = coerce @(from -> m ()) $ put_ tag + {-# INLINE put_ #-} + state_ :: forall a. Proxy# tag -> (to -> (a, to)) -> Coerce to m a + state_ tag = coerce @((from -> (a, from)) -> m a) $ state_ tag + {-# INLINE state_ #-} + +-- | Rename the tag. +instance HasState oldtag s m => HasState newtag s (Rename oldtag m) where + get_ _ = coerce @(m s) $ get @oldtag + {-# INLINE get_ #-} + put_ _ = coerce @(s -> m ()) $ put @oldtag + {-# INLINE put_ #-} + state_ :: forall a. Proxy# newtag -> (s -> (a, s)) -> Rename oldtag m a + state_ _ = coerce @((s -> (a, s)) -> m a) $ state @oldtag + {-# INLINE state_ #-} + +-- | Zoom in on the record field @field@ of type @v@ in the state @record@. +instance + -- The constraint raises @-Wsimplifiable-class-constraints@. + -- This could be avoided by instead placing @HasField'@s constraints here. + -- Unfortunately, it uses non-exported symbols from @generic-lens@. + ( tag ~ field, Generic.HasField' field record v, HasState oldtag record m ) + => HasState tag v (Field field oldtag m) + where + get_ _ = coerce @(m v) $ + gets @oldtag $ view (Generic.field' @field) + {-# INLINE get_ #-} + put_ _ = coerce @(v -> m ()) $ + modify @oldtag . set (Generic.field' @field @record) + {-# INLINE put_ #-} + state_ :: forall a. + Proxy# tag + -> (v -> (a, v)) + -> Field field oldtag m a + state_ _ = coerce @((v -> (a, v)) -> m a) $ + state @oldtag . Generic.field' @field @_ @_ @((,) a) + {-# INLINE state_ #-} + +-- | Zoom in on the field at position @pos@ of type @v@ in the state @struct@. +instance + -- The constraint raises @-Wsimplifiable-class-constraints@. + -- This could be avoided by instead placing @HasPosition'@s constraints here. + -- Unfortunately, it uses non-exported symbols from @generic-lens@. + ( tag ~ pos, Generic.HasPosition' pos struct v, HasState oldtag struct m ) + => HasState tag v (Pos pos oldtag m) + where + get_ _ = coerce @(m v) $ + gets @oldtag $ view (Generic.position' @pos) + {-# INLINE get_ #-} + put_ _ = coerce @(v -> m ()) $ + modify @oldtag . set (Generic.position' @pos @struct) + {-# INLINE put_ #-} + state_ :: forall a. + Proxy# tag + -> (v -> (a, v)) + -> Pos pos oldtag m a + state_ _ = coerce @((v -> (a, v)) -> m a) $ + state @oldtag . Generic.position' @pos @_ @_ @((,) a) + {-# INLINE state_ #-} + +-- | Lift one layer in a monad transformer stack. +instance (HasState tag s m, MonadTrans t, Monad (t m)) + => HasState tag s (Lift (t m)) + where + get_ _ = coerce $ lift @t @m $ get @tag @s + {-# INLINE get_ #-} + put_ _ = coerce $ lift @t @m . put @tag @s + {-# INLINE put_ #-} + state_ :: forall a. Proxy# tag -> (s -> (a, s)) -> Lift (t m) a + state_ _ = coerce $ lift @t @m . state @tag @s @m @a + {-# INLINE state_ #-} + +-- | Compose two accessors. +deriving via ((t2 :: (* -> *) -> * -> *) ((t1 :: (* -> *) -> * -> *) m)) + instance + ( forall x. Coercible (m x) (t2 (t1 m) x) + , Monad m, HasState tag s (t2 (t1 m)) ) + => HasState tag s ((t2 :.: t1) m) + +-- | Derive a state monad from a reader over an 'Data.IORef.IORef'. +-- +-- Example: +-- +-- > newtype MyState m a = MyState (ReaderT (IORef Int) m a) +-- > deriving (Functor, Applicative, Monad) +-- > deriving HasState "foo" Int via +-- > ReaderIORef (MonadReader (ReaderT (IORef Int) m)) +-- +-- See 'ReaderRef' for a more generic strategy. +newtype ReaderIORef m a = ReaderIORef (m a) + deriving (Functor, Applicative, Monad) + +instance + (HasReader tag (IORef s) m, MonadIO m) + => HasState tag s (ReaderIORef m) + where + get_ _ = ReaderIORef $ do + ref <- ask @tag + liftIO $ readIORef ref + {-# INLINE get_ #-} + put_ _ v = ReaderIORef $ do + ref <- ask @tag + liftIO $ writeIORef ref v + {-# INLINE put_ #-} + state_ _ f = ReaderIORef $ do + ref <- ask @tag + liftIO $ atomicModifyIORef' ref (swap . f) + where + swap (a, b) = (b, a) + {-# INLINE state_ #-} + +-- | Derive a state monad from a reader over a mutable reference. +-- +-- Mutable references are available in a 'Control.Monad.Primitive.PrimMonad'. +-- The corresponding 'Control.Monad.Primitive.PrimState' has to match the +-- 'Data.Mutable.MCState' of the reference. This constraint makes a stand-alone +-- deriving clause necessary. +-- +-- Example: +-- +-- > newtype MyState m a = MyState (ReaderT (IORef Int) m a) +-- > deriving (Functor, Applicative, Monad) +-- > deriving via ReaderRef (MonadReader (ReaderT (IORef Int) m)) +-- > instance (PrimMonad m, PrimState m ~ PrimState IO) +-- > => HasState "foo" Int (MyState m) +-- +-- See 'ReaderIORef' for a specialized version over 'Data.IORef.IORef'. +newtype ReaderRef m (a :: *) = ReaderRef (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +instance + ( MutableRef ref, RefElement ref ~ s + , HasReader tag ref m, PrimMonad m, PrimState m ~ MCState ref ) + => HasState tag s (ReaderRef m) + where + get_ _ = ReaderRef $ do + ref <- ask @tag + readRef ref + {-# INLINE get_ #-} + put_ _ v = ReaderRef $ do + ref <- ask @tag + writeRef ref v + {-# INLINE put_ #-} + state_ _ f = ReaderRef $ do + ref <- ask @tag + s <- readRef ref + let (a, s') = f s + writeRef ref s' + pure a + {-# INLINE state_ #-} diff --git a/src/Capability/Stream.hs b/src/Capability/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Stream.hs @@ -0,0 +1,109 @@ +-- | Defines a capability for computations that produce a stream of values +-- as part of their execution. +-- +-- Programs producing streams of data are common. Examples: emitting events on +-- input, or emitting events whenever certain conditions are observed. Streams +-- are similar to Python generators. +-- +-- The 'HasStream' capability enables separating the logic responsible for +-- emitting events from that responsible for collecting or handling them. +-- +-- This can be thought of as a writer capability of a list of values @HasWriter +-- tag [v]@ with @\\x -> tell \@tag [x]@ as a primitive operation. However, that +-- implementation would be inefficient. +-- +-- For example using the 'Streaming.Prelude.Stream' instance, a producer defined +-- using this capability can be consumed efficiently in a streaming fashion. + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +module Capability.Stream + ( -- * Interface + HasStream(..) + , yield + -- * Strategies + , StreamStack(..) + , StreamDList(..) + -- ** Modifiers + , module Capability.Accessors + ) where + +import Capability.Accessors +import Capability.State +import Capability.Writer +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Primitive (PrimMonad) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Data.Coerce (Coercible, coerce) +import Data.DList (DList) +import qualified Data.DList as DList +import GHC.Exts (Proxy#, proxy#) +import Streaming +import qualified Streaming.Prelude as S + +-- | Streaming capability. +-- +-- An instance does not need to fulfill any additional laws +-- besides the monad laws. +class Monad m + => HasStream (tag :: k) (a :: *) (m :: * -> *) | tag m -> a + where + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasReader'. + -- Otherwise, you will want to use 'yield'. + -- See 'yield' for more documentation. + yield_ :: Proxy# tag -> a -> m () + +-- | @yield \@tag a@ +-- emits @a@ in the stream capability @tag@. +yield :: forall tag a m. HasStream tag a m => a -> m () +yield = yield_ (proxy# @_ @tag) +{-# INLINE yield #-} + +-- | Accumulate streamed values in a reverse order list. +newtype StreamStack m (a :: *) = StreamStack (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) +instance HasState tag [a] m => HasStream tag a (StreamStack m) where + yield_ _ a = coerce @(m ()) $ modify' @tag (a:) + {-# INLINE yield_ #-} + +-- | Accumulate streamed values in forward order in a difference list. +newtype StreamDList m (a :: *) = StreamDList (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) +instance HasWriter tag (DList a) m => HasStream tag a (StreamDList m) where + yield_ _ = coerce @(a -> m ()) $ tell @tag . DList.singleton + {-# INLINE yield_ #-} + +instance Monad m => HasStream tag a (S.Stream (Of a) m) where + yield_ _ = S.yield + {-# INLINE yield_ #-} + +-- | Lift one layer in a monad transformer stack. +instance (HasStream tag a m, MonadTrans t, Monad (t m)) + => HasStream tag a (Lift (t m)) + where + yield_ _ = coerce @(a -> t m ()) $ lift . yield @tag + {-# INLINE yield_ #-} + +-- | Compose two accessors. +deriving via ((t2 :: (* -> *) -> * -> *) ((t1 :: (* -> *) -> * -> *) m)) + instance + ( forall x. Coercible (m x) (t2 (t1 m) x) + , Monad m, HasStream tag a (t2 (t1 m)) ) + => HasStream tag a ((t2 :.: t1) m) diff --git a/src/Capability/Writer.hs b/src/Capability/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Writer.hs @@ -0,0 +1,162 @@ +-- | Defines a capability type class for writer effects. A writer program can +-- output values with 'tell'. The values output by two consecutive +-- sub-computation are combined using a monoid's @mappend@. +-- +-- The interface of 'HasWriter' follows that of +-- 'Control.Monad.Writer.Class.MonadWriter'. However, this module does not +-- include a strategy to provide a @HasWriter@ capability from a @MonadWriter@ +-- instance. It is generally a bad idea to use monads such as +-- 'Control.Monad.Writer.Strict.WriterT', as they tend to leak space, as +-- described in this +-- by Getty Ritter. +-- +-- Instead, you should use the 'WriterLog' strategy that implements the writer +-- monad on a state monad. There is no downside, as using 'HasWriter' instead of +-- 'HasState' directly ensures your code adheres to the writer monad interface +-- and does not misuse the underlying state monad. + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} + +module Capability.Writer + ( -- * Interface + HasWriter(..) + , writer + , tell + , listen + , pass + -- * Strategies + , WriterLog(..) + -- ** Modifiers + , module Capability.Accessors + ) where + +import Capability.Accessors +import Capability.State +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Primitive (PrimMonad) +import Data.Coerce (Coercible, coerce) +import GHC.Exts (Proxy#, proxy#) + +-- | Writer capability +-- +-- An instance should fulfill the following laws. +-- At this point these laws are not definitive, +-- see . +-- +-- prop> listen @t (pure a) = pure (a, mempty) +-- prop> listen @t (tell @t w) = tell @t w >> pure (w, w) +-- prop> listen @t (m >>= k) = listen @t m >>= \(a, w1) -> listen @t (k a) >>= \(b, w2) -> pure (b, w1 `mappend` w2) +-- prop> pass @t (tell @t w >> pure (a, f)) = tell @t (f w) >> pure a +-- prop> writer @t (a, w) = tell @t w >> pure a +class (Monoid w, Monad m) + => HasWriter (tag :: k) (w :: *) (m :: * -> *) | tag m -> w + where + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasReader'. + -- Otherwise, you will want to use 'writer'. + -- See 'writer' for more documentation. + writer_ :: Proxy# tag -> (a, w) -> m a + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasReader'. + -- Otherwise, you will want to use 'tell'. + -- See 'tell' for more documentation. + tell_ :: Proxy# tag -> w -> m () + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasReader'. + -- Otherwise, you will want to use 'listen'. + -- See 'listen' for more documentation. + listen_ :: Proxy# tag -> m a -> m (a, w) + -- | For technical reasons, this method needs an extra proxy argument. + -- You only need it if you are defining new instances of 'HasReader'. + -- Otherwise, you will want to use 'pass'. + -- See 'pass' for more documentation. + pass_ :: Proxy# tag -> m (a, w -> w) -> m a + +-- | @writer \@tag (a, w)@ +-- lifts a pure writer action @(a, w)@ to a monadic action in an arbitrary +-- monad @m@ with capability @HasWriter@. +-- +-- Appends @w@ to the output of the writer capability @tag@ +-- and returns the value @a@. +writer :: forall tag w m a. HasWriter tag w m => (a, w) -> m a +writer = writer_ (proxy# @_ @tag) +{-# INLINE writer #-} + +-- | @tell \@tag w@ +-- appends @w@ to the output of the writer capability @tag@. +tell :: forall tag w m. HasWriter tag w m => w -> m () +tell = tell_ (proxy# @_ @tag) +{-# INLINE tell #-} + +-- | @listen \@tag m@ +-- executes the action @m@ and returns the output of @m@ +-- in the writer capability @tag@ along with result of @m@. +-- Appends the output of @m@ to the output of the writer capability @tag@. +listen :: forall tag w m a. HasWriter tag w m => m a -> m (a, w) +listen = listen_ (proxy# @_ @tag) +{-# INLINE listen #-} + +-- | @pass \@tag m@ +-- executes the action @m@. Assuming @m@ returns @(a, f)@ and appends +-- @w@ to the output of the writer capability @tag@. +-- @pass \@tag m@ instead appends @w' = f w@ to the output and returns @a@. +pass :: forall tag w m a. HasWriter tag w m => m (a, w -> w) -> m a +pass = pass_ (proxy# @_ @tag) +{-# INLINE pass #-} + +-- | Compose two accessors. +deriving via ((t2 :: (* -> *) -> * -> *) ((t1 :: (* -> *) -> * -> *) m)) + instance + ( forall x. Coercible (m x) (t2 (t1 m) x) + , Monad m, HasWriter tag w (t2 (t1 m)) ) + => HasWriter tag w ((t2 :.: t1) m) + +newtype WriterLog m a = WriterLog (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +instance (Monoid w, HasState tag w m) + => HasWriter tag w (WriterLog m) + where + writer_ tag (a, w) = tell_ tag w >> pure a + {-# INLINE writer_ #-} + tell_ _ w = coerce @(m ()) $ modify' @tag (<> w) + {-# INLINE tell_ #-} + listen_ :: forall a. Proxy# tag -> WriterLog m a -> WriterLog m (a, w) + listen_ _ m = coerce @(m (a, w)) $ do + w0 <- get @tag + put @tag mempty + a <- coerce m + w <- get @tag + put @tag $! w0 <> w + pure (a, w) + {-# INLINE listen_ #-} + pass_ :: forall a. Proxy# tag -> WriterLog m (a, w -> w) -> WriterLog m a + pass_ _ m = coerce @(m a) $ do + w0 <- get @tag + put @tag mempty + (a, f) <- coerce @_ @(m (a, w -> w)) m + w <- get @tag + put @tag $! w0 <> f w + pure a + {-# INLINE pass_ #-} diff --git a/src/Capability/Writer/Discouraged.hs b/src/Capability/Writer/Discouraged.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Writer/Discouraged.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} + +-- | Defines discouraged instances of writer monad capabilities. + +module Capability.Writer.Discouraged + ( ) where + +import Capability.Accessors +import Capability.Writer +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Unlift (MonadTransUnlift, Unlift(..), askUnlift) +import Data.Coerce (coerce) +import GHC.Exts (Proxy#) + +-- | Lift one layer in a monad transformer stack. +-- +-- Note, that if the 'HasWriter' instance is based on 'HasState', then it is +-- more efficient to apply 'Lift' to the underlying state capability. E.g. +-- you should favour +-- +-- > deriving (HasWriter tag w) via +-- > WriterLog (Lift (SomeTrans (MonadState SomeStateMonad))) +-- +-- over +-- +-- > deriving (HasWriter tag w) via +-- > Lift (SomeTrans (WriterLog (MonadState SomeStateMonad))) +instance + -- MonadTransUnlift constraint requires -Wno-simplifiable-class-constraints + (HasWriter tag w m, MonadTransUnlift t, Monad (t m)) + => HasWriter tag w (Lift (t m)) + where + writer_ :: forall a. Proxy# tag -> (a, w) -> Lift (t m) a + writer_ _ = coerce @((a, w) -> t m a) $ lift . writer @tag + {-# INLINE writer_ #-} + tell_ _ = coerce @(w -> t m ()) $ lift . tell @tag + {-# INLINE tell_ #-} + listen_ :: forall a. Proxy# tag -> Lift (t m) a -> Lift (t m) (a, w) + listen_ _ = coerce @(t m a -> t m (a, w)) $ \m -> do + u <- askUnlift + lift $ listen @tag $ unlift u m + {-# INLINE listen_ #-} + pass_ :: forall a. Proxy# tag -> Lift (t m) (a, w -> w) -> Lift (t m) a + pass_ _ = coerce @(t m (a, w -> w) -> t m a) $ \m -> do + u <- askUnlift + lift $ pass @tag $ unlift u m + {-# INLINE pass_ #-}