Derivable Algebra

ChangeLog.md

@@ -1,3 +1,16 @@
+# 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 the signatures of `runInterpret` and `runInterpretState` analogously. ([#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))
+
+
 # v1.0.2.0
 
 - Adds a `state` operation for the `State` effect. ([#353](https://github.com/fused-effects/fused-effects/pull/353))

README.md

@@ -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 implementations of `HFunctor` and `Effect`.
+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 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.
 

benchmark/Bench.hs

@@ -40,14 +40,14 @@ main = defaultMain
   ,
     bgroup "InterpretC vs InterpretStateC vs StateC"
     [ bgroup "InterpretC"
-      [ bench "100"   $ whnf (\n -> run $ evalState @(Sum Int) 0 $ runInterpret (\case { Get k -> get @(Sum Int) >>= k ; Put s k -> put s >> k }) $ modLoop n) 100
-      , bench "1000"  $ whnf (\n -> run $ evalState @(Sum Int) 0 $ runInterpret (\case { Get k -> get @(Sum Int) >>= k ; Put s k -> put s >> k }) $ modLoop n) 1000
-      , bench "10000" $ whnf (\n -> run $ evalState @(Sum Int) 0 $ runInterpret (\case { Get k -> get @(Sum Int) >>= k ; Put s k -> put s >> k }) $ modLoop n) 10000
+      [ 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
       ]
     , bgroup "InterpretStateC"
-      [ bench "100"   $ whnf (\n -> run $ runInterpretState (\ s -> \case { Get k -> runState @(Sum Int) s (k s) ; Put s k -> runState s k }) 0 $ modLoop n) 100
-      , bench "1000"  $ whnf (\n -> run $ runInterpretState (\ s -> \case { Get k -> runState @(Sum Int) s (k s) ; Put s k -> runState s k }) 0 $ modLoop n) 1000
-      , bench "10000" $ whnf (\n -> run $ runInterpretState (\ s -> \case { Get k -> runState @(Sum Int) s (k s) ; Put s k -> runState s k }) 0 $ modLoop n) 10000
+      [ 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
       ]
     , bgroup "StateC"
       [ bench "100"   $ whnf (run . evalState @(Sum Int) 0 . modLoop) 100

docs/defining_effects.md

@@ -25,9 +25,9 @@ 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 two other instances: `HFunctor` and `Effect`. `HFunctor`, named for “higher-order functor,” has one operation, `hmap`, which applies a function to any embedded computations inside an 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.
+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 instances both of `HFunctor` and `Effect` by first deriving a `Generic1` instance (using `-XDeriveGeneric`):
+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)
@@ -38,11 +38,10 @@ data Teletype m k
   deriving (Functor, Generic1)
 ```
 
-and then defining `HFunctor` & `Effect`, leaving their methods to use the default definitions:
+and then defining `Effect`, leaving it to use the default definition of the `thread` method:
 
 ```haskell
-instance HFunctor Teletype
-instance Effect   Teletype
+instance Effect Teletype
 ```
 
 Now that we have our effect datatype, we can give definitions for `read` and `write`:
@@ -67,14 +66,15 @@ Following from the above section, we can define a carrier for the `Teletype` eff
 newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }
 
 instance (Algebra sig m, MonadIO m) => Algebra (Teletype :+: sig) (TeletypeIOC m) where
-  alg (L (Read    k)) = TeletypeIOC (liftIO getLine      >>= runTeletypeIOC . k)
-  alg (L (Write s k)) = TeletypeIOC (liftIO (putStrLn s) >>  runTeletypeIOC   k)
-  alg (R other)       = TeletypeIOC (alg (handleCoercible other))
+  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)
 ```
 
 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.
 
-In this case, since the `Teletype` carrier is just a thin wrapper around the underlying computation, we can use `handleCoercible` to handle any embedded `TeletypeIOC` carriers by simply mapping `coerce` over them.
+In this case, since the `Teletype` carrier is just a thin wrapper around the underlying computation, we pass `alg` a function to unwrap any embedded `TeletypeIOC` values by simply composing `runTeletypeIOC` onto `hom`.
 
 That leaves `Teletype` effects themselves, which are handled with one case per constructor. Since we’re assuming the existence of a `MonadIO` instance for the underlying computation, we can use `liftIO` to inject the `getLine` and `putStrLn` actions into it, and then proceed with the continuations, unwrapping them in the process.
 
@@ -96,7 +96,8 @@ This allows us to use `liftIO` directly on the carrier itself, instead of only i
 
 ```haskell
 instance (MonadIO m, Algebra sig m) => Algebra (Teletype :+: sig) (TeletypeIOC m) where
-  alg (L (Read    k)) = liftIO getLine      >>= k
-  alg (L (Write s k)) = liftIO (putStrLn s) >>  k
-  alg (R other)       = TeletypeIOC (alg (handleCoercible other))
+  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/faqs.md

@@ -38,10 +38,7 @@ There are two approaches: the first is to use the monadic types defined by `tran
 
 ```haskell
 newtype Wrapper s m a = Wrapper { runWrapper :: m a }
-  deriving (Applicative, Functor, Monad)
-
-instance Algebra sig m => Algebra sig (Wrapper s m) where
-  alg = Wrapper . alg . handleCoercible
+  deriving (Algebra sig, Applicative, Functor, Monad)
 
 getState :: Has (State s) sig m => Wrapper s m s
 getState = get
@@ -54,4 +51,3 @@ instance Has (State s) sig m => MTL.MonadState s (Wrapper s m) where
   get = Control.Carrier.State.Strict.get
   put = Control.Carrier.State.Strict.put
 ```
-

docs/reinterpreting_effects.md

@@ -22,7 +22,7 @@ Let's break down some of the properties of the API client that would be desirabl
 ``` haskell
 {-# LANGUAGE ExistentialQuantification, DeriveFunctor,
 DeriveGeneric, FlexibleInstances,
-GeneralizedNewtypeDeriving, OverloadedStrings, MultiParamTypeClasses,
+GeneralizedNewtypeDeriving, OverloadedStrings, LambdaCase, MultiParamTypeClasses,
 RankNTypes, TypeApplications, TypeOperators, UndecidableInstances #-}
 module CatFacts
     ( main
@@ -139,12 +139,13 @@ instance ( Has Http sig m
          , Algebra sig m
          ) =>
          Algebra (CatFactClient :+: sig) (CatFactsApi m) where
-  alg (L (ListFacts numberOfFacts k)) = do
-    resp <- sendRequest (catFactsEndpoint { HTTP.queryString = "?amount=" <> B.pack (show numberOfFacts) })
-    case lookup hContentType (HTTP.responseHeaders resp) of
-      Just "application/json; charset=utf-8" -> decodeOrThrow (HTTP.responseBody resp) >>= k
-      other -> throwError (InvalidContentType (show other))
-  alg (R other) = CatFactsApi (handleCoercible other)
+  alg hom = \case
+    L (ListFacts numberOfFacts k) -> do
+      resp <- sendRequest (catFactsEndpoint { HTTP.queryString = "?amount=" <> B.pack (show numberOfFacts) })
+      case lookup hContentType (HTTP.responseHeaders resp) of
+        Just "application/json; charset=utf-8" -> decodeOrThrow (HTTP.responseBody resp) >>= k
+        other -> throwError (InvalidContentType (show other))
+    R other -> CatFactsApi (alg (runCatFactsApi . hom) other)
 ```
 
 We implement a `CatFacts` effect handler that depends on _three_ underlying effects:
@@ -168,8 +169,9 @@ newtype HttpClient m a = HttpClient { runHttp :: m a }
     )
 
 instance (MonadIO m, Algebra sig m) => Algebra (Http :+: sig) (HttpClient m) where
-  alg (L (SendRequest req k)) = liftIO (HTTP.getGlobalManager >>= HTTP.httpLbs req) >>= k
-  alg (R other) = HttpClient (handleCoercible other)
+  alg hom = \case
+    L (SendRequest req k) -> liftIO (HTTP.getGlobalManager >>= HTTP.httpLbs req) >>= k
+    R other -> HttpClient (alg (runHttp . hom) other)
 ```
 
 Note for the above code snippets how the `CatFactsApi` carrier delegates fetching JSON to any other effect that supports retrieving JSON given an HTTP request specification.
@@ -233,8 +235,9 @@ runMockHttp :: (HTTP.Request -> IO (HTTP.Response L.ByteString)) -> MockHttpC m
 runMockHttp responder m = runReader responder (runMockHttpClient m)
 
 instance (MonadIO m, Algebra sig m) => Algebra (Http :+: sig) (MockHttpClient m) where
-  alg (L (SendRequest req k)) = MockHttpClient ask >>= \responder -> liftIO (responder req) >>= k
-  alg (R other) = MockHttpClient (handleCoercible other)
+  alg hom = \case
+    L (SendRequest req k) -> MockHttpClient ask >>= \responder -> liftIO (responder req) >>= k
+    R other -> MockHttpClient (alg (runMockHttpClient . hom) other)
 
 faultyNetwork :: HTTP.Request -> IO (HTTP.Response L.ByteString)
 faultyNetwork req = throwIO (HTTP.HttpExceptionRequest req HTTP.ConnectionTimeout)

examples/Inference.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeApplications, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-}
 module Inference
 ( example
 ) where
@@ -46,5 +46,4 @@ newtype HasEnv env m a = HasEnv { runHasEnv :: m a }
   deriving (Applicative, Functor, Monad)
 
 -- | The 'Carrier' instance for 'HasEnv' simply delegates all effects to the underlying carrier.
-instance Algebra sig m => Algebra sig (HasEnv env m) where
-  alg = HasEnv . alg . handleCoercible
+deriving instance Algebra sig m => Algebra sig (HasEnv env m)

examples/Parser.hs

@@ -1,22 +1,30 @@
-{-# LANGUAGE DeriveGeneric, DeriveTraversable, ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Parser
 ( example
 ) where
 
-import Control.Algebra
-import Control.Carrier.Cut.Church
-import Control.Carrier.NonDet.Church
-import Control.Carrier.State.Strict
-import Control.Monad (replicateM)
-import Data.Char
-import Data.List (intercalate)
-import GHC.Generics (Generic1)
-import Hedgehog
+import           Control.Algebra
+import           Control.Carrier.Cut.Church
+import           Control.Carrier.NonDet.Church
+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
 import qualified Hedgehog.Range as Range
-import Test.Tasty
-import Test.Tasty.Hedgehog
+import           Test.Tasty
+import           Test.Tasty.Hedgehog
 
 example :: TestTree
 example = testGroup "parser"
@@ -36,23 +44,22 @@ example = testGroup "parser"
     [ testProperty "matches with a predicate" . property $ do
       c <- forAll Gen.alphaNum
       f <- (. ord) <$> Fn.forAllFn predicate
-      run (runNonDetA (parse [c] (satisfy f))) === if f c then [c] else []
+      run (runNonDetA (parse [c] (satisfy f))) === [c | f c]
 
     , testProperty "fails at end of input" . property $ do
       f <- (. ord) <$> Fn.forAllFn predicate
       run (runNonDetA (parse "" (satisfy f))) === []
 
     , testProperty "fails if input remains" . property $ do
-      c1 <- forAll Gen.alphaNum
-      c2 <- forAll Gen.alphaNum
+      (c1, c2) <- forAll ((,) <$> Gen.alphaNum <*> Gen.alphaNum)
       f <- (. ord) <$> Fn.forAllFn predicate
       run (runNonDetA (parse [c1, c2] (satisfy f))) === []
 
     , testProperty "consumes input" . property $ do
       c1 <- forAll Gen.alphaNum
       c2 <- forAll Gen.alphaNum
       f <- (. ord) <$> Fn.forAllFn predicate
-      run (runNonDetA (parse [c1, c2] ((,) <$> satisfy f <*> satisfy f))) === if f c1 && f c2 then [(c1, c2)] else []
+      run (runNonDetA (parse [c1, c2] ((,) <$> satisfy f <*> satisfy f))) === [(c1, c2) | f c1, f c2]
     ]
 
   , testGroup "factor"
@@ -93,24 +100,23 @@ example = testGroup "parser"
       run (runCutA (parse (intercalate "+" (intercalate "*" . map (show . abs) . (1:) <$> [0]:as)) expr)) === [sum (map (product . map abs) as)]
     ]
   ]
+  where
+  arbNested :: Gen a -> Range.Size -> Gen [[a]]
+  arbNested _ 0 = pure []
+  arbNested g n = do
+    m <- Gen.integral (Range.linear 0 10)
+    let n' = n `div` (m + 1)
+    replicateM (Range.unSize m) (Gen.list (Range.singleton (Range.unSize n')) g)
 
-    where arbNested :: Gen a -> Range.Size -> Gen [[a]]
-          arbNested _ 0 = pure []
-          arbNested g n = do
-            m <- Gen.integral (Range.linear 0 10)
-            let n' = n `div` (m + 1)
-            replicateM (Range.unSize m) (Gen.list (Range.singleton (Range.unSize n')) g)
-
-          predicate = Fn.fn Gen.bool
-          genFactor = Gen.integral (Range.linear 0 100)
-          genFactors = Gen.list (Range.linear 0 10) genFactor
+  predicate = Fn.fn Gen.bool
+  genFactor = Gen.integral (Range.linear 0 100)
+  genFactors = Gen.list (Range.linear 0 10) genFactor
 
 
 data Symbol m k = Satisfy (Char -> Bool) (Char -> m k)
   deriving (Functor, Generic1)
 
-instance HFunctor Symbol
-instance Effect   Symbol
+instance Effect Symbol
 
 satisfy :: Has Symbol sig m => (Char -> Bool) -> m Char
 satisfy p = send (Satisfy p pure)
@@ -134,12 +140,13 @@ 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 (L (Satisfy p k)) = do
-    input <- ParseC get
-    case input of
-      c:cs | p c -> ParseC (put cs) *> k c
-      _          -> empty
-  alg (R other)         = ParseC (alg (R (handleCoercible other)))
+  alg hom = \case
+    L (Satisfy p k) -> do
+      input <- ParseC get
+      case input of
+        c:cs | p c -> ParseC (put cs) *> hom (k c)
+        _          -> empty
+    R other         -> ParseC (alg (runParseC . hom) (R other))
   {-# INLINE alg #-}