{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

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

module Test.Tasty.Sugar.ParamCheck
  (
    getSinglePVals
  , namedPMatches
  , pmatchCmp
  , pmatchMax
  , isCompatible
  )
  where

import           Control.Monad
import           Data.Function ( on )
import qualified Data.List as DL

import           Test.Tasty.Sugar.Types
import           Test.Tasty.Sugar.Iterations ( LogicI, eachFrom )


-- | Return a value to use for each parameter in the pattern, retricting those
-- values to the name parameter matches already established.  This is a little
-- more complicated because there could be parameter name duplicates in the
-- already established matches (e.g. a matched file contains multiple values for
-- a parameter), so the actual subset of the named parameter matches associated
-- with this pattern selection is also returned.

getSinglePVals :: [NamedParamMatch] -> [ParameterPattern]
               -> LogicI ([NamedParamMatch], [(String, Maybe String)])
getSinglePVals :: [NamedParamMatch]
-> [ParameterPattern]
-> LogicI ([NamedParamMatch], [(String, Maybe String)])
getSinglePVals [NamedParamMatch]
sel = (([NamedParamMatch], [(String, Maybe String)])
 -> ([NamedParamMatch], [(String, Maybe String)]))
-> LogicI ([NamedParamMatch], [(String, Maybe String)])
-> LogicI ([NamedParamMatch], [(String, Maybe String)])
forall a b.
(a -> b)
-> LogicT (StateT IterStat Identity) a
-> LogicT (StateT IterStat Identity) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([(String, Maybe String)] -> [(String, Maybe String)])
-> ([NamedParamMatch], [(String, Maybe String)])
-> ([NamedParamMatch], [(String, Maybe String)])
forall a b.
(a -> b) -> ([NamedParamMatch], a) -> ([NamedParamMatch], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(String, Maybe String)] -> [(String, Maybe String)]
forall a. Ord a => [a] -> [a]
DL.sort) (LogicI ([NamedParamMatch], [(String, Maybe String)])
 -> LogicI ([NamedParamMatch], [(String, Maybe String)]))
-> ([ParameterPattern]
    -> LogicI ([NamedParamMatch], [(String, Maybe String)]))
-> [ParameterPattern]
-> LogicI ([NamedParamMatch], [(String, Maybe String)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([NamedParamMatch], [(String, Maybe String)])
 -> ParameterPattern
 -> LogicI ([NamedParamMatch], [(String, Maybe String)]))
-> ([NamedParamMatch], [(String, Maybe String)])
-> [ParameterPattern]
-> LogicI ([NamedParamMatch], [(String, Maybe String)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([NamedParamMatch], [(String, Maybe String)])
-> ParameterPattern
-> LogicI ([NamedParamMatch], [(String, Maybe String)])
eachVal ([NamedParamMatch]
forall a. Monoid a => a
mempty, [(String, Maybe String)]
forall a. Monoid a => a
mempty)
  where eachVal :: ([NamedParamMatch], [(String, Maybe String)])
-> ParameterPattern
-> LogicI ([NamedParamMatch], [(String, Maybe String)])
eachVal ([NamedParamMatch]
an,[(String, Maybe String)]
av) (String
pn, Maybe [String]
Nothing) =
          case (NamedParamMatch -> Bool) -> [NamedParamMatch] -> [NamedParamMatch]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
pn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool)
-> (NamedParamMatch -> String) -> NamedParamMatch -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedParamMatch -> String
forall a b. (a, b) -> a
fst) [NamedParamMatch]
sel of
            [] -> ([NamedParamMatch], [(String, Maybe String)])
-> LogicI ([NamedParamMatch], [(String, Maybe String)])
forall a. a -> LogicT (StateT IterStat Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedParamMatch]
an, (String
pn, Maybe String
forall a. Maybe a
Nothing) (String, Maybe String)
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. a -> [a] -> [a]
: [(String, Maybe String)]
av)
            [NamedParamMatch]
pvsets -> do ParamMatch
npv <- NamedParamMatch -> ParamMatch
forall a b. (a, b) -> b
snd (NamedParamMatch -> ParamMatch)
-> LogicT (StateT IterStat Identity) NamedParamMatch
-> LogicT (StateT IterStat Identity) ParamMatch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> [NamedParamMatch]
-> LogicT (StateT IterStat Identity) NamedParamMatch
forall a. Text -> [a] -> LogicI a
eachFrom Text
"assigned param value" [NamedParamMatch]
pvsets
                         ([NamedParamMatch], [(String, Maybe String)])
-> LogicI ([NamedParamMatch], [(String, Maybe String)])
forall a. a -> LogicT (StateT IterStat Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String
pn, ParamMatch
npv) NamedParamMatch -> [NamedParamMatch] -> [NamedParamMatch]
forall a. a -> [a] -> [a]
: [NamedParamMatch]
an, (String
pn, ParamMatch -> Maybe String
getParamVal ParamMatch
npv) (String, Maybe String)
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. a -> [a] -> [a]
: [(String, Maybe String)]
av)
        eachVal ([NamedParamMatch]
an,[(String, Maybe String)]
av) (String
pn, Just [String]
pvs) =
          case (NamedParamMatch -> Bool) -> [NamedParamMatch] -> [NamedParamMatch]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
