fused-effects-1.1.2.1: test/Gen.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-identities #-}
module Gen
( module Data.Functor.Identity
  -- * Polymorphic generation & instantiation
, m
, GenM
, genT
, T(..)
, a
, A
, b
, B
, c
, C
, e
, E
, r
, R
, s
, S
, w
, W
, unit
, identity
  -- * Handlers
, Run(..)
, runL
, runR
, runC
  -- * Generation
, Rec(..)
, forall_
  -- * Showing generated values
, showing
, GenTerm
, atom
, Gen.label
, infixL
, infixR
, pair
, addLabel
  -- * Test trees
, TestTree
, checkTestTree
, testGroup
, testProperty
  -- * Re-exports
, Gen
, (===)
, (/==)
, Gen.choice
, Gen.integral
, Gen.unicode
, Gen.string
, Gen.subtermM
, Gen.subtermM2
, Fn.Arg
, Fn.Vary
, Gen.fn
, termFn
, Fn.apply
) where

import           Control.Applicative
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Writer
import           Data.Foldable (traverse_)
import           Data.Function (on)
import           Data.Functor.Classes (showsUnaryWith)
import           Data.Functor.Identity
import           Data.Proxy
import qualified Data.Semigroup as S
import qualified Data.Set as Set
import           Data.String (fromString)
import           GHC.Generics ((:.:)(..))
import           GHC.Stack
import           GHC.TypeLits
import           Hedgehog hiding (Rec (..))
import qualified Hedgehog.Function as Fn
import           Hedgehog.Gen as Hedgehog
import           Hedgehog.Range

-- | A generator for computations, given a higher-order generator for effectful operations, & a generator for results.
m
  :: forall m
  .  Monad m
  => (forall a . GenTerm a -> [GenTerm (m a)])
  -> (forall a . GenM m -> GenTerm a -> [GenTerm (m a)]) -- ^ A higher-order computation generator using any effects in @m@.
  -> GenM m                                              -- ^ A computation generator.
m terminals nonterminals = m where
  m :: GenM m
  m a = Comp1 $ scale (`div` 2) $ recursive Hedgehog.choice
    (unComp1 <$> ((Gen.label "pure" pure <*> a) : terminals a))
    ( unComp1 (addLabel ">>" (Gen.subtermM2 (m a) (m a) (\ a b -> infixL 1 ">>" (>>) <*> a <*> b)))
    : (unComp1 <$> nonterminals m a))

-- | Computation generators are higher-order generators of computations in some monad @m@.
type GenM m = (forall a . GenTerm a -> GenTerm (m a))


genT :: KnownSymbol s => GenTerm (T s)
genT = Gen.integral (linear 0 100)

newtype T (a :: Symbol) = T { unT :: Integer }
  deriving (Enum, Eq, Fn.Generic, Integral, Num, Ord, Real, Fn.Vary)

instance Fn.Arg (T a)

instance S.Semigroup (T a) where
  T a <> T b = T (a + b)

instance Monoid (T a) where
  mempty = T 0
  mappend = (S.<>)

instance KnownSymbol s => Show (T s) where
  showsPrec d = showsUnaryWith showsPrec (symbolVal (Proxy @s)) d . unT

a :: GenTerm A
a = genT

type A = T "A"

b :: GenTerm B
b = genT

type B = T "B"

c :: GenTerm C
c = genT

type C = T "C"

e :: GenTerm E
e = genT

type E = T "E"

r :: GenTerm R
r = genT

type R = T "R"

s :: GenTerm S
s = genT

type S = T "S"

w :: GenTerm W
w = genT

type W = T "W"

unit :: GenTerm ()
unit = atom "()" ()

identity :: GenTerm (a -> Identity a)
identity = atom "Identity" Identity

fn :: (Fn.Arg a, Fn.Vary a, Show a) => GenTerm b -> GenTerm (a -> b)
fn b = Comp1 (lift (fmap (fmap runTerm) . showingFn <$> Fn.fn (fst <$> runWriterT (unComp1 b))))

termFn :: GenTerm b -> GenTerm (a -> b)
termFn b = Comp1 $ recursive Hedgehog.choice
  [ unComp1 (atom "const" const <*> b) ]
  []

choice :: [GenTerm a] -> GenTerm a
choice = Comp1 . Hedgehog.choice . Prelude.map unComp1

integral :: (Integral a, Show a) => Range a -> GenTerm a
integral range = Comp1 (showing <$> Hedgehog.integral range)

unicode :: GenTerm Char
unicode = Comp1 (showing <$> Hedgehog.unicode)

string :: Range Int -> GenTerm Char -> GenTerm String
string range cs = Comp1 (showing <$> Hedgehog.string range (runTerm <$> unComp1 cs))

subtermM :: GenTerm a -> (GenTerm a -> GenTerm a) -> GenTerm a
subtermM t f = Comp1 (Hedgehog.subtermM (unComp1 t) (unComp1 . f . term))

subtermM2 :: GenTerm a -> GenTerm a -> (GenTerm a -> GenTerm a -> GenTerm a) -> GenTerm a
subtermM2 t1 t2 f = Comp1 (Hedgehog.subtermM2 (unComp1 t1) (unComp1 t2) (fmap unComp1 . f `on` term))


-- | This captures the shape of the handler function passed to the "Monad" & "MonadFix" tests.
newtype Run f g m = Run (forall a . f (m a) -> Identity (g a))

-- | Handlers with output state, but no input state (e.g. 'Control.Carrier.Error.Either.ErrorC').
runL :: (forall a . m a -> Identity (f a)) -> Run Identity f m
runL run = Run (run . runIdentity)

-- | Handlers with input state, but no output state (e.g. 'Control.Carrier.Reader.ReaderC').
runR :: (forall a . f (m a) -> Identity a) -> Run f Identity m
runR run = Run (fmap Identity . run)

-- | Handlers with curried input state (e.g. 'Control.Carrier.Reader.ReaderC', 'Control.Carrier.State.Strict.StateC').
runC :: (forall a . s -> m a -> Identity (f a)) -> Run ((,) s) f m
runC run = Run (uncurry run)


infixr 5 :.

data Rec as where
  Nil :: Rec '[]
  (:.) :: a -> Rec as -> Rec (a ': as)

forall_ :: (Forall g f, HasCallStack) => g -> f -> Hedgehog.Property
forall_ g f = withFrozenCallStack $ Hedgehog.property (forall' g f)

class Forall g f | g -> f, f -> g where
  forall' :: HasCallStack => g -> f -> PropertyT IO ()

instance Forall (Rec '[]) (PropertyT IO ()) where
  forall' Nil = id

instance (Forall (Rec gs) b) => Forall (Rec (GenTerm a ': gs)) (a -> b) where
  forall' (g :. gs) f = do
    HideLabels (a, labels) <- Hedgehog.forAll (HideLabels <$> runWriterT (unComp1 g))
    traverse_ Hedgehog.label labels
    forall' gs (f (runTerm a))

newtype HideLabels a = HideLabels { unHideLabels :: (a, Set.Set LabelName) }

instance Show a => Show (HideLabels a) where
  showsPrec d = showsPrec d . fst . unHideLabels


showing :: Show a => a -> Term a
showing = Pure . flip showsPrec <*> id

showingFn :: (Show a, Show b) => Fn.Fn a b -> Term (a -> b)
showingFn = Pure . flip showsPrec <*> Fn.apply


type GenTerm = WriterT (Set.Set LabelName) Gen :.: Term

term :: Term a -> GenTerm a
term = Comp1 . pure

atom :: String -> a -> GenTerm a
atom s = term . Pure (const (showString s))

label :: String -> a -> GenTerm a
label s = addLabel s . atom s

infixL :: Int -> String -> (a -> b -> c) -> GenTerm (a -> b -> c)
infixL p s f = term (InfixL p s f)

infixR :: Int -> String -> (a -> b -> c) -> GenTerm (a -> b -> c)
infixR p s f = term (InfixR p s f)

pair :: GenTerm (a -> b -> (a, b))
pair = term Pair

addLabel :: String -> GenTerm a -> GenTerm a
addLabel s = Comp1 . (>>= (<$ tell (Set.singleton (fromString s)))) . unComp1


data Term a where
  Pure :: (Int -> ShowS) -> a -> Term a
  InfixL :: Int -> String -> (a -> b -> c) -> Term (a -> b -> c)
  InfixR :: Int -> String -> (a -> b -> c) -> Term (a -> b -> c)
  Pair :: Term (a -> b -> (a, b))
  (:<*>) :: Term (a -> b) -> Term a -> Term b

infixl 4 :<*>

runTerm :: Term a -> a
runTerm = \case
  Pure _ a -> a
  InfixL _ _ f -> f
  InfixR _ _ f -> f
  Pair -> (,)
  f :<*> a -> runTerm f $ runTerm a

instance Functor Term where
  fmap = liftA

instance Applicative Term where
  pure = Pure (const (showString "_"))
  (<*>) = (:<*>)

instance Show (Term a) where
  showsPrec d = \case
    Pure s _ -> s d
    InfixL _ s _ -> showParen True (showString s)
    InfixR _ s _ -> showParen True (showString s)
    Pair -> showParen True (showString ",")
    InfixL p s _ :<*> a :<*> b -> showParen (d > p) (showsPrec p a . showString " " . showString s . showString " " . showsPrec (succ p) b)
    InfixR p s _ :<*> a :<*> b -> showParen (d > p) (showsPrec (succ p) a . showString " " . showString s . showString " " . showsPrec p b)
    Pair :<*> a :<*> b -> showParen True (shows a . showString ", " . shows b)
    InfixL p s _ :<*> a -> showParen True (showsPrec p a . showString " " . showString s)
    InfixR p s _ :<*> a -> showParen True (showsPrec (succ p) a . showString " " . showString s)
    f :<*> a -> showParen (d > 10) (showsPrec 10 f . showString " " . showsPrec 11 a)


data TestTree
  = Leaf String Property
  | Branch String [TestTree]

checkTestTree :: TestTree -> IO Bool
checkTestTree = \case
  Leaf   n p  ->        putStrLn n  *> check p                   <* putStrLn ""
  Branch n ts -> and <$ putStrLn n <*> traverse checkTestTree ts <* putStrLn ""

testGroup :: String -> [TestTree] -> TestTree
testGroup = Branch

testProperty :: String -> Property -> TestTree
testProperty = Leaf