One.hs

{-# OPTIONS_GHC -Wall #-}

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DefaultSignatures #-}

-- A better One type-class than Relude.Container.One

import Control.Applicative
import Control.Lens
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as LazyByteString
import qualified Data.ByteString.Short as ShortByteString
import Data.List.NonEmpty( NonEmpty( (:|) ))
import Data.Map( Map )
import qualified Data.Map as Map
import Data.Hashable
import Data.HashMap.Strict( HashMap )
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet ( HashSet )
import qualified Data.HashSet as HashSet
import Data.IntMap ( IntMap )
import qualified Data.IntMap as IntMap
import Data.IntSet ( IntSet )
import qualified Data.IntSet as IntSet
import Data.Ord
import Data.Semigroup
import Data.Sequence
import qualified Data.Sequence as Sequence
import Data.Set ( Set )
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LazyText
import Data.Tuple
import Data.Word
import GHC.Generics

class One x where
  type OneItem x

  one :: Prism' x (OneItem x)

instance One [a] where
  type OneItem [a] = a

  one =
    prism'
      (:[])
      (\case
          [a] -> Just a
          _   -> Nothing)

instance One (NonEmpty a) where
  type OneItem (NonEmpty a) = a

  one =
    prism'
      (:|[])
      (\case
          a:|[] -> Just a
          _     -> Nothing)

instance One (Seq a) where
  type OneItem (Seq a) = a

  one =
    prism'
      Sequence.singleton
      (\x ->
        case x of
          a :<| Sequence.Empty -> Just a
          _           -> Nothing)

instance One Text.Text where
  type OneItem Text.Text = Char

  one =
    prism'
      Text.singleton
      (\x ->
        if Text.length x == 1 then Just (Text.head x) else Nothing)

instance One LazyText.Text where
  type OneItem LazyText.Text = Char

  one =
    prism'
      LazyText.singleton
      (\x ->
        if LazyText.length x == 1 then Just (LazyText.head x) else Nothing)

instance One ByteString.ByteString where
  type OneItem ByteString.ByteString = Word8

  one =
    prism'
      ByteString.singleton
      (\x ->
        if ByteString.length x == 1 then Just (ByteString.head x) else Nothing)

instance One LazyByteString.ByteString where
  type OneItem LazyByteString.ByteString = Word8

  one =
    prism'
      LazyByteString.singleton
      (\x ->
        if LazyByteString.length x == 1 then Just (LazyByteString.head x) else Nothing)

instance One ShortByteString.ShortByteString where
  type OneItem ShortByteString.ShortByteString = Word8

  one =
    prism'
      ShortByteString.singleton
      (\x ->
        if ShortByteString.length x == 1 then Just (ShortByteString.head x) else Nothing)

instance One (Map k v) where
  type OneItem (Map k v) = (k, v)

  one =
    prism'
      (uncurry Map.singleton)
      (\x ->
        if Map.size x == 1
          then Just (Map.findMin x)
          else Nothing)

instance Hashable k => One (HashMap k v) where
  type OneItem (HashMap k v) = (k, v)

  one =
    prism'
      (uncurry HashMap.singleton)
      (\x ->
        if HashMap.size x == 1
        then Just (head (HashMap.toList x))
        else Nothing)

instance One (IntMap v) where
  type OneItem (IntMap v) = (Int, v)

  one =
    prism'
      (uncurry IntMap.singleton)
      (\x ->
        if IntMap.size x == 1
          then Just (IntMap.findMin x)
          else Nothing)

instance One (Set a) where
  type OneItem (Set a) = a

  one =
    prism'
      (Set.singleton)
      (\x ->
        if Set.size x == 1
          then Just (Set.findMin x)
          else Nothing)

instance Hashable a => One (HashSet a) where
  type OneItem (HashSet a) = a

  one =
    prism'
      (HashSet.singleton)
      (\x ->
        if HashSet.size x == 1
        then Just (head (HashSet.toList x))
        else Nothing)

instance One IntSet where
  type OneItem IntSet = Int

  one =
    prism'
      (IntSet.singleton)
      (\x ->
        if IntSet.size x == 1
          then Just (IntSet.findMin x)
          else Nothing)

-- extras

-- | the original one function
--
-- >>> one' 7 :: [Int]
-- [7]
one' :: One x => OneItem x -> x
one' = review one

getOne' :: One x => x -> Maybe (OneItem x)
getOne' = preview one

instance (Eq a, Monoid a) => One (a, b) where
  type OneItem (a, b) = b

  one =
    prism'
      (\b -> (mempty, b))
      (\case
          (a, b) -> if a == mempty then Just b else Nothing)

instance One (Maybe a) where
  type OneItem (Maybe a) = a

  one =
    _Just
  {-# INLINE one #-}

instance One (Either a b) where
  type OneItem (Either a b) = b

  one =
    _Right
  {-# INLINE one #-}

instance One (Identity a) where
  type OneItem (Identity a) = a

  one =
    _Wrapped
  {-# INLINE one #-}

instance One (Const a b) where
  type OneItem (Const a b) = a

  one =
    _Wrapped
  {-# INLINE one #-}

instance One (First a) where
  type OneItem (First a) = a

  one =
    _Wrapped
  {-# INLINE one #-}

instance One (Last a) where
  type OneItem (Last a) = a

  one =
    _Wrapped
  {-# INLINE one #-}

instance One (WrappedMonoid a) where
  type OneItem (WrappedMonoid a) = a

  one =
    _Wrapped
  {-# INLINE one #-}

instance One (Dual a) where
  type OneItem (Dual a) = a

  one =
    _Wrapped
  {-# INLINE one #-}

instance One (Down a) where
  type OneItem (Down a) = a

  one =
    _Wrapped
  {-# INLINE one #-}

instance One (Sum a) where
  type OneItem (Sum a) = a

  one =
    _Wrapped
  {-# INLINE one #-}

instance One (Product a) where
  type OneItem (Product a) = a

  one =
    _Wrapped
  {-# INLINE one #-}

instance One (Min a) where
  type OneItem (Min a) = a

  one =
    _Wrapped
  {-# INLINE one #-}

instance One (Max a) where
  type OneItem (Max a) = a

  one =
    _Wrapped
  {-# INLINE one #-}

instance One (ZipList a) where
  type OneItem (ZipList a) = a

  one =
    _Wrapped . one
  {-# INLINE one #-}

instance One (Par1 a) where
  type OneItem (Par1 a) = a

  one =
    _Wrapped
  {-# INLINE one #-}

instance One (Solo a) where
  type OneItem (Solo a) = a

  one =
    prism'
      MkSolo
      (\(MkSolo x) -> Just x)