TextSpec.hs

{-# LANGUAGE TypeApplications #-}

module Data.GenValidity.TextSpec
    ( spec
    ) where

import Control.Monad
import Data.List
import Data.Word
import Text.Printf

import Test.Hspec
import Test.QuickCheck
import Test.Validity

import Data.GenValidity.Text

import qualified Data.Text as ST
import qualified Data.Text.Array as A
import qualified Data.Text.Internal as ST
import qualified Data.Text.Internal.Lazy as LT
import qualified Data.Text.Lazy as LT

showTextDebug :: ST.Text -> String
showTextDebug (ST.Text arr off len) =
    unlines
        [ unwords
              [ "arr:   "
              , intercalate "," $
                map (printf "%4d" :: Word16 -> String) $ A.toList arr off len
              ]
        , unwords
              [ "hexarr:"
              , intercalate "," $
                map (printf "%4x" :: Word16 -> String) $ A.toList arr off len
              ]
        , unwords ["off:      ", show off]
        , 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 "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 "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 (textWithA c) $ \t -> ST.unpack t `shouldSatisfy` elem c
        describe "textWithoutAny" $
            it "never contains the given char" $
            forAll arbitrary $ \c ->
                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