Tentative composition of Free DSLs and Cofree Interpreters

gistfile1.hs

{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverlappingInstances  #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeOperators         #-}
-- |Tentative at composing @Free@  and @Cofree@ things to separate DSL fragments and interpreters
-- the goal is to be able to define separately DSL fragments, and their interpretation(s), and 
-- combine them at will.
-- This has been triggered by http://dlaing.org/cofun/posts/free_and_cofree.html
module Capital.Client.Free
       -- (Commands(..), End
       -- ,login, logout, findUserByEmail, failure, end)
       where

import           Control.Applicative
import           Control.Comonad.Cofree
import           Control.Monad
import           Control.Monad.Free
import           Control.Monad.Identity
import           Control.Monad.Trans    (MonadIO, liftIO)

-- Coproduct stuff from https://hackage.haskell.org/package/comonad-transformers-2.0.3/docs/src/Data-Functor-Coproduct.html#Coproduct
newtype Coproduct f g a = Coproduct { getCoproduct :: Either (f a) (g a) }

left :: f a -> Coproduct f g a
left = Coproduct . Left

right :: g a -> Coproduct f g a
right = Coproduct . Right

coproduct :: (f a -> b) -> (g a -> b) -> Coproduct f g a -> b
coproduct f g = either f g . getCoproduct

instance (Functor f, Functor g) => Functor (Coproduct f g) where
  fmap f = Coproduct . coproduct (Left . fmap f) (Right . fmap f)

newtype Product f g a = Product { getProduct :: (f a, g a) }

p1 :: Product f g a -> f a
p1 = fst . getProduct

p2 :: Product f g a -> g a
p2 = snd . getProduct

instance (Functor f, Functor g) => Functor (Product f g) where
  fmap f (Product (a,b)) = Product (fmap f a, fmap f b)

infixr 6 |*|

-- | Given...
(|*|) :: (Functor f, Functor g)
         => (forall a. f a -> g a)
         -- ^A natural transformation from f to g
         -> (forall b. h b -> g b)
         -- ^A natural transformation from h to g
         -> Coproduct f h c
         -- ^A coproduct instance for f and h
         -> g c
         -- ^... results in an instance of g
fg |*| hg = \x -> case getCoproduct x of
  Left f -> fg f
  Right h -> hg h

data Logging a = Logging String a  deriving (Functor)

data Persist a = Store String a deriving Functor

class (Functor f, Functor g) => f :<: g where
  inject :: f a -> g a

instance (Functor f, Functor g) => f :<: Coproduct f g where
  inject = left

instance (Functor f, Functor g, Functor h, g :<: h) => g :<: Coproduct f h where
  inject = right . inject

instance (Functor f) => f :<: f where
  inject = id

inFree :: (Functor f, f :<: g) => f a -> Free g a
inFree = hoistFree inject . liftF

logI :: (Logging :<: f) => String -> Free f ()
logI msg = inFree (Logging msg ())

store :: (Persist :<: f) => String -> Free f ()
store s = inFree (Store s ())

data CoLogging a = CoLogging { cLog :: String -> a }  deriving Functor

type CoLoggingF a = Cofree CoLogging a

interpretM :: (Functor f) => (a -> f a) -> a -> Cofree f a
interpretM = coiter

interpretCommands :: (MonadIO m) => CoLoggingF (m ())
interpretCommands = interpretM (CoLogging . coLog) (return ())

coLog :: (MonadIO m) => m () -> String -> m ()
coLog a s = a >> (liftIO $ print s)

data CoPersist a = CoPersist { cStore :: String -> a }  deriving Functor

type CoPersistF a = Cofree CoPersist a

interpretStore :: (MonadIO m) => CoPersistF (m ())
interpretStore = interpretM (CoPersist . coStore) (return ())

coStore :: (MonadIO m) => m () -> String -> m ()
coStore a s = a >> (liftIO . print . ("storing " ++)) s

class (Functor f, Functor g) => Pairing f g where
  pair :: (a -> b -> r) -> f a -> g b -> r

instance Pairing Identity Identity where
  pair f (Identity a) (Identity b) = f a b

instance Pairing ((->) a) ((,) a) where
  pair p f = uncurry (p . f)

instance Pairing ((,) a) ((->) a) where
  pair p f g = pair (flip p) g f

instance Pairing f g => Pairing (Cofree f) (Free g) where
  pair p (a :< _ ) (Pure x)  = p a x
  pair p (_ :< fs) (Free gs) = pair (pair p) fs gs

instance Pairing CoLogging Logging where
  pair f (CoLogging l) (Logging m k) = f (l m) k

instance Pairing CoPersist Persist where
  pair f (CoPersist s) (Store v k) = f (s v) k

instance (Pairing g f, Pairing k h) => Pairing (Product g k) (Coproduct f h) where
  pair p (Product (g,_))  (Coproduct (Left f)) = pair p g f
  pair p (Product (_,k)) (Coproduct (Right h)) = pair p k h

type Effect = Coproduct Logging Persist

type Interp = Product CoLogging CoPersist

interpretEffect :: Cofree Interp (IO ())
interpretEffect = interpretM f (return ())
  where
     f a = Product (CoLogging $ coLog a, CoPersist $ coStore a)

hoistCofree :: Functor f => (forall x . f x -> g x) -> Cofree f a -> Cofree g a
hoistCofree f (x :< y) = x :< f (hoistCofree f <$> y)

prg'  :: Free Logging ()
prg' = logI "foo"

prg :: Free Effect ()
prg = forever (store "bar" >> logI "foo")


interpretWith :: (Pairing f g) => Cofree f a -> Free g a -> a
interpretWith = pair seq  
-- seq is my tentative to force evaluation of the IO actions while unfolding the interpreter
-- does not work obviously: the whole IO () action is built by traversing the whole Free structure, which does not work 
-- great here because it is infinite...