pn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool)
-> (NamedParamMatch -> String) -> NamedParamMatch -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedParamMatch -> String
forall a b. (a, b) -> a
fst) [NamedParamMatch]
sel of
            [] -> do String
pv <- Text -> [String] -> LogicI String
forall a. Text -> [a] -> LogicI a
eachFrom Text
"assumed (non-root) param value" ([String] -> LogicI String) -> [String] -> LogicI String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Ord a => [a] -> [a]
DL.sort [String]
pvs
                     ([NamedParamMatch], [(String, Maybe String)])
-> LogicI ([NamedParamMatch], [(String, Maybe String)])
forall a. a -> LogicT (StateT IterStat Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedParamMatch]
an, (String
pn, String -> Maybe String
forall a. a -> Maybe a
Just String
pv) (String, Maybe String)
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. a -> [a] -> [a]
: [(String, Maybe String)]
av)
            [NamedParamMatch]
pvsets -> do ParamMatch
npv <- Text
-> [ParamMatch] -> LogicT (StateT IterStat Identity) ParamMatch
forall a. Text -> [a] -> LogicI a
eachFrom Text
"matched param value" (NamedParamMatch -> ParamMatch
forall a b. (a, b) -> b
snd (NamedParamMatch -> ParamMatch)
-> [NamedParamMatch] -> [ParamMatch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedParamMatch]
pvsets)
                         ([NamedParamMatch], [(String, Maybe String)])
-> LogicI ([NamedParamMatch], [(String, Maybe String)])
forall a. a -> LogicT (StateT IterStat Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String
pn, ParamMatch
npv) NamedParamMatch -> [NamedParamMatch] -> [NamedParamMatch]
forall a. a -> [a] -> [a]
: [NamedParamMatch]
an, (String
pn, ParamMatch -> Maybe String
getParamVal ParamMatch
npv) (String, Maybe String)
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. a -> [a] -> [a]
: [(String, Maybe String)]
av)


-- | namedPMatches supplements the core set of named matches with the extended
-- set of parameter values, marking all parameters not in the core set as Assumed
-- or NotSpecified.

namedPMatches :: [NamedParamMatch] -> [(String, Maybe String)]
              -> [NamedParamMatch]
namedPMatches :: [NamedParamMatch] -> [(String, Maybe String)] -> [NamedParamMatch]
namedPMatches [NamedParamMatch]
pmatch =
  let inCore :: String -> Bool
inCore = (String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (NamedParamMatch -> String
forall a b. (a, b) -> a
fst (NamedParamMatch -> String) -> [NamedParamMatch] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedParamMatch]
pmatch))
      go :: [(String, Maybe String)] -> [NamedParamMatch]
go = \case
        [] -> [NamedParamMatch]
pmatch
        ((String
p, Just  String
v):[(String, Maybe String)]
r) | Bool -> Bool
not (String -> Bool
inCore String
p) -> (String
p, String -> ParamMatch
Assumed String
v) NamedParamMatch -> [NamedParamMatch] -> [NamedParamMatch]
forall a. a -> [a] -> [a]
: [(String, Maybe String)] -> [NamedParamMatch]
go [(String, Maybe String)]
r
        ((String
p, Maybe String
Nothing):[(String, Maybe String)]
r) | Bool -> Bool
not (String -> Bool
inCore String
p) -> (String
p, ParamMatch
NotSpecified) NamedParamMatch -> [NamedParamMatch] -> [NamedParamMatch]
forall a. a -> [a] -> [a]
: [(String, Maybe String)] -> [NamedParamMatch]
go [(String, Maybe String)]
r
        ((String, Maybe String)
_:[(String, Maybe String)]
r) -> [(String, Maybe String)] -> [NamedParamMatch]
go [(String, Maybe String)]
r
    in [(String, Maybe String)] -> [NamedParamMatch]
go


-- | This provides an Ordering result of comparing two sets of NamedParamMatch.
-- This can be used for sorting or other prioritization of named matches.

pmatchCmp :: [ NamedParamMatch ] -> [ NamedParamMatch ] -> Ordering
pmatchCmp :: [NamedParamMatch] -> [NamedParamMatch] -> Ordering
pmatchCmp [NamedParamMatch]
p1 [NamedParamMatch]
p2 =
  let comparisons :: [[NamedParamMatch] -> [NamedParamMatch] -> Ordering]
comparisons =
        [
          -- the one with more Explicit matches is better
          Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ([NamedParamMatch] -> Int)
-> [NamedParamMatch]
-> [NamedParamMatch]
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([NamedParamMatch] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([NamedParamMatch] -> Int)
-> ([NamedParamMatch] -> [NamedParamMatch])
-> [NamedParamMatch]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedParamMatch -> Bool) -> [NamedParamMatch] -> [NamedParamMatch]
forall a. (a -> Bool) -> [a] -> [a]
filter (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))
          -- the one with more parameters (usually the same)
        , Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ([NamedParamMatch] -> Int)
