-- | Functions for checking different parameter/value combinations.

module Test.Tasty.Sugar.ParamCheck
  (
    eachFrom
  , getPVals
  , pvalMatch
  )
  where

import           Control.Monad.Logic
import qualified Data.List as L
import           Data.Maybe ( fromMaybe )

import           Test.Tasty.Sugar.Types


-- | Core Logic function to iteratively return elements of a list via
-- backtracking.
eachFrom :: [a] -> Logic a
eachFrom :: [a] -> Logic a
eachFrom = (a -> Logic a -> Logic a) -> Logic a -> [a] -> Logic a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Logic a -> Logic a -> Logic a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus (Logic a -> Logic a -> Logic a)
-> (a -> Logic a) -> a -> Logic a -> Logic a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Logic a
forall (m :: * -> *) a. Monad m => a -> m a
return) Logic a
forall (m :: * -> *) a. MonadPlus m => m a
mzero


-- | Returns various combinations of parameter value selections
getPVals :: [ParameterPattern] -> Logic [(String, Maybe String)]
getPVals :: [ParameterPattern] -> Logic [(String, Maybe String)]
getPVals = (ParameterPattern -> LogicT Identity (String, Maybe String))
-> [ParameterPattern] -> Logic [(String, Maybe String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ParameterPattern -> LogicT Identity (String, Maybe String)
forall a a. (a, Maybe [a]) -> LogicT Identity (a, Maybe a)
getPVal
  where
    getPVal :: (a, Maybe [a]) -> LogicT Identity (a, Maybe a)
getPVal (a
pn, Maybe [a]
Nothing) = (a, Maybe a) -> LogicT Identity (a, Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
pn, Maybe a
forall a. Maybe a
Nothing)
    getPVal (a
pn, Just [a]
pv) = do a
pv' <- [a] -> Logic a
forall a. [a] -> Logic a
eachFrom [a]
pv
                               (a, Maybe a) -> LogicT Identity (a, Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
pn, a -> Maybe a
forall a. a -> Maybe a
Just a
pv')

-- | Generate each possible combination of Explicit or non-Explicit
-- (Assumed or NotSpecified) parameter value and the corresponding
-- string with each combination of separators.  The string will be
-- used to match against input files.
--
-- Note that valid combinations require that if a parameter is
-- non-Explicit, all following parameters must also be non-Explicit.
--
-- The preset set of parameters are any parameters *already* matched
-- against (usually in the rootName); these parameters may or may not
-- be present in the filename matched from the output of this
-- function, but if they are present, they must have the values
-- specified in the preset (instead of having any of the possible
-- values allowed for that parameter).
--
-- It's also possible that since this returns varying combinations of
-- parameters, that there may be multiple files that will match
-- against these combinations.  Therefore, the results also indicate
-- how many of the parameters are used in the associated matching
-- string since the caller will usually select the match with the
-- highest ranking (number of matched parameters) in the filename.
-- [Note that it is not possibly to simply use the length of the
-- @[NamedParamMatch]@ return component since that may contain values
-- from the preset that don't actually occur in the match string.
pvalMatch :: Separators
          -> [NamedParamMatch]
          -> [(String, Maybe String)]
          -> Logic ([NamedParamMatch], Int, String)
pvalMatch :: String
-> [NamedParamMatch]
-> [(String, Maybe String)]
-> Logic ([NamedParamMatch], Int, String)
pvalMatch String
seps [NamedParamMatch]
preset [(String, Maybe String)]
pvals =
  let ([(String, Maybe String)]
ppv, [(String, Maybe String)]
rpv) = ((String, Maybe String) -> Bool)
-> [(String, Maybe String)]
-> ([(String, Maybe String)], [(String, Maybe String)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (String, Maybe String) -> Bool
forall b. (String, b) -> Bool
isPreset [(String, Maybe String)]
pvals
      isPreset :: (String, b) -> Bool
isPreset (String, b)
p = (String, b) -> String
forall a b. (a, b) -> a
fst (String, b)
p String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((NamedParamMatch -> String) -> [NamedParamMatch] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedParamMatch -> String
forall a b. (a, b) -> a
fst [NamedParamMatch]
preset)

      matchesPreset :: Bool
matchesPreset = ((String, Maybe String) -> Bool)
-> [(String, Maybe String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (String, Maybe String) -> Bool
matchPreset [(String, Maybe String)]
ppv
      matchPreset :: (String, Maybe String) -> Bool
matchPreset (String
pn,Maybe String
mpv) = Bool -> (ParamMatch -> Bool) -> Maybe ParamMatch -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Maybe String -> ParamMatch -> Bool
matchPresetVal Maybe String
mpv) (Maybe ParamMatch -> Bool) -> Maybe ParamMatch -> Bool
forall a b. (a -> b) -> a -> b
$
                             String -> [NamedParamMatch] -> Maybe ParamMatch
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pn [NamedParamMatch]
preset
      matchPresetVal :: Maybe String -> ParamMatch -> Bool
matchPresetVal Maybe String
mpv ParamMatch
pv = case Maybe String
mpv of
                                Just String
v -> String -> ParamMatch -> Bool
paramMatchVal String
v ParamMatch
pv
                                Maybe String
Nothing -> Bool
True

      pvVal :: [(String, Maybe String)] -> Logic [NamedParamMatch]
      pvVal :: [(String, Maybe String)] -> Logic [NamedParamMatch]
pvVal [] = [NamedParamMatch] -> Logic [NamedParamMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      pvVal ((String
pn, Maybe String
mpv):[(String, Maybe String)]
ps) =
        let explicit :: String -> Logic [NamedParamMatch]
explicit String
v = do [NamedParamMatch]
nxt <- [(String, Maybe String)] -> Logic [NamedParamMatch]
pvVal [(String, Maybe String)]
ps
                            [NamedParamMatch] -> Logic [NamedParamMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedParamMatch] -> Logic [NamedParamMatch])
-> [NamedParamMatch] -> Logic [NamedParamMatch]
forall a b. (a -> b) -> a -> b
$ (String
pn, String -> ParamMatch
Explicit String
v) NamedParamMatch -> [NamedParamMatch] -> [NamedParamMatch]
forall a. a -> [a] -> [a]
: [NamedParamMatch]
nxt
            notExplicit :: Logic [NamedParamMatch]
notExplicit = let pMatchImpl :: Maybe String -> ParamMatch
pMatchImpl = ParamMatch -> (String -> ParamMatch) -> Maybe String -> ParamMatch
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ParamMatch
NotSpecified String -> ParamMatch
Assumed
                              remPVMS :: [NamedParamMatch]
remPVMS = ((String, Maybe String) -> NamedParamMatch)
-> [(String, Maybe String)] -> [NamedParamMatch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe String -> ParamMatch)
-> (String, Maybe String) -> NamedParamMatch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe String -> ParamMatch
pMatchImpl) [(String, Maybe String)]
ps
                          in [NamedParamMatch] -> Logic [NamedParamMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedParamMatch] -> Logic [NamedParamMatch])
-> [NamedParamMatch] -> Logic [NamedParamMatch]
forall a b. (a -> b) -> a -> b
$ (String
pn, Maybe String -> ParamMatch
pMatchImpl Maybe String
mpv) NamedParamMatch -> [NamedParamMatch] -> [NamedParamMatch]
forall a. a -> [a] -> [a]
: [NamedParamMatch]
remPVMS
        in (Logic [NamedParamMatch]
-> (String -> Logic [NamedParamMatch])
-> Maybe String
-> Logic [NamedParamMatch]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Logic [NamedParamMatch]
forall (m :: * -> *) a. MonadPlus m => m a
mzero String -> Logic [NamedParamMatch]
explicit Maybe String
mpv) Logic [NamedParamMatch]
-> Logic [NamedParamMatch] -> Logic [NamedParamMatch]
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Logic [NamedParamMatch]
notExplicit

      genPVStr :: [NamedParamMatch] -> Logic String
      genPVStr :: [NamedParamMatch] -> Logic String
genPVStr [NamedParamMatch]
pvs =
        let vstr :: (a, ParamMatch) -> String
vstr = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> ((a, ParamMatch) -> Maybe String) -> (a, ParamMatch) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParamMatch -> Maybe String
getExplicit (ParamMatch -> Maybe String)
-> ((a, ParamMatch) -> ParamMatch)
-> (a, ParamMatch)
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, ParamMatch) -> ParamMatch
forall a b. (a, b) -> b
snd
            sepJoin :: String -> NamedParamMatch -> Logic String
            sepJoin :: String -> NamedParamMatch -> Logic String
sepJoin String
r NamedParamMatch
v = if ParamMatch -> Bool
isExplicit (NamedParamMatch -> ParamMatch
forall a b. (a, b) -> b
snd NamedParamMatch
v)
                          then do Char
s <- String -> Logic Char
forall a. [a] -> Logic a
eachFrom String
seps
                                  String -> Logic String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Logic String) -> String -> Logic String
forall a b. (a -> b) -> a -> b
$ [Char
s] String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NamedParamMatch -> String
forall a. (a, ParamMatch) -> String
vstr NamedParamMatch
v String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
r
                          else String -> Logic String
forall (m :: * -> *) a. Monad m => a -> m a
return String
r
        in if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
seps
           then String -> Logic String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Logic String) -> String -> Logic String
forall a b. (a -> b) -> a -> b
$ (NamedParamMatch -> String -> String)
-> String -> [NamedParamMatch] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\NamedParamMatch
v String
r -> NamedParamMatch -> String
forall a. (a, ParamMatch) -> String
vstr NamedParamMatch
v String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
r) String
"" [NamedParamMatch]
pvs
           else do Char
s <- String -> Logic Char
forall a. [a] -> Logic a
eachFrom String
seps
                   (String -> NamedParamMatch -> Logic String)
-> String -> [NamedParamMatch] -> Logic String
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM String -> NamedParamMatch -> Logic String
sepJoin [Char
s] [NamedParamMatch]
pvs

  in do Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
matchesPreset
        [NamedParamMatch]
candidateVals <- [(String, Maybe String)] -> Logic [NamedParamMatch]
pvVal [(String, Maybe String)]
rpv
        let rset :: [NamedParamMatch]
rset = [NamedParamMatch]
preset [NamedParamMatch] -> [NamedParamMatch] -> [NamedParamMatch]
forall a. Semigroup a => a -> a -> a
<> [NamedParamMatch]
candidateVals
            orderedRset :: [NamedParamMatch]
orderedRset = (String -> NamedParamMatch) -> [String] -> [NamedParamMatch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> NamedParamMatch
from_rset ([String] -> [NamedParamMatch]) -> [String] -> [NamedParamMatch]
forall a b. (a -> b) -> a -> b
$ ((String, Maybe String) -> String)
-> [(String, Maybe String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, Maybe String) -> String
forall a b. (a, b) -> a
fst [(String, Maybe String)]
pvals
            from_rset :: String -> NamedParamMatch
from_rset String
n = let Just ParamMatch
v = String -> [NamedParamMatch] -> Maybe ParamMatch
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup String
n [NamedParamMatch]
rset in (String
n,ParamMatch
v)
        String
pvstr <- [NamedParamMatch] -> Logic String
genPVStr [NamedParamMatch]
orderedRset
        ([NamedParamMatch], Int, String)
-> Logic ([NamedParamMatch], Int, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedParamMatch]
rset, [NamedParamMatch] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NamedParamMatch]
orderedRset, String
pvstr)