Reify.hs

-- |
-- Module: Data.Dynamic.Reify
-- Copyright: (c) 2009 Andy Gill
-- License: BSD3
--
-- Maintainer: Andy Gill <andygill@ku.edu>
-- Stability: unstable
-- Portability: ghc
--
-- This is a 'Dynamic' version of 'Data.Reify', that can reify nodes
-- of different types inside a sigle graph, provided they unify to
-- a common representation.
-- 

{-# LANGUAGE UndecidableInstances, TypeFamilies, RankNTypes, ExistentialQuantification, DeriveDataTypeable, RelaxedPolyRec, FlexibleContexts  #-}
module Data.Dynamic.Reify (
        MuRef(..),
        module Data.Reify.Graph,
        reifyGraph,
        ) where

import Control.Concurrent.MVar
import Control.Monad
import Data.Unique
import System.Mem.StableName
import Data.IntMap as M
import Data.Dynamic

import Control.Applicative
import Data.Reify.Graph


-- | '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, 
                            Typeable 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 'Unique' rather than recursive values.

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

findNodes :: (MuRef s, Typeable s) 
          => MVar (IntMap [(Dynamic,Unique)])   -- Dynamic of StableNames
          -> MVar [(Unique,DeRef s Unique)] 
          -> s 
          -> IO Unique
findNodes rt1 rt2 j | j `seq` True = do
        st <- makeStableName j
        tab <- takeMVar rt1
        case mylookup st tab of
          Just var -> do putMVar rt1 tab
                         return $ var
          Nothing -> 
                    do var <- newUnique
                       putMVar rt1 $ M.insertWith (++) (hashStableName st) [(toDyn st,var)] tab
                       res <- mapDeRef (findNodes rt1 rt2) j
                       tab' <- takeMVar rt2
                       putMVar rt2 $ (var,res) : tab'
                       return var

mylookup :: (Typeable a) => StableName a -> IntMap [(Dynamic,Unique)] -> Maybe Unique
mylookup h tab =
           case M.lookup (hashStableName h) tab of
             Just tab2 -> Prelude.lookup (Just h) [ (fromDynamic c,u) | (c,u) <- tab2 ]
             Nothing ->  Nothing