data-reify 0.6.2 → 0.6.3

raw patch · 6 files changed

+142/−57 lines, 6 filesdep +base-compatdep +hspecdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: base-compat, hspec

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• Data/Reify.hs +75/−50
• Data/Reify/Graph.hs +7/−6
• data-reify.cabal +14/−1
• spec/Data/ReifySpec.hs +41/−0
• spec/Spec.hs +1/−0

@@ -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. 

@@ -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

@@ -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 

@@ -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

@@ -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)

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}