-- | Provides test identification by Search Using Golden Answer
-- References.  This is similar in principle to Tasty.KAT and
-- Tasty.Golden, but with different input selection processes.  The
-- intent is that there are multiple different test scenarios, which
-- may all originate with the same input, and that all scenarios are
-- specified by the presence of an "expected" result file along with
-- optional support files.
--
-- A 'Tasty.Sugar.CUBE' object is provided to the 'findSugar' function
-- which returns an array of 'Tasty.Sugar.Sweets' that describe test
-- configurations.
--
-- The 'sugarOptions' should be added to the tasty Options
-- specification, and the 'sugarIngredients' provides additional
-- ingredients for the sugar testing (e.g. the ability to use
-- --showsearch and see the scan and identification of tests).
--
-- The 'withSugarGroups' function can be used to drive the test
-- invocations and group the 'Sweets' by parameter values.
--
-- Example:
--
-- > import qualified Test.Tasty as T
-- > import Test.Tasty.Hunit ( testCase, (@?=) )
-- > import Test.Tasty.Sugar
-- > import Numeric.Natural
-- >
-- > sugarCube = mkCUBE { inputDirs = [ "test/samples", "test/expected" ]
-- >                    , rootName = "*.c"
-- >                    , associatedNames = [ ("inputs", "inp") ]
-- >                    , expectedSuffix = "exp"
-- >                    }
-- >
-- > ingredients = T.includingOptions sugarOptions :
-- >               sugarIngredients [sugarCube] <>
-- >               T.defaultIngredients
-- >
-- > main =
-- >   do testSweets <- findSugar sugarCube
-- >      T.defaultMainWithIngredients ingredients .
-- >        T.testGroup "sweet tests" =<<
-- >        withSugarGroups testSweets T.testGroup mkTest
-- >
-- > mkTest :: Sweets -> Natural -> Expectation -> IO [T.TestTree]
-- > mkTest s n e = do
-- >    exp <- reads <$> readFile $ expectedFile e
-- >    return [ testCase (rootMatchName s <> " #" <> show n) $ do
-- >               Just inpF <- lookup "inputs" $ associated e
-- >               result <- testSomething inpF
-- >               result @?= exp
-- >           ]
--
-- See the README for more information.

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}

module Test.Tasty.Sugar
  (
    -- * Tasty Options and Ingredients
    sugarOptions
  , sugarIngredients

    -- * Test Generation Functions
  , findSugar
  , findSugarIn
  , withSugarGroups

    -- * Types
    -- ** Input
  , CUBE(..)
  , Separators
  , ParameterPattern
  , mkCUBE
  , CandidateFile(..)
  , makeCandidate
  , findCandidates
    -- ** Output
  , Sweets(..)
  , Expectation(..)
  , Association
  , NamedParamMatch
  , ParamMatch(..)
  , paramMatchVal
  , getParamVal
    -- ** Reporting
  , sweetsKVITable
  , sweetsTextTable
  )
where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Logic
import           Data.Either ( lefts, rights )
import qualified Data.Foldable as F
import           Data.Function
import qualified Data.List as L
import qualified Data.Map as Map
import           Data.Maybe ( isJust, isNothing, fromJust, fromMaybe )
import           Data.Proxy
import qualified Data.Text as T
import           Data.Typeable ( Typeable )
import           Numeric.Natural ( Natural )
import           Prettyprinter
import           System.IO ( hPutStrLn, stderr )
import           Test.Tasty.Ingredients
import           Test.Tasty.Options

import Test.Tasty.Sugar.Analysis
import Test.Tasty.Sugar.Candidates
import Test.Tasty.Sugar.Report
import Test.Tasty.Sugar.Types

import Prelude hiding ( exp )


----------------------------------------------------------------------

