-- | Provides the rangedParam and rangedParamAdjuster helper functions.

{-# LANGUAGE LambdaCase #-}

module Test.Tasty.Sugar.Ranged
  ( rangedParam
  , rangedParamAdjuster
  )
where

import           Control.Applicative ( liftA2 )
import           Control.Monad.IO.Class ( MonadIO )
import           Data.Function ( on )
import qualified Data.List as L
import           Data.Maybe ( isNothing )
import qualified Data.Set as Set

import           Test.Tasty.Sugar.Types


-- | Given a Parameter Name and a boolean that indicates valid/not-valid for a
-- Parameter Value, update the expectations in the Sweets to treat the parameter
-- as a ranged value.
--
-- [This is the pure internals version; the recommended usage is via the
-- 'rangedParamAdjuster' wrapper specification in the 'sweetAdjuster' field of
-- the 'CUBE' structure.]
--
-- Normal sweets results expect a 1:1 match between parameter value and the
-- expected file markup, but this function modifies the sweets results to
-- accomodate a parameter range with range boundaries.  For example, if the test
-- might vary the output based on the version of clang used to compile the file,
-- the 'CUBE' might specify:
--
-- > mkCUBE { rootName = "*.c"
-- >        , expectedSuffix = "good"
-- >        , validParams = [ ("clang-range", Just ["pre_clang11", "pre_clang13" ] ) ]
-- >        ...
-- >        }
--
-- Then if the following files were present:
--
-- > foo.c
-- > foo-pre_clang11.good
-- > foo.good
--
-- Then a normal sweets response would include the expectations:
--
--  > foo-pre_clang11.good ==> Explicit "pre_clang11"
--  > foo.good             ==> Assumed  "pre_clang13"
--
-- The 'Test.Tasty.Sugar.withSugarGroups' callback would then be invoked with
-- these two expectations.  The callback might check the actual version of clang
-- available to run in the environment.  If it detected clang version 10 was
-- available, the best file would be the @foo-pre_clang11.good@, even though the
-- parameters didn't mention @clang9@ and the @foo.good@ would be the usual match
-- to pick when there was no explicit match.
--
-- To handle this case, the 'rangedParam' function is used to filter the sweets,
-- and is also given the version of clang locally available:
--
-- > let rangedSweets = rangedParam "clang-range" extract (<=) (Just "9") sweets
-- >     extract = readMaybe . drop (length "pre-clang")
-- > withSugarGroups rangedSweets TT.testGroup $ \sweet instnum exp ->
-- >   ... generate test ...
--
-- Where the above would result in a single call to the _generate test_ code with
-- the @foo-pre_clang11.good@ expectation.  The @extract@ function removes the
-- numeric value from the parameter value, and the @<=@ test checks to see if the
-- version supplied is less than or equal to the extracted parameter value.
--
-- The @>@ comparator could be used if the validParams values specified a lower
-- limit instead of an upper limit, and the comparator and extractor can be
-- extended to handle other ways of specifying ranges.
--
-- If the extract function returns Nothing, then the corresponding parameter
-- value is /not/ a ranged parameter value (there can be a mix of ranged values
-- and non-ranged values), and the corresponding value(s) will be used whenever
-- there is not a ranged match.  As an example, if the 'validParams' above was
-- extended with a "recent-clang" value; for actual clang versions up through 12
-- one of the pre_clang values provides the ranged match, but for clang versions
-- of 13 or later, there is no pre_clang match so recent-clang will be used.
-- Providing a non-extractable parameter value is recommended as the default to
-- select when no ranged value is applicable; the expected file does /not/ need
-- to have the same parameter value since a weak match (no parameter match) file
-- will match with the 'Assumed' value, which will be selected if no better
-- ranged match is applicable.

rangedParam :: Enum a => Ord a
            => String -> (String -> Maybe a) -> (a -> a -> Bool)
            -> Maybe a
            -> CUBE -> [Sweets] -> [Sweets]
rangedParam :: forall a.
(Enum a, Ord a) =>
String
-> (String -> Maybe a)
-> (a -> a -> Bool)
-> Maybe a
-> CUBE
-> [Sweets]
-> [Sweets]
rangedParam String
pname String -> Maybe a
extractVal a -> a -> Bool
cmpVal Maybe a
targetVal CUBE
cube [Sweets]
sweets =
  let adj :: Sweets -> Sweets
adj Sweets
sweet = let exps :: [Expectation]
exps = Sweets -> [Expectation]
expected Sweets
sweet
                  in Sweets
sweet { expected :: [Expectation]
expected = [Expectation] -> [Expectation]
adjustExp [Expectation]
exps }

      -- extracts all parameters except the named parameter
      paramsExceptPName :: Expectation -> [(String, ParamMatch)]
paramsExceptPName = forall a. (a -> Bool) -> [a] -> [a]
filter ((String
pname forall a. Eq a => a -> a -> Bool
/=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expectation -> [(String, ParamMatch)]
expParamsMatch

      -- Compares two assoc-lists for equality on the union of both.
      assocUnionEq :: [(String, ParamMatch)] -> [(String, ParamMatch)] -> Bool
assocUnionEq = \case
        [] -> forall a b. a -> b -> a
const Bool
True
        ((String
an,ParamMatch
av):[(String, ParamMatch)]
as) -> \case
          [] -> Bool
True
          [(String, ParamMatch)]
bs -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
an [(String, ParamMatch)]
bs of
                  Maybe ParamMatch
Nothing -> [(String, ParamMatch)] -> [(String, ParamMatch)] -> Bool
assocUnionEq [(String, ParamMatch)]
as [(String, ParamMatch)]
bs
                  Just ParamMatch
bv -> ParamMatch
av forall a. Eq a => a -> a -> Bool
== ParamMatch
bv Bool -> Bool -> Bool
&& [(String, ParamMatch)] -> [(String, ParamMatch)] -> Bool
assocUnionEq [(String, ParamMatch)]
as [(String, ParamMatch)]
bs

      -- This divides a list into clusters of lists, where each sub-list contains
      -- members that satisfy a comparison predicate between the list members
      -- (comparing against the first member of each sub-list).  This is
      -- effectively List.groupBy, but with global clustering instead of local
      -- clustering.
      --
      -- > Data.List.groupBy (==) "Mississippi" = ["M", "i", "ss", "i", "ss" ...]
      -- > cluster (==) "Mississippi" = ["M", "iiii", "ssss", "pp"]
      clusterBy :: (a -> a -> Bool) -> [a] -> [[a]]
clusterBy a -> a -> Bool
equiv = \case
        [] -> []
        (a
x:[a]
xs) -> let ([a]
same,[a]
diff) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (a -> a -> Bool
equiv a
x) [a]
xs
                  in (a
xforall a. a -> [a] -> [a]
:[a]
same) forall a. a -> [a] -> [a]
: (a -> a -> Bool) -> [a] -> [[a]]
clusterBy a -> a -> Bool
equiv [a]
diff

      adjustExp :: [Expectation] -> [Expectation]
      adjustExp :: [Expectation] -> [Expectation]
adjustExp [Expectation]
exps = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Expectation] -> [Expectation]
expInRange
                       forall a b. (a -> b) -> a -> b
$ forall {a}. (a -> a -> Bool) -> [a] -> [[a]]
clusterBy ([(String, ParamMatch)] -> [(String, ParamMatch)] -> Bool
assocUnionEq forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Expectation -> [(String, ParamMatch)]
paramsExceptPName) [Expectation]
exps

      notRange :: Expectation -> Bool
notRange Expectation
e = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False
                   (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe a
extractVal)
                   (ParamMatch -> Maybe String
getParamVal forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pname (Expectation -> [(String, ParamMatch)]
expParamsMatch Expectation
e))

      expInRange :: [Expectation] -> [Expectation]
      expInRange :: [Expectation] -> [Expectation]
expInRange =
        case Maybe a
targetVal of
          Maybe a
Nothing ->
            -- User did not specify which target version of clang was desired.
            -- Iterate through the possible parameter values, extract the version
            -- associated with each, and return the expectations that would have
            -- been chosen for that version.  Also use a version that is the succ
            -- of the highest and the pred of the lowest, to ensure
            -- out-of-known-range values are also considered.
            case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pname (CUBE -> [ParameterPattern]
validParams CUBE
cube) of
              Maybe (Maybe [String])
Nothing ->
                -- Should not happen: this means the user called rangedParam with
                -- a parameter name that is not an actual parameter.  In this
                -- case, just return the inputs.
                forall a. a -> a
id
              Just Maybe [String]
Nothing ->
                -- Cannot support ranges on existentials (parameters whose value
                -- can be *anything*).  This can happen if the user specifies a
                -- parameter name of this type.  In this case, there is no
                -- meaningful range that can be predicted, so just return the
                -- inputs
                forall a. a -> a
id
              Just (Just [String]
vals) -> \[Expectation]
exps ->
                -- Iterate through the possible values to extract the
                -- corresponding parameter value.  This may be a subset of the
                -- actual values that could be encountered, but it at least
                -- allows the proper expected file to be determined for this set
                -- of values.  For possible values that do not have a valid
                -- extraction, just pass those Expectation entires through
                -- directly.
                let withPVal :: Maybe a -> [Expectation]
withPVal = \case
                      Maybe a
Nothing -> forall a. (a -> Bool) -> [a] -> [a]
filter Expectation -> Bool
notRange [Expectation]
exps
                      Just a
v -> a -> [Expectation] -> [Expectation]
expInRangeFor a
v [Expectation]
exps
                    vals' :: Set (Maybe a)
vals' = forall a. Ord a => [a] -> Set a
Set.fromList (String -> Maybe a
extractVal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
vals)
                            -- Use a Set to eliminate duplicates, especially of
                            -- Nothing results.
                    vals'' :: Set (Maybe a)
vals'' = let vs :: Set (Maybe a)
vs = forall a. Maybe a
Nothing forall a. Ord a => a -> Set a -> Set a
`Set.delete` Set (Maybe a)
vals'
                                 lower :: Maybe a
lower = forall a. Enum a => a -> a
pred forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum Set (Maybe a)
vs
                                 higher :: Maybe a
higher = forall a. Enum a => a -> a
succ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum Set (Maybe a)
vs
                             in if forall a. Set a -> Bool
Set.null Set (Maybe a)
vs
                                then Set (Maybe a)
vs
                                else Maybe a
lower forall a. Ord a => a -> Set a -> Set a
`Set.insert` (Maybe a
higher forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set (Maybe a)
vs)
                in forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
                   -- Set operations combine/eliminate identical results
                   forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. Ord a => a -> Set a -> Set a
Set.insert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> [Expectation]
withPVal) forall a. Monoid a => a
mempty Set (Maybe a)
vals''
          Just a
tv -> a -> [Expectation] -> [Expectation]
expInRangeFor a
tv

      -- expInRangeFor :: a -> [Expectation] -> [Expectation]
      expInRangeFor :: a -> [Expectation] -> [Expectation]
expInRangeFor a
tgtVal [Expectation]
exps =
            -- Find the expectations with the _cmpVal-est_ Explicit that is still
            -- a _cmpVal_ of the input value than the target value.  If none
            -- exist, use the expectations that Assume the target value.  There
            -- can be multiple matches because of differences in other parameter
            -- values; stated another way: for any set of parameter values, find
            -- the expectations with the cmpVal-est Explicit ...
            let explParam :: Expectation -> Bool
explParam Expectation
e = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pname forall a b. (a -> b) -> a -> b
$ Expectation -> [(String, ParamMatch)]
expParamsMatch Expectation
e of
                                Just (Explicit String
v) ->
                                  forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (a -> a -> Bool
cmpVal a
tgtVal) forall a b. (a -> b) -> a -> b
$ String -> Maybe a
extractVal String
v
                                Maybe ParamMatch
_ -> Bool
False
                okParam :: Expectation -> Bool
okParam Expectation
e = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pname forall a b. (a -> b) -> a -> b
$ Expectation -> [(String, ParamMatch)]
expParamsMatch Expectation
e of
                              Just (Assumed String
v) ->
                                  forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (a -> a -> Bool
cmpVal a
tgtVal) forall a b. (a -> b) -> a -> b
$ String -> Maybe a
extractVal String
v
                              Maybe ParamMatch
_ -> Bool
False
                pval :: Expectation -> Maybe a
pval Expectation
e = do ParamMatch
pm <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pname forall a b. (a -> b) -> a -> b
$ Expectation -> [(String, ParamMatch)]
expParamsMatch Expectation
e
                            String
pv <- ParamMatch -> Maybe String
getParamVal ParamMatch
pm
                            String -> Maybe a
extractVal String
pv
                -- bestsBy finds the testVal-est value for each set of
                -- expectations whose other parameter values are the same.
                bestsBy :: (Expectation -> Maybe b)
-> (b -> b -> Bool) -> [Expectation] -> [Expectation]
bestsBy Expectation -> Maybe b
getVal b -> b -> Bool
testVal = \case
                  [] -> []
                  (Expectation
xp:[Expectation]
xps) ->
                    let chk :: Expectation -> [Expectation] -> [Expectation]
chk Expectation
e [Expectation]
bests =
                          -- e is an Expectation, bests is the best testVal-est
                          -- [Expectation] collected so-far.
                          let ev :: Maybe b
ev = Expectation -> Maybe b
getVal Expectation
e
                              ep :: [(String, ParamMatch)]
ep = Expectation -> [(String, ParamMatch)]
paramsExceptPName Expectation
e
                              matchE :: Expectation -> Bool
matchE = [(String, ParamMatch)] -> [(String, ParamMatch)] -> Bool
assocUnionEq [(String, ParamMatch)]
ep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expectation -> [(String, ParamMatch)]
paramsExceptPName
                              ([Expectation]
yes,[Expectation]
oBest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition Expectation -> Bool
matchE [Expectation]
bests
                                -- yes is the entries in bests whose non-PName
                                -- parameters match e, so we can now determine if
                                -- yes or z is testVal-est (yes may have multiple
                                -- entries, but if it does they should have the
                                -- same value for pname, which mostly happens on
                                -- the Nothing case... param does not exist or
                                -- has NotSpecified value).
                                --
                                -- oBest has the other entries in bests that
                                -- don't match e and should therefore just be
                                -- passed through.  Note that due to adjustExp
                                -- this should usually be a null list.
                              yv :: Maybe b
yv = Expectation -> Maybe b
getVal forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Expectation]
yes
                          in case () of
                               ()
_ | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expectation]
yes -> Expectation
eforall a. a -> [a] -> [a]
:[Expectation]
bests
                               ()
