Building a toy effect system with the free monad. And then doing the same thing but with the freer monad, which provides some advantages when writing effect data types.

effects-with-free.hs

#!/usr/bin/env nix-shell
#!nix-shell -p "haskellPackages.ghcWithPackages (p: with p; [])"
#!nix-shell -i "ghci"

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wcompat #-}
{-# OPTIONS_GHC -Werror=incomplete-record-updates #-}
{-# OPTIONS_GHC -Werror=incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Werror=missing-fields #-}
{-# OPTIONS_GHC -Werror=partial-fields #-}
{-# OPTIONS_GHC -Widentities #-}
{-# OPTIONS_GHC -Wmissing-home-modules #-}
{-# OPTIONS_GHC -Wredundant-constraints #-}
{-# OPTIONS_GHC -fshow-warning-groups #-}

module Main where

import Data.Function ((&))
import Data.Kind (Constraint, Type)


--------------------------------------------------------------------------------
-- Start with the `Free` monad
--------------------------------------------------------------------------------


data Free f a
  = Pure a
  | Free (f (Free f a))


instance Functor f => Functor (Free f) where
  fmap :: (a -> b) -> Free f a -> Free f b
  fmap f (Pure x) = Pure (f x)
  fmap f (Free x) = Free (fmap (fmap f) x)


instance Functor f => Applicative (Free f) where
  pure :: a -> Free f a
  pure x = Pure x

  (<*>) :: Free f (a -> b) -> Free f a -> Free f b
  (<*>) (Pure f) x = fmap f x
  (<*>) (Free f) x = Free (fmap (<*> x) f)


instance Functor f => Monad (Free f) where
  (>>=) :: Free f a -> (a -> Free f b) -> Free f b
  (>>=) (Pure x) f = f x
  (>>=) (Free x) f = Free (fmap (>>= f) x)


liftFree :: Functor f => f a -> Free f a
liftFree x = Free (fmap Pure x)


hoistFree
  :: Functor f
  => Functor g
  => (forall x. f x -> g x)
  -> Free f a
  -> Free g a
hoistFree f = \case
  Pure x -> pure x
  Free x -> Free (f (fmap (hoistFree f) x))


foldFree :: (Functor f, Monad m) => (forall x. f x -> m x) -> Free f a -> m a
foldFree f = \case
  Pure x -> pure x
  Free x -> f x >>= foldFree f


--------------------------------------------------------------------------------
-- First version of the Teletype effect, and a handler into IO
--------------------------------------------------------------------------------


data Teletype k
  = ReadLine (String -> k)
  | WriteLine String k
  deriving Functor


readLine :: Free Teletype String
readLine = liftFree $ ReadLine id


writeLine :: String -> Free Teletype ()
writeLine string = liftFree $ WriteLine string ()


teletypeToIO :: Teletype a -> IO a
teletypeToIO = \case
  ReadLine k -> do
    string <- getLine
    pure $ k string

  WriteLine string k -> do
    putStrLn string
    pure k


--------------------------------------------------------------------------------
-- First version of the Reader effect, and a handler into some monad
--------------------------------------------------------------------------------


data Reader env k
  = Ask (env -> k)
  deriving Functor


ask :: Free (Reader env) env
ask = liftFree $ Ask id


readerToM :: Monad m => env -> Reader env a -> m a
readerToM env = \case
  Ask k -> pure $ k env


--------------------------------------------------------------------------------
-- We can now write programs and interpret them how we like later! But we can't
-- combine multiple effects yet...
--------------------------------------------------------------------------------


program1Teletype :: Free Teletype ()
program1Teletype = do
  writeLine "Enter username:"
  name <- readLine

  if name == "Evan" then
    writeLine "Access granted"
  else
    writeLine "Access denied"


program1Reader :: Free (Reader String) String
program1Reader = do
  name <- ask
  pure ("Hello, " <> name <> "!")


main1 :: IO ()
main1 = do
  foldFree teletypeToIO program1Teletype
  putStrLn =<< foldFree (readerToM "Evan") program1Reader


--------------------------------------------------------------------------------
-- Let's combine two effects using the `Sum` functor. We need to define new
-- constructor functions so we can wrap things up in the correct branch of the
-- `Sum`.
--------------------------------------------------------------------------------


-- Defined in Data.Functor.Sum
data Sum f g a
  = InL (f a)
  | InR (g a)
  deriving Functor


readLineSum :: Functor g => Free (Sum Teletype g) String
readLineSum = liftFree $ InL $ ReadLine id


writeLineSum :: Functor g => String -> Free (Sum Teletype g) ()
writeLineSum string = liftFree $ InL $ WriteLine string ()


askSum :: Functor f => Free (Sum f (Reader env)) env
askSum = liftFree $ InR $ Ask id


runSumM
  :: (forall x. f x -> m x)
  -> (forall x. g x -> m x)
  -> Sum f g a
  -> m a
runSumM runF runG = \case
  InL f -> runF f
  InR g -> runG g


program2 :: Free (Sum Teletype (Reader String)) ()
program2 = do
  adminName <- askSum

  writeLineSum "Enter username:"
  name <- readLineSum

  if name == adminName then
    writeLineSum "Access granted"
  else
    writeLineSum "Access denied"


main2 :: IO ()
main2 = foldFree (runSumM teletypeToIO (readerToM "Evan")) program2


--------------------------------------------------------------------------------
-- We could continue nesting `Sum`s, or define our own sum type with many cases
-- to combine an arbitrary number of effects. But that would be really tedious,
-- and it's better if we don't have to worry about which side of the `Sum` the
-- effect belongs on.
--
-- If we use an open union type, we can combine as many effects as we want,
-- without nesting!
--------------------------------------------------------------------------------


type Effect = Type -> Type


data Union (r :: [Effect]) a where
  This :: Functor e => e a -> Union (e ': r) a
  Next :: Union r a -> Union (any ': r) a


instance Functor (Union r) where
  fmap :: (a -> b) -> Union r a -> Union r b
  fmap f = \case
    This e -> This $ fmap f e
    Next u -> Next $ fmap f u


--------------------------------------------------------------------------------
-- But there's a problem: while we can now combine as many effects as we want,
-- we still have to worry about their order! Notice how we have to add the
-- correct number of `Next`s in the following examples to make the types line
-- up:
--------------------------------------------------------------------------------


unionExample1 :: Union '[Teletype] String
unionExample1 = This $ ReadLine id


unionExample2 :: Union '[Reader env, Teletype] String
unionExample2 = Next $ This $ ReadLine id


unionExample3 :: Union '[Reader env1, Reader env2, Reader env3] env3
unionExample3 = Next $ Next $ This $ Ask id


--------------------------------------------------------------------------------
-- We can solve this problem of fixed ordering by creating a more abstract
-- notion of membership, using a constraint called `Member`.
--------------------------------------------------------------------------------


class Member e r where
  -- Insert an effect into the union (without worrying about the order)
  inject :: Functor e => e a -> Union r a
  -- If the union has the effect, then pull it out (without worrying about the
  -- order)
  project :: Union r a -> Maybe (e a)


-- Case where effect is at the head of the list
instance Member e (e ': r) where
  inject :: Functor e => e a -> Union (e ': r) a
  inject = This

  project :: Union (e ': r) a -> Maybe (e a)
  project = \case
    This x -> Just x
    Next _ -> Nothing


-- Case where effect is in the tail of the list
instance {-# OVERLAPPABLE #-} Member e r => Member e (any ': r) where
  inject :: Functor e => e a -> Union (any ': r) a
  inject = Next . inject

  project :: Union (any ': r) a -> Maybe (e a)
  project = \case
    Next u -> project u
    This _ -> Nothing


--------------------------------------------------------------------------------
-- We can also define the handy `Members` (plural) constraint with a type family
--------------------------------------------------------------------------------


type family Members (es :: [Effect]) (r :: [Effect]) :: Constraint where
  -- Base case, when there are no effects left in the list
  Members '[] _ = ()
  -- Pluck the head off of the list and create a `Member` constraint for it,
  -- then recurse to deal with the rest of the list
  Members (e ': es) r = (Member e r, Members es r)


--------------------------------------------------------------------------------
-- Now we can take our old `*Sum` constructor functions and rewrite them in
-- terms of `Union` and `Member`! We can now combine any number of effects, and
-- we don't need to worry about their ordering in `Sum` or `Union`!
--------------------------------------------------------------------------------


readLineUnion :: Member Teletype r => Free (Union r) String
readLineUnion = liftFree $ inject $ ReadLine id


writeLineUnion :: Member Teletype r => String -> Free (Union r) ()
writeLineUnion string = liftFree $ inject $ WriteLine string ()


askUnion :: Member (Reader env) r => Free (Union r) env
askUnion = liftFree $ inject $ Ask id


--------------------------------------------------------------------------------
-- What about interpreting our effects? Previously we used the `runSum`
-- interpreter with `Sum`, so now we need something similar for `Union`.
--------------------------------------------------------------------------------


-- Similar to `project`, but it returns the union with the effect removed from
-- the type-level list if it isn't present.
decompose :: Union (e ': r) a -> Either (Union r a) (e a)
decompose = \case
  This x -> Right x
  Next u -> Left u


interpret
  :: forall e2 e1 r a
   . Functor e2
  => Member e2 r
  -- Our effect handler, e.g. Teletype a -> IO a
  => (forall x. e1 x -> e2 x)
  -- Initial program
  -> Free (Union (e1 ': r)) a
  -- Final program, with effect e1 interpreted in terms of e2 (which remains)
  -> Free (Union r) a
interpret handler = hoistFree \union ->
  case decompose union of
    Left union' -> union'
    Right e1 -> inject (handler e1)


-- Pass handler to `interpret` function to get interpreters


runTeletypeIO
  :: forall r a
   . Member IO r
  => Free (Union (Teletype ': r)) a
  -> Free (Union r) a
runTeletypeIO = interpret \case
  ReadLine k -> do
    string <- getLine
    pure $ k string

  WriteLine string k -> do
    putStrLn string
    pure k


runReader
  :: forall m r env a
   . Monad m
  => Member m r
  => env
  -> Free (Union (Reader env ': r)) a
  -> Free (Union r) a
runReader env = interpret @m \case
  Ask k -> pure $ k env


--------------------------------------------------------------------------------
-- But `interpret` doesn't let us escape the `Free` monad! We need a way to
-- discharge a final effect, in this case the base monad itself.
--------------------------------------------------------------------------------


-- When there's only one thing left in the union, we can extract it without
-- worrying about `Maybe`s. It can only be one thing!
extract :: Union '[e] a -> e a
extract = \case
  This x -> x
  -- It's impossible to construct an empty union, so we can use `EmptyCase` to
  -- exhaustively pattern match on it and prove to GHC we're all good.
  Next u -> case u of


runM :: Monad m => Free (Union '[m]) a -> m a
runM free = foldFree extract free


--------------------------------------------------------------------------------
-- Finally, we can rewrite our old program in terms of our new `Union` and
-- `Member` technology, and run it!
--------------------------------------------------------------------------------


program3 :: Members '[Teletype, Reader String] r => Free (Union r) ()
program3 = do
  adminName <- askUnion
  writeLineUnion "Enter username:"
  name <- readLineUnion
  if name == adminName then
    writeLineUnion "Access granted"
  else
    writeLineUnion "Access denied"


main3 :: IO ()
main3 = do
  program3
    & runReader @IO "Evan"
    & runTeletypeIO
    & runM


main :: IO ()
main = pure ()

effects-with-freer.hs

#!/usr/bin/env nix-shell
#!nix-shell -p "haskellPackages.ghcWithPackages (p: with p; [])"
#!nix-shell -i "ghci"

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wcompat #-}
{-# OPTIONS_GHC -Werror=incomplete-record-updates #-}
{-# OPTIONS_GHC -Werror=incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Werror=missing-fields #-}
{-# OPTIONS_GHC -Werror=partial-fields #-}
{-# OPTIONS_GHC -Widentities #-}
{-# OPTIONS_GHC -Wmissing-home-modules #-}
{-# OPTIONS_GHC -Wredundant-constraints #-}
{-# OPTIONS_GHC -fshow-warning-groups #-}

module Main where

import Data.Function ((&))
import Data.Kind (Constraint, Type)


--------------------------------------------------------------------------------
-- Start with the `Freer` monad
--------------------------------------------------------------------------------


newtype Freer f a = Freer
  { runFreer
      :: forall m
       . Monad m
      => (forall x. f x -> m x) -- Natural transformation
      -> m a
  }


instance Functor (Freer f) where
  fmap :: (a -> b) -> Freer f a -> Freer f b
  fmap f freer = Freer \toM ->
    let
      x = runFreer freer toM
    in
      fmap f x


instance Applicative (Freer f) where
  pure :: a -> Freer f a
  pure x = Freer \_ -> pure x

  (<*>) :: Freer f (a -> b) -> Freer f a -> Freer f b
  (<*>) freerF freerX = Freer \toM ->
    let
      f = runFreer freerF toM
      x = runFreer freerX toM
    in
      f <*> x


instance Monad (Freer f) where
  (>>=) :: Freer f a -> (a -> Freer f b) -> Freer f b
  (>>=) freerX freerK = Freer \toM ->
    let
      m = runFreer freerX toM
      k x = runFreer (freerK x) toM
    in
      m >>= k


liftFreer :: f a -> Freer f a
liftFreer f = Freer \toM -> toM f


hoistFreer :: (forall x. f x -> g x) -> Freer f a -> Freer g a
hoistFreer toG freer = Freer \toM -> runFreer freer (toM . toG)


foldFreer :: Monad m => (forall x. f x -> m x) -> Freer f a -> m a
foldFreer toM freer = runFreer freer toM


--------------------------------------------------------------------------------
-- Let's set up our `Union` and `Member` machinery upfront
--------------------------------------------------------------------------------


type Effect = Type -> Type


data Union (r :: [Effect]) a where
  This :: e a -> Union (e ': r) a
  Next :: Union r a -> Union (any ': r) a


class Member e r where
  inject :: e a -> Union r a
  project :: Union r a -> Maybe (e a)


instance Member e (e ': r) where
  inject :: e a -> Union (e ': r) a
  inject = This

  project :: Union (e ': r) a -> Maybe (e a)
  project = \case
    This x -> Just x
    Next _ -> Nothing


instance {-# OVERLAPPABLE #-} Member e r => Member e (any ': r) where
  inject :: e a -> Union (any ': r) a
  inject = Next . inject

  project :: Union (any ': r) a -> Maybe (e a)
  project = \case
    Next u -> project u
    This _ -> Nothing


type family Members (es :: [Effect]) (r :: [Effect]) :: Constraint where
  Members '[] _ = ()
  Members (e ': es) r = (Member e r, Members es r)


extract :: Union '[e] a -> e a
extract = \case
  This x -> x
  Next u -> case u of


decompose :: Union (e ': r) a -> Either (Union r a) (e a)
decompose = \case
  This x -> Right x
  Next u -> Left u


--------------------------------------------------------------------------------
-- We'll also need an `interpret` function to discharge effects, and a type
-- alias would be nice.
--------------------------------------------------------------------------------


type Eff r a = Freer (Union r) a


interpret
  :: forall e2 e1 r a
   . Member e2 r
  => (forall x. e1 x -> e2 x)
  -> Eff (e1 ': r) a
  -> Eff r a
interpret handler = hoistFreer \union ->
  case decompose union of
    Left u -> u
    Right e -> inject (handler e)


runM :: Monad m => Eff '[m] a -> m a
runM freer = foldFreer extract freer


--------------------------------------------------------------------------------
-- Teletype effect, and a handler into IO
--------------------------------------------------------------------------------


data Teletype a where
  ReadLine :: Teletype String
  WriteLine :: String -> Teletype ()


readLine :: Member Teletype r => Eff r String
readLine = liftFreer $ inject ReadLine


writeLine :: Member Teletype r => String -> Eff r ()
writeLine string = liftFreer $ inject $ WriteLine string


runTeletypeIO
  :: Member IO r
  => Eff (Teletype ': r) a
  -> Eff r a
runTeletypeIO = interpret @IO \case
  ReadLine -> getLine
  WriteLine string -> putStrLn string


--------------------------------------------------------------------------------
-- Reader effect, and a handler into some monad
--------------------------------------------------------------------------------


data Reader env a where
  Ask :: Reader env env


ask :: Member (Reader env) r => Eff r env
ask = liftFreer $ inject Ask


runReader
  :: forall m r env a
   . Monad m
  => Member m r
  => env
  -> Eff (Reader env ': r) a
  -> Eff r a
runReader env = interpret @m \case
  Ask -> pure env


--------------------------------------------------------------------------------
-- Now let's write a program and interpret it
--------------------------------------------------------------------------------


program3 :: Members '[Teletype, Reader String] r => Eff r ()
program3 = do
  adminName <- ask

  writeLine "Enter username:"
  name <- readLine

  if name == adminName then
    writeLine "Access granted"
  else
    writeLine "Access denied"


main3 :: IO ()
main3 = do
  program3
    & runReader @IO "Evan"
    & runTeletypeIO
    & runM


main :: IO ()
main = pure ()