{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.KindID.Internal 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.Type.Bool
import Data.Type.Equality
import Data.Type.Ord
import Data.TypeID.Class
import Data.TypeID.Error
import Data.TypeID.Internal (TypeID)
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)
newtype KindID prefix = KindID { forall {k} (prefix :: k). KindID prefix -> UUID
_getUUID :: UUID }
deriving (KindID prefix -> KindID prefix -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (prefix :: k). KindID prefix -> KindID prefix -> Bool
/= :: KindID prefix -> KindID prefix -> Bool
$c/= :: forall k (prefix :: k). KindID prefix -> KindID prefix -> Bool
== :: KindID prefix -> KindID prefix -> Bool
$c== :: forall k (prefix :: k). KindID prefix -> KindID prefix -> Bool
Eq, KindID prefix -> KindID prefix -> Bool
KindID prefix -> KindID prefix -> Ordering
KindID prefix -> KindID prefix -> KindID prefix
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall k (prefix :: k). Eq (KindID prefix)
forall k (prefix :: k). KindID prefix -> KindID prefix -> Bool
forall k (prefix :: k). KindID prefix -> KindID prefix -> Ordering
forall k (prefix :: k).
KindID prefix -> KindID prefix -> KindID prefix
min :: KindID prefix -> KindID prefix -> KindID prefix
$cmin :: forall k (prefix :: k).
KindID prefix -> KindID prefix -> KindID prefix
max :: KindID prefix -> KindID prefix -> KindID prefix
$cmax :: forall k (prefix :: k).
KindID prefix -> KindID prefix -> KindID prefix
>= :: KindID prefix -> KindID prefix -> Bool
$c>= :: forall k (prefix :: k). KindID prefix -> KindID prefix -> Bool
> :: KindID prefix -> KindID prefix -> Bool
$c> :: forall k (prefix :: k). KindID prefix -> KindID prefix -> Bool
<= :: KindID prefix -> KindID prefix -> Bool
$c<= :: forall k (prefix :: k). KindID prefix -> KindID prefix -> Bool
< :: KindID prefix -> KindID prefix -> Bool
$c< :: forall k (prefix :: k). KindID prefix -> KindID prefix -> Bool
compare :: KindID prefix -> KindID prefix -> Ordering
$ccompare :: forall k (prefix :: k). KindID prefix -> KindID prefix -> Ordering
Ord, Int -> KindID prefix -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (prefix :: k). Int -> KindID prefix -> ShowS
forall k (prefix :: k). [KindID prefix] -> ShowS
forall k (prefix :: k). KindID prefix -> String
showList :: [KindID prefix] -> ShowS
$cshowList :: forall k (prefix :: k). [KindID prefix] -> ShowS
show :: KindID prefix -> String
$cshow :: forall k (prefix :: k). KindID prefix -> String
showsPrec :: Int -> KindID prefix -> ShowS
$cshowsPrec :: forall k (prefix :: k). Int -> KindID prefix -> ShowS
Show)
type ValidPrefix prefix = ( KnownSymbol prefix
, LengthSymbol prefix < 64
, IsLowerSymbol prefix ~ 'True )
instance (ToPrefix prefix, ValidPrefix (PrefixSymbol 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 {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
KindID prefix -> Text
toText
{-# INLINE toJSON #-}
instance (ToPrefix prefix, ValidPrefix (PrefixSymbol 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 {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol 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 #-}
instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> ToJSONKey (KindID prefix) where
toJSONKey :: ToJSONKeyFunction (KindID prefix)
toJSONKey :: ToJSONKeyFunction (KindID prefix)
toJSONKey = forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
KindID prefix -> Text
toText
{-# INLINE toJSONKey #-}
instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> FromJSONKey (KindID prefix) where
fromJSONKey :: FromJSONKeyFunction (KindID prefix)
fromJSONKey :: FromJSONKeyFunction (KindID prefix)
fromJSONKey = forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser \Text
t -> case forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
Text -> Either TypeIDError (KindID prefix)
parseText Text
t 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 fromJSONKey #-}
instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> IDType (KindID prefix) where
getPrefix :: KindID prefix -> Text
getPrefix :: KindID prefix -> Text
getPrefix KindID prefix
_ = String -> Text
T.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @(PrefixSymbol prefix)))
{-# INLINE getPrefix #-}
getUUID :: KindID prefix -> UUID
getUUID :: KindID prefix -> UUID
getUUID = forall {k} (prefix :: k). KindID prefix -> UUID
_getUUID
{-# INLINE getUUID #-}
getTime :: KindID prefix -> Word64
getTime :: KindID prefix -> Word64
getTime = UUID -> Word64
V7.getTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IDType a => a -> UUID
getUUID
{-# INLINE getTime #-}
instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> IDConv (KindID prefix) where
string2ID :: String -> Either TypeIDError (KindID prefix)
string2ID :: String -> Either TypeIDError (KindID prefix)
string2ID = forall k (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
String -> Either TypeIDError (KindID prefix)
parseString
{-# INLINE string2ID #-}
text2ID :: Text -> Either TypeIDError (KindID prefix)
text2ID :: Text -> Either TypeIDError (KindID prefix)
text2ID = forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
Text -> Either TypeIDError (KindID prefix)
parseText
{-# INLINE text2ID #-}
byteString2ID :: ByteString -> Either TypeIDError (KindID prefix)
byteString2ID :: ByteString -> Either TypeIDError (KindID prefix)
byteString2ID = forall k (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
ByteString -> Either TypeIDError (KindID prefix)
parseByteString
{-# INLINE byteString2ID #-}
id2String :: KindID prefix -> String
id2String :: KindID prefix -> String
id2String = forall k (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
KindID prefix -> String
toString
{-# INLINE id2String #-}
id2Text :: KindID prefix -> Text
id2Text :: KindID prefix -> Text
id2Text = forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
KindID prefix -> Text
toText
{-# INLINE id2Text #-}
id2ByteString :: KindID prefix -> ByteString
id2ByteString :: KindID prefix -> ByteString
id2ByteString = forall k (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
KindID prefix -> ByteString
toByteString
{-# INLINE id2ByteString #-}
genKindID :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> IO (KindID prefix)
genKindID :: forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
IO (KindID prefix)
genKindID = forall {k} (prefix :: k). 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
. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> Word16 -> IO [KindID prefix]
genKindIDs :: forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
Word16 -> IO [KindID prefix]
genKindIDs Word16
n = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (prefix :: k). 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 {k} (prefix :: k). UUID -> KindID prefix
KindID UUID
V7.nil
{-# INLINE nil #-}
{-# DEPRECATED nil "Use 'nilKindID' instead." #-}
nilKindID :: KindID ""
nilKindID :: KindID ""
nilKindID = forall {k} (prefix :: k). UUID -> KindID prefix
KindID UUID
V7.nil
{-# INLINE nilKindID #-}
decorate :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> UUID -> KindID prefix
decorate :: forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
UUID -> KindID prefix
decorate = forall {k} (prefix :: k). UUID -> KindID prefix
KindID
{-# INLINE decorate #-}
{-# DEPRECATED decorate "Use 'decorateKindID' instead." #-}
decorateKindID :: forall prefix
. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> UUID -> KindID prefix
decorateKindID :: forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
UUID -> KindID prefix
decorateKindID = forall {k} (prefix :: k). UUID -> KindID prefix
KindID
toTypeID :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> KindID prefix -> TypeID
toTypeID :: forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
KindID prefix -> TypeID
toTypeID KindID prefix
kid = Text -> UUID -> TypeID
TID.TypeID (forall a. IDType a => a -> Text
getPrefix KindID prefix
kid) (forall a. IDType a => a -> UUID
getUUID KindID prefix
kid)
{-# INLINE toTypeID #-}
fromTypeID :: forall prefix
. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> TypeID -> Maybe (KindID prefix)
fromTypeID :: forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol 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 @(PrefixSymbol prefix))) forall a. Eq a => a -> a -> Bool
== forall a. IDType a => a -> Text
getPrefix TypeID
tid)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {k} (prefix :: k). UUID -> KindID prefix
KindID (forall a. IDType a => a -> UUID
getUUID TypeID
tid)
{-# INLINE fromTypeID #-}
toString :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> KindID prefix -> String
toString :: forall k (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
KindID prefix -> String
toString = TypeID -> String
TID.toString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
KindID prefix -> TypeID
toTypeID
{-# INLINE toString #-}
toText :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> KindID prefix -> Text
toText :: forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
KindID prefix -> Text
toText = TypeID -> Text
TID.toText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
KindID prefix -> TypeID
toTypeID
{-# INLINE toText #-}
toByteString :: forall prefix
. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> KindID prefix -> ByteString
toByteString :: forall k (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
KindID prefix -> ByteString
toByteString = TypeID -> ByteString
TID.toByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
KindID prefix -> TypeID
toTypeID
{-# INLINE toByteString #-}
parseString :: forall prefix
. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> String -> Either TypeIDError (KindID prefix)
parseString :: forall k (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
String -> Either TypeIDError (KindID prefix)
parseString String
str = do
TypeID
tid <- String -> Either TypeIDError TypeID
TID.parseString String
str
case forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol 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
TypeIDErrorPrefixMismatch
(String -> Text
T.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @(PrefixSymbol prefix))))
(forall a. IDType a => a -> Text
getPrefix TypeID
tid)
Just KindID prefix
kid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KindID prefix
kid
{-# INLINE parseString #-}
parseText :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> Text -> Either TypeIDError (KindID prefix)
parseText :: forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
Text -> Either TypeIDError (KindID prefix)
parseText Text
str = do
TypeID
tid <- Text -> Either TypeIDError TypeID
TID.parseText Text
str
case forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol 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
TypeIDErrorPrefixMismatch
(String -> Text
T.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @(PrefixSymbol prefix))))
(forall a. IDType a => a -> Text
getPrefix TypeID
tid)
Just KindID prefix
kid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KindID prefix
kid
{-# INLINE parseText #-}
parseByteString :: forall prefix
. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
=> ByteString -> Either TypeIDError (KindID prefix)
parseByteString :: forall k (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol prefix)) =>
ByteString -> Either TypeIDError (KindID prefix)
parseByteString ByteString
str = do
TypeID
tid <- ByteString -> Either TypeIDError TypeID
TID.parseByteString ByteString
str
case forall {k} (prefix :: k).
(ToPrefix prefix, ValidPrefix (PrefixSymbol 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
TypeIDErrorPrefixMismatch
(String -> Text
T.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @(PrefixSymbol prefix))))
(forall a. IDType a => a -> Text
getPrefix TypeID
tid)
Just KindID prefix
kid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KindID prefix
kid
{-# INLINE parseByteString #-}
type family LengthSymbol (prefix :: Symbol) :: Nat where
LengthSymbol prefix = LSUH (UnconsSymbol prefix)
type family LSUH (uncons :: Maybe (Char, Symbol)) :: Nat where
LSUH 'Nothing = 0
LSUH ('Just '(c, s)) = 1 + LengthSymbol s
type family IsLowerChar (ch :: Char) :: Bool where
IsLowerChar ch = Compare '`' ch == LT && Compare ch '{' == LT
type family IsLowerSymbol (prefix :: Symbol) :: Bool where
IsLowerSymbol prefix = ILSUH (UnconsSymbol prefix)
type family ILSUH (uncons :: Maybe (Char, Symbol)) :: Bool where
ILSUH 'Nothing = 'True
ILSUH ('Just '(c, s)) = IsLowerChar c && IsLowerSymbol s
class ToPrefix a where
type PrefixSymbol a :: Symbol
instance ToPrefix (a :: Symbol) where
type PrefixSymbol a = a