From f3a2f60abc7c7c5a8e29ce96675da46c1861c50e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 5 Dec 2011 22:51:37 -0400 Subject: [PATCH 1/4] adjust to build with monad-control-0.3 I had to, I hope temporarily, lose my nice Annex newtype, and use a type synonym. This because I cannot find a way to derive a MonadBaseControl instance of the Annex newtype. I've emailed Bas van Dijk in hope he can help get the newtype back. Otherwise appears to build & work. --- Annex.hs | 16 ++++------------ Annex/Exception.hs | 6 +++--- 2 files changed, 7 insertions(+), 15 deletions(-) diff --git a/Annex.hs b/Annex.hs index 6d245a92d1..d21f0a06c6 100644 --- a/Annex.hs +++ b/Annex.hs @@ -22,7 +22,7 @@ module Annex ( fromRepo, ) where -import Control.Monad.IO.Control +import Control.Monad.Trans.Control import Control.Monad.State import Common @@ -38,15 +38,7 @@ import Types.UUID import qualified Utility.Matcher -- git-annex's monad -newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a } - deriving ( - Monad, - MonadIO, - MonadControlIO, - MonadState AnnexState, - Functor, - Applicative - ) +type Annex = StateT AnnexState IO data OutputType = NormalOutput | QuietOutput | JSONOutput @@ -102,9 +94,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 (runAnnex a) s +run s a = runStateT a s eval :: AnnexState -> Annex a -> IO a -eval s a = evalStateT (runAnnex a) s +eval s a = evalStateT a s {- Gets a value from the internal state, selected by the passed value - constructor. -} diff --git a/Annex/Exception.hs b/Annex/Exception.hs index c147439a1c..cb36d1bdbc 100644 --- a/Annex/Exception.hs +++ b/Annex/Exception.hs @@ -11,8 +11,8 @@ module Annex.Exception ( throw, ) where -import Control.Exception.Control (handle) -import Control.Monad.IO.Control (liftIOOp) +import Control.Exception.Lifted (handle) +import Control.Monad.Trans.Control (liftBaseOp) import Control.Exception hiding (handle, throw) import Common.Annex @@ -20,7 +20,7 @@ import Common.Annex {- Runs an Annex action, with setup and cleanup both in the IO monad. -} bracketIO :: IO c -> (c -> IO b) -> Annex a -> Annex a bracketIO setup cleanup go = - liftIOOp (Control.Exception.bracket setup cleanup) (const go) + liftBaseOp (Control.Exception.bracket setup cleanup) (const go) {- Throws an exception in the Annex monad. -} throw :: Control.Exception.Exception e => e -> Annex a From 5e7e873853f9ffdf1fc191c5477829c3627da0c6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 6 Dec 2011 11:37:58 -0400 Subject: [PATCH 2/4] 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(-) diff --git a/Annex.hs b/Annex.hs index d21f0a06c6..d60e08e2d9 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. -} From 730041688d616bff4df745c6605bbaff52733513 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 6 Dec 2011 13:13:42 -0400 Subject: [PATCH 3/4] add modules needed for using the new monad-control --- git-annex.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/git-annex.cabal b/git-annex.cabal index 7be78053f8..d701cd6999 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -30,8 +30,8 @@ Executable git-annex Main-Is: git-annex.hs Build-Depends: MissingH, hslogger, directory, filepath, unix, containers, utf8-string, network, mtl, bytestring, old-locale, time, - pcre-light, extensible-exceptions, dataenc, SHA, process, hS3, HTTP, - base < 5, monad-control, json + pcre-light, extensible-exceptions, dataenc, SHA, process, hS3, json, HTTP, + base < 5, monad-control, transformers-base, lifted-base Executable git-annex-shell Main-Is: git-annex-shell.hs From 85f1f3a63a025204e931959ec9c5ae2a7812ddff Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 24 Dec 2011 23:05:23 -0400 Subject: [PATCH 4/4] Updated to build with monad-control 0.3. --- debian/changelog | 5 +++-- debian/control | 2 +- doc/todo/Please_add_support_for_monad-control_0.3.x.mdwn | 2 ++ 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/debian/changelog b/debian/changelog index 33d196fa32..61b10c80f3 100644 --- a/debian/changelog +++ b/debian/changelog @@ -8,11 +8,12 @@ git-annex (3.20111212) UNRELEASED; urgency=low * Test suite improvements. Current top-level test coverage: 75% * Improve deletion of files from rsync special remotes. Closes: #652849 * Add --include, which is the same as --not --exclude. - * Can now be built with older git versions (before 1.7.7); the resulting - binary should only be used with old git. * Format strings can be specified using the new --format option, to control what is output by git annex find. * Support git annex find --json + * Can now be built with older git versions (before 1.7.7); the resulting + binary should only be used with old git. + * Updated to build with monad-control 0.3. -- Joey Hess Mon, 12 Dec 2011 01:57:49 -0400 diff --git a/debian/control b/debian/control index 6f59ada5b8..a3035e8807 100644 --- a/debian/control +++ b/debian/control @@ -13,7 +13,7 @@ Build-Depends: libghc-utf8-string-dev, libghc-hs3-dev (>= 0.5.6), libghc-testpack-dev [any-i386 any-amd64], - libghc-monad-control-dev, + libghc-monad-control-dev (>= 0.3), libghc-json-dev, ikiwiki, perlmagick, diff --git a/doc/todo/Please_add_support_for_monad-control_0.3.x.mdwn b/doc/todo/Please_add_support_for_monad-control_0.3.x.mdwn index ca68c2c913..f822249916 100644 --- a/doc/todo/Please_add_support_for_monad-control_0.3.x.mdwn +++ b/doc/todo/Please_add_support_for_monad-control_0.3.x.mdwn @@ -5,3 +5,5 @@ Git-annex doesn't compile with the latest version of monad-control. Would it be > > There is now a branch in git called `new-monad-control` that will build > with the new monad-control. --[[Joey]] + +>> Now merged to master. [[done]] --[[Joey]]