-- | Function to find expected results files for a specific root file,
-- along with any parameter values identified by the root file.

module Test.Tasty.Sugar.ExpectCheck
  (
    findExpectation
  , removeNonExplicitMatchingExpectations
  )
  where

import           Control.Monad.Logic
import           System.FilePath ( (</>) )
import qualified Data.List as L

import           Test.Tasty.Sugar.AssocCheck
import           Test.Tasty.Sugar.ParamCheck
import           Test.Tasty.Sugar.Types


-- | Finds the possible expected files matching the selected
-- source. There will be either one or none.
findExpectation :: CUBE
                -> FilePath   --  original name of source
                -> [FilePath] --  all of the names to choose from
                -> ([NamedParamMatch], FilePath, FilePath) -- param constraints from the root name
                -> Maybe ( Sweets, SweetExplanation )
findExpectation :: CUBE
-> FilePath
-> [FilePath]
-> ([NamedParamMatch], FilePath, FilePath)
-> Maybe (Sweets, SweetExplanation)
findExpectation CUBE
pat FilePath
rootN [FilePath]
allNames ([NamedParamMatch]
rootPMatches, FilePath
matchPrefix, FilePath
_) =
  let r :: Maybe Sweets
r = [Expectation] -> Maybe Sweets
mkSweet ([Expectation] -> Maybe Sweets)
-> ([Expectation] -> [Expectation])
-> [Expectation]
-> Maybe Sweets
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          [Expectation] -> [Expectation]
trimExpectations ([Expectation] -> Maybe Sweets) -> [Expectation] -> Maybe Sweets
forall a b. (a -> b) -> a -> b
$
          Logic Expectation -> [Expectation]
forall a. Logic a -> [a]
observeAll (Logic Expectation -> [Expectation])
-> Logic Expectation -> [Expectation]
forall a b. (a -> b) -> a -> b
$
          FilePath
-> FilePath
-> [NamedParamMatch]
-> FilePath
-> [ParameterPattern]
-> FilePath
-> [(FilePath, FilePath)]
-> [FilePath]
-> Logic Expectation
expectedSearch FilePath
d FilePath
matchPrefix [NamedParamMatch]
rootPMatches FilePath
seps [ParameterPattern]
params FilePath
expSuffix [(FilePath, FilePath)]
o
          [FilePath]
candidates
      d :: FilePath
d = CUBE -> FilePath
inputDir CUBE
pat
      o :: [(FilePath, FilePath)]
o = CUBE -> [(FilePath, FilePath)]
associatedNames CUBE
pat
      seps :: FilePath
seps = CUBE -> FilePath
separators CUBE
pat
      params :: [ParameterPattern]
params = CUBE -> [ParameterPattern]
validParams CUBE
pat
      expSuffix :: FilePath
expSuffix = CUBE -> FilePath
expectedSuffix CUBE
pat
      candidates :: [FilePath]
candidates = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
possible [FilePath]
allNames
      possible :: FilePath -> Bool
