graph fixpoint

gistfile1.lhs

> {-# LANGUAGE
>     DeriveFunctor
>   , DeriveFoldable
>   , DeriveTraversable
>   , StandaloneDeriving
>   , DoRec
>   #-}
> module Graph where

> import Control.Applicative
> import Control.Concurrent.STM
> import Control.Monad.Fix
> import Data.Foldable
> import Data.Maybe
> import Data.Traversable
> import Prelude hiding (mapM)
> import qualified Data.Map as M

> instance MonadFix STM where
>   mfix = error "I need this instance!"

A single node is a graph, has a list of both incoming and outgoing edges.

> data Node edge = Node
>   { nodeId   :: NodeId
>   , payload  :: String
>   , incoming :: [edge]
>   , ougoing  :: [edge]
>   } deriving (Functor, Foldable, Traversable)

> type NodeId = String

A graph with an index on the nodes by NodeId, parametrized with the type we
want to used as the edge pointer.

> type Graph edge = M.Map NodeId (Node edge)

Type level fixed point combinator with a TVar pointer.

> newtype TFix f = TIn { tout :: TVar (f (TFix f)) }

Take a graph that uses NodeIds as edges and recursively transform it into a
graph with TVars to the neighbouring nodes in the edges.

> tieTheKnot :: Graph NodeId -> STM (Graph (TFix Node))
> tieTheKnot untied =
>   do rec tied <- (mapM . mapM) (\nodeid -> TIn <$> newTVar (tryLookup nodeid tied)) untied
>      return tied

Helper function to lookup a pre-tied node from a graph, throws an error when
the edge could not be resolved. This should, of course, not happen.

> tryLookup :: NodeId -> Graph (TFix Node) -> Node (TFix Node)
> tryLookup i = fromJust (error msg) . M.lookup i
>   where msg = "tieTheKnot: Lookup error, input is an incomplete graph."

I wonder what this looks like with the graphs package.