impure-containers 0.3.1 → 0.4.0

raw patch · 10 files changed

+490/−237 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• impure-containers.cabal +3/−1
• src/Data/Graph/Immutable.hs +220/−98
• src/Data/Graph/Mutable.hs +51/−22
• src/Data/Graph/Types.hs +13/−43
• src/Data/Graph/Types/Internal.hs +86/−0
• src/Data/HashMap/Mutable/Basic.hs +43/−60
• src/Data/Heap/Mutable/ModelC.hs +1/−1
• src/Data/Trie/Immutable/Bits.hs +59/−0
• src/Data/Trie/Mutable/Bits.hs +12/−9
• test/Spec.hs +2/−3

@@ -1,5 +1,5 @@ name:                impure-containers-version:             0.3.1+version:             0.4.0 synopsis:            Mutable containers in haskell description:         Please see README.md homepage:            https://github.com/andrewthad/impure-containers#readme@@ -29,8 +29,10 @@     Data.Graph.Immutable     Data.Graph.Mutable     Data.Trie.Mutable.Bits+    Data.Trie.Immutable.Bits     Data.ArrayList.Generic     Data.Graph.Types+    Data.Graph.Types.Internal     Data.Primitive.PrimArray     Data.Primitive.Array.Maybe     Data.Primitive.MutVar.Maybe

@@ -2,13 +2,51 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes    #-} -module Data.Graph.Immutable where+-- | This module provides a safe and performant way to perform+--   operations on graphs. The types 'Graph', 'Vertex', 'Vertices'+--   and 'Size' are all parameterized by a phantom type variable @g@.+--   Much like the @s@ used with @ST@, this type variable will+--   always be free. It gives us a guarentee that a vertex belongs+--   in a graph. See the bottom of this page for a more detailed+--   explanation. -import Data.Graph.Types+module Data.Graph.Immutable+  ( -- * Graph Operations+    lookupVertex+  , lookupEdge+  , mapVertices+  , traverseVertices_+  , traverseEdges_+  , traverseNeighbors_+  , vertices+  , setVertices+  , size+  , freeze+  , create+  , with+    -- * Algorithms+  , dijkstra+  , dijkstraMonoidal+  , dijkstraMonoidalCover+    -- * Size and Vertex+  , sizeInt+  , vertexInt+    -- * Vertices+  , verticesRead+  , verticesLength+  , verticesTraverse_+  , verticesToVertexList+  , verticesToVector+  , verticesThaw+  , verticesFreeze+  ) where++import Data.Graph.Types.Internal import Control.Monad.Primitive import Data.Foldable import Data.Vector (Vector) import Data.Vector.Mutable (MVector)+import Data.Functor.Identity (Identity(..)) import Control.Monad import Data.Word import Control.Monad.ST (runST)@@ -23,68 +61,17 @@ import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU -dijkstra :: (Ord s, Monoid s)-  => (v -> v -> s -> e -> s)-  -> s -- ^ Weight to assign start vertex-  -> Vertex g -- ^ start-  -> Vertex g -- ^ end-  -> Graph g e v-  -> s-dijkstra f s start end g =-  verticesRead (dijkstraTraversal f s start g) end---- | This is a generalization of Dijkstra\'s algorithm. This function could---   be written without unsafely pattern matching on 'Vertex', but doing---   so allows us to use a faster heap implementation.-dijkstraTraversal ::-     (Ord s, Monoid s)-  => (v -> v -> s -> e -> s) -- ^ Weight combining function-  -> s -- ^ Weight to assign start vertex-  -> Vertex g -- ^ Start vertex-  -> Graph g e v-  -> Vertices g s-dijkstraTraversal f s0 v0 g = runST $ do-  let theSize = size g-      oldVertices = vertices g-  newVertices <- Mutable.verticesReplicate theSize mempty-  Mutable.verticesWrite newVertices v0 s0-  visited <- Mutable.verticesUReplicate theSize False-  heap <- Heap.new (unSize theSize)-  -- Using getVertex casts Vertex to Int. This is safe to do,-  -- but going from Int to Vertex (done later) is normally unsafe.-  -- We know it's ok in this case because the min heap does not-  -- create Ints that we did not push onto it.-  Heap.unsafePush s0 (getVertexInternal v0) heap-  let go = do-        m <- Heap.pop heap-        case m of-          Nothing -> return True-          Just (s,unwrappedVertexIx) -> do-            -- Unsafe cast from Int to Vertex-            let vertex = Vertex unwrappedVertexIx-                value = verticesRead oldVertices vertex-            Mutable.verticesUWrite visited vertex True-            Mutable.verticesWrite newVertices vertex s-            traverseNeighbors_ (\neighborVertex neighborValue theEdge -> do-                alreadyVisited <- Mutable.verticesURead visited neighborVertex-                when (not alreadyVisited) $ Heap.unsafePush-                  (f value neighborValue s theEdge)-                  -- Casting from Vertex to Int-                  (getVertexInternal neighborVertex)-                  heap-              ) vertex g-            return False-      runMe = do-        isDone <- go-        if isDone then return () else runMe-  runMe-  newVerticesFrozen <- verticesFreeze newVertices-  return newVerticesFrozen-+-- | Lookup a 'Vertex' by its label. lookupVertex :: Eq v => v -> Graph g e v -> Maybe (Vertex g) lookupVertex val (Graph g) = fmap Vertex (V.elemIndex val (graphVertices g)) --- | Not the same as fmap because the function also takes the vertex id.+lookupEdge :: Vertex g -> Vertex g -> Graph g e v -> Maybe e+lookupEdge (Vertex x) (Vertex y) (Graph (SomeGraph _ neighbors edges)) =+  case U.elemIndex y (V.unsafeIndex neighbors x) of+    Nothing -> Nothing+    Just ix -> Just (V.unsafeIndex (V.unsafeIndex edges x) ix)++-- | Not the same as 'fmap' because the function also takes the vertex id. mapVertices :: (Vertex g -> a -> b) -> Graph g e a -> Graph g e b mapVertices f (Graph sg) = Graph sg   { graphVertices = V.imap (coerce f) (graphVertices sg) }@@ -105,7 +92,8 @@           vertex g         ) allVertices --- | Change this to use unsafeRead some time soon.+-- | Traverse the neighbors of a specific vertex.+--   Change this to use unsafeRead some time soon. traverseNeighbors_ :: Applicative m   => (Vertex g -> v -> e -> m a)   -> Vertex g@@ -124,36 +112,23 @@         else pure ()    in go 0 -lookupEdge :: Vertex g -> Vertex g -> Graph g e v -> Maybe e-lookupEdge (Vertex x) (Vertex y) (Graph (SomeGraph _ neighbors edges)) =-  case U.elemIndex y (V.unsafeIndex neighbors x) of-    Nothing -> Nothing-    Just ix -> Just (V.unsafeIndex (V.unsafeIndex edges x) ix) -mutableIForM_ :: PrimMonad m => MVector (PrimState m) a -> (Int -> a -> m b) -> m ()-mutableIForM_ m f = forM_ (take (MV.length m) (enumFrom 0)) $ \i -> do-  a <- MV.read m i-  f i a--mutableIFoldM' :: PrimMonad m => (a -> Int -> b -> m a) -> a -> MVector (PrimState m) b -> m a-mutableIFoldM' f x m = go 0 x where-  len = MV.length m-  go !i !a = if i < len-    then do-      b <- MV.read m i-      aNext <- f a i b-      go (i + 1) aNext-    else return x-+-- | Get the vertices from a graph. vertices :: Graph g e v -> Vertices g v vertices (Graph (SomeGraph v _ _)) = Vertices v +-- | Set the vertices of a graph.+setVertices :: Vertices g v -> Graph g e v -> Graph g e v+setVertices (Vertices x) (Graph (SomeGraph _ a b)) = Graph (SomeGraph x a b)++-- | Get the number of vertices in a graph. size :: Graph g e v -> Size g size (Graph (SomeGraph v _ _)) = Size (V.length v) -unSize :: Size g -> Int-unSize (Size s) = s+sizeInt :: Size g -> Int+sizeInt (Size s) = s +-- | Convert a 'Vertex' to an 'Int'. vertexInt :: Vertex g -> Int vertexInt (Vertex i) = i @@ -181,13 +156,15 @@ verticesLength :: Vertices g v -> Int verticesLength (Vertices v) = V.length v -verticesFreeze :: PrimMonad m => MVertices g (PrimState m) v -> m (Vertices g v)+verticesFreeze :: PrimMonad m => MVertices (PrimState m) g v -> m (Vertices g v) verticesFreeze (MVertices mvec) = fmap Vertices (V.freeze mvec) -verticesThaw :: PrimMonad m => Vertices g v -> m (MVertices g (PrimState m) v)+-- | Make a mutable copy of a set of 'Vertices'.+verticesThaw :: PrimMonad m => Vertices g v -> m (MVertices (PrimState m) g v) verticesThaw (Vertices vec) = fmap MVertices (V.thaw vec) -freeze :: PrimMonad m => MGraph g (PrimState m) e v -> m (Graph g e v)+-- | Make an immutable copy of a mutable graph.+freeze :: PrimMonad m => MGraph (PrimState m) g e v -> m (Graph g e v) freeze (MGraph vertexIndex currentIdVar edges) = do   let initialArrayListSize = 16   numberOfVertices <- readMutVar currentIdVar@@ -211,7 +188,7 @@  -- | Takes a function that builds on an empty 'MGraph'. After the function --   mutates the 'MGraph', it is frozen and becomes an immutable 'SomeGraph'.-create :: PrimMonad m => (forall g. MGraph g (PrimState m) e v -> m ()) -> m (SomeGraph e v)+create :: PrimMonad m => (forall g. MGraph (PrimState m) g e v -> m ()) -> m (SomeGraph e v) create f = do   mg <- MGraph     <$> HashTable.new@@ -221,18 +198,163 @@   Graph g <- freeze mg   return g +-- | Take a function that can be performed on any 'Graph' and perform that+--   on the given 'SomeGraph'. with :: SomeGraph e v -> (forall g. Graph g e v -> a) -> a with sg f = f (Graph sg) --- data Edge g = Edge---   { edgeVertexA :: !Int---   , edgeVertexB :: !Int---   }+-- | Find the shortest path between two vertices using Dijkstra\'s algorithm.+--   The source code of this function provides an example of how to use+--   the generalized variants of Dijkstra\'s algorithm provided by this+--   module.+dijkstra :: (Num e, Ord e)+  => Vertex g -- ^ Start vertex+  -> Vertex g -- ^ End vertex+  -> Graph g e v -- ^ Graph+  -> Maybe e+dijkstra start end g = getMinDistance+  ( dijkstraMonoidal+    (\_ _ mdist e -> addMinDistance mdist e)+    (MinDistance (Just 0))+    start end g+  )+  where addMinDistance (MinDistance m) e = MinDistance (fmap (+ e) m) --- instance Functor (Graph g e) where---   fmap f g = g { graphVertices = Vector.map (graphVertices g) }+newtype MinDistance a = MinDistance { getMinDistance :: Maybe a } --- visited,allowed,notAllowed :: Word8--- visited = 2--- allowed = 1--- notAllowed = 0+instance Eq a => Eq (MinDistance a) where+  MinDistance a == MinDistance b = a == b++instance Ord a => Ord (MinDistance a) where+  compare (MinDistance a) (MinDistance b) = case a of+    Nothing -> case b of+      Nothing -> EQ+      Just _ -> GT+    Just aval -> case b of+      Nothing -> LT+      Just bval -> compare aval bval++instance Ord a => Monoid (MinDistance a) where+  mempty = MinDistance Nothing+  mappend ma mb = min ma mb++-- | A generalized version of Dijkstra\'s algorithm.+dijkstraMonoidal :: (Ord s, Monoid s)+  => (v -> v -> s -> e -> s) -- Weight combining function+  -> s           -- ^ Weight to assign start vertex+  -> Vertex g    -- ^ Start vertex+  -> Vertex g    -- ^ End vertex+  -> Graph g e v -- ^ Graph+  -> s+dijkstraMonoidal f s start end g =+  verticesRead (dijkstraMonoidalCover f s (Identity start) g) end++-- | This is a generalization of Dijkstra\'s algorithm. Like the original,+--   it takes a start 'Vertex' but unlike the original, it does not take+--   an end. It will continue traversing the 'Graph' until it has touched+--   all vertices that are reachable from the start vertex.+--+--   Additionally, this function generalizes the notion of distance. It+--   can be numeric (as Dijkstra has it) data, non-numeric data, or tagged numeric+--   data. This can be used, for example, to find the shortest path from+--   the start vertex to all other vertices in the graph.+--+--   In Dijkstra\'s original algorithm, tentative distances are initialized+--   to infinity. After a node is visited, the procedure for updating its+--   neighbors\' tentative distance to a node is to compare the existing tentative distance with+--   the new one and to keep the lesser of the two.+--+--   In this variant, tentative distances are initialized to 'mempty'.+--   The update procedure involves combining them with 'mappend' instead+--   of being choosing the smaller of the two. For this+--   algorithm to function correctly, the distance @s@ must have 'Ord' and+--   'Monoid' instances satisfying:+--+--   > ∀ a b. mappend a b ≤ a+--   > ∀ a b. mappend a b ≤ b+--   > ∀ c.   mempty ≥ c+--+--   Additionally, the 'Monoid' instance should have a commutative 'mappend':+--+--   > ∀ a b. mappend a b ≅ mappend b a+--+--   The weight function is described by:+--+--   > from    to    from   edge   tentative+--   > node   node  weight  value  to weight+--   >  |      |      |      |      |+--   >  V      V      V      V      V+--   >+--   > (v  ->  v  ->  s  ->  e  ->  s)+--+--   In many cases, some of input values can be ignored. For example, to implement+--   Dijkstra\'s original algorithm the @from-node@ and @to-node@ values are+--   not needed. The weight combining function will typically use the @from-weight@+--   in some way. The way this algorithm uses the weight function makes it suseptible to+--   the same negative-edge problem as the original. For some weight combining+--   function @f@, it should be the case that:+--+--   > ∀ v1 v2 s e. f v1 v2 s e ≥ s+--+--   This function could be written without unsafely pattern matching+--   on 'Vertex', but doing so allows us to use a faster heap implementation.+dijkstraMonoidalCover ::+     (Ord s, Monoid s, Foldable t)+  => (v -> v -> s -> e -> s) -- ^ Weight function+  -> s                 -- ^ Weight to assign start vertex+  -> t (Vertex g)      -- ^ Start vertices+  -> Graph g e v       -- ^ Graph+  -> Vertices g s+dijkstraMonoidalCover f s0 v0 g = runST $ do+  let theSize = size g+      oldVertices = vertices g+  newVertices <- Mutable.verticesReplicate theSize mempty+  visited <- Mutable.verticesUReplicate theSize False+  heap <- Heap.new (sizeInt theSize)+  forM_ v0 $ \v -> do+    Mutable.verticesWrite newVertices v s0+    -- Using getVertex casts Vertex to Int. This is safe to do,+    -- but going from Int to Vertex (done later) is normally unsafe.+    -- We know it's ok in this case because the min heap does not+    -- create Ints that we did not push onto it.+    Heap.unsafePush s0 (getVertexInternal v) heap+  let go = do+        m <- Heap.pop heap+        case m of+          Nothing -> return True+          Just (s,unwrappedVertexIx) -> do+            -- Unsafe cast from Int to Vertex+            let vertex = Vertex unwrappedVertexIx+                value = verticesRead oldVertices vertex+            Mutable.verticesUWrite visited vertex True+            Mutable.verticesWrite newVertices vertex s+            traverseNeighbors_ (\neighborVertex neighborValue theEdge -> do+                alreadyVisited <- Mutable.verticesURead visited neighborVertex+                when (not alreadyVisited) $ Heap.unsafePush+                  (f value neighborValue s theEdge)+                  -- Casting from Vertex to Int+                  (getVertexInternal neighborVertex)+                  heap+              ) vertex g+            return False+      runMe = do+        isDone <- go+        if isDone then return () else runMe+  runMe+  newVerticesFrozen <- verticesFreeze newVertices+  return newVerticesFrozen++-- mutableIForM_ :: PrimMonad m => MVector (PrimState m) a -> (Int -> a -> m b) -> m ()+-- mutableIForM_ m f = forM_ (take (MV.length m) (enumFrom 0)) $ \i -> do+--   a <- MV.read m i+--   f i a+--+-- mutableIFoldM' :: PrimMonad m => (a -> Int -> b -> m a) -> a -> MVector (PrimState m) b -> m a+-- mutableIFoldM' f x m = go 0 x where+--   len = MV.length m+--   go !i !a = if i < len+--     then do+--       b <- MV.read m i+--       aNext <- f a i b+--       go (i + 1) aNext+--     else return x

@@ -1,6 +1,20 @@-module Data.Graph.Mutable where+module Data.Graph.Mutable+  ( -- * Graph Operations+    -- $mutgraph+    insertVertex+  , insertEdge+  , insertEdgeWith+    -- * Vertices Operations+    -- $mutvertices+  , verticesReplicate+  , verticesUReplicate+  , verticesWrite+  , verticesUWrite+  , verticesRead+  , verticesURead+  ) where -import Data.Graph.Types+import Data.Graph.Types.Internal import Control.Monad.Primitive import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Unboxed.Mutable as MU@@ -9,23 +23,10 @@ import Data.Hashable (Hashable) import qualified Data.HashMap.Mutable.Basic as HashTable -verticesReplicate :: PrimMonad m => Size g -> v -> m (MVertices g (PrimState m) v)-verticesReplicate (Size i) v = fmap MVertices (MV.replicate i v)--verticesUReplicate :: (PrimMonad m, Unbox v) => Size g -> v -> m (MUVertices g (PrimState m) v)-verticesUReplicate (Size i) v = fmap MUVertices (MU.replicate i v)--verticesUWrite :: (PrimMonad m, Unbox v) => MUVertices g (PrimState m) v -> Vertex g -> v -> m ()-verticesUWrite (MUVertices mvec) (Vertex ix) v = MU.unsafeWrite mvec ix v--verticesWrite :: PrimMonad m => MVertices g (PrimState m) v -> Vertex g -> v -> m ()-verticesWrite (MVertices mvec) (Vertex ix) v = MV.unsafeWrite mvec ix v--verticesURead :: (PrimMonad m, Unbox v) => MUVertices g (PrimState m) v -> Vertex g -> m v-verticesURead (MUVertices mvec) (Vertex ix) = MU.unsafeRead mvec ix--verticesRead :: PrimMonad m => MVertices g (PrimState m) v -> Vertex g -> m v-verticesRead (MVertices mvec) (Vertex ix) = MV.unsafeRead mvec ix+-- | $mutgraph+-- Operations that mutate a 'MGraph'. Vertices and edges can both be added,+-- and edges can be deleted, but vertices cannot be deleted. Providing such+-- an operation would undermine the safety that this library provides.  -- | This does two things: --@@ -34,7 +35,7 @@ -- --   In either case, the vertex id is returned, regardless or whether it was --   preexisting or newly created.-insertVertex :: (PrimMonad m, Hashable v, Eq v) => MGraph g (PrimState m) e v -> v -> m (Vertex g)+insertVertex :: (PrimMonad m, Hashable v, Eq v) => MGraph (PrimState m) g e v -> v -> m (Vertex g) insertVertex (MGraph vertexIndex currentIdVar _) v = do   m <- HashTable.lookup vertexIndex v   case m of@@ -47,16 +48,44 @@  -- | This replaces the edge if it already exists. If you pass the same vertex --   as the source and the destination, this function has no effect.-insertEdge :: PrimMonad m => MGraph g (PrimState m) e v -> Vertex g -> Vertex g -> e -> m ()+insertEdge :: PrimMonad m => MGraph (PrimState m) g e v -> Vertex g -> Vertex g -> e -> m () insertEdge (MGraph _ _ edges) (Vertex a) (Vertex b) e = do   HashTable.insert edges (IntPair a b) e  -- | Insert edge with a function, combining the existing edge value and the old one.-insertEdgeWith :: PrimMonad m => MGraph g (PrimState m) e v -> (e -> e -> e) -> Vertex g -> Vertex g -> e -> m ()+insertEdgeWith :: PrimMonad m => MGraph (PrimState m) g e v -> (e -> e -> e) -> Vertex g -> Vertex g -> e -> m () insertEdgeWith (MGraph _ _ edges) combine (Vertex a) (Vertex b) e = do   m <- HashTable.lookup edges (IntPair a b)   case m of     Nothing -> HashTable.insert edges (IntPair a b) e     Just eOld -> HashTable.insert edges (IntPair a b) (combine eOld e) +-- | $mutvertices+-- Operations that mutate a 'MVertices' or a 'MUVertices'. These functions have nothing+-- to do with 'MGraph' and are not usually needed by end users of this library. They+-- are useful for users writing algorithms that need to mark vertices in a graph as+-- it is traversed.+--+-- All of these operations are+-- wrappers around operations from @Data.Vector.Mutable@ and @Data.Vector.Unbox.Mutable@.+-- As long as you do not import @Data.Graph.Types.Internal@, this library guarentees that+-- these operations will not fail at runtime.++verticesReplicate :: PrimMonad m => Size g -> v -> m (MVertices (PrimState m) g v)+verticesReplicate (Size i) v = fmap MVertices (MV.replicate i v)++verticesUReplicate :: (PrimMonad m, Unbox v) => Size g -> v -> m (MUVertices (PrimState m) g v)+verticesUReplicate (Size i) v = fmap MUVertices (MU.replicate i v)++verticesUWrite :: (PrimMonad m, Unbox v) => MUVertices (PrimState m) g v -> Vertex g -> v -> m ()+verticesUWrite (MUVertices mvec) (Vertex ix) v = MU.unsafeWrite mvec ix v++verticesWrite :: PrimMonad m => MVertices (PrimState m) g v -> Vertex g -> v -> m ()+verticesWrite (MVertices mvec) (Vertex ix) v = MV.unsafeWrite mvec ix v++verticesURead :: (PrimMonad m, Unbox v) => MUVertices (PrimState m) g v -> Vertex g -> m v+verticesURead (MUVertices mvec) (Vertex ix) = MU.unsafeRead mvec ix++verticesRead :: PrimMonad m => MVertices (PrimState m) g v -> Vertex g -> m v+verticesRead (MVertices mvec) (Vertex ix) = MV.unsafeRead mvec ix 

@@ -2,48 +2,18 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE BangPatterns  #-}-module Data.Graph.Types where--import Data.HashMap.Mutable.Basic (HashTable)-import Data.Vector (Vector,MVector)-import Data.Primitive.MutVar (MutVar)-import Data.Hashable (Hashable)-import GHC.Generics (Generic)-import qualified Data.Vector.Unboxed as U-import qualified Data.Vector.Unboxed.Mutable as MU--newtype Graph g e v = Graph { getGraphInternal :: SomeGraph e v }-  deriving (Functor)---- | The neighbor vertices and neighbor edges must have---   equal length.------   TODO: enforce that the inner vectors for the neighbors are---   ordered. This will make testing for neighbors easier and---   will make an equality check easier.-data SomeGraph e v = SomeGraph-  { graphVertices :: !(Vector v)-  , graphOutboundNeighborVertices :: !(Vector (U.Vector Int))-  , graphOutboundNeighborEdges :: !(Vector (Vector e))-  } deriving (Functor)--newtype Size g = Size { getSizeInternal :: Int }--newtype Vertex g = Vertex { getVertexInternal :: Int }-  deriving (Eq,Ord,Hashable)-newtype Vertices g v = Vertices { getVerticesInternal :: Vector v }-  deriving (Functor)-newtype MVertices g s v = MVertices { getMVerticesInternal :: MVector s v }-newtype MUVertices g s v = MUVertices { getMUVerticesInternal :: MU.MVector s v }--data IntPair = IntPair !Int !Int-  deriving (Eq,Ord,Show,Read,Generic)--instance Hashable IntPair+module Data.Graph.Types+  ( SomeGraph+  , Graph+  , Vertex+  , Size+  , Vertices+  , MVertices+  , MUVertices+  , MGraph+  , IOGraph+  , STGraph+  ) where -data MGraph g s e v = MGraph-  { mgraphVertexIndex :: !(HashTable s v Int)-  , mgraphCurrentId :: !(MutVar s Int)-  , mgraphEdges :: !(HashTable s IntPair e)-  }+import Data.Graph.Types.Internal 

