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