-- | Specifies the base tasty-sweet types and common class instance
-- definitions for those types.

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Test.Tasty.Sugar.Types where

import           Data.Function ( on )
import qualified Data.List as L
import           Data.Maybe ( catMaybes )
import           System.FilePath -- ( (</>) )
import qualified System.FilePath.GlobPattern as FPGP
#if MIN_VERSION_prettyprinter(1,7,0)
import Prettyprinter
#else
import Data.Text.Prettyprint.Doc
#endif

import Prelude hiding ( exp )


-- | This is the type used to specify file suffixes.  The synonym name
-- is primarily used to indicate where this suffix specification is
-- used.
type FileSuffix = String


-- | Specifies the parameters and patterns to use when searching for
-- samples to build tests from.  The 'mkCUBE' function should be used
-- to obtain a 'CUBE' structure initialized with overrideable
-- defaults.
--
-- The primary elements to specify are the 'rootName' and the
-- 'expectedSuffix'.  With these two specifications (and possibly the
-- 'inputDirs') the 'Test.Tasty.Sugar' functionality will be similar to
-- a "golden" testing package.
--
-- The 'validParams' is an optional feature that is useful when
-- multiple expected results files are generated from a single
-- 'rootName', differing by the specified parameters.
--
-- The 'associatedNames' is an optional feature that is useful for
-- when there are other files to be associated with a test in addition
-- to the 'rootFile' and the 'expectedFile'.
--
data CUBE = CUBE
   {
     -- | The original directory in which the sample files can be found.  This is
     -- provided for backward-compatibility, but the use of the 'inputDirs'
     -- alternative is recommended.
     CUBE -> FilePath
inputDir :: FilePath

     -- | The directories in which the sample files that drive the
     -- testing exist.  When specified as a relative filepath
     -- (suggested) then a directory is relative to the cabal file.
   , CUBE -> [FilePath]
inputDirs :: [FilePath]

     -- | The name of the "root" file for each test scenario.  The
     -- contents of this file are opaque to 'tasty-sweet' and are
     -- interpreted by the tests themselves.  Each "root" file is
     -- the kernel for a set of test cases.
     --
     -- The root file should not be specified with any path element,
     -- it should exist in one of the 'inputDirs' location and it can be
     -- specified as a glob pattern.
     --
     -- The corresponding expected results files will be identified by
     -- finding files which match a portion of this name with a
     -- "{separator}{expectedSuffix}" appended to it.
   , CUBE -> FilePath
rootName :: FPGP.GlobPattern

     -- | The expected suffix for a target pattern for running a test.
     -- There may be multiple files specifying expected results for a
     -- test (see the 'validParams' below), but a particular test case
     -- is comprised of a source file along with a corresponding
     -- "expected result" file that is the name of the source file
     -- with the 'expectedSuffix' suffix.  The suffix should not contain
     -- any glob match characters. Note that the suffix is the text
     -- that comes after one of the 'separators' below.
     --
     -- The 'expectedSuffix' *may* start with one of the characters in
     -- 'separators'.  If this occurs, then the suffix will only be
     -- considered if preceeded by that specific separator; otherwise
     -- any of the 'separators' may be used prior to the
     -- 'expectedSuffix'.
   , CUBE -> FilePath
expectedSuffix :: FileSuffix

     -- | The 'separators' specify the characters which separate the
     -- expected suffix from the rootName, and which also separate
     -- the various parameters (if any, see 'validParams' below).  Any
     -- one of the separators in this list can be used, and a file can
     -- used a mixture of the separators in the filename.
     --
     -- It is also valid to specify no separators, in which case the
     -- 'rootName' and 'expectedSuffix' are directly concatenated.  This
     -- is not a typical usage, however.
     --
     -- The default separators (returned by 'mkCUBE') are ".-" meaning
     -- that extensions (and parameters) can be separated from the
     -- base name by either a period or a dash.
   , CUBE -> FilePath
separators :: Separators

     -- | The 'associatedNames' specifies other files that are
     -- associated with a particular test configuration.  These files
     -- are optional and not all of them appear, but different
     -- suffixes may be associated here with a general name.  When a
     -- test is being generated, any associatedNames that were found
     -- will be passed to the test generator for use as supplemental
     -- data.
     --
     -- Specified as a list of tuples, where each tuple is the
     -- (arbitrary) name of the associated file type, and the file
     -- type suffix (with no period or other separator).
   , CUBE -> [(FilePath, FilePath)]
associatedNames :: [ (String, FileSuffix) ]

     -- | The 'validParams' can be used to specify various parameters
     -- that may be present in the filename.
     --
     -- For example, tests might be parameterized by which C compiler
     -- (@"gcc"@ or @"clang"@) was used, which target architecture
     -- (@"x86_64"@ or @"ppc"@ or @"arm"@), and which optimization
     -- level.  The values for these parameters appear in any order in
     -- the filenames of any file (other than the 'rootName')
     -- delineated by any of the separators.  Not all parameter values
     -- are required to appear.
     --
     -- The following are valid examples:
     --
     -- > foo-gcc-ppc-O3.o
     -- > foo-clang.x86_64.o
     -- > foo.O0-clang.o
     --
     -- The sugar matching code will attempt to identify the various parameter
     -- values appearing in the _EXPECTED_ filename which correspond to the same
     -- values in the _ROOT_ filename and provide that information to the test
     -- generation process to allow the generated test to be customized to the
     -- available set of parameters.
     --
     -- The 'associatedNames' provided to the test generator will be
     -- constrained to those associated names that match the parameter
     -- values explicit in the expected name, and called for each
     -- combination of unspecified parameter values present in
     -- associated names.
     --
     -- There may actually be multiple sets of parameterized files for
     -- each 'rootName' file: the test generator will be called for
     -- each set of parameters.
     --
     -- Each entry in the 'validParams' specifies the name of the
     -- parameter and the set of values; one (and only one) parameter
     -- may have existential values rather than pre-determined values,
     -- as indicated by a Nothing for the parameter value set.  Valid
     -- parameter values are *not* matched with file globbing (they
     -- must be explicit and precise matches) and they cannot be blank
     -- (the lack of a parameter is handled automatically rather than
     -- an explicit blank value).
   , CUBE -> [ParameterPattern]
validParams :: [ParameterPattern]
   }
   deriving (Int -> CUBE -> ShowS
[CUBE] -> ShowS
CUBE -> FilePath
(Int -> CUBE -> ShowS)
-> (CUBE -> FilePath) -> ([CUBE] -> ShowS) -> Show CUBE
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [CUBE] -> ShowS
$cshowList :: [CUBE] -> ShowS
show :: CUBE -> FilePath
$cshow :: CUBE -> FilePath
showsPrec :: Int -> CUBE -> ShowS
$cshowsPrec :: Int -> CUBE -> ShowS
Show, ReadPrec [CUBE]
ReadPrec CUBE
Int -> ReadS CUBE
ReadS [CUBE]
(Int -> ReadS CUBE)
-> ReadS [CUBE] -> ReadPrec CUBE -> ReadPrec [CUBE] -> Read CUBE
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CUBE]
$creadListPrec :: ReadPrec [CUBE]
readPrec :: ReadPrec CUBE
$creadPrec :: ReadPrec CUBE
readList :: ReadS [CUBE]
$creadList :: ReadS [CUBE]
readsPrec :: Int -> ReadS CUBE
$creadsPrec :: Int -> ReadS CUBE
Read)

