Effect Stacks in the van Laarhoven Free Monad

vfm-03.hs

{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE PolyKinds              #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE TypeOperators          #-}

{- Effects Stack in the van Laarhoven Free Monad

The goal is to explore the idea put out by Russell O'Connor
in the blog post here: http://r6.ca/blog/20140210T181244Z.html
and Russell's follow-up comment here:
https://www.reddit.com/r/haskell/comments/3yksmn/a_modern_architecture_for_fp/cyeebzv

Russell' comment on reddit hint thats, if i understood it correctly,
using lenses, we could have an arbitrary effect stack with a
large product of effects and use lenses to lense in on our effect.

When exploring that idea I found a slightly different version: here
the effect stack is an HList of effects. I then used a trick
I learned from Julian Karni via haskell-servant of using typeclasses
to fetch effects out of this stack based on their tag. However, in this
formulation, we use the type itself as the tag.

The result is an arbitrary effect stack, using typeclasses to pick out
effects and build programs in an arbitrary Free Monad.

We can build our progrmas without assuming an effects stack, and run different
interpreters. Also, because the van Laarhoven is effectively a Reader Monad over
our effect stack, we get a very performant and simple Free Monad with no cost
for larger effect stacks.

The only price we pay is a kitchen-soup of extensions :(

previous effort with tags here: https://gist.github.com/aaronlevin/b9fd6e329fb45549fdff

-}

module Main where

import           Control.Arrow          ((&&&))
import           Control.Monad.Identity (Identity (Identity))

-- some ops

type Response = String
data HttpOps m =
    HttpOps { get :: String -> m Response
            , put :: String -> String -> m Response
            }

data LogLevel = Info | Warning | Error | Debug
data LoggingOps m =
    LoggingOps { logOp :: LogLevel -> String -> m () }

data TeletypeOps m =
    TeletypeOps { getCharacter :: m Char
                , putCharacter :: Char -> m ()
                }

-- HLists for ops

data Ops a (m :: * -> *) where
    EmptyOp :: Ops '[] m
    ConsOp :: x m -> Ops xs m -> Ops (x ': xs) m

class HasOp (ops :: [((* -> *) -> *)]) (op :: ((* -> *) -> *)) where
    getOp :: Ops ops m -> op m

instance {-# OVERLAPPABLE #-}
    HasOp ops op => HasOp (notit ': ops) op where
    getOp (ConsOp _ xs) = getOp xs

instance {-# OVERLAPPABLE #-}
    HasOp (op ': xs) op where
    getOp (ConsOp x _) = x

(.:) :: op m -> Ops ops m -> Ops (op ': ops) m
op .: ops = ConsOp op ops
infixr 5 .:

-- HList version of van Laarhoven free monad

newtype FreeVL ops a =
    FreeVL { runFreeVL :: forall m. Monad m => Ops ops m -> m a }

instance Functor (FreeVL ops) where
    fmap f (FreeVL run) = FreeVL (fmap f . run)

instance Applicative (FreeVL ops) where
    pure a = FreeVL (const (pure a))
    (FreeVL fab) <*> (FreeVL a) =
        FreeVL $ uncurry (<*>) . (fab &&& a)

instance Monad (FreeVL ops) where
    (FreeVL oa) >>= f =
        FreeVL $ \ops -> oa ops >>= \a -> runFreeVL (f a) ops

-- lift operations into the van laarhoven free monad
liftVL :: HasOp ops op
       => (forall m. op m -> m a)
       -> FreeVL ops a
liftVL getter = FreeVL $ \ops -> getter (getOp ops)

-- interpret programs in the van laarhoven free monad
interperetM :: Monad m
            => Ops ops m
            -> FreeVL ops a
            -> m a
interperetM = flip runFreeVL

-- user code
-- some helper combinators

getM :: HasOp ops HttpOps
     => String
     -> FreeVL ops Response
getM s = liftVL (`get` s)

putM :: HasOp ops HttpOps
     => String
     -> String
     -> FreeVL ops Response
putM s1 s2 = liftVL (\http -> put http s1 s2)

logM :: HasOp ops LoggingOps
     => LogLevel
     -> String
     -> FreeVL ops ()
logM l s = liftVL (\logger -> logOp logger l s)

putCharM :: HasOp ops TeletypeOps
         => Char
         -> FreeVL ops ()
putCharM c = liftVL (`putCharacter` c)

-- a program where we don't make assumptions about the effect stack.
program :: ( HasOp ops LoggingOps
           , HasOp ops HttpOps
           )
        => FreeVL ops Int
program = do
    logM Debug "running http request! yay"
    _ <- getM "http://google.com"
    return 10

-- our effects stack
type MyOps = (  HttpOps
             ': LoggingOps
             ': TeletypeOps
             ': '[]
             )

-- same program but with explicit effects stack.
program2 :: FreeVL MyOps Int
program2 = do
    logM Debug "running http request"
    _ <- getM "http://google.com"
    return 10

program3 :: HasOp ops TeletypeOps
         => FreeVL ops ()
program3 = putCharM 'c'

composeProgram :: FreeVL MyOps ()
composeProgram = do
    _ <- program2
    program3

-- a pure interpreter for our program
pureInterpreter :: Ops MyOps Identity
pureInterpreter =
    let http = HttpOps Identity (const . Identity)
        logger  = LoggingOps (const . const $ Identity ())
        tele = TeletypeOps (Identity 'c') (const (Identity ()))
    in http .: logger .: tele .: EmptyOp

-- IO Interpreter for HTTP
httpIO :: HttpOps IO
httpIO = let getIO = const (return "get response")
             putIO = const . const $ return "put response"
         in HttpOps getIO putIO

-- IO Interpreter for logging
loggerIO :: LoggingOps IO
loggerIO = LoggingOps $ \_ s -> putStrLn s

-- IO Interpreter for Teletype
teletypeIO :: TeletypeOps IO
teletypeIO = let getIO = return 'c'
                 putIO = const (return ())
             in TeletypeOps getIO putIO

-- the full interpreter for our effects stack.
ioInterpreter :: Ops MyOps IO
ioInterpreter = httpIO .: loggerIO .: teletypeIO .: EmptyOp

main :: IO ()
main = do
    putStrLn "running program with interpreter in IO"
    num <- interperetM ioInterpreter program2
    putStrLn "running prorgramM2 with interpreter in IO"
    num2 <- interperetM ioInterpreter program
    print num
    print num2