diff --git a/genvalidity-text.cabal b/genvalidity-text.cabal --- a/genvalidity-text.cabal +++ b/genvalidity-text.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.28.2. +cabal-version: >= 1.10 + +-- This file has been generated from package.yaml by hpack version 0.29.6. -- -- see: https://github.com/sol/hpack -- --- hash: b2736c8f08d545f919f3113a9d909d562daf368e62f0a7fb3a3d0332e596adc2 +-- hash: 0b74a2109a1d1a01ef347a56e9eb34ceafe87cdd703a165cc25c976325210d43 name: genvalidity-text -version: 0.5.0.2 +version: 0.5.1.0 synopsis: GenValidity support for Text description: Please see README.md category: Testing @@ -18,13 +20,16 @@ license: MIT license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 source-repository head type: git location: https://github.com/NorfairKing/validity library + exposed-modules: + Data.GenValidity.Text + other-modules: + Paths_genvalidity_text hs-source-dirs: src build-depends: @@ -35,15 +40,14 @@ , text , validity >=0.5 , validity-text >=0.3 - exposed-modules: - Data.GenValidity.Text - other-modules: - Paths_genvalidity_text default-language: Haskell2010 test-suite genvalidity-text-test type: exitcode-stdio-1.0 main-is: Spec.hs + other-modules: + Data.GenValidity.TextSpec + Paths_genvalidity_text hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-name-shadowing @@ -55,7 +59,4 @@ , genvalidity-text , hspec , text - other-modules: - Data.GenValidity.TextSpec - Paths_genvalidity_text default-language: Haskell2010 diff --git a/src/Data/GenValidity/Text.hs b/src/Data/GenValidity/Text.hs --- a/src/Data/GenValidity/Text.hs +++ b/src/Data/GenValidity/Text.hs @@ -10,14 +10,15 @@ import Control.Monad #if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure) +import Control.Applicative ((<*>), pure) import Data.Functor ((<$>)) #endif -import qualified Data.Text as T +import qualified Data.Text as ST import qualified Data.Text.Array as A -import Data.Text.Internal (Text(..)) +import qualified Data.Text.Internal as ST +import qualified Data.Text.Internal.Lazy as LT -instance GenUnchecked Text where +instance GenUnchecked ST.Text where genUnchecked = sized $ \n -> do size <- upTo n @@ -30,50 +31,78 @@ return arr off <- upTo $ max 0 (size - 1) let len = size - off - pure $ Text arr off len + pure $ ST.Text arr off len shrinkUnchecked _ = [] -instance GenValid Text where +instance GenValid ST.Text where genValid = sized $ \n -> do size <- upTo n chars <- resize size $ genListOf arbitrary - return $ T.pack chars - shrinkValid = fmap T.pack . shrinkValid . T.unpack + return $ ST.pack chars + shrinkValid = fmap ST.pack . shrinkValid . ST.unpack -instance GenInvalid Text +instance GenInvalid ST.Text +instance GenUnchecked LT.Text where + genUnchecked = + sized $ \n -> + case n of + 0 -> pure LT.Empty + _ -> do + (a, b) <- genSplit n + st <- resize a genUnchecked + lt <- resize b genUnchecked + pure $ LT.Chunk st lt + shrinkUnchecked LT.Empty = [] + shrinkUnchecked (LT.Chunk st lt) = + [LT.Chunk st' lt' | (st', lt') <- shrinkUnchecked (st, lt)] + +instance GenValid LT.Text where + genValid = + sized $ \n -> + case n of + 0 -> pure LT.Empty + _ -> do + (a, b) <- genSplit n + st <- ST.cons <$> genValid <*> resize a genValid + lt <- resize b genValid + pure $ LT.Chunk st lt + +instance GenInvalid LT.Text + -- | 'textStartingWith c' generates a 'Text' value that starts with 'c'. -textStartingWith :: Char -> Gen Text +textStartingWith :: Char -> Gen ST.Text textStartingWith c = sized $ \n -> case n of - 0 -> pure $ T.singleton c - 1 -> pure $ T.singleton c - _ -> T.cons c <$> resize (n - 1) genValid + 0 -> pure $ ST.singleton c + 1 -> pure $ ST.singleton c + _ -> ST.cons c <$> resize (n - 1) genValid -- | 'textStartingWith g' generates a 'Text' value that contains a substring generated by 'g'. -textWith :: Gen Text -> Gen Text +textWith :: Gen ST.Text -> Gen ST.Text textWith gen = sized $ \n -> do (b, m, a) <- genSplit3 n before <- resize b genValid middle <- resize m gen after <- resize a genValid - return $ T.concat [before, middle, after] + return $ ST.concat [before, middle, after] -- | 'textStartingWith c' generates a 'Text' value that contains a 'c'. -textWithA :: Char -> Gen Text -textWithA c = textWith $ T.singleton <$> pure c +textWithA :: Char -> Gen ST.Text +textWithA c = textWith $ ST.singleton <$> pure c -- | 'textWithoutAny c' generates a 'Text' value that does not contain any 'c'. -textWithoutAny :: Char -> Gen Text +textWithoutAny :: Char -> Gen ST.Text textWithoutAny c = textWithoutAnyOf [c] -- | 'textWithoutAnyOf c' generates a 'Text' value that does not contain any character in 'ls'. -textWithoutAnyOf :: String -> Gen Text -textWithoutAnyOf cs = T.pack <$> genListOf (arbitrary `suchThat` (`notElem` cs)) +textWithoutAnyOf :: String -> Gen ST.Text +textWithoutAnyOf cs = + ST.pack <$> genListOf (arbitrary `suchThat` (`notElem` cs)) -- | 'textAllCaps' generates a 'Text' value with only upper-case characters. -textAllCaps :: Gen Text -textAllCaps = T.toUpper <$> genValid +textAllCaps :: Gen ST.Text +textAllCaps = ST.toUpper <$> genValid diff --git a/test/Data/GenValidity/TextSpec.hs b/test/Data/GenValidity/TextSpec.hs --- a/test/Data/GenValidity/TextSpec.hs +++ b/test/Data/GenValidity/TextSpec.hs @@ -5,26 +5,26 @@ ) where import Control.Monad -import Data.Either import Data.List import Data.Word import Text.Printf import Test.Hspec import Test.QuickCheck +import Test.Validity -import Data.GenValidity import Data.GenValidity.Text -import qualified Data.Text as T +import qualified Data.Text as ST import qualified Data.Text.Array as A -import Data.Text.Internal (Text(Text)) +import qualified Data.Text.Internal as ST +import qualified Data.Text.Internal.Lazy as LT +import qualified Data.Text.Lazy as LT -showTextDebug :: Text -> String -showTextDebug t@(Text arr off len) = +showTextDebug :: ST.Text -> String +showTextDebug (ST.Text arr off len) = unlines - [ unwords [show t, "is invalid"] - , unwords + [ unwords [ "arr: " , intercalate "," $ map (printf "%4d" :: Word16 -> String) $ A.toList arr off len @@ -38,48 +38,70 @@ , unwords ["len: ", show len] ] +showLazyTextDebug :: LT.Text -> String +showLazyTextDebug LT.Empty = "empty" +showLazyTextDebug (LT.Chunk st lt) = + unlines + [ "A chuck with this strict text:" + , showTextDebug st + , "and this rest of the lazy text:" + , showLazyTextDebug lt, "" + ] + spec :: Spec spec = do - describe "genValid" $ do - it "is always empty when resized to 0" $ - forAll (resize 0 genValid) (`shouldSatisfy` T.null) - it "generates valid text" $ - forAll (genValid :: Gen Text) $ \t -> + describe "Strict Text" $ do + genValiditySpec @ST.Text + describe "genValid" $ do + it "is always empty when resized to 0" $ + forAll (resize 0 genValid) (`shouldSatisfy` ST.null) + it "generates valid text" $ + forAll (genValid) $ \t -> + unless (isValid t) $ expectationFailure $ showTextDebug t + describe "genUnchecked `suchThat` isValid" $ + it "generates valid text" $ + forAll ((genUnchecked :: Gen ST.Text) `suchThat` isValid) $ \t -> unless (isValid t) $ expectationFailure $ showTextDebug t - describe "genUnchecked `suchThat` isValid" $ - it "generates valid text" $ - forAll ((genUnchecked :: Gen Text) `suchThat` isValid) $ \t -> - unless (isValid t) $ expectationFailure $ showTextDebug t - describe "textStartingWith" $ do - it "is never empty" $ - forAll arbitrary $ \c -> - forAll (textStartingWith c) $ \t -> t `shouldNotSatisfy` T.null - it "contains exactly the first character if resized to 0" $ - forAll arbitrary $ \c -> - forAll (resize 0 $ textStartingWith c) $ \t -> - t `shouldBe` T.pack [c] - it "contains exactly the first character if resized to 1" $ + describe "textStartingWith" $ do + it "is never empty" $ + forAll arbitrary $ \c -> + forAll (textStartingWith c) $ \t -> + t `shouldNotSatisfy` ST.null + it "contains exactly the first character if resized to 0" $ + forAll arbitrary $ \c -> + forAll (resize 0 $ textStartingWith c) $ \t -> + t `shouldBe` ST.pack [c] + it "contains exactly the first character if resized to 1" $ + forAll arbitrary $ \c -> + forAll (resize 0 $ textStartingWith c) $ \t -> + t `shouldBe` ST.pack [c] + it "always starts with the given char" $ + forAll arbitrary $ \c -> + forAll (textStartingWith c) $ \t -> ST.head t `shouldBe` c + describe "textWithA" $ + it "contains the given character" $ forAll arbitrary $ \c -> - forAll (resize 0 $ textStartingWith c) $ \t -> - t `shouldBe` T.pack [c] - it "always starts with the given char" $ + forAll (textWithA c) $ \t -> ST.unpack t `shouldSatisfy` elem c + describe "textWithoutAny" $ + it "never contains the given char" $ forAll arbitrary $ \c -> - forAll (textStartingWith c) $ \t -> T.head t `shouldBe` c - describe "textWithA" $ - it "contains the given character" $ - forAll arbitrary $ \c -> - forAll (textWithA c) $ \t -> T.unpack t `shouldSatisfy` elem c - describe "textWithoutAny" $ - it "never contains the given char" $ - forAll arbitrary $ \c -> - forAll (textWithoutAny c) $ \t -> - T.unpack t `shouldNotSatisfy` elem c - describe "textWithoutAnyOf" $ - it "never contains any of the given chars" $ - forAll arbitrary $ \cs -> - forAll (textWithoutAnyOf cs) $ \text -> - T.unpack text `shouldNotSatisfy` (\t -> any (`elem` t) cs) - describe "isValid" $ - it "equals isRight . checkValidity" $ - forAll (genUnchecked @Text) $ \t -> - isValid t `shouldBe` isRight (checkValidity t) + forAll (textWithoutAny c) $ \t -> + ST.unpack t `shouldNotSatisfy` elem c + describe "textWithoutAnyOf" $ + it "never contains any of the given chars" $ + forAll arbitrary $ \cs -> + forAll (textWithoutAnyOf cs) $ \text -> + ST.unpack text `shouldNotSatisfy` (\t -> any (`elem` t) cs) + describe "Lazy Text" $ do + genValiditySpec @LT.Text + describe "genValid" $ do + it "is always empty when resized to 0" $ + forAll (resize 0 genValid) (`shouldSatisfy` LT.null) + it "generates valid text" $ + forAll (genValid) $ \t -> + unless (isValid t) $ + expectationFailure $ showLazyTextDebug t + describe "genUnchecked `suchThat` isValid" $ + it "generates valid text" $ + forAll ((genUnchecked :: Gen LT.Text) `suchThat` isValid) $ \t -> + unless (isValid t) $ expectationFailure $ showLazyTextDebug t