module Generics.Putlenses.Language (
withS,
withMbS,
withV,
withMbV,
withV',
initSt,
modifySt,
updateSt,
modifyS,
modifyV',
updateS',
unforkPut,
idPut,
(.<),
phiPut,
botPut,
addfstPut,
addsndPut,
keepfstPut,
keepsndPut,
keepfstOrPut,
keepsndOrPut,
remfstPut,
remsndPut,
(><<),
ignorePut,
newPut,
keepPut,
pntPut,
addfstOnePut,
addsndOnePut,
remfstOnePut,
remsndOnePut,
injPut,
injSPut,
(\/<),
eitherSPut,
(.\/<),
(\/.<),
(-|-<),
injlPut,
injrPut,
uninjlPut,
uninjrPut,
ifthenelsePut,
ifVthenelsePut,
ifSthenelsePut,
ifKthenelsePut,
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.State
import Generics.Putlenses.Putlens
import GHC.InOut
withS :: Putlens st s s v -> Putlens st e s v
withS l = l { getputM = getput', createM = create' }
where getput' s = let (v,put) = getputM l s
put' v' = withReaderT (\(e,testGetPut) -> (s,testGetPut)) (put v')
in (v,put')
create' v' = withReaderT (\(e,testGetPut) -> (error "withS fails (no original source)",testGetPut)) (createM l v')
withMbS :: Putlens st (Maybe s) s v -> Putlens st e s v
withMbS l = l { getputM = getput', createM = create' }
where getput' s = let (v,put) = getputM l s
put' v' = withReaderT (\(e,testGetPut) -> (Just s,testGetPut)) (put v')
in (v,put')
create' v' = withReaderT (\(e,testGetPut) -> (Nothing,testGetPut)) (createM l v')
withV :: Putlens st v s v -> Putlens st e s v
withV l = l { getputM = getput', createM = create' }
where getput' s = let (mbv,put) = getputM l s
v = maybe (error "withV fails (no original view)") id mbv
put' v' = withReaderT (\(e,testGetPut) -> (v,testGetPut)) (put v')
in (mbv,put')
create' v' = withReaderT (\(e,testGetPut) -> (error "withV fails (no original view)",testGetPut)) (createM l v')
withMbV :: Putlens st (Maybe v) s v -> Putlens st e s v
withMbV l = l { getputM = getput', createM = create' }
where getput' s = let (v,put) = getputM l s
put' v' = withReaderT (\(e,testGetPut) -> (v,testGetPut)) (put v')
in (v,put')
create' v' = withReaderT (\(e,testGetPut) -> (Nothing,testGetPut)) (createM l v')
withV' :: Putlens st v s v -> Putlens st e s v
withV' l = l { getputM = getput', createM = create' }
where getput' s = let (v,put) = getputM l s
put' v' = withReaderT (\(e,testGetPut) -> (v',testGetPut)) (put v')
in (v,put')
create' v' = withReaderT (\(e,testGetPut) -> (v',testGetPut)) (createM l v')
initSt :: (st -> e -> v -> st') -> Putlens st' e s v -> Putlens st e s v
initSt f l = l { getputM = getput', createM = create' }
where getput' s = let (v,put') = getputM l s in (v,createSt put')
create' = createSt (createM l)
createSt put v' = do (st,testPutGet) <- readSt
(e,testGetPut) <- ask
let st' = f st e v'
(s',testPutGet') = runPutM (put v') (e,testGetPut) (st',testPutGet)
writeSt (st,testPutGet')
return s'
modifySt :: (st -> e -> v -> st) -> Putlens st e s v -> Putlens st e s v
modifySt f l = l { getputM = getput', createM = create' }
where getput' s = let (v,put') = getputM l s in (v,createSt put')
create' = createSt (createM l)
createSt put v' = do (e,testGetPut) <- ask
(st,testPutGet) <- readSt
writeSt (f st e v',testPutGet)
put v'
updateSt :: (st -> e -> s -> st) -> Putlens st e s v -> Putlens st e s v
updateSt f l = modifySt f idPut .< l
offGetPut :: PutM e st s -> PutM e st s
offGetPut m = withReaderT (\(e,testGetPut) -> (e,False)) m
onPutGet :: PutM e st s -> PutM e st s
onPutGet m = mapReaderT (withState (\(st,testPutGet) -> (st,True))) m
checkGetPut :: Eq v => Putlens st e s v -> Putlens st e s v
checkGetPut l = l { getputM = getput' }
where getput' s = let (v,put) = getputM l s
put' v' = do (e,testGetPut) <- ask
if testGetPut && v == Just v' then return s else put v'
in (v,put')
checkPutGet :: Putlens st e s v -> Putlens st e s v
checkPutGet l = l { getputM = getput', createM = create' (createM l) }
where getput' s = let (v,put) = getputM l s in (v,create' put)
create' put v' = do (st,testPutGet) <- readSt
writeSt (st,True)
put v'
modifyS :: Eq v => (st -> e -> s -> v -> s) -> Putlens st e s v -> Putlens st e s v
modifyS f l = checkGetPut $ l { getputM = getput' }
where getput' s = let (v,put) = getputM l s
put' v' = do (st,testPutGet) <- readSt
(e,testGetPut) <- ask
let s1 = f st e s v'
(v1,put1) = getputM l s1
offGetPut (put1 v')
in (v,put')
modifyV' :: (st -> e -> v -> v) -> Putlens st e s v -> Putlens st e s v
modifyV' f l = l { getputM = getput' }
where getput' s = let (v,put) = getputM l s
put' v' = do (st,testPutGet) <- readSt
(e,testGetPut) <- ask
let v1 = f st e v'
onPutGet (put v1)
in (v,put')
updateS' :: (st -> e -> s -> s) -> Putlens st e s v -> Putlens st e s v
updateS' f l = modifyV' f idPut .< l
unforkPut :: Putlens st e s v1 -> Putlens st e s v2 -> Putlens st e s (v1,v2)
unforkPut f g = checkPutGet (Putlens 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 :: Putlens st e v v
idPut = Putlens getput' create'
where getput' s = (Just s,create')
create' v' = return v'
infixr 9 .<
(.<) :: Putlens st e s u -> Putlens st e u v -> Putlens st e s v
(.<) f g = Putlens 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 :: (v -> Bool) -> Putlens st e v v
phiPut p = Putlens getput' create'
where getput' s = (if p s then Just s else Nothing,create')
create' v' | p v' = return v'
| otherwise = error "phiPut fails"
botPut :: Putlens st e a b
botPut = Putlens getput' create'
where getput' s = (Nothing,create')
create' v' = return (error "botPut fails")
addfstPut :: Eq v => (st -> e -> v -> s1) -> Putlens st e (s1,v) v
addfstPut f = checkGetPut $ Putlens getput' create'
where get' (s1,v) = Just v
create' v' = do f' <- withPutM f
return (f' v',v')
getput' s = (get' s,create')
addsndPut :: Eq v => (st -> e -> v -> s2) -> Putlens st e (v,s2) v
addsndPut f = checkGetPut $ Putlens getput' create'
where get' (v,s2) = Just v
create' v' = do f' <- withPutM f
return (v', f' v')
getput' s = (get' s,create')
keepfstPut :: Eq v => Putlens st e (s1,v) v
keepfstPut = withS (addfstPut (\st (s1,v) v' -> s1))
keepsndPut :: Eq v => Putlens st e (v,s2) v
keepsndPut = withS (addsndPut (\st (v,s2) v' -> s2))
keepfstOrPut :: Eq v => (st -> e -> v -> s1) -> Putlens st e (s1,v) v
keepfstOrPut f = initSt (\st e v' -> (st,e)) $ withMbS $ addfstPut (\(st,e) s v' -> if isJust s then fst (fromJust s) else f st e v')
keepsndOrPut :: Eq v => (st -> e -> v -> s2) -> Putlens st e (v,s2) v
keepsndOrPut f = initSt (\st e v' -> (st,e)) $ withMbS $ addsndPut (\(st,e) s v' -> if isJust s then snd (fromJust s) else f st e v')
remfstPut :: Eq v1 => (v -> v1) -> Putlens st e v (v1,v)
remfstPut f = Putlens getput' create'
where get' v = Just (f v,v)
create' (v1',v') | f v' == v1' = return v'
| otherwise = error "remfstPut fails"
getput' s = (get' s,create')
remsndPut :: Eq v2 => (v -> v2) -> Putlens st e v (v,v2)
remsndPut f = Putlens getput' create'
where get' v = Just (v,f v)
create' (v',v2') | f v' == v2' = return v'
| otherwise = error "remsndPut fails"
getput' s = (get' s,create')
infix 7 ><<
(><<) :: (Eq v1,Eq v2) => Putlens st e s1 v1 -> Putlens st e s2 v2 -> Putlens st e (s1,s2) (v1,v2)
(><<) f g = checkGetPut $ Putlens 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 :: Eq v => v -> Putlens st e () v
ignorePut x = remfstPut (\() -> x) .< addsndPut (\st e v -> ())
newPut :: s -> Putlens st e s ()
newPut x = pntPut (\st e -> x)
keepPut :: Putlens st e s ()
keepPut = withS (pntPut (\st s -> s))
pntPut :: (st -> e -> a) -> Putlens st e a ()
pntPut f = remfstPut (\s -> ()) .< addsndPut (\st e () -> f st e)
addfstOnePut :: Eq v => Putlens st e ((),v) v
addfstOnePut = addfstPut (\st e -> const ())
addsndOnePut :: Eq v => Putlens st e (v,()) v
addsndOnePut = addsndPut (\st e -> const ())
remfstOnePut :: Putlens st e a ((),a)
remfstOnePut = remfstPut (const ())
remsndOnePut :: Putlens st e a (a,())
remsndOnePut = remsndPut (const ())
injPut :: Eq v => (st -> e -> v -> Bool) -> Putlens st e (Either v v) v
injPut p = checkGetPut $ Putlens getput' create'
where get' s = Just (either id id s)
create' v' = do p' <- withPutM p
if p' v' then return (Left v') else return (Right v')
getput' s = (get' s,create')
injSPut :: Eq v => Putlens st e (Either v v) v
injSPut = withS (injPut (\st s v -> p s))
where p = either (const True) (const False)
infix 4 \/<
(\/<) :: Putlens st e s v1 -> Putlens st e s v2 -> Putlens st e s (Either v1 v2)
(\/<) f g = Putlens 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') = liftM (disj f g) (put1 v1')
put' put1 put2 (Right v2') = liftM (disj g f) (put2 v2')
disj x y s | isJust (getM x s) && isNothing (getM y s) = s
| otherwise = error "\\/< fails"
create' = put' (createM f) (createM g)
eitherSPut :: (s -> Bool) -> Putlens st e s v1 -> Putlens st e s v2 -> Putlens st e s (Either v1 v2)
eitherSPut p f g = (phiPut p .< f) \/< (phiPut (not . p) .< g)
infix 4 .\/<
(.\/<) :: Putlens st e s v1 -> Putlens st e s v2 -> Putlens st e s (Either v1 v2)
(.\/<) f g = f \/< (phiPut (isNothing . getM f) .< g)
infix 4 \/.<
(\/.<) :: Putlens st e s v1 -> Putlens st e s v2 -> Putlens st e s (Either v1 v2)
(\/.<) f g = (phiPut (isNothing . getM g) .< f) \/< g
infix 5 -|-<
(-|-<) :: Putlens st e s1 v1 -> Putlens st e s2 v2 -> Putlens st e (Either s1 s2) (Either v1 v2)
(-|-<) f g = Putlens 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 :: Putlens st e (Either v v2) v
injlPut = Putlens getput' create'
where getput' s = (get' s,create')
get' (Left s1) = Just s1
get' (Right s2) = Nothing
create' v' = return (Left v')
injrPut :: Putlens st e (Either v1 v) v
injrPut = Putlens getput' create'
where getput' s = (get' s,create')
get' (Left s1) = Nothing
get' (Right s2) = Just s2
create' v' = return (Right v')
uninjlPut :: Putlens st e v (Either v v2)
uninjlPut = (idPut \/< botPut)
uninjrPut :: Putlens st e v (Either v1 v)
uninjrPut = (botPut \/< idPut)
ifthenelsePut :: Eq v => (st -> e -> v -> Bool) -> Putlens st e s v -> Putlens st e s v -> Putlens st e s v
ifthenelsePut p f g = (f .\/< g) .< injPut p
ifVthenelsePut :: Eq v => (v -> Bool) -> Putlens st e s v -> Putlens st e s v -> Putlens st e s v
ifVthenelsePut p f g = ((f .< phiPut p) .\/< g) .< injPut (\st e -> p)
ifSthenelsePut :: Eq v => (s -> Bool) -> Putlens st e s v -> Putlens st e s v -> Putlens st e s v
ifSthenelsePut p f g = Putlens getput' create'
where l Nothing = eitherSPut p f g .< injPut (\st e v -> True)
l (Just s) = eitherSPut p f g .< injPut (\st e v -> p s)
getput' s = getputM (l (Just s)) s
create' = createM (l Nothing)
ifKthenelsePut :: (st -> e -> v -> Bool) -> Putlens st e s v -> Putlens st e s v -> Putlens st e s v
ifKthenelsePut p f g = Putlens getput' create'
where getput' s = let (v1,put1) = getputM f s
(v2,put2) = getputM g s
in (v1,put' put1 put2)
create' = put' (createM f) (createM g)
put' putf putg v' = do p' <- withPutM p
if p' v' then putf v' else putg v'
customPut :: Eq v => (st -> Maybe s -> v -> s) -> (s -> v) -> Putlens st e s v
customPut put get = withMbS (remfstPut get .< addsndPut put)
innPut :: InOut a => Putlens st e a (F a)
innPut = isoPut inn out
outPut :: InOut a => Putlens st e (F a) a
outPut = isoPut out inn
isoPut :: (a -> b) -> (b -> a) -> Putlens st e b a
isoPut f g = Putlens getput' create'
where getput' b = (Just (g b),create')
create' a = return (f a)
swapPut :: Putlens st e (b,a) (a,b)
swapPut = isoPut swap swap
where swap (x,y) = (y,x)
assoclPut :: Putlens st e ((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 :: Putlens st e (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 :: Putlens st e (Either b a) (Either a b)
coswapPut = isoPut coswap coswap
where coswap = either Right Left
coassoclPut :: Putlens st e (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 :: Putlens st e (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 :: Putlens st e (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 :: Putlens st e (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 :: Putlens st e (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 :: Putlens st e (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 :: Putlens st e (b,(a,c)) (a,(b,c))
subrPut = isoPut subr subr
where subr (x,(y,z)) = (y,(x,z))
sublPut :: Putlens st e ((a,c),b) ((a,b),c)
sublPut = isoPut subl subl
where subl ((x,y),z) = ((x,z),y)
cosubrPut :: Putlens st e (Either b (Either a c)) (Either a (Either b c))
cosubrPut = isoPut cosubr cosubr
where cosubr = either (Right . Left) (either Left (Right . Right))
cosublPut :: Putlens st e (Either (Either a c) b) (Either (Either a b) c)
cosublPut = isoPut cosubl cosubl
where cosubl = either (either (Left . Left) Right) (Left . Right)
distpPut :: Putlens st e ((a,c),(b,d)) ((a,b),(c,d))
distpPut = isoPut distp distp
where distp ((x,y),(z,w)) = ((x,z),(y,w))
distsPut :: Putlens st e (Either (Either (a,c) (a,d)) (Either (b,c) (b,d))) (Either a b,Either c d)
distsPut = (distrPut -|-< distrPut) .< distlPut
paramfstPut :: (k -> Putlens st e s v) -> Putlens st e (k,s) (k,v)
paramfstPut f = Putlens 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 :: Eq v => (k -> Putlens st e s v) -> Putlens st e (k,s) v
paramfstGet f = paramfstPut f .< keepfstPut
paramsndPut :: (k -> Putlens st e s v) -> Putlens st e (s,k) (v,k)
paramsndPut f = swapPut .< paramfstPut f .< swapPut
paramsndGet :: Eq v => (k -> Putlens st e s v) -> Putlens st e (s,k) v
paramsndGet f = paramsndPut f .< keepsndPut