Tagged Effect Stack in the van Laarhoven Free Monad

vfm.hs

{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE PolyKinds              #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}

{- Tagged 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 "tagged" 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.

The result is an arbitrary effect stack, using tags to fetch our effects,
and then building programs in its free monad (van Laarhoven 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 explicitly passing around tags. (and a kitchen-soup
of extensions)

-}

module Main where

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

-- 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

newtype TaggedOp (tag :: k) op m = TaggedOp { untaggedOp :: op m }

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

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

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

(.:) :: x m -> Ops xs m -> Ops (TaggedOp tag x ': xs) m
o .: ops = ConsOp (TaggedOp o) ops
infixr 4 .:

-- 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 tag op
        => Proxy tag
        -> (forall m. op m -> m a)
        -> FreeVL ops a
liftVL p getter = FreeVL $ \ops -> getter (getOp p 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 tag HttpOps
     => Proxy tag
     -> String
     -> FreeVL ops Response
getM p s = liftVL p (`get` s)

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

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

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

-- our effects stack
type MyOps = (  TaggedOp "http" HttpOps
             ': TaggedOp "log" LoggingOps
             ': TaggedOp "tele" TeletypeOps
             ': '[]
             )

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

-- 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 (Proxy :: Proxy "log") (Proxy :: Proxy "http"))
    print num
    print num2