data-reify-0.6.3/0000755000000000000000000000000007346545000011736 5ustar0000000000000000data-reify-0.6.3/CHANGELOG.md0000755000000000000000000000140207346545000013547 0ustar0000000000000000## 0.6.3 [2020.10.12] * Fix a bug introduced in `data-reify-0.6.2` where `reifyGraph` could return `Graph`s with duplicate key-value pairs. ## 0.6.2 [2020.09.30] * Use `HashMap`s and `IntSet`s internally for slightly better performance. ## 0.6.1 * Fix warnings in GHC 7.10. ## 0.5 * Merge the mono-typed and dynamic version again, by using 'DynStableName', an unphantomized version of StableName. ## 0.4 * Use 'Int' as a synonym for 'Unique' rather than 'Data.Unique' for node ids, by popular demand. ## 0.3 * Provide two versions of 'MuRef', the mono-typed version, for trees of a single type, and the dynamic-typed version, for trees of different types. ## 0.2 * Use 'StableName's, making `data-reify` much faster. ## 0.1 * Use unsafe pointer compares. data-reify-0.6.3/Data/0000755000000000000000000000000007346545000012607 5ustar0000000000000000data-reify-0.6.3/Data/Reify.hs0000644000000000000000000001250207346545000014221 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Data.Reify ( MuRef(..), module Data.Reify.Graph, reifyGraph, reifyGraphs ) where import Control.Concurrent.MVar import qualified Data.HashMap.Lazy as HM import Data.HashMap.Lazy (HashMap) import Data.Hashable as H import Data.Reify.Graph import qualified Data.IntSet as IS import Data.IntSet (IntSet) import System.Mem.StableName #if !(MIN_VERSION_base(4,7,0)) import Unsafe.Coerce #endif #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative import Data.Traversable #endif -- | '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, 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's rather than recursive values. reifyGraph :: (MuRef s) => s -> IO (Graph (DeRef s)) reifyGraph m = do rt1 <- newMVar HM.empty uVar <- newMVar 0 reifyWithContext rt1 uVar m -- | 'reifyGraphs' takes a 'Traversable' container 't s' of a data structure 's' -- admitting 'MuRef', and returns a 't (Graph (DeRef s))' with the graph nodes -- resolved within the same context. -- -- This allows for, e.g., a list of mutually recursive structures. reifyGraphs :: (MuRef s, Traversable t) => t s -> IO (t (Graph (DeRef s))) reifyGraphs coll = do rt1 <- newMVar HM.empty uVar <- newMVar 0 traverse (reifyWithContext rt1 uVar) coll -- NB: We deliberately reuse the same map of stable -- names and unique supply across all iterations of the -- traversal to ensure that the same context is used -- when reifying all elements of the container. -- Reify a data structure's 'Graph' using the supplied map of stable names and -- unique supply. reifyWithContext :: (MuRef s) => MVar (HashMap DynStableName Unique) -> MVar Unique -> s -> IO (Graph (DeRef s)) reifyWithContext rt1 uVar j = do rt2 <- newMVar [] nodeSetVar <- newMVar IS.empty root <- findNodes rt1 rt2 uVar nodeSetVar j pairs <- readMVar rt2 return (Graph pairs root) -- The workhorse for 'reifyGraph' and 'reifyGraphs'. findNodes :: (MuRef s) => MVar (HashMap DynStableName Unique) -- ^ A map of stable names to unique numbers. -- Invariant: all 'Uniques' that appear in the range are less -- than the current value in the unique name supply. -> MVar [(Unique,DeRef s Unique)] -- ^ The key-value pairs in the 'Graph' that is being built. -- Invariant 1: the domain of this association list is a subset -- of the range of the map of stable names. -- Invariant 2: the domain of this association list will never -- contain duplicate keys. -> MVar Unique -- ^ A supply of unique names. -> MVar IntSet -- ^ The unique numbers that we have encountered so far. -- Invariant: this set is a subset of the range of the map of -- stable names. -> s -- ^ The value for which we will reify a 'Graph'. -> IO Unique -- ^ The unique number for the value above. findNodes rt1 rt2 uVar nodeSetVar !j = do st <- makeDynStableName j tab <- takeMVar rt1 nodeSet <- takeMVar nodeSetVar case HM.lookup st tab of Just var -> do putMVar rt1 tab if var `IS.member` nodeSet then do putMVar nodeSetVar nodeSet return var else recurse var nodeSet Nothing -> do var <- newUnique uVar putMVar rt1 $ HM.insert st var tab recurse var nodeSet where recurse :: Unique -> IntSet -> IO Unique recurse var nodeSet = do putMVar nodeSetVar $ IS.insert var nodeSet res <- mapDeRef (findNodes rt1 rt2 uVar nodeSetVar) j tab' <- takeMVar rt2 putMVar rt2 $ (var,res) : tab' return var newUnique :: MVar Unique -> IO Unique newUnique var = do v <- takeMVar var let v' = succ v putMVar var v' return v' -- Stable names that do not use phantom types. -- As suggested by Ganesh Sittampalam. -- Note: GHC can't unpack these because of the existential -- quantification, but there doesn't seem to be much -- potential to unpack them anyway. data DynStableName = forall a. DynStableName !(StableName a) instance Hashable DynStableName where hashWithSalt s (DynStableName n) = hashWithSalt s n instance Eq DynStableName where DynStableName m == DynStableName n = #if MIN_VERSION_base(4,7,0) eqStableName m n #else m == unsafeCoerce n #endif makeDynStableName :: a -> IO DynStableName makeDynStableName a = do st <- makeStableName a return $ DynStableName st data-reify-0.6.3/Data/Reify/0000755000000000000000000000000007346545000013665 5ustar0000000000000000data-reify-0.6.3/Data/Reify/Graph.hs0000644000000000000000000000221207346545000015257 0ustar0000000000000000-- | -- Module: Data.Reify.Graph -- Copyright: (c) 2009 Andy Gill -- License: BSD3 -- -- Maintainer: Andy Gill -- Stability: unstable -- Portability: ghc -- -- This is the shared definition of a 'Graph' in Data.Reify. {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module Data.Reify.Graph ( Graph(..), Unique ) where -- | 'Graph' is a basic graph structure over nodes of the higher kind 'e', with a single root. -- There is an assumption that there is no Unique used in a node which does not have a -- corresponding entry is the association list. -- The idea with this structure is that it is trivial to convert into an 'Array', -- 'IntMap', or into a Martin Erwig's Functional Graph, as required. data Graph e = Graph [(Unique,e Unique)] Unique type Unique = Int -- | If 'e' is s Functor, and 'e' is 'Show'-able, then we can 'Show' a 'Graph'. instance (Show (e Unique)) => Show (Graph e) where show (Graph netlist start) = "let " ++ show [ (u,e) | (u,e) <- netlist ] ++ " in " ++ show start data-reify-0.6.3/LICENSE0000644000000000000000000000256107346545000012747 0ustar0000000000000000Copyright (c) 2009 Andy Gill All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The names of the authors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. data-reify-0.6.3/README.md0000755000000000000000000000267507346545000013232 0ustar0000000000000000# data-reify [![Hackage version](https://img.shields.io/hackage/v/data-reify.svg?style=flat)](http://hackage.haskell.org/package/data-reify) [![Build Status](https://img.shields.io/travis/ku-fpg/data-reify.svg?style=flat)](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-0.6.3/Setup.hs0000644000000000000000000000005607346545000013373 0ustar0000000000000000import Distribution.Simple main = defaultMain data-reify-0.6.3/data-reify.cabal0000644000000000000000000001035507346545000014753 0ustar0000000000000000Name: data-reify Version: 0.6.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, 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 several examples of this are provided. . © 2009 Andy Gill; BSD3 license. Category: Language, Data, Parsing, Reflection License: BSD3 License-file: LICENSE Author: Andy Gill Maintainer: Andy Gill Copyright: (c) 2009 Andy Gill Homepage: http://ku-fpg.github.io/software/data-reify/ Stability: alpha build-type: Simple Cabal-Version: >= 1.10 tested-with: GHC == 7.0.4 , GHC == 7.2.2 , GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.3 , GHC == 8.10.1 extra-source-files: CHANGELOG.md, README.md source-repository head type: git location: https://github.com/ku-fpg/data-reify Flag tests Description: Enable full development tree Default: False Library Build-Depends: base >= 4 && < 5, hashable, containers, unordered-containers Exposed-modules: Data.Reify, Data.Reify.Graph Ghc-Options: -Wall if impl(ghc >= 8.6) ghc-options: -Wno-star-is-type default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: Data.ReifySpec build-depends: base >= 4 && < 5 , base-compat >= 0.11 && < 0.12 , data-reify , hspec == 2.* build-tool-depends: hspec-discover:hspec-discover == 2.* hs-source-dirs: spec default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts Executable data-reify-test1 Build-Depends: base, data-reify Main-Is: Test1.hs Hs-Source-Dirs: test ghc-options: -Wall default-language: Haskell2010 if !flag(tests) buildable: False Executable data-reify-test2 Build-Depends: base, data-reify Main-Is: Test2.hs Hs-Source-Dirs: test ghc-options: -Wall default-language: Haskell2010 if !flag(tests) buildable: False Executable data-reify-test3 Build-Depends: base, data-reify Main-Is: Test3.hs Hs-Source-Dirs: test ghc-options: -Wall default-language: Haskell2010 if !flag(tests) buildable: False Executable data-reify-test4 Build-Depends: base, data-reify Main-Is: Test4.hs Hs-Source-Dirs: test ghc-options: -Wall default-language: Haskell2010 if !flag(tests) buildable: False Executable data-reify-test5 Build-Depends: base, data-reify Main-Is: Test5.hs Hs-Source-Dirs: test ghc-options: -Wall default-language: Haskell2010 if !flag(tests) buildable: False Executable data-reify-test6 Build-Depends: base, data-reify Main-Is: Test6.hs Hs-Source-Dirs: test ghc-options: -Wall default-language: Haskell2010 if !flag(tests) buildable: False Executable data-reify-test7 Build-Depends: base, data-reify Main-Is: Test7.hs Hs-Source-Dirs: test ghc-options: -Wall default-language: Haskell2010 if !flag(tests) buildable: False data-reify-0.6.3/spec/Data/0000755000000000000000000000000007346545000013541 5ustar0000000000000000data-reify-0.6.3/spec/Data/ReifySpec.hs0000644000000000000000000000172707346545000015775 0ustar0000000000000000{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.ReifySpec where import qualified Data.List as L import Data.Reify import Prelude () import Prelude.Compat import Test.Hspec main :: IO () main = hspec spec spec :: Spec spec = parallel $ describe "reifyGraph" $ it "should produce a Graph with unique key-value pairs" $ do -- #11 g <- reifyGraph s1 nubGraph g `shouldBe` g data State = State Char [State] deriving (Eq, Show) data StateDeRef r = StateDeRef Char [r] deriving (Eq, Show) s1, s2, s3 :: State s1 = State 'a' [s2,s3] s2 = State 'b' [s1,s2] s3 = State 'c' [s2,s1] instance MuRef State where type DeRef State = StateDeRef mapDeRef f (State a tr) = StateDeRef a <$> traverse f tr nubGraph :: Eq (e Unique) => Graph e -> Graph e nubGraph (Graph netlist start) = Graph (L.nub netlist) start deriving instance Eq (e Unique) => Eq (Graph e) data-reify-0.6.3/spec/0000755000000000000000000000000007346545000012670 5ustar0000000000000000data-reify-0.6.3/spec/Spec.hs0000644000000000000000000000005407346545000014115 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} data-reify-0.6.3/test/0000755000000000000000000000000007346545000012715 5ustar0000000000000000data-reify-0.6.3/test/Test1.hs0000644000000000000000000000243107346545000014251 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module Main (main) where import Control.Applicative hiding (Const) import qualified Data.Foldable as F 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 type DeRef (Mu a) = a -- deRef (In a) = a mapDeRef f (In a) = T.traverse f a data List a b = Cons a b | Nil deriving Show type MyList a = Mu (List a) instance Functor (List a) where fmap _ Nil = Nil fmap f (Cons a b) = Cons a (f b) instance F.Foldable (List a) where 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 _ 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 :: 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 :: MyList Int g3 = count 1 1000 reifyGraph g3 >>= print data-reify-0.6.3/test/Test2.hs0000644000000000000000000000247507346545000014262 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module Main (main) where import Control.Applicative hiding (Const) import Data.Reify import qualified Data.Traversable as T 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)] data StateDeRef a b r = StateDeRef a [(b,r)] deriving Show instance MuRef (State a b) where type DeRef (State a b) = StateDeRef a b 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 ] main :: IO () main = do reifyGraph s0 >>= print reifyGraphs [s0, s1] >>= 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 -} data-reify-0.6.3/test/Test3.hs0000644000000000000000000000760307346545000014261 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module Main (main) where import Control.Applicative hiding (Const) import qualified Data.Foldable as F import Data.Monoid import Data.Reify import qualified Data.Traversable as T import Prelude data Signal = Signal (Circuit Signal) -- Call this 'Circuit' data Circuit c = And2 (c,c) | Xor2 (c,c) | Mux2 c (c,c) | Delay c | Const BitValue | Var String deriving (Eq,Ord) -- newtype Mu a = In (a (Mu a)) instance MuRef Signal where type DeRef Signal = Circuit mapDeRef f (Signal s) = T.traverse f s instance Show Signal where show (Signal b) = show b instance Show c => Show (Circuit c) where show (Const bv) = show bv show (And2 (b1,b2)) = "and(" ++ show b1 ++ "," ++ show b2 ++ ")" show (Xor2 (b1,b2)) = "xor(" ++ show b1 ++ "," ++ show b2 ++ ")" show (Mux2 s (b1,b2)) = "mux(" ++ show s ++ "," ++ show b1 ++ "," ++ show b2 ++ ")" 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 :: 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 instance Show BitValue where show High = "high" show Low = "low" halfAdder :: (Signal,Signal) -> (Signal,Signal) halfAdder (a,b) = (carry,sum') where carry = and2 (a,b) sum' = xor2 (a,b) fullAdder :: (Signal,(Signal,Signal)) -> (Signal,Signal) fullAdder (cin,(a,b)) = (cout,sum') where (car1,sum1) = halfAdder (a,b) (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 (Mux2 s (e1,e2)) = f s `mappend` f e1 `mappend` f e2 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 (Mux2 s (e1,e2)) = Mux2 (f s) (f e1,f e2) 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 _ (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 _ _ (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) 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] :: [Int] ]) reifyGraph g2 >>= print data-reify-0.6.3/test/Test4.hs0000644000000000000000000000222307346545000014253 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Control.Applicative hiding (Const) import Data.Reify import System.CPUTime import Prelude data List a b = Nil | Cons a b deriving Show instance MuRef [a] where type DeRef [a] = List a mapDeRef f (x:xs) = Cons x <$> f xs mapDeRef _ [] = pure Nil instance Functor (List a) where fmap _ Nil = Nil fmap f (Cons a b) = Cons a (f b) main :: IO () main = do let g1 :: [Int] g1 = [1..10] reifyGraph g1 >>= print 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' data-reify-0.6.3/test/Test5.hs0000644000000000000000000000222407346545000014255 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Control.Applicative hiding (Const) import Data.Dynamic import Data.Reify import System.CPUTime import Prelude 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 _ [] = pure Nil instance Functor (List a) where fmap _ Nil = Nil fmap f (Cons a b) = Cons a (f b) main :: IO () 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' data-reify-0.6.3/test/Test6.hs0000644000000000000000000000537007346545000014263 0ustar0000000000000000{-# LANGUAGE TypeFamilies, UndecidableInstances, DeriveDataTypeable, RankNTypes, ExistentialQuantification #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Control.Applicative hiding (Const) import Data.Dynamic import Data.Reify import System.CPUTime 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 _ 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 _ [] = 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 _ (ExpVar _) = pure Var mapDeRef _ (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 _ 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 _ Var = Var fmap f (Add a b) = Add (f a) (f b) main :: IO () 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 :: [[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' -- capture :: (Typeable a, Typeable b, NewVar a) => (a -> b) -> (a,b) -- capture f = (a,f a) -- where a = mkVar (toDyn f) data-reify-0.6.3/test/Test7.hs0000644000000000000000000000313607346545000014262 0ustar0000000000000000{-# LANGUAGE TypeFamilies, UndecidableInstances, DeriveDataTypeable, RankNTypes, ExistentialQuantification #-} module Main (main) where import Control.Applicative hiding (Const) import Data.Reify import Data.Typeable import System.CPUTime import System.Environment import Prelude 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 _ (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 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' :: Int -> Tree 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 :: IO () main = do (x:args) <- getArgs sequence_ [ timeme n (case x of "sharing" -> deepTree2' "no-sharing" -> deepTree') | n <- map read args ]