{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE RankNTypes #-}

{-# OPTIONS_GHC -Wno-warnings-deprecations #-}

-------------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Unsound
-- Copyright   :  (C) 2012-16 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  Rank2Types
--
-- One commonly asked question is: can we combine two lenses,
-- @`Lens'` a b@ and @`Lens'` a c@ into @`Lens'` a (b, c)@.
-- This is fair thing to ask, but such operation is unsound in general.
-- See `lensProduct`.
--
-------------------------------------------------------------------------------
module Control.Lens.Unsound
  (
    lensProduct
  , prismSum
  , adjoin
  ) where

import Control.Lens
import Control.Lens.Internal.Prelude
import Prelude ()

-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens

-- | A lens product. There is no law-abiding way to do this in general.
-- Result is only a valid 'Lens' if the input lenses project disjoint parts of
-- the structure @s@. Otherwise "you get what you put in" law
--
-- @
-- 'Control.Lens.Getter.view' l ('Control.Lens.Setter.set' l v s) ≡ v
-- @
--
-- is violated by
--
-- >>> let badLens :: Lens' (Int, Char) (Int, Int); badLens = lensProduct _1 _1
-- >>> view badLens (set badLens (1,2) (3,'x'))
-- (2,2)
--
-- but we should get @(1,2)@.
--
-- Are you looking for 'Control.Lens.Lens.alongside'?
--
lensProduct :: ALens' s a -> ALens' s b -> Lens' s (a, b)
lensProduct :: ALens' s a -> ALens' s b -> Lens' s (a, b)
lensProduct ALens' s a
l1 ALens' s b
l2 (a, b) -> f (a, b)
f s
s =
    (a, b) -> f (a, b)
f (s
s s -> ALens' s a -> a
forall s t a b. s -> ALens s t a b -> a
^# ALens' s a
l1, s
s s -> ALens' s b -> b
forall s t a b. s -> ALens s t a b -> a
^# ALens' s b
l2) f (a, b) -> ((a, b) -> s) -> f s
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(a
a, b
b) -> s
s s -> (s -> s) -> s
forall a b. a -> (a -> b) -> b
& ALens' s a
l1 ALens' s a -> a -> s -> s
forall s t a b. ALens s t a b -> b -> s -> t
#~ a
a s -> (s -> s) -> s
forall a b. a -> (a -> b) -> b
& ALens' s b
l2 ALens' s b -> b -> s -> s
forall s t a b. ALens s t a b -> b -> s -> t
#~ b
b

-- | A dual of `lensProduct`: a prism sum.
--
-- The law
--
-- @
-- 'Control.Lens.Fold.preview' l ('Control.Lens.Review.review' l b) ≡ 'Just' b
-- @
--
-- breaks with
--
-- >>> let badPrism :: Prism' (Maybe Char) (Either Char Char); badPrism = prismSum _Just _Just
-- >>> preview badPrism (review badPrism (Right 'x'))
-- Just (Left 'x')
--
-- We put in 'Right' value, but get back 'Left'.
--
-- Are you looking for 'Control.Lens.Prism.without'?
--
prismSum :: APrism s t a b
         -> APrism s t c d
         -> Prism s t (Either a c) (Either b d)
prismSum :: APrism s t a b
-> APrism s t c d -> Prism s t (Either a c) (Either b d)
prismSum APrism s t a b
k APrism s t c d
k' =
    APrism s t a b
-> ((b -> t)
    -> (s -> Either t a)
    -> p (Either a c) (f (Either b d))
    -> p s (f t))
-> p (Either a c) (f (Either b d))
-> p s (f t)
forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism s t a b
k                  (((b -> t)
  -> (s -> Either t a)
  -> p (Either a c) (f (Either b d))
  -> p s (f t))
 -> p (Either a c) (f (Either b d)) -> p s (f t))
-> ((b -> t)
    -> (s -> Either t a)
    -> p (Either a c) (f (Either b d))
    -> p s (f t))
-> p (Either a c) (f (Either b d))
-> p s (f t)
forall a b. (a -> b) -> a -> b
$ \b -> t
bt s -> Either t a
seta ->
    APrism s t c d
-> ((d -> t)
    -> (s -> Either t c)
    -> p (Either a c) (f (Either b d))
    -> p s (f t))
-> p (Either a c) (f (Either b d))
-> p s (f t)
forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism s t c d
k'                 (((d -> t)
  -> (s -> Either t c)
  -> p (Either a c) (f (Either b d))
  -> p s (f t))
 -> p (Either a c) (f (Either b d)) -> p s (f t))
