Merge pull request #361 from fused-effects/distributive-algebra

Distributive Algebra

ChangeLog.md

@@ -1,15 +1,23 @@
-# Backwards-incompatible changes
+## Backwards-incompatible changes
 
-- Changes `alg`’s signature, giving it a monad homomorphism which must be applied to each computation in the signature. This change allows `Algebra` instances to be derived using `GeneralizedNewtypeDeriving` and `DerivingVia`, while also obviating the need for `hmap` or `handleCoercible`. ([#359](https://github.com/fused-effects/fused-effects/pull/359))
+- Changes `alg`’s signature, giving it an initial state, and a distributive law which must be applied to each computation in the signature. This change allows `Algebra` instances to be derived using `GeneralizedNewtypeDeriving` and `DerivingVia`, while also obviating the need for `hmap`, `handleCoercible`, or the `thread` method of `Effect`. This furthermore increases the expressiveness of effects, allowing effects with higher-order positions yielding concrete types, e.g. `m ()`, to be run anywhere in the stack, not just above any `Effect`-requiring algebras. ([#359](https://github.com/fused-effects/fused-effects/pull/359), [#361](https://github.com/fused-effects/fused-effects/pull/361))
 
-- Changes the signatures of `runInterpret` and `runInterpretState` analogously. ([#359](https://github.com/fused-effects/fused-effects/pull/359))
+- Changes the signatures of `runInterpret` and `runInterpretState` analogously; also reorders the parameters to `runInterpretState` to take the signature before the state parameter. ([#359](https://github.com/fused-effects/fused-effects/pull/359))
 
 - Removes `Algebra`’s superclass constraint requiring a `HFunctor` instance for the signature. ([#359](https://github.com/fused-effects/fused-effects/pull/359))
 
 - Removes `handleCoercible`. Algebras which formerly used it when handling the tail of the signature may now compose `coerce` onto the homomorphism passed to `alg`. ([#359](https://github.com/fused-effects/fused-effects/pull/359))
 
 - Removes `HFunctor`. Effects are no longer required to have `HFunctor` instances, and so the class is redundant. ([#359](https://github.com/fused-effects/fused-effects/pull/359))
 
+- Removes `Effect`. The new signature for `alg` (see above) obviates the need for threading handlers through _effects_, replacing that by threading them through _algebras_ instead. ([#361](https://github.com/fused-effects/fused-effects/pull/361))
+
+- Redefines `thread` as a wrapper around `alg`, composing context functors and distributive laws together. (Note that its type has also changed to take the context last and to decompose the handler for the two carriers.) ([#361](https://github.com/fused-effects/fused-effects/pull/361))
+
+- Renames `Control.Effect.Interpret.Handler` to `Interpreter`. ([#361](https://github.com/fused-effects/fused-effects/pull/361))
+
+- Reorders the parameters to the higher-order function passed to `Control.Effect.Lift.liftWith` for consistency with `alg` and to reflect its purpose of lifting Kleisli arrows in some underlying monad into the context modulo the context’s state. ([#361](https://github.com/fused-effects/fused-effects/pull/361))
+
 
 # v1.0.2.0
 

README.md

@@ -143,7 +143,7 @@ action2 = do
 Effects are run with _effect handlers_, specified as functions (generally starting with `run…`) unpacking some specific monad with a `Carrier` instance. For example, we can run a `State` computation using `runState`, imported from the `Control.Carrier.State.Strict` carrier module:
 
 ```haskell
-example1 :: (Algebra sig m, Effect sig) => [a] -> m (Int, ())
+example1 :: Algebra sig m => [a] -> m (Int, ())
 example1 list = runState 0 $ do
   i <- get
   put (i + length list)
@@ -154,7 +154,7 @@ example1 list = runState 0 $ do
 Since this function returns a value in some carrier `m`, effect handlers can be chained to run multiple effects. Here, we get the list to compute the length of from a `Reader` effect:
 
 ```haskell
-example2 :: (Algebra sig m, Effect sig) => m (Int, ())
+example2 :: Algebra sig m => m (Int, ())
 example2 = runReader "hello" . runState 0 $ do
   list <- ask
   put (length (list :: String))
@@ -188,7 +188,7 @@ example4 = runM . runReader "hello" . runState 0 $ do
 
 ### Required compiler extensions
 
-When defining your own effects, you may need `-XKindSignatures` if GHC cannot correctly infer the type of your handler; see the [documentation on common errors][common] for more information about this case. `-XDeriveGeneric` can be used with many first-order effects to derive default implementation of `Effect`.
+When defining your own effects, you may need `-XKindSignatures` if GHC cannot correctly infer the type of your constructor; see the [documentation on common errors][common] for more information about this case.
 
 When defining carriers, you’ll need `-XTypeOperators` to declare a `Carrier` instance over (`:+:`), `-XFlexibleInstances` to loosen the conditions on the instance, `-XMultiParamTypeClasses` since `Carrier` takes two parameters, and `-XUndecidableInstances` to satisfy the coverage condition for this instance.
 
@@ -197,7 +197,7 @@ When defining carriers, you’ll need `-XTypeOperators` to declare a `Carrier` i
 The following invocation, taken from the teletype example, should suffice for most use or construction of effects and carriers:
 
 ```haskell
-{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
 ```
 
 

benchmark/Bench.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeApplications #-}
@@ -40,14 +39,14 @@ main = defaultMain
   ,
     bgroup "InterpretC vs InterpretStateC vs StateC"
     [ bgroup "InterpretC"
-      [ bench "100"   $ whnf (\n -> run $ evalState @(Sum Int) 0 $ runInterpret (\ hom -> \case { Get k -> get @(Sum Int) >>= hom . k ; Put s k -> put s >> hom k }) $ modLoop n) 100
-      , bench "1000"  $ whnf (\n -> run $ evalState @(Sum Int) 0 $ runInterpret (\ hom -> \case { Get k -> get @(Sum Int) >>= hom . k ; Put s k -> put s >> hom k }) $ modLoop n) 1000
-      , bench "10000" $ whnf (\n -> run $ evalState @(Sum Int) 0 $ runInterpret (\ hom -> \case { Get k -> get @(Sum Int) >>= hom . k ; Put s k -> put s >> hom k }) $ modLoop n) 10000
+      [ bench "100"   $ whnf (\n -> run $ evalState @(Sum Int) 0 $ runInterpret (\ hdl sig ctx -> case sig of { Get k -> get @(Sum Int) >>= hdl . (<$ ctx) . k ; Put s k -> put s >> hdl (k <$ ctx) }) $ modLoop n) 100
+      , bench "1000"  $ whnf (\n -> run $ evalState @(Sum Int) 0 $ runInterpret (\ hdl sig ctx -> case sig of { Get k -> get @(Sum Int) >>= hdl . (<$ ctx) . k ; Put s k -> put s >> hdl (k <$ ctx) }) $ modLoop n) 1000
+      , bench "10000" $ whnf (\n -> run $ evalState @(Sum Int) 0 $ runInterpret (\ hdl sig ctx -> case sig of { Get k -> get @(Sum Int) >>= hdl . (<$ ctx) . k ; Put s k -> put s >> hdl (k <$ ctx) }) $ modLoop n) 10000
       ]
     , bgroup "InterpretStateC"
-      [ bench "100"   $ whnf (\n -> run $ runInterpretState (\ hom s -> \case { Get k -> runState @(Sum Int) s (hom (k s)) ; Put s k -> runState s (hom k) }) 0 $ modLoop n) 100
-      , bench "1000"  $ whnf (\n -> run $ runInterpretState (\ hom s -> \case { Get k -> runState @(Sum Int) s (hom (k s)) ; Put s k -> runState s (hom k) }) 0 $ modLoop n) 1000
-      , bench "10000" $ whnf (\n -> run $ runInterpretState (\ hom s -> \case { Get k -> runState @(Sum Int) s (hom (k s)) ; Put s k -> runState s (hom k) }) 0 $ modLoop n) 10000
+      [ bench "100"   $ whnf (\n -> run $ runInterpretState (\ hdl sig s ctx -> case sig of { Get k -> runState @(Sum Int) s (hdl (k s <$ ctx)) ; Put s k -> runState s (hdl (k <$ ctx)) }) 0 $ modLoop n) 100
+      , bench "1000"  $ whnf (\n -> run $ runInterpretState (\ hdl sig s ctx -> case sig of { Get k -> runState @(Sum Int) s (hdl (k s <$ ctx)) ; Put s k -> runState s (hdl (k <$ ctx)) }) 0 $ modLoop n) 1000
+      , bench "10000" $ whnf (\n -> run $ runInterpretState (\ hdl sig s ctx -> case sig of { Get k -> runState @(Sum Int) s (hdl (k s <$ ctx)) ; Put s k -> runState s (hdl (k <$ ctx)) }) 0 $ modLoop n) 10000
       ]
     , bgroup "StateC"
       [ bench "100"   $ whnf (run . evalState @(Sum Int) 0 . modLoop) 100

docs/common_errors.md

@@ -21,8 +21,8 @@ newtype FailC m a = FailC { runFailC :: m (Either String a) }
 Declaring an `Algebra` instance will fail:
 
 ```haskell
-instance (Algebra sig m, Effect sig)
-    => Algebra (Fail :+: sig) (FailC m) where…
+instance Algebra sig m
+      => Algebra (Fail :+: sig) (FailC m) where…
 ```
 
 ```

docs/defining_effects.md

@@ -25,25 +25,6 @@ The `Read` operation returns a `String`, and hence its continuation is represent
 
 On the other hand, the `Write` operation returns `()`. Since a function `() -> k` is equivalent to a (non-strict) `k`, we can omit the function parameter.
 
-In addition to a `Functor` instance (derived here using `-XDeriveFunctor`), we need one other instance: `Effect`. `Effect` is used by `Algebra` instances to service any requests for their effect occurring inside other computations—whether embedded or in the continuations. Since these may require some state to be maintained, `thread` takes an initial state parameter (encoded as some arbitrary functor filled with `()`), and its function is phrased as a _distributive law_, mapping state functors containing unhandled computations to handled computations producing the state functor alongside any results.
-
-Since `Teletype` is a first-order effect (i.e., its operations don’t have any embedded computations), we can derive an instance of `Effect` by first deriving a `Generic1` instance (using `-XDeriveGeneric`):
-
-```haskell
-import GHC.Generics (Generic1)
-
-data Teletype m k
-  = Read (String -> m k)
-  | Write String (m k)
-  deriving (Functor, Generic1)
-```
-
-and then defining `Effect`, leaving it to use the default definition of the `thread` method:
-
-```haskell
-instance Effect Teletype
-```
-
 Now that we have our effect datatype, we can give definitions for `read` and `write`:
 
 ```haskell
@@ -60,16 +41,17 @@ This gives us enough to write computations using the `Teletype` effect. The next
 
 Effects only specify actions, they don’t actually perform them. That task is left up to effect handlers, typically defined as functions calling `interpret` to apply a given `Algebra` instance.
 
-Following from the above section, we can define a carrier for the `Teletype` effect which runs the calls in an underlying `MonadIO` instance:
+Following from the above section, we can define a carrier for the `Teletype` effect which runs the calls in an underlying `MonadIO` instance, accessed via our carrier’s own `GenericNewtypeDeriving`-derived instance:
 
 ```haskell
 newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }
+  deriving (Applicative, Functor, Monad, MonadIO)
 
-instance (Algebra sig m, MonadIO m) => Algebra (Teletype :+: sig) (TeletypeIOC m) where
-  alg hom = \case
-    L (Read    k) -> TeletypeIOC (liftIO getLine      >>= runTeletypeIOC . k)
-    L (Write s k) -> TeletypeIOC (liftIO (putStrLn s) >>  runTeletypeIOC   k)
-    R other       -> TeletypeIOC (alg (runTeletypeIOC . hom) other)
+instance (MonadIO m, Algebra sig m) => Algebra (Teletype :+: sig) (TeletypeIOC m) where
+  alg hdl sig ctx = case sig of
+    L (Read    k) -> liftIO getLine      >>= hdl . (<$ ctx) . k
+    L (Write s k) -> liftIO (putStrLn s) >>  hdl (k <$ ctx>)
+    R other       -> TeletypeIOC (alg (runTeletypeIOC . hdl) other ctx)
 ```
 
 Here, `alg` is responsible for handling effectful computations. Since the `Algebra` instance handles a sum (`:+:`) of `Teletype` and the remaining signature, `alg` has two parts: a handler for `Teletype`, and a handler for teletype effects that might be embedded inside other effects in the signature.
@@ -84,20 +66,3 @@ By convention, we also provide a `runTeletypeIO` function. For `TeletypeIOC` thi
 runTeletypeIO :: TeletypeIOC m a -> m a
 runTeletypeIO = runTeletypeIOC
 ```
-
-Carrier types are also `Monad`s. Since `TeletypeIOC` is just a thin wrapper around an underlying computation, we can derive several instances using `-XGeneralizedNewtypeDeriving`:
-
-```haskell
-newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }
-  deriving (Applicative, Functor, Monad, MonadIO)
-```
-
-This allows us to use `liftIO` directly on the carrier itself, instead of only in the underlying `m`; likewise with `>>=`, `>>`, and `pure`:
-
-```haskell
-instance (MonadIO m, Algebra sig m) => Algebra (Teletype :+: sig) (TeletypeIOC m) where
-  alg hom = \case
-    L (Read    k) -> liftIO getLine      >>= k
-    L (Write s k) -> liftIO (putStrLn s) >>  k
-    R other       -> TeletypeIOC (alg (runTeletypeIOC . hom) other)
-```

docs/reinterpreting_effects.md

@@ -20,8 +20,7 @@ Let's break down some of the properties of the API client that would be desirabl
 ### Initial setup
 
 ``` haskell
-{-# LANGUAGE ExistentialQuantification, DeriveFunctor,
-DeriveGeneric, FlexibleInstances,
+{-# LANGUAGE ExistentialQuantification, DeriveFunctor, FlexibleInstances,
 GeneralizedNewtypeDeriving, OverloadedStrings, LambdaCase, MultiParamTypeClasses,
 RankNTypes, TypeApplications, TypeOperators, UndecidableInstances #-}
 module CatFacts
@@ -30,7 +29,6 @@ module CatFacts
 -- from base
 import Control.Applicative
 import Control.Exception (throwIO)
-import GHC.Generics (Generic1)
 -- from fused-effects
 import Control.Algebra
 import Control.Carrier.Reader
@@ -70,9 +68,7 @@ instance FromJSON CatFact where
 -- | Our high level effect type that will be able to target different data sources.
 data CatFactClient m k
   = ListFacts Int {- ^ Number of facts to fetch -} ([CatFact] -> m k)
-  deriving (Functor, Generic1)
-
-instance Effect CatFactsClient
+  deriving (Functor)
 
 listFacts :: Has CatFactClient sig m => Int -> m [CatFact]
 listFacts n = send (ListFacts n pure)
@@ -83,9 +79,7 @@ Now that we have our very simple DSL in place, let's think about the underlying
 ``` haskell
 data Http m k
   = SendRequest HTTP.Request (HTTP.Response L.ByteString -> m k)
-  deriving (Functor, Generic1)
-
-instance Effect Http
+  deriving (Functor)
 
 sendRequest :: Has Http sig m => HTTP.Request -> m (HTTP.Response L.ByteString)
 sendRequest r = send (SendRequest r pure)
@@ -189,7 +183,7 @@ handlePrint r =
       Left jsonParseError -> print jsonParseError
       Right facts -> traverse (putStrLn . catFact) facts
 
-catFactsRunner :: (Effect sig, Has Http sig m) => m (Either InvalidContentType (Either JsonParseError [CatFact]))
+catFactsRunner :: Has Http sig m => m (Either InvalidContentType (Either JsonParseError [CatFact]))
 catFactsRunner =
   runError @InvalidContentType $
   runError @JsonParseError $

examples/Parser.hs

@@ -1,9 +1,7 @@
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -18,7 +16,6 @@ import           Control.Carrier.State.Strict
 import           Control.Monad (replicateM)
 import           Data.Char
 import           Data.List (intercalate)
-import           GHC.Generics (Generic1)
 import           Hedgehog
 import qualified Hedgehog.Function as Fn
 import qualified Hedgehog.Gen as Gen
@@ -114,9 +111,8 @@ example = testGroup "parser"
 
 
 data Symbol m k = Satisfy (Char -> Bool) (Char -> m k)
-  deriving (Functor, Generic1)
+  deriving (Functor)
 
-instance Effect Symbol
 
 satisfy :: Has Symbol sig m => (Char -> Bool) -> m Char
 satisfy p = send (Satisfy p pure)
@@ -139,14 +135,14 @@ parse input = (>>= exhaustive) . runState input . runParseC
 newtype ParseC m a = ParseC { runParseC :: StateC String m a }
   deriving (Alternative, Applicative, Functor, Monad)
 
-instance (Alternative m, Algebra sig m, Effect sig) => Algebra (Symbol :+: sig) (ParseC m) where
-  alg hom = \case
+instance (Alternative m, Algebra sig m) => Algebra (Symbol :+: sig) (ParseC m) where
+  alg hdl sig ctx = case sig of
     L (Satisfy p k) -> do
       input <- ParseC get
       case input of
-        c:cs | p c -> ParseC (put cs) *> hom (k c)
+        c:cs | p c -> ParseC (put cs) *> hdl (k c <$ ctx)
         _          -> empty
-    R other         -> ParseC (alg (runParseC . hom) (R other))
+    R other         -> ParseC (alg (runParseC . hdl) (R other) ctx)
   {-# INLINE alg #-}
 
 

examples/ReinterpretLog.hs

@@ -11,7 +11,6 @@
 
 
 {-# LANGUAGE DeriveFunctor              #-}
-{-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs               #-}
@@ -37,7 +36,6 @@ import Control.Carrier.Writer.Strict
 import Control.Monad.IO.Class (MonadIO(..))
 import Data.Function          ((&))
 import Data.Kind              (Type)
-import GHC.Generics           (Generic1)
 import Prelude                hiding (log)
 import Test.Tasty
 import Test.Tasty.HUnit
@@ -104,9 +102,8 @@ runApplication =
 -- Log an 'a', then continue with 'k'.
 data Log (a :: Type) (m :: Type -> Type) (k :: Type)
   = Log a (m k)
-  deriving (Functor, Generic1)
+  deriving (Functor)
 
-instance Effect (Log a)
 
 -- Log an 'a'.
 log :: Has (Log a) sig m
@@ -134,14 +131,14 @@ instance
      -- ... the 'LogStdoutC m' monad can interpret 'Log String :+: sig' effects
   => Algebra (Log String :+: sig) (LogStdoutC m) where
 
-  alg hom = \case
+  alg hdl sig ctx = case sig of
     L (Log message k) ->
       LogStdoutC $ do
         liftIO (putStrLn message)
-        runLogStdout (hom k)
+        runLogStdout (hdl (k <$ ctx))
 
     R other ->
-      LogStdoutC (alg (runLogStdout . hom) other)
+      LogStdoutC (alg (runLogStdout . hdl) other ctx)
 
 -- The 'LogStdoutC' runner.
 runLogStdout ::
@@ -165,15 +162,15 @@ instance
      -- effects
   => Algebra (Log s :+: sig) (ReinterpretLogC s t m) where
 
-  alg hom = \case
+  alg hdl sig ctx = case sig of
     L (Log s k) ->
       ReinterpretLogC $ do
         f <- ask @(s -> t)
         log (f s)
-        unReinterpretLogC (hom k)
+        unReinterpretLogC (hdl (k <$ ctx))
 
     R other ->
-      ReinterpretLogC (alg (unReinterpretLogC . hom) (R other))
+      ReinterpretLogC (alg (unReinterpretLogC . hdl) (R other) ctx)
 
 -- The 'ReinterpretLogC' runner.
 reinterpretLog ::
@@ -193,21 +190,19 @@ newtype CollectLogMessagesC s m a
 
 instance
      -- So long as the 'm' monad can interpret the 'sig' effects...
-     ( Algebra sig m
-     , Effect sig
-     )
+     Algebra sig m
      -- ...the 'CollectLogMessagesC s m' monad can interpret 'Log s :+: sig'
      -- effects
   => Algebra (Log s :+: sig) (CollectLogMessagesC s m) where
 
-  alg hom = \case
+  alg hdl sig ctx = case sig of
     L (Log s k) ->
       CollectLogMessagesC $ do
         tell [s]
-        unCollectLogMessagesC (hom k)
+        unCollectLogMessagesC (hdl (k <$ ctx))
 
     R other ->
-      CollectLogMessagesC (alg (unCollectLogMessagesC . hom) (R other))
+      CollectLogMessagesC (alg (unCollectLogMessagesC . hdl) (R other) ctx)
 
 -- The 'CollectLogMessagesC' runner.
 collectLogMessages ::