{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.KindID
(
KindID
, getPrefix
, getUUID
, getTime
, ValidPrefix
, genKindID
, genKindIDs
, nil
, decorate
, toString
, toText
, toByteString
, parseString
, parseText
, parseByteString
, 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 #-}
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 #-}
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 #-}
nil :: KindID ""
nil :: KindID ""
nil = forall (prefix :: Symbol). UUID -> KindID prefix
KindID UUID
V7.nil
{-# INLINE nil #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}