-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.Putlenses.Language
-- Copyright   :  (C) 2013 Hugo Pacheco
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Hugo Pacheco <hpacheco@nii.ac.jp>
-- Stability   :  provisional
--
-- Core language of put-based lenses.
-- 
--
--
----------------------------------------------------------------------------

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,
	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,
	paramsndPut
) where

import Data.Maybe
import Control.Monad.Reader
import Control.Monad.State
import Generics.Putlenses.Putlens
import GHC.InOut

-- * Core Language

-- ** Environment modifiers

-- | Modifies the environment to the original source
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')

-- | Modifies the environment to the original source (with @Maybe@)
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')

-- | Modifies the environment to the original view
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')

-- | Modifies the environment to the original view (with @Maybe@)
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')

-- | Modifies the environment to the updated view
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')

-- ** State modifiers

-- Ignores the current state and re-initializes the monad with a new state
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'

-- | Modifies the state before executing put
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'

-- | Modifies the state after executing put
updateSt :: (st -> e -> s -> st) -> Putlens st e s v -> Putlens st e s v
updateSt f l = modifySt f idPut .< l

-- ** Unsafe cast combinators

-- internal
offGetPut :: PutM e st s -> PutM e st s
offGetPut m = withReaderT (\(e,testGetPut) -> (e,False)) m

-- internal
onPutGet :: PutM e st s -> PutM e st s
onPutGet m = mapReaderT (withState (\(st,testPutGet) -> (st,True))) m

-- internal
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')
          
-- internal
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'
  
-- | Modifies the original source before executing put (unsafe cast)
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')

-- | Modifies the updated view before executing put (unsafe cast)
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')
	
-- | Modifies the updated source after executing put (unsafe cast)
updateS' :: (st -> e -> s -> s) -> Putlens st e s v -> Putlens st e s v
updateS' f l = modifyV' f idPut .< l

-- | Unfork putlens that applies two putlenses to distinct sides of a view pair, producing the same source (unsafe)
-- ^ Dualizes forward splitting and induces a source-passing style
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'

-- ** Basic combinators

-- | Identity putlens
idPut :: Putlens st e v v
idPut = Putlens getput' create'
    where getput' s = (Just s,create')
          create' v' = return v'

infixr 9 .<
-- | Binary composition of putlenses
(.<) :: 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'

-- | View-based filtering putlens
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"

-- | Bottom putlens that is always undefined
botPut :: Putlens st e a b
botPut = Putlens getput' create'
    where getput' s = (Nothing,create')
          create' v' = return (error "botPut fails")

-- ** Product combinators

-- | Adds a value to the left of the view (according to a user-specified function)
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')

-- | Adds a value to the right of the view (according to a user-specified function)
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')

-- | Adds a value to the left of the view (retrieving it from the original source)
keepfstPut :: Eq v => Putlens st e (s1,v) v
keepfstPut = withS (addfstPut (\st (s1,v) v' -> s1))

-- | Adds a value to the right of the view (retrieving it from the original source)
keepsndPut :: Eq v => Putlens st e (v,s2) v
keepsndPut = withS (addsndPut (\st (v,s2) v' -> s2))

-- | Adds a value to the left of the view (retrieving it from the original source or otherwise using a user-specified function)
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')

-- | Adds a value to the right of the view (retrieving it from the original source or otherwise using a user-specified function)
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')

-- | Deletes the left value of a view pair (taking a user-specified function that instructs how it can be restored)
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')

-- | Deletes the right value of a view pair (taking a user-specified function that instructs how it can be restored)
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 ><<
-- | Product putlens that applies two putlenses to distinct sides of a view pair, producing a source pair
(><<) :: (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)

-- ** Unit combinators

-- | Deletes a user-specified view
ignorePut :: Eq v => v -> Putlens st e () v
ignorePut x = remfstPut (\() -> x) .< addsndPut (\st e v -> ())

-- | Creates a constant source from an empty view
newPut :: s -> Putlens st e s ()
newPut x = pntPut (\st e -> x)

-- | Creates a source from an empty view (according to a user-specified function)
pntPut :: (st -> e -> a) -> Putlens st e a ()
pntPut f = remfstPut (\s -> ()) .< addsndPut (\st e () -> f st e)
	
-- | Adds an empty view to the left of the view
addfstOnePut :: Eq v => Putlens st e ((),v) v
addfstOnePut = addfstPut (\st e -> const ())

-- | Adds an empty view to the right of the view
addsndOnePut :: Eq v => Putlens st e (v,()) v
addsndOnePut = addsndPut (\st e -> const ())
	
-- | Deletes an empty view to the left of the view
remfstOnePut :: Putlens st e a ((),a)
remfstOnePut = remfstPut (const ())

-- | Deletes an empty view to the left of the view
remsndOnePut :: Putlens st e a (a,())
remsndOnePut = remsndPut (const ())

-- ** Sum combinators

-- | Injects a tag in the view (according to a user-specified predicate)
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')

-- | Injects a tag in the view (according to the tags of the original source)
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 \/<
-- | Ignores the tags in the view
-- ^ Fails whenever the domains of @getM f@ and @getM g@ are not disjoint
(\/<) :: 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)

-- | Ignores the tags in the view (guaranteeing disjointness according to a predicate on sources)
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 .\/<
-- | Ignores the tags in the view (left-biased)
-- ^ Guarantees disjointness by favoring the left putlens
(.\/<) :: 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 \/.<
-- | Ignores the tags in the view (right-biased)
-- ^ Guarantees disjointness by favoring the right putlens
(\/.<) :: 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 -|-<
-- | Sum putlens that applies two putlenses to distinct sides of a view sum, producing a view sum
(-|-<) :: 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')

-- | Injects a left tag in the view
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')

-- | Injects a right tag in the view
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')

-- | Ignores left tags for left-tagged views
uninjlPut :: Putlens st e v (Either v v2)
uninjlPut = (idPut \/< botPut)

-- | Ignores left tags for left-tagged views
uninjrPut :: Putlens st e v (Either v1 v)
uninjrPut = (botPut \/< idPut)

-- ** Conditional combinators

-- | Conditional putlens combinator
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

-- | Conditional putlens combinator (with a predicate on views)
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)
	
-- | Conditional putlens combinator (with a predicate on sources)
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)

-- | Special if-then-else combinator for two putlenses with the same get function
-- ^ Given the invariant |getM f = getM g|, there are no restrictions regarding branching behavior
-- ^ This invariant is not checked
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'

-- ** Custom Combinators

-- | Embed user-specified lenses as putlenses
customPut :: Eq v => (st -> Maybe s -> v -> s) -> (s -> v) -> Putlens st e s v
customPut put get = withMbS (remfstPut get .< addsndPut put)
	
-- ** Recursive combinators

-- | Putlens from a sums-of-products view to an algebraic data type source
innPut :: InOut a => Putlens st e a (F a)
innPut = isoPut inn out

-- | Putlens from an algebraic data type view to a sums-of-products source 
outPut :: InOut a => Putlens st e (F a) a
outPut = isoPut out inn
	
-- ** Isomorphism combinators

-- internal
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)

-- | Swaps the order of elements in a view pair
swapPut :: Putlens st e (b,a) (a,b)
swapPut = isoPut swap swap
    where swap (x,y) = (y,x)

-- | Associates a right-nested view pair to the left
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))

-- | Associates a left-nested view pair to the right
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)

-- | Swaps the order of elements in a view sum
coswapPut :: Putlens st e (Either b a) (Either a b)
coswapPut = isoPut coswap coswap
    where coswap = either Right Left

-- | Associates a right-nested view sum to the 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)

-- | Associates a left-nested view sum to the left
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)
          
-- | Distributes a sum to the left of a view pair into a sum of pairs
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))
	
-- | Undistributes a sum of pairs view into source pair with a sum to the left
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

-- | Distributes a sum to the right of a view pair into a sum of pairs
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))
	
-- | Undistributes a sum of pairs view into source pair with a sum to the right
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

-- | Swaps the first with the second element of a right-nested view pair
subrPut :: Putlens st e (b,(a,c)) (a,(b,c))
subrPut = isoPut subr subr
    where subr (x,(y,z)) = (y,(x,z))

-- | Swaps the second with the third element of a left-nested view pair
sublPut :: Putlens st e ((a,c),b) ((a,b),c)
sublPut = isoPut subl subl
    where subl ((x,y),z) = ((x,z),y)

-- | Swaps the first with the second choice of a right-nested view sum
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))

-- | Swaps the second with the third choice of a left-nested view sum
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)

-- | Swaps the order of two nested view pairs
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))

-- | Distributes a pair of view sums into a sum of choices
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

-- ** Additional putlens parameters

-- | Lifts a parameter outside of a lens (first element as external parameter)
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')

-- | Lifts a parameter outside of a lens (second element as external parameter)
paramsndPut :: (k -> Putlens st e s v) -> Putlens st e (s,k) (v,k)
paramsndPut f = swapPut .< paramfstPut f .< swapPut