Update KindID prefix rules to match spec v0.3

src/Data/KindID/Class.hs

@@ -16,8 +16,13 @@ module Data.KindID.Class
   , ToPrefix(..)
   -- * Helpers
   , LengthSymbol
-  , IsLowerSymbol
   , IsLowerChar
+  , IsUnderscore
+  , IsLUSymbol
+  , ILUSUH1
+  , ILUSUH2
+  -- * Deprecated Helpers
+  , IsLowerSymbol
   , LSUH
   , ILSUH
   ) where
@@ -27,33 +32,6 @@ 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.KindID' prefixes.
@@ -86,3 +64,59 @@ class ToPrefix a where
 -- | The 'PrefixSymbol' of a 'Symbol' is the 'Symbol' itself.
 instance ToPrefix (a :: Symbol) where
   type PrefixSymbol a = a
+
+
+-- | A constraint for valid prefix 'Symbol's.
+type ValidPrefix prefix = ( KnownSymbol prefix
+                          , LengthSymbol prefix < 64
+                          , IsLUSymbol prefix ~ 'True )
+
+-- | 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; will be removed in the next major version" #-}
+
+-- | 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; will be removed in the next major version" #-}

test/Spec.hs

@@ -50,16 +50,16 @@ data TestDataUUID tid = TestDataUUID { name   :: String
                                      , uuid   :: UUID }
   deriving (Generic, FromJSON, ToJSON)
 
-data Prefix = User | Post | Comment
+data Prefix = User | Post | SuperUser
 
 instance ToPrefix 'User where
   type PrefixSymbol 'User = "user"
 
 instance ToPrefix 'Post where
   type PrefixSymbol 'Post = "post"
 
-instance ToPrefix 'Comment where
-  type PrefixSymbol 'Comment = "comment"
+instance ToPrefix 'SuperUser where
+  type PrefixSymbol 'SuperUser = "super_user"
 
 anyTypeIDError :: Selector TypeIDError
 anyTypeIDError = const True
@@ -273,16 +273,16 @@ v7Test = do
         kid <- withCheck $ genID @(KindID 'Post)
         getPrefix kid `shouldBe` "post"
     it "can parse KindID from String" do
-      case string2ID @(KindID 'User) "user_00041061050r3gg28a1c60t3gf" of
+      case string2ID @(KindID 'SuperUser) "super_user_00041061050r3gg28a1c60t3gf" of
         Left err  -> expectationFailure $ "Parse error: " ++ show err
-        Right kid -> getPrefix kid `shouldBe` "user"
+        Right kid -> getPrefix kid `shouldBe` "super_user"
     it "cannot parse KindID into wrong prefix" do
-      case string2ID @(KindID 'Comment) "user_00041061050r3gg28a1c60t3gf" of
+      case string2ID @(KindID 'User) "super_user_00041061050r3gg28a1c60t3gf" of
         Left _    -> pure ()
         Right kid -> expectationFailure $ "Parsed KindID: " ++ show kid
     it "can generate in batch with same timestamp and in ascending order" do
-      kids <- withChecks $ genIDs @(KindID 'Comment) 32768
-      all ((== "comment") . getPrefix) kids `shouldBe` True
+      kids <- withChecks $ genIDs @(KindID 'User) 32768
+      all ((== "user") . getPrefix) kids `shouldBe` True
       let timestamp = getTime $ head kids
       all ((== timestamp) . getTime) kids `shouldBe` True
       all (uncurry (<)) (zip kids $ tail kids) `shouldBe` True
@@ -472,11 +472,11 @@ v1Test = do
         kid <- withCheck $ genID @(KindID 'Post)
         getPrefix kid `shouldBe` "post"
     it "can parse KindIDV1 from String" do
-      case string2ID @(KindIDV1 'User) "user_00041061050r3gg28a1c60t3gf" of
+      case string2ID @(KindIDV1 'SuperUser) "super_user_00041061050r3gg28a1c60t3gf" of
         Left err  -> expectationFailure $ "Parse error: " ++ show err
-        Right kid -> getPrefix kid `shouldBe` "user"
+        Right kid -> getPrefix kid `shouldBe` "super_user"
     it "cannot parse KindIDV1 into wrong prefix" do
-      case string2ID @(KindIDV1 'Comment) "user_00041061050r3gg28a1c60t3gf" of
+      case string2ID @(KindIDV1 'User) "post_00041061050r3gg28a1c60t3gf" of
         Left _    -> pure ()
         Right kid -> expectationFailure $ "Parsed KindIDV1: " ++ show kid
 
@@ -668,11 +668,11 @@ v4Test = do
         kid <- withCheck $ genID @(KindID 'Post)
         getPrefix kid `shouldBe` "post"
     it "can parse KindIDV4 from String" do
-      case string2ID @(KindIDV4 'User) "user_00041061050r3gg28a1c60t3gf" of
+      case string2ID @(KindIDV4 'SuperUser) "super_user_00041061050r3gg28a1c60t3gf" of
         Left err  -> expectationFailure $ "Parse error: " ++ show err
-        Right kid -> getPrefix kid `shouldBe` "user"
+        Right kid -> getPrefix kid `shouldBe` "super_user"
     it "cannot parse KindIDV4 into wrong prefix" do
-      case string2ID @(KindIDV4 'Comment) "user_00041061050r3gg28a1c60t3gf" of
+      case string2ID @(KindIDV4 'User) "post_00041061050r3gg28a1c60t3gf" of
         Left _    -> pure ()
         Right kid -> expectationFailure $ "Parsed KindIDV4: " ++ show kid
 
@@ -733,11 +733,11 @@ v5Test = do
         Left err  -> expectationFailure $ "Parse error: " ++ show err
         Right tid -> getPrefix tid `shouldBe` "mmzk"
     it "can parse TypeIDV5 from Text" do
-      case text2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of
+      case text2ID @TypeIDV5 "mmzk_00041061050r3gg28a1c60t3gf" of
         Left err  -> expectationFailure $ "Parse error: " ++ show err
         Right tid -> getPrefix tid `shouldBe` "mmzk"
     it "can parse TypeIDV5 from ByteString" do
-      case byteString2ID @TypeID "mmzk_00041061050r3gg28a1c60t3gf" of
+      case byteString2ID @TypeIDV5 "mmzk_00041061050r3gg28a1c60t3gf" of
         Left err  -> expectationFailure $ "Parse error: " ++ show err
         Right tid -> getPrefix tid `shouldBe` "mmzk"
 
@@ -863,11 +863,11 @@ v5Test = do
         kid <- withCheck $ genID @(KindID 'Post)
         getPrefix kid `shouldBe` "post"
     it "can parse KindIDV5 from String" do
-      case string2ID @(KindIDV5 'User) "user_00041061050r3gg28a1c60t3gf" of
+      case string2ID @(KindIDV5 'SuperUser) "super_user_00041061050r3gg28a1c60t3gf" of
         Left err  -> expectationFailure $ "Parse error: " ++ show err
-        Right kid -> getPrefix kid `shouldBe` "user"
+        Right kid -> getPrefix kid `shouldBe` "super_user"
     it "cannot parse KindIDV5 into wrong prefix" do
-      case string2ID @(KindIDV5 'Comment) "user_00041061050r3gg28a1c60t3gf" of
+      case string2ID @(KindIDV5 'User) "post_00041061050r3gg28a1c60t3gf" of
         Left _    -> pure ()
         Right kid -> expectationFailure $ "Parsed KindIDV5: " ++ show kid