Created
June 4, 2015 17:31
-
-
Save abailly/84a54ace82a67c3c8aab to your computer and use it in GitHub Desktop.
Tentative composition of Free DSLs and Cofree Interpreters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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