diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,26 @@ # Revision history for capability +## 0.3.0.0 -- 2020-03-19 + +* Rename HasStream to HasSink, for symmetry. + See [#75](https://github.com/tweag/capability/pull/75) + +* Introduce HasSource, a superclass of HasReader. + See [#75](https://github.com/tweag/capability/pull/75) + +* Make HasSource and HasSink superclasses of HasState. + See [#75](https://github.com/tweag/capability/pull/75) + +* Introduce `derive` to run an action that requires additional capabilities. + See [#74](https://github.com/tweag/capability/pull/74) + and [#83](https://github.com/tweag/capability/pull/83) + +* Handlers `zoom` and `magnify` can now carry capabilities over from the context. + See [#73](https://github.com/tweag/capability/pull/73) + +* Introduce functional capabilities and the `TypeOf` type family. + See [#72](https://github.com/tweag/capability/pull/72) + ## 0.2.0.0 -- 2019-03-22 * Make HasStream a superclass of HasWriter. diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -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/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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 --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ # capability: effects, extensionally +[![Build status](https://badge.buildkite.com/a44574059e13fc443caa437226af5ae5e67b6a5ae012534712.svg?branch=master)](https://buildkite.com/tweag-1/capability) + 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 @@ -135,17 +137,6 @@ [`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 diff --git a/capability.cabal b/capability.cabal --- a/capability.cabal +++ b/capability.cabal @@ -1,8 +1,8 @@ name: capability -version: 0.2.0.0 +version: 0.3.0.0 homepage: https://github.com/tweag/capability license: BSD3 -license-file: LICENSE +license-file: LICENSE.md maintainer: andreas.herrmann@tweag.io copyright: 2018 EURL Tweag category: Control @@ -29,37 +29,59 @@ This package allows JUnit formatted test reporting for CI. default: False +flag dev + description: Turn on development settings. + manual: True + default: False + library exposed-modules: Capability Capability.Accessors + Capability.Constraints + Capability.Derive Capability.Error Capability.Reader Capability.Reader.Internal.Class Capability.Reader.Internal.Strategies + Capability.Sink + Capability.Sink.Internal.Class + Capability.Sink.Internal.Strategies + Capability.Source + Capability.Source.Internal.Class + Capability.Source.Internal.Strategies Capability.State Capability.State.Internal.Class Capability.State.Internal.Strategies + Capability.State.Internal.Strategies.Common Capability.Stream + Capability.TypeOf Capability.Writer Capability.Writer.Discouraged build-depends: base >= 4.12 && < 5.0 + , constraints >= 0.1 && < 0.12 , dlist >= 0.8 && < 0.9 , exceptions >= 0.6 && < 0.11 - , generic-lens >= 1.0 && < 1.2 + , generic-lens >= 1.0 && < 1.3 , 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 + , primitive >= 0.6 && < 0.8 , 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 + if flag(dev) + ghc-options: -Wall -Werror -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wnoncanonical-monad-instances + else + ghc-options: -Wall hs-source-dirs: src default-language: Haskell2010 @@ -70,8 +92,8 @@ CountLog Error Reader + Sink State - Stream Test.Common Writer main-is: Test.hs @@ -89,6 +111,12 @@ , unliftio >= 0.2 && < 0.3 if flag(hspec-jenkins) build-depends: hspec-jenkins - ghc-options: -Wall + if flag(dev) + ghc-options: -Wall -Werror -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wnoncanonical-monad-instances + else + ghc-options: -Wall hs-source-dirs: examples default-language: Haskell2010 diff --git a/examples/Error.hs b/examples/Error.hs --- a/examples/Error.hs +++ b/examples/Error.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -80,10 +81,10 @@ 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") + let wrapParserError = wrapError @"parser" + @(Rename "ParserError" :.: Ctor "ParserError" "calc") @'[] + wrapMathError = wrapError @"math" + @(Rename "MathError" :.: Ctor "MathError" "calc") @'[] num <- wrapParserError $ parseNumber input root <- wrapMathError $ sqrtNumber num liftIO $ putStrLn $ "sqrt = " ++ show root diff --git a/examples/Reader.hs b/examples/Reader.hs --- a/examples/Reader.hs +++ b/examples/Reader.hs @@ -1,48 +1,65 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeInType #-} -- | Example uses and instances of the @HasReader@ capability. module Reader where import Capability.Reader +import Capability.Source import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT (..)) import GHC.Generics (Generic) import Test.Common import Test.Hspec +data Foo +data Bar +type instance TypeOf * Foo = Int +type instance TypeOf * Bar = Int + ---------------------------------------------------------------------- -- Example Programs -- | Returns the triple of the number in context "foo". -tripleFoo :: HasReader "foo" Int m => m Int +tripleFoo :: HasReader' Foo m => m Int tripleFoo = do - single <- ask @"foo" - double <- asks @"foo" (*2) + 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 :: (HasReader' Foo m, MonadIO m) => m () fooExample = do liftIO . print =<< tripleFoo - liftIO . print =<< local @"foo" (*2) 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 () + :: (HasReader' Foo m, HasReader' Bar m, MonadIO m) => m () fooBarExample = do - local @"bar" (*2) $ do - liftIO . print =<< ask @"bar" + local @Bar (*2) $ do + liftIO . print =<< ask @Bar liftIO . print =<< tripleFoo +-- | Shows the interaction between 'local' and 'magnify'. +fooBarMagnify + :: (HasReader "foobar" FooBar m, MonadIO m) => m () +fooBarMagnify = do + magnify + @"foo" + @(Field "foo" "foobar") + @('[HasReader "foobar" FooBar, MonadIO]) $ do + FooBar a b <- local @"foo" (const 5) (ask @"foobar") + c <- local @"foobar" (const $ FooBar 3 4) (ask @"foo") + liftIO $ print ((a, b), c) ---------------------------------------------------------------------- -- Instances @@ -50,7 +67,8 @@ -- | @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) + deriving (HasSource Foo Int) via MonadReader (ReaderT Int m) + deriving (HasReader Foo Int) via MonadReader (ReaderT Int m) runFooReaderT :: FooReaderT m a -> m a runFooReaderT (FooReaderT m) = runReaderT m 1 @@ -64,10 +82,12 @@ -- | 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)) + deriving (HasSource "foobar" FooBar, HasReader "foobar" FooBar) via + (MonadReader (ReaderT FooBar IO)) + deriving (HasSource Foo Int, HasReader Foo Int) via + Rename "foo" (Field "foo" () (MonadReader (ReaderT FooBar IO))) + deriving (HasSource Bar Int, HasReader Bar Int) via + Rename "bar" (Field "bar" () (MonadReader (ReaderT FooBar IO))) runFooBarReader :: FooBarReader a -> IO a runFooBarReader (FooBarReader m) = runReaderT m FooBar { foo = 1, bar = 2 } @@ -80,8 +100,10 @@ -- 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) + deriving (HasSource Foo Int, HasReader Foo Int) + via MonadReader (ReaderT Int IO) + deriving (HasSource Bar Int, HasReader Bar Int) + via MonadReader (ReaderT Int IO) runBadFooBarReader :: BadFooBarReader a -> IO a runBadFooBarReader (BadFooBarReader m) = runReaderT m 1 @@ -100,6 +122,8 @@ runFooBarReader fooExample `shouldPrint` "3\n6\n" it "evaluates fooBarExample" $ runFooBarReader fooBarExample `shouldPrint` "4\n3\n" + it "evaluates fooBarMagnify" $ + runFooBarReader fooBarMagnify `shouldPrint` "((5,2),3)\n" describe "BadFooBarReader" $ do it "evaluates fooExample" $ runBadFooBarReader fooExample `shouldPrint` "3\n6\n" diff --git a/examples/Sink.hs b/examples/Sink.hs new file mode 100644 --- /dev/null +++ b/examples/Sink.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} + +-- | Example uses and instances of the @HasSink@ capability. +module Sink where + +import Capability.State +import Capability.Source +import Capability.Sink +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 :: HasSink "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, HasSink "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 + +-- | @HasSink a@ derived from @HasState [a]@. Will produce reversed list. +newtype StreamAccM a = StreamAccM (State [Int] a) + deriving (Functor, Applicative, Monad) + deriving (HasSink "nums" Int) via + SinkStack (MonadState (State [Int])) + +runStreamAccM :: StreamAccM a -> (a, [Int]) +runStreamAccM (StreamAccM m) = runState m [] + + +-- | @'Streaming.Stream' ('Streaming.Of' a)@ has a @HasSink a@ instance. +printStreamOfInt :: Stream (Of Int) IO () -> IO () +printStreamOfInt = S.stdoutLn . S.map show + + +-- | Composed @StateT@ and @Stream@ to provide @HasState@ and @HasSink@. +newtype StateOverStream a = + StateOverStream (StateT Int (Stream (Of (Int, Char)) IO) a) + deriving (Functor, Applicative, Monad) + deriving (HasSource "counter" Int, HasSink "counter" Int, HasState "counter" Int) via + MonadState (StateT Int (Stream (Of (Int, Char)) IO)) + deriving (HasSink "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/State.hs b/examples/State.hs --- a/examples/State.hs +++ b/examples/State.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} @@ -12,6 +14,8 @@ module State where import Capability.Reader +import Capability.Sink +import Capability.Source import Capability.State import Control.Monad.Reader (ReaderT (..)) import Control.Monad.State.Strict (State, StateT (..), runState) @@ -25,6 +29,9 @@ incFoo :: HasState "foo" Int m => m () incFoo = modify @"foo" (+1) +incFoobar :: HasState "foobar" (Int,Int) m => m () +incFoobar = modify @"foobar" $ \(x,y) -> (x+1, y+1) + twoStates :: (HasState "foo" Int m, HasState "bar" Int m) => m () twoStates = do incFoo @@ -34,9 +41,13 @@ 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 + -- Zoom in on the first element in the current state, renaming tag 1 to "foo", + -- while retaining the original 'HasState "foobar" (Int, Int)' capability. + zoom + @"foo" @(Rename 1 :.: Pos 1 "foobar") + @('[HasState "foobar" (Int,Int)]) $ do + incFoo + incFoobar gets @"foobar" (\(foo, bar) -> foo + bar) @@ -54,10 +65,10 @@ -- fields of the @HasReader@ context. newtype TwoStatesM a = TwoStatesM (ReaderT TwoStates IO a) deriving (Functor, Applicative, Monad) - deriving (HasState "foo" Int) via + deriving (HasSource "foo" Int, HasSink "foo" Int, HasState "foo" Int) via ReaderIORef (Rename "tsFoo" (Field "tsFoo" () (MonadReader (ReaderT TwoStates IO)))) - deriving (HasState "bar" Int) via + deriving (HasSource "bar" Int, HasSink "bar" Int, HasState "bar" Int) via ReaderIORef (Rename "tsBar" (Field "tsBar" () (MonadReader (ReaderT TwoStates IO)))) @@ -78,9 +89,9 @@ -- @MonadState@. newtype PairStateM a = PairStateM (State (Int, Int) a) deriving (Functor, Applicative, Monad) - deriving (HasState "foo" Int) via + deriving (HasSource "foo" Int, HasSink "foo" Int, HasState "foo" Int) via Rename 1 (Pos 1 () (MonadState (State (Int, Int)))) - deriving (HasState "bar" Int) via + deriving (HasSource "bar" Int, HasSink "bar" Int, HasState "bar" Int) via Rename 2 (Pos 2 () (MonadState (State (Int, Int)))) runPairStateM :: PairStateM a -> (a, (Int, Int)) @@ -94,8 +105,10 @@ -- 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))) + deriving (HasSource "foo" Int, HasSink "foo" Int, HasState "foo" Int) via + MonadState (StateT Int (State Int)) + deriving (HasSource "bar" Int, HasSink "bar" Int, HasState "bar" Int) via + Lift (StateT Int (MonadState (State Int))) runNestedStatesM :: NestedStatesM a -> ((a, Int), Int) runNestedStatesM (NestedStatesM m) = runState (runStateT m 0) 0 @@ -123,4 +136,4 @@ runNestedStatesM twoStates `shouldBe` (((), 1), -1) describe "runFooBarState" $ it "evaluates useZoom" $ - runFooBarState useZoom (0, 0) `shouldBe` (5, (3, 2)) + runFooBarState useZoom (0, 0) `shouldBe` (7, (4, 3)) diff --git a/examples/Stream.hs b/examples/Stream.hs deleted file mode 100644 --- a/examples/Stream.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# 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 --- a/examples/Test.hs +++ b/examples/Test.hs @@ -15,7 +15,7 @@ import qualified Error import qualified Reader import qualified State -import qualified Stream +import qualified Sink import qualified Writer import qualified WordCount @@ -26,7 +26,7 @@ describe "Error" Error.spec describe "Reader" Reader.spec describe "State" State.spec - describe "Stream" Stream.spec + describe "Sink" Sink.spec describe "Writer" Writer.spec describe "WordCount" WordCount.spec diff --git a/examples/WordCount.hs b/examples/WordCount.hs --- a/examples/WordCount.hs +++ b/examples/WordCount.hs @@ -14,7 +14,7 @@ import Capability.Reader import Capability.State -import Capability.Stream +import Capability.Sink import Control.Lens (ifor_) import Data.Coerce (coerce) import Data.Map.Strict (Map) @@ -56,21 +56,21 @@ -- | Count the occurrence of a single letter. countLetter :: - HasStream "letterCount" (Occurrences Char) m + HasSink "letterCount" (Occurrences Char) m => Char -> m () countLetter letter = yield @"letterCount" (oneOccurrence letter) -- | Count the occurrence of a single word. countWord :: - HasStream "wordCount" (Occurrences Text) m + HasSink "wordCount" (Occurrences Text) m => Text -> m () countWord word = yield @"wordCount" (oneOccurrence word) -- | Count the occurrence of a single word and all the letters in it. countWordAndLetters :: - ( HasStream "letterCount" (Occurrences Char) m - , HasStream "wordCount" (Occurrences Text) m ) + ( HasSink "letterCount" (Occurrences Char) m + , HasSink "wordCount" (Occurrences Text) m ) => Text -> m () countWordAndLetters word = do countWord word @@ -80,8 +80,8 @@ -- | Count the occurrences of words and letters in a text, -- excluding white space. countWordsAndLettersInText :: - ( HasStream "letterCount" (Occurrences Char) m - , HasStream "wordCount" (Occurrences Text) m ) + ( HasSink "letterCount" (Occurrences Char) m + , HasSink "wordCount" (Occurrences Text) m ) => Text -> m () countWordsAndLettersInText text = mapM_ countWordAndLetters (Text.words text) @@ -98,14 +98,14 @@ -- | Counter application monad. newtype Counter a = Counter { runCounter :: CounterCtx -> IO a } deriving (Functor, Applicative, Monad) via (ReaderT CounterCtx IO) - deriving (HasStream "letterCount" (Occurrences Char)) via - (StreamLog -- Generate HasStream using HasState of Monoid + deriving (HasSink "letterCount" (Occurrences Char)) via + (SinkLog -- Generate HasSink 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 (HasStream "wordCount" (Occurrences Text)) via - StreamLog (ReaderIORef + deriving (HasSink "wordCount" (Occurrences Text)) via + SinkLog (ReaderIORef (Field "wordCount" "ctx" (MonadReader (ReaderT CounterCtx IO)))) diff --git a/examples/Writer.hs b/examples/Writer.hs --- a/examples/Writer.hs +++ b/examples/Writer.hs @@ -9,7 +9,8 @@ module Writer where import Capability.State -import Capability.Stream +import Capability.Sink +import Capability.Source import Capability.Writer import Control.Monad.State.Strict (State, StateT (..), runState) import Data.Monoid (Sum (..)) @@ -19,12 +20,12 @@ -- Example Programs -- | Increase a counter using a writer monad. -useWriter :: HasWriter "count" (Sum Int) m => m () +useWriter :: HasWriter "count-writer" (Sum Int) m => m () useWriter = do -- Add 3 and retrieve result - ((), count) <- listen @"count" (tell @"count" 3) + ((), count) <- listen @"count-writer" (tell @"count-writer" 3) -- Duplicate - tell @"count" count + tell @"count-writer" count -- | Mix writer and state monad operations on the same tag. @@ -33,12 +34,12 @@ -- 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) + :: (HasState "count-state" Int m, HasWriter "count-writer" (Sum Int) m) => m Int mixWriterState = do - tell @"count" 1 - one <- get @"count" - tell @"count" $ Sum one + tell @"count-writer" 1 + one <- get @"count-state" + tell @"count-writer" $ Sum one pure one @@ -51,7 +52,7 @@ -- via clause. newtype WriterM a = WriterM (State Int a) deriving (Functor, Applicative, Monad) - deriving (HasStream "count" (Sum Int), HasWriter "count" (Sum Int)) + deriving (HasSink "count-writer" (Sum Int), HasWriter "count-writer" (Sum Int)) via WriterLog (Coerce (Sum Int) (MonadState (State Int))) runWriterM :: WriterM a -> (a, Int) @@ -65,9 +66,9 @@ -- See caveat on 'mixWriterState'. newtype BadWriterM a = BadWriterM (State Int a) deriving (Functor, Applicative, Monad) - deriving (HasStream "count" (Sum Int), HasWriter "count" (Sum Int)) + deriving (HasSink "count-writer" (Sum Int), HasWriter "count-writer" (Sum Int)) via WriterLog (Coerce (Sum Int) (MonadState (State Int))) - deriving (HasState "count" Int) + deriving (HasSource "count-state" Int, HasSink "count-state" Int, HasState "count-state" Int) via MonadState (State Int) runBadWriterM :: BadWriterM a -> (a, Int) diff --git a/src/Capability.hs b/src/Capability.hs --- a/src/Capability.hs +++ b/src/Capability.hs @@ -51,6 +51,29 @@ -- Then you can use @foo@ at type @MyM@. Or any other type which can provide -- these capabilites. -- +-- === Functional capabilities +-- +-- When writing applications, as opposed to libraries, a capability /name/ often +-- determines its type parameters. It can be tiresome to write +-- +-- @ +-- f :: HasReader "config" Config m => … +-- @ +-- +-- over and over again. +-- +-- To avoid this, each capability comes with a /functional/—here +-- @HasReader\'@—variant (in this terminology @HasReader@ is +-- /relational/). Where the type is deduced from the capability's name. The +-- mapping from name to type is done with the @'Capability.TypeOf.TypeOf'@ +-- family, which is re-exported by every capability module. +-- +-- @ +-- type instance TypeOf Symbol "config" = Config +-- +-- f :: HasReader' "config" m => … +-- @ +-- -- == Module structure -- -- Each module introduces a capability type class (or several related type @@ -65,12 +88,34 @@ -- * "Capability.State" state effects -- * "Capability.Writer" writer effects -- * "Capability.Error" throw and catch errors --- * "Capability.Stream" streaming effect (aka generators) +-- * "Capability.Source" streaming in effect +-- * "Capability.Sink" streaming out effect (aka generators) -- +-- The effects are not all independent: +-- +-- > Source Sink +-- > / \ / \ +-- > / \ / \ +-- > Reader State Writer +-- +-- "Capability.Source" and "Capability.Sink" have just a method each, and no laws. +-- The bottom three, familiar from mtl, add methods and laws relating them. +-- The use of tags allows one to have independent effects that share a superclass. +-- E.g. @HasState "foo" Int@ and @HasWriter "bar" String@. +-- -- 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. +-- +-- Finally there is +-- +-- * "Capability.Derive" +-- +-- Which exports a (still experimental) 'Capability.Derive.derive' function, +-- which lets you run a computation which requires capabilities which are not +-- directly provided by the ambient monad, but can be derived from the +-- capabilities provided by the ambient monad. -- -- == Further considerations -- diff --git a/src/Capability/Constraints.hs b/src/Capability/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Constraints.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module defines helper types and type families for working with sets of +-- capabilities. + +module Capability.Constraints + ( All + , Capability + , Constraint + , Dict(..) + ) where + +import Data.Constraint (Dict(..)) +import Data.Kind (Constraint) + +-- | A 'Capability' takes a type constructor @* -> *@ (e.g., a monad) and +-- returns a 'Constraint'. Examples of capabilities includ: @HasReader "foo" +-- Int@, @MonadIO@, … +type Capability = (* -> *) -> Constraint + +-- | Type family used used to express a conjunction of constraints over a single +-- type. +-- +-- Examples: +-- +-- > All '[Num, Eq] Int +-- > -- Equivalent to: (Num Int, Eq Int) +-- > +-- > All '[HasReader "foo" Int, HasSink "bar" Float] m +-- > -- Equivalent to: (HasReader "foo" Int m, HasSink "bar" Float m) +type family All (xs :: [k -> Constraint]) a :: Constraint where + All '[] a = () + All (x ':xs) a = (x a, All xs a) diff --git a/src/Capability/Derive.hs b/src/Capability/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Derive.hs @@ -0,0 +1,54 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Capability.Derive where + +import Capability.Constraints +import Data.Coerce (Coercible) +import Unsafe.Coerce (unsafeCoerce) + +-- | Runs an action that requires additional capabilities. +-- +-- @'derive' \@t \@derived \@ambient act@ runs @act@ by providing both the +-- capabilities in @derived@ and @ambient@. The difference is that @ambient@ +-- capabilities are assumed to be available, whereas @derived@ instances are +-- provided by @t@. +-- +-- 'derive' assumes that @t@ is a newtype defined in the form: +-- +-- @ +-- newtype T m a = T (m a) +-- @ +-- +-- Then 'derive' uses type-class instances for `T` to provide for each of the +-- capabilities in @derived@. +-- +-- A common instance of this is 'Capability.Error.wrapError', whereby exceptions +-- raised by @act@ can be repackaged in a larger exception type. +-- +-- The @derive@ function is experimental and is subject to change. +derive :: + forall t (derived :: [Capability]) (ambient :: [Capability]) m a. + ( forall x. Coercible (t m x) (m x) + , All derived (t m) + , All ambient m) + => (forall m'. (All derived m', All ambient m') => m' a) -> m a +derive action = + let tmDict = Dict @(All derived (t m)) + mDict = + -- Note: this use of 'unsafeCoerce' should be safe thanks the Coercible + -- constraint between 'm x' and 't m x'. However, dictionaries + -- themselves aren't coercible since the type role of 'c' in 'Dict c' is + -- nominal. + unsafeCoerce @_ @(Dict (All derived m)) tmDict in + case mDict of + Dict -> action +{-# INLINE derive #-} diff --git a/src/Capability/Error.hs b/src/Capability/Error.hs --- a/src/Capability/Error.hs +++ b/src/Capability/Error.hs @@ -24,6 +24,7 @@ -- thrown under @"foo"@. {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} @@ -45,13 +46,17 @@ {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} module Capability.Error - ( -- * Interface + ( -- * Relational capabilities HasThrow(..) , throw , HasCatch(..) , catch , catchJust , wrapError + -- * Functional capabilities + , HasThrow' + , HasCatch' + , TypeOf -- * Strategies , MonadError(..) , MonadThrow(..) @@ -66,6 +71,9 @@ ) where import Capability.Accessors +import Capability.Constraints +import Capability.Derive (derive) +import Capability.TypeOf import Control.Exception (Exception(..)) import qualified Control.Exception.Safe as Safe import Control.Lens (preview, review) @@ -143,12 +151,12 @@ {-# INLINE catchJust #-} -- | Wrap exceptions @inner@ originating from the given action according to --- the accessor @t@. +-- the accessor @t@. Retain arbitrary capabilities listed in @cs@. -- -- Example: -- -- > wrapError --- > @"AppError" @"ComponentError" @(Ctor "ComponentError" "AppError") +-- > @"ComponentError" @(Ctor "ComponentError" "AppError") @'[] -- > component -- > -- > component :: HasError "ComponentError" ComponentError m => m () @@ -156,13 +164,13 @@ -- -- This function is experimental and subject to change. -- See . -wrapError :: forall outertag innertag t outer inner m a. +wrapError :: forall innertag t (cs :: [Capability]) 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 + , HasCatch innertag inner (t m) + , All cs m) + => (forall m'. All (HasCatch innertag inner ': cs) m' => m' a) -> m a +wrapError = + derive @t @'[HasCatch innertag inner] @cs {-# INLINE wrapError #-} -- XXX: Does it make sense to add a HasMask capability similar to @MonadMask@? @@ -421,3 +429,11 @@ ( forall x. Coercible (m x) (t2 (t1 m) x) , Monad m, HasCatch tag e (t2 (t1 m)) ) => HasCatch tag e ((t2 :.: t1) m) + +-- | Type synonym using the 'TypeOf' type family to specify 'HasThrow' +-- constraints without having to specify the type associated to a tag. +type HasThrow' (tag :: k) = HasThrow tag (TypeOf k tag) + +-- | Type synonym using the 'TypeOf' type family to specify 'HasCatch' +-- constraints without having to specify the type associated to a tag. +type HasCatch' (tag :: k) = HasCatch tag (TypeOf k tag) diff --git a/src/Capability/Reader.hs b/src/Capability/Reader.hs --- a/src/Capability/Reader.hs +++ b/src/Capability/Reader.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeInType #-} + -- | 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 @@ -5,8 +9,11 @@ -- a change is local, and does not persist when the 'local' call ends. module Capability.Reader - ( -- * Interface + ( -- * Relational capability module Capability.Reader.Internal.Class + -- * Functional capability + , HasReader' + , TypeOf -- * Strategies , module Capability.Reader.Internal.Strategies -- ** Modifiers @@ -16,3 +23,8 @@ import Capability.Accessors import Capability.Reader.Internal.Class import Capability.Reader.Internal.Strategies +import Capability.TypeOf + +-- | Type synonym using the 'TypeOf' type family to specify 'HasReader' +-- constraints without having to specify the type associated to a tag. +type HasReader' (tag :: k) = HasReader tag (TypeOf k tag) diff --git a/src/Capability/Reader/Internal/Class.hs b/src/Capability/Reader/Internal/Class.hs --- a/src/Capability/Reader/Internal/Class.hs +++ b/src/Capability/Reader/Internal/Class.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeInType #-} {-# OPTIONS_HADDOCK hide #-} @@ -20,7 +21,10 @@ , magnify ) where -import Data.Coerce (Coercible, coerce) +import Capability.Constraints +import Capability.Source.Internal.Class +import Capability.Derive (derive) +import Data.Coerce (Coercible) import GHC.Exts (Proxy#, proxy#) -- | Reader capability @@ -36,16 +40,11 @@ -- 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 +class (Monad m, HasSource tag r 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 @@ -58,7 +57,7 @@ -- | @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) +ask = await @tag {-# INLINE ask #-} -- | @asks \@tag@ @@ -67,7 +66,7 @@ -- -- 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 +asks = awaits @tag {-# INLINE asks #-} -- | @local \@tag f m@ @@ -88,17 +87,19 @@ {-# INLINE reader #-} -- | Execute the given reader action on a sub-component of the current context --- as defined by the given transformer @t@. +-- as defined by the given transformer @t@, retaining arbitrary capabilities +-- listed in @cs@. -- --- See 'Capability.State.zoom'. +-- See the similar 'Capability.State.zoom' function for more details and +-- examples. -- -- This function is experimental and subject to change. -- See . -magnify :: forall outertag innertag t outer inner m a. +magnify :: forall innertag t (cs :: [Capability]) 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 + , HasReader innertag inner (t m) + , All cs m) + => (forall m'. All (HasReader innertag inner ': cs) m' => m' a) -> m a +magnify = + derive @t @'[HasReader innertag inner] @cs {-# INLINE magnify #-} diff --git a/src/Capability/Reader/Internal/Strategies.hs b/src/Capability/Reader/Internal/Strategies.hs --- a/src/Capability/Reader/Internal/Strategies.hs +++ b/src/Capability/Reader/Internal/Strategies.hs @@ -15,6 +15,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} @@ -30,10 +31,9 @@ import Capability.Accessors import Capability.Reader.Internal.Class import Capability.State.Internal.Class +import Capability.Source.Internal.Strategies 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(..)) @@ -42,14 +42,7 @@ 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 @@ -58,27 +51,7 @@ 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 @@ -89,20 +62,10 @@ 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 -> @@ -122,8 +85,6 @@ , 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 @@ -134,8 +95,6 @@ -- | 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 @@ -144,7 +103,6 @@ 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 @@ -154,9 +112,6 @@ ( 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) @@ -182,9 +137,6 @@ ( 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) @@ -205,8 +157,6 @@ 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) $ diff --git a/src/Capability/Sink.hs b/src/Capability/Sink.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Sink.hs @@ -0,0 +1,43 @@ +-- | 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 'HasSink' capability enables separating the logic responsible for +-- emitting events from that responsible for collecting or handling them. +-- The name is because a sink is needed to consume the locally produced stream. +-- +-- 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 ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} + +module Capability.Sink + ( -- * Relational capability + module Capability.Sink.Internal.Class + -- * Functional capability + , HasSink' + , TypeOf + -- * Strategies + , module Capability.Sink.Internal.Strategies + -- ** Modifiers + , module Capability.Accessors + ) where + +import Capability.Sink.Internal.Class +import Capability.Sink.Internal.Strategies +import Capability.Accessors +import Capability.TypeOf + +-- | Type synonym using the 'TypeOf' type family to specify 'HasSink' +-- constraints without having to specify the type associated to a tag. +type HasSink' (tag :: k) = HasSink tag (TypeOf k tag) diff --git a/src/Capability/Sink/Internal/Class.hs b/src/Capability/Sink/Internal/Class.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Sink/Internal/Class.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# 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 #-} + +{-# OPTIONS_HADDOCK hide #-} + +module Capability.Sink.Internal.Class where + +import GHC.Exts (Proxy#, proxy#) + +-- | Sinking capability. +-- +-- An instance does not need to fulfill any additional laws +-- besides the monad laws. +class Monad m + => HasSink (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 'HasSink'. + -- Otherwise, you will want to use 'yield'. + -- See 'yield' for more documentation. + yield_ :: Proxy# tag -> a -> m () + +-- | @yield \@tag a@ +-- emits @a@ in the sink capability @tag@. +yield :: forall tag a m. HasSink tag a m => a -> m () +yield = yield_ (proxy# @_ @tag) +{-# INLINE yield #-} diff --git a/src/Capability/Sink/Internal/Strategies.hs b/src/Capability/Sink/Internal/Strategies.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Sink/Internal/Strategies.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# 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 TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# OPTIONS_HADDOCK hide #-} + +module Capability.Sink.Internal.Strategies + ( SinkStack(..) + , SinkDList(..) + , SinkLog(..) + ) where + +import Capability.Accessors +import Capability.Source.Internal.Class +import Capability.Sink.Internal.Class +import Capability.State.Internal.Class +import Capability.State.Internal.Strategies.Common +import Control.Lens (set) +import Control.Monad.IO.Class (MonadIO) +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 Data.DList (DList) +import qualified Data.DList as DList +import qualified Data.Generics.Product.Fields as Generic +import qualified Data.Generics.Product.Positions as Generic +import Data.IORef +import Data.Mutable +import Streaming +import qualified Streaming.Prelude as S + +-- | Accumulate sunk values in a reverse order list. +newtype SinkStack m (a :: *) = SinkStack (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) +instance HasState tag [a] m => HasSink tag a (SinkStack m) where + yield_ _ a = coerce @(m ()) $ modify' @tag (a:) + {-# INLINE yield_ #-} + +-- | Accumulate sunk values in forward order in a difference list. +newtype SinkDList m (a :: *) = SinkDList (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) +-- | This instance may seem a bit odd at first. All it does is wrap each +-- 'yield'ed value in a single element difference list. How does re-yielding +-- something else constitute a strategy for implementing 'HasSink' in the +-- first place? The answer is that difference lists form a monoid, which allows +-- a second stragegy to be used which accumulates all 'yield's in a single +-- value, actually eliminating the 'HasSink' constraint this time. +-- +-- 'SinkLog' below in fact does this, so the easiest way to fully eliminate +-- the 'HasSink' constraint as described above is: +-- +-- > deriving (HasSink tag w) via +-- > SinkDList (SinkLog (MonadState SomeStateMonad)) +instance HasSink tag (DList a) m => HasSink tag a (SinkDList m) where + yield_ _ = coerce @(a -> m ()) $ yield @tag . DList.singleton + {-# INLINE yield_ #-} + +-- | Accumulate sunk values with their own monoid. +newtype SinkLog m (a :: *) = SinkLog (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) +instance (Monoid w, HasState tag w m) => HasSink tag w (SinkLog m) where + yield_ _ w = coerce @(m ()) $ modify' @tag (<> w) + {-# INLINE yield_ #-} + +instance Monad m => HasSink tag a (S.Stream (Of a) m) where + yield_ _ = S.yield + {-# INLINE yield_ #-} + +-- | Lift one layer in a monad transformer stack. +-- +-- Note, that if the 'HasSink' instance is based on 'HasState', then it is +-- more efficient to apply 'Lift' to the underlying state capability. E.g. +-- you should favour +-- +-- > deriving (HasSink tag w) via +-- > SinkLog (Lift (SomeTrans (MonadState SomeStateMonad))) +-- +-- over +-- +-- > deriving (HasSink tag w) via +-- > Lift (SomeTrans (SinkLog (MonadState SomeStateMonad))) +instance (HasSink tag a m, MonadTrans t, Monad (t m)) + => HasSink 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, HasSink tag a (t2 (t1 m)) ) + => HasSink tag a ((t2 :.: t1) m) + +-- | Convert the state using safe coercion. +instance + ( Coercible from to, HasSink tag from m ) + => HasSink tag to (Coerce to m) + where + yield_ tag = coerce @(from -> m ()) $ yield_ tag + {-# INLINE yield_ #-} + +-- | Rename the tag. +instance HasSink oldtag s m => HasSink newtag s (Rename oldtag m) where + yield_ _ = coerce @(s -> m ()) $ yield @oldtag + {-# INLINE yield_ #-} + +-- | 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 ) + => HasSink tag v (Field field oldtag m) + where + yield_ _ = coerce @(v -> m ()) $ + modify @oldtag . set (Generic.field' @field @record) + {-# INLINE yield_ #-} + +-- | 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 ) + => HasSink tag v (Pos pos oldtag m) + where + yield_ _ = coerce @(v -> m ()) $ + modify @oldtag . set (Generic.position' @pos @struct) + {-# INLINE yield_ #-} + +-------------------------------------------------------------------------------- + +instance State.MonadState s m => HasSink tag s (MonadState m) where + yield_ _ = coerce @(s -> m ()) State.put + {-# INLINE yield_ #-} + +instance + (HasSource tag (IORef s) m, MonadIO m) + => HasSink tag s (ReaderIORef m) + where + yield_ _ v = ReaderIORef $ do + ref <- await @tag + liftIO $ writeIORef ref v + {-# INLINE yield_ #-} + +instance + ( MutableRef ref, RefElement ref ~ s + , HasSource tag ref m, PrimMonad m, PrimState m ~ MCState ref ) + => HasSink tag s (ReaderRef m) + where + yield_ _ v = ReaderRef $ do + ref <- await @tag + writeRef ref v + {-# INLINE yield_ #-} diff --git a/src/Capability/Source.hs b/src/Capability/Source.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Source.hs @@ -0,0 +1,53 @@ +-- | Defines a capability for computations that consume a stream of values +-- as part of their execution. +-- +-- Programs comsuming streams of data are common. Examples: rolling up input +-- events. Sources are similar to Python generators. +-- +-- This can be thought of as a reader capability where there's no guarantee that +-- one reads the same value each time. +-- +-- The 'HasSource' capability enables separating the logic responsible for +-- emitting events from that responsible for collecting or handling them. +-- The name is because a source is needed to produce the locally consumed stream. +-- + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# 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.Source + ( -- * Relational capability + module Capability.Source.Internal.Class + -- * Functional capability + , HasSource' + , TypeOf + -- * Strategies + , module Capability.Source.Internal.Strategies + -- ** Modifiers + , module Capability.Accessors + ) where + +import Capability.Accessors +import Capability.Source.Internal.Class +import Capability.Source.Internal.Strategies +import Capability.TypeOf + +-- | Type synonym using the 'TypeOf' type family to specify 'HasSource' +-- constraints without having to specify the type associated to a tag. +type HasSource' (tag :: k) = HasSource tag (TypeOf k tag) diff --git a/src/Capability/Source/Internal/Class.hs b/src/Capability/Source/Internal/Class.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Source/Internal/Class.hs @@ -0,0 +1,66 @@ +-- | Defines a capability for computations that consume a stream of values +-- as part of their execution. +-- +-- Programs comsuming streams of data are common. Examples: rolling up input +-- events. Sources are similar to Python generators. +-- +-- This can be thought of as a reader capability where there's no guarantee that +-- one reads the same value each time. +-- +-- The 'HasSource' capability enables separating the logic responsible for +-- emitting events from that responsible for collecting or handling them. +-- The name is because a source is needed to produce the locally consumed stream. +-- + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# 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 #-} + +{-# OPTIONS_HADDOCK hide #-} + +module Capability.Source.Internal.Class where + +import GHC.Exts (Proxy#, proxy#) + +-- | Sourcing capability. +-- +-- An instance does not need to fulfill any additional laws +-- besides the monad laws. +class Monad m + => HasSource (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 'HasSource'. + -- Otherwise, you will want to use 'await'. + -- See 'await' for more documentation. + await_ :: Proxy# tag -> m a + +-- | @await \@tag a@ +-- takes @a@ from the source capability @tag@. +await :: forall tag a m. HasSource tag a m => m a +await = await_ (proxy# @_ @tag) +{-# INLINE await #-} + +-- | @awaits \@tag@ +-- retrieves the image by @f@ of the environment +-- of the reader capability @tag@. +-- +-- prop> awaits @tag f = f <$> await @tag +awaits :: forall tag r m a. HasSource tag r m => (r -> a) -> m a +awaits f = f <$> await @tag +{-# INLINE awaits #-} diff --git a/src/Capability/Source/Internal/Strategies.hs b/src/Capability/Source/Internal/Strategies.hs new file mode 100644 --- /dev/null +++ b/src/Capability/Source/Internal/Strategies.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# OPTIONS_HADDOCK hide #-} + +module Capability.Source.Internal.Strategies + ( MonadReader(..) + , ReadStatePure(..) + , ReadState(..) + , MonadState(..) + , ReaderIORef(..) + , ReaderRef(..) + ) where + +import Capability.Source.Internal.Class +import Capability.State.Internal.Class +import Capability.State.Internal.Strategies.Common +import Capability.Accessors +import Control.Lens (view) +import Control.Monad.Catch (MonadMask) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Primitive (PrimMonad) +import qualified Control.Monad.Reader.Class as Reader +import qualified Control.Monad.State.Class as State +import Control.Monad.Trans.Class (MonadTrans, lift) +import Data.Coerce (Coercible, coerce) +import Data.IORef +import Data.Mutable +import qualified Data.Generics.Product.Fields as Generic +import qualified Data.Generics.Product.Positions as Generic + +-------------------------------------------------------------------------------- + +-- | Derive 'HasSource' 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 => HasSource tag r (MonadReader m) where + await_ _ = coerce @(m r) Reader.ask + {-# INLINE await_ #-} + +-- | 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 => HasSource tag r (ReadStatePure m) where + await_ _ = coerce @(m r) $ get @tag + {-# INLINE await_ #-} + +-- | 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) + => HasSource tag r (ReadState m) + where + await_ _ = coerce @(m r) $ get @tag + {-# INLINE await_ #-} + +instance + ( tag ~ pos, Generic.HasPosition' pos struct v, HasSource oldtag struct m ) + => HasSource tag v (Pos pos oldtag m) + where + await_ _ = coerce @(m v) $ + awaits @oldtag $ view (Generic.position' @pos) + {-# INLINE await_ #-} + +deriving via ((t2 :: (* -> *) -> * -> *) ((t1 :: (* -> *) -> * -> *) m)) + instance + ( forall x. Coercible (m x) (t2 (t1 m) x) + , Monad m, HasSource tag r (t2 (t1 m)) ) + => HasSource tag r ((t2 :.: t1) m) + +instance + ( Coercible from to, HasSource tag from m + , forall x y. Coercible x y => Coercible (m x) (m y) ) + => HasSource tag to (Coerce to m) + where + await_ tag = coerce @(m from) $ await_ tag + {-# INLINE await_ #-} + +-- | Rename the tag. +instance HasSource oldtag r m => HasSource newtag r (Rename oldtag m) where + await_ _ = coerce @(m r) $ await @oldtag + {-# INLINE await_ #-} + +instance + ( tag ~ field, Generic.HasField' field record v, HasSource oldtag record m ) + => HasSource tag v (Field field oldtag m) + where + await_ _ = coerce @(m v) $ + awaits @oldtag $ view (Generic.field' @field) + {-# INLINE await_ #-} + +instance (HasSource tag r m, MonadTrans t, Monad (t m)) + => HasSource tag r (Lift (t m)) + where + await_ _ = coerce $ lift @t @m $ await @tag @r + {-# INLINE await_ #-} + +-------------------------------------------------------------------------------- + +instance State.MonadState s m => HasSource tag s (MonadState m) where + await_ _ = coerce @(m s) State.get + {-# INLINE await_ #-} + +instance + (HasSource tag (IORef s) m, MonadIO m) + => HasSource tag s (ReaderIORef m) + where + await_ _ = ReaderIORef $ do + ref <- await @tag + liftIO $ readIORef ref + {-# INLINE await_ #-} + +instance + ( MutableRef ref, RefElement ref ~ s + , HasSource tag ref m, PrimMonad m, PrimState m ~ MCState ref ) + => HasSource tag s (ReaderRef m) + where + await_ _ = ReaderRef $ do + ref <- await @tag + readRef ref + {-# INLINE await_ #-} diff --git a/src/Capability/State.hs b/src/Capability/State.hs --- a/src/Capability/State.hs +++ b/src/Capability/State.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeInType #-} + -- | 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 @@ -9,8 +13,11 @@ -- or "Capability.Stream". module Capability.State - ( -- * Interface + ( -- * Relational capability module Capability.State.Internal.Class + -- * Functional capability + , HasState' + , TypeOf -- * Strategies , module Capability.State.Internal.Strategies -- ** Modifiers @@ -20,3 +27,8 @@ import Capability.Accessors import Capability.State.Internal.Class import Capability.State.Internal.Strategies +import Capability.TypeOf + +-- | Type synonym using the 'TypeOf' type family to specify 'HasState' +-- constraints without having to specify the type associated to a tag. +type HasState' (tag :: k) = HasState tag (TypeOf k tag) diff --git a/src/Capability/State/Internal/Class.hs b/src/Capability/State/Internal/Class.hs --- a/src/Capability/State/Internal/Class.hs +++ b/src/Capability/State/Internal/Class.hs @@ -7,7 +7,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} @@ -22,7 +24,11 @@ , zoom ) where -import Data.Coerce (Coercible, coerce) +import Capability.Constraints +import Capability.Derive (derive) +import Capability.Source.Internal.Class +import Capability.Sink.Internal.Class +import Data.Coerce (Coercible) import GHC.Exts (Proxy#, proxy#) -- | State capability @@ -36,21 +42,11 @@ -- 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 +class (Monad m, HasSource tag s m, HasSink tag s 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 @@ -58,13 +54,13 @@ -- | @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) +get = await @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) +put = yield @tag {-# INLINE put #-} -- | @state \@tag f@ @@ -102,24 +98,34 @@ 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@. +-- | Execute the given state action on a sub-component of the current state as +-- defined by the given transformer @t@. The set of retained capabilities must +-- be passed as @cs. If no capabilities are required, +-- 'Capabilities.Constraints.None' can be used. -- --- Example: +-- Examples: -- --- > zoom @"foobar" @"foo" @(Field "foo" "foobar") foo --- > :: HasState "foobar" FooBar m => m () +-- > foo :: HasState "foo" Int m => m () +-- > zoom @"foo" @(Field "foo" "foobar") @None foo +-- > :: (HasField' "foobar" record Int, HasState "foobar" record m) => m () -- > +-- > zoom @"foo" @(Field "foo" "foobar") @('[MonadIO]) bar +-- > :: ( HasField' "foobar" record Int, HasState "foobar" record m +-- > , MonadIO m) => m () +-- > -- > foo :: HasState "foo" Int m => m () --- > data FooBar = FooBar { foo :: Int, bar :: String } +-- > bar :: (MonadIO m, HasState "foo" Int m) => m () -- +-- Note: the 'Data.Generics.Product.Fields.HasField'' constraint comes from the +-- @generic-lens@ package. +-- -- This function is experimental and subject to change. -- See . -zoom :: forall outertag innertag t outer inner m a. +zoom :: forall innertag t (cs :: [Capability]) 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 + , HasState innertag inner (t m) + , All cs m ) + => (forall m'. All (HasState innertag inner ': cs) m' => m' a) -> m a +zoom = + derive @t @'[HasState innertag inner] @cs {-# INLINE zoom #-} diff --git a/src/Capability/State/Internal/Strategies.hs b/src/Capability/State/Internal/Strategies.hs --- a/src/Capability/State/Internal/Strategies.hs +++ b/src/Capability/State/Internal/Strategies.hs @@ -30,7 +30,9 @@ import Capability.Accessors import Capability.Reader.Internal.Class import Capability.State.Internal.Class -import Control.Lens (set, view) +import Capability.State.Internal.Strategies.Common +import Capability.Source.Internal.Strategies () +import Capability.Sink.Internal.Strategies () import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Primitive (PrimMonad) import qualified Control.Monad.State.Class as State @@ -42,16 +44,7 @@ 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_ #-} @@ -62,20 +55,12 @@ , 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_ #-} @@ -88,12 +73,6 @@ ( 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)) @@ -110,12 +89,6 @@ ( 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)) @@ -128,10 +101,6 @@ 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_ #-} @@ -143,31 +112,10 @@ , 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) @@ -175,38 +123,11 @@ 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 diff --git a/src/Capability/State/Internal/Strategies/Common.hs b/src/Capability/State/Internal/Strategies/Common.hs new file mode 100644 --- /dev/null +++ b/src/Capability/State/Internal/Strategies/Common.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# 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.Common + ( MonadState(..) + , ReaderIORef(..) + , ReaderRef(..) + ) where + +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Primitive (PrimMonad) + +-- | Derive 'HasState' from @m@'s +-- 'Control.Monad.State.Class.MonadState' instance. +newtype MonadState (m :: * -> *) (a :: *) = MonadState (m a) + deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) + +-- | 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) + +-- | 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) diff --git a/src/Capability/Stream.hs b/src/Capability/Stream.hs --- a/src/Capability/Stream.hs +++ b/src/Capability/Stream.hs @@ -1,140 +1,33 @@ --- | 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 +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PolyKinds #-} +module Capability.Stream {-# DEPRECATED "Use 'Capability.Sink' "#-} ( -- * Interface - HasStream(..) + HasStream + , HasStream' , yield -- * Strategies - , StreamStack(..) - , StreamDList(..) - , StreamLog(..) + , StreamStack + , StreamDList + , StreamLog -- ** Modifiers , module Capability.Accessors ) where import Capability.Accessors -import Capability.State -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_ #-} +import Capability.Sink --- | Accumulate streamed values in forward order in a difference list. -newtype StreamDList m (a :: *) = StreamDList (m a) - deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) --- | This instance may seem a bit odd at first. All it does is wrap each --- 'yield'ed value in a single element difference list. How does re-yielding --- something else constitute a strategy for implementing 'HasStream' in the --- first place? The answer is that difference lists form a monoid, which allows --- a second stragegy to be used which accumulates all 'yield's in a single --- value, actually eliminating the 'HasStream' constraint this time. --- --- 'StreamLog' below in fact does this, so the easiest way to fully eliminate --- the 'HasStream' constraint as described above is: --- --- > deriving (HasStream tag w) via --- > StreamDList (StreamLog (MonadState SomeStateMonad)) -instance HasStream tag (DList a) m => HasStream tag a (StreamDList m) where - yield_ _ = coerce @(a -> m ()) $ yield @tag . DList.singleton - {-# INLINE yield_ #-} +{-# DEPRECATED HasStream "Use 'HasSink'" #-} +type HasStream = HasSink --- | Accumulate streamed values with their own monoid. -newtype StreamLog m (a :: *) = StreamLog (m a) - deriving (Functor, Applicative, Monad, MonadIO, PrimMonad) -instance (Monoid w, HasState tag w m) => HasStream tag w (StreamLog m) where - yield_ _ w = coerce @(m ()) $ modify' @tag (<> w) - {-# INLINE yield_ #-} +{-# DEPRECATED StreamStack "Use 'SinkStack'" #-} +type StreamStack = SinkStack -instance Monad m => HasStream tag a (S.Stream (Of a) m) where - yield_ _ = S.yield - {-# INLINE yield_ #-} +{-# DEPRECATED StreamDList "Use 'SinkDList'" #-} +type StreamDList = SinkDList --- | Lift one layer in a monad transformer stack. --- --- Note, that if the 'HasStream' instance is based on 'HasState', then it is --- more efficient to apply 'Lift' to the underlying state capability. E.g. --- you should favour --- --- > deriving (HasStream tag w) via --- > StreamLog (Lift (SomeTrans (MonadState SomeStateMonad))) --- --- over --- --- > deriving (HasStream tag w) via --- > Lift (SomeTrans (StreamLog (MonadState SomeStateMonad))) -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_ #-} +{-# DEPRECATED StreamLog "Use 'SinkLog'" #-} +type StreamLog = SinkLog --- | 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) +{-# DEPRECATED HasStream' "Use 'HasSink''" #-} +type HasStream' tag = HasSink' tag diff --git a/src/Capability/TypeOf.hs b/src/Capability/TypeOf.hs new file mode 100644 --- /dev/null +++ b/src/Capability/TypeOf.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} + +module Capability.TypeOf where + +-- | Type family associating a tag to the corresponding type. It is intended to +-- simplify constraint declarations, by removing the need to redundantly specify +-- the type associated to a tag. +-- +-- It is poly-kinded, which allows users to define their own kind of tags. +-- Standard haskell types can also be used as tags by specifying the '*' kind +-- when defining the type family instance. +-- +-- Defining 'TypeOf' instances for 'GHC.TypeLits.Symbol's (typelevel string +-- literals) is discouraged. Since symbols all belong to the same global +-- namespace, such instances could conflict with others defined in external +-- libraries. More generally, as for typeclasses, 'TypeOf' instances should +-- always be defined in the same module as the tag type to prevent issues due to +-- orphan instances. +-- +-- Example: +-- +-- @ +-- import Capability.Reader +-- +-- data Foo +-- data Bar +-- type instance TypeOf * Foo = Int +-- type instance TypeOf * Bar = String +-- +-- -- Same as: foo :: HasReader Foo Int M => … +-- foo :: HasReader' Foo m => … +-- foo = … +-- @ +type family TypeOf k (s :: k) :: * diff --git a/src/Capability/Writer.hs b/src/Capability/Writer.hs --- a/src/Capability/Writer.hs +++ b/src/Capability/Writer.hs @@ -17,6 +17,7 @@ -- and does not misuse the underlying state monad. {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} @@ -36,24 +37,30 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints -Wno-deprecations #-} module Capability.Writer - ( -- * Interface + ( -- * Relational capability HasWriter(..) , writer , tell , listen , pass + -- * Functional capability + , HasWriter' + , TypeOf -- * Strategies , WriterLog - , StreamLog (..) + , StreamLog + , SinkLog (..) -- ** Modifiers , module Capability.Accessors ) where import Capability.Accessors +import Capability.Sink import Capability.State +-- import deprecated module to reexport deprecated item for back-compat. import Capability.Stream import Data.Coerce (Coercible, coerce) import GHC.Exts (Proxy#, proxy#) @@ -70,21 +77,21 @@ -- 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 -- --- = A note on the 'HasStream' super class. +-- = A note on the 'HasSink' super class. -- --- 'HasStream' offers one 'yield' method with the same signature as 'tell'. +-- 'HasSink' offers one 'yield' method with the same signature as 'tell'. -- Many people's intuition, however, wouldn't connect the two: 'yield'ing -- tosses the value down some black-box chute, while 'tell'ing grows and -- accumulation via the monoid. The connection is since the 'chute' is opaque, -- the tosser cannot rule out there being such an accumulation at the chutes -- other end. -- --- Formally, we reach the same conclusion. 'HasStream' has no laws, +-- Formally, we reach the same conclusion. 'HasSink' has no laws, -- indicating the user can make no assumptions beyond the signature of 'yield'. -- 'HasWriter', with 'tell' defined as 'yield', is thus always compatable -- regardless of whatever additional methods it provides and laws by which it -- abides. -class (Monoid w, Monad m, HasStream tag w m) +class (Monoid w, Monad m, HasSink tag w m) => HasWriter (tag :: k) (w :: *) (m :: * -> *) | tag m -> w where -- | For technical reasons, this method needs an extra proxy argument. @@ -110,7 +117,7 @@ -- 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) +writer = writer @tag {-# INLINE writer #-} -- | @tell \@tag w@ @@ -142,7 +149,7 @@ , Monad m, HasWriter tag w (t2 (t1 m)) ) => HasWriter tag w ((t2 :.: t1) m) -type WriterLog = StreamLog +type WriterLog = SinkLog instance (Monoid w, HasState tag w m) => HasWriter tag w (WriterLog m) @@ -167,3 +174,7 @@ put @tag $! w0 <> f w pure a {-# INLINE pass_ #-} + +-- | Type synonym using the 'TypeOf' type family to specify 'HasWriter' +-- constraints without having to specify the type associated to a tag. +type HasWriter' (tag :: k) = HasWriter tag (TypeOf k tag)