Alternative record-based/final implementation of effects using a free monad

FinalFreeEffects.hs

{-# LANGUAGE QuantifiedConstraints #-}
{-# OPTIONS_GHC -Wall #-}

import Control.Arrow ((>>>))
import Control.Monad

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

deriving instance Functor f => Functor (Free f)
instance Functor f => Applicative (Free f) where
  pure = Pure
  (<*>) = ap
instance Functor f => Monad (Free f) where
  Pure x >>= k = k x
  Free m >>= k = Free (fmap (>>= k) m)

class Contra f where
  contramap :: (a -> b) -> f b -> f a

newtype R f k = R { runR :: forall r. f r k -> r }

instance (forall r. Contra (f r)) => Functor (R f) where
  fmap f (R g) = R (g . contramap f)

data State s r k = State
  { put_ :: s -> k -> r
  , get_ :: (s -> k) -> r
  }

instance Contra (State s r) where
  contramap f (State put get) = State (\s k -> put s (f k)) (\k -> get (f . k))

instance Self (State s) where
  self prj = State
    { put_ = \s k -> put prj s >> k
    , get_ = \k -> get prj >>= k
    }

put :: (forall r. Contra (f r)) => Prj (State s) f -> s -> Free (R f) ()
put prj s = Free $ R $ prj >>> put_ >>> \k -> k s $ Pure ()

get :: (forall r. Contra (f r)) => Prj (State s) f -> Free (R f) s
get prj = Free $ R $ prj >>> get_ >>> \k -> k pure

prog :: Free (R (State Int)) ()
prog = do
  s <- get id
  put id (s + 1)

hState :: s -> Free (R (State s)) a -> (a, s)
hState s (Pure x) = (x, s)
hState s (Free m) = runR m State
  { put_ = \s' k -> hState s' k
  , get_ = \k -> hState s (k s)
  }

data Throw r k = Throw
  { throw_ :: forall a. (a -> k) -> r
  }

-- Project 'f' out of 'g'
type Prj f g = forall r k. g r k -> f r k

class Self f where
  self :: (forall r. Contra (g r)) => Prj f g -> f (Free (R g) x) (Free (R g) x)

instance Self Throw where
  self prj = Throw { throw_ = \k -> throw prj >>= k }

instance Contra (Throw r) where
  contramap f (Throw throw) = Throw (\k -> throw (f . k))

throw :: (forall r. (Contra (f r))) => Prj Throw f -> Free (R f) a
throw prj = Free $ R $ prj >>> \t -> throw_ t Pure

hThrow :: (forall r. Contra (f r), Self f) => Free (R (Throw :* f)) a -> Free (R f) (Maybe a)
hThrow (Pure x) = Pure (Just x)
hThrow (Free m) = runR m $ Prod 
  Throw { throw_ = \k -> Pure Nothing }
  (contramap hThrow (self id))

data (f :* g) r k = Prod { l :: f r k, r :: g r k }

instance (Contra (f r), Contra (g r)) => Contra ((f :* g) r) where
  contramap f (Prod x y) = Prod (contramap f x) (contramap f y)

instance (Self f, Self g) => Self (f :* g) where
  self f = Prod (self (l . f)) (self (r . f))

data End r k = End

hEnd :: Free (R End) a -> a
hEnd (Pure x) = x
hEnd (Free (R m)) = m End