diff --git a/Data/Dynamic/Reify.hs b/Data/Dynamic/Reify.hs deleted file mode 100644 --- a/Data/Dynamic/Reify.hs +++ /dev/null @@ -1,90 +0,0 @@ --- | --- Module: Data.Dynamic.Reify --- Copyright: (c) 2009 Andy Gill --- License: BSD3 --- --- Maintainer: Andy Gill --- 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 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 'Int' rather than recursive values. - -reifyGraph :: (MuRef s, Typeable s) => s -> IO (Graph (DeRef s)) -reifyGraph m = do rt1 <- newMVar M.empty - rt2 <- newMVar [] - uVar <- newMVar 0 - root <- findNodes rt1 rt2 uVar m - pairs <- readMVar rt2 - return (Graph pairs root) - -findNodes :: (MuRef s, Typeable s) - => MVar (IntMap [(Dynamic,Int)]) -- Dynamic of StableNames - -> MVar [(Int,DeRef s Int)] - -> MVar Int - -> s - -> IO Int -findNodes rt1 rt2 uVar 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 uVar - putMVar rt1 $ M.insertWith (++) (hashStableName st) [(toDyn st,var)] tab - res <- mapDeRef (findNodes rt1 rt2 uVar) j - tab' <- takeMVar rt2 - putMVar rt2 $ (var,res) : tab' - return var - -mylookup :: (Typeable a) => StableName a -> IntMap [(Dynamic,Int)] -> Maybe Int -mylookup h tab = - case M.lookup (hashStableName h) tab of - Just tab2 -> Prelude.lookup (Just h) [ (fromDynamic c,u) | (c,u) <- tab2 ] - Nothing -> Nothing - -newUnique :: MVar Int -> IO Int -newUnique var = do - v <- takeMVar var - let v' = succ v - putMVar var v' - return v' - - - diff --git a/Data/Reify.hs b/Data/Reify.hs --- a/Data/Reify.hs +++ b/Data/Reify.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances, TypeFamilies #-} +{-# LANGUAGE TypeFamilies, RankNTypes #-} module Data.Reify ( MuRef(..), module Data.Reify.Graph, @@ -9,21 +9,22 @@ import Control.Monad import System.Mem.StableName import Data.IntMap as M +import Unsafe.Coerce 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 m) - => (a -> m u) - -> a - -> m (DeRef a u) - + 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. @@ -36,32 +37,32 @@ pairs <- readMVar rt2 return (Graph pairs root) - findNodes :: (MuRef s) - => MVar (IntMap [(StableName s,Int)]) -- Dynamic of StableNames + => MVar (IntMap [(DynStableName,Int)]) -> MVar [(Int,DeRef s Int)] -> MVar Int -> s -> IO Int findNodes rt1 rt2 uVar j | j `seq` True = do - st <- makeStableName j + st <- makeDynStableName j tab <- takeMVar rt1 case mylookup st tab of Just var -> do putMVar rt1 tab return $ var Nothing -> do var <- newUnique uVar - putMVar rt1 $ M.insertWith (++) (hashStableName st) [(st,var)] tab + putMVar rt1 $ M.insertWith (++) (hashDynStableName st) [(st,var)] tab res <- mapDeRef (findNodes rt1 rt2 uVar) j tab' <- takeMVar rt2 putMVar rt2 $ (var,res) : tab' return var - where - mylookup h tab = - case M.lookup (hashStableName h) tab of - Just tab2 -> Prelude.lookup h tab2 - Nothing -> Nothing +findNodes _ _ _ _ = error "findNodes: strictness seq function failed to return True" +mylookup :: DynStableName -> IntMap [(DynStableName,Int)] -> Maybe Int +mylookup h tab = + case M.lookup (hashDynStableName h) tab of + Just tab2 -> Prelude.lookup h [ (c,u) | (c,u) <- tab2 ] + Nothing -> Nothing newUnique :: MVar Int -> IO Int newUnique var = do @@ -69,3 +70,19 @@ let v' = succ v putMVar var v' return v' + +-- Stable names that not use phantom types. +-- As suggested by Ganesh Sittampalam. +data DynStableName = DynStableName (StableName ()) + +hashDynStableName :: DynStableName -> Int +hashDynStableName (DynStableName sn) = hashStableName sn + +instance Eq DynStableName where + (DynStableName sn1) == (DynStableName sn2) = sn1 == sn2 + +makeDynStableName :: a -> IO DynStableName +makeDynStableName a = do + st <- makeStableName a + return $ DynStableName (unsafeCoerce st) + diff --git a/data-reify.cabal b/data-reify.cabal --- a/data-reify.cabal +++ b/data-reify.cabal @@ -1,5 +1,5 @@ Name: data-reify -Version: 0.4 +Version: 0.5 Synopsis: Reify a recursive data structure into an explicit graph. Description: 'data-reify' provided the ability to turn recursive structures into explicit graphs. Many (implicitly or explicitly) recursive data structure can be given this ability, via @@ -13,12 +13,16 @@ Providing an instance for 'MuRef' is the mechanism for allowing a structure to be reified into a graph, and several examples of this are provided. . + History: + Version 0.1 used unsafe pointer compares. Version 0.2 of 'data-reify' used 'StableName's, and was much faster. Version 0.3 provided two versions of 'MuRef', the mono-typed version, for trees of a single type, and the dynamic-typed version, for trees of different types. - Version 0.4 uses 'Int' as a synonym for 'Unique' rather than 'Data.Unique' + Version 0.4 used 'Int' as a synonym for 'Unique' rather than 'Data.Unique' for node ids, by popular demand. + Version 0.5 merged the mono-typed and dynamic version again, by using + 'DynStableName', an unphantomized version of StableName. . © 2009 Andy Gill; BSD3 license. @@ -37,11 +41,9 @@ Build-Depends: base >= 3 && < 4.2, containers Exposed-modules: Data.Reify, - Data.Dynamic.Reify, Data.Reify.Graph Ghc-Options: -Wall - Executable data-reify-test1 Build-Depends: base Main-Is: Test1.hs @@ -75,5 +77,11 @@ Executable data-reify-test6 Build-Depends: base Main-Is: Test6.hs + Hs-Source-Dirs: ., test + buildable: False + +Executable data-reify-test7 + Build-Depends: base + Main-Is: Test7.hs Hs-Source-Dirs: ., test buildable: False diff --git a/test/Test5.hs b/test/Test5.hs --- a/test/Test5.hs +++ b/test/Test5.hs @@ -5,7 +5,7 @@ import qualified Data.Foldable as F import Data.Monoid import Control.Applicative hiding (Const) -import Data.Dynamic.Reify +import Data.Reify import Data.Dynamic import Control.Monad diff --git a/test/Test6.hs b/test/Test6.hs --- a/test/Test6.hs +++ b/test/Test6.hs @@ -7,7 +7,7 @@ --import Control.Monad import Control.Applicative hiding (Const) -import Data.Dynamic.Reify +import Data.Reify import Control.Monad import System.CPUTime import Data.Typeable diff --git a/test/Test7.hs b/test/Test7.hs new file mode 100644 --- /dev/null +++ b/test/Test7.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TypeFamilies, UndecidableInstances, DeriveDataTypeable, RankNTypes, ExistentialQuantification #-} + + +import qualified Data.Traversable as T +import qualified Data.Foldable as F +import Data.Monoid +--import Control.Monad +import Control.Applicative hiding (Const) +import Data.Unique + +import System.Environment + +import Data.Reify +--import Data.Reify +import Control.Monad +import System.CPUTime +import Data.Typeable +import Control.Exception as E + +import Data.Dynamic + +data Tree = Node Tree Tree | Leaf Int + deriving (Show,Eq,Typeable) + +data T s = N s s | L Int + +instance MuRef Tree where + type DeRef Tree = T + mapDeRef f (Node t1 t2) = N <$> f t1 <*> f t2 + mapDeRef f (Leaf i) = pure $ L i + +deepTree :: Int -> Int -> Tree +deepTree 1 x = Leaf x +deepTree n x = Node (deepTree (pred n) (x * 37)) (deepTree (pred n) (x * 17)) + +-- no sharing +deepTree' n = deepTree n 1 + +deepTree2 :: Int -> Integer -> Tree -> Tree +deepTree2 1 v x = if v == 89235872347 then Leaf 1 else x +deepTree2 n v x = Node (deepTree2 (pred n) (v * 37) x) (deepTree2 (pred n) (v * 17) x) + +-- sharing +deepTree2' n = let v = deepTree2 n 1 v in v + +timeme :: Int -> (Int -> Tree) -> IO Float +timeme n f = do + i <- getCPUTime + let g3 :: Tree + g3 = f n + reifyGraph g3 >>= \ (Graph xs _) -> putStr $ show (length xs) + j <- getCPUTime + let t :: Float + t = fromIntegral ((j - i) `div` 1000000000) + putStrLn $ " " ++ show n ++ " ==> " ++ show (t / 1000) + return t + + +main = do + (x:args) <- getArgs + sequence [ timeme n (case x of + "sharing" -> deepTree2' + "no-sharing" -> deepTree') + | n <- map read args + ]