mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

Merge branch 'new-monad-control'

Browse source
This commit is contained in:
Joey Hess 2011-12-24 23:02:42 -04:00
commit 6d4382a89e
3 changed files with 19 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

17
Annex.hs
View file

@ -5,7 +5,7 @@
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-}
module Annex ( module Annex (
Annex, Annex,
@ -22,8 +22,9 @@ module Annex (
fromRepo, fromRepo,
) where ) where
import Control.Monad.IO.Control
import Control.Monad.State import Control.Monad.State
import Control.Monad.Trans.Control (StM, MonadBaseControl, liftBaseWith, restoreM)
import Control.Monad.Base (liftBase, MonadBase)
import Common import Common
import qualified Git import qualified Git
@ -45,12 +46,22 @@ newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a }
deriving ( deriving (
Monad, Monad,
MonadIO, MonadIO,
MonadControlIO,
MonadState AnnexState, MonadState AnnexState,
Functor, Functor,
Applicative 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 data OutputType = NormalOutput | QuietOutput | JSONOutput
-- internal state storage -- internal state storage

6
Annex/Exception.hs
View file

@ -11,8 +11,8 @@ module Annex.Exception (
throw, throw,
) where ) where
import Control.Exception.Control (handle) import Control.Exception.Lifted (handle)
import Control.Monad.IO.Control (liftIOOp) import Control.Monad.Trans.Control (liftBaseOp)
import Control.Exception hiding (handle, throw) import Control.Exception hiding (handle, throw)
import Common.Annex import Common.Annex
@ -20,7 +20,7 @@ import Common.Annex
{- Runs an Annex action, with setup and cleanup both in the IO monad. -} {- Runs an Annex action, with setup and cleanup both in the IO monad. -}
bracketIO :: IO c -> (c -> IO b) -> Annex a -> Annex a bracketIO :: IO c -> (c -> IO b) -> Annex a -> Annex a
bracketIO setup cleanup go = 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. -} {- Throws an exception in the Annex monad. -}
throw :: Control.Exception.Exception e => e -> Annex a throw :: Control.Exception.Exception e => e -> Annex a

4
git-annex.cabal
View file

@ -30,8 +30,8 @@ Executable git-annex
Main-Is: git-annex.hs Main-Is: git-annex.hs
Build-Depends: MissingH, hslogger, directory, filepath, Build-Depends: MissingH, hslogger, directory, filepath,
unix, containers, utf8-string, network, mtl, bytestring, old-locale, time, unix, containers, utf8-string, network, mtl, bytestring, old-locale, time,
pcre-light, extensible-exceptions, dataenc, SHA, process, hS3, HTTP, pcre-light, extensible-exceptions, dataenc, SHA, process, hS3, json, HTTP,
base < 5, monad-control < 0.3, json base < 5, monad-control, transformers-base, lifted-base
Executable git-annex-shell Executable git-annex-shell
Main-Is: git-annex-shell.hs Main-Is: git-annex-shell.hs