module Generics.Putlenses.Language (
withMonadPut,
effectPut,
runMaybePut,
runStatePut,
resetStatePut,
withStatePut,
withStateTPut,
updateStatePut,
updateStateTPut,
runReaderPut,
runReaderPutS,
runReaderPutMbS,
runReaderPutV,
runReaderPutMbV,
runReaderPutV',
withReaderPut,
modifyS,
modifyV',
updateS',
unforkPut,
idPut,
(.<),
phiPut,
botPut,
addfstPut,
addsndPut,
dupPut,
keepfstPut,
keepsndPut,
keepfstOrPut,
keepsndOrPut,
remfstPut,
remsndPut,
(><<),
ignorePut,
newPut,
keepPut,
pntPut,
addfstOnePut,
addsndOnePut,
remfstOnePut,
remsndOnePut,
injPut,
injsOrPut,
injlsPut,
injrsPut,
injunionPut,
(\/<),
eitherSPut,
(.\/<),
(\/.<),
(-|-<),
injlPut,
injrPut,
uninjlPut,
uninjrPut,
ifthenelsePut,
ifVthenelsePut,
ifSthenelsePut,
ifKthenelsePut,
unionPut,
customPut,
innPut,
outPut,
swapPut,
assoclPut,
assocrPut,
coswapPut,
coassoclPut,
coassocrPut,
distlPut,
distrPut,
undistlPut,
undistrPut,
subrPut,
sublPut,
cosubrPut,
cosublPut,
distpPut,
distsPut,
paramfstPut,
paramfstGet,
paramsndPut,
paramsndGet
) 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 Nothing
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')
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')
effectPut :: Monad m => (Maybe s -> v -> m ()) -> PutlensM m s v -> PutlensM m s v
effectPut f l = withMonadPut (\e v' m -> f e 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'
runMaybePut :: Monad m => PutlensMaybeM m s v -> PutlensM m s v
runMaybePut = mapPutlensM (liftM (maybe (error "initMb 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 => 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 <- putf v1'
let (v2I,putgI) = getputM g sI
putgI v2'
idPut :: Monad m => PutlensM m v v
idPut = PutlensM getput' create'
where getput' s = (Just 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"
botPut :: Monad m => PutlensM m a b
botPut = PutlensM getput' create'
where getput' s = (Nothing,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 $ PutlensM getput' (put' Nothing)
where get' (s1,v) = Just 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 $ PutlensM getput' (put' Nothing)
where get' (v,s2) = Just 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)
keepfstPut :: (Monad m,Eq v) => PutlensM m (s1,v) v
keepfstPut = keepfstOrPut (\v -> fail "keepfstPut fails")
keepsndPut :: (Monad m,Eq v) => PutlensM m (v,s2) v
keepsndPut = keepsndOrPut (\v -> fail "keepsndPut fails")
keepfstOrPut :: (Monad m,Eq v) => (v -> m s1) -> PutlensM m (s1,v) v
keepfstOrPut f = addfstPut (\s v' -> maybe (f v') (return . fst) s)
keepsndOrPut :: (Monad m,Eq v) => (v -> m s2) -> PutlensM m (v,s2) v
keepsndOrPut f = addsndPut (\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,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) .< addsndPut (\e v -> return ())
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)
pntPut :: Monad m => (Maybe a -> m a) -> PutlensM m a ()
pntPut f = remfstPut (\s -> ()) .< addsndPut (\s () -> f $ fmap snd s)
addfstOnePut :: (Monad m,Eq v) => PutlensM m ((),v) v
addfstOnePut = addfstPut (\e v -> return ())
addsndOnePut :: (Monad m,Eq v) => PutlensM m (v,()) v
addsndOnePut = addsndPut (\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 $ PutlensM getput' (put' Nothing)
where get' s = Just (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,Eq v) => (v -> m Bool) -> PutlensM m (Either v v) v
injsOrPut p = injPut (\s v' -> maybe (p v') (return . isLeft) s)
where isLeft = either (const True) (const False)
injlsPut :: (Monad m,Eq v) => PutlensM m (Either v v) v
injlsPut = injsOrPut (\v -> return True)
injrsPut :: (Monad m,Eq v) => 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 $ 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
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)
eitherSPut :: Monad m => (s -> Bool) -> PutlensM m s v1 -> PutlensM m s v2 -> PutlensM m s (Either v1 v2)
eitherSPut p f g = (phiPut p .< f) \/< (phiPut (not . p) .< g)
infix 4 .\/<
(.\/<) :: Monad m => PutlensM m s v1 -> PutlensM m s v2 -> PutlensM m s (Either v1 v2)
(.\/<) f g = f \/< (phiPut (not . dom f) .< g)
infix 4 \/.<
(\/.<) :: Monad m => PutlensM m s v1 -> PutlensM m s v2 -> PutlensM m s (Either v1 v2)
(\/.<) f g = (phiPut (not . dom g) .< f) \/< 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) = Just s1
get' (Right s2) = Nothing
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) = Nothing
get' (Right s2) = Just s2
create' v' = return (Right v')
uninjlPut :: Monad m => PutlensM m v (Either v v2)
uninjlPut = (idPut \/< botPut)
uninjrPut :: Monad m => PutlensM m v (Either v1 v)
uninjrPut = (botPut \/< 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,Eq v) => (v -> Bool) -> PutlensM m s v -> PutlensM m s v -> PutlensM m s v
ifVthenelsePut p f g = ((f .< phiPut p) .\/< g) .< injPut (\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
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 = (Just (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
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')
paramfstGet :: (Monad m,Eq v) => (k -> PutlensM m s v) -> PutlensM m (k,s) v
paramfstGet f = paramfstPut f .< keepfstPut
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) => (k -> PutlensM m s v) -> PutlensM m (s,k) v
paramsndGet f = paramsndPut f .< keepsndPut