data ShowSugarSearch = ShowSugarSearch Bool deriving (ShowSugarSearch -> ShowSugarSearch -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShowSugarSearch -> ShowSugarSearch -> Bool
$c/= :: ShowSugarSearch -> ShowSugarSearch -> Bool
== :: ShowSugarSearch -> ShowSugarSearch -> Bool
$c== :: ShowSugarSearch -> ShowSugarSearch -> Bool
Eq, Eq ShowSugarSearch
ShowSugarSearch -> ShowSugarSearch -> Bool
ShowSugarSearch -> ShowSugarSearch -> Ordering
ShowSugarSearch -> ShowSugarSearch -> ShowSugarSearch
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ShowSugarSearch -> ShowSugarSearch -> ShowSugarSearch
$cmin :: ShowSugarSearch -> ShowSugarSearch -> ShowSugarSearch
max :: ShowSugarSearch -> ShowSugarSearch -> ShowSugarSearch
$cmax :: ShowSugarSearch -> ShowSugarSearch -> ShowSugarSearch
>= :: ShowSugarSearch -> ShowSugarSearch -> Bool
$c>= :: ShowSugarSearch -> ShowSugarSearch -> Bool
> :: ShowSugarSearch -> ShowSugarSearch -> Bool
$c> :: ShowSugarSearch -> ShowSugarSearch -> Bool
<= :: ShowSugarSearch -> ShowSugarSearch -> Bool
$c<= :: ShowSugarSearch -> ShowSugarSearch -> Bool
< :: ShowSugarSearch -> ShowSugarSearch -> Bool
$c< :: ShowSugarSearch -> ShowSugarSearch -> Bool
compare :: ShowSugarSearch -> ShowSugarSearch -> Ordering
$ccompare :: ShowSugarSearch -> ShowSugarSearch -> Ordering
Ord, Typeable)

instance IsOption ShowSugarSearch where
  defaultValue :: ShowSugarSearch
defaultValue = Bool -> ShowSugarSearch
ShowSugarSearch Bool
False
  parseValue :: [Char] -> Maybe ShowSugarSearch
parseValue = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> ShowSugarSearch
ShowSugarSearch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => [Char] -> Maybe a
safeRead
  optionName :: Tagged ShowSugarSearch [Char]
optionName = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char]
"showsearch"
  optionHelp :: Tagged ShowSugarSearch [Char]
optionHelp = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char]
"Show details of the search for the set of\n\
                      \ sample-file driven tests that would be\n\
                      \ performed based on the search."
  optionCLParser :: Parser ShowSugarSearch
optionCLParser = forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser forall a. Maybe a
Nothing (Bool -> ShowSugarSearch
ShowSugarSearch Bool
True)


-- | Specify the Sugar-specific Tasty command-line options
sugarOptions :: [OptionDescription]
sugarOptions :: [OptionDescription]
sugarOptions = [ forall v. IsOption v => Proxy v -> OptionDescription
Option (forall {k} (t :: k). Proxy t
Proxy :: Proxy ShowSugarSearch)
               ]

-- | Provides the Tasty Ingredients that can be used to inform the
-- testing process.
sugarIngredients :: [CUBE] -> [Ingredient]
sugarIngredients :: [CUBE] -> [Ingredient]
sugarIngredients [CUBE]
pats = [ [CUBE] -> Ingredient
searchResultsSugarReport [CUBE]
pats ]


-- | This is a Tasty "Ingredient" (aka test runner) that can be used
-- to display the search process and results for generating the tests.
-- This output can be requested by the "--showsearch" argument to the
-- test executable.

searchResultsSugarReport :: [CUBE] -> Ingredient
searchResultsSugarReport :: [CUBE] -> Ingredient
searchResultsSugarReport [CUBE]
pats = [OptionDescription]
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
TestManager [] forall a b. (a -> b) -> a -> b
$ \OptionSet
opts TestTree
_tests ->
  if forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts forall a. Eq a => a -> a -> Bool
== Bool -> ShowSugarSearch
ShowSugarSearch Bool
True
  then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do [([Sweets], Doc Any)]
searchinfo <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) ann.
MonadIO m =>
CUBE -> m ([Sweets], Doc ann)
findSugar' [CUBE]
pats
                 forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) [CUBE]
