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


import Control.Lens

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 :: p (Maybe (a, b)) (f (Maybe (c, d)))
-> p (Smash a b) (f (Smash 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

-- | A 'Control.Lens.Traversal' of the smashed pair, suitable for use
-- with "Control.Lens".
--
-- >>> over smashed (fmap pred) (Smash 1 2)
-- Smash 1 1
--
-- >>> over smashed id Nada
-- Nada
--
smashed :: Traversal (Smash a b) (Smash c d) (a,b) (c,d)
smashed :: ((a, b) -> f (c, d)) -> Smash a b -> f (Smash c d)
smashed (a, b) -> f (c, d)
f = \case
  Smash a b
Nada -> Smash c d -> f (Smash c d)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Smash c d
forall a b. Smash a b
Nada
  Smash a
a b
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)

-- | A 'Control.Lens.Traversal' of the smashed pair, suitable for use
-- with "Control.Lens".
--
-- >>> over smashing show (Smash 1 2)
-- Smash "1" "2"
--
-- >>> over smashing show Nada
-- Nada
--
smashing :: Traversal (Smash a a) (Smash b b) a b
smashing :: (a -> f b) -> Smash a a -> f (Smash b b)
smashing = ((a, a) -> f (b, b)) -> Smash a a -> f (Smash b b)
forall a b c d. Traversal (Smash a b) (Smash c d) (a, b) (c, d)
smashed (((a, a) -> f (b, b)) -> Smash a a -> f (Smash b b))
-> ((a -> f b) -> (a, a) -> f (b, b))
-> (a -> f b)
-> Smash a a
-> f (Smash b b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> (a, a) -> f (b, b)
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both

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

-- | A 'Control.Lens.Prism'' selecting the 'Nada' constructor.
--
-- /Note:/ cannot change type.
--
_Nada :: Prism' (Smash a b) ()
_Nada :: p () (f ()) -> p (Smash a b) (f (Smash a b))
_Nada = (() -> Smash a b)
-> (Smash a b -> Either (Smash a b) ())
-> Prism (Smash a b) (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) () ())
-> (Smash a b -> Either (Smash a b) ())
-> Prism (Smash a b) (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 'Control.Lens.Prism'' selecting the 'Smash' constructor.
--
-- /Note:/ cannot change type.
--
_Smash :: Prism' (Smash a b) (a,b)
_Smash :: p (a, b) (f (a, b)) -> p (Smash a b) (f (Smash a b))
_Smash = ((a, b) -> Smash a b)
-> (Smash a b -> Either (Smash a b) (a, b))
-> Prism (Smash a b) (Smash a b) (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) (Smash a b) (a, b) (a, b))
-> (Smash a b -> Either (Smash a b) (a, b))
-> Prism (Smash a b) (Smash a b) (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

#if ! MIN_VERSION_lens(5,0,0)
instance Swapped Smash where
  swapped = iso swapSmash swapSmash
#endif

instance (a ~ a', b ~ b') => Each (Smash a a') (Smash b b') a b where
  each :: (a -> f b) -> Smash a a' -> f (Smash b b')
each a -> f b
_ 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
  each a -> f b
f (Smash a
a 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
<$> a -> f b
f 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
<*> a -> f b
f a
a'
b