diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## 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. diff --git a/Data/Reify.hs b/Data/Reify.hs --- a/Data/Reify.hs +++ b/Data/Reify.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE CPP, TypeFamilies, RankNTypes #-} -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} module Data.Reify ( MuRef(..), module Data.Reify.Graph, @@ -8,27 +10,28 @@ reifyGraphs ) where -import Control.Applicative import Control.Concurrent.MVar -import Data.HashMap.Lazy as M +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 S -#if !(MIN_VERSION_base(4,8,0)) -import Data.Traversable -#endif +import qualified Data.IntSet as IS +import Data.IntSet (IntSet) import System.Mem.StableName -import Prelude -#if __GLASGOW_HASKELL__ < 708 +#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 :: * -> * @@ -38,13 +41,11 @@ -> 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 - reifyWithContext rt1 rt2 uVar m + 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 @@ -52,50 +53,73 @@ -- -- 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 +reifyGraphs coll = do rt1 <- newMVar HM.empty uVar <- newMVar 0 - flip traverse coll $ \m -> do - rt2 <- newMVar [] - reifyWithContext rt1 rt2 uVar m + 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 Int) - -> MVar [(Int,DeRef s Int)] - -> MVar Int - -> s - -> IO (Graph (DeRef s)) -reifyWithContext rt1 rt2 uVar j = do - root <- findNodes rt1 rt2 uVar S.empty j + => 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 Int) - -> MVar [(Int,DeRef s Int)] - -> MVar Int - -> S.IntSet + => 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 - -> IO Int -findNodes rt1 rt2 uVar nodeSet !j = do + -- ^ 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 M.lookup st tab of + nodeSet <- takeMVar nodeSetVar + case HM.lookup st tab of Just var -> do putMVar rt1 tab - 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' + if var `IS.member` nodeSet + then do putMVar nodeSetVar nodeSet return var - Nothing -> - do var <- newUnique uVar - 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 + 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 @@ -113,10 +137,11 @@ hashWithSalt s (DynStableName n) = hashWithSalt s n instance Eq DynStableName where -#if __GLASGOW_HASKELL__ >= 708 - DynStableName m == DynStableName n = eqStableName m n + DynStableName m == DynStableName n = +#if MIN_VERSION_base(4,7,0) + eqStableName m n #else - DynStableName m == DynStableName n = m == unsafeCoerce n + m == unsafeCoerce n #endif makeDynStableName :: a -> IO DynStableName diff --git a/Data/Reify/Graph.hs b/Data/Reify/Graph.hs --- a/Data/Reify/Graph.hs +++ b/Data/Reify/Graph.hs @@ -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 diff --git a/data-reify.cabal b/data-reify.cabal --- a/data-reify.cabal +++ b/data-reify.cabal @@ -1,5 +1,5 @@ Name: data-reify -Version: 0.6.2 +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 @@ -57,6 +57,19 @@ 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 diff --git a/spec/Data/ReifySpec.hs b/spec/Data/ReifySpec.hs new file mode 100644 --- /dev/null +++ b/spec/Data/ReifySpec.hs @@ -0,0 +1,41 @@ +{-# 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) diff --git a/spec/Spec.hs b/spec/Spec.hs new file mode 100644 --- /dev/null +++ b/spec/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}