KindID.hs

{-# 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 = toJSON . toText
  {-# INLINE toJSON #-}

instance ValidPrefix prefix => FromJSON (KindID prefix) where
  parseJSON :: Value -> Parser (KindID prefix)
  parseJSON str = do
    s <- parseJSON str
    case parseText s of
      Left err  -> fail $ show err
      Right kid -> pure 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 = KindID <$> 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 n = fmap KindID <$> V7.genUUIDs n
{-# INLINE genKindIDs #-}

-- | The nil 'KindID'.
nil :: KindID ""
nil = KindID V7.nil
{-# INLINE nil #-}

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

-- | Get the prefix of the 'KindID'.
getPrefix :: forall prefix. ValidPrefix prefix => KindID prefix -> Text
getPrefix _ = T.pack $ symbolVal (Proxy @prefix)
{-# INLINE getPrefix #-}

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

-- | Get the timestamp of the 'KindID'.
getTime :: forall prefix. ValidPrefix prefix => KindID prefix -> Word64
getTime = V7.getTime . getUUID
{-# INLINE getTime #-}

-- | Convert a 'KindID' to a 'TypeID'.
toTypeID :: forall prefix. ValidPrefix prefix => KindID prefix -> TypeID
toTypeID kid = TID.TypeID (getPrefix kid) (getUUID 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 tid = do
  guard (T.pack (symbolVal (Proxy @prefix)) == TID.getPrefix tid)
  pure $ KindID (TID.getUUID tid)
{-# INLINE fromTypeID #-}

-- | Pretty-print a 'KindID'.
toString :: forall prefix. ValidPrefix prefix => KindID prefix -> String
toString = TID.toString . toTypeID
{-# INLINE toString #-}

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

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

-- | Parse a 'KindID' from its 'String' representation.
parseString :: forall prefix. ValidPrefix prefix
            => String -> Either TID.TypeIDError (KindID prefix)
parseString str = do
  tid <- TID.parseString str
  case fromTypeID tid of
    Nothing  -> Left $ TID.TypeIDErrorPrefixMismatch
                       (T.pack (symbolVal (Proxy @prefix)))
                       (TID.getPrefix tid)
    Just kid -> pure 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 str = do
  tid <- TID.parseText str
  case fromTypeID tid of
    Nothing  -> Left $ TID.TypeIDErrorPrefixMismatch
                       (T.pack (symbolVal (Proxy @prefix)))
                       (TID.getPrefix tid)
    Just kid -> pure 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 str = do
  tid <- TID.parseByteString str
  case fromTypeID tid of
    Nothing  -> Left $ TID.TypeIDErrorPrefixMismatch
                       (T.pack (symbolVal (Proxy @prefix)))
                       (TID.getPrefix tid)
    Just kid -> pure kid
{-# INLINE parseByteString #-}