Skip to content

Instantly share code, notes, and snippets.

@siraben
Created February 27, 2022 09:28
Show Gist options
  • Save siraben/602014ff9702e318937ee3faaade0d9d to your computer and use it in GitHub Desktop.
Save siraben/602014ff9702e318937ee3faaade0d9d to your computer and use it in GitHub Desktop.
Free monads example accompanying https://siraben.dev/2020/02/20/free-monads.html
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment