module Generics.Putlenses.Language (
withMonadPut,
withMonadPut',
effectPut,
runMaybePut,
runStatePut,
resetStatePut,
withStatePut,
withStateTPut,
updateStatePut,
updateStateTPut,
runReaderPut,
runReaderPutS,
runReaderPutMbS,
runReaderPutV,
runReaderPutMbV,
runReaderPutV',
withReaderPut,
withReaderPut',
localPut,
withS,
withMbS,
withV,
withMbV,
withV',
modifyS,
modifyV',
updateS',
unforkPut,
idPut,
(.<),
phiPut,
phiSourcePut,
botPut,
addfstPut,
addfstPutUnsafe,
addsndPut,
addsndPutUnsafe,
dupPut,
mergePut,
keepfstPut,
keepsndPut,
keepfstOrPut,
keepsndOrPut,
remfstPut,
remsndPut,
(><<),
(><<<),
ignorePut,
newPut,
keepPut,
keepOrPut,
pntPut,
addfstOnePut,
addsndOnePut,
remfstOnePut,
remsndOnePut,
injPut,
injPutUnsafe,
injsOrPut,
injlsPut,
injrsPut,
injunionPut,
injunionPutUnsafe,
(\/<),
eitherPutUnsafe,
eitherSPut,
(.\/<),
(\/.<),
(-|-<),
injlPut,
injrPut,
uninjlPut,
uninjrPut,
ifthenelsePut,
ifVthenelsePut,
ifSthenelsePut,
ifKthenelsePut,
unionPut,
unionPutUnsafe,
customPut,
innPut,
outPut,
swapPut,
assoclPut,
assocrPut,
coswapPut,
coassoclPut,
coassocrPut,
distlPut,
distrPut,
undistlPut,
undistrPut,
subrPut,
sublPut,
cosubrPut,
cosublPut,
distpPut,
distsPut,
undistsPut,
paramfstPut,
paramfstGet,
paramsndPut,
paramsndGet,
paramSrcPut,
paramPut,
isoPut
) where
import Data.Maybe
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State as State
import Generics.Putlenses.Putlens
import GHC.InOut
import Control.Monad.Trans.Maybe
runReaderPut :: (Monad m) => (Maybe s -> v -> m e) -> PutlensReaderM m e s v -> PutlensM m s v
runReaderPut f = withMonadPut (\s v' reader -> f s v' >>= runReaderT reader)
runReaderPutS :: (Monad m) => PutlensReaderM m s s v -> PutlensM m s v
runReaderPutS l = runReaderPut f l
where f Nothing v = fail "runReaderPutS fails"
f (Just s) v = return s
runReaderPutMbS :: (Monad m) => PutlensReaderM m (Maybe s) s v -> PutlensM m s v
runReaderPutMbS l = runReaderPut (\s v -> return s) l
runReaderPutV :: Monad m => PutlensReaderM m v s v -> PutlensM m s v
runReaderPutV l = runReaderPut f l
where f Nothing v = fail "runReaderPutV fails"
f (Just s) v = maybe (fail "runReaderPutV fails") return (getM l s)
runReaderPutMbV :: (Monad m) => PutlensReaderM m (Maybe v) s v -> PutlensM m s v
runReaderPutMbV l = runReaderPut f l
where f Nothing v = return $ fail "no original view"
f (Just s) v = return (getM l s)
runReaderPutV' :: (Monad m) => PutlensReaderM m v s v -> PutlensM m s v
runReaderPutV' = runReaderPut (\s v' -> return v')
localPut :: (MonadReader e m) => (Maybe s -> v -> e -> e) -> PutlensM m s v -> PutlensM m s v
localPut f = withMonadPut (\s v' -> local (f s v'))
withReaderPut :: (Monad m) => (Maybe s -> v -> e -> m e') -> PutlensReaderM m e' s v -> PutlensReaderM m e s v
withReaderPut f = withMonadPut (\s v' reader' -> ask >>= \r -> lift $ f s v' r >>= runReaderT reader')
withReaderPut' :: Monad m => (Maybe s -> Maybe v -> v -> e -> m e') -> PutlensReaderM m e' s v -> PutlensReaderM m e s v
withReaderPut' f = withMonadPut' (\s v v' reader' -> ask >>= \r -> lift $ f s v v' r >>= runReaderT reader')
withS :: (Monad m) => PutlensReaderM m s s v -> PutlensReaderM m e s v
withS = withReaderPut (\s v e -> maybe (fail "withS") return s)
withMbS :: (Monad m) => PutlensReaderM m (Maybe s) s v -> PutlensReaderM m e s v
withMbS = withReaderPut (\s v e -> return s)
withV :: Monad m => PutlensReaderM m v s v -> PutlensReaderM m e s v
withV = withReaderPut' (\s v v' e -> maybe (fail "withV") return v)
withMbV :: Monad m => PutlensReaderM m (Maybe v) s v -> PutlensReaderM m e s v
withMbV = withReaderPut' (\s v v' e -> return v)
withV' :: (Monad m) => PutlensReaderM m v s v -> PutlensReaderM m e s v
withV' = withReaderPut (\s v e -> return v)
effectPut :: (Monad m) => (Maybe s -> v -> m ()) -> PutlensM m s v -> PutlensM m s v
effectPut f l = withMonadPut (\s v' m -> f s v' >> m) l
withMonadPut :: (Monad m,Monad n) => (forall a. Maybe s -> v -> n a -> m a) -> PutlensM n s v -> PutlensM m s v
withMonadPut f l = l { getputM = getput', createM = create' }
where getput' s = let ~(v,put) = getputM l s in (v,putT put (Just s))
create' = putT (createM l) Nothing
putT put s v' = do gp <- ask
~(s',pg) <- liftPutM $ f s v' (runPutM (put v') gp)
tell pg
return s'
withMonadPut' :: (Monad m,Monad n) => (forall a. Maybe s -> Maybe v -> v -> n a -> m a) -> PutlensM n s v -> PutlensM m s v
withMonadPut' f l = l { getputM = getput', createM = create' }
where getput' s = let (v,put) = getputM l s in (v,putT v put (Just s))
create' = putT Nothing (createM l) Nothing
putT v put s v' = do gp <- ask
(s',pg) <- liftPutM $ f s v v' (runPutM (put v') gp)
tell pg
return s'
runMaybePut :: (Monad m) => PutlensMaybeM m s v -> PutlensM m s v
runMaybePut = mapPutlensM (liftM (maybe (error "runMaybePut fails") id) . runMaybeT)
runStatePut :: (Monad m) => (Maybe s -> v -> m st) -> PutlensStateM m st s v -> PutlensM m s v
runStatePut f l = withMonadPut (\s v n -> f s v >>= State.evalStateT n) l
resetStatePut :: (Monad m) => (Maybe s -> v -> st -> m st') -> PutlensStateM m st' s v -> PutlensStateM m st s v
resetStatePut f l = withMonadPut (reinitialize f) l
where reinitialize :: (Monad m) => (Maybe s -> v -> st -> m st') -> Maybe s -> v -> StateT st' m a -> StateT st m a
reinitialize f s v n = State.get >>= \st -> lift (f s v st) >>= lift . evalStateT n
withStatePut :: (MonadState st m) => (Maybe s -> v -> st -> m st) -> PutlensM m s v -> PutlensM m s v
withStatePut f l = effectPut modify l
where modify e v = do { st <- State.get; st' <- f e v st; State.put st' }
withStateTPut :: (Monad m) => (Maybe s -> v -> st -> m st) -> PutlensStateM m st s v -> PutlensStateM m st s v
withStateTPut f = withStatePut (\s v st -> lift $ f s v st)
updateStatePut ::(MonadState st m) => (Maybe s -> s -> st -> m st) -> PutlensM m s v -> PutlensM m s v
updateStatePut f l = withStatePut f idPut .< l
updateStateTPut :: (Monad m) => (Maybe s -> s -> st -> m st) -> PutlensStateM m st s v -> PutlensStateM m st s v
updateStateTPut f l = withStateTPut f idPut .< l
modifyS :: (Monad m,Eq v) => (Maybe s -> v -> m (Maybe s)) -> PutlensM m s v -> PutlensM m s v
modifyS f l = checkGetPut $ PutlensM getput' (put' Nothing)
where getput' s = let (v,put) = getputM l s
in (v,put' (Just s))
put' s v' = do ms1 <- liftPutM (f s v')
case ms1 of
Nothing -> offGetPut (createM l v')
Just s1 -> do let (v1,put1) = getputM l s1
offGetPut (put1 v')
modifyV' :: (Monad m) => (Maybe s -> v -> m v) -> PutlensM m s v -> PutlensM m s v
modifyV' f l = PutlensM getput' (put' (createM l) Nothing)
where getput' s = let (v,put) = getputM l s
in (v,put' put (Just s))
put' put s v' = do v1 <- liftPutM (f s v')
onPutGet (put v1)
updateS' :: (Monad m) => (Maybe s -> s -> m s) -> PutlensM m s v -> PutlensM m s v
updateS' f l = modifyV' f idPut .< l
unforkPut :: (Monad m,Eq v1,Eq v2) => PutlensM m s v1 -> PutlensM m s v2 -> PutlensM m s (v1,v2)
unforkPut f g = (checkPutGet (PutlensM getput' create'))
where getput' s = let (v1,putf) = getputM f s
(v2,putg) = getputM g s
v = do { x <- v1; y <- v2; return (x,y) }
in (v,put' putf)
create' = put' (createM f)
put' putf (v1',v2') = do sI <- offGetPut (putf v1')
let (v2I,putgI) = getputM g sI
offGetPut (putgI v2')
idPut :: (Monad m) => PutlensM m v v
idPut = PutlensM getput' create'
where getput' s = (return s,create')
create' v' = return v'
infixr 9 .<
(.<) :: Monad m => PutlensM m s u -> PutlensM m u v -> PutlensM m s v
(.<) f g = PutlensM getput' create'
where getput' (getputM f -> (Just u,putf)) = let (v,putg) = getputM g u in (v,put' putf putg)
getput' (getputM f -> (Nothing,putf)) = (Nothing,put' putf (createM g))
put' putf putg v' = putg v' >>= putf
create' v' = put' (createM f) (createM g) v'
phiPut :: Monad m => (v -> Bool) -> PutlensM m v v
phiPut p = PutlensM getput' create'
where getput' s = (if p s then Just s else Nothing,create')
create' v' | p v' = return v'
| otherwise = fail "phiPut fails"
phiSourcePut :: Monad m => (s -> Bool) -> PutlensM m s v -> PutlensM m s v
phiSourcePut p f = PutlensM getput' create'
where getput' s@(getputM f -> (Just v,putf)) = (if p s then Just v else Nothing,put' putf)
getput' s@(getputM f -> (Nothing,putf)) = (Nothing,put' putf)
put' putf v' = putf v' >>= \s' -> if p s' then return s' else fail "phiSourcePut fails"
create' = put' (createM f)
botPut :: (Monad m) => PutlensM m a b
botPut = PutlensM getput' create'
where getput' s = (fail "bottom",create')
create' v' = fail "botPut fails"
addfstPut :: (Monad m,Eq v) => (Maybe (s1,v) -> v -> m s1) -> PutlensM m (s1,v) v
addfstPut f = checkGetPut (addfstPutUnsafe f)
addfstPutUnsafe :: (Monad m) => (Maybe (s1,v) -> v -> m s1) -> PutlensM m (s1,v) v
addfstPutUnsafe f = PutlensM getput' (put' Nothing)
where get' ~(s1,v) = return v
put' s v' = do s1 <- liftPutM (f s v')
return (s1,v')
getput' s = (get' s,put' (Just s))
addsndPut :: (Monad m,Eq v) => (Maybe (v,s2) -> v -> m s2) -> PutlensM m (v,s2) v
addsndPut f = checkGetPut (addsndPutUnsafe f)
addsndPutUnsafe :: (Monad m) => (Maybe (v,s2) -> v -> m s2) -> PutlensM m (v,s2) v
addsndPutUnsafe f = PutlensM getput' (put' Nothing)
where get' ~(v,s2) = return v
put' s v' = do s2 <- liftPutM (f s v')
return (v',s2)
getput' s = (get' s,put' (Just s))
dupPut :: (Monad m,Eq v) => PutlensM m (v,v) v
dupPut = phiPut (uncurry (==)) .< addsndPut (\e v -> return v)
mergePut :: (Monad m,Eq v) => PutlensM m (v,v) v
mergePut = addsndPut (\e v -> return v)
keepfstPut :: (Monad m) => PutlensM m (s1,v) v
keepfstPut = keepfstOrPut (\v -> fail "keepfstPut fails")
keepsndPut :: (Monad m) => PutlensM m (v,s2) v
keepsndPut = keepsndOrPut (\v -> fail "keepsndPut fails")
keepfstOrPut :: (Monad m) => (v -> m s1) -> PutlensM m (s1,v) v
keepfstOrPut f = addfstPutUnsafe (\s v' -> maybe (f v') (return . fst) s)
keepsndOrPut :: (Monad m) => (v -> m s2) -> PutlensM m (v,s2) v
keepsndOrPut f = addsndPutUnsafe (\s v' -> maybe (f v') (return . snd) s)
remfstPut :: (Monad m,Eq v1) => (v -> v1) -> PutlensM m v (v1,v)
remfstPut f = PutlensM getput' create'
where get' v = Just (f v,v)
create' (v1',v') | f v' == v1' = return v'
| otherwise = fail "remfstPut fails"
getput' s = (get' s,create')
remsndPut :: (Monad m,Eq v2) => (v -> v2) -> PutlensM m v (v,v2)
remsndPut f = PutlensM getput' create'
where get' v = Just (v,f v)
create' (v',v2') | f v' == v2' = return v'
| otherwise = fail "remsndPut fails"
getput' s = (get' s,create')
infix 7 ><<
(><<) :: (Monad m) => PutlensM m s1 v1 -> PutlensM m s2 v2 -> PutlensM m (s1,s2) (v1,v2)
(><<) f g = PutlensM getput' create'
where getput' ~(s1,s2) = let ~(v1,put1) = getputM f s1
~(v2,put2) = getputM g s2
v = do { x <- v1; y <- v2; return (x,y) }
in (v,put' put1 put2)
put' putf putg ~(v1',v2') = do s1' <- (putf v1')
s2' <- (putg v2')
return (s1',s2')
create' = put' (createM f) (createM g)
infix 7 ><<<
(><<<) :: (Monad m,Eq v1,Eq v2) => PutlensM m s1 v1 -> PutlensM m s2 v2 -> PutlensM m (s1,s2) (v1,v2)
(><<<) f g = checkGetPut $ PutlensM getput' create'
where getput' (s1,s2) = let (v1,put1) = getputM f s1
(v2,put2) = getputM g s2
v = do { x <- v1; y <- v2; return (x,y) }
in (v,put' put1 put2)
put' putf putg (v1',v2') = do s1' <- offGetPut (putf v1')
s2' <- offGetPut (putg v2')
return (s1',s2')
create' = put' (createM f) (createM g)
ignorePut :: (Monad m,Eq v) => v -> PutlensM m () v
ignorePut x = remfstPut (\() -> x) .< addsndOnePut
newPut :: (Monad m) => s -> PutlensM m s ()
newPut x = pntPut (\e -> return x)
keepPut :: (Monad m) => PutlensM m s ()
keepPut = pntPut (\s -> maybe (fail "keepPut fails") return s)
keepOrPut :: (Monad m) => m s -> PutlensM m s ()
keepOrPut m = pntPut (\s -> maybe m return s)
pntPut :: (Monad m) => (Maybe a -> m a) -> PutlensM m a ()
pntPut f = remfstPut (\s -> ()) .< addsndPut (\s () -> f $ fmap snd s)
addfstOnePut :: (Monad m) => PutlensM m ((),v) v
addfstOnePut = addfstPutUnsafe (\e v -> return ())
addsndOnePut :: (Monad m) => PutlensM m (v,()) v
addsndOnePut = addsndPutUnsafe (\e v -> return ())
remfstOnePut :: (Monad m) => PutlensM m a ((),a)
remfstOnePut = remfstPut (const ())
remsndOnePut :: (Monad m) => PutlensM m a (a,())
remsndOnePut = remsndPut (const ())
injPut :: (Monad m,Eq v) => (Maybe (Either v v) -> v -> m Bool) -> PutlensM m (Either v v) v
injPut p = checkGetPut $ injPutUnsafe p
injPutUnsafe :: (Monad m) => (Maybe (Either v v) -> v -> m Bool) -> PutlensM m (Either v v) v
injPutUnsafe p = PutlensM getput' (put' Nothing)
where get' s = return (either id id s)
put' s v' = do p' <- liftPutM (p s v')
if p' then return (Left v') else return (Right v')
getput' s = (get' s,put' (Just s))
injsOrPut :: (Monad m) => (v -> m Bool) -> PutlensM m (Either v v) v
injsOrPut p = injPutUnsafe (\s v' -> maybe (p v') (return . isLeft) s)
where isLeft = either (const True) (const False)
injlsPut :: (Monad m) => PutlensM m (Either v v) v
injlsPut = injsOrPut (\v -> return True)
injrsPut :: (Monad m) => PutlensM m (Either v v) v
injrsPut = injsOrPut (\v -> return False)
injunionPut :: (Eq v,MonadPlus m) => PutlensM m s1 v -> PutlensM m s2 v -> PutlensM m (Either s1 s2) v
injunionPut f g = checkGetPut (injunionPutUnsafe f g)
injunionPutUnsafe :: (MonadPlus m) => PutlensM m s1 v -> PutlensM m s2 v -> PutlensM m (Either s1 s2) v
injunionPutUnsafe f g = PutlensM getput' create'
where getput' (Left s) = let (mbv1,put1) = getputM f s
in (mbv1,put' (liftM Left . put1) (liftM Right . (createM g)))
getput' (Right s) = let (mbv2,put2) = getputM g s
in (mbv2,put' (liftM Right . put2) (liftM Left . (createM f)))
put' putf putg v' = putf v' `mplus` putg v'
create' = put' (liftM Left . createM f) (liftM Right . createM g)
infix 4 \/<
(\/<) :: Monad m => PutlensM m s v1 -> PutlensM m s v2 -> PutlensM m s (Either v1 v2)
(\/<) f g = PutlensM getput' create'
where getput' s = let (v1,put1) = getputM f s
(v2,put2) = getputM g s
jv | isNothing v1 && isNothing v2 = Nothing
| isJust v1 && isNothing v2 = liftM Left v1
| isNothing v1 && isJust v2 = liftM Right v2
| isJust v1 && isJust v2 = Nothing
in (jv,put' put1 put2)
put' put1 put2 (Left v1') = put1 v1' >>= disj f g
put' put1 put2 (Right v2') = put2 v2' >>= disj g f
disj x y s | isJust (getM x s) && isNothing (getM y s) = return s
| otherwise = fail "\\/< fails"
create' = put' (createM f) (createM g)
eitherPutUnsafe :: (Monad m) => PutlensM m s v1 -> PutlensM m s v2 -> PutlensM m s (Either v1 v2)
eitherPutUnsafe f g = PutlensM getput' create'
where getput' s = let (mv1,put1) = getputM f s
(mv2,put2) = getputM g s
checkView = liftM Left mv1 `mplus` liftM Right mv2
in (checkView,put' put1 put2)
put' put1 put2 (Left v1') = put1 v1'
put' put1 put2 (Right v2') = put2 v2'
create' = put' (createM f) (createM g)
eitherSPut :: (Monad m) => (s -> Bool) -> PutlensM m s v1 -> PutlensM m s v2 -> PutlensM m s (Either v1 v2)
eitherSPut p f g = (phiSourcePut p f) \/< (phiSourcePut (not . p) g)
infix 4 .\/<
(.\/<) :: (Monad m) => PutlensM m s v1 -> PutlensM m s v2 -> PutlensM m s (Either v1 v2)
(.\/<) f g = f `eitherPutUnsafe` (phiSourcePut (not . dom f) g)
infix 4 \/.<
(\/.<) :: (Monad m) => PutlensM m s v1 -> PutlensM m s v2 -> PutlensM m s (Either v1 v2)
(\/.<) f g = (phiSourcePut (not . dom g) f) `eitherPutUnsafe` g
infix 5 -|-<
(-|-<) :: (Monad m) => PutlensM m s1 v1 -> PutlensM m s2 v2 -> PutlensM m (Either s1 s2) (Either v1 v2)
(-|-<) f g = PutlensM getput' create'
where getput' (Left s1) = let ~(v1,put1) = getputM f s1
put' (Left v1') = liftM Left (put1 v1')
put' (Right v2') = liftM Right (createM g v2')
in (liftM Left v1,put')
getput' (Right s2) = let ~(v2,put2) = getputM g s2
put' (Left v1') = liftM Left (createM f v1')
put' (Right v2') = liftM Right (put2 v2')
in (liftM Right v2,put')
create' (Left v1') = liftM Left (createM f v1')
create' (Right v2') = liftM Right (createM g v2')
injlPut :: (Monad m) => PutlensM m (Either v v2) v
injlPut = PutlensM getput' create'
where getput' s = (get' s,create')
get' (Left s1) = return s1
get' (Right s2) = fail "injlPut get failed"
create' v' = return (Left v')
injrPut :: (Monad m) => PutlensM m (Either v1 v) v
injrPut = PutlensM getput' create'
where getput' s = (get' s,create')
get' (Left s1) = fail "injrPut get failed"
get' (Right s2) = return s2
create' v' = return (Right v')
uninjlPut :: (Monad m) => PutlensM m v (Either v v2)
uninjlPut = (idPut `eitherPutUnsafe` botPut)
uninjrPut :: (Monad m) => PutlensM m v (Either v1 v)
uninjrPut = (botPut `eitherPutUnsafe` idPut)
ifthenelsePut :: (Monad m,Eq v) => (Maybe s -> v -> m Bool) -> PutlensM m s v -> PutlensM m s v -> PutlensM m s v
ifthenelsePut p f g = runReaderPutMbS ((liftPutlensM f .\/< liftPutlensM g) .< injPut (\_ v -> ask >>= \s -> lift $ p s v))
ifVthenelsePut :: (Monad m) => (v -> Bool) -> PutlensM m s v -> PutlensM m s v -> PutlensM m s v
ifVthenelsePut p f g = ((f .< phiPut p) .\/< (g .< phiPut (not . p))) .< injPutUnsafe (\e -> return . p)
ifSthenelsePut :: (Monad m,Eq v) => (s -> Bool) -> PutlensM m s v -> PutlensM m s v -> PutlensM m s v
ifSthenelsePut p f g = PutlensM getput' create'
where l Nothing = eitherSPut p f g .< injPut (\e v -> return True)
l (Just s) = eitherSPut p f g .< injPut (\e v -> return $ p s)
getput' s = getputM (l (Just s)) s
create' = createM (l Nothing)
ifKthenelsePut :: (Monad m,Eq v) => (Maybe s -> v -> m Bool) -> PutlensM m s v -> PutlensM m s v -> PutlensM m s v
ifKthenelsePut p f g = PutlensM getput' create'
where getput' s = let (v1,put1) = getputM f s
(v2,put2) = getputM g s
in (checkView v1 v2,put' put1 put2 (Just s))
create' = put' (createM f) (createM g) Nothing
put' putf putg s v' = do p' <- liftPutM (p s v')
if p' then putf v' >>= checkGet else putg v' >>= checkGet
checkView (Just v1) (Just v2) | v1 == v2 = Just v1
| otherwise = fail "ifKthenelsePut get fails"
checkView (Just v1) Nothing = Just v1
checkView Nothing (Just v2) = Just v2
checkGet s | get' f s == get' g s = return s
| otherwise = fail "ifKthenelsePut put fails"
unionPut :: (Eq v,MonadPlus m) => PutlensM m s v -> PutlensM m s v -> PutlensM m s v
unionPut f g = (phiPut (dom f) .\/< phiPut (dom g)) .< injunionPut f g
unionPutUnsafe :: (MonadPlus m) => PutlensM m s v -> PutlensM m s v -> PutlensM m s v
unionPutUnsafe f g = (idPut `eitherPutUnsafe` idPut) .< injunionPutUnsafe f g
customPut :: (Monad m,Eq v) => (Maybe s -> v -> m s) -> (s -> v) -> PutlensM m s v
customPut put get = remfstPut get .< addsndPut (\p v' -> put (fmap snd p) v')
innPut :: (Monad m,InOut a) => PutlensM m a (F a)
innPut = isoPut inn out
outPut :: (Monad m,InOut a) => PutlensM m (F a) a
outPut = isoPut out inn
isoPut :: (Monad m) => (a -> b) -> (b -> a) -> PutlensM m b a
isoPut f g = PutlensM getput' create'
where getput' b = (return (g b),create')
create' a = return (f a)
swapPut :: (Monad m) => PutlensM m (b,a) (a,b)
swapPut = isoPut swap swap
where swap (x,y) = (y,x)
assoclPut :: (Monad m) => PutlensM m ((a,b),c) (a,(b,c))
assoclPut = isoPut assocl assocr
where assocl (x,(y,z)) = ((x,y),z)
assocr ((x,y),z) = (x,(y,z))
assocrPut :: (Monad m) => PutlensM m (a,(b,c)) ((a,b),c)
assocrPut = isoPut assocr assocl
where assocr ((x,y),z) = (x,(y,z))
assocl (x,(y,z)) = ((x,y),z)
coswapPut :: (Monad m) => PutlensM m (Either b a) (Either a b)
coswapPut = isoPut coswap coswap
where coswap = either Right Left
coassoclPut :: (Monad m) => PutlensM m (Either (Either a b) c) (Either a (Either b c))
coassoclPut = isoPut coassocl coassocr
where coassocl = either (Left . Left) (either (Left . Right) Right)
coassocr = either (either Left (Right . Left)) (Right . Right)
coassocrPut :: (Monad m) => PutlensM m (Either a (Either b c)) (Either (Either a b) c)
coassocrPut = isoPut coassocr coassocl
where coassocr = either (either Left (Right . Left)) (Right . Right)
coassocl = either (Left . Left) (either (Left . Right) Right)
distlPut :: (Monad m) => PutlensM m (Either (a,c) (b,c)) (Either a b,c)
distlPut = isoPut distl undistl
where distl (ab,c) = either (\a -> Left (a,c)) (\b -> Right (b,c)) ab
undistl = either (\(a,c) -> (Left a,c)) (\(b,c) -> (Right b,c))
undistlPut :: (Monad m) => PutlensM m (Either a b,c) (Either (a,c) (b,c))
undistlPut = isoPut undistl distl
where undistl = either (\(a,c) -> (Left a,c)) (\(b,c) -> (Right b,c))
distl (ab,c) = either (\a -> Left (a,c)) (\b -> Right (b,c)) ab
distrPut :: (Monad m) => PutlensM m (Either (a,b) (a,c)) (a,Either b c)
distrPut = isoPut distr undistr
where distr (a,bc) = either (\b -> Left (a,b)) (\c -> Right (a,c)) bc
undistr = either (\(a,b) -> (a,Left b)) (\(a,c) -> (a,Right c))
undistrPut :: (Monad m) => PutlensM m (a,Either b c) (Either (a,b) (a,c))
undistrPut = isoPut undistr distr
where undistr = either (\(a,b) -> (a,Left b)) (\(a,c) -> (a,Right c))
distr (a,bc) = either (\b -> Left (a,b)) (\c -> Right (a,c)) bc
subrPut :: (Monad m) => PutlensM m (b,(a,c)) (a,(b,c))
subrPut = isoPut subr subr
where subr (x,(y,z)) = (y,(x,z))
sublPut :: (Monad m) => PutlensM m ((a,c),b) ((a,b),c)
sublPut = isoPut subl subl
where subl ((x,y),z) = ((x,z),y)
cosubrPut :: (Monad m) => PutlensM m (Either b (Either a c)) (Either a (Either b c))
cosubrPut = isoPut cosubr cosubr
where cosubr = either (Right . Left) (either Left (Right . Right))
cosublPut :: (Monad m) => PutlensM m (Either (Either a c) b) (Either (Either a b) c)
cosublPut = isoPut cosubl cosubl
where cosubl = either (either (Left . Left) Right) (Left . Right)
distpPut :: (Monad m) => PutlensM m ((a,c),(b,d)) ((a,b),(c,d))
distpPut = isoPut distp distp
where distp ((x,y),(z,w)) = ((x,z),(y,w))
distsPut :: (Monad m) => PutlensM m (Either (Either (a,c) (a,d)) (Either (b,c) (b,d))) (Either a b,Either c d)
distsPut = (distrPut -|-< distrPut) .< distlPut
undistsPut :: (Monad m) => PutlensM m (Either a b,Either c d) (Either (Either (a,c) (a,d)) (Either (b,c) (b,d)))
undistsPut = undistlPut .< (undistrPut -|-< undistrPut)
paramfstPut :: (Monad m) => (k -> PutlensM m s v) -> PutlensM m (k,s) (k,v)
paramfstPut f = PutlensM getputM' createM'
where getputM' (k,s) = let (mb,_) = getputM (f k) s
in (liftM (\v -> (k,v)) mb,putM' s)
createM' (k,v') = do { s <- createM (f k) v'; return (k,s) }
putM' s (k,v') = do let (_,putf) = getputM (f k) s
s' <- putf v'
return (k,s')
paramSrcPut :: (Monad m) => (Maybe s -> k) -> (k -> PutlensM m s v) -> PutlensM m s v
paramSrcPut f l = PutlensM getput' create' where
getput' s = let k = f (Just s) in getputM (l k) s
create' = createM (l $ f Nothing)
paramfstGet :: (Monad m,Eq v) => (v -> m k) -> (k -> PutlensM m s v) -> PutlensM m (k,s) v
paramfstGet g f = paramfstPut f .< keepfstOrPut g
paramsndPut :: (Monad m) => (k -> PutlensM m s v) -> PutlensM m (s,k) (v,k)
paramsndPut f = swapPut .< paramfstPut f .< swapPut
paramsndGet :: (Monad m,Eq v) => (v -> m k) -> (k -> PutlensM m s v) -> PutlensM m (s,k) v
paramsndGet g f = paramsndPut f .< keepsndOrPut g
paramPut :: Monad m => (Maybe s -> v -> m k) -> (k -> PutlensM m s v) -> PutlensM m s v
paramPut f l = PutlensM getput' create' where
getput' s = (getM (l $ error "paramPut: parameter cannot be used in get") s,put' (Just s))
put' s v' = liftPutM (f s v') >>= \k -> createM (l k) v'
create' = put' Nothing