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

-- * 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 $ 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)

-- | 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 (\s v' m -> f s 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'

-- | Runs an inner monad @n@ inside a putlens with monad @m@ (using also the original view)
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'

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

-- | Converts a putlens with explicitly partial put functions into a normal putlens
runMaybePut :: (Monad m) => PutlensMaybeM m s v -> PutlensM m s v
runMaybePut = mapPutlensM (liftM (maybe (error "runMaybePut 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,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')

-- ** Basic combinators

-- | Identity putlens
idPut :: (Monad m) => PutlensM m v v
idPut = PutlensM getput' create'
    where getput' s = (return 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"

-- | Like phiPut p .< l, but with a less restricted put function that uses the original source even when it does not satisfy @p@
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)

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

-- | Bottom putlens that is always undefined
botPut :: (Monad m) => PutlensM m a b
botPut = PutlensM getput' create'
    where getput' s = (fail "bottom",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 (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))

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

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

-- | Duplicates a view but not enforcing the two sources to be the same
mergePut :: (Monad m,Eq v) => PutlensM m (v,v) v
mergePut = addsndPut (\e v -> return v)

-- | Adds a value to the left of the view (retrieving it from the original source)
keepfstPut :: (Monad m) => 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) => 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)
-- GetPut is always satisfied
keepfstOrPut :: (Monad m) => (v -> m s1) -> PutlensM m (s1,v) v
keepfstOrPut f = addfstPutUnsafe (\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)
-- GetPut is always satisfied
keepsndOrPut :: (Monad m) => (v -> m s2) -> PutlensM m (v,s2) v
keepsndOrPut f = addsndPutUnsafe (\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) => 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 ><<<
-- | Product putlens that applies two putlenses to distinct sides of a view pair, producing a source pair.
-- | Turns off/on GetPut checking for maximum expressivity.
(><<<) :: (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) .< addsndOnePut

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

keepOrPut :: (Monad m) => m s -> PutlensM m s ()
keepOrPut m = pntPut (\s -> maybe m 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) => PutlensM m ((),v) v
addfstOnePut = addfstPutUnsafe (\e v -> return ())

-- | Adds an empty view to the right of the view
addsndOnePut :: (Monad m) => PutlensM m (v,()) v
addsndOnePut = addsndPutUnsafe (\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 $ 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))

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

-- | Injects a tag in the view (according to the tags of the original source) with a left default for create
injlsPut :: (Monad m) => 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) => 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 (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 \/<
-- | 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
                             | 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)

-- | 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 = (phiSourcePut p f) \/< (phiSourcePut (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 `eitherPutUnsafe` (phiSourcePut (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 = (phiSourcePut (not . dom g) f) `eitherPutUnsafe` 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) = return s1
          get' (Right s2) = fail "injlPut get failed"
          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) = fail "injrPut get failed"
          get' (Right s2) = return s2
          create' v' = return (Right v')

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

-- | Ignores left tags for left-tagged views
uninjrPut :: (Monad m) => PutlensM m v (Either v1 v)
uninjrPut = (botPut `eitherPutUnsafe` 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) => (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)
	
-- | 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

-- | Union of two putlenses (without well-behavedness checks)
unionPutUnsafe :: (MonadPlus m) => PutlensM m s v -> PutlensM m s v -> PutlensM m s v
unionPutUnsafe f g = (idPut `eitherPutUnsafe` idPut) .< injunionPutUnsafe 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 = (return (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

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

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

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)

-- | Lifts a left element of the source to an external parameter
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

-- | 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) => (v -> m k) -> (k -> PutlensM m s v) -> PutlensM m (s,k) v
paramsndGet g f = paramsndPut f .< keepsndOrPut g

-- | Lifts a parameter used only by the backward function to an external parameter
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