-- --< Header >-- {{{

{-# LANGUAGE PatternSynonyms, QuantifiedConstraints #-}

{- |

Description : An (almost) drop-in replacement for "Data.Some" with broader 'Eq' & 'Ord'
Copyright   : (c) L. S. Leary, 2025

An (almost) drop-in replacement for "Data.Some".

=== Differences

 * Broader 'Eq' and 'Ord' instances via 'HetEq' and 'HetOrd', which generalise @GEq@ and @GCompare@ respectively.
 * No @GShow@ or @GNFData@ classes for 'Show' and 'NFData'; it suffices to wield @QuantifiedConstraints@.
 * 'Hashable' instance using the same approach.
 * For simplicity, 'Read' is neglected.

-}

-- }}}

-- --< Exports & Imports >-- {{{

module Data.Hetero.Some (

  -- * Some
  Some(Some),
  mkSome,
  withSome,
  withSomeM,
  mapSome,
  foldSome,
  traverseSome,

) where

-- GHC/base
import GHC.Exts (Any)

-- base
import Unsafe.Coerce (unsafeCoerce)

-- deepseq
import Control.DeepSeq (NFData(..))

-- hashable
import Data.Hashable (Hashable(..))

-- heterogeneous-comparison
import Data.Hetero.Eq (HetEq(..))
import Data.Hetero.Ord (HetOrdering(..), HetOrd(..))

-- }}}

-- --< Some >-- {{{

-- | Existentials sans indirection.
newtype Some f = UnsafeSome (f Any)

{-# COMPLETE Some #-}
pattern Some :: f x -> Some f
pattern $mSome :: forall {r} {k} {f :: k -> *}.
Some f -> (forall {x :: k}. f x -> r) -> ((# #) -> r) -> r
$bSome :: forall {k} (f :: k -> *) (x :: k). f x -> Some f
Some fx <- UnsafeSome fx
  where Some f x
fx = f x -> Some f
forall {k} (f :: k -> *) (x :: k). f x -> Some f
mkSome f x
fx

instance HetEq f => Eq (Some f) where
  Some f x
fx == :: Some f -> Some f -> Bool
== Some f x
fy = case f x
fx f x -> f x -> Maybe (AtLeast (Strength f) x x)
forall (a :: k) (b :: k).
f a -> f b -> Maybe (AtLeast (Strength f) a b)
forall {k} (f :: k -> *) (a :: k) (b :: k).
HetEq f =>
f a -> f b -> Maybe (AtLeast (Strength f) a b)
`heq` f x
fy of
    Maybe (AtLeast (Strength f) x x)
Nothing -> Bool
False
    Just AtLeast (Strength f) x x
_  -> Bool
True

instance HetOrd f => Ord (Some f) where
  Some f x
fx compare :: Some f -> Some f -> Ordering
`compare` Some f x
fy = case f x
fx f x -> f x -> HetOrdering (Strength f) x x
forall (a :: k) (b :: k).
f a -> f b -> HetOrdering (Strength f) a b
forall {k} (f :: k -> *) (a :: k) (b :: k).
HetOrd f =>
f a -> f b -> HetOrdering (Strength f) a b
`hcompare` f x
fy of
    HetOrdering (Strength f) x x
HLT   -> Ordering
LT
    HEQ AtLeast (Strength f) x x
_ -> Ordering
EQ
    HetOrdering (Strength f) x x
HGT   -> Ordering
GT

instance Applicative f => Semigroup (Some f) where
  UnsafeSome f Any
fAny1 <> :: Some f -> Some f -> Some f
<> UnsafeSome f Any
fAny2 = f Any -> Some f
forall {k} (f :: k -> *). f Any -> Some f
UnsafeSome (f Any
fAny1 f Any -> f Any -> f Any
forall a b. f a -> f b -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f Any
fAny2)

instance Applicative f => Monoid (Some f) where
  mempty :: Some f
mempty = f () -> Some f
forall {k} (f :: k -> *) (x :: k). f x -> Some f
Some (() -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

instance (forall x. Show (f x)) => Show (Some f) where
  showsPrec :: Int -> Some f -> ShowS
showsPrec Int
d (Some f x
fx)
    = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11)
    (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Some " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> f x -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 f x
fx

instance (forall x. NFData (f x)) => NFData (Some f) where
  rnf :: Some f -> ()
rnf = (forall (x :: k). f x -> ()) -> Some f -> ()
forall {k} (f :: k -> *) b.
(forall (x :: k). f x -> b) -> Some f -> b
foldSome f x -> ()
forall (x :: k). f x -> ()
forall a. NFData a => a -> ()
rnf

instance (forall x. Hashable (f x), HetEq f) => Hashable (Some f) where
  hash :: Some f -> Int
hash           = (forall (x :: k). f x -> Int) -> Some f -> Int
forall {k} (f :: k -> *) b.
(forall (x :: k). f x -> b) -> Some f -> b
foldSome  f x -> Int
forall (x :: k). f x -> Int
forall a. Hashable a => a -> Int
hash
  hashWithSalt :: Int -> Some f -> Int
hashWithSalt Int
s = (forall (x :: k). f x -> Int) -> Some f -> Int
forall {k} (f :: k -> *) b.
(forall (x :: k). f x -> b) -> Some f -> b
foldSome (Int -> f x -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s)

mkSome :: f x -> Some f
mkSome :: forall {k} (f :: k -> *) (x :: k). f x -> Some f
mkSome = f Any -> Some f
forall {k} (f :: k -> *). f Any -> Some f
UnsafeSome (f Any -> Some f) -> (f x -> f Any) -> f x -> Some f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> f Any
forall a b. a -> b
unsafeCoerce

withSome :: Some f -> (forall x. f x -> r) -> r
withSome :: forall {k} (f :: k -> *) r.
Some f -> (forall (x :: k). f x -> r) -> r
withSome (UnsafeSome f Any
fAny) forall (x :: k). f x -> r
k = f Any -> r
forall (x :: k). f x -> r
k f Any
fAny

withSomeM :: Monad m => m (Some f) -> (forall x. f x -> m r) -> m r
withSomeM :: forall {k} (m :: * -> *) (f :: k -> *) r.
Monad m =>
m (Some f) -> (forall (x :: k). f x -> m r) -> m r
withSomeM m (Some f)
msf forall (x :: k). f x -> m r
k = m (Some f)
msf m (Some f) -> (Some f -> m r) -> m r
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (x :: k). f x -> m r) -> Some f -> m r
forall {k} (f :: k -> *) b.
(forall (x :: k). f x -> b) -> Some f -> b
foldSome f x -> m r
forall (x :: k). f x -> m r
k

mapSome :: (forall x. f x -> g x) -> Some f -> Some g
mapSome :: forall {k} (f :: k -> *) (g :: k -> *).
(forall (x :: k). f x -> g x) -> Some f -> Some g
mapSome forall (x :: k). f x -> g x
fg (UnsafeSome f Any
fAny) = g Any -> Some g
forall {k} (f :: k -> *). f Any -> Some f
UnsafeSome (f Any -> g Any
forall (x :: k). f x -> g x
fg f Any
fAny)

foldSome :: (forall x. f x -> b) -> Some f -> b
foldSome :: forall {k} (f :: k -> *) b.
(forall (x :: k). f x -> b) -> Some f -> b
foldSome forall (x :: k). f x -> b
alg Some f
sf = Some f -> (forall (x :: k). f x -> b) -> b
forall {k} (f :: k -> *) r.
Some f -> (forall (x :: k). f x -> r) -> r
withSome Some f
sf f x -> b
forall (x :: k). f x -> b
alg

traverseSome
  :: Applicative h
  => (forall x. f x -> h (g x)) -> Some f -> h (Some g)
traverseSome :: forall {k} (h :: * -> *) (f :: k -> *) (g :: k -> *).
Applicative h =>
(forall (x :: k). f x -> h (g x)) -> Some f -> h (Some g)
traverseSome forall (x :: k). f x -> h (g x)
fhg (UnsafeSome f Any
fAny) = g Any -> Some g
forall {k} (f :: k -> *). f Any -> Some f
UnsafeSome (g Any -> Some g) -> h (g Any) -> h (Some g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Any -> h (g Any)
forall (x :: k). f x -> h (g x)
fhg f Any
fAny

-- }}}