-- | 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 Test.Tasty as T
-- > import Test.Tasty.Options
-- > import Test.Tasty.Sugar
-- > import Numeric.Natural
-- >
-- > sugarCube = mkCUBE { inputDir = "test/samples"
-- >                    , 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
-- >    inp <- readFile inpF
-- >    exp <- reads <$> readFile $ expectedFile e
-- >    return [ testCase (rootMatchName s <> " #" <> show n) $ do
-- >               Just inpF <- lookup "inputs" $ associated e
-- >               result <- testSomething inp
-- >               result @?= exp
-- >           ]
--
-- See the README for more information.

{-# LANGUAGE OverloadedStrings #-}

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

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

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

import           Control.Applicative
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Logic
import qualified Data.Foldable as F
import           Data.Function
import qualified Data.List as L
import           Data.Maybe ( isJust, isNothing, fromJust )
import           Data.Proxy
import           Data.Tagged
import qualified Data.Text as T
import           Data.Typeable ( Typeable )
import           Numeric.Natural ( Natural )
import           Options.Applicative
import           Prettyprinter
import           System.Directory ( listDirectory )
import           Test.Tasty.Ingredients
import           Test.Tasty.Options

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

import Prelude hiding ( exp )


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

data ShowSugarSearch = ShowSugarSearch Bool deriving (ShowSugarSearch -> ShowSugarSearch -> Bool
(ShowSugarSearch -> ShowSugarSearch -> Bool)
-> (ShowSugarSearch -> ShowSugarSearch -> Bool)
-> Eq ShowSugarSearch
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
Eq ShowSugarSearch
-> (ShowSugarSearch -> ShowSugarSearch -> Ordering)
-> (ShowSugarSearch -> ShowSugarSearch -> Bool)
-> (ShowSugarSearch -> ShowSugarSearch -> Bool)
-> (ShowSugarSearch -> ShowSugarSearch -> Bool)
-> (ShowSugarSearch -> ShowSugarSearch -> Bool)
-> (ShowSugarSearch -> ShowSugarSearch -> ShowSugarSearch)
-> (ShowSugarSearch -> ShowSugarSearch -> ShowSugarSearch)
-> Ord 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
$cp1Ord :: Eq ShowSugarSearch
Ord, Typeable)

instance IsOption ShowSugarSearch where
  defaultValue :: ShowSugarSearch
defaultValue = Bool -> ShowSugarSearch
ShowSugarSearch Bool
False
  parseValue :: String -> Maybe ShowSugarSearch
parseValue = (Bool -> ShowSugarSearch) -> Maybe Bool -> Maybe ShowSugarSearch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> ShowSugarSearch
ShowSugarSearch (Maybe Bool -> Maybe ShowSugarSearch)
-> (String -> Maybe Bool) -> String -> Maybe ShowSugarSearch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
forall a. Read a => String -> Maybe a
safeRead
  optionName :: Tagged ShowSugarSearch String
optionName = String -> Tagged ShowSugarSearch String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Tagged ShowSugarSearch String)
-> String -> Tagged ShowSugarSearch String
forall a b. (a -> b) -> a -> b
$ String
"showsearch"
  optionHelp :: Tagged ShowSugarSearch String
optionHelp = String -> Tagged ShowSugarSearch String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Tagged ShowSugarSearch String)
-> String -> Tagged ShowSugarSearch String
forall a b. (a -> b) -> a -> b
$ String
"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 = Maybe Char -> ShowSugarSearch -> Parser ShowSugarSearch
forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser Maybe Char
forall a. Maybe a
Nothing (Bool -> ShowSugarSearch
ShowSugarSearch Bool
True)


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

findSugar' :: MonadIO m => CUBE -> m ([Sweets], Doc ann)
findSugar' :: CUBE -> m ([Sweets], Doc ann)
findSugar' CUBE
pat = CUBE -> [String] -> ([Sweets], Doc ann)
forall ann. CUBE -> [String] -> ([Sweets], Doc ann)
findSugarIn CUBE
pat ([String] -> ([Sweets], Doc ann))
-> m [String] -> m ([Sweets], Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String] -> m [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO [String]
listDirectory (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ CUBE -> String
inputDir CUBE
pat)


-- | Given a list of files 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 -> [FilePath] -> ([Sweets], Doc ann)
findSugarIn :: CUBE -> [String] -> ([Sweets], Doc ann)
findSugarIn CUBE
pat [String]
allFiles =
  let (Int
nCandidates, [([Sweets], [SweetExplanation])]
sres) = CUBE -> [String] -> (Int, [([Sweets], [SweetExplanation])])
checkRoots CUBE
pat [String]
allFiles
      inps :: [Sweets]
inps = [[Sweets]] -> [Sweets]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Sweets]] -> [Sweets]) -> [[Sweets]] -> [Sweets]
forall a b. (a -> b) -> a -> b
$ ([Sweets], [SweetExplanation]) -> [Sweets]
forall a b. (a, b) -> a
fst (([Sweets], [SweetExplanation]) -> [Sweets])
-> [([Sweets], [SweetExplanation])] -> [[Sweets]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([Sweets], [SweetExplanation])]
sres
      expl :: Doc ann