{-# DEPRECATED inputDir "Use inputDirs instead" #-}

-- | Parameters are specified by their name and a possible list of
-- valid values.  If there is no list of valid values, any value is
-- accepted for that parameter position.  Parameters are listed in the
-- order that they should appear in the filenames to be matched.

type ParameterPattern = (String, Maybe [String])

  -- KWQ: if this could be an exact string or a regexp (or a glob?) then that would remove the need for a complete enumeration but not be a full wildcard.  For example: llvm* to capture different llvm versions available.  However, this is super-hard, because many elements use Logic to generate all potential parameter value combinations, so this would need to be inverted, and still wouldn't handle Assumed values well.

-- | Separators for the path and suffix specifications.  Any separator
-- is accepted in any position between parameters and prior to the
-- expected suffix. The synonym name is primarily used to indicate
-- where this separators specification is intended to be used.

type Separators = String

-- | Generates the default 'CUBE' configuration; callers should override
-- individual fields as appropriate.  This is the preferred way to initialize a
-- CUBE if defaults are to be used for various fields:
--
--   * inputDirs:      [ "test/samples" ]
--   * inputDir:       "test/samples"
--   * separators:     .-
--   * rootName:       *
--   * expectedSuffix: exp

mkCUBE :: CUBE
mkCUBE :: CUBE
mkCUBE = CUBE :: FilePath
-> [FilePath]
-> FilePath
-> FilePath
-> FilePath
-> [(FilePath, FilePath)]
-> [ParameterPattern]
-> CUBE
CUBE { inputDirs :: [FilePath]
inputDirs = [FilePath
"test/samples"]
              , inputDir :: FilePath
inputDir = FilePath
""
              , separators :: FilePath
separators = FilePath
".-"
              , rootName :: FilePath
rootName = FilePath
"*"
              , associatedNames :: [(FilePath, FilePath)]
associatedNames = []
              , expectedSuffix :: FilePath
expectedSuffix = FilePath
"exp"
              , validParams :: [ParameterPattern]
validParams = []
              }


instance Pretty CUBE where
  pretty :: CUBE -> Doc ann
pretty CUBE
cube =
    let assoc :: Maybe (Doc ann)
assoc = [(FilePath, FilePath)] -> Maybe (Doc ann)
forall ann. [(FilePath, FilePath)] -> Maybe (Doc ann)
prettyAssocNames ([(FilePath, FilePath)] -> Maybe (Doc ann))
-> [(FilePath, FilePath)] -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ CUBE -> [(FilePath, FilePath)]
associatedNames CUBE
cube
        parms :: Maybe (Doc ann)
parms = [ParameterPattern] -> Maybe (Doc ann)
forall ann. [ParameterPattern] -> Maybe (Doc ann)
prettyParamPatterns ([ParameterPattern] -> Maybe (Doc ann))
-> [ParameterPattern] -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ CUBE -> [ParameterPattern]
validParams CUBE
cube
        hdrs :: [Doc ann]
hdrs = [ Doc ann
"input dirs: "
                 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [FilePath] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
L.nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ CUBE -> FilePath
inputDir CUBE
cube FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: CUBE -> [FilePath]
inputDirs CUBE
cube)
               , Doc ann
"rootName: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (CUBE -> FilePath
rootName CUBE
cube)
               , Doc ann
