data-reify 0.2 → 0.3

raw patch · 11 files changed

+378/−87 lines, 11 filesnew-component:exe:data-reify-test5new-component:exe:data-reify-test6PVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Dynamic/Reify.hs +79/−0
• Data/Reify.hs +62/−0
• Data/Reify/Graph.hs +30/−0
• Data/Unsafe/Reify.hs +0/−67
• data-reify.cabal +22/−6
• test/Test1.hs +3/−3
• test/Test2.hs +22/−3
• test/Test3.hs +2/−3
• test/Test4.hs +3/−5
• test/Test5.hs +48/−0
• test/Test6.hs +107/−0

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

@@ -0,0 +1,62 @@+{-# LANGUAGE UndecidableInstances, TypeFamilies #-}+module Data.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 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)+++-- | '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 M.empty+                  rt2 <- newMVar []+                  root <- findNodes rt1 rt2 m+                  pairs <- readMVar rt2+                  return (Graph pairs root)+++findNodes :: (MuRef s) +          => MVar (IntMap [(StableName s,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) [(st,var)] tab+                       res <- mapDeRef (findNodes rt1 rt2) 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

@@ -0,0 +1,30 @@+-- |+-- Module: Data.Reify.Graph+-- Copyright: (c) 2009 Andy Gill+-- License: BSD3+--+-- Maintainer: Andy Gill <andygill@ku.edu>+-- Stability: unstable+-- Portability: ghc+--+-- This is the shared definition of a 'Graph' in Data.Reify.+++{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}++module Data.Reify.Graph (+        Graph(..),+        ) where++import Data.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+++-- | If 'e' is s Functor, and 'e' is 'Show'-able, then we can 'Show' a 'Graph'.+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)+

