data-reify 0.6 → 0.6.4
raw patch · 17 files changed
Files
- CHANGELOG.md +30/−0
- Data/Reify.hs +100/−50
- Data/Reify/Graph.hs +7/−6
- README.md +9/−0
- data-reify.cabal +103/−45
- examples/example1.hs +57/−0
- examples/simplify.hs +121/−0
- spec/Data/ReifySpec.hs +39/−0
- spec/Spec.hs +1/−0
- test-common/Common.hs +15/−0
- test/Test1.hs +17/−13
- test/Test2.hs +12/−13
- test/Test3.hs +49/−43
- test/Test4.hs +19/−18
- test/Test5.hs +18/−15
- test/Test6.hs +45/−45
- test/Test7.hs +17/−23
+ CHANGELOG.md view
@@ -0,0 +1,30 @@+## 0.6.4 [2024.10.27]+* Drop support for pre-8.0 versions of GHC.++## 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.hs view
@@ -1,87 +1,137 @@-{-# LANGUAGE TypeFamilies, RankNTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Data.Reify ( MuRef(..), module Data.Reify.Graph,- reifyGraph+ reifyGraph,+ reifyGraphs ) where import Control.Concurrent.MVar-import System.Mem.StableName-import Data.IntMap as M-import Unsafe.Coerce -import Control.Applicative+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 -- | '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 + 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.-+-- 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 M.empty- rt2 <- newMVar []+reifyGraph m = do rt1 <- newMVar HM.empty uVar <- newMVar 0- root <- findNodes rt1 rt2 uVar m- pairs <- readMVar rt2- return (Graph pairs root)+ reifyWithContext rt1 uVar m -findNodes :: (MuRef s) - => MVar (IntMap [(DynStableName,Int)]) - -> MVar [(Int,DeRef s Int)] - -> MVar Int- -> s - -> IO Int-findNodes rt1 rt2 uVar j | j `seq` True = do+-- | '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- case mylookup st tab of+ nodeSet <- takeMVar nodeSetVar+ case HM.lookup st tab of Just var -> do putMVar rt1 tab- return $ var- Nothing -> - do var <- newUnique uVar- 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-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+ 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 Int -> IO Int+newUnique :: MVar Unique -> IO Unique newUnique var = do v <- takeMVar var let v' = succ v putMVar var v' return v'- --- Stable names that not use phantom types.++-- Stable names that do not use phantom types. -- As suggested by Ganesh Sittampalam.-data DynStableName = DynStableName (StableName ())+-- 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) -hashDynStableName :: DynStableName -> Int-hashDynStableName (DynStableName sn) = hashStableName sn+instance Hashable DynStableName where+ hashWithSalt s (DynStableName n) = hashWithSalt s n instance Eq DynStableName where- (DynStableName sn1) == (DynStableName sn2) = sn1 == sn2+ DynStableName m == DynStableName n =+ eqStableName m n makeDynStableName :: a -> IO DynStableName makeDynStableName a = do- st <- makeStableName a- return $ DynStableName (unsafeCoerce st)- + st <- makeStableName a+ return $ DynStableName st
Data/Reify/Graph.hs view
@@ -10,7 +10,8 @@ -- This is the shared definition of a 'Graph' in Data.Reify. -{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} module Data.Reify.Graph ( Graph(..),@@ -18,10 +19,10 @@ ) 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 +-- 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. +-- 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 @@ -29,8 +30,8 @@ type Unique = Int -- | If 'e' is s Functor, and 'e' is 'Show'-able, then we can 'Show' a 'Graph'.-instance (Show (e Int)) => Show (Graph e) where+instance (Show (e Unique)) => Show (Graph e) where show (Graph netlist start) = "let " ++ show [ (u,e)- | (u,e) <- netlist + | (u,e) <- netlist ] ++ " in " ++ show start
+ README.md view
@@ -0,0 +1,9 @@+# data-reify [](http://hackage.haskell.org/package/data-reify) [](https://github.com/ku-fpg/data-reify/actions?query=workflow%3AHaskell-CI)++`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,100 +1,158 @@ Name: data-reify-Version: 0.6+Version: 0.6.4 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.- .- 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 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.+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 +Category: Language, Data, Parsing, Reflection License: BSD3 License-file: LICENSE Author: Andy Gill Maintainer: Andy Gill <andygill@ku.edu> Copyright: (c) 2009 Andy Gill-Homepage: http://www.ittc.ku.edu/csdl/fpg/Tools/IOReification-Stability: alpha+Homepage: http://ku-fpg.github.io/software/data-reify/+Stability: alpha build-type: Simple-Cabal-Version: >= 1.6+Cabal-Version: >= 1.10+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.6+ , GHC == 9.8.2+ , GHC == 9.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, containers+ Build-Depends: base >= 4.9 && < 5+ , containers >= 0.5.7.1+ , hashable+ , 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+ , 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 example1+ Build-Depends: base, containers, data-reify+ Main-Is: example1.hs+ Hs-Source-Dirs: examples+ ghc-options: -Wall+ default-language: Haskell2010+ if !flag(tests)+ buildable: False++Executable simplify+ Build-Depends: base, containers, data-reify+ Main-Is: simplify.hs+ Hs-Source-Dirs: examples+ ghc-options: -Wall+ default-language: Haskell2010+ if !flag(tests)+ buildable: False+ 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+ default-language: Haskell2010 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+ default-language: Haskell2010 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+ default-language: Haskell2010 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+ other-modules: Common+ Hs-Source-Dirs: test, test-common+ ghc-options: -Wall+ default-language: Haskell2010 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+ other-modules: Common+ Hs-Source-Dirs: test, test-common+ ghc-options: -Wall+ default-language: Haskell2010 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+ other-modules: Common+ Hs-Source-Dirs: test, test-common+ ghc-options: -Wall+ default-language: Haskell2010 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+ default-language: Haskell2010 if !flag(tests) buildable: False
+ examples/example1.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}++module Main (DistF,Dist,D,share,expand,main) where++import Data.Reify+import Data.IntMap as IntMap++{-+This example was written by Edward Kmett for Johan Tibell,+and can be found at http://lpaste.net/74064++-}+main :: IO ()+main = print "example1"++data DistF a+ = ConcatF [a]+ | ConcatMapF String [a]+ | GroupByKeyF [a]+ | InputF FilePath+ deriving (Functor, Foldable, Traversable)++newtype Dist a = Dist (DistF (Dist a))++instance MuRef (Dist a) where+ type DeRef (Dist a) = DistF+ mapDeRef f (Dist body) = case body of+ ConcatF xs -> ConcatF <$> traverse f xs+ ConcatMapF n xs -> ConcatMapF n <$> traverse f xs+ GroupByKeyF xs -> GroupByKeyF <$> traverse f xs+ InputF fn -> pure (InputF fn)++data D+ = Concat [D]+ | ConcatMap String [D]+ | GroupByKey [D]+ | Input FilePath+ | Var Int++share :: Dist a -> IO (IntMap D, D)+share d = do+ Graph nodes s <- reifyGraph d+ let universe = IntMap.fromList nodes+ refs = insertWith (+) s (1::Integer) $ Prelude.foldr (\k -> insertWith (+) (fst k) 1) mempty nodes+ (urefs, mrefs) = IntMap.partition (==1) refs+ lut = intersectionWith const universe urefs+ return (mapWithKey (\k _ -> expand lut k) mrefs, expand lut s)++expand :: IntMap (DistF Int) -> Int -> D+expand m = go where+ go k = case IntMap.lookup k m of+ Nothing -> Var k+ Just d -> case d of+ ConcatF xs -> Concat (go <$> xs)+ ConcatMapF n xs -> ConcatMap n (go <$> xs)+ GroupByKeyF xs -> GroupByKey (go <$> xs)+ InputF fn -> Input fn
+ examples/simplify.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-+ This example simplifies a reified graph so only nodes+ referenced from multiple places are assigned labels,+ and unshared terms are folded into the parent by+ changing the type of the graph to use the free+ monad (Free e) over the original functor e.+ -}+module Main (main) where++-- to define simplification+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Reify (Graph(Graph), Unique)+import qualified Data.Set as Set++-- for the example+import Data.Reify (MuRef(mapDeRef), DeRef, reifyGraph)++#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..))+#endif++#if !(MIN_VERSION_base(4,18,0))+import Control.Applicative (liftA2)+#endif++-- Self-contained Free monad+data Free f a = Pure a | Free (f (Free f a))+deriving instance (Show a, Show (f (Free f a))) => Show (Free f a)++instance Functor f => Functor (Free f) where+ fmap f = go where+ go (Pure a) = Pure (f a)+ go (Free fa) = Free (go <$> fa)++instance Functor f => Applicative (Free f) where+ pure = Pure+ Pure a <*> Pure b = Pure $ a b+ Pure a <*> Free mb = Free $ fmap a <$> mb+ Free ma <*> b = Free $ (<*> b) <$> ma++instance Functor f => Monad (Free f) where+#if !(MIN_VERSION_base(4,11,0))+ return = Pure+#endif+ Pure a >>= f = f a+ Free m >>= f = Free (fmap (>>= f) m)++newtype Hist a = Hist (Map a Int)+ deriving Show+count :: a -> Hist a+count x = Hist (Map.singleton x 1)++instance (Ord a) => Semigroup (Hist a) where+ (<>) (Hist m1) (Hist m2) = Hist (Map.unionWith (+) m1 m2)++instance (Ord a) => Monoid (Hist a) where+ mempty = Hist Map.empty+#if !(MIN_VERSION_base(4,11,0))+ mappend (Hist m1) (Hist m2) = Hist (Map.unionWith (+) m1 m2)+#endif+ mconcat hists = Hist (Map.unionsWith (+) [m | Hist m <- hists])++-- Count the number of times each Unique is referenced+-- in the graph.+occs :: (Foldable e) => Graph e -> Hist Unique+occs (Graph binds root) = count root `mappend` foldMap (foldMap count . snd) binds++-- nest unshared nodes into parents.+simpl :: (Functor e, Foldable e) => Graph e -> Graph (Free e)+simpl g@(Graph binds root) =+ let Hist counts = occs g+ repeated = Map.keysSet (Map.filter (>1) counts)+ grow ix+ | Set.member ix repeated = Pure ix+ | otherwise =+ case lookup ix binds of+ Just pat -> Free (fmap grow pat)+ Nothing -> error "this shouldn't happen"+ in Graph [(k, Free (fmap grow v))+ | (k,v) <- binds, Set.member k repeated]+ root++-- A data type for the example.+data Tree a =+ Leaf a+ | Fork (Tree a) (Tree a)+ deriving (Show)+data TreeF a t =+ LeafF a+ | ForkF t t+ deriving (Show, Functor, Foldable)+instance MuRef (Tree a) where+ type DeRef (Tree a) = TreeF a+ mapDeRef _ (Leaf v) = pure $ LeafF v+ mapDeRef child (Fork l r) = liftA2 ForkF (child l) (child r)++-- An example graph.+loop1, loop2 :: Tree Int++-- loop1 is referenced twice so it must have an explicit+-- label in the simplified graph whether or not it's the root.+loop1 = Fork (Fork (Leaf 1) loop1) loop2++-- loop2 is only reference once in the graph, so it will+-- have a label in the simplified graph only if it is the root.+loop2 = Fork loop1 (Leaf 2)++main :: IO ()+main = do+ putStrLn "Simplifed graph for loop1, should have one label"+ print . simpl =<< reifyGraph loop1+ putStrLn "Simplifed graph for loop2, should have two labels"+ print . simpl =<< reifyGraph loop2
+ spec/Data/ReifySpec.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Data.ReifySpec where++import qualified Data.List as L+import Data.Reify+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)
+ spec/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test-common/Common.hs view
@@ -0,0 +1,15 @@+module Common (head_, tail_) where++-- | Like 'head', but with a more specific error message in case the argument is+-- empty. This is primarily defined to avoid incurring @-Wx-partial@ warnings+-- whenever 'head' is used.+head_ :: [a] -> a+head_ (x:_) = x+head_ [] = error "head_: Empty list"++-- | Like 'tail', but with a more specific error message in case the argument is+-- empty. This is primarily defined to avoid incurring @-Wx-partial@ warnings+-- whenever 'tail' is used.+tail_ :: [a] -> [a]+tail_ (_:xs) = xs+tail_ [] = error "tail_: Empty list"
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,16 +28,15 @@ 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 = 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 [] @@ -52,5 +51,5 @@ deriving Show -}- +
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,46 +1,47 @@ {-# LANGUAGE TypeFamilies #-}-module Main where+{-# OPTIONS_GHC -Wno-orphans #-}+module Main (main) where -import qualified Data.Traversable as T-import qualified Data.Foldable as F-import Data.Monoid---import Control.Monad+import Common 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 instance MuRef [a] where- type DeRef [a] = List a + 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) ]+ 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,30 +1,33 @@-{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}-module Main where+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Main (main) where -import qualified Data.Traversable as T-import qualified Data.Foldable as F-import Data.Monoid+import Common+ 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 instance Typeable a => MuRef [a] where- type DeRef [a] = List a + 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@@ -33,7 +36,7 @@ -- 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) ]+ print $ reverse $ take 4 $ reverse [ n2 / n1 | (n1,n2) <- zip ns (tail_ ns) ] timeme :: Int -> IO Float timeme n = do@@ -41,7 +44,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,34 +1,30 @@-{-# LANGUAGE TypeFamilies, UndecidableInstances, DeriveDataTypeable, RankNTypes, ExistentialQuantification #-}-module Main where+{-# LANGUAGE TypeFamilies, UndecidableInstances,+ RankNTypes, ExistentialQuantification, TypeOperators #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Main (main) where -import qualified Data.Traversable as T-import qualified Data.Foldable as F-import Data.Monoid---import Control.Monad+import Common+ 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 instance MuRef Int where- type DeRef Int = List + 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 - + 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@@ -36,43 +32,44 @@ -- return $ Var $ toDyn fn data Exp = ExpVar Dynamic | ExpLit Int | ExpAdd Exp Exp- deriving (Typeable, Show)- - + deriving 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 _ (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 + 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 _ 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]@@ -81,27 +78,30 @@ g2 = [1..10] ++ g2 reifyGraph g2 >>= print - let g3 = [\ x -> x :: Exp, \ y -> y + head g3 2] ++ g3+ 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) ]+ 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 - -capture :: (Typeable a, Typeable b, NewVar a) => (a -> b) -> (a,b)-capture f = (a,f a)- where a = mkVar (toDyn f) + 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)
test/Test7.hs view
@@ -1,39 +1,32 @@-{-# LANGUAGE TypeFamilies, UndecidableInstances, DeriveDataTypeable, RankNTypes, ExistentialQuantification #-}-+{-# LANGUAGE TypeFamilies, UndecidableInstances,+ 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 System.Environment -import Data.Dynamic+import Prelude data Tree = Node Tree Tree | Leaf Int- deriving (Show,Eq,Typeable)+ deriving (Show,Eq) 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+ 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,25 +34,26 @@ 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 + 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 - + putStrLn $ " " ++ show n ++ " ==> " ++ show (t / 1000)+ 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+ ]