possible FilePath
f = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ FilePath
matchPrefix FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` FilePath
f
                       , FilePath
rootN FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
f
                       ]
      mkSweet :: [Expectation] -> Maybe Sweets
mkSweet [Expectation]
e = Sweets -> Maybe Sweets
forall a. a -> Maybe a
Just (Sweets -> Maybe Sweets) -> Sweets -> Maybe Sweets
forall a b. (a -> b) -> a -> b
$ Sweets :: FilePath
-> FilePath
-> FilePath
-> [ParameterPattern]
-> [Expectation]
-> Sweets
Sweets { rootMatchName :: FilePath
rootMatchName = FilePath
rootN
                                , rootBaseName :: FilePath
rootBaseName = FilePath
matchPrefix
                                , rootFile :: FilePath
rootFile = CUBE -> FilePath
inputDir CUBE
pat FilePath -> FilePath -> FilePath
</> FilePath
rootN
                                , cubeParams :: [ParameterPattern]
cubeParams = CUBE -> [ParameterPattern]
validParams CUBE
pat
                                , expected :: [Expectation]
expected = [Expectation]
e
                                }

      -- The expectedSearch tries various combinations and ordering of
      -- parameter values, separators, and such to find all valid
      -- expected file matches.  However, the result is an
      -- over-sampling, so this function trims the excess and unwanted
      -- expectations.
      trimExpectations :: [Expectation] -> [Expectation]
      trimExpectations :: [Expectation] -> [Expectation]
trimExpectations =
        -- If a parameter is Explicitly matched, discard any
        -- Expectation with the same Assumed matches.
        [Expectation] -> [Expectation]
removeNonExplicitMatchingExpectations
        -- remove duplicates (uses the Eq instance for Expectation
        -- that ignores the order of the expParamsMatch and associated
        -- to ensure that different ordering with the same values
        -- doesn't cause multiple Expectation.
        ([Expectation] -> [Expectation])
-> ([Expectation] -> [Expectation])
-> [Expectation]
-> [Expectation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expectation] -> [Expectation]
forall a. Eq a => [a] -> [a]
L.nub

  in case Maybe Sweets
r of
       Maybe Sweets
Nothing -> Maybe (Sweets, SweetExplanation)
forall a. Maybe a
Nothing
       Just Sweets
r' | [] <- Sweets -> [Expectation]
expected Sweets
r' -> Maybe (Sweets, SweetExplanation)
forall a. Maybe a
Nothing
       Just Sweets
r' -> (Sweets, SweetExplanation) -> Maybe (Sweets, SweetExplanation)
forall a. a -> Maybe a
Just ( Sweets
r'
                       , SweetExpl :: FilePath -> FilePath -> [FilePath] -> [Sweets] -> SweetExplanation
SweetExpl { rootPath :: FilePath
rootPath = FilePath
rootN
                                   , base :: FilePath
base = FilePath
matchPrefix
                                   , expectedNames :: [FilePath]
expectedNames =
                                       (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter
                                       (if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
expSuffix then Bool -> FilePath -> Bool
forall a b. a -> b -> a
const Bool
True
                                        else (FilePath
expSuffix FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf`))
                                     [FilePath]
candidates
                                   , results :: [Sweets]
results = [ Sweets
r' ]
                                   })

-- Find all Expectations matching this rootMatch
expectedSearch :: FilePath
               -> FilePath
               -> [NamedParamMatch]
               -> Separators
               -> [ParameterPattern]
               -> FileSuffix
               -> [ (String, FileSuffix) ]
               -> [FilePath]
               -> Logic Expectation
expectedSearch :: FilePath
-> FilePath
-> [NamedParamMatch]
-> FilePath
-> [ParameterPattern]
-> FilePath
-> [(FilePath, FilePath)]
-> [FilePath]
-> Logic Expectation
expectedSearch FilePath
inpDir FilePath
rootPrefix [NamedParamMatch]
rootPVMatches FilePath
seps [ParameterPattern]
params FilePath
expSuffix [(FilePath, FilePath)]
assocNames [FilePath]
allNames =
  do (FilePath
expFile, [NamedParamMatch]
pmatch) <-
       let bestRanked :: [(FilePath, Int, [NamedParamMatch])]
                      -> Logic (FilePath, [NamedParamMatch])
           bestRanked :: [(FilePath, Int, [NamedParamMatch])]
-> Logic (FilePath, [NamedParamMatch])
bestRanked [(FilePath, Int, [NamedParamMatch])]
l =
             if [(FilePath, Int, [NamedParamMatch])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FilePath, Int, [NamedParamMatch])]
l then Logic (FilePath, [NamedParamMatch])
forall (m :: * -> *) a. MonadPlus m => m a
mzero
             else let m :: Int
m = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((FilePath, Int, [NamedParamMatch]) -> Int)
-> [(FilePath, Int, [NamedParamMatch])] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath, Int, [NamedParamMatch]) -> Int
forall a b c. (a, b, c) -> b
rankValue [(FilePath, Int, [NamedParamMatch])]
l
                      rankValue :: (a, b, c) -> b