expl = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
             [ Doc ann
"Checking for test inputs in:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (CUBE -> String
inputDir CUBE
pat)
             , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
               [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ [ Doc ann
"# files in directory =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                        Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
allFiles)
                      , Doc ann
"# root candidates matching" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                        Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
dquotes (String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (CUBE -> String
rootName CUBE
pat)) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
equals Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                        Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
nCandidates
                      , Doc ann
"# valid roots" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
equals Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                        Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([([Sweets], [SweetExplanation])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Sweets], [SweetExplanation])]
sres)
                      , Doc ann
"parameters = " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [ParameterPattern] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (CUBE -> [ParameterPattern]
validParams CUBE
pat)
                      ] [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> (((Doc ann
"--?" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann)
-> (SweetExplanation -> Doc ann) -> SweetExplanation -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SweetExplanation -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) (SweetExplanation -> Doc ann) -> [SweetExplanation] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((([Sweets], [SweetExplanation]) -> [SweetExplanation])
-> [([Sweets], [SweetExplanation])] -> [SweetExplanation]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Sweets], [SweetExplanation]) -> [SweetExplanation]
forall a b. (a, b) -> b
snd [([Sweets], [SweetExplanation])]
sres))
             ]
  in case CUBE -> Either String CUBE
cubeIsValid CUBE
pat of
       Right CUBE
_ -> ([Sweets]
inps, Doc ann
forall ann. Doc ann
expl)
       Left String
e -> String -> ([Sweets], Doc ann)
forall a. HasCallStack => String -> a
error String
e  -- this is just testing code, so error is fine

  where

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

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

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

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

    choose2 :: [a] -> LogicT Identity (a, a)
choose2 [a]
lst = let ll :: Int
ll = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
lst
                  in do Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
ll Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
                        Int
i1 <- [Int] -> LogicT Identity Int
forall a. [a] -> LogicT Identity a
choose [Int
0..Int
llInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
                        Int
i2 <- [Int] -> LogicT Identity Int
forall a. [a] -> LogicT Identity a
choose [Int
0..Int
llInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
                        Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
i1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
i2)
                        (a, a) -> LogicT Identity (a, a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
lst [a] -> Int -> a
forall a. [a] -> Int -> a
!! Int
i1, [a]
lst [a] -> Int -> a
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 :: [Sweets]
-> (String -> [a] -> a)
-> (Sweets -> Natural -> Expectation -> m [a])
-> m [a]
withSugarGroups [Sweets]
sweets String -> [a] -> a
mkGroup Sweets -> Natural -> Expectation -> m [a]
mkLeaf =
  let mkSweetTests :: Sweets -> m a
mkSweetTests Sweets
sweet =
        String -> [a] -> a
mkGroup (Sweets -> String
rootMatchName Sweets
sweet) ([a] -> a) -> m [a] -> m a
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) ([ParameterPattern] -> m [a]) -> [ParameterPattern] -> m [a]
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 [] = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> m [[a]] -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Natural, Expectation) -> m [a])
-> [(Natural, Expectation)] -> m [[a]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Natural -> Expectation -> m [a])
-> (Natural, Expectation) -> m [a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Natural -> Expectation -> m [a])
 -> (Natural, Expectation) -> m [a])
-> (Natural -> Expectation -> m [a])
-> (Natural, Expectation)
-> m [a]
forall a b. (a -> b) -> a -> b
$ Sweets -> Natural -> Expectation -> m [a]
mkLeaf Sweets
sweet) ([(Natural, Expectation)] -> m [[a]])
-> [(Natural, Expectation)] -> m [[a]]
forall a b. (a -> b) -> a -> b
$ [Natural] -> [Expectation] -> [(Natural, Expectation)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Natural
1..] [Expectation]
exp)
      mkParams Sweets
sweet [Expectation]
exp ((String
name,Maybe [String]
vspec):[ParameterPattern]
ps) =
        case Maybe [String]
vspec of
          Maybe [String]
Nothing -> do [a]
ts <- Sweets -> [Expectation] -> [ParameterPattern] -> m [a]
mkParams Sweets
sweet [Expectation]
exp [ParameterPattern]
ps
                        [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> [a] -> a
mkGroup String
name [a]
ts]
          Just [String]
vs -> let f :: String -> m a
f String
v = String -> [a] -> a
mkGroup String
v ([a] -> a) -> m [a] -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sweets -> [Expectation] -> [ParameterPattern] -> m [a]
mkParams Sweets
sweet (String -> [Expectation]
subExp String
v) [ParameterPattern]
ps
                         subExp :: String -> [Expectation]
subExp String
v = String -> String -> [Expectation] -> [Expectation]
expMatching String
name String
v [Expectation]
exp
                     in [m a] -> m [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([m a] -> m [a]) -> [m a] -> m [a]
forall a b. (a -> b) -> a -> b
$ String -> m a
f (String -> m a) -> [String] -> [m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> [String]
forall a. Ord a => [a] -> [a]
L.sort [String]
vs

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

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