data-reify 0.6 → 0.6.1
raw patch · 11 files changed
+199/−172 lines, 11 filesdep +data-reifynew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: data-reify
API changes (from Hackage documentation)
Files
- CHANGELOG.md +2/−0
- Data/Reify.hs +11/−9
- README.md +9/−0
- data-reify.cabal +29/−17
- test/Test1.hs +17/−13
- test/Test2.hs +9/−11
- test/Test3.hs +49/−43
- test/Test4.hs +15/−15
- test/Test5.hs +14/−13
- test/Test6.hs +29/−31
- test/Test7.hs +15/−20
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+## 0.6.1+* Fixed warnings in GHC 7.10
Data/Reify.hs view
@@ -1,19 +1,22 @@-{-# LANGUAGE TypeFamilies, RankNTypes #-}+{-# LANGUAGE TypeFamilies, RankNTypes #-} module Data.Reify ( MuRef(..), module Data.Reify.Graph, reifyGraph ) where +import Control.Applicative import Control.Concurrent.MVar-import System.Mem.StableName-import Data.IntMap as M-import Unsafe.Coerce -import Control.Applicative+import Data.IntMap as M import Data.Reify.Graph +import System.Mem.StableName +import Unsafe.Coerce++import Prelude+ -- | 'MuRef' is a class that provided a way to reference into a specific type, -- and a way to map over the deferenced internals. @@ -78,10 +81,9 @@ hashDynStableName (DynStableName sn) = hashStableName sn instance Eq DynStableName where- (DynStableName sn1) == (DynStableName sn2) = sn1 == sn2+ (DynStableName sn1) == (DynStableName sn2) = sn1 == sn2 makeDynStableName :: a -> IO DynStableName makeDynStableName a = do- st <- makeStableName a- return $ DynStableName (unsafeCoerce st)- + st <- makeStableName a+ return $ DynStableName (unsafeCoerce st)
+ README.md view
@@ -0,0 +1,9 @@+# data-reify [](http://hackage.haskell.org/package/data-reify) [](https://travis-ci.org/ku-fpg/data-reify)++`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, 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 DSLs 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 several examples of this are provided.++History: Version 0.1 used unsafe pointer compares. Version 0.2 of `data-reify` used StableNames, 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 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`.
data-reify.cabal view
@@ -1,5 +1,5 @@ Name: data-reify-Version: 0.6+Version: 0.6.1 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@@ -33,10 +33,15 @@ Maintainer: Andy Gill <andygill@ku.edu> Copyright: (c) 2009 Andy Gill Homepage: http://www.ittc.ku.edu/csdl/fpg/Tools/IOReification-Stability: alpha+Stability: alpha build-type: Simple-Cabal-Version: >= 1.6+Cabal-Version: >= 1.8+extra-source-files: CHANGELOG.md, README.md +source-repository head+ type: git+ location: git://github.com/ku-fpg/data-reify+ Flag tests Description: Enable full development tree Default: False@@ -50,51 +55,58 @@ Ghc-Options: -Wall Executable data-reify-test1- Build-Depends: base+ Build-Depends: base, data-reify Main-Is: Test1.hs- Hs-Source-Dirs: ., test+ Hs-Source-Dirs: test+ ghc-options: -Wall if !flag(tests) buildable: False Executable data-reify-test2- Build-Depends: base+ Build-Depends: base, data-reify Main-Is: Test2.hs- Hs-Source-Dirs: ., test+ Hs-Source-Dirs: test+ ghc-options: -Wall if !flag(tests) buildable: False Executable data-reify-test3- Build-Depends: base+ Build-Depends: base, data-reify Main-Is: Test3.hs- Hs-Source-Dirs: ., test+ Hs-Source-Dirs: test+ ghc-options: -Wall if !flag(tests) buildable: False Executable data-reify-test4- Build-Depends: base+ Build-Depends: base, data-reify Main-Is: Test4.hs- Hs-Source-Dirs: ., test+ Hs-Source-Dirs: test+ ghc-options: -Wall if !flag(tests) buildable: False Executable data-reify-test5- Build-Depends: base+ Build-Depends: base, data-reify Main-Is: Test5.hs- Hs-Source-Dirs: ., test+ Hs-Source-Dirs: test+ ghc-options: -Wall if !flag(tests) buildable: False Executable data-reify-test6- Build-Depends: base+ Build-Depends: base, data-reify Main-Is: Test6.hs- Hs-Source-Dirs: ., test+ Hs-Source-Dirs: test+ ghc-options: -Wall if !flag(tests) buildable: False Executable data-reify-test7- Build-Depends: base+ Build-Depends: base, data-reify Main-Is: Test7.hs- Hs-Source-Dirs: ., test+ Hs-Source-Dirs: test+ ghc-options: -Wall if !flag(tests) buildable: False
test/Test1.hs view
@@ -1,13 +1,15 @@ {-# LANGUAGE TypeFamilies #-}-module Main where+module Main (main) where -import qualified Data.Traversable as T+import Control.Applicative hiding (Const)+ import qualified Data.Foldable as F-import Data.Monoid-import Control.Applicative hiding (Const)-import Data.Unique-import Data.Reify+import Data.Monoid+import Data.Reify+import qualified Data.Traversable as T +import Prelude+ newtype Mu a = In (a (Mu a)) instance (T.Traversable a) => MuRef (Mu a) where@@ -22,27 +24,29 @@ type MyList a = Mu (List a) instance Functor (List a) where- fmap f Nil = Nil+ fmap _ Nil = Nil fmap f (Cons a b) = Cons a (f b) instance F.Foldable (List a) where- foldMap f Nil = mempty- foldMap f (Cons a b) = f b+ foldMap _ Nil = mempty+ foldMap f (Cons _ b) = f b instance T.Traversable (List a) where traverse f (Cons a b) = Cons <$> pure a <*> f b- traverse f Nil = pure Nil-+ traverse _ Nil = pure Nil +main :: IO () main = do let g1 :: MyList Int g1 = In (Cons 1 (In (Cons 2 (In Nil)))) reifyGraph g1 >>= print- let g2 = In (Cons 1 (In (Cons 2 g2)))+ let g2 :: MyList Int+ g2 = In (Cons 1 (In (Cons 2 g2))) reifyGraph g2 >>= print let count n m | n == m = In Nil | otherwise = In (Cons n (count (succ n) m)) - let g3 = count 1 1000 + let g3 :: MyList Int+ g3 = count 1 1000 reifyGraph g3 >>= print
test/Test2.hs view
@@ -1,18 +1,18 @@ {-# LANGUAGE TypeFamilies #-}-module Main where+module Main (main) where +import Control.Applicative hiding (Const)++import Data.Reify 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.Reify-import Control.Monad +import Prelude+ -- Notice how there is nothing Mu-ish about this datatype. data State a b = State a [(b,State a b)] deriving Show +s0, s1, s2 :: State Int Bool s0 = State 0 [(True,s1),(False,s2)] s1 = State 1 [(True,s0),(False,s1)] s2 = State 2 [(True,s1),(False,s0)]@@ -28,10 +28,8 @@ instance Functor (StateDeRef a b) where fmap f (StateDeRef a tr) = StateDeRef a [ (b,f s) | (b,s) <- tr ] --main = do- reifyGraph s0 >>= print-+main :: IO ()+main = reifyGraph s0 >>= print {- Alt:
test/Test3.hs view
@@ -1,15 +1,14 @@ {-# LANGUAGE TypeFamilies #-}-module Main where+module Main (main) where -import qualified Data.Traversable as T+import Control.Applicative hiding (Const)+ import qualified Data.Foldable as F-import Data.Monoid-import Control.Applicative hiding (Const)-import Data.Unique-import Control.Monad+import Data.Monoid+import Data.Reify+import qualified Data.Traversable as T -import Data.Reify- +import Prelude data Signal = Signal (Circuit Signal) @@ -23,7 +22,7 @@ | Var String deriving (Eq,Ord) -newtype Mu a = In (a (Mu a))+-- newtype Mu a = In (a (Mu a)) instance MuRef Signal where type DeRef Signal = Circuit@@ -41,17 +40,25 @@ show (Delay b) = "delay(" ++ show b ++ ")" show (Var str) = show str +and2 :: (Signal, Signal) -> Signal and2 (s1,s2) = Signal (And2 (s1,s2))++xor2 :: (Signal, Signal) -> Signal xor2 (s1,s2) = Signal (Xor2 (s1,s2))++mux2 :: Signal -> (Signal, Signal) -> Signal mux2 s (s1,s2) = Signal (Mux2 s (s1,s2))-delay s = Signal (Delay s) +-- delay :: Signal -> Signal+-- delay s = Signal (Delay s)+ pad :: String -> Signal pad nm = Signal (Var nm) data BitValue = High | Low deriving (Eq,Ord) +high, low :: Signal high = Signal $ Const High low = Signal $ Const Low @@ -60,65 +67,64 @@ show Low = "low" halfAdder :: (Signal,Signal) -> (Signal,Signal)-halfAdder (a,b) = (carry,sum)+halfAdder (a,b) = (carry,sum') where carry = and2 (a,b)- sum = xor2 (a,b)+ sum' = xor2 (a,b) fullAdder :: (Signal,(Signal,Signal)) -> (Signal,Signal)-fullAdder (cin,(a,b)) = (cout,sum)+fullAdder (cin,(a,b)) = (cout,sum') where (car1,sum1) = halfAdder (a,b)- (car2,sum) = halfAdder (cin,sum1)- cout = xor2 (car1,car2)+ (car2,sum') = halfAdder (cin,sum1)+ cout = xor2 (car1,car2) instance F.Foldable Circuit where- foldMap f (And2 (e1,e2)) = f e1 `mappend` f e2- foldMap f (Xor2 (e1,e2)) = f e1 `mappend` f e2+ foldMap f (And2 (e1,e2)) = f e1 `mappend` f e2+ foldMap f (Xor2 (e1,e2)) = f e1 `mappend` f e2 foldMap f (Mux2 s (e1,e2)) = f s `mappend` f e1 `mappend` f e2- foldMap f (Delay s) = f s- foldMap f (Const _) = mempty- foldMap f (Var _) = mempty+ foldMap f (Delay s) = f s+ foldMap _ (Const _) = mempty+ foldMap _ (Var _) = mempty instance Functor Circuit where- fmap f (And2 (e1,e2)) = And2 (f e1,f e2)- fmap f (Xor2 (e1,e2)) = Xor2 (f e1,f e2)+ fmap f (And2 (e1,e2)) = And2 (f e1,f e2)+ fmap f (Xor2 (e1,e2)) = Xor2 (f e1,f e2) fmap f (Mux2 s (e1,e2)) = Mux2 (f s) (f e1,f e2)- fmap f (Delay s) = Delay (f s)- fmap f (Const a) = Const a- fmap f (Var a) = Var a+ fmap f (Delay s) = Delay (f s)+ fmap _ (Const a) = Const a+ fmap _ (Var a) = Var a instance T.Traversable Circuit where- traverse f (And2 (e1,e2)) = (\ x y -> And2 (x,y)) <$> f e1 <*> f e2- traverse f (Xor2 (e1,e2)) = (\ x y -> Xor2 (x,y)) <$> f e1 <*> f e2- traverse f (Mux2 c (e1,e2)) = (\ c x y -> Mux2 c (x,y)) <$> f c <*> f e1 <*> f e2- traverse f (Delay s) = Delay <$> f s- traverse f (Const a) = pure (Const a)- traverse f (Var a) = pure (Var a)+ traverse f (And2 (e1,e2)) = (\ x y -> And2 (x,y)) <$> f e1 <*> f e2+ traverse f (Xor2 (e1,e2)) = (\ x y -> Xor2 (x,y)) <$> f e1 <*> f e2+ traverse f (Mux2 c (e1,e2)) = (\ c' x y -> Mux2 c' (x,y)) <$> f c <*> f e1 <*> f e2+ traverse f (Delay s) = Delay <$> f s+ traverse _ (Const a) = pure (Const a)+ traverse _ (Var a) = pure (Var a) rowLA :: (Signal -> (b,b) -> b) -> ((Signal,a) -> (Signal,b)) -> (Signal,[a]) -> (Signal,[b])-rowLA mymux f (cin,[]) = (cin,[])-rowLA mymux f (cin,[a]) = (car,[sum])- where- (car,sum) = f (cin,a)-rowLA mymux f (cin,cs) = (mux2 cout1 (cout2_lo,cout2_hi),+rowLA _ _ (cin,[]) = (cin,[])+rowLA _ f (cin,[a]) = (car,[sum'])+ where (car,sum') = f (cin,a)+rowLA mymux f (cin,cs) = (mux2 cout1 (cout2_lo,cout2_hi), sums1 ++ [ mymux cout1 (s_lo,s_hi) | (s_lo,s_hi) <- zip sums2_lo sums2_hi ])- where- len = length cs `div` 2- (cout1,sums1) = rowLA mymux f (cin,take len cs)- (cout2_hi,sums2_hi) = rowLA mymux f (high,drop len cs)- (cout2_lo,sums2_lo) = rowLA mymux f (low,drop len cs)-+ where+ len = length cs `div` 2+ (cout1,sums1) = rowLA mymux f (cin,take len cs)+ (cout2_hi,sums2_hi) = rowLA mymux f (high,drop len cs)+ (cout2_lo,sums2_lo) = rowLA mymux f (low,drop len cs) +main :: IO () main = do let g1 = xor2 (xor2 (pad "a",pad "b"),g1) reifyGraph g1 >>= print let (g2,_) = rowLA mux2 fullAdder (pad "c",[ (pad $ "a" ++ show x,pad $ "b" ++ show x)- | x <- [1..20]+ | x <- [1..20] :: [Int] ]) reifyGraph g2 >>= print
test/Test4.hs view
@@ -1,15 +1,11 @@ {-# LANGUAGE TypeFamilies #-}-module Main where+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main (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.Reify-import Control.Monad import System.CPUTime+import Prelude data List a b = Nil | Cons a b deriving Show@@ -19,28 +15,32 @@ type DeRef [a] = List a mapDeRef f (x:xs) = Cons x <$> f xs- mapDeRef f [] = pure Nil+ mapDeRef _ [] = pure Nil instance Functor (List a) where- fmap f Nil = Nil+ fmap _ Nil = Nil fmap f (Cons a b) = Cons a (f b) +main :: IO () main = do- let g1 = [1..10]+ let g1 :: [Int]+ g1 = [1..10] reifyGraph g1 >>= print- let g2 = [1..10] ++ g2+ let g2 :: [Int]+ g2 = [1..10] ++ 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 + let n' :: Float+ n' = fromIntegral ((j - i) `div` 1000000000)+ putStrLn $ " ==> " ++ show (n' / 1000) + return n'
test/Test5.hs view
@@ -1,16 +1,16 @@-{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}-module Main where+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main (main) where -import qualified Data.Traversable as T-import qualified Data.Foldable as F-import Data.Monoid import Control.Applicative hiding (Const)-import Data.Reify+ import Data.Dynamic+import Data.Reify -import Control.Monad import System.CPUTime +import Prelude+ data List a b = Nil | Cons a b deriving Show @@ -18,13 +18,14 @@ type DeRef [a] = List a mapDeRef f (x:xs) = Cons x <$> f xs- mapDeRef f [] = pure Nil+ mapDeRef _ [] = pure Nil instance Functor (List a) where- fmap f Nil = Nil+ fmap _ Nil = Nil fmap f (Cons a b) = Cons a (f b) +main :: IO () main = do let g1 = [1..(10::Int)] reifyGraph g1 >>= print@@ -41,7 +42,7 @@ 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 + let n' :: Float+ n' = fromIntegral ((j - i) `div` 1000000000)+ putStrLn $ " ==> " ++ show (n' / 1000) + return n'
test/Test6.hs view
@@ -1,20 +1,14 @@-{-# LANGUAGE TypeFamilies, UndecidableInstances, DeriveDataTypeable, RankNTypes, ExistentialQuantification #-}-module Main where+{-# LANGUAGE TypeFamilies, UndecidableInstances, DeriveDataTypeable,+ RankNTypes, ExistentialQuantification #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main (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.Dynamic import Data.Reify-import Control.Monad-import System.CPUTime-import Data.Typeable-import Control.Exception as E --import Data.Dynamic+import System.CPUTime data List b = Nil | Cons b b | Int Int | Lambda b b | Var | Add b b deriving Show@@ -22,13 +16,13 @@ instance MuRef Int where type DeRef Int = List - mapDeRef f n = pure $ Int n+ mapDeRef _ 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+ mapDeRef _ [] = pure Nil instance NewVar Exp where@@ -47,8 +41,8 @@ instance MuRef Exp where type DeRef Exp = List - mapDeRef f (ExpVar _) = pure Var- mapDeRef f (ExpLit i) = pure $ Int i+ mapDeRef _ (ExpVar _) = pure Var+ mapDeRef _ (ExpLit i) = pure $ Int i mapDeRef f (ExpAdd x y) = Add <$> f x <*> f y @@ -66,13 +60,14 @@ 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 _ Nil = Nil+ fmap f (Cons a b) = Cons (f a) (f b)+ fmap _ (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)+ fmap _ Var = Var+ fmap f (Add a b) = Add (f a) (f b) +main :: IO () main = do let g1 :: [Int] g1 = [1..10]@@ -88,20 +83,23 @@ 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]+-- zz :: [[Int]]+-- zz = let xs = [1..3] +-- ys = (0::Int) : xs+-- in cycle [xs,ys,tail ys]++timeme :: Int -> IO Float 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 + 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) +-- capture :: (Typeable a, Typeable b, NewVar a) => (a -> b) -> (a,b)+-- capture f = (a,f a)+-- where a = mkVar (toDyn f)
test/Test7.hs view
@@ -1,24 +1,17 @@-{-# LANGUAGE TypeFamilies, UndecidableInstances, DeriveDataTypeable, RankNTypes, ExistentialQuantification #-}-+{-# LANGUAGE TypeFamilies, UndecidableInstances, DeriveDataTypeable,+ RankNTypes, ExistentialQuantification #-}+module Main (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 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+import System.CPUTime+import System.Environment +import Prelude+ data Tree = Node Tree Tree | Leaf Int deriving (Show,Eq,Typeable) @@ -27,13 +20,14 @@ 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+ mapDeRef _ (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' :: Int -> Tree deepTree' n = deepTree n 1 deepTree2 :: Int -> Integer -> Tree -> Tree@@ -41,6 +35,7 @@ deepTree2 n v x = Node (deepTree2 (pred n) (v * 37) x) (deepTree2 (pred n) (v * 17) x) -- sharing+deepTree2' :: Int -> Tree deepTree2' n = let v = deepTree2 n 1 v in v timeme :: Int -> (Int -> Tree) -> IO Float@@ -53,13 +48,13 @@ let t :: Float t = fromIntegral ((j - i) `div` 1000000000) putStrLn $ " " ++ show n ++ " ==> " ++ show (t / 1000) - return t + return t -+main :: IO () main = do (x:args) <- getArgs- sequence [ timeme n (case x of+ sequence_ [ timeme n (case x of "sharing" -> deepTree2' "no-sharing" -> deepTree')- | n <- map read args- ]+ | n <- map read args+ ]