-> ((d -> t)
    -> (s -> Either t c)
    -> p (Either a c) (f (Either b d))
    -> p s (f t))
-> p (Either a c) (f (Either b d))
-> p s (f t)
forall a b. (a -> b) -> a -> b
$ \d -> t
dt s -> Either t c
setb ->
    (Either b d -> t)
-> (s -> Either t (Either a c))
-> Prism s t (Either a c) (Either b d)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism ((b -> t) -> (d -> t) -> Either b d -> t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> t
bt d -> t
dt) ((s -> Either t (Either a c))
 -> Prism s t (Either a c) (Either b d))
-> (s -> Either t (Either a c))
-> Prism s t (Either a c) (Either b d)
forall a b. (a -> b) -> a -> b
$ \s
s ->
    Either t (Either a c)
-> Either t (Either a c) -> Either t (Either a c)
forall a b. Either a b -> Either a b -> Either a b
f (a -> Either a c
forall a b. a -> Either a b
Left (a -> Either a c) -> Either t a -> Either t (Either a c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> Either t a
seta s
s) (c -> Either a c
forall a b. b -> Either a b
Right (c -> Either a c) -> Either t c -> Either t (Either a c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> Either t c
setb s
s)
  where
    f :: Either a b -> Either a b -> Either a b
f a :: Either a b
a@(Right b
_) Either a b
_ = Either a b
a
    f (Left a
_)    Either a b
b = Either a b
b

-- | A generalization of `mappend`ing folds: A union of disjoint traversals.
--
-- Traversing the same entry twice is illegal.
--
-- Are you looking for 'Control.Lens.Traversal.failing'?
--
adjoin :: Traversal' s a -> Traversal' s a -> Traversal' s a
adjoin :: Traversal' s a -> Traversal' s a -> Traversal' s a
adjoin Traversal' s a
t1 Traversal' s a
t2 =
    ALens' s [a] -> ALens' s [a] -> Lens' s ([a], [a])
forall s a b. ALens' s a -> ALens' s b -> Lens' s (a, b)
lensProduct (Traversing (->) (Pretext (->) [a] [a]) s s a a -> ALens' s [a]
forall (f :: * -> *) s t a.
Functor f =>
Traversing (->) f s t a a -> LensLike f s t [a] [a]
partsOf Traversing (->) (Pretext (->) [a] [a]) s s a a
Traversal' s a
t1) (Traversing (->) (Pretext (->) [a] [a]) s s a a -> ALens' s [a]
forall (f :: * -> *) s t a.
Functor f =>
Traversing (->) f s t a a -> LensLike f s t [a] [a]
partsOf Traversing (->) (Pretext (->) [a] [a]) s s a a
Traversal' s a
t2) ((([a], [a]) -> f ([a], [a])) -> s -> f s)
-> ((a -> f a) -> ([a], [a]) -> f ([a], [a]))
-> (a -> f a)
-> s
-> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> f [a]) -> ([a], [a]) -> f ([a], [a])
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both (([a] -> f [a]) -> ([a], [a]) -> f ([a], [a]))
-> ((a -> f a) -> [a] -> f [a])
-> (a -> f a)
-> ([a], [a])
-> f ([a], [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f a) -> [a] -> f [a]
forall s t a b. Each s t a b => Traversal s t a b
each