data-reify 0.4 → 0.5

raw patch · 6 files changed

+111/−111 lines, 6 filesdep ~basenew-component:exe:data-reify-test7PVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Data/Dynamic/Reify.hs +0/−90
• Data/Reify.hs +32/−15
• data-reify.cabal +12/−4
• test/Test5.hs +1/−1
• test/Test6.hs +1/−1
• test/Test7.hs +65/−0

@@ -1,90 +0,0 @@--- |--- 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 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'-  -  -  

@@ -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)+	

@@ -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. 		    . 		    &#169; 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

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

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

@@ -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+           ]