Merge branch 'new-monad-control'
This commit is contained in:
commit
6d4382a89e
3 changed files with 19 additions and 8 deletions
17
Annex.hs
17
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.IO.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
|
||||
|
@ -45,12 +46,22 @@ newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a }
|
|||
deriving (
|
||||
Monad,
|
||||
MonadIO,
|
||||
MonadControlIO,
|
||||
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
|
||||
|
||||
-- internal state storage
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 < 0.3, 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
|
||||
|
|
Loading…
Reference in a new issue