switch to the strict state monad

I had not realized what a memory leak the lazy state monad could be,
although I have not seen much evidence of actual leaking in git-annex.
However, if running git-annex on a great many files, this could matter.

The additional Utility.State.changeState adds even more strictness,
avoiding a problem I saw in github-backup where repeatedly modifying
state built up a huge pile of thunks.

5 files changed, 30 insertions, 16 deletions

diff --git a/Annex.hs b/Annex.hs
index 3b79ea270..de36c816d 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -26,7 +26,7 @@ module Annex (
 	fromRepo,
 ) where
 
-import Control.Monad.State
+import Control.Monad.State.Strict
 import Control.Monad.Trans.Control (StM, MonadBaseControl, liftBaseWith, restoreM)
 import Control.Monad.Base (liftBase, MonadBase)
 import System.Posix.Types (Fd)
@@ -41,6 +41,7 @@ import qualified Types.Remote
 import Types.Crypto
 import Types.BranchState
 import Types.TrustLevel
+import Utility.State
 import qualified Utility.Matcher
 import qualified Data.Map as M
 
@@ -125,18 +126,6 @@ run s a = runStateT (runAnnex a) s
 eval :: AnnexState -> Annex a -> IO a
 eval s a = evalStateT (runAnnex a) s
 
-{- Gets a value from the internal state, selected by the passed value
- - constructor. -}
-getState :: (AnnexState -> a) -> Annex a
-getState = gets
-
-{- Applies a state mutation function to change the internal state. 
- -
- - Example: changeState $ \s -> s { output = QuietOutput }
- -}
-changeState :: (AnnexState -> AnnexState) -> Annex ()
-changeState = modify
-
 {- Sets a flag to True -}
 setFlag :: String -> Annex ()
 setFlag flag = changeState $ \s ->
diff --git a/Command/Status.hs b/Command/Status.hs
index d2d8d4c07..a1d4eea08 100644
--- a/Command/Status.hs
+++ b/Command/Status.hs
@@ -7,7 +7,7 @@
 
 module Command.Status where
 
-import Control.Monad.State
+import Control.Monad.State.Strict
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Set (Set)
diff --git a/Common.hs b/Common.hs
index 385d1aba4..fb998214b 100644
--- a/Common.hs
+++ b/Common.hs
@@ -3,7 +3,7 @@ module Common (module X) where
 import Control.Monad as X hiding (join)
 import Control.Monad.IfElse as X
 import Control.Applicative as X
-import Control.Monad.State as X (liftIO)
+import Control.Monad.State.Strict as X (liftIO)
 import Control.Exception.Extensible as X (IOException)
 
 import Data.Maybe as X
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index 16f0b11b9..2a2eb5e6f 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -13,7 +13,6 @@ module Git.CatFile (
 	catObject
 ) where
 
-import Control.Monad.State
 import System.Cmd.Utils
 import System.IO
 import qualified Data.ByteString.Char8 as S
diff --git a/Utility/State.hs b/Utility/State.hs
new file mode 100644
index 000000000..c27f3c261
--- /dev/null
+++ b/Utility/State.hs
@@ -0,0 +1,26 @@
+{- state monad support
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.State where
+
+import Control.Monad.State.Strict
+
+{- Modifies Control.Monad.State's state, forcing a strict update.
+ - This avoids building thunks in the state and leaking.
+ - Why it's not the default, I don't know.
+ -
+ - Example: changeState $ \s -> s { foo = bar }
+ -}
+changeState :: MonadState s m => (s -> s) -> m ()
+changeState f = do
+	x <- get
+	put $! f x
+
+{- Gets a value from the internal state, selected by the passed value
+ - constructor. -}
+getState :: MonadState s m => (s -> a) -> m a
+getState = gets