Commits

Bryan O'Sullivan committed a8ff850

Replace foldMapReduce with a better mapReduce.

Comments (0)

Files changed (1)

src/Network/Riak/Basic.hs

-{-# LANGUAGE OverloadedStrings, RecordWildCards, DoAndIfThenElse #-}
+{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards #-}
 
 -- |
 -- Module:      Network.Riak.Basic
     , setBucket
     -- * Map/reduce
     , mapReduce
-    , foldMapReduce
     ) where
 
 import Control.Applicative ((<$>))
 import Network.Riak.Protocol.BucketProps
 import Network.Riak.Protocol.Content
 import Network.Riak.Protocol.ListKeysResponse
-import Network.Riak.Protocol.MapReduce
+import Network.Riak.Protocol.MapReduce as MapReduce
 import Network.Riak.Protocol.ServerInfo
 import Network.Riak.Types.Internal hiding (MessageTag(..))
 import qualified Data.Foldable as F
 setBucket :: Connection -> T.Bucket -> BucketProps -> IO ()
 setBucket conn bucket props = exchange_ conn $ Req.setBucket bucket props
 
--- | Launch a 'MapReduce' job.
-mapReduce :: Connection -> Job -> IO MapReduce
-mapReduce conn = exchange conn . Req.mapReduce
-
-foldMapReduce :: Connection -> Job -> (MapReduce -> a -> a) -> a -> IO a
-foldMapReduce conn job f start = do
-  mr <- mapReduce conn job
-  loop mr start
-    where loop mr s = do
-            let nextA = f mr s
-            if (maybe False id (Network.Riak.Protocol.MapReduce.done mr)) then
-              return nextA
-            else 
-              (recvResponse conn >>= \r -> loop r nextA)
+-- | Run a 'MapReduce' job.  Its result is consumed via a strict left
+-- fold.
+mapReduce :: Connection -> Job -> (a -> MapReduce -> a) -> a -> IO a
+mapReduce conn job f z0 = loop z0 =<< (exchange conn . Req.mapReduce $ job)
+  where
+    loop z mr = do
+      let !z' = f z mr
+      if fromMaybe False . MapReduce.done $ mr
+        then return z'
+        else loop z' =<< recvResponse conn