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

{-# LANGUAGE TypeFamilies, CPP #-}

#if MIN_VERSION_GLASGOW_HASKELL(9,8,1,0)
{-# LANGUAGE TypeAbstractions #-}
#endif

{- |

Description : Higher-kinded t'Data.Hetero.ID.ID's
Copyright   : (c) L. S. Leary, 2025

Higher-kinded t'ID's with 'HetEq' & 'HetOrd'.

-}

-- }}}

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

module Data.Hetero.ID (

  -- * ID
  ID, newID,

) where

-- base
import Unsafe.Coerce (unsafeCoerce)
import Data.Coerce (coerce)
import Data.Unique (Unique, newUnique)

-- deepseq
import Control.DeepSeq (NFData)

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

-- heterogeneous-comparison
import Data.Hetero.Role (RoleKind(Representational))
import Data.Hetero.Evidence.Exactly (Exactly(ReprEx))
import Data.Hetero.Evidence.AtLeast (AtLeast(AtLeast))
import Data.Hetero.Eq (HetEq(..))
import Data.Hetero.Ord (HetOrdering(..), HetOrd(..), defaultHEq)

-- }}}

-- --< ID >-- {{{

-- | Higher-kinded t'ID's with 'HetEq' & 'HetOrd'.
type role ID representational
newtype   ID a where
  ID :: forall {k} (a :: k). Unique -> ID a
  deriving (ID a -> ID a -> Bool
(ID a -> ID a -> Bool) -> (ID a -> ID a -> Bool) -> Eq (ID a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (a :: k). ID a -> ID a -> Bool
$c== :: forall k (a :: k). ID a -> ID a -> Bool
== :: ID a -> ID a -> Bool
$c/= :: forall k (a :: k). ID a -> ID a -> Bool
/= :: ID a -> ID a -> Bool
Eq, Eq (ID a)
Eq (ID a) =>
(ID a -> ID a -> Ordering)
-> (ID a -> ID a -> Bool)
-> (ID a -> ID a -> Bool)
-> (ID a -> ID a -> Bool)
-> (ID a -> ID a -> Bool)
-> (ID a -> ID a -> ID a)
-> (ID a -> ID a -> ID a)
-> Ord (ID a)
ID a -> ID a -> Bool
ID a -> ID a -> Ordering
ID a -> ID a -> ID a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall k (a :: k). Eq (ID a)
forall k (a :: k). ID a -> ID a -> Bool
forall k (a :: k). ID a -> ID a -> Ordering
forall k (a :: k). ID a -> ID a -> ID a
$ccompare :: forall k (a :: k). ID a -> ID a -> Ordering
compare :: ID a -> ID a -> Ordering
$c< :: forall k (a :: k). ID a -> ID a -> Bool
< :: ID a -> ID a -> Bool
$c<= :: forall k (a :: k). ID a -> ID a -> Bool
<= :: ID a -> ID a -> Bool
$c> :: forall k (a :: k). ID a -> ID a -> Bool
> :: ID a -> ID a -> Bool
$c>= :: forall k (a :: k). ID a -> ID a -> Bool
>= :: ID a -> ID a -> Bool
$cmax :: forall k (a :: k). ID a -> ID a -> ID a
max :: ID a -> ID a -> ID a
$cmin :: forall k (a :: k). ID a -> ID a -> ID a
min :: ID a -> ID a -> ID a
Ord, ID a -> ()
(ID a -> ()) -> NFData (ID a)
forall a. (a -> ()) -> NFData a
forall k (a :: k). ID a -> ()
$crnf :: forall k (a :: k). ID a -> ()
rnf :: ID a -> ()
NFData, Eq (ID a)
Eq (ID a) =>
(Int -> ID a -> Int) -> (ID a -> Int) -> Hashable (ID a)
Int -> ID a -> Int
ID a -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall k (a :: k). Eq (ID a)
forall k (a :: k). Int -> ID a -> Int
forall k (a :: k). ID a -> Int
$chashWithSalt :: forall k (a :: k). Int -> ID a -> Int
hashWithSalt :: Int -> ID a -> Int
$chash :: forall k (a :: k). ID a -> Int
hash :: ID a -> Int
Hashable)

instance HetEq ID where
  type Strength ID = Representational
  heq :: forall (a :: k) (b :: k).
ID a -> ID b -> Maybe (AtLeast (Strength ID) a b)
heq = ID a -> ID b -> Maybe (AtLeast (Strength ID) a b)
forall {k} (f :: k -> *) (a :: k) (b :: k).
HetOrd f =>
f a -> f b -> Maybe (AtLeast (Strength f) a b)
defaultHEq

instance HetOrd ID where
  ID @a Unique
u1 hcompare :: forall (a :: k) (b :: k).
ID a -> ID b -> HetOrdering (Strength ID) a b
`hcompare` ID @b Unique
u2 = case Unique
u1 Unique -> Unique -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Unique
u2 of
    Ordering
LT -> HetOrdering Representational a b
HetOrdering (Strength ID) a b
forall {k} (r :: RoleKind) (a :: k) (b :: k). HetOrdering r a b
HLT
    Ordering
EQ -> AtLeast Representational a b -> HetOrdering Representational a b
forall {k} (r :: RoleKind) (a :: k) (b :: k).
AtLeast r a b -> HetOrdering r a b
HEQ (Exactly Representational a b -> AtLeast Representational a b
forall {k} (r :: RoleKind) (a :: k) (b :: k) (s :: RoleKind).
(r <= s) =>
Exactly s a b -> AtLeast r a b
AtLeast Exactly Representational a b
magic)
    Ordering
GT -> HetOrdering Representational a b
HetOrdering (Strength ID) a b
forall {k} (r :: RoleKind) (a :: k) (b :: k). HetOrdering r a b
HGT
   where
    magic :: Exactly Representational a b
    magic :: Exactly Representational a b
magic = Exactly Representational a a -> Exactly Representational a b
forall a b. a -> b
unsafeCoerce (forall (a :: k) (b :: k).
Coercible a b =>
Exactly Representational a b
forall {k} (a :: k) (b :: k).
Coercible a b =>
Exactly Representational a b
ReprEx @a @a)

instance Show (ID a) where
  showsPrec :: Int -> ID a -> ShowS
showsPrec Int
_ ID a
i = String -> ShowS
showString String
"<ID:" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 (ID a -> Int
forall a. Hashable a => a -> Int
hash ID a
i) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'>'

-- | Create a new @t'ID' a@.
newID :: IO (ID a)
newID :: forall {k} (a :: k). IO (ID a)
newID = IO Unique -> IO (ID a)
forall a b. Coercible a b => a -> b
coerce IO Unique
newUnique

-- }}}