pats
                 [Char] -> IO ()
putStrLn [Char]
""
                 forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([Sweets], Doc Any)]
searchinfo
                 [Char] -> IO ()
putStrLn [Char]
""
                 [Char] -> IO ()
putStrLn ([Char]
"Final set of tests [" forall a. [a] -> [a] -> [a]
++
                           forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [([Sweets], Doc Any)]
searchinfo) forall a. [a] -> [a] -> [a]
++
                           [Char]
"]:")
                 [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map ((Doc Any
"•" forall ann. Doc ann -> Doc ann -> Doc ann
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> Doc ann
align forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [([Sweets], Doc Any)]
searchinfo
                 [Char] -> IO ()
putStrLn [Char]
""
                 [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ [CUBE] -> [Sweets] -> Text
sweetsTextTable [CUBE]
pats forall a b. (a -> b) -> a -> b
$
                   forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([Sweets], Doc Any)]
searchinfo)
                 forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  else forall a. Maybe a
Nothing


----------------------------------------------------------------------

-- | Returns a list of the discovered test configurations (Sweets)
-- that should be run.  This function is used to get the list of
-- possible test configurations that is passed with the
-- withSugarGroups function to generate the actual tests.

findSugar :: MonadIO m => CUBE -> m [Sweets]
findSugar :: forall (m :: * -> *). MonadIO m => CUBE -> m [Sweets]
findSugar CUBE
cube = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) ann.
MonadIO m =>
CUBE -> m ([Sweets], Doc ann)
findSugar' CUBE
cube

findSugar' :: MonadIO m => CUBE -> m ([Sweets], Doc ann)
findSugar' :: forall (m :: * -> *) ann.
MonadIO m =>
CUBE -> m ([Sweets], Doc ann)
findSugar' CUBE
pat = do
  [Either [Char] CandidateFile]
candidates <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CUBE -> [Char] -> IO [Either [Char] CandidateFile]
findCandidates CUBE
pat)
                             forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
L.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
                             forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
L.nub
                             forall a b. (a -> b) -> a -> b
$ CUBE -> [Char]
inputDir CUBE
pat forall a. a -> [a] -> [a]
: CUBE -> [[Char]]
inputDirs CUBE
pat))
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"WARNING: " forall a. Semigroup a => a -> a -> a
<>)) forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [a]
lefts [Either [Char] CandidateFile]
candidates
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ann. CUBE -> [CandidateFile] -> ([Sweets], Doc ann)
findSugarIn CUBE
pat forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
rights [Either [Char] CandidateFile]
candidates


-- | Given a list of filepaths and a CUBE, returns the list of matching
-- test Sweets that should be run, and an explanation of the search
-- process (describing unmatched possibilities as well as valid test
-- configurations).
--
-- This is a low-level function; the findSugar and withSugarGroups are
-- the recommended interface functions to use for writing tests.

findSugarIn :: CUBE -> [CandidateFile] -> ([Sweets], Doc ann)
findSugarIn :: forall ann. CUBE -> [CandidateFile] -> ([Sweets], Doc ann)
findSugarIn CUBE
pat [CandidateFile]
allFiles =
  let (Int
nCandidates, [([Sweets], [SweetExplanation])]
sres, IterStat
stats) = CUBE
-> [CandidateFile]
-> (Int, [([Sweets], [SweetExplanation])], IterStat)
checkRoots CUBE
pat [CandidateFile]
allFiles
      inps :: [Sweets]
inps = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([Sweets], [SweetExplanation])]
sres
      expl :: Doc ann
expl = forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$
             [ Doc ann
"Checking for test inputs in:" forall ann. Doc ann -> Doc ann -> Doc ann
<+>
               forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Eq a => [a] -> [a]
L.nub forall a b. (a -> b) -> a -> b
$ CUBE -> [Char]
inputDir CUBE
pat forall a. a -> [a] -> [a]
: CUBE -> [[Char]]
inputDirs CUBE
pat)
             , forall ann. Int -> Doc ann -> Doc ann
