module Data.Reify (
MuRef(..),
module Data.Reify.Graph,
reifyGraph
) where
import Control.Concurrent.MVar
import Control.Monad
import System.Mem.StableName
import Data.IntMap as M
import Control.Applicative
import Data.Reify.Graph
class MuRef a where
type DeRef a :: * -> *
mapDeRef :: (Applicative m)
=> (a -> m u)
-> a
-> m (DeRef a u)
reifyGraph :: (MuRef s) => s -> IO (Graph (DeRef s))
reifyGraph m = do rt1 <- newMVar M.empty
rt2 <- newMVar []
uVar <- newMVar 0
root <- findNodes rt1 rt2 uVar m
pairs <- readMVar rt2
return (Graph pairs root)
findNodes :: (MuRef s)
=> MVar (IntMap [(StableName s,Int)])
-> MVar [(Int,DeRef s Int)]
-> MVar Int
-> s
-> IO Int
findNodes rt1 rt2 uVar j | j `seq` True = do
st <- makeStableName j
tab <- takeMVar rt1
case mylookup st tab of
Just var -> do putMVar rt1 tab
return $ var
Nothing ->
do var <- newUnique uVar
putMVar rt1 $ M.insertWith (++) (hashStableName st) [(st,var)] tab
res <- mapDeRef (findNodes rt1 rt2 uVar) j
tab' <- takeMVar rt2
putMVar rt2 $ (var,res) : tab'
return var
where
mylookup h tab =
case M.lookup (hashStableName h) tab of
Just tab2 -> Prelude.lookup h tab2
Nothing -> Nothing
newUnique :: MVar Int -> IO Int
newUnique var = do
v <- takeMVar var
let v' = succ v
putMVar var v'
return v'