Use bulk IntMap operations

* Use `Data.IntMap.differenceWith` to implement `(&)` and `match`
for `Data.Graph.Inductive.PatriciaTree`. Instead of modifying
the graph manually, one key at a time, `differenceWith` will
efficiently partition the set of keys to be modified along the
structure of the graph. This should be considerably more efficient
when inserting or matching on well-connected nodes.

* Require `containers >= 0.5.0`. Since that came out in 2012,
  and works with `base` going all the way back to 4.2 (which
  came out in 2009) it seems a reasonable dependency. I want it
  for `Data.IntMap.Strict`.

Fixes haskell#39

.gitignore

@@ -8,5 +8,6 @@ cabal-dev
 .hsenv
 .cabal-sandbox/
 cabal.sandbox.config
+.stack-work
 cabal.config
 TAGS

Data/Graph/Inductive/Internal/Heap.hs

@@ -14,18 +14,14 @@ module Data.Graph.Inductive.Internal.Heap(
 
 import Text.Show (showListWith)
 
-#if MIN_VERSION_containers (0,4,2)
 import Control.DeepSeq (NFData (..))
-#endif
 
 data Heap a b = Empty | Node a b [Heap a b]
      deriving (Eq, Show, Read)
 
-#if MIN_VERSION_containers (0,4,2)
 instance (NFData a, NFData b) => NFData (Heap a b) where
   rnf Empty         = ()
   rnf (Node a b hs) = rnf a `seq` rnf b `seq` rnf hs
-#endif
 
 prettyHeap :: (Show a, Show b) => Heap a b -> String
 prettyHeap = (`showsHeap` "")

Data/Graph/Inductive/NodeMap.hs

@@ -34,19 +34,15 @@ import qualified Prelude                    as P (map)
 import           Data.Map (Map)
 import qualified Data.Map as M
 
-#if MIN_VERSION_containers (0,4,2)
 import Control.DeepSeq (NFData (..))
-#endif
 
 data NodeMap a =
     NodeMap { map :: Map a Node,
               key :: Int }
     deriving (Eq, Show, Read)
 
-#if MIN_VERSION_containers (0,4,2)
 instance (NFData a) => NFData (NodeMap a) where
   rnf (NodeMap mp k) = rnf mp `seq` rnf k
-#endif
 
 -- | Create a new, empty mapping.
 new :: NodeMap a

Data/Graph/Inductive/PatriciaTree.hs

@@ -30,12 +30,12 @@ import Data.Graph.Inductive.Graph
 import           Control.Applicative (liftA2)
 import           Data.IntMap         (IntMap)
 import qualified Data.IntMap         as IM
+import qualified Data.IntMap.Strict  as IMS
 import           Data.List           (sort)
 import           Data.Maybe          (fromMaybe)
+import           Data.Foldable       (foldl')
 
-#if MIN_VERSION_containers (0,4,2)
 import Control.DeepSeq (NFData (..))
-#endif
 
 #if __GLASGOW_HASKELL__ >= 702
 import GHC.Generics (Generic)
@@ -115,15 +115,15 @@ instance Graph Gr where
 
 instance DynGraph Gr where
     (p, v, l, s) & (Gr g)
-        = let !g1 = IM.insert v (fromAdj p, l, fromAdj s) g
-              !g2 = addSucc g1 v p
-              !g3 = addPred g2 v s
+        = let !g1 = IM.insert v (preds, l, succs) g
+              !g2 = addSucc g1 v preds
+              !g3 = addPred g2 v succs
+              !preds = fromAdj p
+              !succs = fromAdj s
           in Gr g3
 
-#if MIN_VERSION_containers (0,4,2)
 instance (NFData a, NFData b) => NFData (Gr a b) where
   rnf (Gr g) = rnf g
-#endif
 
 #if MIN_VERSION_base (4,8,0)
 instance Bifunctor Gr where
@@ -144,8 +144,8 @@ matchGr node (Gr g)
             -> let !g1 = IM.delete node g
                    !p' = IM.delete node p
                    !s' = IM.delete node s
-                   !g2 = clearPred g1 node (IM.keys s')
-                   !g3 = clearSucc g2 node (IM.keys p')
+                   !g2 = clearPred g1 node s'
+                   !g3 = clearSucc g2 node p'
                in (Just (toAdj p', node, label, toAdj s), Gr g3)
 
 ----------------------------------------------------------------------
@@ -220,6 +220,22 @@ toAdj = concatMap expand . IM.toList
 fromAdj :: Adj b -> IntMap [b]
 fromAdj = IM.fromListWith addLists . map (second (:[]) . swap)
 
+data FromListCounting a = FromListCounting !Int !(IntMap a)
+
+getFromListCounting :: FromListCounting a -> (Int, IntMap a)
+getFromListCounting (FromListCounting i m) = (i, m)
+{-# INLINE getFromListCounting #-}
+
+fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
+fromListWithKeyCounting f = getFromListCounting . foldl' ins (FromListCounting 0 IM.empty)
+  where
+    ins (FromListCounting i t) (k,x) = FromListCounting (i + 1) (IM.insertWithKey f k x t)
+{-# INLINE fromListWithKeyCounting #-}
+
+fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
+fromListWithCounting f = fromListWithKeyCounting (\_ x y -> f x y)
+{-# INLINE fromListWithCounting #-}
+
 toContext :: Node -> Context' a b -> Context a b
 toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss)
 
@@ -238,33 +254,30 @@ addLists [a] as  = a : as
 addLists as  [a] = a : as
 addLists xs  ys  = xs ++ ys
 
-addSucc :: GraphRep a b -> Node -> [(b, Node)] -> GraphRep a b
-addSucc g _ []              = g
-addSucc g v ((l, p) : rest) = addSucc g' v rest
-    where
-      g' = IM.adjust f p g
-      f (ps, l', ss) = (ps, l', IM.insertWith addLists v [l] ss)
-
-
-addPred :: GraphRep a b -> Node -> [(b, Node)] -> GraphRep a b
-addPred g _ []              = g
-addPred g v ((l, s) : rest) = addPred g' v rest
+addSucc :: forall a b . GraphRep a b -> Node -> IM.IntMap [b] -> GraphRep a b
+addSucc g v = IMS.differenceWith go g
   where
-    g' = IM.adjust f s g
-    f (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss)
-
+    go :: Context' a b -> [b] -> Maybe (Context' a b)
+    go (ps, l', ss) l = let !ss' = IM.insertWith (++) v l ss
+                        in Just (ps, l', ss')
 
-clearSucc :: GraphRep a b -> Node -> [Node] -> GraphRep a b
-clearSucc g _ []       = g
-clearSucc g v (p:rest) = clearSucc g' v rest
+addPred :: forall a b . GraphRep a b -> Node -> IM.IntMap [b] -> GraphRep a b
+addPred g v = IMS.differenceWith go g
   where
-    g' = IM.adjust f p g
-    f (ps, l, ss) = (ps, l, IM.delete v ss)
+    go :: Context' a b -> [b] -> Maybe (Context' a b)
+    go (ps, l', ss) l = let !ps' = IM.insertWith (++) v l ps
+                        in Just (ps', l', ss)
 
+clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b
+clearSucc g v = IMS.differenceWith go g
+  where
+    go :: Context' a b -> x -> Maybe (Context' a b)
+    go (ps, l, ss) _ = let !ss' = IM.delete v ss
+                       in Just (ps, l, ss')
 
-clearPred :: GraphRep a b -> Node -> [Node] -> GraphRep a b
-clearPred g _ []       = g
-clearPred g v (s:rest) = clearPred g' v rest
+clearPred :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b
+clearPred g v = IMS.differenceWith go g
   where
-    g' = IM.adjust f s g
-    f (ps, l, ss) = (IM.delete v ps, l, ss)
+    go :: Context' a b -> x -> Maybe (Context' a b)
+    go (ps, l, ss) _ = let !ps' = IM.delete v ps
+                       in Just (ps', l, ss)

Data/Graph/Inductive/Tree.hs

@@ -19,9 +19,7 @@ import           Data.Map            (Map)
 import qualified Data.Map            as M
 import           Data.Maybe          (fromMaybe)
 
-#if MIN_VERSION_containers (0,4,2)
 import Control.DeepSeq (NFData (..))
-#endif
 
 #if __GLASGOW_HASKELL__ >= 702
 import GHC.Generics (Generic)
@@ -130,10 +128,8 @@ instance DynGraph Gr where
                        (const (error ("Node Exception, Node: "++show v)))
       cntxt' = (p,l,s)
 
-#if MIN_VERSION_containers (0,4,2)
 instance (NFData a, NFData b) => NFData (Gr a b) where
   rnf (Gr g) = rnf g
-#endif
 
 #if MIN_VERSION_base (4,8,0)
 instance Bifunctor Gr where

fgl.cabal

@@ -24,11 +24,6 @@ source-repository head
     type:         git
     location:     git://github.com/haskell/fgl.git
 
-flag containers042 {
-    manual:  False
-    default: True
-}
-
 library {
     default-language: Haskell98
 
@@ -69,11 +64,8 @@ library {
                     , transformers
                     , array
 
-    if flag(containers042)
-        build-depends:    containers >= 0.4.2
-                        , deepseq >= 1.1.0.0 && < 1.5
-    else
-        build-depends:    containers < 0.4.2
+    build-depends:    containers >= 0.5.0
+                    , deepseq >= 1.1.0.0 && < 1.5
 
     if impl(ghc >= 7.2) && impl(ghc < 7.6)
         build-depends:
@@ -125,20 +117,3 @@ benchmark fgl-benchmark {
     ghc-options: -Wall -O2
 
 }
-
-benchmark fgl-benchmark {
-    default-language: Haskell98
-
-    type: exitcode-stdio-1.0
-
-    hs-source-dirs: test
-
-    main-is: benchmark.hs
-
-    build-depends:   fgl
-                   , base
-                   , microbench
-
-    ghc-options: -Wall
-
-}