indent Int
2 forall a b. (a -> b) -> a -> b
$
               forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ [ Doc ann
"# files in directories =" forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                        forall a ann. Pretty a => a -> Doc ann
pretty (forall (t :: * -> *) a. Foldable t => t a -> Int
length [CandidateFile]
allFiles)
                      , Doc ann
"# root candidates matching" forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                        forall ann. Doc ann -> Doc ann
dquotes (forall a ann. Pretty a => a -> Doc ann
pretty (CUBE -> [Char]
rootName CUBE
pat)) forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
equals forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                        forall a ann. Pretty a => a -> Doc ann
pretty Int
nCandidates
                      , Doc ann
"# valid roots" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
equals forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                        forall a ann. Pretty a => a -> Doc ann
pretty (forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Sweets], [SweetExplanation])]
sres)
                      , Doc ann
"parameters = " forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (CUBE -> [ParameterPattern]
validParams CUBE
pat)
                      ] forall a. Semigroup a => a -> a -> a
<> (((Doc ann
"--?" forall ann. Doc ann -> Doc ann -> Doc ann
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [([Sweets], [SweetExplanation])]
sres))
                      forall a. Semigroup a => a -> a -> a
<> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null IterStat
stats
                         then []
                         else [ Doc ann
"", Doc ann
"Stats:" ]
                              forall a. Semigroup a => a -> a -> a
<> ((\(Text
k,Int
v) -> Doc ann
"  #" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Text
k forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
" = " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Int
v)
                                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toList IterStat
stats)
             ]
  in case CUBE -> Either [Char] CUBE
cubeIsValid CUBE
pat of
       Right CUBE
_ -> (forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Sweets -> [Char]
rootFile) [Sweets]
inps, forall ann. Doc ann
expl)
       Left [Char]
e -> forall a. HasCallStack => [Char] -> a
error [Char]
e  -- this is just testing code, so error is fine

  where

    cubeIsValid :: CUBE -> Either String CUBE
    cubeIsValid :: CUBE -> Either [Char] CUBE
cubeIsValid CUBE
cube = CUBE
cube
                       forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> Either [Char] [()]
separatorsAreValid (CUBE -> [Char]
separators CUBE
cube)
                       forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [Char] -> [ParameterPattern] -> Either [Char] [ParameterPattern]
paramsAreValid (CUBE -> [Char]
separators CUBE
cube) (CUBE -> [ParameterPattern]
validParams CUBE
cube)

    separatorsAreValid :: Separators -> Either String [()]
    separatorsAreValid :: [Char] -> Either [Char] [()]
separatorsAreValid [Char]
seps = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a. Logic a -> [a]
observeAll forall a b. (a -> b) -> a -> b
$
      do (Char
s1,Char
s2) <- forall {b}. [b] -> LogicT Identity (b, b)
choose2 [Char]
seps
         let globChars :: [Char]
globChars = [Char]
"[*](|)\\" :: String
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
s1 forall a. Eq a => a -> a -> Bool
== Char
s2) forall a b. (a -> b) -> a -> b
$
                       forall a b. a -> Either a b
Left [Char]
"Duplicate separator characters"
                     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
s1 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
globChars) forall a b. (a -> b) -> a -> b
$
                       forall a b. a -> Either a b
Left [Char]
"Separator contains glob wildcard"
                     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
s2 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
globChars) forall a b. (a -> b) -> a -> b
$
                       forall a b. a -> Either a b
Left [Char]
"Separator contains glob wildcard"
                     forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    paramsAreValid :: Separators
                   -> [ParameterPattern]
                   -> Either String [ParameterPattern]
    paramsAreValid :: [Char] -> [ParameterPattern] -> Either [Char] [ParameterPattern]
paramsAreValid [Char]
seps [ParameterPattern]
p =
      let existential :: [ParameterPattern]
existential = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [ParameterPattern]
p
          blankVals :: [ParameterPattern]
blankVals = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [ParameterPattern]
p
          emptyVal :: [ParameterPattern]
emptyVal = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [ParameterPattern]
p
          dupVals :: [(([Char], [Char]), [Char])]
dupVals = forall {a} {b}. Eq a => [((a, a), b)] -> [((a, a), b)]
rmvOrderSwapped forall a b. (a -> b) -> a -> b
$ forall a. Logic a -> [a]
observeAll LogicT Identity (([Char], [Char]), [Char])
duplicatedValues
          duplicatedValues :: LogicT Identity (([Char], [Char]), [Char])
duplicatedValues =
            do ParameterPattern
p1 <- forall {a}. [a] -> LogicT Identity a
choose [ParameterPattern]
p
               ParameterPattern
p2 <- forall {a}. [a] -> LogicT Identity a
choose [ParameterPattern]
p
               forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd ParameterPattern
p1)
               forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd ParameterPattern
p2)
               [Char]
pv <- if (forall a b. (a, b) -> a
fst ParameterPattern
p1 forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> a
fst ParameterPattern
p2)
                     then do ([Char]
p1v, [Char]
p2v) <- forall {b}. [b] -> LogicT Identity (b, b)
choose2 forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd ParameterPattern
p1
                             forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Char]
p1v forall a. Eq a => a -> a -> Bool
== [Char]
p2v)
                             forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
p1v
                     else do [Char]
p1v <- forall {a}. [a] -> LogicT Identity a
choose forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd ParameterPattern
p1
                             [Char]
p2v <- forall {a}. [a] -> LogicT Identity a
choose forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd ParameterPattern
p2
                             forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Char]
p1v forall a. Eq a => a -> a -> Bool
== [Char]
p2v)
                             forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
p1v
               forall (m :: * -> *) a. Monad m => a -> m a
return ((forall a b. (a, b) -> a
fst ParameterPattern
p1, forall a b. (a, b) -> a
fst ParameterPattern
p2), [Char]
pv)
          sepVals :: [[Char]]
sepVals = forall a. Logic a -> [a]
observeAll forall a b. (a -> b) -> a -> b
$
                    do ([Char]
n,Maybe [[Char]]
vl) <- forall {a}. [a] -> LogicT Identity a
choose [ParameterPattern]
p
                       forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. Maybe a -> Bool
isJust Maybe [[Char]]
vl)
                       [Char]
v <- forall {a}. [a] -> LogicT Identity a
choose forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. a -> a
id Maybe [[Char]]
vl
                       Char
s <- forall {a}. [a] -> LogicT Identity a
choose [Char]
seps
                       forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
v)
                       forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
n
          rmvOrderSwapped :: [((a, a), b)] -> [((a, a), b)]
rmvOrderSwapped [] = []
          rmvOrderSwapped (e :: ((a, a), b)
e@((a
a,a
b),b
_):[((a, a), b)]
es) =
            let notSwapped :: ((a, a), b) -> Bool
notSwapped ((a
a',a
b'),b
_) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ a
a forall a. Eq a => a -> a -> Bool
== a
a' Bool -> Bool -> Bool
&& a
b forall a. Eq a => a -> a -> Bool
== a
b'
                                                  , a
a forall a. Eq a => a -> a -> Bool
== a
b' Bool -> Bool -> Bool
&& a
b forall a. Eq a => a -> a -> Bool
== a
a' ]
            in ((a, a), b)
e forall a. a -> [a] -> [a]
: [((a, a), b)] -> [((a, a), b)]
rmvOrderSwapped (forall a. (a -> Bool) -> [a] -> [a]
filter forall {b}. ((a, a), b) -> Bool
notSwapped [((a, a), b)]
es)
      in do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ParameterPattern]
existential forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$
              forall a b. a -> Either a b
Left [Char]
"Only one parameter can have unconstrained values (i.e. Nothing)"
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParameterPattern]
blankVals) forall a b. (a -> b) -> a -> b
$
              forall a b. a -> Either a b
