diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Changelog +## [0.2.0.0] - 2022-12-05 + +- Add `literalNonEmptyText`, `literalProse`, `literalNullableNonEmptyText` for creation of string variants from the type-level literals. +- Add `concatWithSpace` to concatenate NonEmptyText in a type-safe way. +- Drop support for GHC <9.2. + ## [0.1.0.2] - 2022-10-18 - Fix `mkNonEmptyTextWithTruncate` to perform truncation after character stripping. diff --git a/src/Data/StringVariants.hs b/src/Data/StringVariants.hs --- a/src/Data/StringVariants.hs +++ b/src/Data/StringVariants.hs @@ -51,10 +51,6 @@ -- ** Information isNullNonEmptyText, - - -- * Convenience util if you need a NonEmptyText of a dynamically determined lengths - useNat, - natOfLength, ) where diff --git a/src/Data/StringVariants/NonEmptyText.hs b/src/Data/StringVariants/NonEmptyText.hs --- a/src/Data/StringVariants/NonEmptyText.hs +++ b/src/Data/StringVariants/NonEmptyText.hs @@ -13,6 +13,7 @@ -- * Construction mkNonEmptyText, mkNonEmptyTextWithTruncate, + literalNonEmptyText, unsafeMkNonEmptyText, nonEmptyTextToText, compileNonEmptyText, @@ -28,27 +29,25 @@ chunksOfNonEmptyText, filterNonEmptyText, (<>|), + concatWithSpace, -- * Conversions between 'Refined' and 'NonEmptyText'. ContainsNonWhitespaceCharacters (..), exactLengthRefinedToRange, nonEmptyTextFromRefined, refinedFromNonEmptyText, - - -- * Convenience util if you need a NonEmptyText of a dynamically determined lengths - useNat, - natOfLength, ) where import Control.Monad import Data.Data (Proxy (..), typeRep) +import Data.Maybe (mapMaybe) import Data.StringVariants.NonEmptyText.Internal import Data.StringVariants.Util import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) -import GHC.TypeLits (KnownNat, natVal, type (+), type (<=)) +import GHC.TypeLits (KnownNat, KnownSymbol, Symbol, Nat, natVal, symbolVal, type (+), type (<=)) import Language.Haskell.TH import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax (Lift (..)) @@ -66,11 +65,16 @@ } where compileNonEmptyText' :: String -> Q Exp - compileNonEmptyText' s = useNat n $ \p -> - case natOfLength p $ mkNonEmptyText (T.pack s) of - Nothing -> fail $ "Invalid NonEmptyText. Needs to be < " ++ show (n + 1) ++ " characters, and not entirely whitespace: " ++ s + compileNonEmptyText' s = usePositiveNat n errorMessage $ \(_ :: proxy n) -> + case mkNonEmptyText @n (T.pack s) of Just txt -> [|$(lift txt) :: NonEmptyText $(pure $ LitT $ NumTyLit n)|] + Nothing -> errorMessage + where + errorMessage = fail $ "Invalid NonEmptyText. Needs to be < " ++ show (n + 1) ++ " characters, and not entirely whitespace: " ++ s +literalNonEmptyText :: forall (s :: Symbol) (n :: Nat). (KnownSymbol s, KnownNat n, SymbolNonEmpty s, SymbolWithNoSpaceAround s, SymbolNoLongerThan s n) => NonEmptyText n +literalNonEmptyText = NonEmptyText (T.pack (symbolVal (Proxy @s))) + convertEmptyTextToNothing :: Text -> Maybe Text convertEmptyTextToNothing t | textIsWhitespace t = Nothing @@ -82,39 +86,43 @@ -- | Identical to the normal text filter function, but maintains the type-level invariant -- that the text length is <= n, unlike unwrapping the text, filtering, then -- rewrapping the text. -filterNonEmptyText :: (Char -> Bool) -> NonEmptyText n -> NonEmptyText n -filterNonEmptyText f (NonEmptyText t) = NonEmptyText (T.filter f t) +-- +-- Will return Nothing if the resulting length is zero. +filterNonEmptyText :: (KnownNat n, 1 <= n) => (Char -> Bool) -> NonEmptyText n -> Maybe (NonEmptyText n) +filterNonEmptyText f (NonEmptyText t) = mkNonEmptyText (T.filter f t) -- | Narrows the maximum length, dropping any remaining trailing characters. -takeNonEmptyText :: forall m n. (KnownNat m, KnownNat n, n <= m) => NonEmptyText m -> NonEmptyText n +takeNonEmptyText :: forall m n. (KnownNat m, KnownNat n, 1 <= n, n <= m) => NonEmptyText m -> NonEmptyText n takeNonEmptyText (NonEmptyText t) = if m == n then NonEmptyText t - else NonEmptyText $ T.take n t + -- when the input is stripped, taking from it is guaranteed to be not empty + else NonEmptyText $ T.stripEnd $ T.take n t where m = fromIntegral $ natVal (Proxy @m) n = fromIntegral $ natVal (Proxy @n) -- | Narrows the maximum length, dropping any prefix remaining characters. -takeNonEmptyTextEnd :: forall m n. (KnownNat m, KnownNat n, n <= m) => NonEmptyText m -> NonEmptyText n +takeNonEmptyTextEnd :: forall m n. (KnownNat m, KnownNat n, 1 <= n, n <= m) => NonEmptyText m -> NonEmptyText n takeNonEmptyTextEnd (NonEmptyText t) = if m == n then NonEmptyText t - else NonEmptyText $ T.takeEnd n t + -- when the input is stripped, taking from it is guaranteed to be not empty + else NonEmptyText $ T.stripStart $ T.takeEnd n t where m = fromIntegral $ natVal (Proxy @m) n = fromIntegral $ natVal (Proxy @n) -- | /O(n)/ Splits a 'NonEmptyText' into components of length @chunkSize@. The --- last element may be shorter than the other chunks, depending on the length --- of the input. +-- chunks may be shorter than the chunkSize depending on the length +-- of the input and spacing. Each chunk is stripped of whitespace. chunksOfNonEmptyText :: forall chunkSize totalSize. - (KnownNat chunkSize, KnownNat totalSize) => + (KnownNat chunkSize, KnownNat totalSize, chunkSize <= totalSize, 1 <= chunkSize) => NonEmptyText totalSize -> [NonEmptyText chunkSize] chunksOfNonEmptyText (NonEmptyText t) = - map NonEmptyText (T.chunksOf chunkSize t) + mapMaybe mkNonEmptyText (T.chunksOf chunkSize t) where chunkSize = fromIntegral $ natVal (Proxy @chunkSize) @@ -124,6 +132,14 @@ -- Mnemonic: @<>@ for monoid, @|@ from NonEmpty's ':|' operator (<>|) :: NonEmptyText n -> NonEmptyText m -> NonEmptyText (n + m) (NonEmptyText l) <>| (NonEmptyText r) = NonEmptyText (l <> r) + +-- | Concat two 'NonEmptyText' values with a space in between them. The new +-- maximum length is the sum of the two maximum lengths of the inputs + 1 for +-- the space. +-- +-- Useful for 'unwords'like operations, or combining first and last names. +concatWithSpace :: NonEmptyText n -> NonEmptyText m -> NonEmptyText (n + m + 1) +concatWithSpace (NonEmptyText l) (NonEmptyText r) = NonEmptyText (l <> " " <> r) -- Refinery diff --git a/src/Data/StringVariants/NonEmptyText/Internal.hs b/src/Data/StringVariants/NonEmptyText/Internal.hs --- a/src/Data/StringVariants/NonEmptyText/Internal.hs +++ b/src/Data/StringVariants/NonEmptyText/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- We need redundant constraints in @widen@ to enforce invariants {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} @@ -17,7 +18,7 @@ import Data.Proxy import Data.Sequences import Data.String.Conversions (ConvertibleStrings (..), cs) -import Data.StringVariants.Util (textHasNoMeaningfulContent, textIsTooLong, textIsWhitespace) +import Data.StringVariants.Util (textHasNoMeaningfulContent, textIsWhitespace) import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) @@ -34,7 +35,7 @@ type instance Element (NonEmptyText _n) = Char -instance KnownNat n => FromJSON (NonEmptyText n) where +instance (KnownNat n, 1 <= n) => FromJSON (NonEmptyText n) where parseJSON = withText "NonEmptyText" $ \t -> do performInboundValidations t case mkNonEmptyText t of @@ -65,7 +66,7 @@ instance ConvertibleStrings (NonEmptyText n) ByteString where convertString (NonEmptyText t) = cs t -instance KnownNat n => Arbitrary (NonEmptyText n) where +instance (KnownNat n, 1 <= n) => Arbitrary (NonEmptyText n) where arbitrary = NonEmptyText @n <$> do size <- chooseInt (1, fromIntegral (natVal (Proxy :: Proxy n)) - 1) @@ -73,15 +74,15 @@ str <- replicateM size $ elements ['0' .. 'z'] pure $ T.pack str -mkNonEmptyText :: forall n. KnownNat n => Text -> Maybe (NonEmptyText n) +mkNonEmptyText :: forall n. (KnownNat n, 1 <= n) => Text -> Maybe (NonEmptyText n) mkNonEmptyText t - | textIsTooLong stripped (fromIntegral $ natVal (Proxy @n)) = Nothing + | T.compareLength stripped (fromIntegral $ natVal (Proxy @n)) == GT = Nothing | textIsWhitespace stripped = Nothing | otherwise = Just (NonEmptyText stripped) where stripped = T.filter (/= '\NUL') $ T.strip t -mkNonEmptyTextWithTruncate :: forall n. KnownNat n => Text -> Maybe (NonEmptyText n) +mkNonEmptyTextWithTruncate :: forall n. (KnownNat n, 1 <= n) => Text -> Maybe (NonEmptyText n) mkNonEmptyTextWithTruncate t | textIsWhitespace stripped = Nothing | otherwise = Just (NonEmptyText $ T.stripEnd $ T.take (fromIntegral $ natVal (Proxy @n)) stripped) @@ -89,7 +90,7 @@ stripped = T.filter (/= '\NUL') $ T.stripStart t -- | Make a NonEmptyText when you can manually verify the length -unsafeMkNonEmptyText :: forall n. KnownNat n => Text -> NonEmptyText n +unsafeMkNonEmptyText :: forall n. (KnownNat n, 1 <= n) => Text -> NonEmptyText n unsafeMkNonEmptyText = NonEmptyText -- | Converts a 'NonEmptyText' to a wider NonEmptyText diff --git a/src/Data/StringVariants/NullableNonEmptyText.hs b/src/Data/StringVariants/NullableNonEmptyText.hs --- a/src/Data/StringVariants/NullableNonEmptyText.hs +++ b/src/Data/StringVariants/NullableNonEmptyText.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Data.StringVariants.NullableNonEmptyText ( -- Safe to construct, so we can export the contents @@ -7,6 +9,7 @@ -- * Constructing mkNonEmptyTextWithTruncate, compileNullableNonEmptyText, + literalNullableNonEmptyText, mkNullableNonEmptyText, parseNullableNonEmptyText, nullNonEmptyText, @@ -32,11 +35,11 @@ import Data.Data (Proxy (..)) import Data.Maybe (fromMaybe) import Data.StringVariants.NonEmptyText -import Data.StringVariants.Util (textIsTooLong) +import Data.StringVariants.Util import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) -import GHC.TypeLits (KnownNat, natVal) +import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal) import Language.Haskell.TH import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax (Lift (..)) @@ -58,9 +61,9 @@ deriving stock (Generic, Show, Read, Lift) deriving newtype (Eq, ToJSON) -mkNullableNonEmptyText :: forall n. KnownNat n => Text -> Maybe (NullableNonEmptyText n) +mkNullableNonEmptyText :: forall n. (KnownNat n, 1 <= n) => Text -> Maybe (NullableNonEmptyText n) mkNullableNonEmptyText t - | textIsTooLong t (fromIntegral $ natVal (Proxy @n)) = Nothing -- we can't store text that is too long + | T.compareLength t (fromIntegral $ natVal (Proxy @n)) == GT = Nothing -- we can't store text that is too long | otherwise = Just $ NullableNonEmptyText $ mkNonEmptyText t nullNonEmptyText :: NullableNonEmptyText n @@ -69,7 +72,7 @@ isNullNonEmptyText :: NullableNonEmptyText n -> Bool isNullNonEmptyText = (== nullNonEmptyText) -instance KnownNat n => FromJSON (NullableNonEmptyText n) where +instance (KnownNat n, 1 <= n) => FromJSON (NullableNonEmptyText n) where parseJSON = \case J.String t -> case mkNullableNonEmptyText t of Just txt -> pure txt @@ -77,7 +80,7 @@ J.Null -> pure $ NullableNonEmptyText Nothing x -> fail $ "Data/StringVariants/NullableNonEmptyText.hs: When trying to parse a NullableNonEmptyText, expected a String or Null, but received: " ++ show x -parseNullableNonEmptyText :: KnownNat n => Text -> J.Object -> J.Parser (NullableNonEmptyText n) +parseNullableNonEmptyText :: (KnownNat n, 1 <= n) => Text -> J.Object -> J.Parser (NullableNonEmptyText n) parseNullableNonEmptyText fieldName obj = obj .:? J.fromText fieldName .!= nullNonEmptyText fromMaybeNullableText :: Maybe (NullableNonEmptyText n) -> NullableNonEmptyText n @@ -90,7 +93,7 @@ maybeNonEmptyTextToNullable Nothing = nullNonEmptyText maybeNonEmptyTextToNullable jt = NullableNonEmptyText jt -maybeTextToTruncateNullableNonEmptyText :: forall n. KnownNat n => Maybe Text -> NullableNonEmptyText n +maybeTextToTruncateNullableNonEmptyText :: forall n. (KnownNat n, 1 <= n) => Maybe Text -> NullableNonEmptyText n maybeTextToTruncateNullableNonEmptyText mText = NullableNonEmptyText $ mText >>= mkNonEmptyText . T.take (fromInteger (natVal (Proxy @n))) nullableNonEmptyTextToMaybeNonEmptyText :: NullableNonEmptyText n -> Maybe (NonEmptyText n) @@ -109,7 +112,13 @@ } where compileNullableNonEmptyText' :: String -> Q Exp - compileNullableNonEmptyText' s = useNat n $ \p -> - case natOfLength p $ mkNullableNonEmptyText (T.pack s) of - Nothing -> fail $ "Invalid NullableNonEmptyText. Needs to be < " ++ show (n + 1) ++ " characters, and not entirely whitespace: " ++ s + compileNullableNonEmptyText' s = usePositiveNat n errorMessage $ \(_ :: proxy n) -> + case mkNullableNonEmptyText @n (T.pack s) of Just txt -> [|$(lift txt)|] + Nothing -> errorMessage + where + errorMessage = fail $ "Invalid NullableNonEmptyText. Needs to be < " ++ show (n + 1) ++ " characters, and not entirely whitespace: " ++ s + +-- | This requires the text to be non-empty. For the empty text just use the constructor `NullableNonEmptyText Nothing` +literalNullableNonEmptyText :: forall (s :: Symbol) (n :: Nat). (KnownSymbol s, KnownNat n, SymbolNonEmpty s, SymbolWithNoSpaceAround s, SymbolNoLongerThan s n) => NullableNonEmptyText n +literalNullableNonEmptyText = NullableNonEmptyText (Just (literalNonEmptyText @s @n)) diff --git a/src/Data/StringVariants/Prose.hs b/src/Data/StringVariants/Prose.hs --- a/src/Data/StringVariants/Prose.hs +++ b/src/Data/StringVariants/Prose.hs @@ -3,6 +3,7 @@ ( Prose, mkProse, compileProse, + literalProse, proseToText, ) where diff --git a/src/Data/StringVariants/Prose/Internal.hs b/src/Data/StringVariants/Prose/Internal.hs --- a/src/Data/StringVariants/Prose/Internal.hs +++ b/src/Data/StringVariants/Prose/Internal.hs @@ -1,5 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} +-- GHC considers the constraints for the prose symbol redundant. +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + -- | Internal module of Prose, allowing breaking the abstraction. -- -- Prefer to use "Data.StringVariants.Prose" instead. @@ -8,9 +11,12 @@ import Data.Aeson (FromJSON, ToJSON, ToJSONKey, withText) import Data.Aeson.Types (FromJSON (..)) import Data.String.Conversions (ConvertibleStrings (..), cs) +import Data.StringVariants.Util (SymbolWithNoSpaceAround) +import Data.Proxy import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as LT +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Prelude @@ -54,6 +60,9 @@ Just s' -> [|$(lift s')|] msg s = "Invalid Prose: " <> s <> ". Make sure you aren't wrapping the text in quotes." + +literalProse :: forall (s :: Symbol). (KnownSymbol s, SymbolWithNoSpaceAround s) => Prose +literalProse = Prose (T.pack (symbolVal (Proxy @s))) proseToText :: Prose -> Text proseToText (Prose txt) = txt diff --git a/src/Data/StringVariants/Util.hs b/src/Data/StringVariants/Util.hs --- a/src/Data/StringVariants/Util.hs +++ b/src/Data/StringVariants/Util.hs @@ -1,31 +1,69 @@ -module Data.StringVariants.Util (natOfLength, useNat, textIsTooLong, textIsWhitespace, textHasNoMeaningfulContent) where -import GHC.TypeLits (KnownNat, Nat, SomeNat (..), someNatVal) +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.StringVariants.Util (SymbolNonEmpty, SymbolWithNoSpaceAround, SymbolNoLongerThan, usePositiveNat, textIsWhitespace, textHasNoMeaningfulContent) where + +import Data.Proxy +import Data.Kind (Constraint) +import Data.Type.Bool +import Data.Type.Equality +import GHC.TypeLits import Prelude import Data.Text (Text) import qualified Data.Text as T import Data.Char (isSpace, isControl) -textIsTooLong :: Text -> Int -> Bool --- why take? because of stream fusion, --- length isn't O(1), it's O(n). which means --- it's better to cut off the text at @n@ --- and then evaluate the resulting stream, than --- to evaluate the entire stream. very unintuitive, --- but that's just the way things are :( -textIsTooLong t n = T.length (T.take (n + 1) t) >= (n + 1) - textIsWhitespace :: Text -> Bool textIsWhitespace = T.all isSpace textHasNoMeaningfulContent :: Text -> Bool textHasNoMeaningfulContent = T.all (\c -> isSpace c || isControl c) +-- | If the integer is >= 1, evaluate the function with the proof of that. Otherwise, return the default value +usePositiveNat :: Integer -> a -> (forall n proxy. (KnownNat n, 1 <= n) => proxy n -> a) -> a +usePositiveNat n a f = case someNatVal n of + Nothing -> a + Just (SomeNat p) -> case cmpNat (Proxy @1) p of + EQI -> f p + LTI -> f p + GTI -> a -natOfLength :: proxy (n :: Nat) -> f (other n) -> f (other n) -natOfLength _ = id +-- Logic ported from base-4.17 Data.Char.isSpace. +-- Hopefully, GHC would add this type-level function +type IsCharWhitespace c + = If + (CharToNat c <=? 0x376) + (CharToNat c == 32 || CharToNat c - 0x9 <=? 4 || CharToNat c == 0xa0) + (IsUnicodeWhitespaceCodePoint (CharToNat c)) -useNat :: Integer -> (forall n proxy. KnownNat n => proxy n -> x) -> x -useNat n f = case someNatVal n of - Nothing -> error (show n ++ " isn't a valid Nat") - Just (SomeNat p) -> f p +-- It checks the whitespace characters (Unicode property White_Space=yes) defined in Unicode 15.0.0 and above the ASCII range. +type IsUnicodeWhitespaceCodePoint n + = n == 0x1680 + || (0x2000 <=? n && n <=? 0x200A) + || n == 0x2028 || n == 0x2029 || n == 0x202F || n == 0x205F || n == 0x3000 +type family SymbolLength (length :: Nat) (s :: Maybe (Char, Symbol)) :: Nat where + SymbolLength length 'Nothing = length + SymbolLength length ('Just '(_, s)) = SymbolLength (length + 1) (UnconsSymbol s) + +type family SymbolNonEmpty (s :: Symbol) :: Constraint where + SymbolNonEmpty "" = TypeError ('Text "Symbol is empty") + SymbolNonEmpty _ = () + +type family SymbolNoLeadingSpace (s :: Maybe (Char, Symbol)) :: Constraint where + SymbolNoLeadingSpace 'Nothing = () + SymbolNoLeadingSpace ('Just '(c, _)) = If (IsCharWhitespace c) (TypeError ('Text "Symbol has leading whitespace")) (() :: Constraint) + +type family SymbolNoTrailingSpace (s :: Maybe (Char, Symbol)) :: Constraint where + SymbolNoTrailingSpace 'Nothing = () + SymbolNoTrailingSpace ('Just '(c, "")) = If (IsCharWhitespace c) (TypeError ('Text "Symbol has trailing whitespace")) (() :: Constraint) + SymbolNoTrailingSpace ('Just '(_, s)) = SymbolNoTrailingSpace (UnconsSymbol s) + +-- The type family IsCharWhitespace is large but it is only evaluated for the first and last symbols +type SymbolWithNoSpaceAround s = (SymbolNoLeadingSpace (UnconsSymbol s), SymbolNoTrailingSpace (UnconsSymbol s)) + +type family SymbolNoLongerThan (s :: Symbol) (n :: Nat) :: Constraint where + SymbolNoLongerThan s n = If (SymbolLength 0 (UnconsSymbol s) <=? n) + (() :: Constraint) + (TypeError ('Text "Invalid NonEmptyText. Needs to be <= " ':<>: 'ShowType n ':<>: 'Text " characters. Has " ':<>: 'ShowType (SymbolLength 0 (UnconsSymbol s)) ':<>: 'Text " characters.")) diff --git a/string-variants.cabal b/string-variants.cabal --- a/string-variants.cabal +++ b/string-variants.cabal @@ -1,22 +1,22 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: string-variants -version: 0.1.0.2 +version: 0.2.0.0 synopsis: Constrained text newtypes description: See README at . category: Data homepage: https://github.com/MercuryTechnologies/string-variants#readme bug-reports: https://github.com/MercuryTechnologies/string-variants/issues -maintainer: Jade Lovelace +maintainer: Jade Lovelace , Borys Lykakh license: MIT license-file: LICENSE build-type: Simple tested-with: - GHC ==8.10.7 || ==9.2.4 || ==9.4.2 + GHC ==9.2.4 || ==9.4.2 extra-source-files: CHANGELOG.md @@ -77,12 +77,81 @@ build-depends: QuickCheck , aeson >=2.0.0.0 - , base >=4.9 && <5 + , base >=4.16 && <5 , bytestring , mono-traversable , refined , refinery , string-conversions + , template-haskell + , text + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Spec + Specs.NonEmptySpec + Specs.TextManipulationSpec + Paths_string_variants + hs-source-dirs: + test + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BlockArguments + DataKinds + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingVia + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + InstanceSigs + LambdaCase + MonoLocalBinds + MultiWayIf + NamedFieldPuns + NumericUnderscores + OverloadedStrings + PatternSynonyms + PolyKinds + RankNTypes + RecordWildCards + RecursiveDo + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TypeApplications + TypeFamilies + ViewPatterns + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-export-lists -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-missing-kind-signatures -threaded -rtsopts -with-rtsopts=-N -Wno-incomplete-uni-patterns -O0 + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + HUnit + , QuickCheck + , aeson >=2.0.0.0 + , base >=4.16 && <5 + , bytestring + , hedgehog + , hspec + , hspec-core + , hspec-expectations + , hspec-hedgehog + , mono-traversable + , refined + , refinery + , string-conversions + , string-variants , template-haskell , text default-language: Haskell2010 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Spec qualified +import Test.Hspec +import Test.Hspec.Runner (defaultConfig, hspecWith) +import Prelude + +main :: IO () +main = + hspecWith defaultConfig $ + parallel Spec.spec diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/test/Specs/NonEmptySpec.hs b/test/Specs/NonEmptySpec.hs new file mode 100644 --- /dev/null +++ b/test/Specs/NonEmptySpec.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} + +module Specs.NonEmptySpec (spec) where + +import Data.Maybe +import Data.Text (Text) +import Data.Text qualified as T +import Data.StringVariants.NonEmptyText +import Data.StringVariants.NullableNonEmptyText +import Data.StringVariants.Util (usePositiveNat) +import GHC.TypeLits +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Language.Haskell.TH.Quote (QuasiQuoter (quoteExp)) +import Prelude +import Test.Hspec +import Test.Hspec.Hedgehog (hedgehog) + +mkNonEmptyText299 :: Text -> Maybe (NonEmptyText 299) +mkNonEmptyText299 = mkNonEmptyText + +maybeTextToTruncateNullableNonEmptyText299 :: Maybe Text -> NullableNonEmptyText 299 +maybeTextToTruncateNullableNonEmptyText299 = maybeTextToTruncateNullableNonEmptyText + +mkNonEmptyText299WithTruncate :: Text -> Maybe (NonEmptyText 299) +mkNonEmptyText299WithTruncate = mkNonEmptyTextWithTruncate + +matchLength :: proxy (n :: Nat) -> other n -> other n +matchLength _ = id + +spec :: Spec +spec = describe "NonEmptyText variants" $ do + describe "NonEmptyText299" $ do + describe "compileNonEmptyText" $ do + it "should work" $ do + mkNonEmptyText299 "hi" `shouldBe` Just (widen [compileNonEmptyTextKnownLength|hi|]) + describe "compileNullableNonEmptyText" $ do + it "should work" $ do + $(quoteExp (compileNullableNonEmptyText 2) "yo") `shouldBe` NullableNonEmptyText (Just [compileNonEmptyTextKnownLength|yo|]) + describe "nonEmptyTextToText" $ do + it "should work" $ do + nonEmptyTextToText [compileNonEmptyTextKnownLength|yo|] `shouldBe` "yo" + + describe "Generalized NonEmptyText" $ do + describe "mkNonEmptyText" $ + it "should work" $ do + mkNonEmptyText299 "" `shouldBe` Nothing + mkNonEmptyText299 " " `shouldBe` Nothing + mkNonEmptyText299 "\n" `shouldBe` Nothing + mkNonEmptyText299 "\t" `shouldBe` Nothing + mkNonEmptyText299 "\NUL" `shouldBe` Nothing + mkNonEmptyText299 "x" `shouldSatisfy` isJust + + describe "literalNonEmptyText" $ do + it "should work" $ do + Just (literalNonEmptyText @"abc def") `shouldBe` mkNonEmptyText299 "abc def" + +-- test cases for bad strings. Alas, the -fdefer-type-errors defers the errors but then happily creates invalid values in runtime. Is this a GHC bug? + + -- describe "rejects invalid strings" $ do + -- it "rejects string too long" $ do + -- print (literalNonEmptyText @"abcdefghijkl" :: NonEmptyText 10) + -- `shouldThrow` (("Invalid NonEmptyText. Needs to be <= 10 characters. Has 12 characters." `isInfixOf`) . show) + -- it "rejects empty string" $ do + -- print (literalNonEmptyText @"" :: NonEmptyText 10) + -- `shouldThrow` (("Symbol is empty" `isInfixOf`) . show) + -- it "rejects string with leading whitespace" $ do + -- print (literalNonEmptyText @" abc" :: NonEmptyText 10) + -- `shouldThrow` (("Symbol has leading whitespace" `isInfixOf`) . show) + -- it "rejects string with trailing whitespace" $ do + -- print (literalNonEmptyText @"abc " :: NonEmptyText 10) + -- `shouldThrow` (("Symbol has leading whitespace" `isInfixOf`) . show) + -- it "rejects string with leading unicode whitespace" $ do + -- print (literalNonEmptyText @"\x2000abc" :: NonEmptyText 10) + -- `shouldThrow` (("Symbol has leading whitespace" `isInfixOf`) . show) + + describe "maybeTextToTruncateNullableNonEmptyText" $ do + it "common behavior" $ do + maybeTextToTruncateNullableNonEmptyText299 Nothing `shouldBe` NullableNonEmptyText Nothing + maybeTextToTruncateNullableNonEmptyText299 (Just "") `shouldBe` NullableNonEmptyText Nothing + maybeTextToTruncateNullableNonEmptyText299 (Just " ") `shouldBe` NullableNonEmptyText Nothing + it "type-dependent behavior" $ + hedgehog $ do + n <- forAll $ Gen.integral $ Range.constant 1 20000 + let n' = fromInteger n + usePositiveNat n (pure ()) $ \p -> do + let NullableNonEmptyText mtext = + matchLength p $ + maybeTextToTruncateNullableNonEmptyText + (Just $ T.pack $ replicate (n' + 1) 'x') + (T.length . nonEmptyTextToText <$> mtext) === Just n' + + describe "mkNonEmptyTextWithTruncate" $ do + it "common behavior" $ do + mkNonEmptyText299WithTruncate "" `shouldBe` Nothing + mkNonEmptyText299WithTruncate " " `shouldBe` Nothing + it "type-dependent behavior" $ + hedgehog $ do + n <- forAll $ Gen.integral $ Range.constant 1 20000 + let n' = fromInteger n + usePositiveNat n (pure ()) $ \(_ :: proxy n) -> do + let mtext = mkNonEmptyTextWithTruncate @n (T.pack $ replicate (n' + 1) 'x') + (T.length . nonEmptyTextToText <$> mtext) === Just n' diff --git a/test/Specs/TextManipulationSpec.hs b/test/Specs/TextManipulationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Specs/TextManipulationSpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Specs.TextManipulationSpec (spec) where + +import Data.Char +import Data.StringVariants.NonEmptyText +import Test.Hspec +import Prelude + +spec :: Spec +spec = describe "Text manipulation" do + describe "filterNonEmptyText" $ do + it "filterNonEmptyText returns Nothing when filtered string is empty" do + filterNonEmptyText (const False) [compileNonEmptyTextKnownLength|abc|] `shouldBe` Nothing + + it "filterNonEmptyText returns Nothing when filtered string only has spaces" do + filterNonEmptyText isSpace [compileNonEmptyTextKnownLength|a b|] `shouldBe` Nothing + + it "filterNonEmptyText returns stripped text" do + filterNonEmptyText (/= 'a') [compileNonEmptyTextKnownLength|a b a|] `shouldBe` Just (widen [compileNonEmptyTextKnownLength|b|]) + + describe "takeNonEmptyText" $ do + it "takeNonEmptyText returns stripped text" do + -- taking two characters results in a trailing space + takeNonEmptyText [compileNonEmptyTextKnownLength|a b|] `shouldBe` (widen [compileNonEmptyTextKnownLength|a|] :: NonEmptyText 2) + + describe "takeNonEmptyTextEnd" $ do + it "takeNonEmptyTextEnd returns stripped text" do + -- taking two characters results in a leading space + takeNonEmptyTextEnd [compileNonEmptyTextKnownLength|a b|] `shouldBe` (widen [compileNonEmptyTextKnownLength|b|] :: NonEmptyText 2) + + describe "chunksOfNonEmptyText" $ do + it "chunksOfNonEmptyText drops empty chunks" $ do + chunksOfNonEmptyText [compileNonEmptyTextKnownLength|a b|] + `shouldBe` ([[compileNonEmptyTextKnownLength|a|], [compileNonEmptyTextKnownLength|b|]] :: [NonEmptyText 1]) + it "chunksOfNonEmptyText strips chunks" $ do + chunksOfNonEmptyText [compileNonEmptyTextKnownLength|a b|] + `shouldBe` ([widen [compileNonEmptyTextKnownLength|a|], widen [compileNonEmptyTextKnownLength|b|]] :: [NonEmptyText 2])