"expected: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                 Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets (FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FilePath -> Doc ann) -> FilePath -> Doc ann
forall a b. (a -> b) -> a -> b
$ CUBE -> FilePath
separators CUBE
cube) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
                 FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (CUBE -> FilePath
expectedSuffix CUBE
cube)
               ]
    in Doc ann
"Sugar.CUBE" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> (Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
1 (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]
forall ann. [Doc ann]
hdrs [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> [Maybe (Doc ann)] -> [Doc ann]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Doc ann)
forall ann. Maybe (Doc ann)
assoc, Maybe (Doc ann)
forall ann. Maybe (Doc ann)
parms])


-- | Pretty printing for a set of associated names
prettyAssocNames :: [(String, String)] -> Maybe (Doc ann)
prettyAssocNames :: [(FilePath, FilePath)] -> Maybe (Doc ann)
prettyAssocNames = \case
  [] -> Maybe (Doc ann)
forall a. Maybe a
Nothing
  [(FilePath, FilePath)]
nms -> Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Doc ann
"associated:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> (Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
1 (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
$ ((FilePath, FilePath) -> Doc ann)
-> [(FilePath, FilePath)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath, FilePath) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ((FilePath, FilePath) -> Doc ann)
-> ((FilePath, FilePath) -> (FilePath, FilePath))
-> (FilePath, FilePath)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> (FilePath, FilePath) -> (FilePath, FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
forall a. Show a => a -> FilePath
show) [(FilePath, FilePath)]
nms)

