the Annex newtype is back

Thanks to Bas van Dijk for providing the instance declarations I needed.
Grody stuff. Bas is talking about perhaps providing utility functions that
contain the ugly parts, so this code may be able to be removed using a
future version of monad-control.

1 files changed, 24 insertions, 5 deletions

diff --git a/Annex.hs b/Annex.hs
index d21f0a06c..d60e08e2d 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-}
 
 module Annex (
 	Annex,
@@ -22,8 +22,9 @@ module Annex (
 	fromRepo,
 ) where
 
-import Control.Monad.Trans.Control
 import Control.Monad.State
+import Control.Monad.Trans.Control (StM, MonadBaseControl, liftBaseWith, restoreM)
+import Control.Monad.Base (liftBase, MonadBase)
 
 import Common
 import qualified Git
@@ -38,7 +39,25 @@ import Types.UUID
 import qualified Utility.Matcher
 
 -- git-annex's monad
-type Annex = StateT AnnexState IO
+newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a }
+	deriving (
+		Monad,
+		MonadIO,
+		MonadState AnnexState,
+		Functor,
+		Applicative
+	)
+
+instance MonadBase IO Annex where
+	liftBase = Annex . liftBase
+
+instance MonadBaseControl IO Annex where
+	newtype StM Annex a = StAnnex (StM (StateT AnnexState IO) a)
+	liftBaseWith f = Annex $ liftBaseWith $ \runInIO ->
+		f $ liftM StAnnex . runInIO . runAnnex
+	restoreM = Annex . restoreM . unStAnnex
+		where
+			unStAnnex (StAnnex st) = st
 
 data OutputType = NormalOutput | QuietOutput | JSONOutput
 
@@ -94,9 +113,9 @@ new gitrepo = newState <$> Git.configRead gitrepo
 
 {- performs an action in the Annex monad -}
 run :: AnnexState -> Annex a -> IO (a, AnnexState)
-run s a = runStateT a s
+run s a = runStateT (runAnnex a) s
 eval :: AnnexState -> Annex a -> IO a
-eval s a = evalStateT a s
+eval s a = evalStateT (runAnnex a) s
 
 {- Gets a value from the internal state, selected by the passed value
  - constructor. -}