named-text 1.0.1.0 → 1.1.0.0
raw patch · 4 files changed
+887/−81 lines, 4 filesdep +hspecdep +named-textdep +parameterized-utilsdep ~basedep ~prettyprinterdep ~sayablePVP ok
version bump matches the API change (PVP)
Dependencies added: hspec, named-text, parameterized-utils, tasty, tasty-ant-xml, tasty-checklist, tasty-hspec
Dependency ranges changed: base, prettyprinter, sayable
API changes (from Hackage documentation)
- Data.Name: instance Control.DeepSeq.NFData (Data.Name.Named style sym)
- Data.Name: instance Data.Hashable.Class.Hashable (Data.Name.Named style sym)
- Data.Name: instance Data.Name.ConvertName Data.Name.UTF8 "component" "instance component"
- Data.Name: instance Data.Name.ConvertName Data.Name.UTF8 "git.branch" "git.branch|ref"
- Data.Name: instance Data.Name.ConvertName Data.Name.UTF8 "git.ref" "git.branch|ref"
- Data.Name: instance Data.Name.IsText (Data.Name.Named Data.Name.CaseInsensitive sym)
- Data.Name: instance Data.Name.IsText (Data.Name.Named style sym)
- Data.Name: instance Data.String.IsString (Data.Name.Named Data.Name.CaseInsensitive sym)
- Data.Name: instance Data.String.IsString (Data.Name.Named style sym)
- Data.Name: instance GHC.Base.Semigroup (Data.Name.Named style sym)
- Data.Name: instance GHC.Classes.Eq (Data.Name.Named style sym)
- Data.Name: instance GHC.Classes.Ord (Data.Name.Named style sym)
- Data.Name: instance GHC.Generics.Generic (Data.Name.Named style sym)
- Data.Name: instance GHC.TypeLits.KnownSymbol ty => Prettyprinter.Internal.Pretty (Data.Name.Name ty)
- Data.Name: instance GHC.TypeLits.KnownSymbol ty => Prettyprinter.Internal.Pretty (Data.Name.Named Data.Name.Secure ty)
+ Data.Name: instance (GHC.TypeLits.KnownSymbol ty, Data.Name.NameText style) => Prettyprinter.Internal.Pretty (Data.Name.Named style ty)
+ Data.Name: instance Control.DeepSeq.NFData (Data.Name.Named style nameOf)
+ Data.Name: instance Data.Hashable.Class.Hashable (Data.Name.Named style nameOf)
+ Data.Name: instance Data.Name.IsText (Data.Name.Named Data.Name.CaseInsensitive nameOf)
+ Data.Name: instance Data.Name.IsText (Data.Name.Named style nameOf)
+ Data.Name: instance Data.Name.NameText Data.Name.Secure
+ Data.Name: instance Data.String.IsString (Data.Name.Named Data.Name.CaseInsensitive nameOf)
+ Data.Name: instance Data.String.IsString (Data.Name.Named style nameOf)
+ Data.Name: instance GHC.Base.Semigroup (Data.Name.Named style nameOf)
+ Data.Name: instance GHC.Classes.Eq (Data.Name.Named style nameOf)
+ Data.Name: instance GHC.Classes.Ord (Data.Name.Named style nameOf)
+ Data.Name: instance GHC.Generics.Generic (Data.Name.Named style nameOf)
+ Data.Name: instance Text.Sayable.Sayable "show" (Data.Name.Named style nm) => GHC.Show.Show (Data.Name.Named style nm)
+ Data.Name: nameLength :: Named style nm -> Natural
+ Data.Name: nullName :: Named style nm -> Bool
- Data.Name: caselessName :: Named CaseInsensitive sym -> Text
+ Data.Name: caselessName :: Named CaseInsensitive nameOf -> Text
- Data.Name: class ConvertName style origTy newTy
+ Data.Name: class NameText style => ConvertName style origTy newTy
- Data.Name: class ConvertNameStyle inpStyle outStyle nameTy
+ Data.Name: class (NameText inpStyle, IsText (Named outStyle nameTy)) => ConvertNameStyle inpStyle outStyle nameTy
- Data.Name: class (KnownNat (AllowedNameType nty ntl), DisallowedNameType nty ntl ntl) => ValidNames (nty :: Symbol) (ntl :: [Symbol])
+ Data.Name: class (KnownNat (AllowedNameType nameOf ntl), DisallowedNameType nameOf ntl ntl) => ValidNames (nameOf :: Symbol) (ntl :: [Symbol])
- Data.Name: data Named (style :: NameStyle) (sym :: Symbol)
+ Data.Name: data Named (style :: NameStyle) (nameOf :: Symbol)
- Data.Name: name :: Name sym -> Text
+ Data.Name: name :: Name nameOf -> Text
- Data.Name: nameOf :: KnownSymbol sym => Named style sym -> Proxy# sym -> String
+ Data.Name: nameOf :: KnownSymbol nameOf => Named style nameOf -> Proxy# nameOf -> String
- Data.Name: nameProxy :: KnownSymbol sym => Named style sym -> Proxy sym
+ Data.Name: nameProxy :: KnownSymbol nameOf => Named style nameOf -> Proxy nameOf
- Data.Name: secureName :: Named Secure sym -> Text
+ Data.Name: secureName :: Named Secure nameOf -> Text
- Data.Name: secureNameBypass :: Named Secure sym -> Text
+ Data.Name: secureNameBypass :: Named Secure nameOf -> Text
- Data.Name: styleProxy :: KnownSymbol style => Named style sym -> Proxy style
+ Data.Name: styleProxy :: KnownSymbol style => Named style nameOf -> Proxy style
- Data.Name: validName :: ValidNames nty ntl => Proxy ntl -> Name nty -> Text
+ Data.Name: validName :: ValidNames nameOf ntl => Proxy ntl -> Name nameOf -> Text
- Data.Name: viewSomeNameStyle :: (forall (s :: Symbol). KnownSymbol s => Named s nameTy -> r) -> SomeNameStyle nameTy -> r
+ Data.Name: viewSomeNameStyle :: (forall (s :: Symbol). (KnownSymbol s, NameText s) => Named s nameTy -> r) -> SomeNameStyle nameTy -> r
Files
- CHANGELOG.md +11/−0
- Data/Name.hs +337/−80
- named-text.cabal +20/−1
- test/Test.hs +519/−0
CHANGELOG.md view
@@ -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
Data/Name.hs view
@@ -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 ----------------------------------------------------------------------
named-text.cabal view
@@ -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
+ test/Test.hs view
@@ -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