Injection2.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall #-}

-- | The second injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field2'.
module Data.Lens.Injection.Injection2 (
  Injection2 (..),
) where

import Control.Lens (Prism, prism)
import Data.Functor.Sum (Sum (..))
import Data.Lens.Injection.Generic (GInjection, injection)
import Data.List.NonEmpty (NonEmpty (..), toList)
import Data.Proxy (Proxy (..))
import GHC.Generics (Generic, Rep, (:+:) (..))

{- $setup
>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances
>>> import GHC.Generics(Generic)
>>> import Control.Lens((^?), (#), over)
>>> import Data.Functor.Sum(Sum(..))
>>> import Data.List.NonEmpty(NonEmpty(..))
>>> import GHC.Generics((:+:)(..))
-}

{- | Access the second constructor of a sum type.

Where 'Control.Lens._2' is the second projection out of a product, '_I2' is the second
injection into a sum.

The default implementation is the prism to the second constructor of a
'Generic' type, @'injection' (Proxy :: Proxy 1)@.

>>> data T = C1 | C2 Int | C3 deriving (Show, Generic)
>>> instance Injection2 T T Int Int
>>> C2 1 ^? _I2
Just 1

>>> C3 ^? _I2
Nothing

>>> _I2 # 1 :: T
C2 1
-}
class Injection2 s t a b | s -> a, t -> b, s b -> t, t a -> s where
  _I2 :: Prism s t a b
  default _I2 :: (Generic s, Generic t, GInjection 1 (Rep s) (Rep t) a b) => Prism s t a b
  _I2 =
    injection (Proxy :: Proxy 1)
  {-# INLINE _I2 #-}

{- |
>>> (Right "x" :: Either Int String) ^? _I2
Just "x"

>>> (Left 1 :: Either Int String) ^? _I2
Nothing

>>> _I2 # "x" :: Either Int String
Right "x"

>>> over _I2 show (Right True :: Either Int Bool)
Right "True"
-}
instance Injection2 (Either c a) (Either c b) a b where
  _I2 =
    prism Right $ \case
      Left c -> Left (Left c)
      Right a -> Right a
  {-# INLINE _I2 #-}

{- |
>>> Just 1 ^? _I2
Just 1

>>> (Nothing :: Maybe Int) ^? _I2
Nothing

>>> _I2 # 1 :: Maybe Int
Just 1

>>> over _I2 show (Just 1)
Just "1"
-}
instance Injection2 (Maybe a) (Maybe b) a b where
  _I2 =
    prism Just $ \case
      Nothing -> Left Nothing
      Just a -> Right a
  {-# INLINE _I2 #-}

{- |
>>> True ^? _I2
Just ()

>>> False ^? _I2
Nothing

>>> _I2 # () :: Bool
True
-}
instance Injection2 Bool Bool () () where
  _I2 =
    prism (const True) $ \case
      False -> Left False
      True -> Right ()
  {-# INLINE _I2 #-}

{- |
>>> EQ ^? _I2
Just ()

>>> LT ^? _I2
Nothing

>>> GT ^? _I2
Nothing

>>> _I2 # () :: Ordering
EQ
-}
instance Injection2 Ordering Ordering () () where
  _I2 =
    prism (const EQ) $ \case
      EQ -> Right ()
      o -> Left o
  {-# INLINE _I2 #-}

{- | A list is the sum of the empty list and a non-empty list.

>>> [1, 2, 3] ^? _I2
Just (1 :| [2,3])

>>> ([] :: [Int]) ^? _I2
Nothing

>>> _I2 # (1 :| [2, 3]) :: [Int]
[1,2,3]

>>> over _I2 (fmap show) [1, 2, 3]
["1","2","3"]
-}
instance Injection2 [a] [b] (NonEmpty a) (NonEmpty b) where
  _I2 =
    prism toList $ \case
      [] -> Left []
      h : t -> Right (h :| t)
  {-# INLINE _I2 #-}

{- |
>>> (InR [1] :: Sum Maybe [] Int) ^? _I2
Just [1]

>>> (InL (Just 1) :: Sum Maybe [] Int) ^? _I2
Nothing

>>> _I2 # [1] :: Sum Maybe [] Int
InR [1]
-}
instance Injection2 (Sum f g a) (Sum f g' a) (g a) (g' a) where
  _I2 =
    prism InR $ \case
      InL x -> Left (InL x)
      InR y -> Right y
  {-# INLINE _I2 #-}

{- |
>>> (R1 [1] :: (Maybe :+: []) Int) ^? _I2
Just [1]

>>> (L1 (Just 1) :: (Maybe :+: []) Int) ^? _I2
Nothing

>>> _I2 # [1] :: (Maybe :+: []) Int
R1 [1]
-}
instance Injection2 ((f :+: g) p) ((f :+: g') p) (g p) (g' p) where
  _I2 =
    prism R1 $ \case
      L1 x -> Left (L1 x)
      R1 y -> Right y
  {-# INLINE _I2 #-}