Text.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.GenValidity.Text where

import Data.GenValidity
import qualified Data.Text as ST
import qualified Data.Text.Internal.Lazy as LT
import qualified Data.Text.Lazy as LT
import Data.Validity.Text ()
import System.Random as Random
import Test.QuickCheck
import Test.QuickCheck.Gen
import Test.QuickCheck.Random

instance GenValid ST.Text where
  genValid = genText
  shrinkValid = fmap ST.pack . shrinkValid . ST.unpack

genText :: Gen ST.Text
genText = do
  len <- genListLength
  MkGen $ \qcgen _ -> ST.unfoldrN len (pure . random) qcgen

genTextBy :: Gen Char -> Gen ST.Text
genTextBy (MkGen charFunc) = do
  len <- genListLength
  MkGen $ \qcgen size ->
    let go :: QCGen -> Maybe (Char, QCGen)
        go qcg =
          let (qc1, qc2) = Random.split qcg
           in Just (charFunc qc1 size, qc2)
     in ST.unfoldrN len go qcgen

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
  shrinkValid = fmap LT.fromChunks . shrinkValid . LT.toChunks

-- | 'textStartingWith c' generates a 'Text' value that starts with 'c'.
textStartingWith :: Char -> Gen ST.Text
textStartingWith c =
  sized $ \n ->
    case n of
      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 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 $ ST.concat [before, middle, after]

-- | 'textStartingWith c' generates a 'Text' value that contains a '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 ST.Text
textWithoutAny c = textWithoutAnyOf [c]

-- | 'textWithoutAnyOf c' generates a 'Text' value that does not contain any character in 'ls'.
textWithoutAnyOf :: String -> Gen ST.Text
textWithoutAnyOf cs = ST.pack <$> genListOf (genValid `suchThat` (`notElem` cs))

-- | 'textAllCaps' generates a 'Text' value with only upper-case characters.
textAllCaps :: Gen ST.Text
textAllCaps = ST.toUpper <$> genValid

-- | 'genSingleLineText' generates a single-line text, that is without any line separators.
--
-- See 'Data.GenValidity.genNonLineSeparator' and 'Data.Validity.isLineSeparator'
genSingleLineText :: Gen ST.Text
genSingleLineText = genTextBy genNonLineSeparator