Commit f645af36 authored by Petr Pudlak's avatar Petr Pudlak

Add a function for traversing over a composition of functors

Most often the inner functor is "(,) r" and "traverseOf2" is used to
traverse an effectful computation that also returns an additional
output value.
Signed-off-by: default avatarPetr Pudlak <pudlak@google.com>
Reviewed-by: default avatarKlaus Aehlig <aehlig@google.com>
parent 68586d9e
......@@ -27,10 +27,12 @@ module Ganeti.Lens
( module Control.Lens
, makeCustomLenses
, makeCustomLenses'
, traverseOf2
) where
import Control.Lens
import Control.Monad
import Data.Functor.Compose (Compose(..))
import qualified Data.Set as S
import Language.Haskell.TH
......@@ -55,3 +57,11 @@ makeCustomLenses' name lst = makeCustomLensesFiltered f name
where
allowed = S.fromList . map nameBase $ lst
f = flip S.member allowed
-- | Traverses over a composition of two functors.
-- Most often the @g@ functor is @(,) r@ and 'traverseOf2' is used to
-- traverse an effectful computation that also returns an additional output
-- value.
traverseOf2 :: Over (->) (Compose f g) s t a b
-> (a -> f (g b)) -> s -> f (g t)
traverseOf2 k f = getCompose . traverseOf k (Compose . f)
......@@ -61,7 +61,6 @@ import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Control
import Data.Functor.Compose (Compose(..))
import Data.Functor.Identity
import Data.IORef.Lifted
import Data.Monoid (Any(..))
......@@ -240,8 +239,8 @@ modifyTempResStateErr
modifyTempResStateErr f = do
-- we use Compose to traverse the composition of applicative functors
-- @ErrorResult@ and @(,) a@
let f' ds = getCompose $ traverseOf dsTempResL
(Compose . runStateT (f (csConfigData . dsConfigState $ ds))) ds
let f' ds = traverseOf2 dsTempResL
(runStateT (f (csConfigData . dsConfigState $ ds))) ds
dh <- daemonHandle
toErrorBase $ atomicModifyIORefErr (dhDaemonState dh) (liftM swap . f')
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment