module Test.Check.Utils
(
consFromList
, consFromAscendingList
, consFromStrictlyAscendingList
, consFromSet
, consFromNoDupList
, product3With
, productMaybeWith
, listsOf
, ascendingListsOf
, strictlyAscendingListsOf
, setsOf
, noDupListsOf
, products
, listsOfLength
, deleteT
, normalizeT
, choices
, ascendingChoices
, strictlyAscendingChoices
)
where
import Test.Check.Basic
import Data.Maybe (catMaybes)
consFromList :: Listable a => ([a] -> b) -> [[b]]
consFromList = (`mapT` listsOf tiers)
consFromAscendingList :: Listable a => ([a] -> b) -> [[b]]
consFromAscendingList = (`mapT` ascendingListsOf tiers)
consFromStrictlyAscendingList :: Listable a => ([a] -> b) -> [[b]]
consFromStrictlyAscendingList = (`mapT` strictlyAscendingListsOf tiers)
consFromSet :: Listable a => ([a] -> b) -> [[b]]
consFromSet = (`mapT` setsOf tiers)
consFromNoDupList :: Listable a => ([a] -> b) -> [[b]]
consFromNoDupList f = mapT f (noDupListsOf tiers)
product3With :: (a->b->c->d) -> [[a]] -> [[b]] -> [[c]] -> [[d]]
product3With f xss yss zss = productWith ($) (productWith f xss yss) zss
productMaybeWith :: (a->b->Maybe c) -> [[a]] -> [[b]] -> [[c]]
productMaybeWith _ _ [] = []
productMaybeWith _ [] _ = []
productMaybeWith f (xs:xss) yss = map (xs **) yss
\/ productMaybeWith f xss yss `addWeight` 1
where xs ** ys = catMaybes [ f x y | x <- xs, y <- ys ]
listsOf :: [[a]] -> [[[a]]]
listsOf xss = cons0 []
\/ productWith (:) xss (listsOf xss) `addWeight` 1
products :: [ [[a]] ] -> [[ [a] ]]
products = foldr (productWith (:)) [[[]]]
deleteT :: Eq a => a -> [[a]] -> [[a]]
deleteT _ [] = []
deleteT y ([]:xss) = [] : deleteT y xss
deleteT y [[x]] | x == y = []
deleteT y ((x:xs):xss) | x == y = xs:xss
| otherwise = [[x]] \/ deleteT y (xs:xss)
normalizeT :: [[a]] -> [[a]]
normalizeT [] = []
normalizeT [[]] = []
normalizeT (xs:xss) = xs:normalizeT xss
noDupListsOf :: [[a]] -> [[[a]]]
noDupListsOf =
([[]]:) . concatT . choicesWith (\x xss -> mapT (x:) (noDupListsOf xss))
choices :: [[a]] -> [[(a,[[a]])]]
choices = choicesWith (,)
choicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]]
choicesWith f [] = []
choicesWith f [[]] = []
choicesWith f ([]:xss) = [] : choicesWith (\y yss -> f y ([]:yss)) xss
choicesWith f ((x:xs):xss) = [[f x (xs:xss)]]
\/ choicesWith (\y (ys:yss) -> f y ((x:ys):yss)) (xs:xss)
ascendingListsOf :: [[a]] -> [[[a]]]
ascendingListsOf =
([[]]:) . concatT . ascendingChoicesWith (\x xss -> mapT (x:) (ascendingListsOf xss))
ascendingChoices :: [[a]] -> [[(a,[[a]])]]
ascendingChoices = ascendingChoicesWith (,)
ascendingChoicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]]
ascendingChoicesWith f [] = []
ascendingChoicesWith f [[]] = []
ascendingChoicesWith f ([]:xss) = [] : ascendingChoicesWith (\y yss -> f y ([]:yss)) xss
ascendingChoicesWith f ((x:xs):xss) = [[f x ((x:xs):xss)]]
\/ ascendingChoicesWith f (xs:xss)
strictlyAscendingListsOf :: [[a]] -> [[[a]]]
strictlyAscendingListsOf =
([[]]:) . concatT .
strictlyAscendingChoicesWith
(\x xss -> mapT (x:) (strictlyAscendingListsOf xss))
setsOf :: [[a]] -> [[[a]]]
setsOf = strictlyAscendingListsOf
strictlyAscendingChoices :: [[a]] -> [[(a,[[a]])]]
strictlyAscendingChoices = strictlyAscendingChoicesWith (,)
strictlyAscendingChoicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]]
strictlyAscendingChoicesWith f [] = []
strictlyAscendingChoicesWith f [[]] = []
strictlyAscendingChoicesWith f ([]:xss) = [] : strictlyAscendingChoicesWith (\y yss -> f y ([]:yss)) xss
strictlyAscendingChoicesWith f ((x:xs):xss) = [[f x (xs:xss)]]
\/ strictlyAscendingChoicesWith f (xs:xss)
listsOfLength :: Int -> [[a]] -> [[[a]]]
listsOfLength n xss = products (replicate n xss)