Routing with Cofree Comonad

https://github.com/coot/purescript-cofree-react-router

Marcin Szamotulski, PhD

Routing with Cofree Comonad

https://github.com/coot/purescript-cofree-react-router

• comonads
• cofree comonad
• react router (v3)
• cofree react router
• isomorphic react app example

Comonads

Are useful for tracking state in a possibly infinite loop

• streams
• interpreters of dsl's
• modeling UIs
• routing - really ;)

Often comonads are explored through a pairing with a monad (Cofree pairs with Free, Store pairs with State, ...)

Comonad - definition

-- | Associativity: `extend f <<< extend g = extend (f <<< extend g)`
class Functor w <= Extend w where
  extend :: forall b a. (w a -> b) -> w a -> w b

-- | Forwards co-Kleisli composition.
composeCoKleisli
  :: forall b a w c
   . Extend w
  => (w a -> b)
  -> (w b -> c)
  -> w a -> c
composeCoKleisli f g w = g (f <<= w)

-- | Duplicate a comonadic context.
duplicate
  :: forall a w
   . Extend w
  => w a -> w (w a)
duplicate = extend id
	    

-- | Left Identity: `extract <<= xs = xs`
-- | Right Identity: `extract (f <<= xs) = f xs`
class Extend w <= Comonad w where
  extract :: forall a. w a -> a
	    

Stream Comonad

data Stream a = Cons a (Lazy (Stream a))

derive instance functorStream :: Functor Stream

instance extendStream :: Extend Stream where
  extend f s@(Cons a r) = Cons (f s) (extend f <$> r)

instance comonadStream :: Comonad Stream where
  extract (Cons a _) = a

smooth :: Int -> Stream Number -> Stream Number
smooth n s = extend (avN n) s
  where
    sumN :: Int -> Stream Number -> Number
    sumN 0 _ = 0.0
    sumN n (Cons a r) = a + (sumN (n - 1) (force r))

    avN :: Int -> Stream Number -> Number
    avN n s = (sumN n s) / (toNumber n)
	    

Cofree comonad

data Cofree f a = Cofree a (Lazy (f (Cofree f a)))

mkCofree :: forall f a. a -> f (Cofree f a) -> Cofree f a
mkCofree a t = Cofree a (defer \_ -> t)

infixr 5 mkCofree as :<

-- | Returns the label for a tree.
head :: forall f a. Cofree f a -> a
head (Cofree h _) = h

instance functorCofree :: Functor f => Functor (Cofree f) where
  map f = loop where
    loop fa@(Cofree head _tail)
      = Cofree (f head) ((map loop) <$> _tail)

instance extendCofree :: Functor f => Extend (Cofree f) where
  extend f = loop
    where
    loop fa@(Cofree _ _tail)
      = Cofree (f fa) ((map loop) <$> _tail)

instance comonadCofree :: Functor f => Comonad (Cofree f) where
  extract = head
	  

React Router

<Router history={browserHistory}>
  <Route path="/" component={Main}>
    <Route path="/home" component={Home}>
      <Route path="/user/:userId" component={User} />
      <Route path="/book/:bookId" component={Book} />
    </Route>
    <Route path="/settings" component={Settings} />
  </Route>
</Router>
	  

  type Router route = Cofree Array route
	    

Cofree Router - Types

type RouteClass props arg
  =  (RoutePropsClass props)
  => ReactClass (props arg)

data Route props arg
  = Route String (Routing.Match arg) (RouteClass props arg)

data IndexRoute props arg
  = IndexRoute String (RouteClass props arg)

type Router props arg
  =  (RoutePropsClass props)
  => Cofree Array
      (Tuple (Route props arg) (Maybe (IndexRoute props arg)))

withoutIndex
  :: forall props arg
   . (RoutePropsClass props)
  => Route props arg
  -> Array (Router props args)
  -> Router props arg
withoutIndex r rs = Tuple r Nothing :< rs

-- | `:+` lets define routes without index route
infixr 6 withoutIndex as :+
	  

Developer Interface

Let's rewrite the routing example:

router =
  Route "main" (lit "") Main :+
    [ Route "home" (unit <$ lit "home") Home :+
      [ Route "user" ({userId: _} <$> (lit "user" *> int)) User :+ []
      , Route "book" ({bookId: _} <$> (lit "book" *> int)) Book :+ []
      ]
    , Route "settings" (unit <$ lit "settings") Settings :+ []
    ]
	  

Some internals

matchRouter
  :: forall props args
   . (RoutePropsClass props)
  => R.Route
  -> Router props args
  -> Maybe (Cofree Array
	      { url :: R.Route
	      , props :: props args
	      , route :: Route props args
	      , indexRoute :: Maybe (IndexRoute props args) })
matchRouter url_ router = shake $ go [] url_ router
    where
    query = foldMap toMap url_

    toMap (R.Query q) = q

    go
      :: Array args
      -> R.Route
      -> Cofree Array (Tuple (Route props args) (Maybe (IndexRoute props args)))
      -> Cofree Array (Maybe
	    { url :: R.Route
	    , props :: props args
	    , route :: Route props args
	    , indexRoute :: Maybe (IndexRoute props args) })
    go argsArr url' r =
      case head r of
        Tuple route indexRoute ->
          case view urlLens route of
            Match mFn ->
              case unV Left Right (mFn url') of
                Right (Tuple url arg) ->
                  let props = case route of
                                Route idRoute _ _ -> mkProps idRoute arg (A.snoc argsArr arg) query
                  in Just {url, props, route, indexRoute} :< map (go (A.snoc argsArr arg) url) (tail r)
                Left err -> Nothing :< []
	  

Hmm... but why not use extend

extendM
  :: forall w m a b
   . Extend w
  => Traversable w
  => Applicative m
  => (w a -> m b)
  -> w a
  -> m (w b)
extendM f wa = sequence $ extend f wa
	  

where we could track the state in the `State` monad

Run router

runRouter
  :: forall props args
   . (RoutePropsClass props)
  -- url:
  => String
  -- router:
  -> Cofree Array
      (Tuple (Route props args) (Maybe (IndexRoute props args)))
  -- react element to be mounted:
  -> Maybe ReactElement
runRouter urlStr router =
    createRouteElement <$> matchRouter (parse decodeURIComponent urlStr) router
  where
    -- ...
	  

Live Demo Time