{-# LANGUAGE UndecidableInstances, TypeFamilies #-}
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

-- | '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 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