-----------------------------------------------------------------------------
-- |
-- 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 (
	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

-- * Core Language

-- ** Environment modifiers

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

-- | Applies some monadic modification (like changing a state) to a putlens
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

-- | Runs an inner monad @n@ inside a putlens with monad @m@
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'

-- ** Putlenses with explicitly partial put functions (@MaybeT@ monad transformer)

-- | Converts a putlens wiht explicitly partial put functions into a normal putlens
runMaybePut :: Monad m => PutlensMaybeM m s v -> PutlensM m s v
runMaybePut = mapPutlensM (liftM (maybe (error "initMb fails") id) . runMaybeT)

-- ** State modifiers

-- | Initializes the monad with a new state
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

-- | Ignores the current state and initializes a new state monad with a new state
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
    
-- | Modifies the state before executing put
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)

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

-- ** Unsafe cast combinators

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

-- | Modifies the updated view before executing put (unsafe cast)
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)
	
-- | Modifies the updated source after executing put (unsafe cast)
updateS' :: Monad m => (Maybe s -> s -> m s) -> PutlensM m s v -> PutlensM m 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 :: 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'

-- ** Basic combinators

-- | Identity putlens
idPut :: Monad m => PutlensM m v v
idPut = PutlensM getput' create'
    where getput' s = (Just s,create')
          create' v' = return v'

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

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

-- | Bottom putlens that is always undefined
botPut :: Monad m => PutlensM m a b
botPut = PutlensM getput' create'
    where getput' s = (Nothing,create')
          create' v' = fail "botPut fails"

-- ** Product combinators

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

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

-- | Duplicates a view by enforcing the two sources to be the same
dupPut :: (Monad m,Eq v) => PutlensM m (v,v) v
dupPut = phiPut (uncurry (==)) .< addsndPut (\e v -> return v)

-- | Adds a value to the left of the view (retrieving it from the original source)
keepfstPut :: (Monad m,Eq v) => PutlensM m (s1,v) v
keepfstPut = keepfstOrPut (\v -> fail "keepfstPut fails")

-- | Adds a value to the right of the view (retrieving it from the original source)
keepsndPut :: (Monad m,Eq v) => PutlensM m (v,s2) v
keepsndPut = keepsndOrPut (\v -> fail "keepsndPut fails")

-- | Adds a value to the left of the view (retrieving it from the original source or otherwise using a user-specified function)
keepfstOrPut :: (Monad m,Eq v) => (v -> m s1) -> PutlensM m (s1,v) v
keepfstOrPut f = addfstPut (\s v' -> maybe (f v') (return . fst) s)

-- | Adds a value to the right of the view (retrieving it from the original source or otherwise using a user-specified function)
keepsndOrPut :: (Monad m,Eq v) => (v -> m s2) -> PutlensM m (v,s2) v
keepsndOrPut f = addsndPut (\s v' -> maybe (f v') (return . snd) s)

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

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

-- ** Unit combinators

-- | Deletes a user-specified view
ignorePut :: (Monad m,Eq v) => v -> PutlensM m () v
ignorePut x = remfstPut (\() -> x) .< addsndPut (\e v -> return ())

-- | Creates a constant source from an empty view
newPut :: Monad m => s -> PutlensM m s ()
newPut x = pntPut (\e -> return x)

-- | Adds a new source (retrieving the original source)
keepPut :: Monad m => PutlensM m s ()
keepPut = pntPut (\s -> maybe (fail "keepPut fails") return s)

-- | Creates a source from an empty view (according to a user-specified function)
pntPut :: Monad m => (Maybe a -> m a) -> PutlensM m a ()
pntPut f = remfstPut (\s -> ()) .< addsndPut (\s () -> f $ fmap snd s)
	
-- | Adds an empty view to the left of the view
addfstOnePut :: (Monad m,Eq v) => PutlensM m ((),v) v
addfstOnePut = addfstPut (\e v -> return ())

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

-- | Deletes an empty view to the left of the view
remsndOnePut :: Monad m => PutlensM m a (a,())
remsndOnePut = remsndPut (const ())

-- ** Sum combinators

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

-- | Injects a tag in the view (according to the tags of the original source)
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)

-- | Injects a tag in the view (according to the tags of the original source) with a left default for create
injlsPut :: (Monad m,Eq v) => PutlensM m (Either v v) v
injlsPut = injsOrPut (\v -> return True)

-- | Injects a tag in the view (according to the tags of the original source) with a right default for create
injrsPut :: (Monad m,Eq v) => PutlensM m (Either v v) v
injrsPut = injsOrPut (\v -> return False)

-- | Injects a tag in the view according to the tags of the original source or giving preference to the first lens when both are applicable.
-- Requires the monad to be an instance of @MonadPlus@ to recover from failure.
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 \/<
-- | Ignores the tags in the view
-- ^ Fails whenever the domains of @getM f@ and @getM g@ are not disjoint
(\/<) :: 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)

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

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

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

-- | Ignores left tags for left-tagged views
uninjlPut :: Monad m => PutlensM m v (Either v v2)
uninjlPut = (idPut \/< botPut)

-- | Ignores left tags for left-tagged views
uninjrPut :: Monad m => PutlensM m v (Either v1 v)
uninjrPut = (botPut \/< idPut)

-- ** Conditional combinators

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

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

-- | 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
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 -- only test when both are defined
                                        | 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 -- get is known to succeed after a put
                     | otherwise = fail "ifKthenelsePut put fails"

-- | Union of two putlenses (requires the monad to be an instance of @MonadPlus@ to be able to recover from failure)
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

-- ** Custom Combinators

-- | Embed user-specified lenses as putlenses
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')
	
-- ** Recursive combinators

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

-- | Putlens from an algebraic data type view to a sums-of-products source 
outPut :: (Monad m,InOut a) => PutlensM m (F a) a
outPut = isoPut out inn
	
-- ** Isomorphism combinators
-- These could be defined as derived combinators, but are defined as primitives for efficiency

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

-- | Swaps the order of elements in a view pair
swapPut :: Monad m => PutlensM m (b,a) (a,b)
swapPut = isoPut swap swap
    where swap (x,y) = (y,x)

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

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

-- | Swaps the order of elements in a view sum
coswapPut :: Monad m => PutlensM m (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 :: 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)

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

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

-- | Swaps the first with the second element of a right-nested view pair
subrPut :: Monad m => PutlensM m (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 :: Monad m => PutlensM m ((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 :: 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))

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

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

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

-- ** Additional putlens parameters

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

-- | Lifts a left element of the source to an external parameter
paramfstGet :: (Monad m,Eq v) => (k -> PutlensM m s v) -> PutlensM m (k,s) v
paramfstGet f = paramfstPut f .< keepfstPut

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

-- | Lifts a right element of the source to an external parameter
paramsndGet :: (Monad m,Eq v) => (k -> PutlensM m s v) -> PutlensM m (s,k) v
paramsndGet f = paramsndPut f .< keepsndPut