-- | Pretty printing for a list of parameter patterns
prettyParamPatterns :: [ParameterPattern] -> Maybe (Doc ann)
prettyParamPatterns :: [ParameterPattern] -> Maybe (Doc ann)
prettyParamPatterns = \case
  [] -> Maybe (Doc ann)
forall a. Maybe a
Nothing
  [ParameterPattern]
prms -> Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Doc ann
"params:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
          (let pp :: (a, Maybe [a]) -> Doc ann
pp (a
pn,Maybe [a]
mpv) =
                 a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
pn 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
<+>
                 case Maybe [a]
mpv of
                   Maybe [a]
Nothing -> Doc ann
"*"
                   Just [a]
vl -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
                              Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
L.intersperse Doc ann
forall ann. Doc ann
pipe ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$
                              (a -> Doc ann) -> [a] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [a]
vl
            in Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
1 (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
$ (ParameterPattern -> Doc ann) -> [ParameterPattern] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map ParameterPattern -> Doc ann
forall a a ann. (Pretty a, Pretty a) => (a, Maybe [a]) -> Doc ann
pp [ParameterPattern]
prms)

-- | Internally, this keeps the association between a possible file and the input
-- directory it came from.  The "file" portion is relative to the input
-- directory.

data CandidateFile = CandidateFile { CandidateFile -> FilePath
candidateDir :: FilePath
                                   , CandidateFile -> [FilePath]
candidateSubdirs :: [ FilePath ]
                                   , CandidateFile -> FilePath
candidateFile :: FilePath
                                   }
                     deriving (CandidateFile -> CandidateFile -> Bool
(CandidateFile -> CandidateFile -> Bool)
-> (CandidateFile -> CandidateFile -> Bool) -> Eq CandidateFile
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CandidateFile -> CandidateFile -> Bool
$c/= :: CandidateFile -> CandidateFile -> Bool
== :: CandidateFile -> CandidateFile -> Bool
$c== :: CandidateFile -> CandidateFile -> Bool
Eq, Int -> CandidateFile -> ShowS
[CandidateFile] -> ShowS
CandidateFile -> FilePath
(Int -> CandidateFile -> ShowS)
-> (CandidateFile -> FilePath)
-> ([CandidateFile] -> ShowS)
-> Show CandidateFile
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [CandidateFile] -> ShowS
$cshowList :: [CandidateFile] -> ShowS
show :: CandidateFile -> FilePath
$cshow :: CandidateFile -> FilePath
showsPrec :: Int -> CandidateFile -> ShowS
$cshowsPrec :: Int -> CandidateFile -> ShowS
Show)  -- Show is for for debugging/tracing

-- | This converts a CandidatFile into a regular FilePath for access
candidateToPath :: CandidateFile -> FilePath
candidateToPath :: CandidateFile -> FilePath
candidateToPath CandidateFile
c =
  CandidateFile -> FilePath
candidateDir CandidateFile
c FilePath -> ShowS
</> (FilePath -> ShowS) -> FilePath -> [FilePath] -> FilePath
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FilePath -> ShowS
(</>) (CandidateFile -> FilePath
candidateFile CandidateFile
c) (CandidateFile -> [FilePath]
candidateSubdirs CandidateFile
c)


-- | Each identified test input set is represented as a 'Sweets'
-- object.. a Specifications With Existing Expected Testing Samples.

data Sweets = Sweets
  { Sweets -> FilePath
rootBaseName :: String
    -- ^ The base of the root path for matching to expected.  This has no path
    -- elements, no extensions and no parameters.  It can be useful to use to
    -- compare to other fields in the 'expected' Expectation list of this
    -- structure.  Note that if the root file matched had parameters as part of
    -- the filename, those are not present in this rootBaseName.
  , Sweets -> FilePath
rootMatchName :: String
    -- ^ Matched root.  This is the name of the matched file, (no path elements)
    -- that matched the rootName in the input CUBE.  This includes any extension
    -- or parameter substitutions.  This is often the best name to use for
    -- displaying this matched item.
  , Sweets -> FilePath
rootFile :: FilePath
    -- ^ The full actual filepath of the matched root, with all path elements,
    -- extensions, parameters, and suffixes present.  This is most useful to open
    -- or otherwise access the file.
  , Sweets -> [ParameterPattern]
cubeParams :: [ParameterPattern] -- ^ parameters for match
  , Sweets -> [Expectation]
expected :: [Expectation] -- ^ all expected files and associated
  }
  deriving (Int -> Sweets -> ShowS
[Sweets] -> ShowS
Sweets -> FilePath
(Int -> Sweets -> ShowS)
-> (Sweets -> FilePath) -> ([Sweets] -> ShowS) -> Show Sweets
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Sweets] -> ShowS
$cshowList :: [Sweets] -> ShowS
show :: Sweets -> FilePath
$cshow :: Sweets -> FilePath
showsPrec :: Int -> Sweets -> ShowS
$cshowsPrec :: Int -> Sweets -> ShowS
Show, Sweets -> Sweets -> Bool
(Sweets -> Sweets -> Bool)
-> (Sweets -> Sweets -> Bool) -> Eq Sweets
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sweets -> Sweets -> Bool
$c/= :: Sweets -> Sweets -> Bool
== :: Sweets -> Sweets -> Bool
$c== :: Sweets -> Sweets -> Bool
Eq)

