Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Tentative composition of Free DSLs and Cofree Interpreters
{-# 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...
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment