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.
This commit is contained in:
parent
f3a2f60abc
commit
5e7e873853
1 changed files with 24 additions and 5 deletions
29
Annex.hs
29
Annex.hs
|
@ -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.Trans.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
|
||||||
|
@ -38,7 +39,25 @@ import Types.UUID
|
||||||
import qualified Utility.Matcher
|
import qualified Utility.Matcher
|
||||||
|
|
||||||
-- git-annex's monad
|
-- 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
|
data OutputType = NormalOutput | QuietOutput | JSONOutput
|
||||||
|
|
||||||
|
@ -94,9 +113,9 @@ new gitrepo = newState <$> Git.configRead gitrepo
|
||||||
|
|
||||||
{- performs an action in the Annex monad -}
|
{- performs an action in the Annex monad -}
|
||||||
run :: AnnexState -> Annex a -> IO (a, AnnexState)
|
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 :: 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
|
{- Gets a value from the internal state, selected by the passed value
|
||||||
- constructor. -}
|
- constructor. -}
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue