GenValidity.hs

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- |
--
--    @GenValid@ exists to make tests involving @Validity@ types easier and
--    speed up the generation of data for them.
--
--    To implement tests for this datatype, we would have to be able to
--    generate both primes. We could do this with a generator like this one:
--
--    > (Prime <$> 'arbitrary') `suchThat` isValid
--
--    However, this is tedious and inefficient, as well as quite
--    naive (because 'arbitrary' tends to use very naive generators).
--
--    The @GenValid@ type class allows you to specify how to (efficiently)
--    generate valid data of the given type to allow for easier and quicker testing.
--    The default implementation of `GenValid` already gives you a generator and shrinking function
--    for free:
--
--    > instance GenValid Prime
--
--    For example, to generate primes, we don't have to consider even numbers other
--    than 2. A more efficient implementation could then look as follows:
--
--    > instance GenValid Prime where
--    >     genValid = Prime <$>
--    >        (oneof
--    >          [ pure 2
--    >          , ((\y -> 2 * abs y + 1) <$> arbitrary) `suchThat` isPrime)
--    >          ])
--
--
--    Typical examples of tests involving validity could look as follows:
--
--    > it "succeeds when given valid input" $ do
--    >     forAllValid $ \input ->
--    >         myFunction input `shouldSatisfy` isRight
--
--    > it "produces valid output when it succeeds" $ do
--    >     forAllValid $ \input ->
--    >         case myFunction input of
--    >             Nothing -> return () -- Can happen
--    >             Just output -> output `shouldSatisfy` isValid
--
--    Definitely also look at the companion packages for more info on how to use this package.
module Data.GenValidity
  ( GenValid (..),

    -- * Helper functions
    genValidStructurally,
    genValidStructurallyWithoutExtraChecking,
    shrinkValidStructurally,
    shrinkValidStructurallyWithoutExtraFiltering,
    module Data.GenValidity.Utils,

    -- ** Helper functions for specific types

    -- *** Char
    genUtf16SurrogateCodePoint,
    genLineSeparator,
    genNonLineSeparator,

    -- *** String
    genSingleLineString,

    -- * Re-exports
    module Data.Validity,

    -- * The Generics magic
    GGenValid (..),
    GValidRecursivelyShrink (..),
    structurallyValidSubterms,
    GValidSubterms (..),
    GValidSubtermsIncl (..),
  )
where

import Control.Monad (guard)
import Data.Char (chr)
import Data.Fixed (Fixed (..), HasResolution)
import Data.GenValidity.Utils
import Data.Int (Int16, Int32, Int64, Int8)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Ratio ((%))
import Data.Validity
import Data.Word (Word16, Word32, Word64, Word8)
import GHC.Generics
import GHC.Real (Ratio (..))
import Numeric.Natural
import Test.QuickCheck hiding (Fixed)

{-# ANN module "HLint: ignore Reduce duplication" #-}

-- | A class of types for which valid values can be generated to be valid.
--
-- === How to instantiate 'GenValid'
--
-- __Step 1__: Try to instantiate 'GenValid' without overriding any functions.
--             It is possible that, if few values are valid or if validity
--             checking is expensive, the resulting generator is too slow.
--             In that case, go to Step 2.
--
-- __Step 2__: Consider using 'genValidStructurallyWithoutExtraChecking' and
--             'shrinkValidStructurallyWithoutExtraFiltering' to speed up generation.
--             This only works if your type has a derived or trivial 'Validity'
--             instance.
--
-- __Step 3__: If that still is not fast enough, consider writing your own
--             generator and shrinking function.
--             Make sure to generate any possible valid value, but only valid values.
--
-- === A note about 'Arbitrary'
--
-- If you also write @Arbitrary@ instances for @GenValid@ types, it may be
-- best to simply use
--
-- > instance Arbitrary A where
-- >   arbitrary = genValid
-- >   shrink = shrinkValid
class Validity a => GenValid a where
  -- | Generate a valid datum, this should cover all possible valid values in
  -- the type
  --
  -- The default implementation is as follows:
  --
  -- >  genValid = genValidStructurally
  --
  -- To speed up testing, it may be a good idea to implement this yourself.
  -- If you do, make sure that it is possible to generate all possible valid
  -- data, otherwise your testing may not cover all cases.
  genValid :: Gen a
  default genValid :: (Generic a, GGenValid (Rep a)) => Gen a
  genValid = genValidStructurally

  -- | Shrink a valid value.
  --
  -- The default implementation is as follows:
  --
  -- >  shrinkValid = shrinkValidStructurally
  --
  -- It is important that this shrinking function only shrinks values to valid values.
  -- If `shrinkValid` ever shrinks a value to an invalid value, the test that is being shrunk for
  -- might fail for a different reason than for the reason that it originally failed.
  -- This would lead to very confusing error messages.
  shrinkValid :: a -> [a]
  default shrinkValid :: (Generic a, GValidRecursivelyShrink (Rep a), GValidSubterms (Rep a) a) => a -> [a]
  shrinkValid = shrinkValidStructurally

instance (GenValid a, GenValid b) => GenValid (a, b) where
  genValid =
    sized $ \n -> do
      (r, s) <- genSplit n
      a <- resize r genValid
      b <- resize s genValid
      return (a, b)
  shrinkValid = shrinkTuple shrinkValid shrinkValid

instance (GenValid a, GenValid b) => GenValid (Either a b) where
  genValid = oneof [Left <$> genValid, Right <$> genValid]
  shrinkValid (Left a) = Left <$> shrinkValid a
  shrinkValid (Right b) = Right <$> shrinkValid b

instance (GenValid a, GenValid b, GenValid c) => GenValid (a, b, c) where
  genValid =
    sized $ \n -> do
      (r, s, t) <- genSplit3 n
      a <- resize r genValid
      b <- resize s genValid
      c <- resize t genValid
      return (a, b, c)
  shrinkValid (a, b, c) =
    [ (a', b', c')
      | (a', (b', c')) <- shrinkValid (a, (b, c))
    ]

instance
  (GenValid a, GenValid b, GenValid c, GenValid d) =>
  GenValid (a, b, c, d)
  where
  genValid =
    sized $ \n -> do
      (r, s, t, u) <- genSplit4 n
      a <- resize r genValid
      b <- resize s genValid
      c <- resize t genValid
      d <- resize u genValid
      return (a, b, c, d)
  shrinkValid (a, b, c, d) =
    [ (a', b', c', d')
      | (a', (b', (c', d'))) <- shrinkValid (a, (b, (c, d)))
    ]

instance
  (GenValid a, GenValid b, GenValid c, GenValid d, GenValid e) =>
  GenValid (a, b, c, d, e)
  where
  genValid =
    sized $ \n -> do
      (r, s, t, u, v) <- genSplit5 n
      a <- resize r genValid
      b <- resize s genValid
      c <- resize t genValid
      d <- resize u genValid
      e <- resize v genValid
      return (a, b, c, d, e)
  shrinkValid (a, b, c, d, e) =
    [ (a', b', c', d', e')
      | (a', (b', (c', (d', e')))) <- shrinkValid (a, (b, (c, (d, e))))
    ]

instance GenValid a => GenValid (Maybe a) where
  genValid = oneof [pure Nothing, Just <$> genValid]
  shrinkValid Nothing = []
  shrinkValid (Just a) = Nothing : (Just <$> shrinkValid a)

instance GenValid a => GenValid (NonEmpty a) where
  genValid = genNonEmptyOf genValid
  shrinkValid (v :| vs) = [e :| es | (e, es) <- shrinkValid (v, vs)]

instance GenValid a => GenValid [a] where
  genValid = genListOf genValid
  shrinkValid = shrinkList shrinkValid

instance GenValid () where
  genValid = pure ()
  shrinkValid () = []

instance GenValid Bool where
  genValid = arbitrary
  shrinkValid = shrink

instance GenValid Ordering where
  genValid = arbitrary
  shrinkValid = shrink

instance GenValid Char where
  genValid =
    frequency
      [ (9, choose (minBound, maxBound)),
        (1, genUtf16SurrogateCodePoint)
      ]
  shrinkValid = shrink

genUtf16SurrogateCodePoint :: Gen Char
genUtf16SurrogateCodePoint = chr <$> oneof [choose (0xD800, 0xDBFF), choose (0xDC00, 0xDFFF)]

genLineSeparator :: Gen Char
genLineSeparator = elements ['\n', '\r']

genNonLineSeparator :: Gen Char
genNonLineSeparator = genValid `suchThat` (not . isLineSeparator)

genSingleLineString :: Gen String
genSingleLineString = genListOf genNonLineSeparator

instance GenValid Int where
  genValid = genIntX
  shrinkValid = shrink

instance GenValid Int8 where
  genValid = genIntX
  shrinkValid = shrink

instance GenValid Int16 where
  genValid = genIntX
  shrinkValid = shrink

instance GenValid Int32 where
  genValid = genIntX
  shrinkValid = shrink

instance GenValid Int64 where
  genValid = genIntX
  shrinkValid = shrink

instance GenValid Word where
  genValid = genWordX
  shrinkValid = shrink

instance GenValid Word8 where
  genValid = genWordX
  shrinkValid = shrink

instance GenValid Word16 where
  genValid = genWordX
  shrinkValid = shrink

instance GenValid Word32 where
  genValid = genWordX
  shrinkValid = shrink

instance GenValid Word64 where
  genValid = genWordX
  shrinkValid = shrink

instance GenValid Float where
  genValid = genFloat
  shrinkValid f
    | isInfinite f = []
    | isNaN f = []
    | otherwise = shrink f

instance GenValid Double where
  genValid = genDouble
  shrinkValid d
    | isInfinite d = []
    | isNaN d = []
    | otherwise = shrink d

instance GenValid Integer where
  genValid = genInteger
  shrinkValid = shrink

instance GenValid Natural where
  genValid = fromInteger . abs <$> genValid
  shrinkValid = fmap (fromInteger . abs) . shrinkValid . toInteger

instance (Integral a, Num a, Ord a, GenValid a) => GenValid (Ratio a) where
  genValid =
    ( do
        n <- genValid
        d <- (genValid `suchThat` (> 0))
        pure $ n :% d
    )
      `suchThat` isValid
  shrinkValid (n :% d) = do
    (n', d') <- shrinkValid (n, d)
    guard $ d' > 0
    let candidate = n' :% d'
    guard $ isValid candidate
    pure $ n' % d'

instance HasResolution a => GenValid (Fixed a) where
  genValid = MkFixed <$> genValid
  shrinkValid (MkFixed i) = MkFixed <$> shrinkValid i

-- | Generate a valid value by generating all the sub parts using the 'Generic' instance,
-- and trying that until a valid value has been generated
--
-- > genValidStructurally = genValidStructurallyWithoutExtraChecking `suchThat` isValid
--
-- This is probably the function that you are looking for.
-- If you do use this function to override `genValid`, you probably also want to use
-- 'shrinkValidStructurally' to override 'shrinkValid'.
genValidStructurally :: (Validity a, Generic a, GGenValid (Rep a)) => Gen a
genValidStructurally = genValidStructurallyWithoutExtraChecking `suchThat` isValid

-- | Generate a valid value by generating all the sub parts using the 'Generic' instance,
--
-- This generator is _not_ guaranteed to generate a valid value.
--
-- This is probably _not_ the function that you are looking for when overriding
-- `genValid` _unless_ the type in question has no _extra_ validity constraints on top of
-- the validity of its sub parts.
genValidStructurallyWithoutExtraChecking :: (Generic a, GGenValid (Rep a)) => Gen a
genValidStructurallyWithoutExtraChecking = to <$> gGenValid

class GGenValid f where
  gGenValid :: Gen (f a)

instance GGenValid U1 where
  gGenValid = pure U1

instance (GGenValid a, GGenValid b) => GGenValid (a :*: b) where
  gGenValid = (:*:) <$> gGenValid <*> gGenValid

instance (GGenValid a, GGenValid b) => GGenValid (a :+: b) where
  gGenValid = oneof [L1 <$> gGenValid, R1 <$> gGenValid]

instance (GGenValid a) => GGenValid (M1 i c a) where
  gGenValid = M1 <$> gGenValid

instance (GenValid a) => GGenValid (K1 i a) where
  gGenValid = K1 <$> genValid

-- | Shrink a term to any of its immediate valid subterms,
-- and also recursively shrink all subterms, and then filtering out the results that are not valid.
--
-- > shrinkValidStructurally = filter isValid . shrinkValidStructurallyWithoutExtraFiltering
--
-- This is probably the function that you are looking for.
shrinkValidStructurally :: (Validity a, Generic a, GValidRecursivelyShrink (Rep a), GValidSubterms (Rep a) a) => a -> [a]
shrinkValidStructurally = filter isValid . shrinkValidStructurallyWithoutExtraFiltering

-- | Shrink a term to any of its immediate valid subterms,
-- and also recursively shrink all subterms.
--
-- This shrinking function is _not_ guaranteed to shrink to valid values.
--
-- This is probably _not_ the function that you are looking for when overriding
-- `shrinkValid` _unless_ the type in question has no _extra_ validity constraints on top of
-- the validity of its sub parts.
shrinkValidStructurallyWithoutExtraFiltering :: (Generic a, GValidRecursivelyShrink (Rep a), GValidSubterms (Rep a) a) => a -> [a]
shrinkValidStructurallyWithoutExtraFiltering x = structurallyValidSubterms x ++ structurallyValidRecursivelyShrink x

-- | Recursively shrink all immediate structurally valid subterms.
structurallyValidRecursivelyShrink :: (Generic a, GValidRecursivelyShrink (Rep a)) => a -> [a]
structurallyValidRecursivelyShrink = map to . gValidRecursivelyShrink . from

class GValidRecursivelyShrink f where
  gValidRecursivelyShrink :: f a -> [f a]

instance (GValidRecursivelyShrink f, GValidRecursivelyShrink g) => GValidRecursivelyShrink (f :*: g) where
  gValidRecursivelyShrink (x :*: y) =
    ((:*:) <$> gValidRecursivelyShrink x <*> gValidRecursivelyShrink y)
      ++ [x' :*: y | x' <- gValidRecursivelyShrink x]
      ++ [x :*: y' | y' <- gValidRecursivelyShrink y]

instance (GValidRecursivelyShrink f, GValidRecursivelyShrink g) => GValidRecursivelyShrink (f :+: g) where
  gValidRecursivelyShrink (L1 x) = map L1 (gValidRecursivelyShrink x)
  gValidRecursivelyShrink (R1 x) = map R1 (gValidRecursivelyShrink x)

instance GValidRecursivelyShrink f => GValidRecursivelyShrink (M1 i c f) where
  gValidRecursivelyShrink (M1 x) = map M1 (gValidRecursivelyShrink x)

instance GenValid a => GValidRecursivelyShrink (K1 i a) where
  gValidRecursivelyShrink (K1 x) = map K1 (shrinkValid x)

instance GValidRecursivelyShrink U1 where
  gValidRecursivelyShrink U1 = []

instance GValidRecursivelyShrink V1 where
  -- The empty type can't be shrunk to anything.
  gValidRecursivelyShrink _ = []

-- | All immediate validSubterms of a term.
structurallyValidSubterms :: (Generic a, GValidSubterms (Rep a) a) => a -> [a]
structurallyValidSubterms = gValidSubterms . from

class GValidSubterms f a where
  gValidSubterms :: f a -> [a]

instance GValidSubterms V1 a where
  gValidSubterms _ = []

instance GValidSubterms U1 a where
  gValidSubterms U1 = []

instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubterms (f :*: g) a where
  gValidSubterms (l :*: r) = gValidSubtermsIncl l ++ gValidSubtermsIncl r

instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubterms (f :+: g) a where
  gValidSubterms (L1 x) = gValidSubtermsIncl x
  gValidSubterms (R1 x) = gValidSubtermsIncl x

instance GValidSubterms f a => GValidSubterms (M1 i c f) a where
  gValidSubterms (M1 x) = gValidSubterms x

instance GValidSubterms (K1 i a) b where
  gValidSubterms (K1 _) = []

class GValidSubtermsIncl f a where
  gValidSubtermsIncl :: f a -> [a]

instance GValidSubtermsIncl V1 a where
  gValidSubtermsIncl _ = []

instance GValidSubtermsIncl U1 a where
  gValidSubtermsIncl U1 = []

instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubtermsIncl (f :*: g) a where
  gValidSubtermsIncl (l :*: r) = gValidSubtermsIncl l ++ gValidSubtermsIncl r

instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubtermsIncl (f :+: g) a where
  gValidSubtermsIncl (L1 x) = gValidSubtermsIncl x
  gValidSubtermsIncl (R1 x) = gValidSubtermsIncl x

instance GValidSubtermsIncl f a => GValidSubtermsIncl (M1 i c f) a where
  gValidSubtermsIncl (M1 x) = gValidSubtermsIncl x

-- This is the important case: We've found a term of the same type.
instance {-# OVERLAPPING #-} GValidSubtermsIncl (K1 i a) a where
  gValidSubtermsIncl (K1 x) = [x]

instance {-# OVERLAPPING #-} GValidSubtermsIncl (K1 i a) b where
  gValidSubtermsIncl (K1 _) = []