Snowflake.hs

-- | The snowflake type
module Calamity.Types.Snowflake (
  Snowflake (..),
  HasID (..),
  type HasID',
  HasIDField (..),
  HasIDFieldCoerce (..),
  type HasIDFieldCoerce',
  coerceSnowflake,
) where

import Data.Aeson
import Data.Bits
import Data.Data
import Data.Hashable
import Data.Kind
import Data.Text.Read
import qualified Data.Vector.Unboxing as U
import Data.Word
import GHC.Records (HasField (getField))
import TextShow
import Web.HttpApiData (ToHttpApiData)

-- Thanks sbrg
-- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs#L78
newtype Snowflake (t :: Type) = Snowflake
  { fromSnowflake :: Word64
  }
  deriving (Eq, Ord, Data)
  deriving newtype (Show, TextShow, FromJSONKey)
  deriving newtype (ToJSONKey, U.Unboxable)
  deriving newtype (ToHttpApiData)

-- I'm pretty sure that Word64's hash just being 'fromIntegral' is a bad idea when
-- attempting to use it in a hashmap, so swizzle the bits a bit to give a good
-- distribution of bits
instance Hashable (Snowflake t) where
  hashWithSalt salt (Snowflake a) =
    let initial = fromIntegral @_ @Word64 $ hashWithSalt salt a
        round1 = (initial `shiftR` 30 `xor` initial) * 0xbf58476d1ce4e5b9
        round2 = (round1 `shiftR` 27 `xor` round1) * 0xbf58476d1ce4e5b9
        round3 = (round2 `shiftR` 31 `xor` round2)
     in fromIntegral @_ @Int round3

instance ToJSON (Snowflake t) where
  toJSON (Snowflake s) = String . showt $ s

instance FromJSON (Snowflake t) where
  parseJSON = withText "Snowflake" $ \t -> do
    n <- case decimal t of
      Right (n, _) -> pure n
      Left e -> fail e
    pure $ Snowflake n

coerceSnowflake :: Snowflake a -> Snowflake b
coerceSnowflake (Snowflake t) = Snowflake t

-- | A typeclass for types that contain snowflakes of type `b`
class HasID b a where
  -- | Retrieve the ID from the type
  getID :: a -> Snowflake b

type HasID' a = HasID a a

-- | A newtype wrapper for deriving HasID generically
newtype HasIDField field a = HasIDField a

instance (HasID b c, HasField field a c) => HasID b (HasIDField field a) where
  getID (HasIDField a) = getID @b @c $ getField @field a

{- | A data `a` which contains an ID of type `Snowflake c`
   which should be swapped with `Snowflake b` upon fetching
-}
newtype HasIDFieldCoerce field a c = HasIDFieldCoerce a

type HasIDFieldCoerce' field a = HasIDFieldCoerce field a a

instance (HasID c d, HasField field a d) => HasID b (HasIDFieldCoerce field a c) where
  getID (HasIDFieldCoerce a) = coerceSnowflake . getID @c $ getField @field a

instance HasID a (Snowflake a) where
  getID = id