{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module       : Data.Smash.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 'Smash' datatype.
--
module Data.Smash.Optics
( -- * Isos
  _SmashIso
-- * Prisms
, _Nada
, _Smash
   -- * Traversals
, smashed
, smashing
) where


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

import Data.Smash



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

-- | A 'Control.Lens.Iso' between a smash product and pointed tuple.
--
_SmashIso :: Iso (Smash a b) (Smash c d) (Maybe (a,b)) (Maybe (c,d))
_SmashIso :: Iso (Smash a b) (Smash c d) (Maybe (a, b)) (Maybe (c, d))
_SmashIso = (Smash a b -> Maybe (a, b))
-> (Maybe (c, d) -> Smash c d)
-> Iso (Smash a b) (Smash c d) (Maybe (a, b)) (Maybe (c, d))
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Smash a b -> Maybe (a, b)
forall a b. Smash a b -> Maybe (a, b)
f Maybe (c, d) -> Smash c d
forall a b. Maybe (a, b) -> Smash a b
g
  where
    f :: Smash a b -> Maybe (a, b)
f Smash a b
Nada = Maybe (a, b)
forall a. Maybe a
Nothing
    f (Smash a
a b
b) = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
a,b
b)

    g :: Maybe (a, b) -> Smash a b
g Maybe (a, b)
Nothing = Smash a b
forall a b. Smash a b
Nada
    g (Just (a
a,b
b)) = a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash a
a b
b

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

-- | An 'AffineTraversal' of the smashed pair.
--
-- >>> over smashed (fmap pred) (Smash 1 2)
-- Smash 1 1
--
-- >>> over smashed id Nada
-- Nada
--
smashed :: AffineTraversal (Smash a b) (Smash c d) (a,b) (c,d)
smashed :: AffineTraversal (Smash a b) (Smash c d) (a, b) (c, d)
smashed = AffineTraversalVL (Smash a b) (Smash c d) (a, b) (c, d)
-> AffineTraversal (Smash a b) (Smash c d) (a, b) (c, d)
forall s t a b.
AffineTraversalVL s t a b -> AffineTraversal s t a b
atraversalVL (AffineTraversalVL (Smash a b) (Smash c d) (a, b) (c, d)
 -> AffineTraversal (Smash a b) (Smash c d) (a, b) (c, d))
-> AffineTraversalVL (Smash a b) (Smash c d) (a, b) (c, d)
-> AffineTraversal (Smash a b) (Smash c d) (a, b) (c, d)
forall a b. (a -> b) -> a -> b
$ \forall r. r -> f r
point (a, b) -> f (c, d)
f -> \case
  Smash a b
Nada -> Smash c d -> f (Smash c d)
forall r. r -> f r
point Smash c d
forall a b. Smash a b
Nada
  Smash a b -> (c -> d -> Smash c d) -> (c, d) -> Smash c d
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry c -> d -> Smash c d
forall a b. a -> b -> Smash a b
Smash ((c, d) -> Smash c d) -> f (c, d) -> f (Smash c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a, b) -> f (c, d)
f (a
a,b
b)

-- | An 'IxTraversal' of the smashed pair. Yes this is equivalent to 'each'.
-- It's here because it's __smashing__.
--
-- >>> over smashing show (Smash 1 2)
-- Smash "1" "2"
--
-- >>> over smashing show Nada
-- Nada
--
smashing :: IxTraversal Bool (Smash a a) (Smash b b) a b
smashing :: IxTraversal Bool (Smash a a) (Smash b b) a b
smashing = IxTraversalVL Bool (Smash a a) (Smash b b) a b
-> IxTraversal Bool (Smash a a) (Smash 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 (Smash a a) (Smash b b) a b
 -> IxTraversal Bool (Smash a a) (Smash b b) a b)
-> IxTraversalVL Bool (Smash a a) (Smash b b) a b
-> IxTraversal Bool (Smash a a) (Smash b b) a b
forall a b. (a -> b) -> a -> b
$ \Bool -> a -> f b
f -> \case
  Smash a a
Nada -> Smash b b -> f (Smash b b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Smash b b
forall a b. Smash a b
Nada
  Smash a b -> b -> b -> Smash b b
forall a b. a -> b -> Smash a b
Smash (b -> b -> Smash b b) -> f b -> f (b -> Smash 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 -> Smash b b) -> f b -> f (Smash b b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> a -> f b
f Bool
False a
b

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

-- | A 'Prism'' selecting the 'Nada' constructor.
--
-- /Note:/ cannot change type.
--
_Nada :: Prism' (Smash a b) ()
_Nada :: Prism' (Smash a b) ()
_Nada = (() -> Smash a b)
-> (Smash a b -> Either (Smash a b) ()) -> Prism' (Smash a b) ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism (Smash a b -> () -> Smash a b
forall a b. a -> b -> a
const Smash a b
forall a b. Smash a b
Nada) ((Smash a b -> Either (Smash a b) ()) -> Prism' (Smash a b) ())
-> (Smash a b -> Either (Smash a b) ()) -> Prism' (Smash a b) ()
forall a b. (a -> b) -> a -> b
$ \case
  Smash a b
Nada -> () -> Either (Smash a b) ()
forall a b. b -> Either a b
Right ()
  Smash a
a b
b -> Smash a b -> Either (Smash a b) ()
forall a b. a -> Either a b
Left (a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash a
a b
b)

-- | A 'Prism'' selecting the 'Smash' constructor.
--
-- /Note:/ cannot change type.
--
_Smash :: Prism' (Smash a b) (a,b)
_Smash :: Prism' (Smash a b) (a, b)
_Smash = ((a, b) -> Smash a b)
-> (Smash a b -> Either (Smash a b) (a, b))
-> Prism' (Smash a b) (a, b)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism ((a -> b -> Smash a b) -> (a, b) -> Smash a b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash) ((Smash a b -> Either (Smash a b) (a, b))
 -> Prism' (Smash a b) (a, b))
-> (Smash a b -> Either (Smash a b) (a, b))
-> Prism' (Smash a b) (a, b)
forall a b. (a -> b) -> a -> b
$ \case
  Smash a
a b
b -> (a, b) -> Either (Smash a b) (a, b)
forall a b. b -> Either a b
Right (a
a,b
b)
  Smash a b
Nada -> Smash a b -> Either (Smash a b) (a, b)
forall a b. a -> Either a b
Left Smash a b
forall a b. Smash a b
Nada


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

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

instance (a ~ a', b ~ b') => Each Bool (Smash a a') (Smash b b') a b where
  each :: IxTraversal Bool (Smash a a') (Smash b b') a b
each = IxTraversal Bool (Smash a a') (Smash b b') a b
forall a b. IxTraversal Bool (Smash a a) (Smash b b) a b
smashing