data-reify 0.6.3 → 0.6.4
raw patch · 12 files changed
+276/−69 lines, 12 filesdep −base-compatdep ~basedep ~containersnew-component:exe:example1new-component:exe:simplifyPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: base-compat
Dependency ranges changed: base, containers
API changes (from Hackage documentation)
- Data.Reify: type family DeRef a :: * -> *;
+ Data.Reify: type DeRef a :: * -> *;
Files
- CHANGELOG.md +3/−0
- Data/Reify.hs +1/−14
- README.md +1/−1
- data-reify.cabal +39/−17
- examples/example1.hs +57/−0
- examples/simplify.hs +121/−0
- spec/Data/ReifySpec.hs +1/−3
- test-common/Common.hs +15/−0
- test/Test4.hs +6/−5
- test/Test5.hs +6/−4
- test/Test6.hs +21/−19
- test/Test7.hs +5/−6
CHANGELOG.md view
@@ -1,3 +1,6 @@+## 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.
Data/Reify.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Data.Reify ( MuRef(..), module Data.Reify.Graph,@@ -21,15 +21,6 @@ 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@@ -138,11 +129,7 @@ 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
README.md view
@@ -1,4 +1,4 @@-# data-reify [](http://hackage.haskell.org/package/data-reify) [](https://travis-ci.org/ku-fpg/data-reify)+# 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.
data-reify.cabal view
@@ -1,5 +1,5 @@ Name: data-reify-Version: 0.6.3+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@@ -25,18 +25,18 @@ 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+tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5- , GHC == 8.8.3- , GHC == 8.10.1+ , 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@@ -49,7 +49,10 @@ Library- Build-Depends: base >= 4 && < 5, hashable, containers, unordered-containers+ Build-Depends: base >= 4.9 && < 5+ , containers >= 0.5.7.1+ , hashable+ , unordered-containers Exposed-modules: Data.Reify, Data.Reify.Graph@@ -62,8 +65,7 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: Data.ReifySpec- build-depends: base >= 4 && < 5- , base-compat >= 0.11 && < 0.12+ build-depends: base , data-reify , hspec == 2.* build-tool-depends: hspec-discover:hspec-discover == 2.*@@ -71,6 +73,24 @@ 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, data-reify Main-Is: Test1.hs@@ -80,7 +100,6 @@ if !flag(tests) buildable: False - Executable data-reify-test2 Build-Depends: base, data-reify Main-Is: Test2.hs@@ -102,7 +121,8 @@ Executable data-reify-test4 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)@@ -111,7 +131,8 @@ Executable data-reify-test5 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)@@ -120,7 +141,8 @@ Executable data-reify-test6 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)
+ 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
@@ -1,13 +1,11 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Data.ReifySpec where import qualified Data.List as L import Data.Reify-import Prelude ()-import Prelude.Compat import Test.Hspec main :: IO ()
+ 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/Test4.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Main (main) where +import Common import Control.Applicative hiding (Const) import Data.Reify import System.CPUTime@@ -12,11 +13,11 @@ instance MuRef [a] where- type DeRef [a] = List a + 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)@@ -32,7 +33,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@@ -42,5 +43,5 @@ j <- getCPUTime let n' :: Float n' = fromIntegral ((j - i) `div` 1000000000)- putStrLn $ " ==> " ++ show (n' / 1000) + putStrLn $ " ==> " ++ show (n' / 1000) return n'
test/Test5.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Main (main) where +import Common+ import Control.Applicative hiding (Const) import Data.Dynamic@@ -15,7 +17,7 @@ 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 _ [] = pure Nil@@ -34,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@@ -44,5 +46,5 @@ j <- getCPUTime let n' :: Float n' = fromIntegral ((j - i) `div` 1000000000)- putStrLn $ " ==> " ++ show (n' / 1000) + putStrLn $ " ==> " ++ show (n' / 1000) return n'
test/Test6.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE TypeFamilies, UndecidableInstances, DeriveDataTypeable,- RankNTypes, ExistentialQuantification #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeFamilies, UndecidableInstances,+ RankNTypes, ExistentialQuantification, TypeOperators #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Main (main) where +import Common+ import Control.Applicative hiding (Const) import Data.Dynamic@@ -14,13 +16,13 @@ deriving Show instance MuRef Int where- type DeRef Int = List + 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 - + type DeRef [a] = List+ mapDeRef f (x:xs) = liftA2 Cons (f x) (f xs) mapDeRef _ [] = pure Nil @@ -30,17 +32,17 @@ -- 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 _ (ExpVar _) = pure Var mapDeRef _ (ExpLit i) = pure $ Int i mapDeRef f (ExpAdd x y) = Add <$> f x <*> f y@@ -49,11 +51,11 @@ 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@@ -76,15 +78,15 @@ 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 :: [[Int]]--- zz = let xs = [1..3] +-- zz = let xs = [1..3] -- ys = (0::Int) : xs -- in cycle [xs,ys,tail ys] @@ -97,9 +99,9 @@ j <- getCPUTime let n' :: Float n' = fromIntegral ((j - i) `div` 1000000000)- putStrLn $ " ==> " ++ show (n' / 1000) + 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,11 +1,10 @@-{-# LANGUAGE TypeFamilies, UndecidableInstances, DeriveDataTypeable,+{-# LANGUAGE TypeFamilies, UndecidableInstances, RankNTypes, ExistentialQuantification #-} module Main (main) where import Control.Applicative hiding (Const) import Data.Reify-import Data.Typeable import System.CPUTime import System.Environment@@ -13,7 +12,7 @@ import Prelude data Tree = Node Tree Tree | Leaf Int- deriving (Show,Eq,Typeable)+ deriving (Show,Eq) data T s = N s s | L Int @@ -42,14 +41,14 @@ 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) + putStrLn $ " " ++ show n ++ " ==> " ++ show (t / 1000) return t- + main :: IO () main = do (x:args) <- getArgs