{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE Trustworthy           #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.These.Optics (
    -- * Affine traversals
    here, there,

    -- * Prisms
    _This, _That, _These,
    ) where

import Data.These
import Data.These.Combinators (swapThese)
import Optics.Core
       (AffineTraversal, Each (..), Prism', Swapped (..), atraversalVL, iso,
       itraversalVL, prism)

-- $setup
-- >>> import Data.These
-- >>> import Optics.Core

-------------------------------------------------------------------------------
-- Traversals
-------------------------------------------------------------------------------

-- | An 'AffineTraversal' of the first half of a 'These'.
--
-- >>> over here show (That 1)
-- That 1
--
-- >>> over here show (These 'a' 2)
-- These "'a'" 2
--
here :: AffineTraversal (These a c) (These b c) a b
here :: AffineTraversal (These a c) (These b c) a b
here = AffineTraversalVL (These a c) (These b c) a b
-> AffineTraversal (These a c) (These b c) a b
forall s t a b.
AffineTraversalVL s t a b -> AffineTraversal s t a b
atraversalVL AffineTraversalVL (These a c) (These b c) a b
forall (f :: * -> *) a b c.
Functor f =>
(forall r. r -> f r) -> (a -> f b) -> These a c -> f (These b c)
here' where
    here' :: Functor f => (forall r. r -> f r) -> (a -> f b) -> These a c -> f (These b c)
    here' :: (forall r. r -> f r) -> (a -> f b) -> These a c -> f (These b c)
