{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      : Data.KindID
-- License     : MIT
-- Maintainer  : mmzk1526@outlook.com
-- Portability : GHC
--
-- Similar to "Data.TypeID", but the type is statically determined in the type
-- level.
--
-- When using TypeID, if we want to check if the type matches, we usually need
-- to get the prefix of the TypeID and compare it with the desired prefix at
-- runtime. However, with Haskell's type system, we can do this at compile time
-- instead. We call this TypeID with compile-time prefix a 'KindID'.
--
-- Of course, that would require the desired prefix to be known at compile time.
-- This is actually quite common, especially when we are using one prefix for
-- one table in the database.
--
-- For example, suppose we have a function that takes a 'KindID' with the prefix
-- "user", it may have a signature like this:
-- @ f :: KindID "user" -> IO () @
--
-- Then if we try to pass in a 'KindID' with the prefix "post", the compiler
-- will complain, thus removing the runtime check and the associated overhead.
--
-- All the prefixes are type-checked at compile time, so if we try to pass in
-- invalid prefixes, the compiler (again) will complain.
--
-- This module contains functions to generate and parse these type-level TypeIDs
-- as well as conversion functions to and from the usual term-level TypeIDs.
-- These functions are usually used with a type application, e.g.
--
-- > do
-- >   tid <- genKindID @"user"
-- >   ...
--
module Data.KindID
  (
  -- * Data types
    KindID
  , getPrefix
  , getUUID
  , getTime
  , ValidPrefix
  -- * KindID generation
  , genKindID
  , genKindIDs
  , nil
  , decorate
  -- * Encoding & decoding
  , toString
  , toText
  , toByteString
  , parseString
  , parseText
  , parseByteString
  -- * Type-level & term-level conversion
  , toTypeID
  , fromTypeID
  ) where

import           Control.Monad
import           Data.Aeson.Types hiding (String)
import           Data.ByteString.Lazy (ByteString)
import           Data.Proxy
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.KindID.Internal
import           Data.TypeID (TypeID, TypeIDError)
import qualified Data.TypeID as TID
import qualified Data.TypeID.Internal as TID
import           Data.UUID.V7 (UUID)
import qualified Data.UUID.V7 as V7
import           Data.Word
import           GHC.TypeLits hiding (Text)

instance ValidPrefix prefix => ToJSON (KindID prefix) where
  toJSON :: KindID prefix -> Value
  toJSON :: KindID prefix -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> Text
toText
  {-# INLINE toJSON #-}

instance ValidPrefix prefix => FromJSON (KindID prefix) where
  parseJSON :: Value -> Parser (KindID prefix)
  parseJSON :: Value -> Parser (KindID prefix)
parseJSON Value
str = do
    Text
s <- forall a. FromJSON a => Value -> Parser a
parseJSON Value
str
    case forall (prefix :: Symbol).
ValidPrefix prefix =>
Text -> Either TypeIDError (KindID prefix)
parseText Text
s of
      Left TypeIDError
err  -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show TypeIDError
err
      Right KindID prefix
kid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KindID prefix
kid
  {-# INLINE parseJSON #-}

-- | Generate a new 'KindID' from a prefix.
--
-- It throws a 'TypeIDError' if the prefix does not match the specification,
-- namely if it's longer than 63 characters or if it contains characters other
-- than lowercase latin letters.
genKindID :: forall prefix. ValidPrefix prefix => IO (KindID prefix)
genKindID :: forall (prefix :: Symbol). ValidPrefix prefix => IO (KindID prefix)
genKindID = forall (prefix :: Symbol). UUID -> KindID prefix
KindID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
V7.genUUID
{-# INLINE genKindID #-}

-- | Generate n 'KindID's from a prefix.
--
-- It tries its best to generate 'KindID's at the same timestamp, but it may not
-- be possible if we are asking too many 'UUID's at the same time.
--
-- It is guaranteed that the first 32768 'KindID's are generated at the same
-- timestamp.
genKindIDs :: forall prefix. ValidPrefix prefix => Word16 -> IO [KindID prefix]
genKindIDs :: forall (prefix :: Symbol).
ValidPrefix prefix =>
Word16 -> IO [KindID prefix]
genKindIDs Word16
n = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (prefix :: Symbol). UUID -> KindID prefix
KindID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word16 -> IO [UUID]
V7.genUUIDs Word16
n
{-# INLINE genKindIDs #-}

-- | The nil 'KindID'.
nil :: KindID ""
nil :: KindID ""
nil = forall (prefix :: Symbol). UUID -> KindID prefix
KindID UUID
V7.nil
{-# INLINE nil #-}

-- | Obtain a 'KindID' from a prefix and a 'UUID'.
decorate :: forall prefix. ValidPrefix prefix => UUID -> KindID prefix
decorate :: forall (prefix :: Symbol).
ValidPrefix prefix =>
UUID -> KindID prefix
decorate = forall (prefix :: Symbol). UUID -> KindID prefix
KindID
{-# INLINE decorate #-}

-- | Get the prefix of the 'KindID'.
getPrefix :: forall prefix. ValidPrefix prefix => KindID prefix -> Text
getPrefix :: forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> Text
getPrefix KindID prefix
_ = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @prefix)
{-# INLINE getPrefix #-}

-- | Get the 'UUID' of the 'KindID'.
getUUID :: forall prefix. ValidPrefix prefix => KindID prefix -> UUID
getUUID :: forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> UUID
getUUID = forall (prefix :: Symbol). KindID prefix -> UUID
_getUUID
{-# INLINE getUUID #-}

-- | Get the timestamp of the 'KindID'.
getTime :: forall prefix. ValidPrefix prefix => KindID prefix -> Word64
getTime :: forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> Word64
getTime = UUID -> Word64
V7.getTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> UUID
getUUID
{-# INLINE getTime #-}

-- | Convert a 'KindID' to a 'TypeID'.
toTypeID :: forall prefix. ValidPrefix prefix => KindID prefix -> TypeID
toTypeID :: forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> TypeID
toTypeID KindID prefix
kid = Text -> UUID -> TypeID
TID.TypeID (forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> Text
getPrefix KindID prefix
kid) (forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> UUID
getUUID KindID prefix
kid)
{-# INLINE toTypeID #-}

-- | Convert a 'TypeID' to a 'KindID'. If the actual prefix does not match
-- with the expected one as defined by the type, it returns @Nothing@.
fromTypeID :: forall prefix. ValidPrefix prefix
           => TypeID -> Maybe (KindID prefix)
fromTypeID :: forall (prefix :: Symbol).
ValidPrefix prefix =>
TypeID -> Maybe (KindID prefix)
fromTypeID TypeID
tid = do
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String -> Text
T.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @prefix)) forall a. Eq a => a -> a -> Bool
== TypeID -> Text
TID.getPrefix TypeID
tid)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (prefix :: Symbol). UUID -> KindID prefix
KindID (TypeID -> UUID
TID.getUUID TypeID
tid)
{-# INLINE fromTypeID #-}

-- | Pretty-print a 'KindID'.
toString :: forall prefix. ValidPrefix prefix => KindID prefix -> String
toString :: forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> String
toString = TypeID -> String
TID.toString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> TypeID
toTypeID
{-# INLINE toString #-}

-- | Pretty-print a 'KindID' to strict 'Text'.
toText :: forall prefix. ValidPrefix prefix => KindID prefix -> Text
toText :: forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> Text
toText = TypeID -> Text
TID.toText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> TypeID
toTypeID
{-# INLINE toText #-}

-- | Pretty-print a 'KindID' to lazy 'ByteString'.
toByteString :: forall prefix. ValidPrefix prefix => KindID prefix -> ByteString
toByteString :: forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> ByteString
toByteString = TypeID -> ByteString
TID.toByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (prefix :: Symbol).
ValidPrefix prefix =>
KindID prefix -> TypeID
toTypeID
{-# INLINE toByteString #-}

-- | Parse a 'KindID' from its 'String' representation.
parseString :: forall prefix. ValidPrefix prefix
            => String -> Either TID.TypeIDError (KindID prefix)
parseString :: forall (prefix :: Symbol).
ValidPrefix prefix =>
String -> Either TypeIDError (KindID prefix)
parseString String
str = do
  TypeID
tid <- String -> Either TypeIDError TypeID
TID.parseString String
str
  case forall (prefix :: Symbol).
ValidPrefix prefix =>
TypeID -> Maybe (KindID prefix)
fromTypeID TypeID
tid of
    Maybe (KindID prefix)
Nothing  -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Text -> TypeIDError
TID.TypeIDErrorPrefixMismatch
                       (String -> Text
T.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @prefix)))
                       (TypeID -> Text
TID.getPrefix TypeID
tid)
    Just KindID prefix
kid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KindID prefix
kid
{-# INLINE parseString #-}

-- | Parse a 'KindID' from its string representation as a strict 'Text'.
parseText :: forall prefix. ValidPrefix prefix
          => Text -> Either TID.TypeIDError (KindID prefix)
parseText :: forall (prefix :: Symbol).
ValidPrefix prefix =>
Text -> Either TypeIDError (KindID prefix)
parseText Text
str = do
  TypeID
tid <- Text -> Either TypeIDError TypeID
TID.parseText Text
str
  case forall (prefix :: Symbol).
ValidPrefix prefix =>
TypeID -> Maybe (KindID prefix)
fromTypeID TypeID
tid of
    Maybe (KindID prefix)
Nothing  -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Text -> TypeIDError
TID.TypeIDErrorPrefixMismatch
                       (String -> Text
T.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @prefix)))
                       (TypeID -> Text
TID.getPrefix TypeID
tid)
    Just KindID prefix
kid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KindID prefix
kid
{-# INLINE parseText #-}

-- | Parse a 'KindID' from its string representation as a lazy 'ByteString'.
parseByteString :: forall prefix. ValidPrefix prefix
                => ByteString -> Either TID.TypeIDError (KindID prefix)
parseByteString :: forall (prefix :: Symbol).
ValidPrefix prefix =>
ByteString -> Either TypeIDError (KindID prefix)
parseByteString ByteString
str = do
  TypeID
tid <- ByteString -> Either TypeIDError TypeID
TID.parseByteString ByteString
str
  case forall (prefix :: Symbol).
ValidPrefix prefix =>
TypeID -> Maybe (KindID prefix)
fromTypeID TypeID
tid of
    Maybe (KindID prefix)
Nothing  -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Text -> TypeIDError
TID.TypeIDErrorPrefixMismatch
                       (String -> Text
T.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @prefix)))
                       (TypeID -> Text
TID.getPrefix TypeID
tid)
    Just KindID prefix
kid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KindID prefix
kid
{-# INLINE parseByteString #-}