{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, TypeOperators #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif
-- |
-- Module      : Test.LeanCheck.Generic
-- Copyright   : (c) 2018-2020 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- This module is part of LeanCheck,
-- a simple enumerative property-based testing library.
--
-- This is an experimental module for deriving 'Listable' instances through
-- GHC's generic.
--
-- If you rather do this through Template Haskell please see:
-- "Test.LeanCheck.Derive".
module Test.LeanCheck.Generic
  ( genericList
  , genericTiers
  )
where

import GHC.Generics
import Test.LeanCheck.Core

-- | A generic implementation of 'list' for instances of 'Generic'.
--
-- Use it to define your 'Listable' instances like so:
--
-- > instance Listable MyType where
-- >   list  =  genericList
--
-- Consider using 'genericTiers' instead of this
-- (unless you know what you're doing).
genericList :: (Generic a, Listable' (Rep a)) => [a]
genericList :: [a]
genericList  =  [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
forall a. (Generic a, Listable' (Rep a)) => [[a]]
genericTiers

-- | A generic implementation of 'tiers' for instances of 'Generic'.
--
-- Use it to define your 'Listable' instances like so:
--
-- > instance Listable MyType where
-- >   tiers  =  genericTiers
genericTiers :: (Generic a, Listable' (Rep a)) => [[a]]
genericTiers :: [[a]]
genericTiers  =  (Rep a Any -> a) -> [[Rep a Any]] -> [[a]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to [[Rep a Any]]
forall (f :: * -> *) p. Listable' f => [[f p]]
tiers'

class Listable' f where
  tiers' :: [[f p]]

instance Listable' V1 where
  tiers' :: [[V1 p]]
tiers'  =  [[V1 p]]
forall a. HasCallStack => a
undefined

instance Listable' U1 where
  tiers' :: [[U1 p]]
tiers'  =  [[U1 p
forall k (p :: k). U1 p
U1]]

instance Listable c => Listable' (K1 i c) where
  tiers' :: [[K1 i c p]]
tiers'  =  (c -> K1 i c p) -> [[c]] -> [[K1 i c p]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT c -> K1 i c p
forall k i c (p :: k). c -> K1 i c p
K1 [[c]]
forall a. Listable a => [[a]]
tiers

instance (Listable' a, Listable' b) => Listable' (a :+: b) where
  tiers' :: [[(:+:) a b p]]
tiers'  =  (a p -> (:+:) a b p) -> [[a p]] -> [[(:+:) a b p]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT a p -> (:+:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 [[a p]]
forall (f :: * -> *) p. Listable' f => [[f p]]
tiers' [[(:+:) a b p]] -> [[(:+:) a b p]] -> [[(:+:) a b p]]
forall a. [[a]] -> [[a]] -> [[a]]
\/ (b p -> (:+:) a b p) -> [[b p]] -> [[(:+:) a b p]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT b p -> (:+:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 [[b p]]
forall (f :: * -> *) p. Listable' f => [[f p]]
tiers'

instance (Listable' a, Listable' b) => Listable' (a :*: b) where
  tiers' :: [[(:*:) a b p]]
tiers'  =  (a p -> b p -> (:*:) a b p)
-> [[a p]] -> [[b p]] -> [[(:*:) a b p]]
forall a b c. (a -> b -> c) -> [[a]] -> [[b]] -> [[c]]
productWith a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) [[a p]]
forall (f :: * -> *) p. Listable' f => [[f p]]
tiers' [[b p]]
forall (f :: * -> *) p. Listable' f => [[f p]]
tiers'

instance Listable' f => Listable' (S1 c f) where
  tiers' :: [[S1 c f p]]
tiers'  =  (f p -> S1 c f p) -> [[f p]] -> [[S1 c f p]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT f p -> S1 c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 [[f p]]
forall (f :: * -> *) p. Listable' f => [[f p]]
tiers'

instance Listable' f => Listable' (D1 c f) where
  tiers' :: [[D1 c f p]]
tiers'  =  (f p -> D1 c f p) -> [[f p]] -> [[D1 c f p]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT f p -> D1 c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 [[f p]]
forall (f :: * -> *) p. Listable' f => [[f p]]
tiers'

#if __GLASGOW_HASKELL__ >= 710
-- don't delay when there is a constructor with 0 arguments
instance {-# OVERLAPPING #-} Listable' (C1 c U1) where
  tiers' :: [[C1 c U1 p]]
tiers'  =  (U1 p -> C1 c U1 p) -> [[U1 p]] -> [[C1 c U1 p]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT U1 p -> C1 c U1 p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 [[U1 p]]
forall (f :: * -> *) p. Listable' f => [[f p]]
tiers'

-- delay when there is a constructor with 1 or more arguments
instance {-# OVERLAPPABLE #-} Listable' f => Listable' (C1 c f) where
  tiers' :: [[C1 c f p]]
tiers'  =  [[C1 c f p]] -> [[C1 c f p]]
forall a. [[a]] -> [[a]]
delay ([[C1 c f p]] -> [[C1 c f p]]) -> [[C1 c f p]] -> [[C1 c f p]]
forall a b. (a -> b) -> a -> b
$ (f p -> C1 c f p) -> [[f p]] -> [[C1 c f p]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT f p -> C1 c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 [[f p]]
forall (f :: * -> *) p. Listable' f => [[f p]]
tiers'
#else

instance Listable' (C1 c U1)
  where tiers'  =  mapT M1 tiers'

instance Listable' f => Listable' (C1 c f)
  where tiers'  =  delay $ mapT M1 tiers'
#endif