Use Safe Haskell for GHC >= 7.2
[packages/containers.git] / Data / Graph.hs
index 130c7dd..1bc30c3 100644 (file)
@@ -1,3 +1,6 @@
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Trustworthy #-}
+#endif
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Graph
@@ -6,7 +9,7 @@
 -- 
 -- Maintainer  :  libraries@haskell.org
 -- Stability   :  experimental
--- Portability :  non-portable (requires non-portable module ST)
+-- Portability :  portable
 --
 -- A version of the graph algorithms described in:
 --
@@ -28,7 +31,7 @@ module Data.Graph(
 
        -- ** Building graphs
 
-       graphFromEdges, buildG, transposeG,
+       graphFromEdges, graphFromEdges', buildG, transposeG,
        -- reverseE,
 
        -- ** Graph properties
@@ -43,16 +46,25 @@ module Data.Graph(
        components,
        scc,
        bcc,
-       -- back, cross, forward,
+       -- tree, back, cross, forward,
        reachable, path,
 
        module Data.Tree
 
     ) where
 
+#if __GLASGOW_HASKELL__
+# define USE_ST_MONAD 1
+#endif
+
 -- Extensions
+#if USE_ST_MONAD
 import Control.Monad.ST
 import Data.Array.ST (STArray, newArray, readArray, writeArray)
+#else
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as Set
+#endif
 import Data.Tree (Tree(Node), Forest)
 
 -- std interfaces
@@ -101,7 +113,7 @@ stronglyConnComp edges0
 -- | The strongly connected components of a directed graph, topologically
 -- sorted.  The function is the same as 'stronglyConnComp', except that
 -- all the information about each node retained.
--- The "R" interface is used when you expect to apply 'SCC' to
+-- This interface is used when you expect to apply 'SCC' to
 -- (some of) the result of 'SCC', so you don't want to lose the
 -- dependency information.
 stronglyConnCompR
@@ -117,7 +129,7 @@ stronglyConnCompR [] = []  -- added to avoid creating empty array in graphFromEd
 stronglyConnCompR edges0
   = map decode forest
   where
-    (graph, vertex_fn) = graphFromEdges edges0
+    (graph, vertex_fn,_) = graphFromEdges edges0
     forest            = scc graph
     decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
                       | otherwise         = AcyclicSCC (vertex_fn v)
@@ -175,6 +187,16 @@ outdegree  = mapT numEdges
 indegree :: Graph -> Table Int
 indegree  = outdegree . transposeG
 
+-- | Identical to 'graphFromEdges', except that the return value
+-- does not include the function which maps keys to vertices.  This
+-- version of 'graphFromEdges' is for backwards compatibility.
+graphFromEdges'
+       :: Ord key
+       => [(node, key, [key])]
+       -> (Graph, Vertex -> (node, key, [key]))
+graphFromEdges' x = (a,b) where
+    (a,b,_) = graphFromEdges x
+
 -- | Build a graph from a list of nodes uniquely identified by keys,
 -- with a list of keys of nodes this node should have edges to.
 -- The out-list may contain keys that don't correspond to
@@ -182,9 +204,9 @@ indegree  = outdegree . transposeG
 graphFromEdges
        :: Ord key
        => [(node, key, [key])]
-       -> (Graph, Vertex -> (node, key, [key]))
+       -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
 graphFromEdges edges0
-  = (graph, \v -> vertex_map ! v)
+  = (graph, \v -> vertex_map ! v, key_vertex)
   where
     max_v                  = length edges0 - 1
     bounds0         = (0,max_v) :: (Vertex, Vertex)
@@ -216,17 +238,6 @@ graphFromEdges edges0
 --                                                                     -
 -------------------------------------------------------------------------
 
-type Set s    = STArray s Vertex Bool
-
-mkEmpty      :: Bounds -> ST s (Set s)
-mkEmpty bnds  = newArray bnds False
-
-contains     :: Set s -> Vertex -> ST s Bool
-contains m v  = readArray m v
-
-include      :: Set s -> Vertex -> ST s ()
-include m v   = writeArray m v True
-
 -- | A spanning forest of the graph, obtained from a depth-first search of
 -- the graph starting from each vertex in an unspecified order.
 dff          :: Graph -> Forest Vertex
@@ -242,21 +253,62 @@ generate     :: Graph -> Vertex -> Tree Vertex
 generate g v  = Node v (map (generate g) (g!v))
 
 prune        :: Bounds -> Forest Vertex -> Forest Vertex
-prune bnds ts = runST (mkEmpty bnds  >>= \m ->
-                       chop m ts)
+prune bnds ts = run bnds (chop ts)
 
-chop         :: Set s -> Forest Vertex -> ST s (Forest Vertex)
-chop _ []     = return []
-chop m (Node v ts : us)
-              = contains m v >>= \visited ->
+chop         :: Forest Vertex -> SetM s (Forest Vertex)
+chop []       = return []
+chop (Node v ts : us)
+              = do
+                visited <- contains v
                 if visited then
-                  chop us
-                else
-                  include m v >>= \_  ->
-                  chop m ts   >>= \as ->
-                  chop m us   >>= \bs ->
+                  chop us
+                 else do
+                  include v
+                  as <- chop ts
+                  bs <- chop us
                   return (Node v as : bs)
 
+-- A monad holding a set of vertices visited so far.
+#if USE_ST_MONAD
+
+-- Use the ST monad if available, for constant-time primitives.
+
+newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a }
+
+instance Monad (SetM s) where
+    return x     = SetM $ const (return x)
+    SetM v >>= f = SetM $ \ s -> do { x <- v s; runSetM (f x) s }
+
+run          :: Bounds -> (forall s. SetM s a) -> a
+run bnds act  = runST (newArray bnds False >>= runSetM act)
+
+contains     :: Vertex -> SetM s Bool
+contains v    = SetM $ \ m -> readArray m v
+
+include      :: Vertex -> SetM s ()
+include v     = SetM $ \ m -> writeArray m v True
+
+#else /* !USE_ST_MONAD */
+
+-- Portable implementation using IntSet.
+
+newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) }
+
+instance Monad (SetM s) where
+    return x     = SetM $ \ s -> (x, s)
+    SetM v >>= f = SetM $ \ s -> case v s of (x, s') -> runSetM (f x) s'
+
+run          :: Bounds -> SetM s a -> a
+run _ act     = fst (runSetM act Set.empty)
+
+contains     :: Vertex -> SetM s Bool
+contains v    = SetM $ \ m -> (Set.member v m, m)
+
+include      :: Vertex -> SetM s ()
+include v     = SetM $ \ m -> ((), Set.insert v m)
+
+#endif /* !USE_ST_MONAD */
+
 -------------------------------------------------------------------------
 --                                                                     -
 --     Algorithms
@@ -267,11 +319,14 @@ chop m (Node v ts : us)
 -- Algorithm 1: depth first search numbering
 ------------------------------------------------------------
 
-preorder            :: Tree a -> [a]
-preorder (Node a ts) = a : preorderF ts
+preorder' :: Tree a -> [a] -> [a]
+preorder' (Node a ts) = (a :) . preorderF' ts
 
-preorderF           :: Forest a -> [a]
-preorderF ts         = concat (map preorder ts)
+preorderF' :: Forest a -> [a] -> [a]
+preorderF' ts = foldr (.) id $ map preorder' ts
+
+preorderF :: Forest a -> [a]
+preorderF ts = preorderF' ts []
 
 tabulate        :: Bounds -> [Vertex] -> Table Int
 tabulate bnds vs = array bnds (zipWith (,) vs [1..])
@@ -283,14 +338,14 @@ preArr bnds      = tabulate bnds . preorderF
 -- Algorithm 2: topological sorting
 ------------------------------------------------------------
 
-postorder :: Tree a -> [a]
-postorder (Node a ts) = postorderF ts ++ [a]
+postorder :: Tree a -> [a] -> [a]
+postorder (Node a ts) = postorderF ts . (a :)
 
-postorderF   :: Forest a -> [a]
-postorderF ts = concat (map postorder ts)
+postorderF   :: Forest a -> [a] -> [a]
+postorderF ts = foldr (.) id $ map postorder ts
 
-postOrd      :: Graph -> [Vertex]
-postOrd       = postorderF . dff
+postOrd :: Graph -> [Vertex]
+postOrd g = postorderF (dff g) []
 
 -- | A topological sort of the graph.
 -- The order is partially specified by the condition that a vertex /i/
@@ -321,6 +376,14 @@ scc g = dfs g (reverse (postOrd (transposeG g)))
 -- Algorithm 5: Classifying edges
 ------------------------------------------------------------
 
+{-
+XXX unused code
+
+tree              :: Bounds -> Forest Vertex -> Graph
+tree bnds ts       = buildG bnds (concat (map flat ts))
+ where flat (Node v ts') = [ (v, w) | Node w _us <- ts' ]
+                        ++ concat (map flat ts')
+
 back              :: Graph -> Table Int -> Graph
 back g post        = mapT select g
  where select v ws = [ w | w <- ws, post!v < post!w ]
@@ -330,8 +393,9 @@ cross g pre post   = mapT select g
  where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
 
 forward           :: Graph -> Graph -> Table Int -> Graph
-forward g tree pre = mapT select g
- where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
+forward g tree' pre = mapT select g
+ where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree' ! v
+-}
 
 ------------------------------------------------------------
 -- Algorithm 6: Finding reachable vertices
@@ -361,15 +425,15 @@ do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
 do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
  where us = map (do_label g dnum) ts
        lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
-                     ++ [lu | Node (u,du,lu) xs <- us])
+                     ++ [lu | Node (_,_,lu) _ <- us])
 
 bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
 bicomps (Node (v,_,_) ts)
-      = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
+      = [ Node (v:vs) us | (_,Node vs us) <- map collect ts]
 
 collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
 collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
  where collected = map collect ts
-       vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
+       vs = concat [ ws | (lw, Node ws _) <- collected, lw<dv]
        cs = concat [ if lw<dv then us else [Node (v:ws) us]
                         | (lw, Node ws us) <- collected ]