{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Reify (
MuRef(..),
module Data.Reify.Graph,
reifyGraph,
reifyGraphs
) where
import Control.Concurrent.MVar
import qualified Data.HashMap.Lazy as HM
import Data.HashMap.Lazy (HashMap)
import Data.Hashable as H
import Data.Reify.Graph
import qualified Data.IntSet as IS
import Data.IntSet (IntSet)
import System.Mem.StableName
#if !(MIN_VERSION_base(4,7,0))
import Unsafe.Coerce
#endif
#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative
import Data.Traversable
#endif
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 :: forall s. MuRef s => s -> IO (Graph (DeRef s))
reifyGraph s
m = do MVar (HashMap DynStableName Unique)
rt1 <- forall a. a -> IO (MVar a)
newMVar forall k v. HashMap k v
HM.empty
MVar Unique
uVar <- forall a. a -> IO (MVar a)
newMVar Unique
0
forall s.
MuRef s =>
MVar (HashMap DynStableName Unique)
-> MVar Unique -> s -> IO (Graph (DeRef s))
reifyWithContext MVar (HashMap DynStableName Unique)
rt1 MVar Unique
uVar s
m
reifyGraphs :: (MuRef s, Traversable t) => t s -> IO (t (Graph (DeRef s)))
reifyGraphs :: forall s (t :: * -> *).
(MuRef s, Traversable t) =>
t s -> IO (t (Graph (DeRef s)))
reifyGraphs t s
coll = do MVar (HashMap DynStableName Unique)
rt1 <- forall a. a -> IO (MVar a)
newMVar forall k v. HashMap k v
HM.empty
MVar Unique
uVar <- forall a. a -> IO (MVar a)
newMVar Unique
0
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall s.
MuRef s =>
MVar (HashMap DynStableName Unique)
-> MVar Unique -> s -> IO (Graph (DeRef s))
reifyWithContext MVar (HashMap DynStableName Unique)
rt1 MVar Unique
uVar) t s
coll
reifyWithContext :: (MuRef s)
=> MVar (HashMap DynStableName Unique)
-> MVar Unique
-> s
-> IO (Graph (DeRef s))
reifyWithContext :: forall s.
MuRef s =>
MVar (HashMap DynStableName Unique)
-> MVar Unique -> s -> IO (Graph (DeRef s))
reifyWithContext MVar (HashMap DynStableName Unique)
rt1 MVar Unique
uVar s
j = do
MVar [(Unique, DeRef s Unique)]
rt2 <- forall a. a -> IO (MVar a)
newMVar []
MVar IntSet
nodeSetVar <- forall a. a -> IO (MVar a)
newMVar IntSet
IS.empty
Unique
root <- forall s.
MuRef s =>
MVar (HashMap DynStableName Unique)
-> MVar [(Unique, DeRef s Unique)]
-> MVar Unique
-> MVar IntSet
-> s
-> IO Unique
findNodes MVar (HashMap DynStableName Unique)
rt1 MVar [(Unique, DeRef s Unique)]
rt2 MVar Unique
uVar MVar IntSet
nodeSetVar s
j
[(Unique, DeRef s Unique)]
pairs <- forall a. MVar a -> IO a
readMVar MVar [(Unique, DeRef s Unique)]
rt2
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (e :: * -> *). [(Unique, e Unique)] -> Unique -> Graph e
Graph [(Unique, DeRef s Unique)]
pairs Unique
root)
findNodes :: (MuRef s)
=> MVar (HashMap DynStableName Unique)
-> MVar [(Unique,DeRef s Unique)]
-> MVar Unique
-> MVar IntSet
-> s
-> IO Unique
findNodes :: forall s.
MuRef s =>
MVar (HashMap DynStableName Unique)
-> MVar [(Unique, DeRef s Unique)]
-> MVar Unique
-> MVar IntSet
-> s
-> IO Unique
findNodes MVar (HashMap DynStableName Unique)
rt1 MVar [(Unique, DeRef s Unique)]
rt2 MVar Unique
uVar MVar IntSet
nodeSetVar !s
j = do
DynStableName
st <- forall a. a -> IO DynStableName
makeDynStableName s
j
HashMap DynStableName Unique
tab <- forall a. MVar a -> IO a
takeMVar MVar (HashMap DynStableName Unique)
rt1
IntSet
nodeSet <- forall a. MVar a -> IO a
takeMVar MVar IntSet
nodeSetVar
case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup DynStableName
st HashMap DynStableName Unique
tab of
Just Unique
var -> do forall a. MVar a -> a -> IO ()
putMVar MVar (HashMap DynStableName Unique)
rt1 HashMap DynStableName Unique
tab
if Unique
var Unique -> IntSet -> Bool
`IS.member` IntSet
nodeSet
then do forall a. MVar a -> a -> IO ()
putMVar MVar IntSet
nodeSetVar IntSet
nodeSet
forall (m :: * -> *) a. Monad m => a -> m a
return Unique
var
else Unique -> IntSet -> IO Unique
recurse Unique
var IntSet
nodeSet
Maybe Unique
Nothing -> do Unique
var <- MVar Unique -> IO Unique
newUnique MVar Unique
uVar
forall a. MVar a -> a -> IO ()
putMVar MVar (HashMap DynStableName Unique)
rt1 forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert DynStableName
st Unique
var HashMap DynStableName Unique
tab
Unique -> IntSet -> IO Unique
recurse Unique
var IntSet
nodeSet
where
recurse :: Unique -> IntSet -> IO Unique
recurse :: Unique -> IntSet -> IO Unique
recurse Unique
var IntSet
nodeSet = do
forall a. MVar a -> a -> IO ()
putMVar MVar IntSet
nodeSetVar forall a b. (a -> b) -> a -> b
$ Unique -> IntSet -> IntSet
IS.insert Unique
var IntSet
nodeSet
DeRef s Unique
res <- 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 (forall s.
MuRef s =>
MVar (HashMap DynStableName Unique)
-> MVar [(Unique, DeRef s Unique)]
-> MVar Unique
-> MVar IntSet
-> s
-> IO Unique
findNodes MVar (HashMap DynStableName Unique)
rt1 MVar [(Unique, DeRef s Unique)]
rt2 MVar Unique
uVar MVar IntSet
nodeSetVar) s
j
[(Unique, DeRef s Unique)]
tab' <- forall a. MVar a -> IO a
takeMVar MVar [(Unique, DeRef s Unique)]
rt2
forall a. MVar a -> a -> IO ()
putMVar MVar [(Unique, DeRef s Unique)]
rt2 forall a b. (a -> b) -> a -> b
$ (Unique
var,DeRef s Unique
res) forall a. a -> [a] -> [a]
: [(Unique, DeRef s Unique)]
tab'
forall (m :: * -> *) a. Monad m => a -> m a
return Unique
var
newUnique :: MVar Unique -> IO Unique
newUnique :: MVar Unique -> IO Unique
newUnique MVar Unique
var = do
Unique
v <- forall a. MVar a -> IO a
takeMVar MVar Unique
var
let v' :: Unique
v' = forall a. Enum a => a -> a
succ Unique
v
forall a. MVar a -> a -> IO ()
putMVar MVar Unique
var Unique
v'
forall (m :: * -> *) a. Monad m => a -> m a
return Unique
v'
data DynStableName = forall a. DynStableName !(StableName a)
instance Hashable DynStableName where
hashWithSalt :: Unique -> DynStableName -> Unique
hashWithSalt Unique
s (DynStableName StableName a
n) = forall a. Hashable a => Unique -> a -> Unique
hashWithSalt Unique
s StableName a
n
instance Eq DynStableName where
DynStableName StableName a
m == :: DynStableName -> DynStableName -> Bool
== DynStableName StableName a
n =
#if MIN_VERSION_base(4,7,0)
forall a b. StableName a -> StableName b -> Bool
eqStableName StableName a
m StableName a
n
#else
m == unsafeCoerce n
#endif
makeDynStableName :: a -> IO DynStableName
makeDynStableName :: forall a. a -> IO DynStableName
makeDynStableName a
a = do
StableName a
st <- forall a. a -> IO (StableName a)
makeStableName a
a
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. StableName a -> DynStableName
DynStableName StableName a
st