diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Revision history for named-text +## 1.1.0.0 -- 2022-12-28 + +* Added tests and enhanced haddock. +* Re-organized implementation, removing extraneous definitions. +* The `name` and `caselessName` functions are deprecated in favor of `nameText`. +* General, overlappable `Prettyprinter` `Pretty` instance for all `Named`. +* Changed from `Named style sym` to `Named style nameOf`. +* Fixed `convertStyle` to use the proper `fromText` instance. +* Added `NameText` constraint to `viewSomeNameStyle` first argument signature. +* Added `nameLength` and `nullName` utility functions. + ## 1.0.1.0 -- 2022-12-23 * Specific GHC support range for GHC 8.8--9.4 diff --git a/Data/Name.hs b/Data/Name.hs --- a/Data/Name.hs +++ b/Data/Name.hs @@ -1,3 +1,88 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-| + +The 'Data.Name' type is designed to be used in place of plain 'String' or +'Data.Text' types. Fundamentally 'Data.Name' is an extension of 'Data.Text', but +it includes two type-level parameters that help to manage the underlying data: a +style parameter and a nameOf parameter. + + * The style parameter is used to control various functionality and validation + around the contained Text type. For example, one style is CaseInsensitive, + which allows comparisons to be done independently of ASCII case. + + * The nameOf parameter is a phantom type string which ensures that two different + strings aren't inadvertently swapped or combined. Any transformation from one + nameOf to another nameOf must be intentional. + +== Example + +For a more complete example, consider a @login@ form which takes an email as the +username and a password. Without the Data.Name module, the type signature might +be: + +> login :: String -> String -> IO Bool + +There are a number of deficiencies that can be identified for this +implementation, including: + +* Which argument is the email username, which is the password? + +* Is there any protection against simply printing the password to stdout? + +* Can these protections be extended to the code calling @login@ and not just + observed within the @login@ function itself? + +* Email addresses are typically not case sensitive: does the @login@ function + provide the appropriate case handling? + +Using 'Data.Name', the declaration would look more like: + +> login :: Named CaseInsensitive "email" -> Named Secure "password" -> IO Bool + +There are a number of advantages that can be observed here: + +* The arguments are self-identifying. No need to try to remember which was used + for what purpose. + +* The email is treated as a case-insensitive value, both within @login@ but also + automatically in any other uses elsewhere. Setting this value automatically + applies case insensitivity conversions, and comparisons are always case + independent. + +* The password is secured against simply printing it or retrieving the value to + use unsafely elsewhere. There is a special operation to return the actual + underlying Text from a secure name, which will presumably be very carefully + used only by the @login@ implementation itself. + +* Zero runtime cost (other than where needed, such as case translation). + +== Alternatives: + +One typical alternative approach is to use a @newtype@ wrapper around 'Data.Text' +or 'String' to provide the type level safety. This is not a bad approach, but +this module seeks to provide the following additional benefits over a simple +@newtype@: + +* New names do not need a separate declaration, with associated instance + declarations: simply use a new type string. + +* Names are parameterized over both style and identity, with different conversion + abilities for both. Similar functionality could be established for a @newtype@ + but this would result in either a duplication of effort for each new @newtype@ + declared this way, or else a parameterization of a generic @newtype@ in the + same general manner as provided by this module (and 'Data.Name' *is* simply a + @newtype@ at the core). + +Another approach is to use the 'Data.Tagged'. This module is highly similar to +'Data.Tagged', but this module's 'Named' type has two parameters and the +underlying type is always 'Data.Text'. This module can therefore be considered a +specialization of the generic capabilities of 'Data.Tagged' but more customized +for representing textual data. +-} + + {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExplicitNamespaces #-} @@ -18,19 +103,57 @@ {-# LANGUAGE UndecidableInstances #-} module Data.Name - ( type Name - , Named - , name, nameOf, nameProxy, styleProxy, caselessName - , NameStyle, UTF8, CaseInsensitive, Secure - , HasName, myName - , NameText, nameText + ( + -- * Core type + Named + , nameOf + , nameProxy + , styleProxy , SomeName(SomeName), viewSomeName + , HasName, myName + -- ** Style management + -- + -- | Defines the style type parameter and some well-known styles directly + -- supported by this module. Users may define additional styles as needed. + , NameStyle , SomeNameStyle(SomeNameStyle), viewSomeNameStyle - , SecureName, secureName, secureNameBypass + -- ** Creating a Name + -- + -- | The 'Named' type is an instance of 'IsString', so a name can be created + -- from a string via 'fromString'. In addition, this module defines an + -- 'IsText' class with a 'fromText' method that operates in a parallel + -- fashion. , IsText(fromText) + -- ** Conversions , ConvertName(convertName) , ConvertNameStyle(convertStyle) + -- ** Extraction and rendering + -- + -- | For rendering, the 'sayable' package is preferred (as provided by the + -- 'Sayable' instances, which is an extension of the "prettyprinter" package + -- (and users desiring a "prettyprinter" output can extract that from the + -- 'sayable' representation). + , NameText, nameText + + -- * Regular (UTF-8) Names + , UTF8 + , type Name + , name + + -- * Case Insensitive Names + , CaseInsensitive + , caselessName + + -- * Secure Names + , Secure + , SecureName, secureName, secureNameBypass + + -- * Constraining allowed names , ValidNames, validName + + -- * Utility operations + , nameLength + , nullName ) where @@ -47,16 +170,19 @@ import qualified Prettyprinter as PP import Text.Sayable +#if !MIN_VERSION_base(4,16,0) +import Numeric.Natural +#endif --- | The 'Named' is a wrapper around any 'Text' that identifies the type of --- 'Text' via the @sym@ phantom symbol type, as well as a usage specified by the --- @style@ type parameter. Use of 'Named' should always be preferred to using --- a raw 'Text' (or 'String'). +-- | The 'Named' is a wrapper around any 'Data.Text' that identifies the type of +-- 'Data.Text' via the @nameOf@ phantom symbol type, as well as a usage specified +-- by the @style@ type parameter. Use of 'Named' should always be preferred to +-- using a raw 'Data.Text' (or 'String'). -newtype Named (style :: NameStyle) (sym :: Symbol) = - Named { named :: Text } +newtype Named (style :: NameStyle) (nameOf :: Symbol) = Named { named :: Text } deriving (Eq, Ord, Generic, NFData, Semigroup) + -- | The NameStyle specifies how the name itself is styled. -- -- * The 'UTF8' default style is orthogonal to a normal String or Text. @@ -64,189 +190,320 @@ -- * The 'CaseInsensitive' style indicates that uppercase ASCII characters are -- equivalent to their lowercase form. -- --- * The Secure style is case sensitive, but does not reveal the full contents +-- * The 'Secure' style is case sensitive, but does not reveal the full contents -- unless the specific "secureName" accessor function is used. This is useful -- for storing secrets (e.g. passphrases, access tokens, etc.) that should not -- be fully visible in log messages and other miscellaneous output. +-- +-- These styles will be described in more detail below. type NameStyle = Symbol -type UTF8 = "UTF8" :: NameStyle -type CaseInsensitive = "CaseInsensitive" :: NameStyle -type Secure = "SECURE!" :: NameStyle -instance Hashable (Named style sym) +instance Hashable (Named style nameOf) --- | Retrieve the @sym@ type parameter (the "what am I") of a Named as a text +-- | Retrieve the @nameOf@ type parameter (the "what am I") of a Named as a text -- value -nameOf :: KnownSymbol sym => Named style sym -> Proxy# sym -> String + +nameOf :: KnownSymbol nameOf => Named style nameOf -> Proxy# nameOf -> String nameOf _ = symbolVal' -nameProxy :: KnownSymbol sym => Named style sym -> Proxy sym +-- | Retrieve a proxy for the @nameOf@ parameter of 'Named'. + +nameProxy :: KnownSymbol nameOf => Named style nameOf -> Proxy nameOf nameProxy _ = Proxy -styleProxy :: KnownSymbol style => Named style sym -> Proxy style +-- | Retrieve a proxy for the @style@ parameter of 'Named'. + +styleProxy :: KnownSymbol style => Named style nameOf -> Proxy style styleProxy _ = Proxy -instance {-# OVERLAPPABLE #-} IsString (Named style sym) where +instance {-# OVERLAPPABLE #-} IsString (Named style nameOf) where fromString = Named . fromString +-- | The 'IsText' class provides similar functionality to the 'IsString' class, +-- but with 'Data.Text' sources instead of 'String' sources. Defining an +-- instance of this class allows the use of 'fromText' to convert from +-- 'Data.Text' to the target type (which does not necessarily need to be a +-- 'Named' type, and this generic class should be deprecated in favor of a +-- generic implementation the the "text" library). + class IsText a where fromText :: Text -> a -instance {-# OVERLAPPABLE #-} IsText (Named style sym) where +instance {-# OVERLAPPABLE #-} IsText (Named style nameOf) where fromText = Named -class ConvertName style origTy newTy where +-- | Conversion from a 'Named' with one @nameOf@ to a separate @nameOf@ must be +-- done explicitly; the recommended method is via an instance of the +-- 'ConvertName' class, which provides the 'convertName' method to perform the +-- requested conversion. If there should not be a conversion between the two +-- 'Named' types, no 'ConvertName' class should be defined, and users should +-- refrain from providing an alternative explicit function to perform this +-- conversion. + +class NameText style => ConvertName style origTy newTy where convertName :: Named style origTy -> Named style newTy - convertName = fromText . named + convertName = fromText . nameText -class ConvertNameStyle inpStyle outStyle nameTy where + +-- | A 'Named' can be converted from one @style@ to another with an instance of +-- the 'ConvertNameStyle' class. If no conversion should be supported, no +-- instance should be defined. Users are highly recommended to use the +-- convertStyle method (instead of a separate manual conversion function) to +-- ensure proper conversions are performed. + +class ( NameText inpStyle + , IsText (Named outStyle nameTy) + ) + => ConvertNameStyle inpStyle outStyle nameTy where convertStyle :: Named inpStyle nameTy -> Named outStyle nameTy - convertStyle = fromText . named + convertStyle = fromText . nameText --- | For an @"info"@ 'saytag' (and possibly others), a 'Name' doesn't include its --- label. Normally, it shows the label followed by the text itself. The Sayable --- defers to the Prettyprinting instance for actual representation. +-- | A general class that can be used to extract the Text back out of a name. +-- This should be the preferred method of obtaining the raw Text, and should be +-- used carefully as all of the protections provided by this module are no longer +-- available for that raw Text. In addition, no instance of this class is +-- provided where the name should not be extractable, and this method may extract +-- a modified form of the text (e.g. the Secure namestyle will return a masked +-- version of the original Text). + +class NameText style where + -- | nameText is used to retrieve the original 'Data.Text' text from a 'Named' + -- object of the specified style. This should be the main method used to + -- extract the Text from a Named, but it should be used carefully because the + -- protections offered by the 'Named' type will no longer be available for the + -- raw Text. + nameText :: Named style nm -> Text + nameText = named + +-- | Some objects have (contain) an associated name that identifies or labels +-- that object. If they do, they can declare the 'HasName' constraint, and use +-- its 'myName' method to reconstitute the 'Named' from the object. + +class HasName x style nm | x -> style, x -> nm where + -- | myName can be used to extract the associated 'Named' from an object. + myName :: x -> Named style nm + + +---------------------------------------------------------------------- +-- Rendering + +-- | For an @"info"@ @saytag@ (and possibly others), a 'Name' doesn't include its +-- label and simply shows the 'Data.Text' as would be rendered by +-- "prettyprinter". + instance NameText style => Sayable "info" (Named style nm) where sayable = Saying . PP.pretty . nameText + + +-- | Generically the rendered version includes the textual representation of the +-- 'nameOf' parameter followed by the 'Data.Text' itself. + instance {-# OVERLAPPABLE #-} (PP.Pretty (Named style nm) ) => Sayable tag (Named style nm) where sayable = Saying . PP.pretty +-- | There is also a 'Show' method; this is *not* the inverse of a 'Read', and in +-- fact there is no 'Read' instance for 'Named'. The 'Sayable' instance is +-- preferred over 'Show', but 'Show' is provided for default considerations such +-- as test failure reporting. ----------------------------------------------------------------------- +instance (Sayable "show" (Named style nm)) => Show (Named style nm) where + show = sez @"show" --- | The Name type is for the standard/most commonly used style which is --- orthogonal to a normal String or Text. -type Name = Named UTF8 +-- | This is the general pretty rendering for a Named object. This can be +-- overriden for specific types or styles for a different rendering. -name :: Name sym -> Text -name = named +instance {-# OVERLAPPABLE #-} ( KnownSymbol ty + , NameText style + ) + => PP.Pretty (Named style ty) where + pretty nm = (PP.pretty $ nameOf nm proxy#) + <+> PP.squotes (PP.pretty (nameText nm)) -instance IsList (Name s) where - type Item (Name s) = Item Text - fromList = fromText . fromList - toList = toList . name +---------------------------------------------------------------------- +-- Utility operations -instance ConvertName UTF8 a a where convertName = id -instance ConvertName UTF8 "component" "instance component" -instance ConvertName UTF8 "git.branch" "git.branch|ref" -instance ConvertName UTF8 "git.ref" "git.branch|ref" +-- | Returns the length of the underlying 'Data.Text' -instance KnownSymbol ty => PP.Pretty (Name ty) where - pretty nm = (PP.pretty $ nameOf nm proxy#) <+> PP.squotes (PP.pretty (name nm)) +nameLength :: Named style nm -> Natural +nameLength = toEnum . T.length . named +-- | Returns true if the name value is empty. +nullName :: Named style nm -> Bool +nullName = T.null . named + + ---------------------------------------------------------------------- +-- | The 'SomeName' data type is used to existentially hide the identification +-- type parameter for 'Named' objects. This is usually used when names of +-- different types are mixed together in some container or other name-agnostic +-- interface. + data SomeName = forall (s :: Symbol) . KnownSymbol s => SomeName (Name s) + +-- | The 'viewSomeName' function is used to project the 'Named' object with its +-- identification type parameter existentially recovered to a function that will +-- consume that 'Named' object and return some sort of result. + viewSomeName :: (forall (s :: Symbol) . KnownSymbol s => Name s -> r) -> SomeName -> r viewSomeName f (SomeName n) = f n +-- | The 'SomeNameStyle' data type is used to existentially hide the style type +-- of 'Named' objects. This is usually used when names of different styles are +-- mixed together in some container or other style-agnostic interface. + data SomeNameStyle nameTy = forall (s :: Symbol) . (KnownSymbol s, NameText s) => SomeNameStyle (Named s nameTy) -viewSomeNameStyle :: (forall (s :: Symbol) . KnownSymbol s => Named s nameTy -> r) + +-- | The 'viewSomeNameStyle' function is used to project the 'Named' object with +-- its style type existentially recovered to a function that will consume that +-- 'Named' object and return some sort of result. + +viewSomeNameStyle :: (forall (s :: Symbol) . (KnownSymbol s, NameText s) => Named s nameTy -> r) -> SomeNameStyle nameTy -> r viewSomeNameStyle f (SomeNameStyle n) = f n ---------------------------------------------------------------------- +-- * UTF8 Names --- | Some objects have (contain) an associated name. If they do, they can --- declare the HasName constraint, and use myName to reconsistute the name from --- the object. +-- | The UTF8 type alias is useable as the @style@ parameter of a 'Named' type. +-- The type-string form may also be used but the type alias is designed to allow +-- abstraction from the raw type-string value. -class HasName x style nm | x -> style, x -> nm where - myName :: x -> Named style nm +type UTF8 = "UTF8" :: NameStyle +-- | The Name type is for the standard/most commonly used style which is +-- orthogonal to a normal String or Text. Because this is the most frequently +-- used form of 'Named', it has a type alias to shorten the usage references. --- | A general class that can be used to extract the Text back out of a name. +type Name = Named UTF8 -class NameText style where - nameText :: Named style nm -> Text - nameText = named +{-# DEPRECATED name "Use nameText instead" #-} +name :: Name nameOf -> Text +name = nameText + +instance IsList (Name s) where + type Item (Name s) = Item Text + fromList = fromText . fromList + toList = toList . nameText + +instance ConvertName UTF8 a a where convertName = id + instance NameText UTF8 ---------------------------------------------------------------------- +-- * CaseInsensitive Named objects -instance {-# OVERLAPPING #-} IsString (Named CaseInsensitive sym) where +-- | 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. + +type CaseInsensitive = "CaseInsensitive" :: NameStyle + +instance {-# OVERLAPPING #-} IsString (Named CaseInsensitive nameOf) where fromString = Named . T.toLower . fromString -instance {-# OVERLAPPING #-} IsText (Named CaseInsensitive sym) where +instance {-# OVERLAPPING #-} IsText (Named CaseInsensitive nameOf) where fromText = Named . T.toLower instance KnownSymbol ty => PP.Pretty (Named CaseInsensitive ty) where pretty nm = (PP.pretty $ nameOf nm proxy#) <+> PP.surround (PP.pretty (caselessName nm)) "«" "»" -instance NameText CaseInsensitive where - nameText = named +instance NameText CaseInsensitive -caselessName :: Named CaseInsensitive sym -> Text -caselessName = named +{-# DEPRECATED caselessName "Use nameText instead" #-} +caselessName :: Named CaseInsensitive nameOf -> Text +caselessName = nameText ---------------------------------------------------------------------- +-- * Secure Named objects --- | The SecureName is like Name, but its display form does not reveal --- the full name. +-- | The Secure style of Named objects masks the internal text on extraction or +-- rendering to avoid leaking information. The actual internal text can be +-- retrieved only with the explicit 'secureNameBypass' function. +type Secure = "SECURE!" :: NameStyle + +-- | The SecureName is like Name, but its display form does not reveal the full +-- name. The use of the 'nameText' extractor or any of the renderers will +-- occlude a portion of the secure name to avoid revealing it in its entirety. + type SecureName = Named Secure + -- | The secureName accessor is used to obtain the name field from a Secure -- Named. This is the normal accessor for a Secure Named and will occlude a -- portion of the extracted name for protection. For those specific cases where -- the full Secure Named text is needed, the 'secureNameBypass' accessor should -- be used instead. -secureName :: Named Secure sym -> Text +{-# DEPRECATED secureName "Use nameText instead" #-} +secureName :: Named Secure nameOf -> Text secureName nm = if T.length (named nm) < 5 then T.replicate 8 "#" else ((T.take 2 $ named nm) <> T.replicate (T.length (named nm) - 4) "#" <> T.reverse (T.take 2 $ T.reverse $ named nm)) + -- | The secureNameBypass accessor is used to obtain the raw Text from a Secure --- Named; this essentially bypasses the security protection and should only be +-- Named; this essentially BYPASSES THE SECURITY PROTECTION and should only be -- used in the limited cases when the raw form is absolutely needed. -secureNameBypass :: Named Secure sym -> Text +secureNameBypass :: Named Secure nameOf -> Text secureNameBypass = named --- instance NameText Secure sym <-- explicitly not defined! - -instance KnownSymbol ty => PP.Pretty (Named Secure ty) where - pretty nm = (PP.pretty $ nameOf nm proxy#) - <+> PP.squotes (PP.pretty (named nm)) - --- Note that there should be no instance of ToJSON for a SecureName! +instance NameText Secure where + nameText = secureName ---------------------------------------------------------------------- +-- Constraining allowed names + -- | The ValidNames constraint can be used to specify the list of allowed names --- for a parameterized name argument. +-- for a parameterized name argument. For example: +-- +-- > foo :: ValidNames n '[ "right", "correct" ] => Name n -> a +-- +-- The above allows @foo@ to be called with a @Name "right"@ or a @Name +-- "correct"@, but if it is called with any other 'Named' @nameOf@ parameter then +-- a compilation error will be generated indicating "the supplied @nameOf@ type +-- parameter is not in the allowed Names". +-- +-- All instances of this class are pre-defined by this module and the user should +-- not need to create any instances. -class ( KnownNat (AllowedNameType nty ntl) - , DisallowedNameType nty ntl ntl +class ( KnownNat (AllowedNameType nameOf ntl) + , DisallowedNameType nameOf ntl ntl ) - => ValidNames (nty :: Symbol) (ntl :: [Symbol]) where - validName :: Proxy ntl -> Name nty -> Text + => ValidNames (nameOf :: Symbol) (ntl :: [Symbol]) where + -- | The validName method is used to extract the text form of a 'Name' for + -- which @nameOf@ is a member of the valid names specified by the @ntl@ type + -- list. It corresponds to 'nameText' while also providing the validation + -- of the extraction. + validName :: Proxy ntl -> Name nameOf -> Text ---------------------------------------------------------------------- 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.0.1.0 +version: 1.1.0.0 synopsis: A parameterized named text type and associated functionality. description: . @@ -56,3 +56,22 @@ , sayable >= 1.0 && < 1.1 , text exposed-modules: Data.Name + + +test-suite namedTests + import: bldspec + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + build-depends: base + , hspec + , named-text + , parameterized-utils >= 2.1 && < 2.2 + , prettyprinter + , sayable + , tasty >= 1.4 && < 1.5 + , tasty-ant-xml >= 1.1 && < 1.2 + , tasty-checklist >= 1.0 && < 1.1 + , tasty-hspec >= 1.2 && < 1.3 + , text diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +import Data.Name +import Data.Parameterized.Context ( pattern Empty, pattern (:>) ) +import Data.Proxy ( Proxy(Proxy) ) +import Data.String ( IsString(fromString) ) +import Data.Text ( Text ) +import qualified Data.Text as T +import GHC.Exts ( proxy#, IsList(fromList, toList) ) +import qualified Prettyprinter as PP +import Text.Sayable + +import Test.Hspec +import Test.Tasty +import Test.Tasty.Checklist +import Test.Tasty.Hspec +import Test.Tasty.Runners.AntXML + + +main :: IO () +main = tests >>= defaultMainWithIngredients (antXMLRunner : defaultIngredients) + +tests :: IO TestTree +tests = testGroup "Named" <$> sequence + [ + testCreate + , testRender + , testSemigroup + , testIsList + , testConversions + , testValidNames + , testSomeNames + , testHasName + , testUtilities + ] + + +instance TestShow Text +instance Sayable "test" (Named s n) + => 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 Secure) where testShow _ = "Proxy :: Secure" +instance TestShow [SomeName] where testShow = testShowList +instance TestShow SomeName where testShow = viewSomeName testShow + + +testCreate :: IO TestTree +testCreate = testSpec "Named Creation" $ + describe "creation, properties, and extraction of Named" $ do + + it "CR1 creates UTF8 from IsText" $ + withChecklist "CR1" $ + fromText @(Named UTF8 "CR1") ("test text" :: Text) + `checkValues` + (Empty + :> Val "overloaded equivalent text value" id "test text" + :> Got "case sensitive text value" (/= "Test Text") + :> Val "name parameter value" (\n -> nameOf n proxy#) "CR1" + :> Val "style proxy" styleProxy (Proxy :: Proxy "UTF8") + :> Val "extracted text" nameText ("test text" :: Text) + ) + + it "CR2 creates UTF8 from IsString" $ + withChecklist "CR2" $ + fromString @(Named UTF8 "CR2") ("test string" :: String) + `checkValues` + (Empty + :> Val "overloaded equivalent string value" id "test string" + :> Val "name parameter value" (\n -> nameOf n proxy#) "CR2" + :> Val "style proxy" styleProxy (Proxy :: Proxy "UTF8") + :> Val "extracted text" nameText ("test string" :: Text) + ) + + it "CR3 creates CaseInsensitive from IsText" $ + withChecklist "CR3" $ + fromText @(Named CaseInsensitive "CR3") ("Test teXT" :: Text) + `checkValues` + (Empty + :> Val "overloaded equivalent text value" id "tesT tExt" + :> Val "name parameter value" (\n -> nameOf n proxy#) "CR3" + :> Val "style proxy" styleProxy (Proxy :: Proxy CaseInsensitive) + :> Val "extracted text" nameText ("test text" :: Text) + ) + + it "CR4 creates CaseInsensitive from IsString" $ + withChecklist "CR4" $ + fromString @(Named CaseInsensitive "CR4") ("TEst STring" :: String) + `checkValues` + (Empty + :> Val "overloaded equivalent string value" id "teST sTring" + :> Val "name parameter value" (\n -> nameOf n proxy#) "CR4" + :> Val "style proxy" styleProxy (Proxy :: Proxy CaseInsensitive) + :> Val "extracted text" nameText ("test string" :: Text) + ) + + it "CR5 creates Secure from IsText" $ + withChecklist "CR5" $ + fromText @(Named Secure "CR5") ("test text" :: Text) + `checkValues` + (Empty + :> Val "overloaded equivalent text value" id "test text" + :> Got "case sensitive secure value" (/= "Test Text") + :> Val "name parameter value" (\n -> nameOf n proxy#) "CR5" + :> Val "style proxy" styleProxy (Proxy :: Proxy Secure) + :> Val "extracted text" nameText ("te#####xt" :: Text) + :> Val "security bypass text" secureNameBypass ("test text" :: Text) + ) + + it "CR6 creates Secure from IsString" $ + withChecklist "CR6" $ + fromString @(Named Secure "CR6") ("TEst STring" :: String) + `checkValues` + (Empty + :> Val "overloaded equivalent string value" id "TEst STring" + :> Val "name parameter value" (\n -> nameOf n proxy#) "CR6" + :> Val "style proxy" styleProxy (Proxy :: Proxy Secure) + :> Val "extracted text" nameText ("TE#######ng" :: Text) + :> Val "security bypass text" secureNameBypass ("TEst STring" :: Text) + ) + + it "CR7 creates short Secure" $ + withChecklist "CR7" $ + ("z" :: Named Secure "CR7") + `checkValues` + (Empty + :> Val "overloaded equivalent text value" id "z" + :> Val "name parameter value" (\n -> nameOf n proxy#) "CR7" + :> Val "style proxy" styleProxy (Proxy :: Proxy Secure) + :> Val "extracted text" nameText ("########" :: Text) + :> Val "security bypass text" secureNameBypass ("z" :: Text) + ) + + +testRender :: IO TestTree +testRender = testSpec "Named Rendering" $ + describe "rendering of Named" $ do + + it "CR10 render UTF8 via Sayable" $ + withChecklist "CR10" $ + ("test text" :: Name "CR10") + `checkValues` + (Empty + :> Val "as sayable" (sez @"test") "CR10 'test text'" + :> Val "as sayable info" (sez @"info") "test text" + ) + + it "CR11 render UTF8 via Prettyprinter" $ + withChecklist "CR11" $ + fromText @(Named "UTF8" "CR11") ("test of text" :: Text) + `checkValues` + (Empty + :> Val "as pretty" (show . PP.pretty) "CR11 'test of text'" + ) + + it "CR12 render UTF8 via Show" $ + withChecklist "CR12" $ + fromText @(Named "UTF8" "CR12") ("test of text" :: Text) + `checkValues` + (Empty + :> Val "as show" show "CR12 'test of text'" + ) + + 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 "CR14 render CaseInsensitive via Prettyprinter" $ + withChecklist "CR14" $ + fromText @(Named CaseInsensitive "CR14") ("test OF text" :: Text) + `checkValues` + (Empty + :> Val "as pretty" (show . PP.pretty) "CR14 «test of text»" + ) + + it "CR15 render CaseInsensitive via Show" $ + withChecklist "CR15" $ + fromText @(Named CaseInsensitive "CR15") ("TEST OF TEXT" :: Text) + `checkValues` + (Empty + :> Val "as show" show "CR15 «test of text»" + ) + + it "CR16 render Secure via Sayable" $ + withChecklist "CR16" $ + ("tEST TeXt" :: Named Secure "CR16") + `checkValues` + (Empty + :> Val "as sayable" (sez @"test") "CR16 'tE#####Xt'" + :> Val "as sayable info" (sez @"info") "tE#####Xt" + ) + + it "CR17 render Secure via Prettyprinter" $ + withChecklist "CR17" $ + fromText @(Named Secure "CR17") ("test OF text" :: Text) + `checkValues` + (Empty + :> Val "as pretty" (show . PP.pretty) "CR17 'te########xt'" + ) + + it "CR18 render Secure via Show" $ + withChecklist "CR18" $ + fromText @(Named Secure "CR18") ("TEST OF TEXT" :: Text) + `checkValues` + (Empty + :> Val "as show" show "CR18 'TE########XT'" + ) + + it "CR19 render short Secure via Sayable" $ + withChecklist "CR19" $ + ("X" :: Named Secure "CR19") + `checkValues` + (Empty + :> Val "as sayable" (sez @"test") "CR19 '########'" + :> Val "as sayable info" (sez @"info") "########" + ) + + +testSemigroup :: IO TestTree +testSemigroup = testSpec "Named Semigroup" $ + describe "semigroup of Named" $ do + + it "CR20 UTF8 semigroup" $ + withChecklist "CR20" $ + (fromText @(Named UTF8 "CR20") ("more test text" :: Text) + <> " and still more") + `checkValues` + (Empty + :> Val "raw value" id "more test text and still more" + :> Val "as sayable" (sez @"test") "CR20 'more test text and still more'" + ) + + it "CR21 CaseInsensitive semigroup" $ + withChecklist "CR21" $ + (fromText @(Named CaseInsensitive "CR21") ("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") "CR21 «more test text and still more»" + ) + + it "CR22 Secure semigroup" $ + withChecklist "CR22" $ + (fromText @(Named Secure "CR22") ("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") "CR22 'mo#########################re'" + ) + +testIsList :: IO TestTree +testIsList = testSpec "Named IsList" $ + describe "IsList of Named" $ do + + it "CR30 UTF8 IsList" $ + withChecklist "CR30" $ + (fromList "list of text" :: Name "CR30") + `checkValues` + (Empty + :> Val "matches implicit construction" id "list of text" + :> Val "as sayable" (sez @"test") "CR30 'list of text'" + :> Val "as extracted text" nameText "list of text" + :> Val "as list" toList ['l','i','s','t',' ','o','f',' ','t','e','x','t'] + ) + + -- Note: no IsList instance for CaseInsensitive or Secure + +testConversions :: IO TestTree +testConversions = testSpec "Named Conversions" $ do + + describe "Named nameOf conversions" $ do + -- n.b. these tests use the "instance ConvertName" below. + + it "CR40 UTF8 default conversion" $ + withChecklist "CR40" $ + (convertName (fromText "list of text" :: Name "CR40") :: Name "CR40-2") + `checkValues` + (Empty + :> Val "matches implicit construction" id "list of text" + :> Val "as sayable" (sez @"test") "CR40-2 'list of text'" + :> Val "as extracted text" nameText "list of text" + ) + + it "CR41 UTF8 explicit conversion" $ + withChecklist "CR41" $ + (convertName (fromText "list of text" :: Name "CR41") :: Name "CR41-3") + `checkValues` + (Empty + :> Val "matches implicit construction" id "mjtu!pg!ufyu" + :> Val "as sayable" (sez @"test") "CR41-3 'mjtu!pg!ufyu'" + :> Val "as extracted text" nameText "mjtu!pg!ufyu" + ) + + it "CR42 CaseInsensitive conversion" $ + withChecklist "CR42" $ + (convertName (fromText "biT OF teXt" :: Named CaseInsensitive "CR42") + :: Named CaseInsensitive "CR42 new") + `checkValues` + (Empty + :> Val "matches implicit construction" id "bit of text" + :> Val "as sayable" (sez @"test") "CR42 new «bit of text»" + :> Val "as extracted text" nameText "bit of text" + ) + + it "CR43 Secure conversion" $ + withChecklist "CR43" $ + (convertName (fromText "hidden text" :: Named Secure "CR43") + :: Named Secure "CR43 again") + `checkValues` + (Empty + :> Val "matches implicit construction" id "hidden text" + :> Val "as sayable" (sez @"test") "CR43 again 'hi#######xt'" + :> Val "as extracted text" nameText "hi#######xt" + :> Val "security bypass extraction" secureNameBypass ("hidden text" :: Text) + ) + + describe "Named style conversions" $ do + -- n.b. these tests use the "instance ConvertNameStyle" below. + + it "CR44 UTF8->CaseInsensitive default conversion" $ + withChecklist "CR44" $ + (convertStyle (fromText "Some TEXT" :: Name "CR44") + :: Named CaseInsensitive "CR44") + `checkValues` + (Empty + :> Val "matches implicit construction" id "some text" + :> Val "as sayable" (sez @"test") "CR44 «some text»" + :> Val "as extracted text" nameText "some text" + ) + + it "CR45 UTF8->Secure default conversion" $ + withChecklist "CR45" $ + (convertStyle (fromText "Some TEXT" :: Name "CR45") :: Named Secure "CR45") + `checkValues` + (Empty + :> Val "matches implicit construction" id "Some TEXT" + :> Val "as sayable" (sez @"test") "CR45 'So#####XT'" + :> Val "as extracted text" nameText "So#####XT" + ) + + it "CR46 CaseInsensitive->UTF8 default conversion" $ + withChecklist "CR46" $ + (convertStyle (fromText "Some TEXT" :: Named CaseInsensitive "CR46") + :: Named UTF8 "CR46") + `checkValues` + (Empty + :> Val "matches implicit construction" id "some text" + :> Val "as sayable" (sez @"test") "CR46 'some text'" + :> Val "as extracted text" nameText "some text" + ) + + it "CR47 Secure->UTF8 default conversion" $ + withChecklist "CR47" $ + (convertStyle (fromText "Some TEXT" :: Named Secure "CR47") :: Name "CR47") + `checkValues` + (Empty + -- note here that the default only gets the masked form! + :> Val "matches implicit construction" id "So#####XT" + :> Val "as sayable" (sez @"test") "CR47 'So#####XT'" + :> Val "as extracted text" nameText "So#####XT" + ) + + it "CR48 Secure->UTF8 implicit bypass conversion" $ + withChecklist "CR48" $ + (convertStyle (fromText "Some TEXT" :: Named Secure "CR48") :: Name "CR48") + `checkValues` + (Empty + -- note here that the default only gets the masked form! + :> Val "matches implicit construction" id "Some TEXT" + :> Val "as sayable" (sez @"test") "CR48 'Some TEXT'" + :> Val "as extracted text" nameText "Some TEXT" + ) + +instance ConvertName UTF8 "CR40" "CR40-2" +instance ConvertName UTF8 "CR41" "CR41-3" where + convertName = fromText . T.map succ . nameText +instance ConvertName CaseInsensitive "CR42" "CR42 new" +instance ConvertName Secure "CR43" "CR43 again" where + convertName = fromText . secureNameBypass + +instance ConvertNameStyle UTF8 CaseInsensitive "CR44" +instance ConvertNameStyle UTF8 Secure "CR45" +instance ConvertNameStyle CaseInsensitive UTF8 "CR46" +instance ConvertNameStyle Secure UTF8 "CR47" +instance ConvertNameStyle Secure UTF8 "CR48" where + convertStyle = fromText . secureNameBypass + + +testValidNames :: IO TestTree +testValidNames = testSpec "Named ValidNames" $ + describe "ValidNames" $ do + -- n.b. Uses the validateName function below. + + it "CR50 Valid Names" $ + withChecklist "CR50" $ + (fromText "valid text" :: Name "CR50") + `checkValues` + (Empty + :> Got "valid name for validateName call" validateName + :> Val "validated text extraction" + (validName (Proxy :: Proxy '[ "Foo", "CR50", "Other"])) "valid text" + ) + + -- It would be nice to test the failure case for ValidNames, but that's a + -- compilation failure. + +validateName :: ValidNames n '[ "CR50", "CR50.2" ] => Name n -> Bool +validateName = const True + + +testSomeNames :: IO TestTree +testSomeNames = testSpec "Named SomeName and SomeStyle" $ do + describe "SomeName" $ do + + it "CR60 SomeName collection and extraction" $ + withChecklist "CR60" $ + ([ SomeName (fromText "text one" :: Name "CR60.1") + , SomeName (fromText "text two" :: Name "CR60 2") + , SomeName (fromText "text 3" :: Name "CR60-three") + ]) + `checkValues` + (Empty + :> Val "list length" length 3 + :> Val "@ 0" (viewSomeName (sez @"test") . (!!0)) "CR60.1 'text one'" + :> Val "@ 1" (viewSomeName (sez @"test") . (!!1)) "CR60 2 'text two'" + :> Val "@ 2" (viewSomeName (sez @"test") . (!!2)) "CR60-three 'text 3'" + ) + + describe "SomeStyle" $ do + + it "CR61 SomeStyle collection and extraction" $ + withChecklist "CR61" $ + ([ SomeNameStyle ("Regular text." :: Name "CR61") + , SomeNameStyle ("cASE inSENsitIVE tEXt" :: Named CaseInsensitive "CR61") + , SomeNameStyle ("secret text" :: Named Secure "CR61") + ] + ) + `checkValues` + (Empty + :> Val "list length" length 3 + :> Val "val @ 0" (viewSomeNameStyle nameText . (!!0)) "Regular text." + :> Val "val @ 1" (viewSomeNameStyle nameText . (!!1)) "case insensitive text" + :> Val "val @ 2" (viewSomeNameStyle nameText . (!!2)) "se#######xt" + :> Val "nameOf @ 0" (viewSomeNameStyle (\n -> nameOf n proxy#) . (!!0)) "CR61" + :> Val "nameOf @ 1" (viewSomeNameStyle (\n -> nameOf n proxy#) . (!!1)) "CR61" + :> Val "nameOf @ 2" (viewSomeNameStyle (\n -> nameOf n proxy#) . (!!2)) "CR61" + ) + +instance TestShow [SomeNameStyle "CR61"] where testShow = testShowList +instance TestShow (SomeNameStyle "CR61") where + testShow = viewSomeNameStyle (\n -> nameOf n proxy# <> ": " <> show (nameText n)) + + +testHasName :: IO TestTree +testHasName = testSpec "HasName" $ do + describe "HasName Foo" $ do + + it "CR70 can extract UTF8 myName from Foo" $ + myName (Foo "bar" "baz" "quux") `shouldBe` ("baz" :: Name "principle") + + it "CR71 can extract secure myName from Bar" $ + myName (Bar "baz" "quux") `shouldBe` ("quux" :: Named Secure "second") + +data Foo = Foo (Name "prefix") (Name "principle") (Name "alt") +instance HasName Foo UTF8 "principle" where myName (Foo _ p _) = p + +data Bar = Bar (Name "first") (Named Secure "second") +instance HasName Bar Secure "second" where myName (Bar _ s) = s + + +testUtilities :: IO TestTree +testUtilities = testSpec "Named utilities" $ do + describe "Named length" $ do + + it "CR80 can get a UTF8 length" $ + nameLength ("Length of TEXT" :: Name "CR80") `shouldBe` 14 + + it "CR81 can get a CaseInsensitive length" $ + nameLength ("Length of TEXT" :: Named CaseInsensitive "CR81") `shouldBe` 14 + + it "CR82 can get a Secure length" $ + nameLength ("Length of secure TEXT" :: Named Secure "CR82") `shouldBe` 21 + + describe "Named null check" $ do + + it "CR83 can check a null UTF8" $ + nullName ("" :: Name "CR83") `shouldBe` True + + it "CR84 can check a non-null UTF8" $ + nullName ("Not empty" :: Name "CR84") `shouldBe` False + + it "CR85 can check a null CaseInsensitive named" $ + nullName ("" :: Named CaseInsensitive "CR85") `shouldBe` True + + it "CR86 can check a non-null CaseInsensitive named" $ + nullName ("Not empty" :: Named CaseInsensitive "CR86") `shouldBe` False + + it "CR87 can check a null Secure named" $ + nullName ("" :: Name "CR87") `shouldBe` True + + it "CR88 can check a non-null Secure named" $ + nullName ("Not empty" :: Named Secure "CR88") `shouldBe` False