Injection1.hs

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

-- | The first injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field1'.
module Data.Lens.Injection.Injection1 (
  Injection1 (..),
) where

import Control.Lens (Prism, iso, prism)
import Data.Functor.Identity (Identity (..))
import Data.Functor.Sum (Sum (..))
import Data.Lens.Injection.Generic (GInjection, injection)
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.Identity(Identity(..))
>>> import Data.Functor.Sum(Sum(..))
>>> import GHC.Generics((:+:)(..))
-}

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

Where 'Control.Lens._1' is the first projection out of a product, '_I1' is the first
injection into a sum.

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

>>> data T = C1 Int | C2 deriving (Show, Generic)
>>> instance Injection1 T T Int Int
>>> C1 1 ^? _I1
Just 1

>>> C2 ^? _I1
Nothing

>>> _I1 # 1 :: T
C1 1
-}
class Injection1 s t a b | s -> a, t -> b, s b -> t, t a -> s where
  _I1 :: Prism s t a b
  default _I1 :: (Generic s, Generic t, GInjection 0 (Rep s) (Rep t) a b) => Prism s t a b
  _I1 =
    injection (Proxy :: Proxy 0)
  {-# INLINE _I1 #-}

{- |
>>> (Left 1 :: Either Int String) ^? _I1
Just 1

>>> (Right "x" :: Either Int String) ^? _I1
Nothing

>>> _I1 # 1 :: Either Int String
Left 1

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

{- |
>>> (Nothing :: Maybe Int) ^? _I1
Just ()

>>> Just 1 ^? _I1
Nothing

>>> _I1 # () :: Maybe Int
Nothing
-}
instance Injection1 (Maybe a) (Maybe a) () () where
  _I1 =
    prism (const Nothing) $ \case
      Nothing -> Right ()
      Just a -> Left (Just a)
  {-# INLINE _I1 #-}

{- |
>>> False ^? _I1
Just ()

>>> True ^? _I1
Nothing

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

{- |
>>> LT ^? _I1
Just ()

>>> EQ ^? _I1
Nothing

>>> GT ^? _I1
Nothing

>>> _I1 # () :: Ordering
LT
-}
instance Injection1 Ordering Ordering () () where
  _I1 =
    prism (const LT) $ \case
      LT -> Right ()
      o -> Left o
  {-# INLINE _I1 #-}

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

>>> ([] :: [Int]) ^? _I1
Just ()

>>> [1, 2, 3] ^? _I1
Nothing

>>> _I1 # () :: [Int]
[]
-}
instance Injection1 [a] [a] () () where
  _I1 =
    prism (const []) $ \case
      [] -> Right ()
      h : t -> Left (h : t)
  {-# INLINE _I1 #-}

{- | A sum of one constructor, so '_I1' always matches.

>>> Identity 1 ^? _I1
Just 1

>>> _I1 # 1 :: Identity Int
Identity 1

>>> over _I1 show (Identity 1)
Identity "1"
-}
instance Injection1 (Identity a) (Identity b) a b where
  _I1 =
    iso runIdentity Identity
  {-# INLINE _I1 #-}

{- | A sum of one nullary constructor, so '_I1' always matches.

>>> () ^? _I1
Just ()

>>> _I1 # () :: ()
()
-}
instance Injection1 () () () () where
  _I1 =
    iso (const ()) (const ())
  {-# INLINE _I1 #-}

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

>>> (InR [1] :: Sum Maybe [] Int) ^? _I1
Nothing

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

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

>>> (R1 [1] :: (Maybe :+: []) Int) ^? _I1
Nothing

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