@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns  #-}++{-# OPTIONS_HADDOCK not-home #-}++-- | Unsafe Internals+--+-- The internals provided here do not constitute part of the stable API.+-- Additionally, they are unsafe. Using these data constructors directly+-- can cause other functions in this library to segfault. If you find that+-- you need something from this module, consider opening up an issue on+-- github so that the functionality you need can be provided by the safe+-- API instead.+--+module Data.Graph.Types.Internal where++import Data.HashMap.Mutable.Basic (MHashMap)+import Data.Vector (Vector,MVector)+import Data.Primitive.MutVar (MutVar)+import Data.Hashable (Hashable)+import GHC.Generics (Generic)+import Control.Monad.ST (RealWorld)+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU++-- | A 'Graph' with edges labeled by @e@ and vertices labeled by @v@.+--   The @g@ type variable is a phatom type that associates a+--   'Graph' with vertices that belong to it.+newtype Graph g e v = Graph { getGraphInternal :: SomeGraph e v }+  deriving (Functor)++-- | This is a 'Graph' without the phantom type variable. Very few+--   functions work with this type.+data SomeGraph e v = SomeGraph+  { graphVertices                 :: !(Vector v)+  , graphOutboundNeighborVertices :: !(Vector (U.Vector Int))+  , graphOutboundNeighborEdges    :: !(Vector (Vector e))+  } deriving (Functor, Eq, Ord)+-- The neighbor vertices and neighbor edges must have+-- equal length.+--+-- TODO: enforce that the inner vectors for the neighbors are+-- ordered. This will make testing for neighbors easier and+-- will make an equality check easier.++newtype Size g = Size { getSizeInternal :: Int }++-- | A reference to a vertex in a 'Graph' with matching type variable @g@.+--   'Vertex' is a thin wrapper for 'Int' and does not hold the label+--   of the vertex.+newtype Vertex g = Vertex { getVertexInternal :: Int }+  deriving (Eq,Ord,Hashable)++-- | All vertices in a 'Graph' with matching type variable @g@.+newtype Vertices g v = Vertices { getVerticesInternal :: Vector v }+  deriving (Functor)++-- | Mutable vertices that have the same length as the vertices in a 'Graph'.+--   This is used to safely implement algorithms that need to mark vertices+--   as they traverse a graph.+newtype MVertices s g v = MVertices { getMVerticesInternal :: MVector s v }++-- | Mutable unboxed vertices that have the same length as the vertices in a 'Graph'.+--   See 'MVertices'.+newtype MUVertices s g v = MUVertices { getMUVerticesInternal :: MU.MVector s v }++-- | A strict pair of 'Int's. This is used internally.+data IntPair = IntPair !Int !Int+  deriving (Eq,Ord,Show,Read,Generic)++instance Hashable IntPair++-- | This is more accurately thought of as a graph builder rather than a mutable+--   graph. You can add vertices and edges, and you can delete edges, but you cannot+--   delete vertices.+data MGraph s g e v = MGraph+  { mgraphVertexIndex :: !(MHashMap s v Int)+  , mgraphCurrentId :: !(MutVar s Int)+  , mgraphEdges :: !(MHashMap s IntPair e)+  }++type IOGraph = MGraph RealWorld+type STGraph s = MGraph s+