here' forall r. r -> f r
_     a -> f b
f (This a
x)    = b -> These b c
forall a b. a -> These a b
This (b -> These b c) -> f b -> f (These b c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
    here' forall r. r -> f r
_     a -> f b
f (These a
x c
y) = (b -> c -> These b c) -> c -> b -> These b c
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> c -> These b c
forall a b. a -> b -> These a b
These c
y (b -> These b c) -> f b -> f (These b c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
    here' forall r. r -> f r
point a -> f b
_ (That c
x)    = These b c -> f (These b c)
forall r. r -> f r
point (c -> These b c
forall a b. b -> These a b
That c
x)

-- | An 'AffineTraversal' of the second half of a 'These'.
--
-- >>> over there show (That 1)
-- That "1"
--
-- >>> over there show (These 'a' 2)
-- These 'a' "2"
--
there :: AffineTraversal (These c a) (These c b) a b
there :: AffineTraversal (These c a) (These c b) a b
there = AffineTraversalVL (These c a) (These c b) a b
-> AffineTraversal (These c a) (These c b) a b
forall s t a b.
AffineTraversalVL s t a b -> AffineTraversal s t a b
atraversalVL AffineTraversalVL (These c a) (These c b) a b
forall (f :: * -> *) a b c.
Functor f =>
(forall r. r -> f r) -> (a -> f b) -> These c a -> f (These c b)
there' where
    there' :: Functor f => (forall r. r -> f r) -> (a -> f b) -> These c a -> f (These c b)
    there' :: (forall r. r -> f r) -> (a -> f b) -> These c a -> f (These c b)
there' forall r. r -> f r
point a -> f b
_ (This c
x)    = These c b -> f (These c b)
forall r. r -> f r
point (c -> These c b
forall a b. a -> These a b
This c
x)
    there' forall r. r -> f r
_     a -> f b
f (These c
x a
y) = c -> b -> These c b
forall a b. a -> b -> These a b
These c
x (b -> These c b) -> f b -> f (These c b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
y
    there' forall r. r -> f r
_     a -> f b
f (That a
x)    = b -> These c b
forall a b. b -> These a b
That (b -> These c b) -> f b -> f (These c b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x

-------------------------------------------------------------------------------
-- Prisms
-------------------------------------------------------------------------------

-- | A 'Prism'' selecting the 'This' constructor.
--
-- /Note:/ cannot change type.
_This :: Prism' (These a b) a
_This :: Prism' (These a b) a
_This = (a -> These a b)
-> (These a b -> Either (These a b) a) -> Prism' (These a b) a
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism a -> These a b
forall a b. a -> These a b
This ((a -> Either (These a b) a)
-> (b -> Either (These a b) a)
-> (a -> b -> Either (These a b) a)
-> These a b
-> Either (These a b) a
forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these a -> Either (These a b) a
forall a b. b -> Either a b
Right (These a b -> Either (These a b) a
forall a b. a -> Either a b
Left (These a b -> Either (These a b) a)
-> (b -> These a b) -> b -> Either (These a b) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> These a b
forall a b. b -> These a b
That) (\a
x b
y -> These a b -> Either (These a b) a
forall a b. a -> Either a b
Left (These a b -> Either (These a b) a)
-> These a b -> Either (These a b) a
forall a b. (a -> b) -> a -> b
$ a -> b -> These a b
forall a b. a -> b -> These a b
These a
x b
y))

-- | A 'Prism'' selecting the 'That' constructor.
--
-- /Note:/ cannot change type.
_That :: Prism' (These a b) b
_That :: Prism' (These a b) b
_That = (b -> These a b)
-> (These a b -> Either (These a b) b) -> Prism' (These a b) b
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> These a b
forall a b. b -> These a b
That ((a -> Either (These a b) b)
-> (b -> Either (These a b) b)
-> (a -> b -> Either (These a b) b)
-> These a b
-> Either (These a b) b
forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these (These a b -> Either (These a b) b
forall a b. a -> Either a b
Left (These a b -> Either (These a b) b)
-> (a -> These a b) -> a -> Either (These a b) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> These a b
forall a b. a -> These a b
This) b -> Either (These a b) b
forall a b. b -> Either a b
Right (\a
x b
y -> These a b -> Either (These a b) b
forall a b. a -> Either a b
Left (These a b -> Either (These a b) b)
-> These a b -> Either (These a b) b
forall a b. (a -> b) -> a -> b
$ a -> b -> These a b
forall a b. a -> b -> These a b
These a
x b
y))

-- | A 'Prism'' selecting the 'These' constructor. 'These' names are ridiculous!
--
-- /Note:/ cannot change type.
_These :: Prism' (These a b) (a, b)
_These :: Prism' (These a b) (a, b)
_These = ((a, b) -> These a b)
-> (These a b -> Either (These a b) (a, b))
-> Prism' (These a b) (a, b)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism ((a -> b -> These a b) -> (a, b) -> These a b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> b -> These a b
forall a b. a -> b -> These a b
These) ((a -> Either (These a b) (a, b))
-> (b -> Either (These a b) (a, b))
-> (a -> b -> Either (These a b) (a, b))
-> These a b
-> Either (These a b) (a, b)
forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these (These a b -> Either (These a b) (a, b)
forall a b. a -> Either a b
Left (These a b -> Either (These a b) (a, b))
-> (a -> These a b) -> a -> Either (These a b) (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> These a b
forall a b. a -> These a b
This) (These a b -> Either (These a b) (a, b)
forall a b. a -> Either a b
Left (These a b -> Either (These a b) (a, b))
-> (b -> These a b) -> b -> Either (These a b) (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> These a b
forall a b. b -> These a b
That) (\a
x b
y -> (a, b) -> Either (These a b) (a, b)
forall a b. b -> Either a b
Right (a
x, b
y)))

-------------------------------------------------------------------------------
-- Orphans
-------------------------------------------------------------------------------

instance Swapped These where
    swapped :: Iso (These a b) (These c d) (These b a) (These d c)
swapped = (These a b -> These b a)
-> (These d c -> These c d)
-> Iso (These a b) (These c d) (These b a) (These d c)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso These a b -> These b a
forall a b. These a b -> These b a
swapThese These d c -> These c d
forall a b. These a b -> These b a
swapThese

-- | @since 1.0.1
instance (a ~ a', b ~ b') => Each (Either () ()) (These a a') (These b b') a b where
    each :: IxTraversal (Either () ()) (These a a') (These b b') a b
each = IxTraversalVL (Either () ()) (These a a') (These b b') a b
-> IxTraversal (Either () ()) (These a a') (These b b') a b
forall i s t a b. IxTraversalVL i s t a b -> IxTraversal i s t a b
itraversalVL IxTraversalVL (Either () ()) (These a a') (These b b') a b
forall (f :: * -> *) t a.
Applicative f =>
(Either () () -> t -> f a) -> These t t -> f (These a a)
aux where
        aux :: (Either () () -> t -> f a) -> These t t -> f (These a a)
aux Either () () -> t -> f a
f (This t
a)    = a -> These a a
forall a b. a -> These a b
This (a -> These a a) -> f a -> f (These a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either () () -> t -> f a
f (() -> Either () ()
forall a b. a -> Either a b
Left ()) t
a
        aux Either () () -> t -> f a
f (That t
b)    = a -> These a a
forall a b. b -> These a b
That (a -> These a a) -> f a -> f (These a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either () () -> t -> f a
f (() -> Either () ()
forall a b. b -> Either a b
Right ()) t
b
        aux Either () () -> t -> f a
f (These t
a t
b) = a -> a -> These a a
forall a b. a -> b -> These a b
These (a -> a -> These a a) -> f a -> f (a -> These a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either () () -> t -> f a
f (() -> Either () ()
forall a b. a -> Either a b
Left ()) t
a f (a -> These a a) -> f a -> f (These a a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either () () -> t -> f a
f (() -> Either () ()
forall a b. b -> Either a b
Right ()) t
b