{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module       : Data.Can.Optics
-- Copyright 	: (c) 2020-2022 Emily Pillmore
-- License	: BSD-style
--
-- Maintainer	: Emily Pillmore <emilypi@cohomolo.gy>
-- Stability	: Experimental
-- Portability	: FlexibleInstances, MPTC, Type Families, UndecideableInstances
--
-- 'Prism's and 'Traversal's for the 'Can' datatype.
--
module Data.Can.Optics
( -- * Isos
  _CanIso
  -- * Prisms
, _Non
, _One
, _Eno
, _Two
  -- * Traversals
, oneing
, enoing
, twoed
, twoing
) where


import Data.Can

import Optics.AffineTraversal
import Optics.Each.Core
import Optics.Iso
import Optics.IxTraversal
import Optics.Prism
import Optics.Traversal


-- ------------------------------------------------------------------- --
-- Isos

-- | A 'Control.Lens.Iso' between a wedge coproduct and pointed coproduct.
--
_CanIso :: Iso (Can a b) (Can c d) (Maybe a, Maybe b) (Maybe c, Maybe d)
_CanIso :: Iso (Can a b) (Can c d) (Maybe a, Maybe b) (Maybe c, Maybe d)
_CanIso = (Can a b -> (Maybe a, Maybe b))
-> ((Maybe c, Maybe d) -> Can c d)
-> Iso (Can a b) (Can c d) (Maybe a, Maybe b) (Maybe c, Maybe d)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Can a b -> (Maybe a, Maybe b)
forall a b. Can a b -> (Maybe a, Maybe b)
f (Maybe c, Maybe d) -> Can c d
forall a b. (Maybe a, Maybe b) -> Can a b
g
  where
    f :: Can a b -> (Maybe a, Maybe b)
f Can a b
t = (Can a b -> Maybe a
forall a b. Can a b -> Maybe a
canFst Can a b
t, Can a b -> Maybe b
forall a b. Can a b -> Maybe b
canSnd Can a b
t)

    g :: (Maybe a, Maybe b) -> Can a b
g (Maybe a
Nothing, Maybe b
Nothing) = Can a b
forall a b. Can a b
Non
    g (Just a
a, Maybe b
Nothing) = a -> Can a b
forall a b. a -> Can a b
One a
a
    g (Maybe a
Nothing, Just b
b) = b -> Can a b
forall a b. b -> Can a b
Eno b
b
    g (Just a
a, Just b
b) = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b

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

-- | An 'AffineTraversal' of the first parameter, suitable for use
-- with "Optics".
--
oneing :: AffineTraversal (Can a c) (Can b c) a b
oneing :: AffineTraversal (Can a c) (Can b c) a b
oneing = AffineTraversalVL (Can a c) (Can b c) a b
-> AffineTraversal (Can a c) (Can b c) a b
forall s t a b.
AffineTraversalVL s t a b -> AffineTraversal s t a b
atraversalVL (AffineTraversalVL (Can a c) (Can b c) a b
 -> AffineTraversal (Can a c) (Can b c) a b)
-> AffineTraversalVL (Can a c) (Can b c) a b
-> AffineTraversal (Can a c) (Can b c) a b
forall a b. (a -> b) -> a -> b
$ \forall r. r -> f r
point a -> f b
f -> \case
  Can a c
Non -> Can b c -> f (Can b c)
forall r. r -> f r
point Can b c
forall a b. Can a b
Non
  One a -> b -> Can b c
forall a b. a -> Can a b
One (b -> Can b c) -> f b -> f (Can b c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
  Eno c -> Can b c -> f (Can b c)
forall r. r -> f r
point (c -> Can b c
forall a b. b -> Can a b
Eno c
c)
  Two a c -> (b -> c -> Can b c) -> c -> b -> Can b c
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> c -> Can b c
forall a b. a -> b -> Can a b
Two c
c (b -> Can b c) -> f b -> f (Can b c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a

-- | An 'AffineTraversal' of the second parameter, suitable for use
-- with "Optics".
--
enoing :: AffineTraversal (Can a b) (Can a c) b c
enoing :: AffineTraversal (Can a b) (Can a c) b c
enoing = AffineTraversalVL (Can a b) (Can a c) b c
-> AffineTraversal (Can a b) (Can a c) b c
forall s t a b.
AffineTraversalVL s t a b -> AffineTraversal s t a b
atraversalVL (AffineTraversalVL (Can a b) (Can a c) b c
 -> AffineTraversal (Can a b) (Can a c) b c)
-> AffineTraversalVL (Can a b) (Can a c) b c
-> AffineTraversal (Can a b) (Can a c) b c
forall a b. (a -> b) -> a -> b
$ \forall r. r -> f r
point b -> f c
f -> \case
  Can a b
Non -> Can a c -> f (Can a c)
forall r. r -> f r
point Can a c
forall a b. Can a b
Non
  One a -> Can a c -> f (Can a c)
forall r. r -> f r
point (a -> Can a c
forall a b. a -> Can a b
One a
a)
  Eno b -> c -> Can a c
forall a b. b -> Can a b
Eno (c -> Can a c) -> f c -> f (Can a c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f c
f b
b
  Two a b -> a -> c -> Can a c
forall a b. a -> b -> Can a b
Two a
a (c -> Can a c) -> f c -> f (Can a c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f c
f b
b

-- | An 'AffineTraversal' of the pair, suitable for use
-- with "Optics".
--
-- /Note:/ cannot change type.
--
twoed :: AffineTraversal' (Can a b) (a,b)
twoed :: AffineTraversal' (Can a b) (a, b)
twoed = AffineTraversalVL (Can a b) (Can a b) (a, b) (a, b)
-> AffineTraversal' (Can a b) (a, b)
forall s t a b.
AffineTraversalVL s t a b -> AffineTraversal s t a b
atraversalVL (AffineTraversalVL (Can a b) (Can a b) (a, b) (a, b)
 -> AffineTraversal' (Can a b) (a, b))
-> AffineTraversalVL (Can a b) (Can a b) (a, b) (a, b)
-> AffineTraversal' (Can a b) (a, b)
forall a b. (a -> b) -> a -> b
$ \forall r. r -> f r
point (a, b) -> f (a, b)
f -> \case
  Can a b
Non -> Can a b -> f (Can a b)
forall r. r -> f r
point Can a b
forall a b. Can a b
Non
  One a -> Can a b -> f (Can a b)
forall r. r -> f r
point (a -> Can a b
forall a b. a -> Can a b
One a
a)
  Eno b -> Can a b -> f (Can a b)
forall r. r -> f r
point (b -> Can a b
forall a b. b -> Can a b
Eno b
b)
  Two a b -> (a -> b -> Can a b) -> (a, b) -> Can a b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> b -> Can a b
forall a b. a -> b -> Can a b
Two ((a, b) -> Can a b) -> f (a, b) -> f (Can a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a, b) -> f (a, b)
f (a
a,b
b)

-- | A 'Traversal' of the pair ala 'both', suitable for use
-- with "Optics".
--
twoing :: Traversal (Can a a) (Can b b) a b
twoing :: Traversal (Can a a) (Can b b) a b
twoing = TraversalVL (Can a a) (Can b b) a b
-> Traversal (Can a a) (Can b b) a b
forall s t a b. TraversalVL s t a b -> Traversal s t a b
traversalVL (TraversalVL (Can a a) (Can b b) a b
 -> Traversal (Can a a) (Can b b) a b)
-> TraversalVL (Can a a) (Can b b) a b
-> Traversal (Can a a) (Can b b) a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f -> \case
  Can a a
Non -> Can b b -> f (Can b b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Can b b
forall a b. Can a b
Non
  One a -> b -> Can b b
forall a b. a -> Can a b
One (b -> Can b b) -> f b -> f (Can b b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
  Eno a -> b -> Can b b
forall a b. b -> Can a b
Eno (b -> Can b b) -> f b -> f (Can b b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
  Two a b -> b -> b -> Can b b
forall a b. a -> b -> Can a b
Two (b -> b -> Can b b) -> f b -> f (b -> Can b b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a f (b -> Can b b) -> f b -> f (Can b b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> f b
f a
b

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

-- | A 'Prism'' selecting the 'Non' constructor.
--
-- /Note:/ cannot change type.
--
_Non :: Prism' (Can a b) ()
_Non :: Prism' (Can a b) ()
_Non = (() -> Can a b)
-> (Can a b -> Either (Can a b) ()) -> Prism' (Can a b) ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism (Can a b -> () -> Can a b
forall a b. a -> b -> a
const Can a b
forall a b. Can a b
Non) ((Can a b -> Either (Can a b) ()) -> Prism' (Can a b) ())
-> (Can a b -> Either (Can a b) ()) -> Prism' (Can a b) ()
forall a b. (a -> b) -> a -> b
$ \case
  Can a b
Non -> () -> Either (Can a b) ()
forall a b. b -> Either a b
Right ()
  One a
a -> Can a b -> Either (Can a b) ()
forall a b. a -> Either a b
Left (a -> Can a b
forall a b. a -> Can a b
One a
a)
  Eno b
b -> Can a b -> Either (Can a b) ()
forall a b. a -> Either a b
Left (b -> Can a b
forall a b. b -> Can a b
Eno b
b)
  Two a
a b
b -> Can a b -> Either (Can a b) ()
forall a b. a -> Either a b
Left (a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b)

-- | A 'Prism'' selecting the 'One' constructor.
--
-- /Note:/ cannot change type.
--
_One :: Prism' (Can a b) a
_One :: Prism' (Can a b) a
_One = (a -> Can a b)
-> (Can a b -> Either (Can a b) a) -> Prism' (Can a b) a
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism a -> Can a b
forall a b. a -> Can a b
One ((Can a b -> Either (Can a b) a) -> Prism' (Can a b) a)
-> (Can a b -> Either (Can a b) a) -> Prism' (Can a b) a
forall a b. (a -> b) -> a -> b
$ \case
  Can a b
Non -> Can a b -> Either (Can a b) a
forall a b. a -> Either a b
Left Can a b
forall a b. Can a b
Non
  One a
a -> a -> Either (Can a b) a
forall a b. b -> Either a b
Right a
a
  Eno b
b -> Can a b -> Either (Can a b) a
forall a b. a -> Either a b
Left (b -> Can a b
forall a b. b -> Can a b
Eno b
b)
  Two a
a b
b -> Can a b -> Either (Can a b) a
forall a b. a -> Either a b
Left (a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b)

-- | A 'Prism'' selecting the 'Eno' constructor.
--
-- /Note:/ cannot change type.
--
_Eno :: Prism' (Can a b) b
_Eno :: Prism' (Can a b) b
_Eno = (b -> Can a b)
-> (Can a b -> Either (Can a b) b) -> Prism' (Can a b) b
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> Can a b
forall a b. b -> Can a b
Eno ((Can a b -> Either (Can a b) b) -> Prism' (Can a b) b)
-> (Can a b -> Either (Can a b) b) -> Prism' (Can a b) b
forall a b. (a -> b) -> a -> b
$ \case
  Can a b
Non -> Can a b -> Either (Can a b) b
forall a b. a -> Either a b
Left Can a b
forall a b. Can a b
Non
  One a
a -> Can a b -> Either (Can a b) b
forall a b. a -> Either a b
Left (a -> Can a b
forall a b. a -> Can a b
One a
a)
  Eno b
b -> b -> Either (Can a b) b
forall a b. b -> Either a b
Right b
b
  Two a
a b
b -> Can a b -> Either (Can a b) b
forall a b. a -> Either a b
Left (a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b)

-- | A 'Prism'' selecting the 'Two' constructor.
--
-- /Note:/ cannot change type.
--
_Two :: Prism' (Can a b) (a,b)
_Two :: Prism' (Can a b) (a, b)
_Two = ((a, b) -> Can a b)
-> (Can a b -> Either (Can a b) (a, b)) -> Prism' (Can a b) (a, b)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism ((a -> b -> Can a b) -> (a, b) -> Can a b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> b -> Can a b
forall a b. a -> b -> Can a b
Two) ((Can a b -> Either (Can a b) (a, b)) -> Prism' (Can a b) (a, b))
-> (Can a b -> Either (Can a b) (a, b)) -> Prism' (Can a b) (a, b)
forall a b. (a -> b) -> a -> b
$ \case
  Can a b
Non -> Can a b -> Either (Can a b) (a, b)
forall a b. a -> Either a b
Left Can a b
forall a b. Can a b
Non
  One a
a -> Can a b -> Either (Can a b) (a, b)
forall a b. a -> Either a b
Left (a -> Can a b
forall a b. a -> Can a b
One a
a)
  Eno b
b -> Can a b -> Either (Can a b) (a, b)
forall a b. a -> Either a b
Left (b -> Can a b
forall a b. b -> Can a b
Eno b
b)
  Two a
a b
b -> (a, b) -> Either (Can a b) (a, b)
forall a b. b -> Either a b
Right (a
a,b
b)

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

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

instance (a ~ a', b ~ b') => Each Bool (Can a a') (Can b b') a b where
  each :: IxTraversal Bool (Can a a') (Can b b') a b
each = IxTraversalVL Bool (Can a a') (Can b b') a b
-> IxTraversal Bool (Can a a') (Can b b') a b
forall i s t a b. IxTraversalVL i s t a b -> IxTraversal i s t a b
itraversalVL (IxTraversalVL Bool (Can a a') (Can b b') a b
 -> IxTraversal Bool (Can a a') (Can b b') a b)
-> IxTraversalVL Bool (Can a a') (Can b b') a b
-> IxTraversal Bool (Can a a') (Can b b') a b
forall a b. (a -> b) -> a -> b
$ \Bool -> a -> f b
f -> \case
    Can a a'
Non -> Can b' b' -> f (Can b' b')
forall (f :: * -> *) a. Applicative f => a -> f a
pure Can b' b'
forall a b. Can a b
Non
    One a -> b -> Can b b'
forall a b. a -> Can a b
One (b -> Can b b') -> f b -> f (Can b b')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> a -> f b
f Bool
True a
a
    Eno a -> b -> Can b' b
forall a b. b -> Can a b
Eno (b -> Can b' b) -> f b -> f (Can b' b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> a -> f b
f Bool
False a
a
    Two a b -> b -> b -> Can b b
forall a b. a -> b -> Can a b
Two (b -> b -> Can b b) -> f b -> f (b -> Can b b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> a -> f b
f Bool
True a
a f (b -> Can b b) -> f b -> f (Can b b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> a -> f b
f Bool
False a
b