@@ -2,8 +2,24 @@ {-# LANGUAGE CPP          #-} {-# LANGUAGE MagicHash    #-} +-- | This whole module is mostly copied from the+--   <http://hackage.haskell.org/package/hashtables hashtables> package.+--   You can find much better documentation there. Additionally, if you+--   problem in the implementation of a function, you should probably open+--   up the issue on the <https://github.com/gregorycollins/hashtables hashtables github repo>+--   since Gregory is the one who actually authored (and the one who+--   actually understands) this code. The main differences are as follows:+--+--   * The type is named @MHashMap@ instead of @HashTable@.+--   * All functions are generalized to work in any 'PrimMonad' instead+--     of only 'ST'.+--   * The functions 'mapM_' and 'foldM' have been curried. They do not+--     take tuples here.+--   * There is no type class used to overload the hashtable operations.+--+ module Data.HashMap.Mutable.Basic-  ( HashTable+  ( MHashMap   , new   , newSized   , delete@@ -40,7 +56,7 @@  ------------------------------------------------------------------------------ -- | An open addressing hash table using linear probing.-newtype HashTable s k v = HT (MutVar s (HashTable_ s k v))+newtype MHashMap s k v = HT (MutVar s (HashTable_ s k v))  type SizeRefs s = A.MutableByteArray s @@ -67,7 +83,7 @@     return a  -data HashTable_ s k v = HashTable+data HashTable_ s k v = MHashMap     { _size   :: {-# UNPACK #-} !Int     , _load   :: !(SizeRefs s)   -- ^ 2-element array, stores how many entries                                   -- and deleted entries are in the table.@@ -78,22 +94,15 @@   -------------------------------------------------------------------------------instance Show (HashTable s k v) where-    show _ = "<HashTable>"+instance Show (MHashMap s k v) where+    show _ = "<MHashMap>"  ---------------------------------------------------------------------------------- | See the documentation for this function in--- "Data.HashTable.Class#v:new".-new :: PrimMonad m => m (HashTable (PrimState m) k v)+new :: PrimMonad m => m (MHashMap (PrimState m) k v) new = newSized 1 {-# INLINE new #-} ----------------------------------------------------------------------------------- | See the documentation for this function in--- "Data.HashTable.Class#v:newSized".-newSized :: PrimMonad m => Int -> m (HashTable (PrimState m) k v)+newSized :: PrimMonad m => Int -> m (MHashMap (PrimState m) k v) newSized n = do     debug $ "entering: newSized " ++ show n     let m = nextBestPrime $ ceiling (fromIntegral n / maxLoad)@@ -101,8 +110,6 @@     newRef ht {-# INLINE newSized #-} -------------------------------------------------------------------------------- newSizedReal :: PrimMonad m => Int -> m (HashTable_ (PrimState m) k v) newSizedReal m = do     -- make sure the hash array is a multiple of cache-line sized so we can@@ -113,14 +120,10 @@     k  <- newArray m undefined     v  <- newArray m undefined     ld <- newSizeRefs-    return $! HashTable m ld h k v-+    return $! MHashMap m ld h k v ---------------------------------------------------------------------------------- | See the documentation for this function in--- "Data.HashTable.Class#v:delete". delete :: (PrimMonad m, Hashable k, Eq k) =>-          (HashTable (PrimState m) k v)+          (MHashMap (PrimState m) k v)        -> k        -> m () delete htRef k = do@@ -132,16 +135,12 @@     !h = hash k {-# INLINE delete #-} ----------------------------------------------------------------------------------- | See the documentation for this function in--- "Data.HashTable.Class#v:lookup".-lookup :: (PrimMonad m, Eq k, Hashable k) => (HashTable (PrimState m) k v) -> k -> m (Maybe v)+lookup :: (PrimMonad m, Eq k, Hashable k) => (MHashMap (PrimState m) k v) -> k -> m (Maybe v) lookup htRef !k = do     ht <- readRef htRef     lookup' ht   where-    lookup' (HashTable sz _ hashes keys values) = do+    lookup' (MHashMap sz _ hashes keys values) = do         let !b = whichBucket h sz         debug $ "lookup h=" ++ show h ++ " sz=" ++ show sz ++ " b=" ++ show b         go b 0 sz@@ -184,12 +183,8 @@                            else go (idx + 1) start end {-# INLINE lookup #-} ----------------------------------------------------------------------------------- | See the documentation for this function in--- "Data.HashTable.Class#v:insert". insert :: (PrimMonad m, Eq k, Hashable k) =>-          (HashTable (PrimState m) k v)+          (MHashMap (PrimState m) k v)        -> k        -> v        -> m ()@@ -224,14 +219,10 @@         values = _values ht {-# INLINE insert #-} ----------------------------------------------------------------------------------- | See the documentation for this function in--- "Data.HashTable.Class#v:foldM".-foldM :: PrimMonad m => (a -> (k,v) -> m a) -> a -> HashTable (PrimState m) k v -> m a+foldM :: PrimMonad m => (a -> k -> v -> m a) -> a -> MHashMap (PrimState m) k v -> m a foldM f seed0 htRef = readRef htRef >>= work   where-    work (HashTable sz _ hashes keys values) = go 0 seed0+    work (MHashMap sz _ hashes keys values) = go 0 seed0       where         go !i !seed | i >= sz = return seed                     | otherwise = do@@ -241,17 +232,13 @@               else do                 k <- readArray keys i                 v <- readArray values i-                !seed' <- f seed (k, v)+                !seed' <- f seed k v                 go (i+1) seed' ----------------------------------------------------------------------------------- | See the documentation for this function in--- "Data.HashTable.Class#v:mapM_".-mapM_ :: PrimMonad m => (k -> v -> m b) -> HashTable (PrimState m) k v -> m ()+mapM_ :: PrimMonad m => (k -> v -> m b) -> MHashMap (PrimState m) k v -> m () mapM_ f htRef = readRef htRef >>= work   where-    work (HashTable sz _ hashes keys values) = go 0+    work (MHashMap sz _ hashes keys values) = go 0       where         go !i | i >= sz = return ()               | otherwise = do@@ -264,14 +251,10 @@                 _ <- f k v                 go (i+1) ----------------------------------------------------------------------------------- | See the documentation for this function in--- "Data.HashTable.Class#v:computeOverhead".-computeOverhead :: PrimMonad m => HashTable (PrimState m) k v -> m Double+computeOverhead :: PrimMonad m => MHashMap (PrimState m) k v -> m Double computeOverhead htRef = readRef htRef >>= work   where-    work (HashTable sz' loadRef _ _ _) = do+    work (MHashMap sz' loadRef _ _ _) = do         !ld <- readLoad loadRef         let k = fromIntegral ld / sz         return $ constOverhead/sz + (2 + 2*ws*(1-k)) / (k * ws)@@ -319,7 +302,7 @@ checkOverflow :: (PrimMonad m, Eq k, Hashable k) =>                  (HashTable_ (PrimState m) k v)               -> m (HashTable_ (PrimState m) k v)-checkOverflow ht@(HashTable sz ldRef _ _ _) = do+checkOverflow ht@(MHashMap sz ldRef _ _ _) = do     !ld <- readLoad ldRef     let !ld' = ld + 1     writeLoad ldRef ld'@@ -341,10 +324,10 @@  ------------------------------------------------------------------------------ rehashAll :: (Hashable k, PrimMonad m) => HashTable_ (PrimState m) k v -> Int -> m (HashTable_ (PrimState m) k v)-rehashAll (HashTable sz loadRef hashes keys values) sz' = do+rehashAll (MHashMap sz loadRef hashes keys values) sz' = do     debug $ "rehashing: old size " ++ show sz ++ ", new size " ++ show sz'     ht' <- newSizedReal sz'-    let (HashTable _ loadRef' newHashes newKeys newValues) = ht'+    let (MHashMap _ loadRef' newHashes newKeys newValues) = ht'     readLoad loadRef >>= writeLoad loadRef'     rehash newHashes newKeys newValues     return ht'@@ -365,7 +348,7 @@  ------------------------------------------------------------------------------ growTable :: (Hashable k, PrimMonad m) => HashTable_ (PrimState m) k v -> m (HashTable_ (PrimState m) k v)-growTable ht@(HashTable sz _ _ _ _) = do+growTable ht@(MHashMap sz _ _ _ _) = do     let !sz' = bumpSize maxLoad sz     rehashAll ht sz' @@ -395,7 +378,7 @@         -> k         -> Int         -> m Int-delete' (HashTable sz loadRef hashes keys values) clearOut k h = do+delete' (MHashMap sz loadRef hashes keys values) clearOut k h = do     debug $ "delete': h=" ++ show h ++ " he=" ++ show he             ++ " sz=" ++ show sz ++ " b0=" ++ show b0     pair@(found, slot) <- go mempty b0 False@@ -551,15 +534,15 @@   -------------------------------------------------------------------------------newRef :: PrimMonad m => HashTable_ (PrimState m) k v -> m (HashTable (PrimState m) k v)+newRef :: PrimMonad m => HashTable_ (PrimState m) k v -> m (MHashMap (PrimState m) k v) newRef = liftM HT . newMutVar {-# INLINE newRef #-} -writeRef :: PrimMonad m => HashTable (PrimState m) k v -> HashTable_ (PrimState m) k v -> m ()+writeRef :: PrimMonad m => MHashMap (PrimState m) k v -> HashTable_ (PrimState m) k v -> m () writeRef (HT ref) ht = writeMutVar ref ht {-# INLINE writeRef #-} -readRef :: PrimMonad m => HashTable (PrimState m) k v -> m (HashTable_ (PrimState m) k v)+readRef :: PrimMonad m => MHashMap (PrimState m) k v -> m (HashTable_ (PrimState m) k v) readRef (HT ref) = readMutVar ref {-# INLINE readRef #-} 

@@ -29,7 +29,7 @@ --     onto the heap, the priority of the existing one and the priority of the one you are attempting --     to push will be combined with the 'Monoid' instance. (Note: this could definitely be weakened --     to 'Semigroup'). At the moment, only bubble up is attempted after this operation, so if this---     causing the priority to increas, the heap becomes invalid (but not in a way that causes+--     causes the priority to increase, the heap becomes invalid (but not in a way that causes --     segfaults). -- --   As a result of the last constraint, the 'Monoid' instance and 'Ord' instance of the priority type

@@ -0,0 +1,59 @@+{-# LANGUAGE BangPatterns #-}++module Data.Trie.Immutable.Bits+  ( Trie(..)+  , empty+  , lookup+  , freeze+  ) where++import Prelude hiding (lookup)+import Control.Monad.Primitive+import Data.Bits+import Data.Primitive.ByteArray+import Data.Primitive.MutVar.Maybe+import Data.Trie.Mutable.Bits (MTrie(..))++data Trie k v = Trie+  { trieValue :: !(Maybe v)+  , trieLeft  :: !(Maybe (Trie k v))+  , trieRight :: !(Maybe (Trie k v))+  }++empty :: Trie k v+empty = Trie Nothing Nothing Nothing++-- | This gives the best match, that is, the+--   value stored at the longest prefix that+--   matched this key.+lookup :: FiniteBits k+  => Trie k v+  -> k+  -> Maybe v+lookup theTrie theKey = go Nothing theTrie theKey where+  totalBits :: Int+  totalBits = finiteBitSize theKey+  -- mask :: k+  mask = bit (totalBits - 1)+  -- zero :: k+  zero = zeroBits+  go !mres (Trie mval mleft mright) key =+    let chosen = if (mask .&. key) == zero then mleft else mright+     in case chosen of+          Nothing -> mval+          Just nextTrie -> go mval nextTrie (unsafeShiftL key 1)++freeze :: PrimMonad m => MTrie (PrimState m) k v -> m (Trie k v)+freeze = go where+  go (MTrie valVar leftVar rightVar) = do+    mleft  <- readMutMaybeVar leftVar+    mright <- readMutMaybeVar rightVar+    mval   <- readMutMaybeVar valVar+    immutableLeft <- case mleft of+      Just left -> fmap Just $ go left+      Nothing -> return Nothing+    immutableRight <- case mright of+      Just right -> fmap Just $ go right+      Nothing -> return Nothing+    return (Trie mval immutableLeft immutableRight)+

@@ -1,21 +1,23 @@ {-# LANGUAGE BangPatterns #-} -module Data.Trie.Mutable.Bits where+module Data.Trie.Mutable.Bits+  ( MTrie(..)+  , new+  , lookup+  , insert+  , insertPrefix+  ) where +import Prelude hiding (lookup) import Control.Monad.Primitive import Data.Bits import Data.Primitive.ByteArray-import Data.Primitive.Array import Data.Primitive.MutVar.Maybe-import Data.Word-import GHC.TypeLits-import Data.Primitive.PrimArray-import Data.Primitive.Bool (BoolByte(..))  data MTrie s k v = MTrie-  { trieValue :: !(MutMaybeVar s v)-  , trieLeft  :: !(MutMaybeVar s (MTrie s k v))-  , trieRight :: !(MutMaybeVar s (MTrie s k v))+  { mtrieValue :: !(MutMaybeVar s v)+  , mtrieLeft  :: !(MutMaybeVar s (MTrie s k v))+  , mtrieRight :: !(MutMaybeVar s (MTrie s k v))   }  new :: PrimMonad m => m (MTrie (PrimState m) k v)@@ -89,5 +91,6 @@         Just nextTrie -> return nextTrie       go (significant - 1) (unsafeShiftL key 1) nextTrie     else writeMutMaybeVar valRef (Just value)+  

@@ -131,8 +131,7 @@ graphBuildingVertices :: [Int] -> Bool graphBuildingVertices xs =   let sg = runST $ Graph.create $ \mg -> do-        forM_ xs $ \x -> do-          MGraph.insertVertex mg x+        forM_ xs (MGraph.insertVertex mg)       ys = Graph.with sg (Graph.verticesToVector . Graph.vertices)    in List.nub (List.sort xs) == List.sort (V.toList ys) @@ -171,7 +170,7 @@         (Just _,Nothing)  -> False         (Just start, Just end) ->           let expected = Min (sum xs)-           in expected == Graph.dijkstra (\_ _ (Min x) distance -> Min (x + distance)) (Min 0) start end g+           in expected == Graph.dijkstraMonoidal (\_ _ (Min x) distance -> Min (x + distance)) (Min 0) start end g  data Thing = Foo | Bar Int | Baz Bool   deriving (Eq,Show)