module Data.Dynamic.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 Data.Dynamic
import Control.Applicative
import Data.Reify.Graph
class MuRef a where
type DeRef a :: * -> *
mapDeRef :: (Applicative f) =>
(forall b . (MuRef b,
Typeable b,
DeRef a ~ DeRef b) => b -> f u)
-> a
-> f (DeRef a u)
reifyGraph :: (MuRef s, Typeable 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, Typeable s)
=> MVar (IntMap [(Dynamic,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) [(toDyn st,var)] tab
res <- mapDeRef (findNodes rt1 rt2 uVar) j
tab' <- takeMVar rt2
putMVar rt2 $ (var,res) : tab'
return var
mylookup :: (Typeable a) => StableName a -> IntMap [(Dynamic,Int)] -> Maybe Int
mylookup h tab =
case M.lookup (hashStableName h) tab of
Just tab2 -> Prelude.lookup (Just h) [ (fromDynamic c,u) | (c,u) <- tab2 ]
Nothing -> Nothing
newUnique :: MVar Int -> IO Int
newUnique var = do
v <- takeMVar var
let v' = succ v
putMVar var v'
return v'