{-# 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

-- | 'MuRef' is a class that provided a way to reference into a specific type,
-- and a way to map over the deferenced internals.

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' takes a data structure that admits 'MuRef', and returns a 'Graph' that contains
-- the dereferenced nodes, with their children as 'Int' rather than recursive values.

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'
  
-- Stable names that not use phantom types.
-- As suggested by Ganesh Sittampalam.
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)