diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,2 +1,23 @@ +## 0.6.2 [2020.09.30] +* Use `HashMap`s and `IntSet`s internally for slightly better performance. + ## 0.6.1 -* Fixed warnings in GHC 7.10 +* 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. diff --git a/Data/Reify.hs b/Data/Reify.hs --- a/Data/Reify.hs +++ b/Data/Reify.hs @@ -1,21 +1,30 @@ -{-# LANGUAGE TypeFamilies, RankNTypes #-} +{-# LANGUAGE CPP, TypeFamilies, RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE BangPatterns #-} module Data.Reify ( MuRef(..), module Data.Reify.Graph, - reifyGraph + reifyGraph, + reifyGraphs ) where import Control.Applicative import Control.Concurrent.MVar -import Data.IntMap as M +import Data.HashMap.Lazy as M +import Data.Hashable as H import Data.Reify.Graph +import qualified Data.IntSet as S +#if !(MIN_VERSION_base(4,8,0)) +import Data.Traversable +#endif import System.Mem.StableName -import Unsafe.Coerce - import Prelude +#if __GLASGOW_HASKELL__ < 708 +import Unsafe.Coerce +#endif -- | 'MuRef' is a class that provided a way to reference into a specific type, -- and a way to map over the deferenced internals. @@ -23,9 +32,9 @@ 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 @@ -35,55 +44,82 @@ reifyGraph m = do rt1 <- newMVar M.empty rt2 <- newMVar [] uVar <- newMVar 0 - root <- findNodes rt1 rt2 uVar m - pairs <- readMVar rt2 - return (Graph pairs root) + reifyWithContext rt1 rt2 uVar m -findNodes :: (MuRef s) - => MVar (IntMap [(DynStableName,Int)]) - -> MVar [(Int,DeRef s Int)] +-- | '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 M.empty + uVar <- newMVar 0 + flip traverse coll $ \m -> do + rt2 <- newMVar [] + reifyWithContext rt1 rt2 uVar m + +reifyWithContext :: (MuRef s) + => MVar (HashMap DynStableName Int) + -> MVar [(Int,DeRef s Int)] -> MVar Int - -> s + -> s + -> IO (Graph (DeRef s)) +reifyWithContext rt1 rt2 uVar j = do + root <- findNodes rt1 rt2 uVar S.empty j + pairs <- readMVar rt2 + return (Graph pairs root) + +findNodes :: (MuRef s) + => MVar (HashMap DynStableName Int) + -> MVar [(Int,DeRef s Int)] + -> MVar Int + -> S.IntSet + -> s -> IO Int -findNodes rt1 rt2 uVar j | j `seq` True = do +findNodes rt1 rt2 uVar nodeSet !j = do st <- makeDynStableName j tab <- takeMVar rt1 - case mylookup st tab of + case M.lookup st tab of Just var -> do putMVar rt1 tab - return $ var - Nothing -> + if var `S.member` nodeSet + then return var + else do res <- mapDeRef (findNodes rt1 rt2 uVar (S.insert var nodeSet)) j + tab' <- takeMVar rt2 + putMVar rt2 $ (var,res) : tab' + return var + Nothing -> do var <- newUnique uVar - putMVar rt1 $ M.insertWith (++) (hashDynStableName st) [(st,var)] tab - res <- mapDeRef (findNodes rt1 rt2 uVar) j + putMVar rt1 $ M.insert st var tab + res <- mapDeRef (findNodes rt1 rt2 uVar (S.insert var nodeSet)) 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 - newUnique :: MVar Int -> IO Int 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 +#if __GLASGOW_HASKELL__ >= 708 + DynStableName m == DynStableName n = eqStableName m n +#else + DynStableName m == DynStableName n = m == unsafeCoerce n +#endif makeDynStableName :: a -> IO DynStableName makeDynStableName a = do st <- makeStableName a - return $ DynStableName (unsafeCoerce st) + return $ DynStableName st diff --git a/data-reify.cabal b/data-reify.cabal --- a/data-reify.cabal +++ b/data-reify.cabal @@ -1,46 +1,47 @@ Name: data-reify -Version: 0.6.1 +Version: 0.6.2 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 Copyright: (c) 2009 Andy Gill -Homepage: http://www.ittc.ku.edu/csdl/fpg/Tools/IOReification +Homepage: http://ku-fpg.github.io/software/data-reify/ Stability: alpha build-type: Simple -Cabal-Version: >= 1.8 +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: git://github.com/ku-fpg/data-reify + location: https://github.com/ku-fpg/data-reify Flag tests Description: Enable full development tree @@ -48,17 +49,21 @@ Library - Build-Depends: base >= 4 && < 5, containers + 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 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 @@ -68,6 +73,7 @@ Main-Is: Test2.hs Hs-Source-Dirs: test ghc-options: -Wall + default-language: Haskell2010 if !flag(tests) buildable: False @@ -76,6 +82,7 @@ Main-Is: Test3.hs Hs-Source-Dirs: test ghc-options: -Wall + default-language: Haskell2010 if !flag(tests) buildable: False @@ -84,6 +91,7 @@ Main-Is: Test4.hs Hs-Source-Dirs: test ghc-options: -Wall + default-language: Haskell2010 if !flag(tests) buildable: False @@ -92,6 +100,7 @@ Main-Is: Test5.hs Hs-Source-Dirs: test ghc-options: -Wall + default-language: Haskell2010 if !flag(tests) buildable: False @@ -100,6 +109,7 @@ Main-Is: Test6.hs Hs-Source-Dirs: test ghc-options: -Wall + default-language: Haskell2010 if !flag(tests) buildable: False @@ -108,5 +118,6 @@ Main-Is: Test7.hs Hs-Source-Dirs: test ghc-options: -Wall + default-language: Haskell2010 if !flag(tests) buildable: False diff --git a/test/Test2.hs b/test/Test2.hs --- a/test/Test2.hs +++ b/test/Test2.hs @@ -29,13 +29,14 @@ fmap f (StateDeRef a tr) = StateDeRef a [ (b,f s) | (b,s) <- tr ] main :: IO () -main = reifyGraph s0 >>= print - +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 [] @@ -50,5 +51,5 @@ deriving Show -} - +