Compose Free / Cofree DSL's

bower.json

{
  "name": "purescript-compose-free",
  "ignore": [
    "**/.*",
    "node_modules",
    "bower_components",
    "output"
  ],
  "dependencies": {
    "purescript-prelude": "^3.0.0",
    "purescript-console": "^3.0.0",
    "purescript-free": "^4.0.1",
    "purescript-functors": "^2.1.0"
  },
  "devDependencies": {
    "purescript-psci-support": "^3.0.0"
  }
}

Main.purs

module Main where

import Control.Comonad.Cofree (Cofree, explore, head, mkCofree, tail, unfoldCofree)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Free (Free, liftF)
import Data.Either (Either(..))
import Data.Foldable (fold)
import Data.Functor.Coproduct (Coproduct(..), left, right)
import Data.Functor.Product (Product(..), product)
import Data.Newtype (class Newtype, over)
import Data.Tuple (Tuple(Tuple), uncurry)
import Prelude (class Functor, class Show, Unit, bind, flip, id, show, ($), (*), (+), (<$>), (<>))
import TryPureScript

-- Additive State
newtype StateA = StateA
  { count :: Int }

derive instance newtypeStateA :: Newtype StateA _

instance showStateA :: Show StateA where
  show (StateA { count }) = "StateA { count: " <> show count <> "}"

-- Additive commands
data CommandA a = Add Int a

add :: Int -> Free CommandA (StateA -> StateA)
add x = liftF $ Add x id

derive instance functorCommandA :: Functor CommandA

-- Additive interpreter
data RunCommandA a = RunCommandA
  { add :: Int -> a }

derive instance functorRunCommandA :: Functor RunCommandA

mkInterpA :: StateA -> Cofree RunCommandA StateA
mkInterpA state = unfoldCofree id next state
  where
    add' :: StateA -> Int -> StateA
    add' (StateA st@{ count }) x = StateA (st { count = count + x})

    next :: StateA -> RunCommandA StateA
    next st = RunCommandA
      { add: add' st
      }

pairA :: forall x y. CommandA (x -> y) -> RunCommandA x -> y
pairA (Add x f) (RunCommandA i) = f $ i.add x

runA :: Free CommandA (StateA -> StateA) -> StateA -> StateA
runA cmds state = explore pairA cmds (mkInterpA state)

-- Multiplicative state
newtype StateM = StateM
  { count :: Int }

derive instance newtypeStateM :: Newtype StateM _

instance showStateM :: Show StateM where
  show (StateM { count }) = "StateM { count: " <> show count <> "}"

-- Multiplicative commands
data CommandM a = Multiply Int a

derive instance functorCommandM :: Functor CommandM

multiply :: Int -> Free CommandM (StateM -> StateM)
multiply x = liftF $ Multiply x id

-- Multiplicative interpreter
data RunCommandM a = RunCommandM
  { multiply :: Int -> a }

derive instance functorRunCommandM :: Functor RunCommandM

mkInterpM :: StateM -> Cofree RunCommandM StateM
mkInterpM state = unfoldCofree id next state
  where
    multiply' :: StateM -> Int -> StateM
    multiply' st x = over StateM (\{ count } -> { count: count * x }) st

    next :: StateM -> RunCommandM StateM
    next st = RunCommandM
      { multiply: multiply' st }

pairM :: forall x y. CommandM (x -> y) -> RunCommandM x -> y
pairM (Multiply x f) (RunCommandM i) = f $ i.multiply x

runM :: Free CommandM (StateM -> StateM) -> StateM -> StateM
runM cmds state = explore pairM cmds (mkInterpM state)

-- Product State, Coproduct of commands, Product of interprepters
type ComposedCommand a = Coproduct CommandA CommandM a

type ComposedState = Tuple StateA StateM

type ComposedDSL = Free (Coproduct CommandA CommandM) (ComposedState -> ComposedState)

type ComposedRunCommand a = Product RunCommandA RunCommandM a

-- compose two cofree comonands into a product
compose
  :: forall f g a b
   . Functor f
  => Functor g
  => Cofree f a
  -> Cofree g b
  -> Cofree (Product f g) (Tuple a b)
compose f g =
  mkCofree
    (Tuple (head f) (head g))
    (fn (tail f) (tail g))
  where
    fn :: f (Cofree f a) -> g (Cofree g b) -> Product f g (Cofree (Product f g) (Tuple a b))
    fn fa gb = uncurry compose <$> (product (flip Tuple g <$> fa) (Tuple f <$> gb))

mkInterp :: ComposedState -> Cofree (Product RunCommandA RunCommandM) ComposedState
mkInterp (Tuple s1 s2) = compose (mkInterpA s1) (mkInterpM s2)

pair :: forall x y. (Coproduct CommandA CommandM (x -> y)) -> Product RunCommandA RunCommandM x -> y
pair (Coproduct (Left c)) (Product (Tuple l r)) = pairA c l
pair (Coproduct (Right c)) (Product (Tuple l r)) = pairM c r

run :: Free (Coproduct CommandA CommandM) (Tuple StateA StateM -> Tuple StateA StateM) -> Tuple StateA StateM -> Tuple StateA StateM
run cmds state = explore pair cmds (mkInterp state)

main :: forall e. Eff (dom :: DOM | e) Unit
main = 
  let 
    stateA :: StateA
    stateA = StateA { count: 0 }

    stateM :: StateM
    stateM = StateM { count: 1 }

    id_ :: Tuple StateA StateM -> Tuple StateA StateM
    id_ = id

    prog :: Free (Coproduct CommandA CommandM) (Tuple StateA StateM -> Tuple StateA StateM)
    prog = do
      _ <- liftF $ left (Add 1 id_)
      liftF $ right (Multiply 2 id_)

  in do
    render $ fold $
      [ h1 (text "Compose Free and Cofree (co)monads")
      , p (text """
      This gist includes two DSL's for managing two states: `StateA` (an additive
      counter) and `StateM` (a multiplicative counter).  Then we take
      a `Coproduct` of corresponding DSL's, and `Product` of `Cofree`
      interpreters to get a DSL and an interpreter for `Tuple StateA StateM`.
      """)
      , p $ code (text $ "initial state: " <> show (Tuple stateA stateM))
      , p $ code (text $ "final state:   " <> show (run prog (Tuple stateA stateM)))
      ]