Left ([Char]
"Blank validParams values are not allowed (" forall a. Semigroup a => a -> a -> a
<>
                    (forall a. [a] -> [[a]] -> [a]
L.intercalate [Char]
", " (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParameterPattern]
blankVals)) forall a. Semigroup a => a -> a -> a
<> [Char]
")")
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParameterPattern]
emptyVal) forall a b. (a -> b) -> a -> b
$
              forall a b. a -> Either a b
Left ([Char]
"Parameter values cannot be blank (" forall a. Semigroup a => a -> a -> a
<>
                    (forall a. [a] -> [[a]] -> [a]
L.intercalate [Char]
", " (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParameterPattern]
emptyVal)) forall a. Semigroup a => a -> a -> a
<> [Char]
")")
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(([Char], [Char]), [Char])]
dupVals) forall a b. (a -> b) -> a -> b
$
              forall a b. a -> Either a b
Left ([Char]
"Parameter values cannot be duplicated " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [(([Char], [Char]), [Char])]
dupVals)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
sepVals) forall a b. (a -> b) -> a -> b
$
              forall a b. a -> Either a b
Left ([Char]
"Parameter values cannot contain separators " forall a. Semigroup a => a -> a -> a
<>
                    forall a. Show a => a -> [Char]
show [[Char]]
sepVals)
            forall (m :: * -> *) a. Monad m => a -> m a
return [ParameterPattern]
p

    choose :: [a] -> LogicT Identity a
choose = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return) forall (m :: * -> *) a. MonadPlus m => m a
mzero

    choose2 :: [b] -> LogicT Identity (b, b)
choose2 [b]
lst = let ll :: Int
ll = forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
lst
                  in do forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
ll forall a. Ord a => a -> a -> Bool
> Int
1)
                        Int
i1 <- forall {a}. [a] -> LogicT Identity a
choose [Int
0..Int
llforall a. Num a => a -> a -> a
-Int
1]
                        Int
i2 <- forall {a}. [a] -> LogicT Identity a
choose [Int
0..Int
llforall a. Num a => a -> a -> a
-Int
1]
                        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
i1 forall a. Eq a => a -> a -> Bool
/= Int
i2)
                        forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
lst forall a. [a] -> Int -> a
!! Int
i1, [b]
lst forall a. [a] -> Int -> a
!! Int
i2)


-- | The 'withSugarGroups' is the primary function used to run tests.
-- Given a list of 'Sweets' returned by 'findSugar', a function to
-- mark a group of tests (usually @Tasty.testGroup@), and a function
-- to generate a number of tests from a 'Sweets' and a specific
-- 'Expectation', this will iterate over the supplied 'Sweets' and
-- call the test generator for each valid test configuration.
--
-- Note that 'Sweets' contains all expectations (@[Expectation]@), but
-- the passed 'Expectation' is the only one that should be tested for
-- this set of generated tests.
--
-- > withSugarGroups sweets groupFun mkTestFun
--
-- where
--
--  * @groupFun@ is the function to group a set of tests with a
--    specific name.  Typically this can just be 'tasty.testGroup'
--
--  * @mkTestFun@ is the function to create any specific tests for the
--    specified expectation.  The output type is usually a
--    @['Tasty.TestTree']@.  This is passed the general 'Sweets', the
--    specific 'Expectation' for the tests that should be created, and
--    a numeric iteration indicating the 'Expectation' number within
--    this group.  The iteration number can be used for
--    differentiation against the other tests, but there is no
--    determinate relationship to elements of the 'Sweets' (such as
--    parameters or associated sets).  It is also possible to suppress
--    the generation of any tests for a particular 'Expectation' by
--    returning an empty list from the @mkTestFun@.

withSugarGroups :: MonadIO m
                => [Sweets]
                -> (String -> [a] -> a)
                   --  Given a name and list of tests (aka
                   -- 'TestTree'), group them (usually 'testGroup')
                -> (Sweets -> Natural -> Expectation -> m [a])
                   -- Generate any tests for this 'Expectation' (usually
                   -- @a ~ TestTree@)
                -> m [a]