rankValue (a
_,b
r,c
_) = b
r
                      rankMatching :: a -> (a, a, c) -> Bool
rankMatching a
v (a
_,a
r,c
_) = a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
r
                      dropRank :: (a, b, b) -> (a, b)
dropRank (a
a,b
_,b
b) = (a
a,b
b)
                  in [(FilePath, [NamedParamMatch])]
-> Logic (FilePath, [NamedParamMatch])
forall a. [a] -> Logic a
eachFrom ([(FilePath, [NamedParamMatch])]
 -> Logic (FilePath, [NamedParamMatch]))
-> [(FilePath, [NamedParamMatch])]
-> Logic (FilePath, [NamedParamMatch])
forall a b. (a -> b) -> a -> b
$ ((FilePath, Int, [NamedParamMatch])
 -> (FilePath, [NamedParamMatch]))
-> [(FilePath, Int, [NamedParamMatch])]
-> [(FilePath, [NamedParamMatch])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath, Int, [NamedParamMatch]) -> (FilePath, [NamedParamMatch])
forall a b b. (a, b, b) -> (a, b)
dropRank ([(FilePath, Int, [NamedParamMatch])]
 -> [(FilePath, [NamedParamMatch])])
-> [(FilePath, Int, [NamedParamMatch])]
-> [(FilePath, [NamedParamMatch])]
forall a b. (a -> b) -> a -> b
$ ((FilePath, Int, [NamedParamMatch]) -> Bool)
-> [(FilePath, Int, [NamedParamMatch])]
-> [(FilePath, Int, [NamedParamMatch])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> (FilePath, Int, [NamedParamMatch]) -> Bool
forall a a c. Eq a => a -> (a, a, c) -> Bool
rankMatching Int
m) [(FilePath, Int, [NamedParamMatch])]
l

       in [(FilePath, Int, [NamedParamMatch])]
-> Logic (FilePath, [NamedParamMatch])
bestRanked ([(FilePath, Int, [NamedParamMatch])]
 -> Logic (FilePath, [NamedParamMatch]))
-> [(FilePath, Int, [NamedParamMatch])]
-> Logic (FilePath, [NamedParamMatch])
forall a b. (a -> b) -> a -> b
$
          Logic (FilePath, Int, [NamedParamMatch])
-> [(FilePath, Int, [NamedParamMatch])]
forall a. Logic a -> [a]
observeAll (Logic (FilePath, Int, [NamedParamMatch])
 -> [(FilePath, Int, [NamedParamMatch])])
-> Logic (FilePath, Int, [NamedParamMatch])
-> [(FilePath, Int, [NamedParamMatch])]
forall a b. (a -> b) -> a -> b
$
          do [ParameterPattern]
pseq <- [[ParameterPattern]] -> Logic [ParameterPattern]
forall a. [a] -> Logic a
eachFrom ([[ParameterPattern]] -> Logic [ParameterPattern])
-> [[ParameterPattern]] -> Logic [ParameterPattern]
forall a b. (a -> b) -> a -> b
$
                     ([] [ParameterPattern] -> [[ParameterPattern]] -> [[ParameterPattern]]
forall a. a -> [a] -> [a]
:) ([[ParameterPattern]] -> [[ParameterPattern]])
-> [[ParameterPattern]] -> [[ParameterPattern]]
forall a b. (a -> b) -> a -> b
$
                     ([ParameterPattern] -> Bool)
-> [[ParameterPattern]] -> [[ParameterPattern]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ([ParameterPattern] -> Bool) -> [ParameterPattern] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParameterPattern] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[ParameterPattern]] -> [[ParameterPattern]])
-> [[ParameterPattern]] -> [[ParameterPattern]]
forall a b. (a -> b) -> a -> b
$
                     ([ParameterPattern] -> [[ParameterPattern]])