instance Pretty Sweets where
  pretty :: Sweets -> Doc ann
pretty Sweets
inp = Doc ann
"Sweet" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
               (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (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
$ [Maybe (Doc ann)] -> [Doc ann]
forall a. [Maybe a] -> [a]
catMaybes
                 [ Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Sweets -> FilePath
rootMatchName Sweets
inp)
                 , Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Doc ann
"root:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                   Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [ FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Sweets -> FilePath
rootBaseName Sweets
inp)
                               , FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Sweets -> FilePath
rootFile Sweets
inp)
                               ])
                 , [ParameterPattern] -> Maybe (Doc ann)
forall ann. [ParameterPattern] -> Maybe (Doc ann)
prettyParamPatterns ([ParameterPattern] -> Maybe (Doc ann))
-> [ParameterPattern] -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Sweets -> [ParameterPattern]
cubeParams Sweets
inp
                 , Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (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
$ (Expectation -> Doc ann) -> [Expectation] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Expectation -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([Expectation] -> [Doc ann]) -> [Expectation] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Sweets -> [Expectation]
expected Sweets
inp
                 ])

-- | The 'Association' specifies the name of the associated file entry
-- and the actual filepath of that associated file.

type Association = (String, FilePath)

-- | The 'NamedParamMatch' specifies the parameter name and the
-- corresponding value for the expected file found.  These can be
-- extracted from the name of the expected file and the set of
-- 'ParameterPattern' entries, but they are presented in an associated
-- list format for easy utilization by the invoked test target.

type NamedParamMatch = (String, ParamMatch)

-- | The 'Expectation' represents a valid test configuration based on
-- the set of provided files.  The 'Expectation' consists of an
-- expected file which matches the 'rootFile' in the containing
-- 'Sweets' data object.  The 'expectedFile' field is the name of the
-- file containing expected output, the 'expParamsMatch' field
-- specifies the 'ParameterPattern' matching values for this expected
-- file, and the 'associated' field provides a list of files
-- associated with this expected file.

data Expectation = Expectation
  { Expectation -> FilePath
expectedFile :: FilePath  -- ^ file containing Expected results
  , Expectation -> [NamedParamMatch]
expParamsMatch :: [ NamedParamMatch ] -- ^ set of CUBE parameters
                                          -- matched and the matched
                                          -- values.
  , Expectation -> [(FilePath, FilePath)]
associated :: [ Association ] -- ^ Associated files found
  }
  deriving Int -> Expectation -> ShowS
[Expectation] -> ShowS
Expectation -> FilePath
(Int -> Expectation -> ShowS)
-> (Expectation -> FilePath)
-> ([Expectation] -> ShowS)
-> Show Expectation
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Expectation] -> ShowS
$cshowList :: [Expectation] -> ShowS
show :: Expectation -> FilePath
$cshow :: Expectation -> FilePath
showsPrec :: Int -> Expectation -> ShowS
$cshowsPrec :: Int -> Expectation -> ShowS
Show

-- | Equality comparisons of two 'Expectation' objects ignores the
-- order of the 'expParamsMatch' and 'associated' fields.
instance Eq Expectation where
  Expectation
e1 == :: Expectation -> Expectation -> Bool
== Expectation
e2 = let bagCmp :: [a] -> [a] -> Bool
bagCmp [a]
a [a]
b = ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([a]
a [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
==) ([[a]] -> Bool) -> [[a]] -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> [[a]]
forall a. [a] -> [[a]]
L.permutations [a]
b
             in [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Expectation -> FilePath
expectedFile Expectation
e1 FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Expectation -> FilePath
expectedFile Expectation
e2
                    , ([NamedParamMatch] -> [NamedParamMatch] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
bagCmp ([NamedParamMatch] -> [NamedParamMatch] -> Bool)
-> (Expectation -> [NamedParamMatch])
-> Expectation
-> Expectation
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Expectation -> [NamedParamMatch]
expParamsMatch) Expectation
e1 Expectation
e2
                    , ([(FilePath, FilePath)] -> [(FilePath, FilePath)] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
bagCmp ([(FilePath, FilePath)] -> [(FilePath, FilePath)] -> Bool)
-> (Expectation -> [(FilePath, FilePath)])
-> Expectation
-> Expectation
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Expectation -> [(FilePath, FilePath)]
associated) Expectation
e1 Expectation
e2
                    ]

instance Pretty Expectation where
  pretty :: Expectation -> Doc ann
pretty Expectation
exp =
    let p :: [NamedParamMatch]
p = Expectation -> [NamedParamMatch]
expParamsMatch Expectation
exp
        pp :: Maybe (Doc ann)
pp = if [NamedParamMatch] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NamedParamMatch]
p
             then Maybe (Doc ann)
forall a. Maybe a
Nothing
             else Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Doc ann
"Matched Params:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (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
$ (NamedParamMatch -> Doc ann) -> [NamedParamMatch] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map NamedParamMatch -> Doc ann
forall a a ann. (Pretty a, Pretty a) => (a, a) -> Doc ann
ppp [NamedParamMatch]
p)
        ppp :: (a, a) -> Doc ann
ppp (a
n,a
v) = a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
n 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
<+> a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
v
        a :: [(FilePath, FilePath)]
a = Expectation -> [(FilePath, FilePath)]
associated Expectation
exp
        pa :: Maybe (Doc ann)
pa = if [(FilePath, FilePath)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FilePath, FilePath)]
a
             then Maybe (Doc ann)
forall a. Maybe a
Nothing
             else Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Doc ann
"Associated:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (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
$ ((FilePath, FilePath) -> Doc ann)
-> [(FilePath, FilePath)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, FilePath) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [(FilePath, FilePath)]
a)
    in Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
4 (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
$ [Maybe (Doc ann)] -> [Doc ann]
forall a. [Maybe a] -> [a]
catMaybes
       [ Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Doc ann
"Expected: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Expectation -> FilePath
expectedFile Expectation
exp))
       , Maybe (Doc ann)