-> [NamedParamMatch]
-> [NamedParamMatch]
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` [NamedParamMatch] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
          -- comparing keys
        , [String] -> [String] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([String] -> [String] -> Ordering)
-> ([NamedParamMatch] -> [String])
-> [NamedParamMatch]
-> [NamedParamMatch]
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([String] -> [String]
forall a. Ord a => [a] -> [a]
DL.sort ([String] -> [String])
-> ([NamedParamMatch] -> [String]) -> [NamedParamMatch] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedParamMatch -> String) -> [NamedParamMatch] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedParamMatch -> String
forall a b. (a, b) -> a
fst)
        ]
        -- comparing the correlated ParamMatch values
        [[NamedParamMatch] -> [NamedParamMatch] -> Ordering]
-> [[NamedParamMatch] -> [NamedParamMatch] -> Ordering]
-> [[NamedParamMatch] -> [NamedParamMatch] -> Ordering]
forall a. Semigroup a => a -> a -> a
<> (String -> [NamedParamMatch] -> [NamedParamMatch] -> Ordering)
-> [String] -> [[NamedParamMatch] -> [NamedParamMatch] -> Ordering]
forall a b. (a -> b) -> [a] -> [b]
map (\String
k -> Maybe ParamMatch -> Maybe ParamMatch -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Maybe ParamMatch -> Maybe ParamMatch -> Ordering)
-> ([NamedParamMatch] -> Maybe ParamMatch)
-> [NamedParamMatch]
-> [NamedParamMatch]
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (String -> [NamedParamMatch] -> Maybe ParamMatch
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
k)) (NamedParamMatch -> String
forall a b. (a, b) -> a
fst (NamedParamMatch -> String) -> [NamedParamMatch] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedParamMatch]
p1)
  in [[NamedParamMatch] -> [NamedParamMatch] -> Ordering]
-> [NamedParamMatch] -> [NamedParamMatch] -> Ordering
forall a. [a -> a -> Ordering] -> a -> a -> Ordering
cascadeCompare [[NamedParamMatch] -> [NamedParamMatch] -> Ordering]
comparisons [NamedParamMatch]
p1 [NamedParamMatch]
p2

cascadeCompare :: [ a -> a -> Ordering ] -> a -> a -> Ordering
cascadeCompare :: forall a. [a -> a -> Ordering] -> a -> a -> Ordering
cascadeCompare [] a
_ a
_ = Ordering
EQ
cascadeCompare (a -> a -> Ordering
o:[a -> a -> Ordering]
os) a
a a
b = case a -> a -> Ordering
o a
a a
b of
                              Ordering
EQ -> [a -> a -> Ordering] -> a -> a -> Ordering
forall a. [a -> a -> Ordering] -> a -> a -> Ordering
cascadeCompare [a -> a -> Ordering]
os a
a a
b
                              Ordering
x -> Ordering
x


-- | Returns the maximum of two arguments based on comparing the
-- [NamedParamMatch] extracted from each argument (via the passed function).

pmatchMax :: (a -> [NamedParamMatch]) -> a -> a -> a
pmatchMax :: forall a. (a -> [NamedParamMatch]) -> a -> a -> a
pmatchMax a -> [NamedParamMatch]
f a
a a
b = case [NamedParamMatch] -> [NamedParamMatch] -> Ordering
pmatchCmp (a -> [NamedParamMatch]
f a
a) (a -> [NamedParamMatch]
f a
b) of
                    Ordering
LT -> a
b
                    Ordering
_ -> a
a


-- | isCompatible can be used as a filter predicate to determine if the specified
-- file is compatible with the provided parameters and chosen parameter values.
-- One principle compatibility check is ensuring that there is no *other*
-- parameter value in the filename that conflicts with a chosen parameter value.
isCompatible :: [(String, Maybe String)]
             -> CandidateFile
             -> Bool
isCompatible :: [(String, Maybe String)] -> CandidateFile -> Bool
isCompatible [(String, Maybe String)]
pvals CandidateFile
fname =
  let isCompatParam :: NamedParamMatch -> Bool
isCompatParam (String
n,ParamMatch
v) = case String -> [(String, Maybe String)] -> Maybe (Maybe String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
DL.lookup String
n [(String, Maybe String)]
pvals of
                              Maybe (Maybe String)
Nothing -> Bool
True
                              Just Maybe String
Nothing -> Bool
True
                              Just (Just String
cv) -> String -> ParamMatch -> Bool
paramMatchVal String
cv ParamMatch
v
  in (NamedParamMatch -> Bool) -> [NamedParamMatch] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all NamedParamMatch -> Bool
isCompatParam ([NamedParamMatch] -> Bool) -> [NamedParamMatch] -> Bool
forall a b. (a -> b) -> a -> b
$ CandidateFile -> [NamedParamMatch]
candidatePMatch CandidateFile
fname