From 5e7e873853f9ffdf1fc191c5477829c3627da0c6 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 6 Dec 2011 11:37:58 -0400
Subject: 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.
---
 Annex.hs | 29 ++++++++++++++++++++++++-----
 1 file changed, 24 insertions(+), 5 deletions(-)

(limited to 'Annex.hs')

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. -}
-- 
cgit v1.2.3