-> [[ParameterPattern]] -> [[ParameterPattern]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [ParameterPattern] -> [[ParameterPattern]]
forall a. [a] -> [[a]]
L.inits ([[ParameterPattern]] -> [[ParameterPattern]])
-> [[ParameterPattern]] -> [[ParameterPattern]]
forall a b. (a -> b) -> a -> b
$
                     [ParameterPattern] -> [[ParameterPattern]]
forall a. [a] -> [[a]]
L.permutations [ParameterPattern]
params
             [(FilePath, Maybe FilePath)]
pvals <- [ParameterPattern] -> Logic [(FilePath, Maybe FilePath)]
getPVals [ParameterPattern]
pseq
             FilePath
-> [NamedParamMatch]
-> FilePath
-> [(FilePath, Maybe FilePath)]
-> FilePath
-> [FilePath]
-> Logic (FilePath, Int, [NamedParamMatch])
getExp FilePath
rootPrefix [NamedParamMatch]
rootPVMatches FilePath
seps [(FilePath, Maybe FilePath)]
pvals FilePath
expSuffix [FilePath]
allNames
     [(FilePath, FilePath)]
assocFiles <- FilePath
-> FilePath
-> [NamedParamMatch]
-> [(FilePath, FilePath)]
-> [FilePath]
-> Logic [(FilePath, FilePath)]
getAssoc FilePath
rootPrefix FilePath
seps [NamedParamMatch]
pmatch [(FilePath, FilePath)]
assocNames [FilePath]
allNames
     Expectation -> Logic Expectation
forall (m :: * -> *) a. Monad m => a -> m a
return (Expectation -> Logic Expectation)
-> Expectation -> Logic Expectation
forall a b. (a -> b) -> a -> b
$ Expectation :: FilePath
-> [NamedParamMatch] -> [(FilePath, FilePath)] -> Expectation
Expectation { expectedFile :: FilePath
expectedFile = FilePath
inpDir FilePath -> FilePath -> FilePath
</> FilePath
expFile
                          , associated :: [(FilePath, FilePath)]
associated = (FilePath -> FilePath)
-> (FilePath, FilePath) -> (FilePath, FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
inpDir FilePath -> FilePath -> FilePath
</>) ((FilePath, FilePath) -> (FilePath, FilePath))
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FilePath, FilePath)]
assocFiles
                          , expParamsMatch :: [NamedParamMatch]
expParamsMatch = [NamedParamMatch]
pmatch
                          }

-- Get all expected files for a particular sequence of param+value.
-- Returns the expected file, the sequence of parameter values that
-- match that expect file, and a ranking (the number of those paramter
-- values that actually appear in the expect file.
getExp :: FilePath
       -> [NamedParamMatch]
       -> Separators
       -> [(String, Maybe String)]
       -> FileSuffix
       -> [FilePath]
       -> Logic (FilePath, Int, [NamedParamMatch])
getExp :: FilePath
-> [NamedParamMatch]
-> FilePath
-> [(FilePath, Maybe FilePath)]
-> FilePath
-> [FilePath]
-> Logic (FilePath, Int, [NamedParamMatch])
getExp FilePath
rootPrefix [NamedParamMatch]
rootPMatches FilePath
seps [(FilePath, Maybe FilePath)]
pvals FilePath
expSuffix [FilePath]
allNames =
  do ([NamedParamMatch]
pm, Int
pmcnt, FilePath
pmstr) <- FilePath
-> [NamedParamMatch]
-> [(FilePath, Maybe FilePath)]
-> Logic ([NamedParamMatch], Int, FilePath)
pvalMatch FilePath
seps [NamedParamMatch]
rootPMatches [(FilePath, Maybe FilePath)]
pvals
     -- If the expSuffix starts with a separator then *only that*
     -- separator is allowed for the suffix (other seps are still
     -- allowed for parameter value separation).
     let suffixSpecifiesSep :: Bool
suffixSpecifiesSep = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
expSuffix)
                                  , FilePath -> Char
forall a. [a] -> a
head FilePath
expSuffix Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
seps
                                  ]
     let suffixSepMatch :: Bool
suffixSepMatch = Bool -> Bool
not Bool
suffixSpecifiesSep
                          Bool -> Bool -> Bool
|| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
pmstr)
                                 , FilePath -> Char
forall a. [a] -> a
last FilePath
pmstr Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Char
forall a. [a] -> a
head FilePath
expSuffix
                                 ]
     Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
suffixSepMatch
     let expFile :: FilePath
expFile = if Bool
suffixSpecifiesSep
                   then FilePath
rootPrefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
pmstr FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
forall a. [a] -> [a]
tail FilePath
expSuffix
                   else FilePath
rootPrefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
pmstr FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
expSuffix
     Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FilePath
expFile FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
allNames)
     (FilePath, Int, [NamedParamMatch])
-> Logic (FilePath, Int, [NamedParamMatch])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
expFile, Int
pmcnt, [NamedParamMatch]
pm)


removeNonExplicitMatchingExpectations :: [Expectation] -> [Expectation]
removeNonExplicitMatchingExpectations :: [Expectation] -> [Expectation]
removeNonExplicitMatchingExpectations [Expectation]
l =
  let removeNonExplicits :: [Expectation] -> Expectation -> [Expectation]
removeNonExplicits [Expectation]
lst Expectation
entry =
        let ([NamedParamMatch]
explParams, [NamedParamMatch]
assumedParams) =
              (NamedParamMatch -> Bool)
-> [NamedParamMatch] -> ([NamedParamMatch], [NamedParamMatch])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (ParamMatch -> Bool
isExplicit (ParamMatch -> Bool)
-> (NamedParamMatch -> ParamMatch) -> NamedParamMatch -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedParamMatch -> ParamMatch
forall a b. (a, b) -> b
snd) (Expectation -> [NamedParamMatch]
expParamsMatch Expectation
entry)

            -- only return False if oneExp should be
            -- removed: i.e. it is an Expectation that
            -- matches all non-explicit parameters and
            -- has non-explicit matches for any of the
            -- Explicit matches.
            nonExplMatch :: Expectation -> Bool
nonExplMatch Expectation
oneExp =
              [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Expectation
oneExp Expectation -> Expectation -> Bool
forall a. Eq a => a -> a -> Bool
== Expectation
entry
                 , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (NamedParamMatch -> Bool) -> [NamedParamMatch] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all NamedParamMatch -> Bool
nonExplParamCheck ([NamedParamMatch] -> Bool) -> [NamedParamMatch] -> Bool
forall a b. (a -> b) -> a -> b
$ Expectation -> [NamedParamMatch]
expParamsMatch Expectation
oneExp
                 ]

            -- return True if this parameter check would
            -- allow removal of this Explicit based on
            -- _this_ parameter.
            nonExplParamCheck :: NamedParamMatch -> Bool
nonExplParamCheck (FilePath
pn, ParamMatch
pv) =
              case FilePath -> [NamedParamMatch] -> Maybe ParamMatch
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
pn [NamedParamMatch]
explParams of
                Just (Explicit FilePath
ev) ->
                  case ParamMatch
pv of
                    Assumed FilePath
av -> FilePath
ev FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
av
                    ParamMatch
NotSpecified -> Bool
True
                    Explicit FilePath
ev' -> FilePath
ev FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
ev'
                Maybe ParamMatch
_ ->  -- generally nothing; other Just values not possible from explParams
                  case FilePath -> [NamedParamMatch] -> Maybe ParamMatch
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
pn [NamedParamMatch]
assumedParams of
                    Maybe ParamMatch
Nothing -> Bool
False
                    Just ParamMatch
av -> ParamMatch
av ParamMatch -> ParamMatch -> Bool
forall a. Eq a => a -> a -> Bool
== ParamMatch
pv

        in (Expectation -> Bool) -> [Expectation] -> [Expectation]
forall a. (a -> Bool) -> [a] -> [a]
filter Expectation -> Bool
nonExplMatch [Expectation]
lst

  in ([Expectation] -> Expectation -> [Expectation])
-> [Expectation] -> [Expectation] -> [Expectation]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Expectation] -> Expectation -> [Expectation]
removeNonExplicits [Expectation]
l [Expectation]
l