{-# LANGUAGE MagicHash, UndecidableInstances, TypeFamilies #-}
module Data.Unsafe.Reify (
        MuRef(..),
        Graph(..),
        reifyGraph
        ) where

import GHC.Exts (Int(I#))
import GHC.Prim (reallyUnsafePtrEquality#, (/=#))
import Control.Concurrent.MVar
import Control.Monad
import Data.Unique



-- | '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 :: * -> *
  deRef :: a -> (DeRef a) a

  mapDeRef :: (Monad m) => (a -> m Unique) -> (DeRef a) a -> m (DeRef a Unique)


-- 'Graph' is a basic graph structure over nodes of the higher kind 'e', with a single root.
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' takes a data structure that admits 'MuRef', and returns a 'Graph' that contains
-- the dereferenced nodes, with their children as 'Unique' rather than recursive values.

reifyGraph :: (MuRef s) => s -> IO (Graph (DeRef s))
reifyGraph m = do rt1 <- newMVar []
                  rt2 <- newMVar []
                  root <- findNodes rt1 rt2 m
                  pairs <- readMVar rt2
                  return (Graph pairs root)

findNodes :: (MuRef s) => MVar [(Unique,s)] -> MVar [(Unique,DeRef s Unique)] -> s -> IO Unique
findNodes rt1 rt2 j = do
        tab <- takeMVar rt1
        case [ m | (m,i) <- tab, j `seq` i `seq` (j `eq` i) ] of
            (var:_) -> do putMVar rt1 tab
                          return $ var
            []   -> do var <- newUnique
                       let e = deRef j 
                       putMVar rt1 $ (var,j) : tab
                       res <- mapDeRef (findNodes rt1 rt2) e
                       tab' <- takeMVar rt2
                       putMVar rt2 $ (var,res) : tab'
                       return var
                 
-- Dangerous, dangerous stuff.
eq :: a -> a -> Bool
eq a b = reallyUnsafePtrEquality# a b /=# 0#