@@ -1,67 +0,0 @@-{-# 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- 

@@ -1,19 +1,21 @@ Name:               data-reify-Version:            0.2+Version:            0.3 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 		    a type class instance. This gives an alternative to using 'Ref' for observable sharing. 		    .-		    Observable sharing in general is unsafe (hence the module path name Data.Unsafe.Reify), -		    but can be used safely if some simple conditions are met.+		    Observable sharing in general is unsafe, so we use the IO monad to bound this effect,+		    but can be used safely even with 'unsafePerformIO' if some simple conditions are met. 		    Typically this package will be used to tie the knot with DSL's that depend of 		    observable sharing, like Lava.  		    . 		    Providing an instance for 'MuRef' is the mechanism for allowing a structure to be -		    reified into a graph, and four examples of this are provided.+		    reified into a graph, and several examples of this are provided. 		    .-		    Version 0.2 of data-reify uses 'StableName's, and is much faster.+		    Version 0.2 of 'data-reify' uses 'StableName's, and is 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. 		    . 		    © 2009 Andy Gill; BSD3 license. @@ -31,7 +33,9 @@ Library   Build-Depends: base, containers   Exposed-modules:-       Data.Unsafe.Reify+       Data.Reify,+       Data.Dynamic.Reify,+       Data.Reify.Graph   Ghc-Options:  -Wall  @@ -56,5 +60,17 @@ Executable data-reify-test4   Build-Depends:  base   Main-Is:        Test4.hs+  Hs-Source-Dirs: ., test+  buildable: False++Executable data-reify-test5+  Build-Depends:  base+  Main-Is:        Test5.hs+  Hs-Source-Dirs: ., test+  buildable: False++Executable data-reify-test6+  Build-Depends:  base+  Main-Is:        Test6.hs   Hs-Source-Dirs: ., test   buildable: False

@@ -6,15 +6,15 @@ import Data.Monoid import Control.Applicative hiding (Const) import Data.Unique-import Data.Unsafe.Reify+import Data.Reify  newtype Mu a = In (a (Mu a))  instance (T.Traversable a) => MuRef (Mu a) where   type DeRef (Mu a) = a-  deRef (In a) = a+--  deRef (In a) = a   -  mapDeRef = T.mapM+  mapDeRef f (In a) = T.traverse f a  data List a b = Cons a b | Nil         deriving Show

@@ -6,7 +6,7 @@ import Data.Monoid import Control.Applicative hiding (Const) import Data.Unique-import Data.Unsafe.Reify+import Data.Reify import Control.Monad  -- Notice how there is nothing Mu-ish about this datatype.@@ -22,8 +22,8 @@  instance MuRef (State a b) where    type DeRef (State a b) = StateDeRef  a b-   deRef (State a tr) = StateDeRef a tr-   mapDeRef f (StateDeRef a tr) = liftM (StateDeRef a) $ mapM (\ (b,s) -> liftM ((,) b) $ (f s)) tr+   mapDeRef f (State a tr) = StateDeRef a <$>+            T.traverse (\ (b,s) -> ((,) b) <$> (f s)) tr  instance Functor (StateDeRef a b) where    fmap f (StateDeRef a tr) = StateDeRef a [ (b,f s) | (b,s) <- tr ]@@ -33,5 +33,24 @@         reifyGraph s0 >>= print          +{- Alt:++data State s i o = State s [(i,o,State s i o)]+        deriving Show         +state :: s -> State s i o+state s = State s []++infixl 4 %%+(%%) :: State s i o -> (i,o,State s i o) -> State s i o+(State s ts) %% (i,o,st) = State s $ (ts ++ [(i,o,st)])++s0 = state () %% (True,True,s1) %% (False,False,s0)+s1 = state () %% (True,False,s0) %% (False,True,s1)++data MuState s i o r = MuState s [(i,o,r)]+        deriving Show++-}+      

@@ -8,7 +8,7 @@ import Data.Unique import Control.Monad -import Data.Unsafe.Reify+import Data.Reify           data Signal = Signal (Circuit Signal)@@ -27,9 +27,8 @@  instance MuRef Signal where   type DeRef Signal = Circuit-  deRef (Signal s) = s   -  mapDeRef = T.mapM+  mapDeRef f (Signal s) = T.traverse f s   instance Show Signal where   show (Signal b) = show b

@@ -8,7 +8,7 @@ import Control.Applicative hiding (Const) import Data.Unique -import Data.Unsafe.Reify+import Data.Reify import Control.Monad import System.CPUTime @@ -18,11 +18,9 @@  instance MuRef [a] where   type DeRef [a] = List a -  deRef []     = Nil-  deRef (x:xs) = Cons x xs -  mapDeRef f (Cons x xs) = liftM (Cons x) $ f xs-  mapDeRef f Nil         = return Nil+  mapDeRef f (x:xs) = Cons x <$> f xs+  mapDeRef f []     = pure Nil    instance Functor (List a) where    fmap f Nil = Nil

@@ -0,0 +1,48 @@+{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}+module Main where++import qualified Data.Traversable as T+import qualified Data.Foldable as F+import Data.Monoid+import Control.Applicative hiding (Const)+import Data.Unique+import Data.Dynamic.Reify+import Data.Dynamic++import Control.Monad+import System.CPUTime++data List a b = Nil | Cons a b+  deriving Show++instance Typeable a => MuRef [a] where+  type DeRef [a] = List a ++  mapDeRef f (x:xs) = Cons x <$> f xs+  mapDeRef f []     = pure Nil+++instance Functor (List a) where+   fmap f Nil = Nil+   fmap f (Cons a b) = Cons a (f b)++main = do+        let g1 = [1..(10::Int)]+        reifyGraph g1 >>= print+        let g2 = [1..(10::Int)] ++ g2+        reifyGraph g2 >>= print++        -- now, some timings.+        ns <- sequence [ timeme n | n <- take 8 (iterate (*2) 1024) ]+        print $ reverse $ take 4 $ reverse [ n2 / n1 | (n1,n2) <- zip ns (tail ns) ]++timeme :: Int -> IO Float+timeme n = do+        i <- getCPUTime+        let g3 = [1..n] ++ g3+        reifyGraph g3 >>= \ (Graph xs _) -> putStr $ show (length xs)+        j <- getCPUTime+        let n :: Float+            n = fromIntegral ((j - i) `div` 1000000000)+        putStrLn $ " ==> " ++ show (n / 1000)   +        return n    

@@ -0,0 +1,107 @@+{-# LANGUAGE TypeFamilies, UndecidableInstances, DeriveDataTypeable, RankNTypes, ExistentialQuantification      #-}+module Main where++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 Data.Dynamic.Reify+import Control.Monad+import System.CPUTime+import Data.Typeable+import Control.Exception as E++import Data.Dynamic++data List b = Nil | Cons b b | Int Int | Lambda b b | Var | Add b b+  deriving Show++instance MuRef Int where+  type DeRef Int = List ++  mapDeRef f n = pure $ Int n++instance (Typeable a, MuRef a,DeRef [a] ~ DeRef a) => MuRef [a] where+  type DeRef [a] = List +  +  mapDeRef f (x:xs) = liftA2 Cons (f x) (f xs)+  mapDeRef f []     = pure Nil+++instance NewVar Exp where+  mkVar = ExpVar+--          return $ Var $ toDyn fn++data Exp = ExpVar Dynamic | ExpLit Int | ExpAdd Exp Exp+  deriving (Typeable, Show)+  +  +instance Eq Exp where+    _ == _ = False+    +-- instance Eq Dynamic where { a == b = False }++instance MuRef Exp where+  type DeRef Exp = List+  +  mapDeRef f (ExpVar _)   = pure Var+  mapDeRef f (ExpLit i)   = pure $ Int i+  mapDeRef f (ExpAdd x y) = Add <$> f x <*> f y+++instance Num Exp where+    (+) = ExpAdd+    fromInteger n = ExpLit (fromInteger n)+    +instance (MuRef a,Typeable a, NewVar a, Typeable b, MuRef b, DeRef a ~ DeRef (a -> b),DeRef b ~ DeRef (a -> b)) => MuRef (a -> b) where+  type DeRef (a -> b) = List++  mapDeRef f fn = let v = mkVar $ toDyn fn +                  in Lambda <$> f v <*> f (fn v)++class NewVar a where+  mkVar :: Dynamic -> a++instance Functor (List) where+   fmap f Nil = Nil+   fmap f (Cons a b) = Cons (f a) (f b)+   fmap f (Int n)    = Int n+   fmap f (Lambda a b) = Lambda (f a) (f b)+   fmap f Var   = Var+   fmap f (Add a b) = Add (f a) (f b)++main = do+        let g1 :: [Int]+            g1 = [1..10]+        reifyGraph g1 >>= print+        let g2 :: [Int]+            g2 = [1..10] ++ g2+        reifyGraph g2 >>= print++        let g3 = [\ x -> x :: Exp, \ y -> y + head g3 2] ++ g3+        reifyGraph g3 >>= print+        +        -- now, some timings.+        ns <- sequence [ timeme n | n <- take 8 (iterate (*2) 1024) ]+        print $ reverse $ take 4 $ reverse [ n2 / n1 | (n1,n2) <- zip ns (tail ns) ]++zz = let xs = [1..3] +         ys = (0::Int) : xs+     in cycle [xs,ys,tail ys]+timeme n = do+        i <- getCPUTime+        let g3 :: [Int]+            g3 = [1..n] ++ g3+        reifyGraph g3 >>= \ (Graph xs _) -> putStr $ show (length xs)+        j <- getCPUTime+        let n :: Float+            n = fromIntegral ((j - i) `div` 1000000000)+        putStrLn $ " ==> " ++ show (n / 1000)   +        return n    +        +capture :: (Typeable a, Typeable b, NewVar a) => (a -> b) -> (a,b)+capture f = (a,f a)+  where a = mkVar (toDyn f)