{-# LANGUAGE AllowAmbiguousTypes #-}

-- |
-- Module      : Data.TypeID.Class
-- License     : MIT
-- Maintainer  : mmzk1526@outlook.com
-- Portability : GHC
--
-- A module with the APIs for any 'Data.TypeID.V7.TypeID'-ish identifier type.
--
-- These type classes are useful to define custom TypeID-ish identifier types.
-- For example, if one wishes to remove the constraints on prefix, or use a
-- different UUID version for the suffix.
--
module Data.TypeID.Class
  (
  -- * Type classes
    TypeIDLike
  , IDType(..)
  , IDConv(..)
  , IDGen(..)
  , decorate
  , genID
  , genID'
  , genIDs
  , checkID
  , checkIDWithEnv
  -- * Helper types
  , GenFunc
  , ResWithErr
  ) where

import           Control.Exception
import           Control.Monad.IO.Class
import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BSL
import           Data.Kind (Type)
import           Data.Proxy
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Text.Encoding
import           Data.TypeID.Error
import           Data.UUID.V7 (UUID)
import           Data.Word

-- | A constraint synonym for a 'Data.TypeID.V7.TypeID'-ish identifier type that
-- supports ID generation and string conversion.
type TypeIDLike a = (IDType a, IDConv a, IDGen a)

-- | A type class for a 'Data.TypeID.V7.TypeID'-ish identifier type, which has a
-- 'Text' prefix and a 'UUID' suffix.
class IDType a where
  -- | Get the prefix of the identifier.
  getPrefix :: a -> Text

  -- | Get the UUID suffix of the identifier.
  getUUID :: a -> UUID

  -- | Get the timestamp of the identifier. Returns 0 if the identifier is not
  -- timestamp-based.
  getTime :: a -> Word64

-- | A type class for converting between a 'Data.TypeID.V7.TypeID'-ish
-- identifier type and some string representations.
class IDConv a where
  -- | Parse the identifier from its 'String' representation.
  string2ID :: String -> Either TypeIDError a
  string2ID = Text -> Either TypeIDError a
forall a. IDConv a => Text -> Either TypeIDError a
text2ID (Text -> Either TypeIDError a)
-> (String -> Text) -> String -> Either TypeIDError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
  {-# INLINE string2ID #-}

  -- | Parse the identifier from its string representation as a strict 'Text'.
  text2ID :: Text -> Either TypeIDError a
  text2ID = ByteString -> Either TypeIDError a
forall a. IDConv a => ByteString -> Either TypeIDError a
byteString2ID (ByteString -> Either TypeIDError a)
-> (Text -> ByteString) -> Text -> Either TypeIDError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
  {-# INLINE text2ID #-}

  -- | Parse the identifier from its string representation as a lazy
  -- 'ByteString'.
  byteString2ID :: ByteString -> Either TypeIDError a
  byteString2ID = String -> Either TypeIDError a
forall a. IDConv a => String -> Either TypeIDError a
string2ID (String -> Either TypeIDError a)
-> (ByteString -> String) -> ByteString -> Either TypeIDError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict
  {-# INLINE byteString2ID #-}

  -- | Pretty-print the identifier to a 'String'.
  id2String :: a -> String
  id2String = Text -> String
T.unpack (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. IDConv a => a -> Text
id2Text
  {-# INLINE id2String #-}

  -- | Pretty-print the identifier to a strict 'Text'.
  id2Text :: a -> Text
  id2Text = ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. IDConv a => a -> ByteString
id2ByteString
  {-# INLINE id2Text #-}

  -- | Pretty-print the identifier to a lazy 'ByteString'.
  id2ByteString :: a -> ByteString
  id2ByteString = ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (a -> Text) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. IDConv a => a -> String
id2String
  {-# INLINE id2ByteString #-}

  -- | Parse the identifier from its 'String' representation, throwing an error
  -- when the parsing fails.
  string2IDM :: MonadIO m => String -> m a
  string2IDM = (TypeIDError -> m a) -> (a -> m a) -> Either TypeIDError a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (TypeIDError -> IO a) -> TypeIDError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeIDError -> IO a
forall e a. Exception e => e -> IO a
throwIO) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either TypeIDError a -> m a)
-> (String -> Either TypeIDError a) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either TypeIDError a
forall a. IDConv a => String -> Either TypeIDError a
string2ID
  {-# INLINE string2IDM #-}

  -- | Parse the identifier from its string representation as a strict 'Text',
  -- throwing an error when the parsing fails.
  text2IDM :: MonadIO m => Text -> m a
  text2IDM = (TypeIDError -> m a) -> (a -> m a) -> Either TypeIDError a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (TypeIDError -> IO a) -> TypeIDError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeIDError -> IO a
forall e a. Exception e => e -> IO a
throwIO) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either TypeIDError a -> m a)
-> (Text -> Either TypeIDError a) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either TypeIDError a
forall a. IDConv a => Text -> Either TypeIDError a
text2ID
  {-# INLINE text2IDM #-}

  -- | Parse the identifier from its string representation as a lazy
  -- 'ByteString', throwing an error when the parsing fails.
  byteString2IDM :: MonadIO m => ByteString -> m a
  byteString2IDM = (TypeIDError -> m a) -> (a -> m a) -> Either TypeIDError a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (TypeIDError -> IO a) -> TypeIDError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeIDError -> IO a
forall e a. Exception e => e -> IO a
throwIO) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either TypeIDError a -> m a)
-> (ByteString -> Either TypeIDError a) -> ByteString -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either TypeIDError a
forall a. IDConv a => ByteString -> Either TypeIDError a
byteString2ID
  {-# INLINE byteString2IDM #-}

  -- | Parse the identifier from its 'String' representation, but crashes when
  -- the parsing fails.
  unsafeString2ID :: String -> a
  unsafeString2ID = (TypeIDError -> a) -> (a -> a) -> Either TypeIDError a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (TypeIDError -> String) -> TypeIDError -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeIDError -> String
forall a. Show a => a -> String
show) a -> a
forall a. a -> a
id (Either TypeIDError a -> a)
-> (String -> Either TypeIDError a) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either TypeIDError a
forall a. IDConv a => String -> Either TypeIDError a
string2ID
  {-# INLINE unsafeString2ID #-}

  -- | Parse the identifier from its string representation as a strict 'Text',
  -- but crashes when the parsing fails.
  unsafeText2ID :: Text -> a
  unsafeText2ID = (TypeIDError -> a) -> (a -> a) -> Either TypeIDError a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (TypeIDError -> String) -> TypeIDError -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeIDError -> String
forall a. Show a => a -> String
show) a -> a
forall a. a -> a
id (Either TypeIDError a -> a)
-> (Text -> Either TypeIDError a) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either TypeIDError a
forall a. IDConv a => Text -> Either TypeIDError a
text2ID
  {-# INLINE unsafeText2ID #-}

  -- | Parse the identifier from its string representation as a lazy
  -- 'ByteString', but crashes when the parsing fails.
  unsafeByteString2ID :: ByteString -> a
  unsafeByteString2ID = (TypeIDError -> a) -> (a -> a) -> Either TypeIDError a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (TypeIDError -> String) -> TypeIDError -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeIDError -> String
forall a. Show a => a -> String
show) a -> a
forall a. a -> a
id (Either TypeIDError a -> a)
-> (ByteString -> Either TypeIDError a) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either TypeIDError a
forall a. IDConv a => ByteString -> Either TypeIDError a
byteString2ID
  {-# INLINE unsafeByteString2ID #-}
  {-# MINIMAL string2ID, id2String
            | string2ID, id2Text
            | string2ID, id2ByteString
            | text2ID, id2String
            | text2ID, id2Text
            | text2ID, id2ByteString
            | byteString2ID, id2String
            | byteString2ID, id2Text
            | byteString2ID, id2ByteString #-}

-- | Generate a new identifier with the given prefix.
genID :: forall a m. (IDGen a, MonadIO m)
      => GenFunc (IDGenPrefix a) (IDGenReq a (m a))
genID :: forall a (m :: * -> *).
(IDGen a, MonadIO m) =>
GenFunc (IDGenPrefix a) (IDGenReq a (m a))
genID = forall a (m :: * -> *).
(IDGen a, MonadIO m) =>
Proxy a -> GenFunc (IDGenPrefix a) (IDGenReq a (m a))
genID_ @a @m Proxy a
forall {k} (t :: k). Proxy t
Proxy
{-# INLINE genID #-}

-- | Similar to 'genID', but stateless. It can be a faster implementation than
-- 'genID', but it does not guarantee any stateful property, such as
-- monotonically increasing for 'UUID'v7-based identifiers.
--
-- The default implementation is the same as 'genID'.
genID' :: forall a m. (IDGen a, MonadIO m)
       => GenFunc (IDGenPrefix a) (IDGenReq a (m a))
genID' :: forall a (m :: * -> *).
(IDGen a, MonadIO m) =>
GenFunc (IDGenPrefix a) (IDGenReq a (m a))
genID' = forall a (m :: * -> *).
(IDGen a, MonadIO m) =>
Proxy a -> GenFunc (IDGenPrefix a) (IDGenReq a (m a))
genID'_ @a @m Proxy a
forall {k} (t :: k). Proxy t
Proxy
{-# INLINE genID' #-}

-- | Generate a list of identifiers with the given prefix.
genIDs :: forall a m. (IDGen a, MonadIO m)
       => GenFunc (IDGenPrefix a) (IDGenReq a (Word16 -> m [a]))
genIDs :: forall a (m :: * -> *).
(IDGen a, MonadIO m) =>
GenFunc (IDGenPrefix a) (IDGenReq a (Word16 -> m [a]))
genIDs = forall a (m :: * -> *).
(IDGen a, MonadIO m) =>
Proxy a -> GenFunc (IDGenPrefix a) (IDGenReq a (Word16 -> m [a]))
genIDs_ @a @m Proxy a
forall {k} (t :: k). Proxy t
Proxy
{-# INLINE genIDs #-}

-- | Generate a new identifier with the given prefix and 'UUID' suffix.
decorate :: forall a. IDGen a
         => GenFunc (IDGenPrefix a) (UUID -> ResWithErr (IDGenPrefix a) a)
decorate :: forall a.
IDGen a =>
GenFunc (IDGenPrefix a) (UUID -> ResWithErr (IDGenPrefix a) a)
decorate = forall a.
IDGen a =>
Proxy a
-> GenFunc (IDGenPrefix a) (UUID -> ResWithErr (IDGenPrefix a) a)
decorate_ @a Proxy a
forall {k} (t :: k). Proxy t
Proxy
{-# INLINE decorate #-}

-- | Check the validity of the identifier.
checkID :: forall a. IDGen a => a -> Maybe TypeIDError
checkID :: forall a. IDGen a => a -> Maybe TypeIDError
checkID = forall a. IDGen a => Proxy a -> a -> Maybe TypeIDError
checkID_ @a Proxy a
forall {k} (t :: k). Proxy t
Proxy
{-# INLINE checkID #-}

-- | Check the validity of the identifier, potentially with impure criteria.
checkIDWithEnv :: forall a m. (IDGen a, MonadIO m) => a -> m (Maybe TypeIDError)
checkIDWithEnv :: forall a (m :: * -> *).
(IDGen a, MonadIO m) =>
a -> m (Maybe TypeIDError)
checkIDWithEnv = forall a (m :: * -> *).
(IDGen a, MonadIO m) =>
Proxy a -> a -> m (Maybe TypeIDError)
checkIDWithEnv_ @a @m Proxy a
forall {k} (t :: k). Proxy t
Proxy
{-# INLINE checkIDWithEnv #-}

-- | A type class for generating 'Data.TypeID.V7.TypeID'-ish identifiers.
--
-- The methods in this type class are not directly used since each of them has
-- a dummy 'Proxy' in order to compile. We implement the methods here and use
-- the methods without the underscore suffix instead.
class IDGen a where
  -- | If the identifier has compile-time determined prefix, this type should be
  -- @'Nothing@. Otherwise it should be @'Just prefix@ where @prefix@ is the
  -- type of the prefix (e.g. 'Text').
  type IDGenPrefix a :: Maybe Type

  -- | If the identifier's generation requires additional information (such as
  -- 'UUID' version 5), this type corresponds to how to generate @r@ from the
  -- required information. Otherwise it should be simply
  -- @ type IDGenReq a r = r @.
  type IDGenReq a r :: Type

  -- | Generate an identifier with the given prefix.
  genID_ :: MonadIO m => Proxy a -> GenFunc (IDGenPrefix a) (IDGenReq a (m a))

  -- | Similar to 'genID'_, but stateless. It can be a faster implementation
  -- than 'genID'_, but it does not guarantee any stateful property, such as
  -- monotonically increasing for 'UUID'v7-based identifiers.
  --
  -- The default implementation is the same as 'genID'_.
  genID'_ :: forall m. MonadIO m
          => Proxy a -> GenFunc (IDGenPrefix a) (IDGenReq a (m a))
  genID'_ = forall a (m :: * -> *).
(IDGen a, MonadIO m) =>
Proxy a -> GenFunc (IDGenPrefix a) (IDGenReq a (m a))
genID_ @_ @m
  {-# INLINE genID'_ #-}

  -- | Generate a list of identifiers with the given prefix.
  genIDs_ :: forall m. MonadIO m
          => Proxy a -> GenFunc (IDGenPrefix a) (IDGenReq a (Word16 -> m [a]))

  -- | Generate a new identifier with the given prefix and 'UUID' suffix.
  decorate_ :: Proxy a
            -> GenFunc (IDGenPrefix a) (UUID -> ResWithErr (IDGenPrefix a) a)

  -- | Check the validity of the identifier.
  checkID_ :: Proxy a -> a -> Maybe TypeIDError

  -- | Check the validity of the identifier, potentially with impure criteria.
  checkIDWithEnv_ :: MonadIO m => Proxy a -> a -> m (Maybe TypeIDError)
  checkIDWithEnv_ Proxy a
_ = Maybe TypeIDError -> m (Maybe TypeIDError)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TypeIDError -> m (Maybe TypeIDError))
-> (a -> Maybe TypeIDError) -> a -> m (Maybe TypeIDError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> a -> Maybe TypeIDError
forall a. IDGen a => Proxy a -> a -> Maybe TypeIDError
checkID_ (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
  {-# INLINE checkIDWithEnv_ #-}

-- | A function generator based on the 'IDGenPrefix' type family.
type family GenFunc prefix res where
  GenFunc ('Just prefix) res = prefix -> res
  GenFunc 'Nothing res       = res

-- | A result that may contain an error, based on the 'IDGenPrefix' type family.
--
-- In other words, if the prefix type is already encoded in the type level,
-- we are certain that the prefix is valid, so the result type does not need the
-- @Either TypeIDError@ part.
type family ResWithErr prefix res where
  ResWithErr ('Just prefix) res = Either TypeIDError res
  ResWithErr 'Nothing res       = res