Free Monad vs Direct approach with existential type

example.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes                 #-}
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans

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

instance Functor f => Functor (Free f) where
    fmap f (Pure a) = Pure (f a)
    fmap f (Free m) = Free (fmap (fmap f) m)

instance Functor f => Applicative (Free f) where
    pure  = return
    (<*>) = ap

instance Functor f => Monad (Free f) where
    return = Pure

    Pure a >>= f = f a
    Free m >>= f = Free (fmap (f =<<) m)

data KeyValue a
    = Put String String a
    | Get String (String -> a)
    | Delete String a

instance Functor KeyValue where
    fmap f (Put k v a)  = Put k v (f a)
    fmap f (Get ky k)   = Get ky (f . k)
    fmap f (Delete k a) = Delete k (f a)

type KeyValueStore a = Free KeyValue a

foldFree :: Functor f => (a -> b) -> (f b -> b) -> Free f a -> b
foldFree p _ (Pure a) = p a
foldFree p f (Free m) = f $ fmap (foldFree p f) m

storeGet :: String -> KeyValueStore String
storeGet k = Free $ Get k Pure

storePut :: String -> String -> KeyValueStore ()
storePut k v = Free $ Put k v (Pure ())

storeDelete :: String -> KeyValueStore ()
storeDelete k = Free $ Delete k (Pure ())

runKeyValueStore :: KeyValueStore a -> Maybe a
runKeyValueStore kv = (foldFree pure impure kv) [] where
  pure a _ = Just a

  impure (Get ky k)    xs = lookup ky xs >>= \v -> k v xs
  impure (Put ky v k)  xs = k ((ky,v):xs)
  impure (Delete ky k) xs = k (delete ky xs)


freeTest :: KeyValueStore ()
freeTest = do
    v <- storeGet "key"
    storePut "foo" "bar"
    storeDelete "baz"

--------------------------------------------------------------------------------
-- | Direct approach
--------------------------------------------------------------------------------
newtype KeyValueApi a = KeyValueApi { unKVM :: forall m. KeyValueMonad m => m a }

class (Applicative m, Monad m) => KeyValueMonad m where
    mGet    :: String -> m String
    mPut    :: String -> String -> m ()
    mDelete :: String -> m ()

instance Functor KeyValueApi where
    fmap f m = KeyValueApi $ fmap f (unKVM m)

instance Applicative KeyValueApi where
    pure a = KeyValueApi $ pure a
    f <*> a = KeyValueApi ((unKVM f) <*> (unKVM a))

instance Monad KeyValueApi where
    return a = KeyValueApi $ return a
    m >>= f  = KeyValueApi (unKVM m >>= unKVM . f)

instance KeyValueMonad KeyValueApi where
    mGet    = apiGet
    mPut    = apiPut
    mDelete = apiDelete

runKeyValue :: KeyValueMonad m => KeyValueApi a -> m a
runKeyValue = unKVM

newtype KeyValueImpl a
    = KeyValueImpl (StateT [(String, String)] Maybe a)
    deriving ( Functor
             , Applicative
             , Monad
             , MonadState [(String, String)]
             )

instance KeyValueMonad KeyValueImpl where
    mGet key = do
        xs <- get
        liftMaybe $ lookup key xs

    mPut key v = modify ((key,v):)

    mDelete key = modify (delete key)

liftMaybe :: Maybe a -> KeyValueImpl a
liftMaybe = KeyValueImpl . lift

runKeyValueImpl :: KeyValueApi a -> Maybe a
runKeyValueImpl p =
    let (KeyValueImpl m) = runKeyValue p in evalStateT m []

--------------------------------------------------------------------------------
-- | Api
--------------------------------------------------------------------------------
apiGet :: String -> KeyValueApi String
apiGet k = KeyValueApi $ mGet k

apiPut :: String -> String -> KeyValueApi ()
apiPut k v = KeyValueApi $ mPut k v

apiDelete :: String -> KeyValueApi ()
apiDelete k = KeyValueApi $ mDelete k

apiTest :: KeyValueApi ()
apiTest = do
    v <- apiGet "key"
    apiPut "foo" "bar"
    apiDelete "baz"

--------------------------------------------------------------------------------
-- | Utilities
--------------------------------------------------------------------------------
delete :: Eq k => k -> [(k, v)] -> [(k, v)]
delete x = filter ((/= x) . fst)