HasOne.hs

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall -Werror #-}

module Control.One.HasOne where

import Control.Applicative (Const (..))
import Control.Lens (Lens', lens, view)
import Control.One.GetterOne (GetterOne (GetterOneItem, getOne))
import Data.Functor.Identity (Identity (..))
import Data.List.NonEmpty (NonEmpty (..))
import Data.Ord (Down (..))
import Data.Semigroup (Dual (..), First (..), Last (..), Max (..), Min (..), Product (..), Sum (..), WrappedMonoid (..))
import Data.Tuple (Solo (..))
import GHC.Generics (Par1 (..))

-- $setup
-- >>> import Control.Lens (set)

class (GetterOne x) => HasOne x where
  type OneItem x

  setOne :: x -> OneItem x -> x

  one :: Lens' x (OneItem x)
  default one :: (GetterOneItem x ~ OneItem x) => Lens' x (OneItem x)
  one = lens (view getOne) setOne

-- | >>> view one (1 :| [2, 3])
-- 1
--
-- >>> set one 9 (1 :| [2, 3])
-- 9 :| [2,3]
instance HasOne (NonEmpty a) where
  type OneItem (NonEmpty a) = a

  setOne (_ :| xs) a = a :| xs

-- | >>> view one ("hello", 42 :: Int)
-- 42
--
-- >>> set one 9 ("hello", 42 :: Int)
-- ("hello",9)
instance HasOne (x, a) where
  type OneItem (x, a) = a

  setOne (x, _) a = (x, a)

-- | >>> view one (Identity 7)
-- 7
--
-- >>> set one 9 (Identity 7)
-- Identity 9
instance HasOne (Identity a) where
  type OneItem (Identity a) = a

  setOne _ = Identity

-- | >>> view one (Const 7 :: Const Int String)
-- 7
--
-- >>> set one 9 (Const 7 :: Const Int String)
-- Const 9
instance HasOne (Const a b) where
  type OneItem (Const a b) = a

  setOne _ = Const

-- | >>> view one (First 7)
-- 7
--
-- >>> set one 9 (First 7)
-- First {getFirst = 9}
instance HasOne (First a) where
  type OneItem (First a) = a

  setOne _ = First

-- | >>> view one (Last 7)
-- 7
--
-- >>> set one 9 (Last 7)
-- Last {getLast = 9}
instance HasOne (Last a) where
  type OneItem (Last a) = a

  setOne _ = Last

-- | >>> view one (WrapMonoid "hello")
-- "hello"
--
-- >>> set one "world" (WrapMonoid "hello")
-- WrapMonoid {unwrapMonoid = "world"}
instance HasOne (WrappedMonoid a) where
  type OneItem (WrappedMonoid a) = a

  setOne _ = WrapMonoid

-- | >>> view one (Dual 7)
-- 7
--
-- >>> set one 9 (Dual 7)
-- Dual {getDual = 9}
instance HasOne (Dual a) where
  type OneItem (Dual a) = a

  setOne _ = Dual

-- | >>> view one (Down 7)
-- 7
--
-- >>> set one 9 (Down 7)
-- Down 9
instance HasOne (Down a) where
  type OneItem (Down a) = a

  setOne _ = Down

-- | >>> view one (Sum 7)
-- 7
--
-- >>> set one 9 (Sum 7)
-- Sum {getSum = 9}
instance HasOne (Sum a) where
  type OneItem (Sum a) = a

  setOne _ = Sum

-- | >>> view one (Product 7)
-- 7
--
-- >>> set one 9 (Product 7)
-- Product {getProduct = 9}
instance HasOne (Product a) where
  type OneItem (Product a) = a

  setOne _ = Product

-- | >>> view one (Min 7)
-- 7
--
-- >>> set one 9 (Min 7)
-- Min {getMin = 9}
instance HasOne (Min a) where
  type OneItem (Min a) = a

  setOne _ = Min

-- | >>> view one (Max 7)
-- 7
--
-- >>> set one 9 (Max 7)
-- Max {getMax = 9}
instance HasOne (Max a) where
  type OneItem (Max a) = a

  setOne _ = Max

-- | >>> view one (Par1 7)
-- 7
--
-- >>> set one 9 (Par1 7)
-- Par1 {unPar1 = 9}
instance HasOne (Par1 a) where
  type OneItem (Par1 a) = a

  setOne _ = Par1

-- | >>> view one (MkSolo 7)
-- 7
--
-- >>> set one 9 (MkSolo 7)
-- MkSolo 9
instance HasOne (Solo a) where
  type OneItem (Solo a) = a

  setOne _ = MkSolo