_ | Maybe b
ev forall a. Eq a => a -> a -> Bool
== Maybe b
yv -> Expectation
eforall a. a -> [a] -> [a]
:[Expectation]
bests
                               ()
_ -> case forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> b -> Bool
testVal Maybe b
yv Maybe b
ev of
                                      Just Bool
True -> [Expectation]
bests
                                      Just Bool
False -> Expectation
eforall a. a -> [a] -> [a]
:[Expectation]
oBest
                                      Maybe Bool
Nothing -> Expectation
eforall a. a -> [a] -> [a]
:[Expectation]
oBest
                                             -- maybe bests (const (e:oBest)) ev
                    in forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Expectation -> [Expectation] -> [Expectation]
chk [Expectation
xp] [Expectation]
xps
                exps' :: [Expectation]
exps' = let expl :: [Expectation]
expl = forall a. (a -> Bool) -> [a] -> [a]
L.filter Expectation -> Bool
explParam [Expectation]
exps
                            assum :: [Expectation]
assum = forall a. (a -> Bool) -> [a] -> [a]
L.filter Expectation -> Bool
okParam [Expectation]
exps
                            nonRanged :: [Expectation]
nonRanged = forall a. (a -> Bool) -> [a] -> [a]
L.filter Expectation -> Bool
notRange [Expectation]
exps
                        in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expectation]
