[commit: packages/containers] ghc-head: Add Functor and Applicative instances for SetM... (c58285c)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/containers

On branch  : ghc-head
Link       : http://git.haskell.org/packages/containers.git/commitdiff/c58285c8faa72a4e787751fd8f6d46dd3fa43359

>---------------------------------------------------------------

commit c58285c8faa72a4e787751fd8f6d46dd3fa43359
Author: Milan Straka <fox at ucw.cz>
Date:   Mon Oct 7 15:13:00 2013 +0200

    Add Functor and Applicative instances for SetM...
    
    ... to get ready for AMP proposal in GHC 7.10 and silence warning
    in GHC 7.8.


>---------------------------------------------------------------

c58285c8faa72a4e787751fd8f6d46dd3fa43359
 Data/Graph.hs |   29 ++++++++++++++++++++++++++---
 1 file changed, 26 insertions(+), 3 deletions(-)

diff --git a/Data/Graph.hs b/Data/Graph.hs
index d7a4b92..3ddc4be 100644
--- a/Data/Graph.hs
+++ b/Data/Graph.hs
@@ -72,6 +72,7 @@ import qualified Data.IntSet as Set
 import Data.Tree (Tree(Node), Forest)
 
 -- std interfaces
+import Control.Applicative
 import Control.DeepSeq (NFData(rnf))
 import Data.Maybe
 import Data.Array
@@ -290,7 +291,19 @@ 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 }
+    {-# INLINE return #-}
+    SetM v >>= f = SetM $ \s -> do { x <- v s; runSetM (f x) s }
+    {-# INLINE (>>=) #-}
+
+instance Functor (SetM s) where
+    f `fmap` SetM v = SetM $ \s -> f `fmap` v s
+    {-# INLINE fmap #-}
+
+instance Applicative (SetM s) where
+    pure x = SetM $ const (return x)
+    {-# INLINE pure #-}
+    SetM f <*> SetM v = SetM $ \s -> f s <*> v s
+    {-# INLINE (<*>) #-}
 
 run          :: Bounds -> (forall s. SetM s a) -> a
 run bnds act  = runST (newArray bnds False >>= runSetM act)
@@ -308,8 +321,18 @@ include v     = SetM $ \ m -> writeArray m v True
 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'
+    return x     = SetM $ \s -> (x, s)
+    SetM v >>= f = SetM $ \s -> case v s of (x, s') -> runSetM (f x) s'
+
+instance Functor (SetM s) where
+    f `fmap` SetM v = SetM $ \s -> case v s of (x, s') -> (f x, s')
+    {-# INLINE fmap #-}
+
+instance Applicative (SetM s) where
+    pure x = SetM $ \s -> (x, s)
+    {-# INLINE pure #-}
+    SetM f <*> SetM v = SetM $ \s -> case f s of (k, s') -> case v s' of (x, s'') -> (k x, s'')
+    {-# INLINE (<*>) #-}
 
 run          :: Bounds -> SetM s a -> a
 run _ act     = fst (runSetM act Set.empty)