Add cabal benchmark integration

* Add the benchmarks to `fgl.cabal`.

* Disable AVL benchmarks that result in errors. Surely something
  needs to be fixed!

* Add benchmark for building a full graph with `&`.

* Enable GHC optimizations. Otherwise, none of the `RULES` or
  inlining the source code talks about can ever happen.

Add cabal benchmark integration

* Add the benchmarks to `fgl.cabal`.

* Disable AVL benchmarks that result in errors. Surely something
  needs to be fixed!

* Add benchmark for building a full graph with `&`.

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

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.

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 np preds
+              !g3 = addPred g2 v succs
+              !(np, preds) = fromAdjCounting p
+              !(ns, succs) = fromAdjCounting 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,25 @@ 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 #-}
+
+fromAdjCounting :: Adj b -> (Int, IntMap [b])
+fromAdjCounting = fromListWithCounting addLists . map (second (:[]) . swap)
+
 toContext :: Node -> Context' a b -> Context a b
 toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss)
 
@@ -238,33 +257,33 @@ 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)
-
+-- We use differenceWith to modify a graph more than bulkThreshold times,
+-- and repeated insertWith to modify fewer times.
+bulkThreshold :: Int
+bulkThreshold = 5
 
-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 -> Int -> IM.IntMap [b] -> GraphRep a b
+addSucc g v numAdd
+  | numAdd < 
+addSucc g v numAdd xs = IM.differenceWith go g xs
   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 = Just (ps, l', IM.insertWith (++) v 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 = IM.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 = Just (IM.insertWith (++) v l ps, l', ss)
 
+clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b
+clearSucc g v = IM.differenceWith go g
+  where
+    go :: Context' a b -> x -> Maybe (Context' a b)
+    go (ps, l, ss) _ = Just (ps, l, IM.delete v 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 = IM.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) _ = Just (IM.delete v 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,17 +64,14 @@ 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:
             ghc-prim
 
-    ghc-options:      -Wall
+    ghc-options:      -Wall -O2
 
 }
 
@@ -104,6 +96,24 @@ test-suite fgl-tests {
                     , Data.Graph.Inductive.Proxy
                     , Data.Graph.Inductive.Query.Properties
 
-    ghc-options:      -Wall
+    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
+                   , deepseq
+
+    ghc-options: -Wall -O2
 
 }

test/benchmark.hs

@@ -1,7 +1,15 @@
 {-
-  Install microbench to build this program:
+  This program should generally be run using `cabal bench` or
+  `stack bench`. To use `stack bench`, edit stack.yaml to include
+
+  extra-deps:
+  - microbench-0.1
+
+  To run run benchmarks manually, install microbench from
   http://hackage.haskell.org/cgi-bin/hackage-scripts/package/microbench
 
+  then run
+
   % ghc -O --make benchmark
   % ./benchmark
   [1 of 1] Compiling Main             ( benchmark.hs, benchmark.o )
@@ -27,18 +35,25 @@
   * emap on PATRICIA tree: ...................
     4.532ns per iteration / 220663.09 per second.
 -}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 import Data.Graph.Inductive.Graph
 import qualified Data.Graph.Inductive.Tree as AVL
 import qualified Data.Graph.Inductive.PatriciaTree as Patricia
 import Microbench
-
+import Data.Foldable (foldl')
+import Control.DeepSeq
+import Data.Proxy
 
 main :: IO ()
 main = do microbench "insNode into AVL tree" insNodeAVL
           microbench "insNode into PATRICIA tree" insNodePatricia
 
-          microbench "insEdge into AVL tree" insEdgeAVL
+          microbench "buildFull into PATRICIA tree 100" (buildFullPatricia 100)
+          microbench "buildFull into PATRICIA tree 500" (buildFullPatricia 500)
+          microbench "buildFull into PATRICIA tree 1000" (buildFullPatricia 1000)
+
+--          microbench "insEdge into AVL tree" insEdgeAVL
           microbench "insEdge into PATRICIA tree" insEdgePatricia
 
           microbench "gmap on AVL tree" gmapAVL
@@ -47,17 +62,27 @@ main = do microbench "insNode into AVL tree" insNodeAVL
           microbench "nmap on AVL tree" nmapAVL
           microbench "nmap on PATRICIA tree" nmapPatricia
 
-          microbench "emap on AVL tree" emapAVL
+--          microbench "emap on AVL tree" emapAVL
           microbench "emap on PATRICIA tree" emapPatricia
 
 
 insNodeAVL :: Int -> AVL.UGr
 insNodeAVL = insNodes' empty
 
+buildFullPatricia :: Int -> Int -> ()
+buildFullPatricia sz i = buildFull (Proxy :: Proxy Patricia.Gr) sz i
 
 insNodePatricia :: Int -> Patricia.UGr
 insNodePatricia = insNodes' empty
 
+buildFull :: forall gr proxy . (DynGraph gr, NFData (gr Int ())) => proxy gr -> Int -> Int -> ()
+buildFull _ sz ntimes = rnf [buildFull' i (empty :: gr Int ()) 0 sz | i <- [0..ntimes-1]]
+
+buildFull' :: DynGraph gr => a -> gr a () -> Int -> Int -> gr a ()
+buildFull' a g n limit
+  | n == limit = empty
+  | otherwise = ([((), k) | k <- [0..n-1]],n,a,[((),k) | k <- [0..n-1]]) & buildFull' a g (n + 1) limit
+
 
 {-# INLINE insNodes' #-}
 insNodes' :: DynGraph gr => gr () b -> Int -> gr () b
@@ -135,4 +160,4 @@ emapPatricia n
           g'  = emap f g
           f _ = n
       in
-        g'
+        g'