diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for named-text +## 1.2.3.0 -- 2026-03-10 + +* Added CaseInsensitivePreserve style, which functions similarly to + CaseInsensitive style in that it performs comparisons in a case insensitive + manner, but it stores and divulges the text in the original case. + ## 1.2.2.0 -- 2024-10-26 * Allow building with GHC 9.12. diff --git a/Data/Name.hs b/Data/Name.hs --- a/Data/Name.hs +++ b/Data/Name.hs @@ -143,6 +143,7 @@ -- * Case Insensitive Names , CaseInsensitive + , CaseInsensitivePreserve -- * Secure Names , Secure @@ -161,7 +162,8 @@ ) where -import Data.Hashable ( Hashable ) +import Data.Function ( on ) +import Data.Hashable ( Hashable, hash ) import Data.Proxy ( Proxy(Proxy) ) import Data.String ( IsString(fromString) ) import Data.Text ( Text ) @@ -390,8 +392,13 @@ -- * CaseInsensitive Named objects -- | The CaseInsensitive style of Named objects will allow case-insensitive ASCII --- comparisons between objects. On creation, all text is converted to lowercase, --- so the original input case is not preserved on extraction or rendering. +-- comparisons between objects. +-- +-- On creation, all text is converted to lowercase, so the original input case is +-- not preserved on extraction or rendering. This helps ensure that any +-- comparisons or substitutions outside of the Named object maintain the +-- "equality" perspective of the names; if the original casing should be +-- preserved, see 'CaseInsensitivePreserve' instead. type CaseInsensitive = "CaseInsensitive" :: NameStyle @@ -419,6 +426,48 @@ deriving instance Eq (Named CaseInsensitive nameOf) deriving instance Ord (Named CaseInsensitive nameOf) deriving instance Hashable (Named CaseInsensitive nameOf) + +---------------------------------------------------------------------- +-- * CaseInsensitivePreserve Named objects + +-- | The CaseInsensitivePreserve style of Named objects will allow +-- case-insensitive ASCII comparisons between objects, but only for the Named +-- objects. +-- +-- On creation, the original case of the text is preserved, but the Eq and Ord +-- instances for this style will ignore case when making their determination. +-- This only holds for the Named object: the extracted text will be in the +-- original case and naieve equality or ordinal comparisons of the extracted text +-- will not have the same case-insensitive results; for a more orthogonal +-- handling, see the 'CaseInsensitive' style. + +type CaseInsensitivePreserve = "CaseInsensitive/Preserve" :: NameStyle + +instance {-# OVERLAPPING #-} IsString (Named CaseInsensitivePreserve nameOf) where + fromString = Named . fromString + +instance KnownSymbol ty => PP.Pretty (Named CaseInsensitivePreserve ty) where + pretty nm = (PP.pretty $ nameOf nm proxy#) + <+> PP.surround (PP.pretty (nameText nm)) "«" "»" + +instance NameText CaseInsensitivePreserve + + +instance ConvertNameStyle UTF8 CaseInsensitivePreserve nameTy +instance ConvertNameStyle CaseInsensitivePreserve UTF8 nameTy + +instance ConvertNameStyle CaseInsensitive CaseInsensitivePreserve nameTy +-- No ConvertNameStyle is defined for CaseInsensitivePreserve -> +-- CaseInsensitivePreserve because this cannot be round-tripped. + +instance Eq (Named CaseInsensitivePreserve nameOf) where + (==) = (==) `on` (T.toLower . nameText) + +instance Ord (Named CaseInsensitivePreserve nameOf) where + compare = compare `on` (T.toLower . nameText) + +instance Hashable (Named CaseInsensitivePreserve nameOf) where + hash = hash . T.toLower . nameText ---------------------------------------------------------------------- diff --git a/Data/Name/JSON.hs b/Data/Name/JSON.hs --- a/Data/Name/JSON.hs +++ b/Data/Name/JSON.hs @@ -51,7 +51,10 @@ instance ConvertNameStyle JSONStyle CaseInsensitive nameOf instance ConvertNameStyle CaseInsensitive JSONStyle nameOf +instance ConvertNameStyle JSONStyle CaseInsensitivePreserve nameOf +instance ConvertNameStyle CaseInsensitivePreserve JSONStyle nameOf + -- -- The generic instance results in an object: { "name": "..." } This -- -- instance declaration avoids that and causes the JSON form to be a simple -- -- string. Currently there's no FromJSON, although it's likely the generic @@ -93,3 +96,16 @@ instance FromJSONKey (Named CaseInsensitive nameTy) where fromJSONKey = convertStyle @JSONStyle @CaseInsensitive <$> fromJSONKey + + +instance ToJSON (Named CaseInsensitivePreserve nameTy) where + toJSON = toJSON . convertStyle @CaseInsensitivePreserve @JSONStyle + +instance ToJSONKey (Named CaseInsensitivePreserve nameTy) where + toJSONKey = convertStyle @CaseInsensitivePreserve @JSONStyle >$< toJSONKey + +instance FromJSON (Named CaseInsensitivePreserve nameTy) where + parseJSON j = convertStyle @JSONStyle @CaseInsensitivePreserve . fromString <$> parseJSON j + +instance FromJSONKey (Named CaseInsensitivePreserve nameTy) where + fromJSONKey = convertStyle @JSONStyle @CaseInsensitivePreserve <$> fromJSONKey diff --git a/named-text.cabal b/named-text.cabal --- a/named-text.cabal +++ b/named-text.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: named-text -version: 1.2.2.0 +version: 1.2.3.0 synopsis: A parameterized named text type and associated functionality. description: . diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -65,6 +65,7 @@ => TestShow (Named s n) where testShow = sez @"test" instance TestShow (Proxy UTF8) where testShow _ = "Proxy :: \"UTF8\"" instance TestShow (Proxy CaseInsensitive) where testShow _ = "Proxy :: !Case" +instance TestShow (Proxy CaseInsensitivePreserve) where testShow _ = "Proxy :: !Case+Preserved" instance TestShow (Proxy Secure) where testShow _ = "Proxy :: Secure" instance TestShow [SomeName] where testShow = testShowList instance TestShow SomeName where testShow = viewSomeName testShow @@ -156,7 +157,29 @@ :> Val "security bypass text" secureNameBypass ("z" :: Text) ) + it "CR8 creates CaseInsensitivePreserve from IsText" $ + withChecklist "CR8" $ + fromText @(Named CaseInsensitivePreserve "CR8") ("Test teXT" :: Text) + `checkValues` + (Empty + :> Val "overloaded equivalent text value" id "tesT tExt" + :> Val "name parameter value" (\n -> nameOf n proxy#) "CR8" + :> Val "style proxy" styleProxy (Proxy :: Proxy CaseInsensitivePreserve) + :> Val "extracted text" nameText ("Test teXT" :: Text) + ) + it "CR9 creates CaseInsensitivePreserve from IsString" $ + withChecklist "CR9" $ + fromString @(Named CaseInsensitivePreserve "CR9") ("TEst STring" :: String) + `checkValues` + (Empty + :> Val "overloaded equivalent string value" id "teST sTring" + :> Val "name parameter value" (\n -> nameOf n proxy#) "CR9" + :> Val "style proxy" styleProxy (Proxy :: Proxy CaseInsensitivePreserve) + :> Val "extracted text" nameText ("TEst STring" :: Text) + ) + + testRender :: IO TestTree testRender = testSpec "Named Rendering" $ describe "rendering of Named" $ do @@ -245,7 +268,32 @@ :> Val "as sayable info" (sez @"info") "########" ) + it "CR13 render CaseInsensitive via Sayable" $ + withChecklist "CR13" $ + ("tEST TeXt" :: Named CaseInsensitive "CR13") + `checkValues` + (Empty + :> Val "as sayable" (sez @"test") "CR13 «test text»" + :> Val "as sayable info" (sez @"info") "test text" + ) + it "CR19.1 render CaseInsensitivePreserve via Prettyprinter" $ + withChecklist "CR19.1" $ + fromText @(Named CaseInsensitivePreserve "CR19.1") ("test OF text" :: Text) + `checkValues` + (Empty + :> Val "as pretty" (show . PP.pretty) "CR19.1 «test OF text»" + ) + + it "CR19.2 render CaseInsensitive via Show" $ + withChecklist "CR19.2" $ + fromText @(Named CaseInsensitive "CR19.2") ("TEST OF TEXT" :: Text) + `checkValues` + (Empty + :> Val "as show" show "CR19.2 «test of text»" + ) + + testSemigroup :: IO TestTree testSemigroup = testSpec "Named Semigroup" $ describe "semigroup of Named" $ do @@ -280,6 +328,16 @@ :> Val "as sayable" (sez @"test") "CR22 'mo#########################re'" ) + it "CR23 CaseInsensitivePreserve semigroup" $ + withChecklist "CR23" $ + (fromText @(Named CaseInsensitivePreserve "CR23") ("mORE teST TexT" :: Text) + <> " and STILL more") + `checkValues` + (Empty + :> Val "implicitly constructed full form" id "more test text and still more" + :> Val "as sayable" (sez @"test") "CR23 «mORE teST TexT and STILL more»" + ) + testIsList :: IO TestTree testIsList = testSpec "Named IsList" $ describe "IsList of Named" $ do @@ -295,7 +353,7 @@ :> Val "as list" toList ['l','i','s','t',' ','o','f',' ','t','e','x','t'] ) - -- Note: no IsList instance for CaseInsensitive or Secure + -- Note: no IsList instance for CaseInsensitive or or CaseInsensitivePreserve or Secure testConversions :: IO TestTree testConversions = testSpec "Named Conversions" $ do @@ -354,6 +412,19 @@ :> Val "style proxy" styleProxy (Proxy :: Proxy Secure) ) + it "CR42.1 CaseInsensitivePreserve conversion" $ + withChecklist "CR42.1" $ + (convertName (fromText "biT OF teXt" :: Named CaseInsensitivePreserve "CR42.1") + :: Named CaseInsensitivePreserve "CR42.1 new") + `checkValues` + (Empty + :> Val "matches implicit construction" id "bit of text" + :> Val "as sayable" (sez @"test") "CR42.1 new «biT OF teXt»" + :> Val "as extracted text" nameText "biT OF teXt" + :> Val "nameOf" (\n -> nameOf n proxy#) "CR42.1 new" + :> Val "style proxy" styleProxy (Proxy :: Proxy CaseInsensitivePreserve) + ) + describe "Named style conversions" $ do -- n.b. these tests use the "instance ConvertNameStyle" below. @@ -370,6 +441,19 @@ :> Val "style proxy" styleProxy (Proxy :: Proxy CaseInsensitive) ) + it "CR44.1 UTF8->CaseInsensitivePreserve default conversion" $ + withChecklist "CR44.1" $ + (convertStyle (fromText "Some TEXT" :: Name "CR44.1") + :: Named CaseInsensitivePreserve "CR44.1") + `checkValues` + (Empty + :> Val "matches implicit construction" id "some text" + :> Val "as sayable" (sez @"test") "CR44.1 «Some TEXT»" + :> Val "as extracted text" nameText "Some TEXT" + :> Val "nameOf" (\n -> nameOf n proxy#) "CR44.1" + :> Val "style proxy" styleProxy (Proxy :: Proxy CaseInsensitivePreserve) + ) + it "CR45 UTF8->Secure default conversion" $ withChecklist "CR45" $ (convertStyle (fromText "Some TEXT" :: Name "CR45") :: Named Secure "CR45") @@ -388,13 +472,26 @@ :: Named UTF8 "CR46") `checkValues` (Empty - :> Val "matches implicit construction" id "some text" + :> Val "matches implicit construction" id "some text" -- Note: converted to lowercase :> Val "as sayable" (sez @"test") "CR46 'some text'" :> Val "as extracted text" nameText "some text" :> Val "nameOf" (\n -> nameOf n proxy#) "CR46" :> Val "style proxy" styleProxy (Proxy :: Proxy UTF8) ) + it "CR46.1 CaseInsensitivePreserve->UTF8 default conversion" $ + withChecklist "CR46.1" $ + (convertStyle (fromText "Some TEXT" :: Named CaseInsensitivePreserve "CR46.1") + :: Named UTF8 "CR46.1") + `checkValues` + (Empty + :> Val "matches implicit construction" id "Some TEXT" + :> Val "as sayable" (sez @"test") "CR46.1 'Some TEXT'" + :> Val "as extracted text" nameText "Some TEXT" + :> Val "nameOf" (\n -> nameOf n proxy#) "CR46.1" + :> Val "style proxy" styleProxy (Proxy :: Proxy UTF8) + ) + it "CR47 Secure->UTF8 default conversion" $ withChecklist "CR47" $ (convertStyle (fromText "Some TEXT" :: Named Secure "CR47") :: Name "CR47") @@ -425,6 +522,7 @@ instance ConvertName UTF8 "CR41" "CR41-3" where convertName = fromText . T.map succ . nameText instance ConvertName CaseInsensitive "CR42" "CR42 new" +instance ConvertName CaseInsensitivePreserve "CR42.1" "CR42.1 new" instance ConvertName Secure "CR43" "CR43 again" where convertName = fromText . secureNameBypass @@ -531,6 +629,9 @@ it "CR81 can get a CaseInsensitive length" $ nameLength ("Length of TEXT" :: Named CaseInsensitive "CR81") `shouldBe` 14 + it "CR81.1 can get a CaseInsensitivePreserve length" $ + nameLength ("Length of TEXT" :: Named CaseInsensitivePreserve "CR81.1") `shouldBe` 14 + it "CR82 can get a Secure length" $ nameLength ("Length of secure TEXT" :: Named Secure "CR82") `shouldBe` 21 @@ -545,9 +646,15 @@ it "CR85 can check a null CaseInsensitive named" $ nullName ("" :: Named CaseInsensitive "CR85") `shouldBe` True + it "CR85.1 can check a null CaseInsensitivePreserve named" $ + nullName ("" :: Named CaseInsensitivePreserve "CR85.1") `shouldBe` True + it "CR86 can check a non-null CaseInsensitive named" $ nullName ("Not empty" :: Named CaseInsensitive "CR86") `shouldBe` False + it "CR86.1 can check a non-null CaseInsensitivePreserve named" $ + nullName ("Not empty" :: Named CaseInsensitivePreserve "CR86.1") `shouldBe` False + it "CR87 can check a null Secure named" $ nullName ("" :: Name "CR87") `shouldBe` True @@ -692,7 +799,7 @@ :> Val "decoded" decode (Just obj) ) - it "CR104 JSON of record containing CaseInsensitive Named is not necessarily round-robin" $ + it "CR104 JSON of record containing CaseInsensitive Named is not necessarily round-robin but CaseInsensitivePreserve is" $ withChecklist "CR104" $ let obj = Info "John Henry" "Railroad Worker" "Hammer Master" in encode (toJSON obj) @@ -703,7 +810,8 @@ :> Val "decoded" decode (Just $ obj { title = fromText $ T.toLower $ nameText $ title obj }) ) -data Info = Info { name :: Name "name" + +data Info = Info { name :: Named CaseInsensitivePreserve "name" , title :: Named CaseInsensitive "title" , desc :: Name "description" }