withSugarGroups :: forall (m :: * -> *) a.
MonadIO m =>
[Sweets]
-> ([Char] -> [a] -> a)
-> (Sweets -> Natural -> Expectation -> m [a])
-> m [a]
withSugarGroups [Sweets]
sweets [Char] -> [a] -> a
mkGroup Sweets -> Natural -> Expectation -> m [a]
mkLeaf =
  let mkSweetTests :: Sweets -> m a
mkSweetTests Sweets
sweet =
        [Char] -> [a] -> a
mkGroup (Sweets -> [Char]
rootMatchName Sweets
sweet) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Sweets -> [Expectation] -> [ParameterPattern] -> m [a]
mkParams Sweets
sweet (Sweets -> [Expectation]
expected Sweets
sweet) forall a b. (a -> b) -> a -> b
$ Sweets -> [ParameterPattern]
cubeParams Sweets
sweet)

      -- mkParams iterates through the declared expected values to
      -- create a group for each actual value per expectation, calling
      -- the user-supplied mkLeaf at the leaf of each path.
      mkParams :: Sweets -> [Expectation] -> [ParameterPattern] -> m [a]
mkParams Sweets
sweet [Expectation]
exp [] = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ Sweets -> Natural -> Expectation -> m [a]
mkLeaf Sweets
sweet) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Natural
1..] [Expectation]
exp)
      mkParams Sweets
sweet [Expectation]
exp (([Char]
name,Maybe [[Char]]
vspec):[ParameterPattern]
ps) =
        case Maybe [[Char]]
vspec of
          Maybe [[Char]]
Nothing ->
            let pVal :: Expectation -> Maybe ParamMatch
pVal = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expectation -> [NamedParamMatch]
expParamsMatch
                expSrt :: [Expectation]
expSrt = forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Expectation -> Maybe ParamMatch
pVal) [Expectation]
exp
                expGrps :: [[Expectation]]
expGrps = forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Expectation -> Maybe ParamMatch
pVal) [Expectation]
expSrt
                f :: [Expectation] -> m a
f [Expectation]
es =
                  let gn :: [Char]
gn = forall a. a -> Maybe a -> a
fromMaybe ([Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
" not specified")
                           forall a b. (a -> b) -> a -> b
$ (ParamMatch -> Maybe [Char]
getParamVal forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                              (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
name forall a b. (a -> b) -> a -> b
$ Expectation -> [NamedParamMatch]
expParamsMatch forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Expectation]
es)
                             )
                  in [Char] -> [a] -> a
mkGroup [Char]
gn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sweets -> [Expectation] -> [ParameterPattern] -> m [a]
mkParams Sweets
sweet [Expectation]
es [ParameterPattern]
ps
            in forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ [Expectation] -> m a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Expectation]]
expGrps
          Just [[Char]]
vs -> let f :: [Char] -> m a
f [Char]
v = [Char] -> [a] -> a
mkGroup [Char]
v forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sweets -> [Expectation] -> [ParameterPattern] -> m [a]
mkParams Sweets
sweet ([Char] -> [Expectation]
subExp [Char]
v) [ParameterPattern]
ps
                         subExp :: [Char] -> [Expectation]
subExp [Char]
v = [Char] -> [Char] -> [Expectation] -> [Expectation]
expMatching [Char]
name [Char]
v [Expectation]
exp
                     in forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ [Char] -> m a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => [a] -> [a]
L.sort [[Char]]
vs

      expMatching :: String -> String -> [Expectation] -> [Expectation]
      expMatching :: [Char] -> [Char] -> [Expectation] -> [Expectation]
expMatching [Char]
p [Char]
v [Expectation]
exp =
        forall a. (a -> Bool) -> [a] -> [a]
filter (\Expectation
e -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ([Char] -> ParamMatch -> Bool
paramMatchVal [Char]
v) (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
p (Expectation -> [NamedParamMatch]
expParamsMatch Expectation
e))) [Expectation]
exp

  in forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Sweets -> m a
mkSweetTests forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Sweets -> [Char]
rootMatchName) [Sweets]
sweets