summaryrefslogtreecommitdiff
path: root/Annex.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-12-06 11:37:58 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-12-06 11:43:30 -0400
commit5e7e873853f9ffdf1fc191c5477829c3627da0c6 (patch)
tree43cd449f63c588723771be44485f38a87af5b997 /Annex.hs
parentf3a2f60abc7c7c5a8e29ce96675da46c1861c50e (diff)
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.
Diffstat (limited to 'Annex.hs')
-rw-r--r--Annex.hs29
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. -}