EDSL on free, freer, tagless final

1 - free.hs

{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}

module BL1 where

import           Control.Monad (when)
import           Data.Foldable (for_)
import           Data.Monoid   ((<>))
import           Data.String   (IsString)


-- Free

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

instance Functor f => Functor (Free f) where
  fmap f (Pure a) = Pure $ f a
  fmap f (Free m) = Free $ fmap (fmap f) m

instance Functor f => Applicative (Free f) where
  pure = Pure
  Pure f  <*> Pure x  = Pure $ f x
  Pure f  <*> Free mx = Free $ fmap (fmap f) mx
  Free mf <*> mx      = Free $ fmap (<*> mx) mf

instance Functor f => Monad (Free f) where
  Pure x >>= f = f x
  Free m >>= f = Free $ fmap (>>= f) m

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

foldFree :: Monad m => (forall x. f x -> m x) -> Free f a -> m a
foldFree run = go where
  go (Pure x) = pure x
  go (Free m) = run m >>= go


-- Example [Boilerplate]

newtype UserId  = UserId  Int    deriving (Num, Eq)
newtype Balance = Balance Int    deriving (Num, Eq, Ord)
newtype Email   = Email   String deriving (IsString)

type App = Free AppF

data AppF next
  = GetUsersIds ([UserId] -> next)
  | GetBalance UserId (Balance -> next)
  | SendEmail UserId Email next
  deriving (Functor)

-- Can be genereated by makeFree from free package

getUsersIds :: App [UserId]
getUsersIds = liftF $ GetUsersIds id

getBalance :: UserId -> App Balance
getBalance userId = liftF $ GetBalance userId id

sendEmail :: UserId -> Email -> App ()
sendEmail userId email = liftF $ SendEmail userId email ()

runApp :: App a -> IO a
runApp = foldFree $ \case
  GetUsersIds  callback -> pure $ callback [1, 2, 3]
  GetBalance 1 callback -> pure $ callback 100
  GetBalance _ callback -> pure $ callback 0
  SendEmail (UserId userId) (Email email) next -> do
    putStrLn $ "##########################"
    putStrLn $ "## Message for " <> show userId
    putStrLn $ email
    pure next

main :: IO ()
main = runApp notifyUsersOnEmptyBalance


-- Example

notifyUsersOnEmptyBalance :: App ()
notifyUsersOnEmptyBalance = do
  usersIds <- getUsersIds
  for_ usersIds $ \userId -> do
    balance <- getBalance userId
    when (balance <= 0) $ do
      sendEmail userId "Empty balance"

2 - freer.hs

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}

module BL2 where

import           Control.Monad (when)
import           Data.Foldable (for_)
import           Data.Monoid   ((<>))
import           Data.String   (IsString)


-- Prelude

(...) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
(...) = (.) . (.)


-- Freer

data Freer f a where
  Pure :: a -> Freer f a
  Free :: f x -> (x -> Freer f a) -> Freer f a

instance Functor (Freer f) where
  fmap f (Pure x)    = Pure (f x)
  fmap f (Free v cb) = Free v (fmap f . cb)

instance Applicative (Freer f) where
  pure = Pure
  Pure f    <*> Pure x      = Pure (f x)
  Pure f    <*> (Free v cb) = Free v (fmap f . cb)
  Free v cb <*> mx          = Free v ((<*> mx) . cb)

instance Monad (Freer f) where
  Pure x    >>= f = f x
  Free v cb >>= f = Free v ((>>= f) . cb)

liftF :: f a -> Freer f a
liftF x = Free x Pure

foldFreer :: Monad m => (forall x. f x -> m x) -> Freer f a -> m a
foldFreer run = go where
  go (Pure x)    = pure x
  go (Free v cb) = fmap cb (run v) >>= go


-- Example [Boilerplate]