forall ann. Maybe (Doc ann)
pp
       , Maybe (Doc ann)
forall ann. Maybe (Doc ann)
pa
       ]

-- | Indicates the matching parameter value for this identified
-- expected test.  If the parameter value is explicitly specified in
-- the expected filename, it is an 'Explicit' entry, otherwise it is
-- 'Assumed' (for each of the valid 'ParameterPattern' values) or
-- NotSpecified if there are no known 'ParameterPattern' values.

data ParamMatch =
  -- | This parameter value was explicitly specified in the filename
  -- of the expected file.
  Explicit String

  -- | This parameter value was not specified in the filename of the
  -- expected file, so the value is being synthetically supplied.
  -- This is used for parameters that have known values but none is
  -- present: an 'Expectation' is created for each possible parameter
  -- value, identifying each as 'Assumed'.
  | Assumed String

  -- | This parameter value was not specified in the filename for the
  -- expected file.  In addition, the associated 'ParameterPattern'
  -- specified no defined values (i.e. 'Nothing'), so it is not
  -- possible to identify any actual values.  Instead, the
  -- 'Expectation' generated for this expected file will supply this
  -- 'NotSpecified' for this type of parameter.
  | NotSpecified

  deriving (Int -> ParamMatch -> ShowS
[ParamMatch] -> ShowS
ParamMatch -> FilePath
(Int -> ParamMatch -> ShowS)
-> (ParamMatch -> FilePath)
-> ([ParamMatch] -> ShowS)
-> Show ParamMatch
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ParamMatch] -> ShowS
$cshowList :: [ParamMatch] -> ShowS
show :: ParamMatch -> FilePath
$cshow :: ParamMatch -> FilePath
showsPrec :: Int -> ParamMatch -> ShowS
$cshowsPrec :: Int -> ParamMatch -> ShowS
Show, ParamMatch -> ParamMatch -> Bool
(ParamMatch -> ParamMatch -> Bool)
-> (ParamMatch -> ParamMatch -> Bool) -> Eq ParamMatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParamMatch -> ParamMatch -> Bool
$c/= :: ParamMatch -> ParamMatch -> Bool
== :: ParamMatch -> ParamMatch -> Bool
$c== :: ParamMatch -> ParamMatch -> Bool
Eq, Eq ParamMatch
Eq ParamMatch
-> (ParamMatch -> ParamMatch -> Ordering)
-> (ParamMatch -> ParamMatch -> Bool)
-> (ParamMatch -> ParamMatch -> Bool)
-> (ParamMatch -> ParamMatch -> Bool)
-> (ParamMatch -> ParamMatch -> Bool)
-> (ParamMatch -> ParamMatch -> ParamMatch)
-> (ParamMatch -> ParamMatch -> ParamMatch)
-> Ord ParamMatch
ParamMatch -> ParamMatch -> Bool
ParamMatch -> ParamMatch -> Ordering
ParamMatch -> ParamMatch -> ParamMatch
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 :: ParamMatch -> ParamMatch -> ParamMatch
$cmin :: ParamMatch -> ParamMatch -> ParamMatch
max :: ParamMatch -> ParamMatch -> ParamMatch
$cmax :: ParamMatch -> ParamMatch -> ParamMatch
>= :: ParamMatch -> ParamMatch -> Bool
$c>= :: ParamMatch -> ParamMatch -> Bool
> :: ParamMatch -> ParamMatch -> Bool
$c> :: ParamMatch -> ParamMatch -> Bool
<= :: ParamMatch -> ParamMatch -> Bool
$c<= :: ParamMatch -> ParamMatch -> Bool
< :: ParamMatch -> ParamMatch -> Bool
$c< :: ParamMatch -> ParamMatch -> Bool
compare :: ParamMatch -> ParamMatch -> Ordering
$ccompare :: ParamMatch -> ParamMatch -> Ordering
$cp1Ord :: Eq ParamMatch
Ord)

instance Pretty ParamMatch where
  pretty :: ParamMatch -> Doc ann
