module Data.Unsafe.Reify (
MuRef(..),
Graph(..),
reifyGraph
) where
import Control.Concurrent.MVar
import Control.Monad
import Data.Unique
import System.Mem.StableName
import Data.IntMap as M
class MuRef a where
type DeRef a :: * -> *
deRef :: a -> (DeRef a) a
mapDeRef :: (Monad m) => (a -> m Unique) -> (DeRef a) a -> m (DeRef a Unique)
data Graph e = Graph [(Unique,e Unique)] Unique
instance (Functor e,Show (e Int)) => Show (Graph e) where
show (Graph netlist start) = "let " ++ show [ (hashUnique u,fmap hashUnique e)
| (u,e) <- netlist
] ++ " in " ++ show (hashUnique start)
reifyGraph :: (MuRef s) => s -> IO (Graph (DeRef s))
reifyGraph m = do rt1 <- newMVar empty
rt2 <- newMVar []
root <- findNodes rt1 rt2 m
pairs <- readMVar rt2
return (Graph pairs root)
findNodes :: (MuRef s)
=> MVar (IntMap [(StableName s,Unique)])
-> MVar [(Unique,DeRef s Unique)]
-> s
-> IO Unique
findNodes rt1 rt2 j = do
st <- makeStableName j
tab <- takeMVar rt1
case mylookup st tab of
Just var -> do putMVar rt1 tab
return $ var
Nothing ->
do var <- newUnique
let e = deRef j
putMVar rt1 $ M.insertWith (++) (hashStableName st) [(st,var)] tab
res <- mapDeRef (findNodes rt1 rt2) e
tab' <- takeMVar rt2
putMVar rt2 $ (var,res) : tab'
return var
where
mylookup h tab =
case M.lookup (hashStableName h) tab of
Just tab2 -> case Prelude.lookup h tab2 of
Just uq -> Just uq
Nothing -> Nothing
Nothing -> Nothing