{-# 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Ord a => [a] -> [a]
DL.sort) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (forall a. Monoid a => a
mempty, 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 forall a. (a -> Bool) -> [a] -> [a]
filter ((String
pn forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [NamedParamMatch]
sel of
            [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedParamMatch]
an, (String
pn, forall a. Maybe a
Nothing) forall a. a -> [a] -> [a]
: [(String, Maybe String)]
av)
            [NamedParamMatch]
pvsets -> do ParamMatch
npv <- forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> [a] -> LogicI a
eachFrom Text
"assigned param value" [NamedParamMatch]
pvsets
                         forall (m :: * -> *) a. Monad m => a -> m a
return ((String
pn, ParamMatch
npv) forall a. a -> [a] -> [a]
: [NamedParamMatch]
an, (String
pn, ParamMatch -> Maybe String
getParamVal ParamMatch
npv) forall a. a -> [a] -> [a]
: [(String, Maybe String)]
av)
        eachVal ([NamedParamMatch]
an,[(String, Maybe String)]
av) (String
pn, Just [String]
pvs) =
          case forall a. (a -> Bool) -> [a] -> [a]
filter ((String
pn forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [NamedParamMatch]
sel of
            [] -> do String
pv <- forall a. Text -> [a] -> LogicI a
eachFrom Text
"assumed (non-root) param value" forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
DL.sort [String]
pvs
                     forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedParamMatch]
an, (String
pn, forall a. a -> Maybe a
Just String
pv) forall a. a -> [a] -> [a]
: [(String, Maybe String)]
av)
            [NamedParamMatch]
pvsets -> do ParamMatch
npv <- forall a. Text -> [a] -> LogicI a
eachFrom Text
"matched param value" (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedParamMatch]
pvsets)
                         forall (m :: * -> *) a. Monad m => a -> m a
return ((String
pn, ParamMatch
npv) forall a. a -> [a] -> [a]
: [NamedParamMatch]
an, (String
pn, ParamMatch -> Maybe String
getParamVal ParamMatch
npv) 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 = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (forall a b. (a, b) -> a
fst 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) 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) 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
          forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (ParamMatch -> Bool
isExplicit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd))
          -- the one with more parameters (usually the same)
        , forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (t :: * -> *) a. Foldable t => t a -> Int
length
          -- comparing keys
        , forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a. Ord a => [a] -> [a]
DL.sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst)
        ]
        -- comparing the correlated ParamMatch values
        forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (\String
k -> forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
k)) (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedParamMatch]
p1)
  in 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 -> 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 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all NamedParamMatch -> Bool
isCompatParam forall a b. (a -> b) -> a -> b
$ CandidateFile -> [NamedParamMatch]
candidatePMatch CandidateFile
fname