mmzk-typeid 0.6.3.1 → 0.7.0.0
raw patch · 7 files changed
+171/−95 lines, 7 files
Files
- CHANGELOG.md +7/−2
- mmzk-typeid.cabal +3/−1
- src/Data/KindID/Class.hs +19/−74
- src/Data/KindID/Error.hs +124/−0
- src/Data/KindID/Internal.hs +6/−6
- src/Data/TypeID/Error.hs +6/−8
- src/Data/TypeID/Internal.hs +6/−4
CHANGELOG.md view
@@ -1,9 +1,14 @@ # Revision history for mmzk-typeid -## 0.7.0.0 -- Unreleased+## 0.7.0.0 -- 2024-07-03 -* Use `String`s instead of `Text`s inside the constructors of `TypeIDError` so that it is eaiser to use the promoted constructors.+* Use `String`s instead of `Text`s inside the constructors of `TypeIDError` so that it is easier to use the promoted constructors.++* More complete compile-time error messages for `KindID` errors.++* Hide away internal type-level programming details from Haddock.+ * Many of the type-level helper declarations are now internal. ## 0.6.3.1 -- 2024-06-23
mmzk-typeid.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: mmzk-typeid-version: 0.6.3.1+version: 0.7.0.0 synopsis: A TypeID and UUIDv7 implementation for Haskell description:@@ -74,6 +74,7 @@ Data.UUID.V7, Data.UUID.Versions other-modules:+ Data.KindID.Error, Data.KindID.Internal, Data.TypeID.Internal default-extensions:@@ -119,6 +120,7 @@ other-modules: Data.KindID, Data.KindID.Class,+ Data.KindID.Error, Data.KindID.Internal, Data.KindID.Unsafe, Data.KindID.V1,
src/Data/KindID/Class.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} -- |@@ -14,25 +15,16 @@ -- * Prefix ValidPrefix , ToPrefix(..)- -- * Helpers- , LengthLT64C- , IsLUSymbolC- , LengthSymbol- , IsLowerChar- , IsUnderscore- , IsLUSymbol- , ILUSUH1- , ILUSUH2- -- * Deprecated Helpers- , IsLowerSymbol- , LSUH- , ILSUH ) where +#ifndef __HADDOCK_VERSION__ import Data.Kind+import Data.KindID.Error import Data.Type.Bool import Data.Type.Equality import Data.Type.Ord+import Data.TypeID.Error+#endif import GHC.TypeLits -- | A class that translates any kind to a 'Symbol'. It is used to translate@@ -66,6 +58,7 @@ -- > commentID <- genKindID @'Comment -- Same as genKindID @"comment" -- > suID <- genKindID @'SuperUser -- Same as genKindID @"super_user" class ToPrefix a where+ -- | The associated type family that converts @a@ into a 'Symbol'. type PrefixSymbol a :: Symbol -- | The 'PrefixSymbol' of a 'Symbol' is the 'Symbol' itself.@@ -73,76 +66,28 @@ type PrefixSymbol s = s -- | A constraint for valid prefix 'Symbol's.+--+#ifndef __HADDOCK_VERSION__ type ValidPrefix prefix = ( KnownSymbol prefix , LengthLT64C prefix , IsLUSymbolC prefix )+#else+-- Note that this is __NOT__ the actual definition! Its true definition is+-- hidden here in the documentation as it uses internal type-level helpers that+-- we do not expose and make no guarantee on their In practice, any prefix with+-- this constraint is a valid prefix for a 'Data.KindID.KindID'.+type ValidPrefix prefix = KnownSymbol prefix+#endif +#ifndef __HADDOCK_VERSION__ -- | Contains a custom error message if the prefix 'Symbol' is too long. type family LengthLT64C (prefix :: Symbol) :: Constraint where LengthLT64C s = If (Compare (LengthSymbol s) 64 == 'LT) (() :: Constraint)- ( TypeError ( Text "The prefix "- :<>: ShowType s- :<>: Text " with "- :<>: ShowType (LengthSymbol s)- :<>: Text " characters is too long!" ) )+ (TypeError (ToErrorMessage ('TypeIDErrorPrefixTooLong (Sym2Str s)))) -- | Contains a custom error message if the prefix 'Symbol' is not lowercase + -- underscore or it starts or ends with underscores. type family IsLUSymbolC (prefix :: Symbol) :: Constraint where- IsLUSymbolC s- = If (IsLUSymbol s) (() :: Constraint)- ( TypeError ( Text "The prefix "- :<>: ShowType s- :<>: Text " is not valid!" ) )---- | The length of a 'Symbol' as a 'Nat'.-type family LengthSymbol (prefix :: Symbol) :: Nat where- LengthSymbol prefix = LSUH (UnconsSymbol prefix)---- | LengthSymbol 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' lowercase?-type family IsLowerChar (ch :: Char) :: Bool where- IsLowerChar ch = Compare '`' ch == 'LT && Compare ch '{' == 'LT---- | Is a type-level 'Char' an underscore?-type family IsUnderscore (ch :: Char) :: Bool where- IsUnderscore ch = Compare '_' ch == 'EQ---- | Is a 'Symbol' lowercase + underscore and not start or end with underscores?-type family IsLUSymbol (prefix :: Symbol) :: Bool where- IsLUSymbol prefix = ILUSUH1 (UnconsSymbol prefix)---- | First IsLUSymbol Uncons Helper.-type family ILUSUH1 (uncons :: Maybe (Char, Symbol)) :: Bool where- ILUSUH1 'Nothing = True- ILUSUH1 ('Just '( '_', _ )) = False- ILUSUH1 ('Just '( c, s )) = (IsLowerChar c || IsUnderscore c)- && ILUSUH2 (UnconsSymbol s)---- | Second IsLUSymbol Uncons Helper.-type family ILUSUH2 (uncons :: Maybe (Char, Symbol)) :: Bool where- ILUSUH2 'Nothing = True- ILUSUH2 ('Just '( c, "" )) = IsLowerChar c- ILUSUH2 ('Just '( c, s )) = (IsLowerChar c || IsUnderscore c)- && ILUSUH2 (UnconsSymbol s)-------------------------------------------------------------------------------------- Deprecated------------------------------------------------------------------------------------- | Is a 'Symbol' lowercase?-type family IsLowerSymbol (prefix :: Symbol) :: Bool where- IsLowerSymbol prefix = ILSUH (UnconsSymbol prefix)-{-# DEPRECATED IsLowerSymbol "No longer used; to be removed in version 0.7" #-}---- | Is LowerSymbol Uncons Helper.-type family ILSUH (uncons :: Maybe (Char, Symbol)) :: Bool where- ILSUH 'Nothing = 'True- ILSUH ('Just '( c, s )) = IsLowerChar c && IsLowerSymbol s-{-# DEPRECATED ILSUH "No longer used; to be removed in the version 0.7" #-}+ IsLUSymbolC s = BuildTypeIDErrorConstraint (IsLUSymbol s)+#endif
+ src/Data/KindID/Error.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE UndecidableInstances #-}++-- | An internal module to provide better compilation errors for invalid+-- 'Data.KindID.V7.KindID' prefixes.+--+module Data.KindID.Error where++import Data.Kind+import Data.TypeID.Error+import Data.Type.Bool+import Data.Type.Equality+import Data.Type.Ord+import GHC.TypeLits++-- | A class that covnerts a poly-kind into an "ErrorMessage".+--+-- Used for converting type-level "TypeIDError"s into custom compile-time error+-- messages.+class ToErrorMessageC (e :: k) where+ type ToErrorMessage e :: ErrorMessage++instance ToErrorMessageC (TypeIDErrorPrefixTooLong t) where+ type ToErrorMessage (TypeIDErrorPrefixTooLong t) =+ Text "The prefix "+ :<>: ShowType (Str2Sym t)+ :<>: Text " with "+ :<>: ShowType (LengthSymbol (Str2Sym t))+ :<>: Text " characters is too long!"++instance ToErrorMessageC TypeIDExtraSeparator where+ type ToErrorMessage TypeIDExtraSeparator = Text+ "The underscore separator should not be present if the prefix is empty!"++instance ToErrorMessageC (TypeIDStartWithUnderscore t) where+ type ToErrorMessage (TypeIDStartWithUnderscore t) =+ Text "The prefix "+ :<>: ShowType (Str2Sym t)+ :<>: Text " should not start with an underscore!"++instance ToErrorMessageC (TypeIDEndWithUnderscore t) where+ type ToErrorMessage (TypeIDEndWithUnderscore t) =+ Text "The prefix "+ :<>: ShowType (Str2Sym t)+ :<>: Text " should not end with an underscore!"++instance ToErrorMessageC (TypeIDErrorPrefixInvalidChar t c) where+ type ToErrorMessage (TypeIDErrorPrefixInvalidChar t c) =+ Text "The prefix "+ :<>: ShowType (Str2Sym t)+ :<>: Text " contains invalid character "+ :<>: ShowType c+ :<>: Text "!"++type family Str2Sym (str :: String) :: Symbol where+ Str2Sym '[] = ""+ Str2Sym (c ': cs) = ConsSymbol c (Str2Sym cs)++type family Sym2Str (str :: Symbol) :: String where+ Sym2Str s = SSUH (UnconsSymbol s)++type family SSUH (uncons :: Maybe (Char, Symbol)) :: String where+ SSUH Nothing = '[]+ SSUH (Just '( c, s )) = c ': Sym2Str s++-- | The length of a 'Symbol' as a 'Nat'.+type family LengthSymbol (prefix :: Symbol) :: Nat where+ LengthSymbol prefix = LSUH (UnconsSymbol prefix)++-- | LengthSymbol 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' lowercase?+type family IsLowerChar (ch :: Char) :: Bool where+ IsLowerChar ch = Compare '`' ch == 'LT && Compare ch '{' == 'LT++-- | Is a type-level 'Char' an underscore?+type family IsUnderscore (ch :: Char) :: Bool where+ IsUnderscore ch = Compare '_' ch == 'EQ++-- | Is a 'Symbol' lowercase + underscore and not start or end with underscores?+--+-- ''Nothing' if no error; otherwise ''Just' a 'TypeIDError'.+type family IsLUSymbol (prefix :: Symbol) :: Maybe TypeIDError where+ IsLUSymbol "_" = 'Just 'TypeIDExtraSeparator+ IsLUSymbol prefix = ILUSUH1 (UnconsSymbol prefix) prefix++-- | First IsLUSymbol Uncons Helper.+type family ILUSUH1 (uncons :: Maybe (Char, Symbol)) (prefix :: Symbol)+ :: Maybe TypeIDError where+ ILUSUH1 'Nothing s = 'Nothing+ ILUSUH1 ('Just '( '_', _ )) s = 'Just+ (TypeIDStartWithUnderscore (Sym2Str s))+ ILUSUH1 ('Just '( c, r )) s =+ WrapMaybe (IsLowerChar c || IsUnderscore c)+ (TypeIDErrorPrefixInvalidChar (Sym2Str s) c)+ <|> ILUSUH2 (UnconsSymbol r) s++-- | Second IsLUSymbol Uncons Helper.+type family ILUSUH2 (uncons :: Maybe (Char, Symbol)) (prefix :: Symbol)+ :: Maybe TypeIDError where+ ILUSUH2 'Nothing s = 'Nothing+ ILUSUH2 ('Just '( '_', "" )) s = 'Just (TypeIDEndWithUnderscore (Sym2Str s))+ ILUSUH2 ('Just '( c, r )) s =+ WrapMaybe (IsLowerChar c || IsUnderscore c)+ (TypeIDErrorPrefixInvalidChar (Sym2Str s) c)+ <|> ILUSUH2 (UnconsSymbol r) s++-- | @wrapMaybe True _ = Nothing; wrapMaybe False x = Just x@.+type family WrapMaybe p a where+ WrapMaybe True a = 'Nothing+ WrapMaybe False a = 'Just a++-- | Type-level '(<|>)' for 'Maybe'.+type family (<|>) a b where+ 'Just a <|> b = 'Just a+ Nothing <|> b = b++-- | Turn a type-level 'Maybe' 'TypeIDError' into a 'TypeError'.+type family BuildTypeIDErrorConstraint (a :: Maybe TypeIDError)+ :: Constraint where+ BuildTypeIDErrorConstraint 'Nothing = ()+ BuildTypeIDErrorConstraint ('Just e) = TypeError (ToErrorMessage e)
src/Data/KindID/Internal.hs view
@@ -458,8 +458,8 @@ tid <- TID.parseString str case fromTypeID tid of Nothing -> Left $ TypeIDErrorPrefixMismatch- (T.pack (symbolVal (Proxy @(PrefixSymbol prefix))))- (getPrefix tid)+ (symbolVal (Proxy @(PrefixSymbol prefix)))+ (T.unpack $ getPrefix tid) Just kid -> pure kid {-# INLINE parseString #-} @@ -472,8 +472,8 @@ tid <- TID.parseText str case fromTypeID tid of Nothing -> Left $ TypeIDErrorPrefixMismatch- (T.pack (symbolVal (Proxy @(PrefixSymbol prefix))))- (getPrefix tid)+ (symbolVal (Proxy @(PrefixSymbol prefix)))+ (T.unpack $ getPrefix tid) Just kid -> pure kid {-# INLINE parseText #-} @@ -486,8 +486,8 @@ tid <- TID.parseByteString str case fromTypeID tid of Nothing -> Left $ TypeIDErrorPrefixMismatch- (T.pack (symbolVal (Proxy @(PrefixSymbol prefix))))- (getPrefix tid)+ (symbolVal (Proxy @(PrefixSymbol prefix)))+ (T.unpack $ getPrefix tid) Just kid -> pure kid {-# INLINE parseByteString #-}
src/Data/TypeID/Error.hs view
@@ -13,8 +13,6 @@ ) where import Control.Exception-import Data.Text (Text)-import qualified Data.Text as T -- | Errors from parsing TypeIDs. --@@ -22,18 +20,18 @@ -- exact output format may differ across library versions. data TypeIDError = -- | The prefix is longer than 63 characters.- TypeIDErrorPrefixTooLong Text+ TypeIDErrorPrefixTooLong String -- | The ID contains an extra underscore separator. | TypeIDExtraSeparator -- | The ID starts with an underscore separator.- | TypeIDStartWithUnderscore Text+ | TypeIDStartWithUnderscore String -- | The ID ends with an underscore separator.- | TypeIDEndWithUnderscore Text+ | TypeIDEndWithUnderscore String -- | The prefix contains an invalid character, namely not lowercase Latin.- | TypeIDErrorPrefixInvalidChar Text Char+ | TypeIDErrorPrefixInvalidChar String Char -- | From a 'Data.KindID.V7KindID' conversion. The prefix doesn't match with -- the expected.- | TypeIDErrorPrefixMismatch Text Text+ | TypeIDErrorPrefixMismatch String String -- | The 'Data.UUID.Types.Internal.UUID' suffix has errors. | TypeIDErrorUUIDError deriving (Eq, Ord)@@ -42,7 +40,7 @@ show :: TypeIDError -> String show (TypeIDErrorPrefixTooLong txt) = concat [ "The prefix ", show txt- , " with ", show (T.length txt), " characters is too long!" ]+ , " with ", show (length txt), " characters is too long!" ] show TypeIDExtraSeparator = "The underscore separator should not be present if the prefix is empty!" show (TypeIDStartWithUnderscore txt)
src/Data/TypeID/Internal.hs view
@@ -543,16 +543,18 @@ -- | Check if the given prefix is a valid 'TypeID'' prefix. checkPrefix :: Text -> Maybe TypeIDError checkPrefix prefix- | T.length prefix > 63 = Just $ TypeIDErrorPrefixTooLong prefix+ | T.length prefix > 63 = Just $ TypeIDErrorPrefixTooLong prefixStr | T.null prefix = Nothing- | T.head prefix == '_' = Just $ TypeIDStartWithUnderscore prefix- | T.last prefix == '_' = Just $ TypeIDEndWithUnderscore prefix+ | T.head prefix == '_' = Just $ TypeIDStartWithUnderscore prefixStr+ | T.last prefix == '_' = Just $ TypeIDEndWithUnderscore prefixStr | otherwise = case T.uncons ( T.dropWhile ( liftM2 (||) (== '_') $ liftM2 (&&) isLower isAscii) prefix) of Nothing -> Nothing- Just (c, _) -> Just $ TypeIDErrorPrefixInvalidChar prefix c+ Just (c, _) -> Just $ TypeIDErrorPrefixInvalidChar prefixStr c+ where+ prefixStr = T.unpack prefix {-# INLINE checkPrefix #-} -- | Check if the prefix is valid and the suffix 'UUID' has the correct v7