Free monads example accompanying https://siraben.dev/2020/02/20/free-monads.html

free-monads.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE TypeOperators #-}

module ExtALaCarte where

import Control.Applicative
import Data.Function
import Data.Functor
import Data.Functor.Identity
import Prelude hiding (getLine, readFile, writeFile)

-- Extensible Effects from Data Types à la carte
-- http://okmij.org/ftp/Haskell/extensible/ALaCarteEff.hs
infixr 9 :+:

data (f :+: g) r
  = Inl (f r)
  | Inr (g r)
  deriving (Functor)

data Term f a
  = Pure a
  | Impure (f (Term f a))

instance Functor f => Functor (Term f) where
  fmap f (Pure x) = Pure $ f x
  fmap f (Impure t) = Impure $ (f <$>) <$> t

instance Functor f => Applicative (Term f) where
  pure = Pure
  Pure f <*> Pure x = Pure $ f x
  Pure f <*> Impure b = Impure $ (f <$>) <$> b
  Impure fx <*> a = Impure $ (<*> a) <$> fx

instance Functor f => Monad (Term f) where
  return = pure
  Pure x >>= f = f x
  Impure t >>= f = Impure $ (>>= f) <$> t

-- inject a value from the subtype to the supertype
class (Functor sub, Functor sup) => sub :<: sup where
  inj :: sub a -> sup a

-- any type is a subtype of itself
-- (:<:) is reflexive
instance Functor f => f :<: f where
  inj = id

-- any type f is a subtype of a sum of f and any g
instance (Functor f, Functor g) => f :<: (f :+: g) where
  inj = Inl

-- if f, g and h are functors, and f :<: g
-- then for any h, f :<: (h :+: g)
instance (Functor f, Functor g, Functor h, f :<: g) => f :<: (h :+: g) where
  inj = Inr . inj

data Void t
  deriving (Functor)

efRun :: Term Void a -> a
efRun (Pure a) = a

data Incr t
  = Incr Int t
  deriving (Functor)

newtype Recall t = Recall (Int -> t) deriving (Functor)

newtype Mem = Mem Int deriving (Show)

efRunCalc ::
  Functor r =>
  Mem ->
  Term (Incr :+: (Recall :+: r)) a ->
  Term r (a, Mem)
efRunCalc s (Pure x) = return (x, s)
efRunCalc (Mem s) (Impure (Inl (Incr k r))) = efRunCalc (Mem (s + k)) r
efRunCalc (Mem s) (Impure (Inr (Inl (Recall r)))) = efRunCalc (Mem s) (r s)
efRunCalc s (Impure (Inr (Inr t))) = Impure (efRunCalc s <$> t)

inject :: (g :<: f) => g (Term f a) -> Term f a
inject = Impure . inj

incr :: (Incr :<: f) => Int -> Term f ()
incr i = inject (Incr i (Pure ()))

recall :: (Recall :<: f) => Term f Int
recall = inject (Recall Pure)

tick :: (Incr :<: f, Recall :<: f) => Term f Int
tick = do
  y <- recall
  incr 1
  return y

efRunTick = efRun $ efRunCalc (Mem 4) tick

newtype Exc e t = Exc e deriving (Functor)

raise :: (Exc e :<: f) => e -> Term f a
raise e = inject (Exc e)

efRunExc :: Functor r => Term (Exc e :+: r) a -> Term r (Either e a)
efRunExc (Pure x) = return (Right x)
efRunExc (Impure (Inl (Exc e))) = return (Left e)
efRunExc (Impure (Inr t)) = Impure (efRunExc <$> t)

ticke :: (Exc String :<: f, Incr :<: f, Recall :<: f) => Int -> Term f Int
ticke n = do
  y <- recall
  incr 5
  z <- recall
  if z > n
    then raise "too big"
    else return y

efRunExcString ::
  Functor r =>
  Term (Exc String :+: r) a ->
  Term r (Either String a)
efRunExcString = efRunExc

efRuntickSE1 :: (Either String Int, Mem)
efRuntickSE1 =
  ticke 1
    & efRunExcString
    & efRunCalc (Mem 0)
    & efRun

-- Enable the ConstraintKind language extension for this
data Writer s t = Put s t deriving (Functor)

data Reader s t = Get (s -> t) deriving (Functor)

newtype State s = State s deriving (Show, Functor)

type StEff s r = (Reader s :<: r, Writer s :<: r)

type St s r = Writer s :+: Reader s :+: r

put :: (Writer s :<: f) => s -> Term f ()
put s = inject (Put s (Pure ()))

get :: (Reader s :<: f) => Term f s
get = inject (Get Pure)

sumN :: (StEff (Integer, Integer) f) => Term f ()
sumN = do
  (acc, n) <- get
  if n == 0
    then return ()
    else do put (acc + n, n - 1); sumN

efRunSt :: Functor r => State s -> Term (St s r) a -> Term r (a, s)
efRunSt (State s) (Pure x) = return (x, s)
efRunSt (State s) (Impure (Inl (Put k r))) = efRunSt (State k) r
efRunSt (State s) (Impure (Inr (Inl (Get r)))) = efRunSt (State s) (r s)
efRunSt s (Impure (Inr (Inr t))) = Impure (efRunSt s <$> t)

sumNEx :: ((), (Integer, Integer))
sumNEx =
  sumN
    & efRunSt (State (0, 10))
    & efRun