pretty (Explicit FilePath
s) = FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty FilePath
s
  pretty (Assumed FilePath
s)  = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty FilePath
s
  pretty ParamMatch
NotSpecified = Doc ann
"*"


-- | The 'paramMatchVal' function is used to determine if a specific
-- value matches the corresponding 'ParamMatch'
paramMatchVal :: String -> ParamMatch -> Bool
paramMatchVal :: FilePath -> ParamMatch -> Bool
paramMatchVal FilePath
v (Explicit FilePath
s) = FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
v
paramMatchVal FilePath
v (Assumed FilePath
s) = FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
v
paramMatchVal FilePath
_ ParamMatch
NotSpecified = Bool
True


-- | Predicate test returning true for Explicit param values.
isExplicit :: ParamMatch -> Bool
isExplicit :: ParamMatch -> Bool
isExplicit = \case
  Explicit FilePath
_ -> Bool
True
  ParamMatch
_ -> Bool
False


-- | Extracts explicit value or Nothing
getExplicit :: ParamMatch -> Maybe String
getExplicit :: ParamMatch -> Maybe FilePath
getExplicit (Explicit FilePath
v) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
v
getExplicit ParamMatch
_            = Maybe FilePath
forall a. Maybe a
Nothing

-- | If there is a value associated with this parameter, return the value,
-- regardless of whether it is Explicit or Assumed.  A wildcard is a Nothing
-- return.
getParamVal :: ParamMatch -> Maybe String
getParamVal :: ParamMatch -> Maybe FilePath
getParamVal (Explicit FilePath
v) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
v
getParamVal (Assumed FilePath
v) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
v
getParamVal ParamMatch
_            = Maybe FilePath
forall a. Maybe a
Nothing

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

-- | The 'SweetExplanation' is the data type that contains the
-- description of the 'Test.Tasty.Sugar.findSugar' process and
-- results.
data SweetExplanation =
  SweetExpl { SweetExplanation -> FilePath
rootPath :: FilePath
            , SweetExplanation -> FilePath
base :: String
            , SweetExplanation -> [FilePath]
expectedNames :: [String]  -- ^ candidates
            , SweetExplanation -> Sweets
results :: Sweets -- ^ actual results
            }

instance Pretty SweetExplanation where
  pretty :: SweetExplanation -> Doc ann
pretty SweetExplanation
expl =
    let nms :: [FilePath]
nms = SweetExplanation -> [FilePath]
expectedNames SweetExplanation
expl
    in Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (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
$ [Maybe (Doc ann)] -> [Doc ann]
forall a. [Maybe a] -> [a]
catMaybes [
      Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fillSep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
","
        [ Doc ann
"rootPath" 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 (FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FilePath -> Doc ann) -> FilePath -> Doc ann
forall a b. (a -> b) -> a -> b
$ SweetExplanation -> FilePath
rootPath SweetExplanation
expl)
        , Doc ann
"base" 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 (FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FilePath -> Doc ann) -> FilePath -> Doc ann
forall a b. (a -> b) -> a -> b
$ SweetExplanation -> FilePath
base SweetExplanation
expl)
        , if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
nms
          then Doc ann
"no matches"
          else (Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Doc ann) -> Int -> Doc ann
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
nms) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"possible matches"
        ]
      , if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
nms
        then Maybe (Doc ann)
forall a. Maybe a
Nothing
        else Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
8 (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
$ (FilePath -> Doc ann) -> [FilePath] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [FilePath]
nms
      , Doc ann -> Maybe (Doc ann)
forall a. a -> Maybe a
Just (Doc ann -> Maybe (Doc ann)) -> Doc ann -> Maybe (Doc ann)
forall a b. (a -> b) -> a -> b
$ Sweets -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Sweets -> Doc ann) -> Sweets -> Doc ann
forall a b. (a -> b) -> a -> b
$ SweetExplanation -> Sweets
results SweetExplanation
expl
    ]

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