expl
                           then if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expectation]
assum
                                then [Expectation]
nonRanged
                                else [Expectation]
assum
                           else [Expectation]
expl
            in forall {b}.
Eq b =>
(Expectation -> Maybe b)
-> (b -> b -> Bool) -> [Expectation] -> [Expectation]
bestsBy Expectation -> Maybe a
pval a -> a -> Bool
cmpVal forall a b. (a -> b) -> a -> b
$ [Expectation]
exps'
  in Sweets -> Sweets
adj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Sweets]
sweets


-- | Given a Parameter Name and a boolean that indicates valid/not-valid for a
-- Parameter Value, update the expectations in the Sweets to treat the parameter
-- as a ranged value.  This provides the functionality described by the
-- 'rangedParam' function and is intended for use via the 'sweetAdjuster' field
-- of the 'CUBE' structure.

rangedParamAdjuster :: Enum a => Ord a
                    => MonadIO m
                    => String -> (String -> Maybe a) -> (a -> a -> Bool)
                    -> Maybe a
                    -> CUBE -> [Sweets] -> m [Sweets]
rangedParamAdjuster :: forall a (m :: * -> *).
(Enum a, Ord a, MonadIO m) =>
String
-> (String -> Maybe a)
-> (a -> a -> Bool)
-> Maybe a
-> CUBE
-> [Sweets]
-> m [Sweets]
rangedParamAdjuster String
pname String -> Maybe a
extractVal a -> a -> Bool
cmpVal Maybe a
targetVal CUBE
cube =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Enum a, Ord a) =>
String
-> (String -> Maybe a)
-> (a -> a -> Bool)
-> Maybe a
-> CUBE
-> [Sweets]
-> [Sweets]
rangedParam String
pname String -> Maybe a
extractVal a -> a -> Bool
cmpVal Maybe a
targetVal CUBE
cube