mmzk-typeid 0.2.0.0 → 0.3.0.0

raw patch · 13 files changed

+840/−441 lines, 13 filesdep +hashabledep +uuid-typesdep −transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: hashable, uuid-types

Dependencies removed: transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +45/−2
• mmzk-typeid.cabal +24/−3
• src/Data/KindID.hs +20/−12
• src/Data/KindID/Class.hs +89/−0
• src/Data/KindID/Internal.hs +132/−90
• src/Data/KindID/Unsafe.hs +19/−0
• src/Data/TypeID.hs +20/−14
• src/Data/TypeID/Class.hs +121/−5
• src/Data/TypeID/Error.hs +8/−7
• src/Data/TypeID/Internal.hs +181/−66
• src/Data/TypeID/Unsafe.hs +21/−0
• src/Data/UUID/V7.hs +62/−187
• test/Spec.hs +98/−55

@@ -1,6 +1,42 @@ # Revision history for mmzk-typeid  +## 0.3.0.0 -- 2023-07-17++* Use 'uuid-types' package's `UUID` instead of a custom type.+  * `Data.UUID.V7` only retains the generation functions.+  * Other modules are not affected by this change.++* Add `Read` and `Hashable` instances for `TypeID` and `KindID`.++* Move `ValidPrefix` and `ToPrefix` to `Data.KindID.Class` module.+  * They are no longer exported from `Data.KindID`.++* Remove deprecated functions `unUUID`, `parseStringWithPrefix`,+  `parseTextWithPrefix`, `parseByteStringWithPrefix`, `nil`, and `decorate`.++* Re-implement `Show` instances for `TypeID` and `KindID` using pretty-print+  `toString`.++* Implement `TypeID` generation based on stateless `UUID`v7.+  * It is faster but does not guarantee monotonicity if multiple processes are+    generating `TypeID`s at the same time.++* Introduce unsafe `TypeID` and `KindID` functions for parsing and generating.+  They do not check the validity of the input and only behave well when the+  input is guaranteed to be valid.++* Add validity check on `TypeID` and `KindID` generation.+  * `checkID` checks the prefix and the `UUID`'s version and variant.+  * `checkIDWithEnv` also checks that the `UUID` is generated in the past.++* Deprecate `nilTypeID` and `nilKindID` since they are not useful.++* Fix typos in the documentation.++* More tests.++ ## 0.2.0.0 -- 2023-07-14  * Implement `KindID` to take arbitrary prefix type.@@ -19,6 +55,13 @@   * The original concrete functions remain, and the class is provided as an     alternative. +* Make the generation functions work with any `MonadIO` than just `IO`.++* Introduct `IDGen` class to unify the generation functions for `TypeID` and+  `KindID`.+  * The original concrete functions remain, and the class is provided as an+    alternative.+ * Deprecate `unUUID`, `parseStringWithPrefix`, `parseTextWithPrefix`,   `parseByteStringWithPrefix`, `nil`, and `decorate`. They are either replaced   by functions of other names or are no longer necessary.@@ -34,10 +77,10 @@  * First version. Released on an unsuspecting world. -* Implement TypeID as specified at https://github.com/jetpack-io/typeid.+* Implement `TypeID` as specified at https://github.com/jetpack-io/typeid.  * Add unit tests. -* Add type-level TypeID prefixes.+* Add type-level `TypeID` prefixes.  * Add `FromJSON` and `ToJSON` instances for `TypeID` and `KindID`.

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               mmzk-typeid-version:            0.2.0.0+version:            0.3.0.0  synopsis:           A TypeID implementation for Haskell description:@@ -14,6 +14,8 @@   .     - Encode prefixes at type-level for better type-safety   .+  It also serves as a (temporary) UUIDv7 implementation in Haskell, since there are no official ones yet.+  .   Please enable the following extensions if working with 'KindID':   .   > {-# LANGUAGE DataKinds #-}@@ -33,6 +35,9 @@ author:             Yitang Chen <mmzk1526@ic.ac.uk> maintainer:         Yitang Chen <mmzk1526@ic.ac.uk> category:           Data, UUID, TypeID+tested-with:+    GHC == 9.2.8+    GHC == 9.6.2 extra-source-files:     CHANGELOG.md     LICENSE@@ -43,22 +48,29 @@ library     exposed-modules:         Data.KindID,+        Data.KindID.Class,+        Data.KindID.Unsafe,         Data.TypeID,         Data.TypeID.Class,         Data.TypeID.Error,+        Data.TypeID.Unsafe,         Data.UUID.V7     other-modules:         Data.KindID.Internal,         Data.TypeID.Internal     default-extensions:         BlockArguments+        ConstraintKinds         DataKinds         InstanceSigs         MultiWayIf         OverloadedStrings         PolyKinds+        ScopedTypeVariables+        TupleSections         TypeApplications         TypeFamilies+        TypeOperators     build-depends:         base >=4.16 && <5,         aeson >=2.1 && <3,@@ -66,9 +78,10 @@         binary >=0.8.5 && <0.9,         bytestring ^>= 0.11,         entropy ^>=0.4,+        hashable ^>=1.4,         text ^>=2.0,-        transformers ^>=0.6,         time >=1.11 && <1.13,+        uuid-types >=1.0,     hs-source-dirs:   src     default-language: Haskell2010 @@ -78,21 +91,28 @@     type:             exitcode-stdio-1.0     other-modules:         Data.KindID,+        Data.KindID.Class,         Data.KindID.Internal,+        Data.KindID.Unsafe,         Data.TypeID,         Data.TypeID.Class,         Data.TypeID.Error,         Data.TypeID.Internal,+        Data.TypeID.Unsafe,         Data.UUID.V7     default-extensions:         BlockArguments+        ConstraintKinds         DataKinds         InstanceSigs         MultiWayIf         OverloadedStrings         PolyKinds+        ScopedTypeVariables+        TupleSections         TypeApplications         TypeFamilies+        TypeOperators     build-depends:         base,         aeson,@@ -101,10 +121,11 @@         bytestring,         containers ^>=0.6,         entropy,+        hashable,         hspec ^>=2.11,         text,-        transformers,         time,+        uuid-types,     hs-source-dirs:         src         test

@@ -41,22 +41,23 @@   , getPrefix   , getUUID   , getTime-  , ValidPrefix-  , ToPrefix(..)-  -- * KindID generation-  , nil+  -- * 'KindID' generation ('KindID'-specific)   , nilKindID   , genKindID+  , genKindID'   , genKindIDs-  , decorate   , decorateKindID-  -- * Encoding & decoding (class methods)-  , id2String-  , id2Text-  , id2ByteString-  , string2ID-  , text2ID-  , byteString2ID+  -- * 'KindID' generation (class methods)+  , genID+  , genID'+  , genIDs+  , decorate+  -- * Validation ('KindID'-specific)+  , checkKindID+  , checkKindIDWithEnv+  -- * Validation (class methods)+  , checkID+  , checkIDWithEnv   -- * Encoding & decoding ('KindID'-specific)   , toString   , toText@@ -64,6 +65,13 @@   , parseString   , parseText   , parseByteString+  -- * Encoding & decoding (class methods)+  , id2String+  , id2Text+  , id2ByteString+  , string2ID+  , text2ID+  , byteString2ID   -- * Type-level & term-level conversion   , toTypeID   , fromTypeID

@@ -0,0 +1,89 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Data.KindID.Class+-- License     : MIT+-- Maintainer  : mmzk1526@outlook.com+-- Portability : GHC+--+-- This module contains the type-level mechanisms that are used to define+-- custom 'Data.KindID'-ish identifier types.+--+module Data.KindID.Class+  (+  -- * Prefix+    ValidPrefix+  , ToPrefix(..)+  -- * Helpers+  , LengthSymbol(..)+  , IsLowerSymbol(..)+  , IsLowerChar(..)+  , LSUH(..)+  , ILSUH(..)+  ) where++import           Data.Type.Bool+import           Data.Type.Equality+import           Data.Type.Ord+import           GHC.TypeLits++-- | A constraint for valid prefix 'Symbol's.+type ValidPrefix prefix = ( KnownSymbol prefix+                          , LengthSymbol prefix < 64+                          , IsLowerSymbol prefix ~ 'True )++-- | The length of a 'Symbol' as a 'Nat'.+type family LengthSymbol (prefix :: Symbol) :: Nat where+  LengthSymbol prefix = LSUH (UnconsSymbol prefix)++-- | Length Symbol Uncons Helper.+type family LSUH (uncons :: Maybe (Char, Symbol)) :: Nat where+  LSUH 'Nothing        = 0+  LSUH ('Just '(c, s)) = 1 + LengthSymbol s++-- | Is a type-level 'Char' lower case?+type family IsLowerChar (ch :: Char) :: Bool where+  IsLowerChar ch = Compare '`' ch == 'LT && Compare ch '{' == 'LT++-- | Is a 'Symbol' lower case?+type family IsLowerSymbol (prefix :: Symbol) :: Bool where+  IsLowerSymbol prefix = ILSUH (UnconsSymbol prefix)++-- | Is Lower Symbol Uncons Helper.+type family ILSUH (uncons :: Maybe (Char, Symbol)) :: Bool where+  ILSUH 'Nothing        = 'True+  ILSUH ('Just '(c, s)) = IsLowerChar c && IsLowerSymbol s++-- | A class that translates any kind to a 'Symbol'. It is used to translate+-- custom data kinds to a 'Symbol' so that they can be used as 'Data.KindID'+-- prefixes.+--+-- For example, suppose we have the following data structure that represents the+-- prefixes we are going to use:+--+-- > data Prefix = User | Post | Comment+--+-- Then we can make it an instance of 'ToPrefix' like this:+--+-- > instance ToPrefix 'User where+-- >   type PrefixSymbol 'User = "user"+-- >+-- > instance ToPrefix 'Post where+-- >   type PrefixSymbol 'Post = "post"+-- >+-- > instance ToPrefix 'Comment where+-- >   type PrefixSymbol 'Comment = "comment"+--+-- Now we can use Prefix as a prefix for 'Data.KindID's, e.g.+--+-- > do+-- >   userID <- genKindID @'User -- Same as genKindID @"user"+-- >   postID <- genKindID @'Post -- Same as genKindID @"post"+-- >   commentID <- genKindID @'Comment -- Same as genKindID @"comment"+class ToPrefix a where+  type PrefixSymbol a :: Symbol++-- | The 'PrefixSymbol' of a 'Symbol' is the 'Symbol' itself.+instance ToPrefix (a :: Symbol) where+  type PrefixSymbol a = a

@@ -1,48 +1,56 @@-{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- |+-- Module      : Data.KindID.Internal+-- License     : MIT+-- Maintainer  : mmzk1526@outlook.com+-- Portability : GHC+-- module Data.KindID.Internal where  import           Control.Monad+import           Control.Monad.IO.Class import           Data.Aeson.Types hiding (String) import           Data.ByteString.Lazy (ByteString)+import           Data.Hashable import           Data.Proxy+import           Data.KindID.Class 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           Data.UUID.Types.Internal (UUID(..)) import qualified Data.UUID.V7 as V7 import           Data.Word-import           GHC.TypeLits hiding (Text)+import           GHC.TypeLits (symbolVal)  -- | A TypeID with the prefix encoded at type level. -- -- It is dubbed 'KindID' because we the prefix here is a data kind rather than -- a type.------ Note that the 'Show' instance is for debugging purposes only. To pretty-print--- a 'KindID', use 'toString', 'toText' or 'toByteString'. However, this--- behaviour will be changed in the next major version as it is not useful. By--- then, the 'Show' instance will be the same as 'toString'. newtype KindID prefix = KindID { _getUUID :: UUID }-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord) --- | A constraint for valid prefix 'Symbol's.-type ValidPrefix prefix = ( KnownSymbol prefix-                          , LengthSymbol prefix < 64-                          , IsLowerSymbol prefix ~ 'True )+instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+  => Show (KindID prefix) where+    show :: KindID prefix -> String+    show = toString+    {-# INLINE show #-}  instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+  => Read (KindID prefix) where+    readsPrec :: Int -> String -> [(KindID prefix, String)]+    readsPrec _ str = case TID.parseStringS str of+      Left _           -> []+      Right (tid, rem) -> case fromTypeID tid of+        Nothing  -> []+        Just kid -> [(kid, rem)]+    {-# INLINE readsPrec #-}++instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))   => ToJSON (KindID prefix) where     toJSON :: KindID prefix -> Value     toJSON = toJSON . toText@@ -72,6 +80,12 @@       Right kid -> pure kid     {-# INLINE fromJSONKey #-} +instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+  => Hashable (KindID prefix) where+    hashWithSalt :: Int -> KindID prefix -> Int+    hashWithSalt salt = hashWithSalt salt . toTypeID+    {-# INLINE hashWithSalt #-}+ -- | Get the prefix, 'UUID', and timestamp of a 'KindID'. instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))   => IDType (KindID prefix) where@@ -114,55 +128,82 @@     id2ByteString = toByteString     {-# INLINE id2ByteString #-} +-- | Generate 'KindID's.+instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+  => IDGen (KindID prefix) where+    type IDGenPrefix (KindID prefix) = 'Nothing++    genID_ :: MonadIO m => Proxy (KindID prefix) -> m (KindID prefix)+    genID_ _ = genKindID+    {-# INLINE genID_ #-}++    genID'_ :: MonadIO m => Proxy (KindID prefix) -> m (KindID prefix)+    genID'_ _ = genKindID'+    {-# INLINE genID'_ #-}++    genIDs_ :: MonadIO m => Proxy (KindID prefix) -> Word16 -> m [KindID prefix]+    genIDs_ _ = genKindIDs+    {-# INLINE genIDs_ #-}++    decorate_ :: Proxy (KindID prefix) -> UUID -> KindID prefix+    decorate_ _ = decorateKindID+    {-# INLINE decorate_ #-}++    checkID_ :: Proxy (KindID prefix) -> KindID prefix -> Maybe TypeIDError+    checkID_ _ = checkKindID+    {-# INLINE checkID_ #-}++    checkIDWithEnv_ :: MonadIO m +                    => Proxy (KindID prefix)+                    -> KindID prefix+                    -> m (Maybe TypeIDError)+    checkIDWithEnv_ _ = checkKindIDWithEnv+    {-# INLINE checkIDWithEnv_ #-}+ -- | 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. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))-          => IO (KindID prefix)+genKindID :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix), MonadIO m)+          => m (KindID prefix) genKindID = KindID <$> V7.genUUID {-# INLINE genKindID #-} --- | Generate n 'KindID's from a prefix.+-- | Generate a new 'KindID' from a prefix based on statelesss 'UUID'v7. --+-- See the documentation of 'V7.genUUID'' for more information.+genKindID' :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix), MonadIO m)+           => m (KindID prefix)+genKindID' = KindID <$> V7.genUUID'+{-# INLINE genKindID' #-}++-- | Generate a list of '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-            . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))-           => Word16 -> IO [KindID prefix]+genKindIDs :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix), MonadIO m)+           => Word16 -> m [KindID prefix] genKindIDs n = fmap KindID <$> V7.genUUIDs n {-# INLINE genKindIDs #-}  -- | The nil 'KindID'.-nil :: KindID ""-nil = KindID V7.nil-{-# INLINE nil #-}-{-# DEPRECATED nil "Use 'nilKindID' instead." #-}---- | The nil 'KindID'. nilKindID :: KindID "" nilKindID = KindID V7.nil {-# INLINE nilKindID #-}---- | Obtain a 'KindID' from a prefix and a 'UUID'.-decorate :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))-         => UUID -> KindID prefix-decorate = KindID-{-# INLINE decorate #-}-{-# DEPRECATED decorate "Use 'decorateKindID' instead." #-}+{-# DEPRECATED nilKindID "Will be removed in the next major release." #-}  -- | Obtain a 'KindID' from a prefix and a 'UUID'.-decorateKindID :: forall prefix-                . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+decorateKindID :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))                => UUID -> KindID prefix decorateKindID = KindID+{-# INLINE decorateKindID #-}  -- | Convert a 'KindID' to a 'TypeID'.-toTypeID :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+toTypeID :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))          => KindID prefix -> TypeID toTypeID kid = TID.TypeID (getPrefix kid) (getUUID kid) {-# INLINE toTypeID #-}@@ -178,22 +219,21 @@ {-# INLINE fromTypeID #-}  -- | Pretty-print a 'KindID'. It is 'id2String' with concrete type.-toString :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+toString :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))          => KindID prefix -> String toString = TID.toString . toTypeID {-# INLINE toString #-}  -- | Pretty-print a 'KindID' to strict 'Text'. It is 'id2Text' with concrete -- type.-toText :: forall prefix. (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+toText :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))        => KindID prefix -> Text toText = TID.toText . toTypeID {-# INLINE toText #-}  -- | Pretty-print a 'KindID' to lazy 'ByteString'. It is 'id2ByteString' with -- concrete type.-toByteString :: forall prefix-              . (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+toByteString :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))              => KindID prefix -> ByteString toByteString = TID.toByteString . toTypeID {-# INLINE toByteString #-}@@ -239,54 +279,56 @@     Just kid -> pure kid {-# INLINE parseByteString #-} -type family LengthSymbol (prefix :: Symbol) :: Nat where-  LengthSymbol prefix = LSUH (UnconsSymbol prefix)---- | Length Symbol Uncons Helper.-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+-- | Check if the prefix is valid and the suffix 'UUID' has the correct v7+-- version and variant.+checkKindID :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+            => KindID prefix -> Maybe TypeIDError+checkKindID = TID.checkTypeID . toTypeID+{-# INLINE checkKindID #-} -type family IsLowerSymbol (prefix :: Symbol) :: Bool where-  IsLowerSymbol prefix = ILSUH (UnconsSymbol prefix)+-- | Similar to 'checkKindID', but also checks if the suffix 'UUID' is+-- generated in the past.+checkKindIDWithEnv :: ( ToPrefix prefix+                      , ValidPrefix (PrefixSymbol prefix)+                      , MonadIO m )+                   => KindID prefix -> m (Maybe TypeIDError)+checkKindIDWithEnv = TID.checkTypeIDWithEnv . toTypeID+{-# INLINE checkKindIDWithEnv #-} --- | Is Lower Symbol Uncons Helper.-type family ILSUH (uncons :: Maybe (Char, Symbol)) :: Bool where-  ILSUH 'Nothing        = 'True-  ILSUH ('Just '(c, s)) = IsLowerChar c && IsLowerSymbol s+-- | Convert a 'TypeID' to a 'KindID'. If the actual prefix does not match+-- with the expected one as defined by the type, it does not complain and+-- produces a wrong 'KindID'.+unsafeFromTypeID :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+                 => TypeID -> KindID prefix+unsafeFromTypeID tid = KindID (getUUID tid)+{-# INLINE unsafeFromTypeID #-} --- | A class that translates any kind to a 'Symbol'. It is used to translate--- custom data kinds to a 'Symbol' so that they can be used as 'KindID'--- prefixes.------ For example, suppose we have the following data structure that represents the--- prefixes we are going to use:------ > data Prefix = User | Post | Comment------ Then we can make it an instance of 'ToPrefix' like this:------ > instance ToPrefix 'User where--- >   type PrefixSymbol 'User = "user"--- >--- > instance ToPrefix 'Post where--- >   type PrefixSymbol 'Post = "post"--- >--- > instance ToPrefix 'Comment where--- >   type PrefixSymbol 'Comment = "comment"+-- | Parse a 'KindID' from its 'String' representation, but does not behave+-- correctly when parsing fails. ----- Now we can use Prefix as a prefix for 'KindID's, e.g.+-- More specifically, if the prefix does not match, it will not complain and+-- produce the wrong 'KindID'. If there are other parse errors, it will crash.+unsafeParseString :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+                  => String -> KindID prefix+unsafeParseString = unsafeFromTypeID . TID.unsafeParseString+{-# INLINE unsafeParseString #-}++-- | Parse a 'KindID' from its string representation as a strict 'Text', but+-- does not behave correctly when parsing fails. ----- > do--- >   userID <- genKindID @'User -- Same as genKindID @"user"--- >   postID <- genKindID @'Post -- Same as genKindID @"post"--- >   commentID <- genKindID @'Comment -- Same as genKindID @"comment"-class ToPrefix a where-  type PrefixSymbol a :: Symbol+-- More specifically, if the prefix does not match, it will not complain and+-- produce the wrong 'KindID'. If there are other parse errors, it will crash.+unsafeParseText :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+                => Text -> KindID prefix+unsafeParseText = unsafeFromTypeID . TID.unsafeParseText+{-# INLINE unsafeParseText #-} --- | The 'PrefixSymbol' of a 'Symbol' is the 'Symbol' itself.-instance ToPrefix (a :: Symbol) where-  type PrefixSymbol a = a+-- | Parse a 'KindID' from its string representation as a lazy 'ByteString', but+-- does not behave correctly when parsing fails.+--+-- More specifically, if the prefix does not match, it will not complain and+-- produce the wrong 'KindID'. If there are other parse errors, it will crash.+unsafeParseByteString :: (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))+                      => ByteString -> KindID prefix+unsafeParseByteString = unsafeFromTypeID . TID.unsafeParseByteString+{-# INLINE unsafeParseByteString #-}

@@ -0,0 +1,19 @@+-- |+-- Module      : Data.KindID.Unsafe+-- License     : MIT+-- Maintainer  : mmzk1526@outlook.com+-- Portability : GHC+--+-- Unsafe 'KindID' functions.+--+module Data.KindID.Unsafe+  (+  -- * Unsafe 'KindID' decoding+    unsafeParseString+  , unsafeParseText+  , unsafeParseByteString+  -- * Unsafe conversion+  , unsafeFromTypeID+  ) where++import           Data.KindID.Internal

@@ -14,22 +14,24 @@   , getPrefix   , getUUID   , getTime-  -- * TypeID generation-  , nil+  -- * 'TypeID' generation ('TypeID'-specific)   , nilTypeID   , genTypeID+  , genTypeID'   , genTypeIDs-  , decorate   , decorateTypeID-  -- * Prefix validation+  -- * 'TypeID' generation (class methods)+  , genID+  , genID'+  , genIDs+  , decorate+  -- * Validation ('TypeID'-specific)   , checkPrefix-  -- * Encoding & decoding (class methods)-  , id2String-  , id2Text-  , id2ByteString-  , string2ID-  , text2ID-  , byteString2ID+  , checkTypeID+  , checkTypeIDWithEnv+  -- * Validation (class methods)+  , checkID+  , checkIDWithEnv   -- * Encoding & decoding ('TypeID'-specific)   , toString   , toText@@ -37,9 +39,13 @@   , parseString   , parseText   , parseByteString-  , parseStringWithPrefix-  , parseTextWithPrefix-  , parseByteStringWithPrefix+  -- * Encoding & decoding (class methods)+  , id2String+  , id2Text+  , id2ByteString+  , string2ID+  , text2ID+  , byteString2ID   ) where  import           Data.TypeID.Class

@@ -1,20 +1,47 @@--- | A module with the APIs for any TypeID-ish identifier type.+{-# LANGUAGE AllowAmbiguousTypes #-}++-- |+-- Module      : Data.TypeID.Class+-- License     : MIT+-- Maintainer  : mmzk1526@outlook.com+-- Portability : GHC ----- It is not completed as most of the functions are still implemented--- individually in the "Data.TypeID" and "Data.KindID" modules.+-- A module with the APIs for any 'Data.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-    IDType(..)+    TypeIDLike+  , IDType(..)   , IDConv(..)+  , IDGen(..)+  , decorate+  , genID+  , genID'+  , genIDs+  , checkID+  , checkIDWithEnv+  , GenFunc(..)+  , ResWithErr(..)   ) where +import           Control.Monad.IO.Class import           Data.ByteString.Lazy (ByteString)+import           Data.Kind (Type)+import           Data.Proxy import           Data.Text (Text) import           Data.TypeID.Error import           Data.UUID.V7 (UUID) import           Data.Word +-- | A constraint synonym for a 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 TypeID-ish identifier type, which has a 'Text' prefix -- and a 'UUID' suffix. class IDType a where@@ -24,7 +51,8 @@   -- | Get the UUID suffix of the identifier.   getUUID :: a -> UUID -  -- | Get the timestamp of the identifier.+  -- | 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 TypeID-ish identifier type and some@@ -48,3 +76,91 @@    -- | Pretty-print the identifier to a lazy 'ByteString'.   id2ByteString :: a -> ByteString++-- | Generate a new identifier with the given prefix.+genID :: forall a m. (IDGen a, MonadIO m) => GenFunc (IDGenPrefix a) (m a)+genID = genID_ @a @m 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) (m a)+genID' = genID'_ @a @m Proxy+{-# INLINE genID' #-}++-- | Generate a list of identifiers with the given prefix.+genIDs :: forall a m. (IDGen a, MonadIO m)+       => GenFunc (IDGenPrefix a) (Word16 -> m [a])+genIDs = genIDs_ @a @m 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 = decorate_ @a Proxy+{-# INLINE decorate #-}++-- | Check the validity of the identifier.+checkID :: forall a. IDGen a => a -> Maybe TypeIDError+checkID = checkID_ @a 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 = checkIDWithEnv_ @a @m Proxy+{-# INLINE checkIDWithEnv #-}++-- | A type class for generating 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++  -- | Generate an identifier with the given prefix.+  genID_ :: MonadIO m => Proxy a -> GenFunc (IDGenPrefix 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) (m a)+  genID'_ = genID_ @_ @m+  {-# INLINE genID'_ #-}++  -- | Generate a list of identifiers with the given prefix.+  genIDs_ :: MonadIO m => Proxy a -> GenFunc (IDGenPrefix 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_ _ = pure . checkID_ (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

@@ -1,4 +1,11 @@--- | TypeID Error type.+-- |+-- Module      : Data.TypeID.Error+-- License     : MIT+-- Maintainer  : mmzk1526@outlook.com+-- Portability : GHC+--+-- TypeID Error type.+-- module Data.TypeID.Error  (   -- * Data type@@ -9,13 +16,9 @@ import           Data.Text (Text)  -- | Errors from parsing TypeIDs.------ It will not be explicitly exported from "Data.TypeID" in the future. data TypeIDError = TypeIDErrorPrefixTooLong Int                  | TypeIDExtraSeparator                  | TypeIDErrorPrefixInvalidChar Char-                 -- | Will be removed in the next major release.-                 | TypeIDErrorAlreadyHasPrefix Text                  | TypeIDErrorPrefixMismatch Text Text                  | TypeIDErrorUUIDError   deriving (Eq, Ord)@@ -28,8 +31,6 @@     = "The underscore separator should not be present if the prefix is empty!"   show (TypeIDErrorPrefixInvalidChar c)     = concat ["Prefix contains invalid character ", show c, "!"]-  show (TypeIDErrorAlreadyHasPrefix prefix)-    = concat ["TypeID already has prefix ", show prefix, "!"]   show (TypeIDErrorPrefixMismatch expPrefix actPrefix)     = concat [ "Expected prefix ", show expPrefix, " but got "              , show actPrefix, "!" ]

@@ -1,25 +1,37 @@+-- |+-- Module      : Data.TypeID.Internal+-- License     : MIT+-- Maintainer  : mmzk1526@outlook.com+-- Portability : GHC+-- module Data.TypeID.Internal where  import           Control.Exception import           Control.Monad+import           Control.Monad.IO.Class import           Control.Monad.ST import           Data.Aeson.Types hiding (Array, String) import           Data.Array import           Data.Array.ST import           Data.Array.Unsafe (unsafeFreeze)+import           Data.Binary.Get+import           Data.Binary.Put import           Data.Bifunctor import           Data.Bits import           Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BSL import           Data.Char+import           Data.Hashable+import           Data.Proxy import           Data.String import           Data.Text (Text) import qualified Data.Text as T import           Data.Text.Encoding import           Data.TypeID.Class import           Data.TypeID.Error-import           Data.UUID.V7 (UUID(..))-import qualified Data.UUID.V7 as UUID+import           Data.UUID.Types.Internal (UUID(..))+import qualified Data.UUID.Types.Internal as UUID+import qualified Data.UUID.V7 as V7 import           Data.Word  -- | The constructor is not exposed to the public API to prevent generating@@ -31,8 +43,20 @@ -- then, the 'Show' instance will be the same as 'toString'. data TypeID = TypeID { _getPrefix :: Text                      , _getUUID   :: UUID }-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord) +instance Show TypeID where+  show :: TypeID -> String+  show = toString+  {-# INLINE show #-}++instance Read TypeID where+  readsPrec :: Int -> String -> [(TypeID, String)]+  readsPrec _ str = case parseStringS str of+    Left _      -> []+    Right (x,y) -> [(x, y)]+  {-# INLINE readsPrec #-}+ instance ToJSON TypeID where   toJSON :: TypeID -> Value   toJSON = toJSON . toText@@ -59,6 +83,12 @@     Right tid -> pure tid   {-# INLINE fromJSONKey #-} +instance Hashable TypeID where+  hashWithSalt :: Int -> TypeID -> Int+  hashWithSalt salt (TypeID prefix uuid)+    = salt `hashWithSalt` prefix `hashWithSalt` uuid+  {-# INLINE hashWithSalt #-}+ -- | Get the prefix, 'UUID', and timestamp of a 'TypeID'. instance IDType TypeID where   getPrefix :: TypeID -> Text@@ -70,7 +100,7 @@   {-# INLINE getUUID #-}    getTime :: TypeID -> Word64-  getTime = UUID.getTime . getUUID+  getTime = V7.getTime . getUUID   {-# INLINE getTime #-}  -- | Conversion between 'TypeID' and 'String'/'Text'/'ByteString'.@@ -99,46 +129,95 @@   id2ByteString = toByteString   {-# INLINE id2ByteString #-} +-- | Generate 'TypeID's.+instance IDGen TypeID where+  type IDGenPrefix TypeID = 'Just Text++  genID_ :: MonadIO m => Proxy TypeID -> Text -> m TypeID+  genID_ _ = genTypeID+  {-# INLINE genID_ #-}++  genID'_ :: MonadIO m => Proxy TypeID -> Text -> m TypeID+  genID'_ _ = genTypeID'+  {-# INLINE genID'_ #-}++  genIDs_ :: MonadIO m => Proxy TypeID -> Text -> Word16 -> m [TypeID]+  genIDs_ _ = genTypeIDs+  {-# INLINE genIDs_ #-}++  decorate_ :: Proxy TypeID -> Text -> UUID -> Either TypeIDError TypeID+  decorate_ _ = decorateTypeID+  {-# INLINE decorate_ #-}++  checkID_ :: Proxy TypeID -> TypeID -> Maybe TypeIDError+  checkID_ _ = checkTypeID+  {-# INLINE checkID_ #-}++  checkIDWithEnv_ :: MonadIO m+                  => Proxy TypeID -> TypeID -> m (Maybe TypeIDError)+  checkIDWithEnv_ _ = checkTypeIDWithEnv+  {-# INLINE checkIDWithEnv_ #-}+ -- | Generate a new 'TypeID' 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.-genTypeID :: Text -> IO TypeID+genTypeID :: MonadIO m => Text -> m TypeID genTypeID = fmap head . (`genTypeIDs` 1) {-# INLINE genTypeID #-} --- | Generate n 'TypeID's from a prefix.+-- | Generate a new 'TypeID' from a prefix based on statelesss 'UUID'v7. --+-- See the documentation of 'V7.genUUID'' for more information.+genTypeID' :: MonadIO m => Text -> m TypeID+genTypeID' prefix = case checkPrefix prefix of+  Nothing  -> unsafeGenTypeID' prefix+  Just err -> liftIO $ throwIO err+{-# INLINE genTypeID' #-}++-- | Generate a list of 'TypeID's from a prefix.+-- -- It tries its best to generate 'TypeID'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 'TypeID's are generated at the same -- timestamp.-genTypeIDs :: Text -> Word16 -> IO [TypeID]+genTypeIDs :: MonadIO m => Text -> Word16 -> m [TypeID] genTypeIDs prefix n = case checkPrefix prefix of-  Nothing  -> map (TypeID prefix) <$> UUID.genUUIDs n-  Just err -> throwIO err+  Nothing  -> unsafeGenTypeIDs prefix n+  Just err -> liftIO $ throwIO err {-# INLINE genTypeIDs #-} --- | The nil 'TypeID'.-nil :: TypeID-nil = TypeID "" UUID.nil-{-# INLINE nil #-}-{-# DEPRECATED nil "Use nilTypeID instead." #-}+-- | Generate a new 'TypeID' from a prefix, but without checking if the prefix+-- is valid.+unsafeGenTypeID :: MonadIO m => Text -> m TypeID+unsafeGenTypeID = fmap head . (`unsafeGenTypeIDs` 1)+{-# INLINE unsafeGenTypeID #-} +-- | Generate a new 'TypeID' from a prefix based on statelesss 'UUID'v7, but+-- without checking if the prefix is valid.+unsafeGenTypeID' :: MonadIO m => Text -> m TypeID+unsafeGenTypeID' prefix = TypeID prefix <$> V7.genUUID'+{-# INLINE unsafeGenTypeID' #-}++-- | Generate n 'TypeID's from a prefix, but without checking if the prefix is+-- valid.+--+-- It tries its best to generate 'TypeID'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 'TypeID's are generated at the same+-- timestamp.+unsafeGenTypeIDs :: MonadIO m => Text -> Word16 -> m [TypeID]+unsafeGenTypeIDs prefix n = map (TypeID prefix) <$> V7.genUUIDs n+{-# INLINE unsafeGenTypeIDs #-}+ -- | The nil 'TypeID'. nilTypeID :: TypeID nilTypeID = TypeID "" UUID.nil {-# INLINE nilTypeID #-}---- | Obtain a 'TypeID' from a prefix and a 'UUID'.-decorate :: Text -> UUID -> Either TypeIDError TypeID-decorate prefix uuid = case checkPrefix prefix of-  Nothing  -> Right $ TypeID prefix uuid-  Just err -> Left err-{-# INLINE decorate #-}-{-# DEPRECATED decorate "Use decorateTypeID instead." #-}+{-# DEPRECATED nilTypeID "Will be removed in the next major release." #-}  -- | Obtain a 'TypeID' from a prefix and a 'UUID'. decorateTypeID :: Text -> UUID -> Either TypeIDError TypeID@@ -149,17 +228,21 @@  -- | Pretty-print a 'TypeID'. It is 'id2String' with concrete type. toString :: TypeID -> String-toString (TypeID prefix (UUID bs)) = if T.null prefix+toString (TypeID prefix (UUID w1 w2)) = if T.null prefix   then suffixEncode bs   else T.unpack prefix ++ "_" ++ suffixEncode bs+  where+    bs = runPut $ mapM_ putWord64be [w1, w2] {-# INLINE toString #-}  -- | Pretty-print a 'TypeID' to strict 'Text'. It is 'id2Text' with concrete -- type. toText :: TypeID -> Text-toText (TypeID prefix (UUID bs)) = if T.null prefix+toText (TypeID prefix (UUID w1 w2)) = if T.null prefix   then T.pack (suffixEncode bs)   else prefix <> "_" <> T.pack (suffixEncode bs)+  where+    bs = runPut $ mapM_ putWord64be [w1, w2] {-# INLINE toText #-}  -- | Pretty-print a 'TypeID' to lazy 'ByteString'. It is 'id2ByteString' with@@ -171,17 +254,26 @@ -- | Parse a 'TypeID' from its 'String' representation. It is 'string2ID' with -- concrete type. parseString :: String -> Either TypeIDError TypeID-parseString str = case span (/= '_') str of+parseString str = case parseStringS str of+  Left err        -> Left err+  Right (tid, "") -> Right tid+  _               -> Left TypeIDErrorUUIDError+{-# INLINE parseString #-}++parseStringS :: String -> Either TypeIDError (TypeID, String)+parseStringS str = case span (/= '_') str of   ("", _)              -> Left TypeIDExtraSeparator-  (_, "")              -> TypeID "" <$> decodeUUID bs+  (_, "")              -> do+    let (uuid, rem) = splitAt 26 str+        bs          = fromString uuid+    (, rem) . TypeID "" <$> decodeUUID bs   (prefix, _ : suffix) -> do-    let prefix' = T.pack prefix-    let bs      = fromString suffix+    let prefix'     = T.pack prefix+        (uuid, rem) = splitAt 26 suffix+        bs          = fromString uuid     case checkPrefix prefix' of-      Nothing  -> TypeID prefix' <$> decodeUUID bs+      Nothing  -> (, rem) . TypeID prefix' <$> decodeUUID bs       Just err -> Left err-  where-    bs = fromString str  -- | Parse a 'TypeID' from its string representation as a strict 'Text'. It is -- 'text2ID' with concrete type.@@ -190,9 +282,9 @@   ("", _)                    -> Left TypeIDExtraSeparator   (_, Nothing)               -> TypeID "" <$> decodeUUID bs   (prefix, Just (_, suffix)) -> do-    let bs = BSL.fromStrict $ encodeUtf8 suffix     case checkPrefix prefix of-      Nothing  -> TypeID prefix <$> decodeUUID bs+      Nothing  -> TypeID prefix+              <$> decodeUUID (BSL.fromStrict $ encodeUtf8 suffix)       Just err -> Left err   where     bs = BSL.fromStrict $ encodeUtf8 text@@ -209,46 +301,63 @@       Nothing  -> TypeID prefix' <$> decodeUUID suffix       Just err -> Left err --- | Parse a 'TypeID' from the given prefix and the 'String' representation of a--- suffix.-parseStringWithPrefix :: Text -> String -> Either TypeIDError TypeID-parseStringWithPrefix prefix str = case parseString str of-  Right (TypeID "" uuid) -> decorate prefix uuid-  Right (TypeID p  _)    -> Left $ TypeIDErrorAlreadyHasPrefix p-  Left err               -> Left err-{-# INLINE parseStringWithPrefix #-}-{-# DEPRECATED parseStringWithPrefix "Use 'parseString' and 'decorate' instead" #-}---- | Parse a 'TypeID' from the given prefix and the string representation of a--- suffix as a strict 'Text'.-parseTextWithPrefix :: Text -> Text -> Either TypeIDError TypeID-parseTextWithPrefix prefix text = case parseText text of-  Right (TypeID "" uuid) -> decorate prefix uuid-  Right (TypeID p  _)    -> Left $ TypeIDErrorAlreadyHasPrefix p-  Left err               -> Left err-{-# INLINE parseTextWithPrefix #-}-{-# DEPRECATED parseTextWithPrefix "Use 'parseText' and 'decorate' instead" #-}---- | Parse a 'TypeID' from the given prefix and the string representation of a--- suffix as a lazy 'ByteString'.-parseByteStringWithPrefix :: Text -> ByteString -> Either TypeIDError TypeID-parseByteStringWithPrefix prefix bs = case parseByteString bs of-  Right (TypeID "" uuid) -> decorate prefix uuid-  Right (TypeID p  _)    -> Left $ TypeIDErrorAlreadyHasPrefix p-  Left err               -> Left err-{-# INLINE parseByteStringWithPrefix #-}-{-# DEPRECATED parseByteStringWithPrefix "Use 'parseByteString' and 'decorate' instead" #-}- -- | Check if the given prefix is a valid TypeID prefix. checkPrefix :: Text -> Maybe TypeIDError checkPrefix prefix   | T.length prefix > 63 = Just $ TypeIDErrorPrefixTooLong (T.length prefix)-  | otherwise  +  | otherwise       = case T.uncons (T.dropWhile (liftM2 (&&) isLower isAscii) prefix) of         Nothing     -> Nothing         Just (c, _) -> Just $ TypeIDErrorPrefixInvalidChar c {-# INLINE checkPrefix #-} +-- | Check if the prefix is valid and the suffix 'UUID' has the correct v7+-- version and variant.+checkTypeID :: TypeID -> Maybe TypeIDError+checkTypeID (TypeID prefix uuid)+  = msum [ checkPrefix prefix+         , TypeIDErrorUUIDError <$ guard (not $ V7.validate uuid) ]+{-# INLINE checkTypeID #-}++-- | Similar to 'checkTypeID', but also checks if the suffix 'UUID' is+-- generated in the past.+checkTypeIDWithEnv :: MonadIO m => TypeID -> m (Maybe TypeIDError)+checkTypeIDWithEnv tid@(TypeID _ uuid)+  = fmap (checkTypeID tid `mplus`)+         ((TypeIDErrorUUIDError <$) . guard . not <$> V7.validateWithTime uuid)+{-# INLINE checkTypeIDWithEnv #-}++-- | Parse a 'TypeID' from its 'String' representation, but crashes when+-- parsing fails.+unsafeParseString :: String -> TypeID+unsafeParseString str = case span (/= '_') str of+  (_, "")              -> TypeID "" $ unsafeDecodeUUID bs+  (prefix, _ : suffix) -> TypeID (T.pack prefix)+                        . unsafeDecodeUUID $ fromString suffix+  where+    bs = fromString str+{-# INLINE unsafeParseString #-}++-- | Parse a 'TypeID' from its string representation as a strict 'Text', but+-- crashes when parsing fails.+unsafeParseText :: Text -> TypeID+unsafeParseText text = case second T.uncons $ T.span (/= '_') text of+  (_, Nothing)               -> TypeID "" $ unsafeDecodeUUID bs+  (prefix, Just (_, suffix)) -> TypeID prefix . unsafeDecodeUUID+                              . BSL.fromStrict . encodeUtf8 $ suffix+  where+    bs = BSL.fromStrict $ encodeUtf8 text+{-# INLINE unsafeParseText #-}++-- | Parse a 'TypeID' from its string representation as a lazy 'ByteString',+-- but crashes when parsing fails.+unsafeParseByteString :: ByteString -> TypeID+unsafeParseByteString bs = case second BSL.uncons $ BSL.span (/= 95) bs of+  (_, Nothing)               -> TypeID "" $ unsafeDecodeUUID bs+  (prefix, Just (_, suffix)) -> TypeID (decodeUtf8 $ BSL.toStrict prefix)+                              . unsafeDecodeUUID $ suffix+{-# INLINE unsafeParseByteString #-}+ -- The helpers below are verbatim translations from the official highly magical -- Go implementation. @@ -311,10 +420,16 @@   unless (BSL.length bs == 26) $ Left TypeIDErrorUUIDError   unless (bs `BSL.index` 0 <= 55) $ Left TypeIDErrorUUIDError   when (any ((== 0xFF) . (table !)) $ BSL.unpack bs) $ Left TypeIDErrorUUIDError-  pure . UUID $ suffixDecode bs+  pure $ unsafeDecodeUUID bs+{-# INLINE decodeUUID #-} +unsafeDecodeUUID :: ByteString -> UUID+unsafeDecodeUUID bs+  = uncurry UUID . runGet (join (liftM2 (,)) getWord64be) $ suffixDecode bs+{-# INLINE unsafeDecodeUUID #-}+ table :: Array Word8 Word8-table = listArray (0, 255) +table = listArray (0, 255)   [ 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF   , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF   , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF

@@ -0,0 +1,21 @@+-- |+-- Module      : Data.TypeID.Unsafe+-- License     : MIT+-- Maintainer  : mmzk1526@outlook.com+-- Portability : GHC+--+-- Unsafe 'TypeID' functions.+--+module Data.TypeID.Unsafe+  (+  -- * Unsafe 'TypeID' generation+    unsafeGenTypeID+  , unsafeGenTypeID'+  , unsafeGenTypeIDs+  -- * Unsafe decoding+  , unsafeParseString+  , unsafeParseText+  , unsafeParseByteString+  ) where++import           Data.TypeID.Internal

@@ -1,12 +1,9 @@ -- |--- Module      : Data.KindID+-- Module      : Data.UUID.V7 -- License     : MIT -- Maintainer  : mmzk1526@outlook.com -- Portability : GHC ----- IMPORTANT: In the next major release (breaking change), I will unify the--- 'UUID' type with the one from the uuid-type package.--- -- UUIDv7 implementation. -- -- UUIDv7 is not currently present in the uuid package, therefore I have to@@ -15,207 +12,72 @@ -- Note that since the specification for v7 is not yet finalised, this module's -- implementation may change in the future according to the potential -- adjustments in the specification.+--+-- WARNING: The 'nil' re-export will be removed in the next major version.+-- module Data.UUID.V7   (   -- * Data type-    UUID(..)-  , unUUID-  -- * UUID generation+    UUID+  -- * 'UUID'v7 generation   , nil   , genUUID+  , genUUID'   , genUUIDs-  -- * Encoding & decoding-  , parseString-  , parseText-  , parseByteString-  , toString-  , toText-  , toByteString+  -- Validation+  , validate+  , validateWithTime   -- * Miscellaneous helpers   , getTime   , getEpochMilli   ) where  import           Control.Monad-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Maybe-import           Data.Aeson.Types hiding (String)-import           Data.Array+import           Control.Monad.IO.Class import           Data.Binary import           Data.Binary.Get import           Data.Binary.Put import           Data.Bits-import           Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BSL import           Data.IORef-import           Data.String-import           Data.Text (Text)-import qualified Data.Text as T-import           Data.Text.Encoding import           Data.Time.Clock.POSIX+import           Data.UUID.Types.Internal import           System.Entropy import           System.IO.Unsafe (unsafePerformIO) --- | A simple wrapper around a 'ByteString' representing a UUIDv7.------ Note that the 'Show' instance is for debugging purposes only. To pretty-print--- a 'UUID'v7, use 'toString', 'toText' or 'toByteString'.------ The 'UUID' constructor will be hidden in favour of the 'Binary' instance in--- the future.-newtype UUID = UUID ByteString-  deriving (Eq, Ord, Show)---- | Deprecated. Use the 'Binary' instance instead.-unUUID :: UUID -> ByteString-unUUID (UUID bs) = bs-{-# INLINE unUUID #-}-{-# DEPRECATED unUUID "Use the 'Binary' instance instead" #-}--instance ToJSON UUID where-  toJSON :: UUID -> Value-  toJSON = toJSON . toString-  {-# INLINE toJSON #-}--instance FromJSON UUID where-  parseJSON :: Value -> Parser UUID-  parseJSON str = do-    s <- parseJSON str-    case parseString s of-      Nothing   -> fail "Invalid UUID"-      Just uuid -> pure uuid-  {-# INLINE parseJSON #-}--instance ToJSONKey UUID where-  toJSONKey :: ToJSONKeyFunction UUID-  toJSONKey = toJSONKeyText toText-  {-# INLINE toJSONKey #-}--instance FromJSONKey UUID where-  fromJSONKey :: FromJSONKeyFunction UUID-  fromJSONKey = FromJSONKeyTextParser \t -> case parseText t of-    Nothing   -> fail "Invalid UUID"-    Just uuid -> pure uuid-  {-# INLINE fromJSONKey #-}--instance Binary UUID where-  put :: UUID -> Put-  put (UUID bs) = putLazyByteString bs-  {-# INLINE put #-}--  get :: Get UUID-  get = UUID <$> getLazyByteString 16-  {-# INLINE get #-}---- | Pretty-print a 'UUID'v7.-toString :: UUID -> String-toString (UUID bs)-    | BSL.length bs /= 16 = "<INVALID-UUID>"-    | otherwise           = word16ToHex b0-                          . word16ToHex b1-                          . (('-' :) . word16ToHex b2)-                          . (('-' :) . word16ToHex b3)-                          . (('-' :) . word16ToHex b4)-                          . (('-' :) . word16ToHex b5)-                          . word16ToHex b6-                          $ word16ToHex b7 ""-    where-      [b0, b1, b2, b3, b4, b5, b6, b7]-        = runGet (replicateM 8 getWord16be) bs-      hexTable-        = listArray (0, 15) "0123456789abcdef"-      word16ToHex w rem-       = let (q0, r0) = w `divMod` 16-             (q1, r1) = q0 `divMod` 16-             (q2, r2) = q1 `divMod` 16-             (q3, r3) = q2 `divMod` 16-         in  hexTable ! r3 : hexTable ! r2 : hexTable ! r1 : hexTable ! r0 : rem---- | Pretty-print a 'UUID'v7 to strict 'Text'.-toText :: UUID -> Text-toText = T.pack . toString-{-# INLINE toText #-}---- | Pretty-print a 'UUID'v7 to lazy 'ByteString'.-toByteString :: UUID -> ByteString-toByteString = fromString . toString-{-# INLINE toByteString #-}---- | Parse a 'UUID'v7 from its 'String' representation.------ The representation is either standard or has no dashes. Does not care about--- the case of the letters.-parseString :: String -> Maybe UUID-parseString = parseByteString . fromString-{-# INLINE parseString #-}---- | Parse a 'UUID'v7 from its string representation as a strict 'Text'.------ The representation is either standard or has no dashes. Does not care about--- the case of the letters.-parseText :: Text -> Maybe UUID-parseText = parseByteString . BSL.fromStrict . encodeUtf8-{-# INLINE parseText #-}---- | Parse a 'UUID'v7 from its string representation as a lazy 'ByteString'.------ The representation is either standard or has no dashes. Does not care about--- the case of the letters.-parseByteString :: ByteString -> Maybe UUID-parseByteString bs-  | BSL.length bs == 32 = UUID <$> parse False-  | BSL.length bs == 36 = UUID <$> parse True-  | otherwise           = Nothing-  where-    parse hasDashes    = (`runGet` bs) $ runMaybeT do-      raw1 <- lift $ replicateM 4 (liftM2 (,) getWord8 getWord8)-      seg1 <- hoistMaybe $ mapM readHexPair raw1-      when hasDashes checkDash-      raw2 <- lift $ replicateM 2 (liftM2 (,) getWord8 getWord8)-      seg2 <- hoistMaybe $ mapM readHexPair raw2-      when hasDashes checkDash-      raw3 <- lift $ replicateM 2 (liftM2 (,) getWord8 getWord8)-      seg3 <- hoistMaybe $ mapM readHexPair raw3-      when hasDashes checkDash-      raw4 <- lift $ replicateM 2 (liftM2 (,) getWord8 getWord8)-      seg4 <- hoistMaybe $ mapM readHexPair raw4-      when hasDashes checkDash-      raw5 <- lift $ replicateM 6 (liftM2 (,) getWord8 getWord8)-      seg5 <- hoistMaybe $ mapM readHexPair raw5-      pure . runPut . mapM_ putWord8 $ concat [seg1, seg2, seg3, seg4, seg5]-    readHex w-      | w >= 48 && w <= 57  = Just (w - 48)-      | w >= 65 && w <= 70  = Just (w - 55)-      | w >= 97 && w <= 102 = Just (w - 87)-      | otherwise           = Nothing-    readHexPair (x, y) = do-      x' <- readHex x-      y' <- readHex y-      pure (x' * 16 + y')-    checkDash          = do-      w <- lift getWord8-      guard (w == 45)---- | The nil 'UUID'v7.-nil :: UUID-nil = UUID $ BSL.replicate 16 0-{-# INLINE nil #-}- -- | Generate a 'UUID'v7.-genUUID :: IO UUID+genUUID :: MonadIO m => m UUID genUUID = head <$> genUUIDs 1 {-# INLINE genUUID #-} --- | Generate n 'UUID'v7s.+-- | Generate a stateless 'UUID'v7. --+-- It is faster than 'genUUID' but it is not guaranteed to be monotonically+-- increasing if multiple 'UUID's are generated at the same timestamp.+--+-- In use cases where the ordering is not important, this function is could be+-- preferred.+genUUID' :: MonadIO m => m UUID+genUUID' = do+  timestamp <- getEpochMilli+  entropy16 <- getEntropyWord16+  entropy64 <- getEntropyWord64+  let bs = runPut do+        fillTime timestamp+        fillVerAndRandA entropy16+        fillVarAndRandB entropy16 entropy64+  pure . uncurry UUID $ runGet (join (liftM2 (,)) getWord64be) bs++-- | Generate a list of 'UUID'v7s.+-- -- It tries its best to generate 'UUID'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 'UUID's are generated at the same -- timestamp.-genUUIDs :: Word16 -> IO [UUID]+genUUIDs :: MonadIO m => Word16 -> m [UUID] genUUIDs 0 = pure []-genUUIDs n = do+genUUIDs n = liftIO do   timestamp <- getEpochMilli   -- We set the first bit of the entropy to 0 to ensure that there's enough   -- room for incrementing the sequence number.@@ -240,24 +102,37 @@     else do       uuids <- forM [0..(n' - 1)] $ \curN -> do         entropy64 <- getEntropyWord64-        pure . UUID $ runPut do-          fillTime timestamp-          fillVerAndRandA (seqNo + curN)-          fillVarAndRandB (seqNo + curN) entropy64-      if n' == n-        then pure uuids-        else (uuids ++) <$> genUUIDs (n - n')+        let bs = runPut do+              fillTime timestamp+              fillVerAndRandA (seqNo + curN)+              fillVarAndRandB (seqNo + curN) entropy64+        pure . uncurry UUID $ runGet (join (liftM2 (,)) getWord64be) bs+      if n' == n then pure uuids else (uuids ++) <$> genUUIDs (n - n') +-- | Validate the version and variant of the 'UUID'v7.+validate :: UUID -> Bool+validate (UUID w1 w2)+  = (w1 `shiftR` 12) .&. 0xF == 0x7 && (w2 `shiftR` 62) .&. 0x3 == 0x2+{-# INLINE validate #-}++-- | Validate the version and variant of the 'UUID'v7 as well as its timestamp+-- is no greater than the current time.+validateWithTime :: MonadIO m => UUID -> m Bool+validateWithTime uuid = do+  curTime <- getEpochMilli+  pure $ validate uuid && (getTime uuid <= curTime)+{-# INLINE validateWithTime #-}+   -- | Get the current time in milliseconds since the Unix epoch.-getEpochMilli :: IO Word64-getEpochMilli = do+getEpochMilli :: MonadIO m => m Word64+getEpochMilli = liftIO do   t <- getPOSIXTime-  pure $ round $ t * 1000+  pure . round $ t * 1000 {-# INLINE getEpochMilli #-}  -- | Get the time field (unix_ts_ms) of a 'UUID'v7. getTime :: UUID -> Word64-getTime (UUID bs) = runGet getWord64be bs `shiftR` 16+getTime (UUID w1 _) = w1 `shiftR` 16 {-# INLINE getTime #-}  -- | The global mutable state of (timestamp, sequence number).@@ -313,14 +188,14 @@   in (b3, b2, b1, b0) {-# INLINE splitWord64ToWord16s #-} -getEntropyWord16 :: IO Word16-getEntropyWord16 = do+getEntropyWord16 :: MonadIO m => m Word16+getEntropyWord16 = liftIO do   bs <- BSL.fromStrict <$> getEntropy 2   pure $ runGet getWord16host bs {-# INLINE getEntropyWord16 #-} -getEntropyWord64 :: IO Word64-getEntropyWord64 = do+getEntropyWord64 :: MonadIO m => m Word64+getEntropyWord64 = liftIO do   bs <- BSL.fromStrict <$> getEntropy 8   pure $ runGet getWord64host bs {-# INLINE getEntropyWord64 #-}

@@ -6,15 +6,15 @@ import           Data.Aeson import qualified Data.ByteString.Lazy as BSL import           Data.KindID-import qualified Data.KindID as KID+import           Data.KindID.Class import           Data.Map (Map) import qualified Data.Map as M import           Data.String import           Data.Text (Text) import qualified Data.Text as T import           Data.TypeID+import           Data.TypeID.Class import           Data.TypeID.Error-import qualified Data.TypeID as TID import           Data.UUID.V7 (UUID) import qualified Data.UUID.V7 as V7 import           GHC.Generics (Generic)@@ -46,6 +46,24 @@ anyTypeIDError :: Selector TypeIDError anyTypeIDError = const True +withCheck :: HasCallStack => (IDConv a, IDGen a) => IO a -> IO a+withCheck action = do+  tid         <- action+  checkResult <- checkIDWithEnv tid+  case checkResult of+    Just _  -> do+      expectationFailure $ concat ["The ID ", id2String tid, " does not pass validity check"]+      undefined+    Nothing -> pure tid++withChecks :: HasCallStack => IDGen a => IO [a] -> IO [a]+withChecks action = do+  tids        <- action+  checkResult <- msum <$> mapM checkIDWithEnv tids+  case checkResult of+    Just _  -> expectationFailure "The IDs do not pass validity check" >> undefined+    Nothing -> pure tids+ main :: IO () main = do   invalid   <- BSL.readFile "test/invalid.json" >>= throwDecode :: IO [TestData]@@ -55,23 +73,36 @@   hspec do     describe "Generate TypeID" do       it "can generate TypeID with prefix" do-        tid <- TID.genTypeID "mmzk"+        start <- V7.getEpochMilli+        tid   <- withCheck $ genID @TypeID "mmzk"+        end   <- V7.getEpochMilli         getPrefix tid `shouldBe` "mmzk"+        getTime tid `shouldSatisfy` \t -> t >= start && t <= end       it "can generate TypeID without prefix" do-        tid <- TID.genTypeID ""+        start <- V7.getEpochMilli+        tid   <- withCheck $ genID @TypeID ""+        end   <- V7.getEpochMilli         getPrefix tid `shouldBe` ""-      it "can parse TypeID from String" do-        case string2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of-          Left err  -> expectationFailure $ "Parse error: " ++ show err-          Right tid -> getPrefix tid `shouldBe` "mmzk"-      it "has the correct nil" do-        Right TID.nilTypeID `shouldBe` string2ID "00000000000000000000000000"+        getTime tid `shouldSatisfy` \t -> t >= start && t <= end+      it "can generate TypeID with stateless UUIDv7" do+        start <- V7.getEpochMilli+        tid   <- withCheck $ genID' @TypeID "mmzk"+        end   <- V7.getEpochMilli+        getPrefix tid `shouldBe` "mmzk"+        getTime tid `shouldSatisfy` \t -> t >= start && t <= end       it "can generate in batch with same timestamp and in ascending order" do-        tids <- TID.genTypeIDs "mmzk" 1526+        start <- V7.getEpochMilli+        tids  <- withChecks $ genIDs @TypeID "mmzk" 1526+        end   <- V7.getEpochMilli         all ((== "mmzk") . getPrefix) tids `shouldBe` True         let timestamp = getTime $ head tids         all ((== timestamp) . getTime) tids `shouldBe` True         all (uncurry (<)) (zip tids $ tail tids) `shouldBe` True+        timestamp `shouldSatisfy` \t -> t >= start && t <= end+      it "can parse TypeID from String" do+        case string2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of+          Left err  -> expectationFailure $ "Parse error: " ++ show err+          Right tid -> getPrefix tid `shouldBe` "mmzk"      describe "Parse TypeID" do       let invalidPrefixes = [ ("caps", "PREFIX")@@ -82,8 +113,8 @@                             , ("ascii", "château") ]       describe "can detect invalid prefix" do         forM_ invalidPrefixes \(reason, prefix) -> it reason do-          TID.genTypeID prefix `shouldThrow` anyTypeIDError-          case TID.decorateTypeID prefix V7.nil of+          genID @TypeID prefix `shouldThrow` anyTypeIDError+          case decorate @TypeID prefix V7.nil of             Left _  -> pure ()             Right _ -> expectationFailure "Should not be able to decorate with invalid prefix"       let invalidSuffixes = [ ("spaces", " ")@@ -98,7 +129,7 @@         forM_ invalidSuffixes \(reason, suffix) -> it reason do           case string2ID @TypeID suffix of             Left _    -> pure ()-            Right tid -> expectationFailure $ "Parsed TypeID: " ++ id2String tid+            Right tid -> expectationFailure $ "Parsed TypeID: " ++ show tid      describe "Parse special values" do       let specialValues = [ ("nil", "00000000000000000000000000", "00000000-0000-0000-0000-000000000000")@@ -109,49 +140,49 @@       forM_ specialValues \(reason, tid, uuid) -> it reason do         case string2ID @TypeID tid of           Left err  -> expectationFailure $ "Parse error: " ++ show err-          Right tid -> V7.toString (KID.getUUID tid) `shouldBe` uuid+          Right tid -> show (getUUID tid) `shouldBe` uuid      describe "TypeID valid JSON instances" do       it "Decode and then encode should be identity" do-        tid  <- TID.genTypeID "mmzk"-        tid' <- TID.genTypeID "foo"+        tid  <- genID @TypeID "mmzk"+        tid' <- genID @TypeID "foo"         let mapping = M.fromList [(tid, tid')]         let json    = encode mapping         decode json `shouldBe` Just mapping-        fmap encode (decode json :: Maybe (Map TypeID TypeID)) `shouldBe` Just json+        fmap encode (decode @(Map TypeID TypeID) json) `shouldBe` Just json       describe "Valid JSON value" do         forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do-          case decode (fromString $ show tid) :: Maybe TypeID of+          case decode @TypeID (fromString $ show tid) of             Nothing  -> expectationFailure "Parse JSON failed!"             Just tid -> do               getPrefix tid `shouldBe` prefix-              V7.toString (KID.getUUID tid) `shouldBe` uuid+              show (getUUID tid) `shouldBe` uuid       describe "Valid JSON key" do         forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do-          case decode (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") :: Maybe (Map TypeID Int) of-            Nothing  -> expectationFailure "Parse JSON failed!"-            Just tid -> do-              let (tid', _) = M.elemAt 0 tid-              getPrefix tid' `shouldBe` prefix-              V7.toString (KID.getUUID tid') `shouldBe` uuid+          case decode @(Map TypeID Int) (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") of+            Nothing      -> expectationFailure "Parse JSON failed!"+            Just mapping -> do+              let (tid, _) = M.elemAt 0 mapping+              getPrefix tid `shouldBe` prefix+              show (getUUID tid) `shouldBe` uuid      describe "TypeID invalid JSON instances" do       describe "Invalid JSON value" do-        forM_ invalid \(TestData name tid _ _) -> it name do -          case decode (fromString $ show tid) :: Maybe TypeID of+        forM_ invalid \(TestData name tid _ _) -> it name do+          case decode @TypeID (fromString $ show tid) of             Nothing  -> pure ()-            Just tid -> expectationFailure $ "Parsed TypeID: " ++ id2String tid+            Just tid -> expectationFailure $ "Parsed TypeID: " ++ show tid       describe "Invalid JSON key" do-        forM_ invalid \(TestData name tid _ _) -> it name do -          case decode (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") :: Maybe (Map TypeID Int) of+        forM_ invalid \(TestData name tid _ _) -> it name do+          case decode @(Map TypeID Int) (fromString $ "{" ++ show tid ++ ":" ++ "114514" ++ "}") of             Nothing  -> pure ()             Just tid -> expectationFailure "Invalid TypeID key shouldn't be parsed!"      describe "Test invalid.json" do-      forM_ invalid \(TestData name tid _ _) -> it name do +      forM_ invalid \(TestData name tid _ _) -> it name do         case string2ID @TypeID tid of           Left _    -> pure ()-          Right tid -> expectationFailure $ "Parsed TypeID: " ++ id2String tid+          Right tid -> expectationFailure $ "Parsed TypeID: " ++ show tid      describe "Test valid.json (TypeID as literal)" do       forM_ valid \(TestData name tid (Just prefix) (Just uuid)) -> it name do@@ -159,40 +190,52 @@           Left err  -> expectationFailure $ "Parse error: " ++ show err           Right tid -> do             getPrefix tid `shouldBe` prefix-            V7.toString (KID.getUUID tid) `shouldBe` uuid+            show (getUUID tid) `shouldBe` uuid      describe "Test valid.json (TypeID as JSON)" do       forM_ validUUID \(TestDataUUID name tid prefix uuid) -> it name do         getPrefix tid `shouldBe` prefix-        KID.getUUID tid `shouldBe` uuid+        getUUID tid `shouldBe` uuid -    describe "Generate type-level TypeID with 'Symbol' prefixes" do-      it "can generate TypeID with prefix" do-        kid <- KID.genKindID @"mmzk"+    describe "Generate type-level TypeID (KindID) with 'Symbol' prefixes" do+      it "can generate KindID with prefix" do+        start <- V7.getEpochMilli+        kid   <- withCheck $ genID @(KindID "mmzk")+        end   <- V7.getEpochMilli         getPrefix kid `shouldBe` "mmzk"-      it "can generate TypeID without prefix" do-        kid <- KID.genKindID @""+        getTime kid `shouldSatisfy` \t -> start <= t && t <= end+      it "can generate KindID without prefix" do+        start <- V7.getEpochMilli+        kid   <- withCheck $ genID @(KindID "")+        end   <- V7.getEpochMilli         getPrefix kid `shouldBe` ""-      it "can parse TypeID from String" do-        case string2ID @(KindID "mmzk") "mmzk_00041061050r3gg28a1c60t3gf" of-          Left err  -> expectationFailure $ "Parse error: " ++ show err-          Right kid -> getPrefix kid `shouldBe` "mmzk"-      it "cannot parse TypeID into wrong prefix" do-        case string2ID @(KindID "foo") "mmzk_00041061050r3gg28a1c60t3gf" of-          Left err  -> pure ()-          Right kid -> expectationFailure $ "Parsed TypeID: " ++ id2String kid-      it "has the correct nil" do-        Right KID.nilKindID `shouldBe` string2ID "00000000000000000000000000"+        getTime kid `shouldSatisfy` \t -> start <= t && t <= end+      it "can generate KindID with stateless UUID v7" do+        start <- V7.getEpochMilli+        kid   <- withCheck $ genID' @(KindID "mmzk")+        end   <- V7.getEpochMilli+        getPrefix kid `shouldBe` "mmzk"       it "can generate in batch with same timestamp and in ascending order" do-        kids <- KID.genKindIDs @"mmzk" 1526+        start <- V7.getEpochMilli+        kids  <- withChecks $ genIDs @(KindID "mmzk") 1526+        end   <- V7.getEpochMilli         all ((== "mmzk") . getPrefix) kids `shouldBe` True         let timestamp = getTime $ head kids         all ((== timestamp) . getTime) kids `shouldBe` True         all (uncurry (<)) (zip kids $ tail kids) `shouldBe` True-  +        timestamp `shouldSatisfy` \t -> start <= t && t <= end+      it "can parse KindID from String" do+        case string2ID @(KindID "mmzk") "mmzk_00041061050r3gg28a1c60t3gf" of+          Left err  -> expectationFailure $ "Parse error: " ++ show err+          Right kid -> getPrefix kid `shouldBe` "mmzk"+      it "cannot parse KindID into wrong prefix" do+        case string2ID @(KindID "foo") "mmzk_00041061050r3gg28a1c60t3gf" of+          Left err  -> pure ()+          Right kid -> expectationFailure $ "Parsed TypeID: " ++ show kid+     describe "Generate type-level TypeID with custom data kind prefixes" do       it "can generate TypeID with prefix" do-          kid <- KID.genKindID @'Post+          kid <- withCheck $ genID @(KindID 'Post)           getPrefix kid `shouldBe` "post"       it "can parse TypeID from String" do         case string2ID @(KindID User) "user_00041061050r3gg28a1c60t3gf" of@@ -201,9 +244,9 @@       it "cannot parse TypeID into wrong prefix" do         case string2ID @(KindID Comment) "user_00041061050r3gg28a1c60t3gf" of           Left err  -> pure ()-          Right kid -> expectationFailure $ "Parsed TypeID: " ++ id2String kid+          Right kid -> expectationFailure $ "Parsed TypeID: " ++ show kid       it "can generate in batch with same timestamp and in ascending order" do-        kids <- KID.genKindIDs @'Comment 1526+        kids <- withChecks $ genIDs @(KindID 'Comment) 1526         all ((== "comment") . getPrefix) kids `shouldBe` True         let timestamp = getTime $ head kids         all ((== timestamp) . getTime) kids `shouldBe` True