{-# LANGUAGE TypeFamilies, RankNTypes #-}
module Data.Reify (
MuRef(..),
module Data.Reify.Graph,
reifyGraph
) where
import Control.Applicative
import Control.Concurrent.MVar
import Data.IntMap as M
import Data.Reify.Graph
import System.Mem.StableName
import Unsafe.Coerce
import Prelude
class MuRef a where
type DeRef a :: * -> *
mapDeRef :: (Applicative f) =>
(forall b . (MuRef b, DeRef a ~ DeRef b) => b -> f u)
-> a
-> f (DeRef a u)
reifyGraph :: (MuRef s) => s -> IO (Graph (DeRef s))
reifyGraph :: s -> IO (Graph (DeRef s))
reifyGraph m :: s
m = do MVar (IntMap [(DynStableName, Int)])
rt1 <- IntMap [(DynStableName, Int)]
-> IO (MVar (IntMap [(DynStableName, Int)]))
forall a. a -> IO (MVar a)
newMVar IntMap [(DynStableName, Int)]
forall a. IntMap a
M.empty
MVar [(Int, DeRef s Int)]
rt2 <- [(Int, DeRef s Int)] -> IO (MVar [(Int, DeRef s Int)])
forall a. a -> IO (MVar a)
newMVar []
MVar Int
uVar <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar 0
Int
root <- MVar (IntMap [(DynStableName, Int)])
-> MVar [(Int, DeRef s Int)] -> MVar Int -> s -> IO Int
forall s.
MuRef s =>
MVar (IntMap [(DynStableName, Int)])
-> MVar [(Int, DeRef s Int)] -> MVar Int -> s -> IO Int
findNodes MVar (IntMap [(DynStableName, Int)])
rt1 MVar [(Int, DeRef s Int)]
rt2 MVar Int
uVar s
m
[(Int, DeRef s Int)]
pairs <- MVar [(Int, DeRef s Int)] -> IO [(Int, DeRef s Int)]
forall a. MVar a -> IO a
readMVar MVar [(Int, DeRef s Int)]
rt2
Graph (DeRef s) -> IO (Graph (DeRef s))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Int, DeRef s Int)] -> Int -> Graph (DeRef s)
forall (e :: * -> *). [(Int, e Int)] -> Int -> Graph e
Graph [(Int, DeRef s Int)]
pairs Int
root)
findNodes :: (MuRef s)
=> MVar (IntMap [(DynStableName,Int)])
-> MVar [(Int,DeRef s Int)]
-> MVar Int
-> s
-> IO Int
findNodes :: MVar (IntMap [(DynStableName, Int)])
-> MVar [(Int, DeRef s Int)] -> MVar Int -> s -> IO Int
findNodes rt1 :: MVar (IntMap [(DynStableName, Int)])
rt1 rt2 :: MVar [(Int, DeRef s Int)]
rt2 uVar :: MVar Int
uVar j :: s
j | s
j s -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
True = do
DynStableName
st <- s -> IO DynStableName
forall a. a -> IO DynStableName
makeDynStableName s
j
IntMap [(DynStableName, Int)]
tab <- MVar (IntMap [(DynStableName, Int)])
-> IO (IntMap [(DynStableName, Int)])
forall a. MVar a -> IO a
takeMVar MVar (IntMap [(DynStableName, Int)])
rt1
case DynStableName -> IntMap [(DynStableName, Int)] -> Maybe Int
mylookup DynStableName
st IntMap [(DynStableName, Int)]
tab of
Just var :: Int
var -> do MVar (IntMap [(DynStableName, Int)])
-> IntMap [(DynStableName, Int)] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IntMap [(DynStableName, Int)])
rt1 IntMap [(DynStableName, Int)]
tab
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
var
Nothing ->
do Int
var <- MVar Int -> IO Int
newUnique MVar Int
uVar
MVar (IntMap [(DynStableName, Int)])
-> IntMap [(DynStableName, Int)] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IntMap [(DynStableName, Int)])
rt1 (IntMap [(DynStableName, Int)] -> IO ())
-> IntMap [(DynStableName, Int)] -> IO ()
forall a b. (a -> b) -> a -> b
$ ([(DynStableName, Int)]
-> [(DynStableName, Int)] -> [(DynStableName, Int)])
-> Int
-> [(DynStableName, Int)]
-> IntMap [(DynStableName, Int)]
-> IntMap [(DynStableName, Int)]
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
M.insertWith [(DynStableName, Int)]
-> [(DynStableName, Int)] -> [(DynStableName, Int)]
forall a. [a] -> [a] -> [a]
(++) (DynStableName -> Int
hashDynStableName DynStableName
st) [(DynStableName
st,Int
var)] IntMap [(DynStableName, Int)]
tab
DeRef s Int
res <- (forall b. (MuRef b, DeRef s ~ DeRef b) => b -> IO Int)
-> s -> IO (DeRef s Int)
forall a (f :: * -> *) u.
(MuRef a, Applicative f) =>
(forall b. (MuRef b, DeRef a ~ DeRef b) => b -> f u)
-> a -> f (DeRef a u)
mapDeRef (MVar (IntMap [(DynStableName, Int)])
-> MVar [(Int, DeRef b Int)] -> MVar Int -> b -> IO Int
forall s.
MuRef s =>
MVar (IntMap [(DynStableName, Int)])
-> MVar [(Int, DeRef s Int)] -> MVar Int -> s -> IO Int
findNodes MVar (IntMap [(DynStableName, Int)])
rt1 MVar [(Int, DeRef s Int)]
MVar [(Int, DeRef b Int)]
rt2 MVar Int
uVar) s
j
[(Int, DeRef s Int)]
tab' <- MVar [(Int, DeRef s Int)] -> IO [(Int, DeRef s Int)]
forall a. MVar a -> IO a
takeMVar MVar [(Int, DeRef s Int)]
rt2
MVar [(Int, DeRef s Int)] -> [(Int, DeRef s Int)] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [(Int, DeRef s Int)]
rt2 ([(Int, DeRef s Int)] -> IO ()) -> [(Int, DeRef s Int)] -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int
var,DeRef s Int
res) (Int, DeRef s Int) -> [(Int, DeRef s Int)] -> [(Int, DeRef s Int)]
forall a. a -> [a] -> [a]
: [(Int, DeRef s Int)]
tab'
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
var
findNodes _ _ _ _ = [Char] -> IO Int
forall a. HasCallStack => [Char] -> a
error "findNodes: strictness seq function failed to return True"
mylookup :: DynStableName -> IntMap [(DynStableName,Int)] -> Maybe Int
mylookup :: DynStableName -> IntMap [(DynStableName, Int)] -> Maybe Int
mylookup h :: DynStableName
h tab :: IntMap [(DynStableName, Int)]
tab =
case Int
-> IntMap [(DynStableName, Int)] -> Maybe [(DynStableName, Int)]
forall a. Int -> IntMap a -> Maybe a
M.lookup (DynStableName -> Int
hashDynStableName DynStableName
h) IntMap [(DynStableName, Int)]
tab of
Just tab2 :: [(DynStableName, Int)]
tab2 -> DynStableName -> [(DynStableName, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup DynStableName
h [ (DynStableName
c,Int
u) | (c :: DynStableName
c,u :: Int
u) <- [(DynStableName, Int)]
tab2 ]
Nothing -> Maybe Int
forall a. Maybe a
Nothing
newUnique :: MVar Int -> IO Int
newUnique :: MVar Int -> IO Int
newUnique var :: MVar Int
var = do
Int
v <- MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
var
let v' :: Int
v' = Int -> Int
forall a. Enum a => a -> a
succ Int
v
MVar Int -> Int -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Int
var Int
v'
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
v'
data DynStableName = DynStableName (StableName ())
hashDynStableName :: DynStableName -> Int
hashDynStableName :: DynStableName -> Int
hashDynStableName (DynStableName sn :: StableName ()
sn) = StableName () -> Int
forall a. StableName a -> Int
hashStableName StableName ()
sn
instance Eq DynStableName where
(DynStableName sn1 :: StableName ()
sn1) == :: DynStableName -> DynStableName -> Bool
== (DynStableName sn2 :: StableName ()
sn2) = StableName ()
sn1 StableName () -> StableName () -> Bool
forall a. Eq a => a -> a -> Bool
== StableName ()
sn2
makeDynStableName :: a -> IO DynStableName
makeDynStableName :: a -> IO DynStableName
makeDynStableName a :: a
a = do
StableName a
st <- a -> IO (StableName a)
forall a. a -> IO (StableName a)
makeStableName a
a
DynStableName -> IO DynStableName
forall (m :: * -> *) a. Monad m => a -> m a
return (DynStableName -> IO DynStableName)
-> DynStableName -> IO DynStableName
forall a b. (a -> b) -> a -> b
$ StableName () -> DynStableName
DynStableName (StableName a -> StableName ()
forall a b. a -> b
unsafeCoerce StableName a
st)