newtype UserId  = UserId  Int    deriving (Num, Eq)
newtype Balance = Balance Int    deriving (Num, Eq, Ord)
newtype Email   = Email   String deriving (IsString)

type App = Freer AppF

data AppF a where
  GetUsersIds :: AppF [UserId]
  GetBalance  :: UserId -> AppF Balance
  SendEmail   :: UserId -> Email -> AppF ()

getUsersIds :: App [UserId]
getUsersIds = liftF $ GetUsersIds

getBalance :: UserId -> App Balance
getBalance = liftF . GetBalance

sendEmail :: UserId -> Email -> App ()
sendEmail = liftF ... SendEmail

runApp :: App a -> IO a
runApp = foldFreer $ \case
  GetUsersIds  -> pure [1, 2, 3]
  GetBalance 1 -> pure 100
  GetBalance _ -> pure 0
  SendEmail (UserId userId) (Email email) -> do
    putStrLn $ "##########################"
    putStrLn $ "## Message for " <> show userId
    putStrLn $ email

main :: IO ()
main = runApp notifyUsersOnEmptyBalance


-- Example

notifyUsersOnEmptyBalance :: App ()
notifyUsersOnEmptyBalance = do
  usersIds <- getUsersIds
  for_ usersIds $ \userId -> do
    balance <- getBalance userId
    when (balance <= 0) $ do
      sendEmail userId "Empty balance"

3 - tagless-final.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}

module BL3 where

import           Control.Monad (when)
import           Data.Foldable (for_)
import           Data.Monoid   ((<>))
import           Data.String   (IsString)


-- Example [Boilerplate]

newtype UserId  = UserId  Int    deriving (Num, Eq)
newtype Balance = Balance Int    deriving (Num, Eq, Ord)
newtype Email   = Email   String deriving (IsString)

class Monad m => MonadApp m where
  getUsersIds :: m [UserId]
  getBalance  :: UserId -> m Balance
  sendEmail   :: UserId -> Email -> m ()

instance MonadApp IO where
  getUsersIds  = pure [1, 2, 3]
  getBalance 1 = pure 100
  getBalance _ = pure 0
  sendEmail (UserId userId) (Email email) = do
    putStrLn $ "##########################"
    putStrLn $ "## Message for " <> show userId
    putStrLn $ email

main :: IO ()
main = notifyUsersOnEmptyBalance


-- Example

notifyUsersOnEmptyBalance :: MonadApp m => m ()
notifyUsersOnEmptyBalance = do
  usersIds <- getUsersIds
  for_ usersIds $ \userId -> do
    balance <- getBalance userId
    when (balance <= 0) $ do
      sendEmail userId "Empty balance"

4 - tagless-final-record.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}

module BL4 where

import           Control.Monad (when)
import           Data.Foldable (for_)
import           Data.Monoid   ((<>))
import           Data.String   (IsString)


-- Example [Boilerplate]

newtype UserId  = UserId  Int    deriving (Num, Eq)
newtype Balance = Balance Int    deriving (Num, Eq, Ord)
newtype Email   = Email   String deriving (IsString)

data App m = App
  { getUsersIds :: m [UserId]
  , getBalance  :: UserId -> m Balance
  , sendEmail   :: UserId -> Email -> m ()
  }

appIO :: App IO
appIO = App{..} where
  getUsersIds  = pure [1, 2, 3]
  getBalance 1 = pure 100
  getBalance _ = pure 0
  sendEmail (UserId userId) (Email email) = do
    putStrLn $ "##########################"
    putStrLn $ "## Message for " <> show userId
    putStrLn $ email

main :: IO ()
main = notifyUsersOnEmptyBalance appIO


-- Example

notifyUsersOnEmptyBalance :: Monad m => App m -> m ()
notifyUsersOnEmptyBalance App{..} = do
  usersIds <- getUsersIds
  for_ usersIds $ \userId -> do
    balance <- getBalance userId
    when (balance <= 0) $ do
      sendEmail userId "Empty balance"