{-# LANGUAGE LambdaCase #-}

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

module Test.Tasty.Sugar.ParamCheck
  (
    eachFrom
  , getPVals
  , singlePVals
  , pvalMatch
  , removePVals
  , pmatchCmp
  , pmatchMax
  , dirMatches
  , inEachNothing
  , isCompatible
  )
  where

import           Control.Monad
import           Control.Monad.Logic
import           Data.Function ( on )
import qualified Data.List as L
import           Data.Maybe ( catMaybes, fromJust, isNothing, listToMaybe )
import           Data.Bifunctor ( first )
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')

-- | Returns a ParameterPattern admitting only a single value for each parameter,
-- ensuring that the value is compatible with any existing NamedParamMatch.  This
-- is useful for callers wishing to handle each combination of parameter values
-- separately.
singlePVals :: [NamedParamMatch] -> [ParameterPattern]
            -> Logic [ParameterPattern]
singlePVals :: [NamedParamMatch] -> [ParameterPattern] -> Logic [ParameterPattern]
singlePVals [NamedParamMatch]
sel = [ParameterPattern] -> Logic [ParameterPattern]
eachVal ([ParameterPattern] -> Logic [ParameterPattern])
-> ([ParameterPattern] -> [ParameterPattern])
-> [ParameterPattern]
-> Logic [ParameterPattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParameterPattern] -> [ParameterPattern]
forall a. Ord a => [a] -> [a]
L.sort
  where eachVal :: [ParameterPattern] -> Logic [ParameterPattern]
eachVal [] = [ParameterPattern] -> Logic [ParameterPattern]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        eachVal ((String
pn,Maybe [String]
Nothing):[ParameterPattern]
ps) =
          let this :: ParameterPattern
this = (String
pn, (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) (String -> [String]) -> Maybe String -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> [NamedParamMatch] -> Maybe ParamMatch
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pn [NamedParamMatch]
sel Maybe ParamMatch -> (ParamMatch -> Maybe String) -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParamMatch -> Maybe String
getParamVal))
           in (ParameterPattern
this ParameterPattern -> [ParameterPattern] -> [ParameterPattern]
forall a. a -> [a] -> [a]
:) ([ParameterPattern] -> [ParameterPattern])
-> Logic [ParameterPattern] -> Logic [ParameterPattern]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParameterPattern] -> Logic [ParameterPattern]
eachVal [ParameterPattern]
ps
        eachVal ((String
pn,Just [String]
pvs):[ParameterPattern]
ps) =
          do String
pv <- [String] -> Logic String
forall a. [a] -> Logic a
eachFrom ([String] -> Logic String) -> [String] -> Logic String
forall a b. (a -> b) -> a -> b
$ case String -> [NamedParamMatch] -> Maybe ParamMatch
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pn [NamedParamMatch]
sel Maybe ParamMatch -> (ParamMatch -> Maybe String) -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParamMatch -> Maybe String
getParamVal of
                                Maybe String
Nothing -> [String] -> [String]
forall a. Ord a => [a] -> [a]
L.sort [String]
pvs
                                Just String
v -> [String
v]
             ((String
pn, [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String
pv]) ParameterPattern -> [ParameterPattern] -> [ParameterPattern]
forall a. a -> [a] -> [a]
:) ([ParameterPattern] -> [ParameterPattern])
-> Logic [ParameterPattern] -> Logic [ParameterPattern]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParameterPattern] -> Logic [ParameterPattern]
eachVal [ParameterPattern]
ps


-- | 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

      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 -> LogicT Identity ()) -> Bool -> LogicT Identity ()
forall a b. (a -> b) -> a -> b
$ Bool
matchesPreset
        [NamedParamMatch]
candidateVals <- [NamedParamMatch]
-> [(String, Maybe String)] -> Logic [NamedParamMatch]
pvVals [NamedParamMatch]
preset [(String, Maybe String)]
pvals
        let rset :: [NamedParamMatch]
rset = [NamedParamMatch]
preset [NamedParamMatch] -> [NamedParamMatch] -> [NamedParamMatch]
forall a. Semigroup a => a -> a -> a
<> [NamedParamMatch] -> [NamedParamMatch] -> [NamedParamMatch]
forall a b. [(String, a)] -> [(String, b)] -> [(String, a)]
removePVals [NamedParamMatch]
candidateVals [NamedParamMatch]
preset
            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 v :: ParamMatch
v = ParamMatch
-> (ParamMatch -> ParamMatch) -> Maybe ParamMatch -> ParamMatch
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ParamMatch
NotSpecified ParamMatch -> ParamMatch
forall a. a -> a
id (Maybe ParamMatch -> ParamMatch) -> Maybe ParamMatch -> ParamMatch
forall a b. (a -> b) -> a -> b
$ 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)


-- | Generate the various combinations of parameters+values from the possible
-- set specified by the input.

pvVals :: [NamedParamMatch] -> [(String, Maybe String)] -> Logic [NamedParamMatch]
pvVals :: [NamedParamMatch]
-> [(String, Maybe String)] -> Logic [NamedParamMatch]
pvVals [NamedParamMatch]
_ [] = [NamedParamMatch] -> Logic [NamedParamMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return []
pvVals [NamedParamMatch]
presets ((String
pn, Maybe String
mpv):[(String, Maybe String)]
ps) =
  do [NamedParamMatch]
nxt <- [NamedParamMatch]
-> [(String, Maybe String)] -> Logic [NamedParamMatch]
pvVals [NamedParamMatch]
presets [(String, Maybe String)]
ps
     let explicit :: String -> m [NamedParamMatch]
explicit String
v = [NamedParamMatch] -> m [NamedParamMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedParamMatch] -> m [NamedParamMatch])
-> [NamedParamMatch] -> m [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 =
                             case String -> [NamedParamMatch] -> Maybe ParamMatch
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pn [NamedParamMatch]
presets of
                               Maybe ParamMatch
Nothing -> ParamMatch -> (String -> ParamMatch) -> Maybe String -> ParamMatch
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ParamMatch
NotSpecified String -> ParamMatch
Assumed
                               Just ParamMatch
presetV -> ParamMatch -> Maybe String -> ParamMatch
forall a b. a -> b -> a
const ParamMatch
presetV
                       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]
nxt
     (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]
forall (m :: * -> *). Monad m => String -> m [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


-- | Removes the second set of named params from the first set, leaving the
-- remainder of the first set that isn't matched in the second set.

removePVals :: [(String, a)] -> [(String, b)] -> [(String, a)]
removePVals :: [(String, a)] -> [(String, b)] -> [(String, a)]
removePVals [(String, a)]
main [(String, b)]
rmv = ((String, a) -> Bool) -> [(String, a)] -> [(String, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((String, a) -> Bool) -> (String, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((String, b) -> String
forall a b. (a, b) -> a
fst ((String, b) -> String) -> [(String, b)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, b)]
rmv)) (String -> Bool) -> ((String, a) -> String) -> (String, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, a) -> String
forall a b. (a, b) -> a
fst) [(String, a)]
main


-- | 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 (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 (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]
L.sort ([String] -> [String])
-> ([NamedParamMatch] -> [String]) -> [NamedParamMatch] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)
        ]
        -- 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 :: [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 :: (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


-- | Given the root directory and a file in that directory, along with the
-- possible parameters and values, return each valid set of parameter matches
-- from that file, along with the remaining unmatched parameter possibilities.
--
-- The first set of parameters is the total set, and the second set represents
-- those that could be identified in the path subdirs; this is needed to prevent
-- a wildcard ParameterPattern in the second set from matching values explicit to
-- other parameters.

dirMatches :: CandidateFile -> [ParameterPattern] -> [ParameterPattern]
           -> Logic ([NamedParamMatch], [ParameterPattern])
dirMatches :: CandidateFile
-> [ParameterPattern]
-> [ParameterPattern]
-> Logic ([NamedParamMatch], [ParameterPattern])
dirMatches CandidateFile
fname [ParameterPattern]
fullParams [ParameterPattern]
params = do
  let pathPart :: [String]
pathPart = CandidateFile -> [String]
candidateSubdirs CandidateFile
fname

  let findVMatch :: FilePath -> (String, Maybe [String]) -> Maybe String
      findVMatch :: String -> ParameterPattern -> Maybe String
findVMatch String
e (String
pn,Maybe [String]
pv) =
        case Maybe [String]
pv of
          Maybe [String]
Nothing -> Maybe String
forall a. Maybe a
Nothing
          Just [String]
vs -> if String
e String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
vs then String -> Maybe String
forall a. a -> Maybe a
Just String
pn else Maybe String
forall a. Maybe a
Nothing
  let findPVMatch :: [ParameterPattern] -> String -> [Maybe String] -> [Maybe String]
findPVMatch [ParameterPattern]
parms String
pthPartE [Maybe String]
found =
        [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ((ParameterPattern -> Maybe String)
-> [ParameterPattern] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ParameterPattern -> Maybe String
findVMatch String
pthPartE) [ParameterPattern]
parms)) Maybe String -> [Maybe String] -> [Maybe String]
forall a. a -> [a] -> [a]
: [Maybe String]
found

  let pmatches :: [Maybe String]
pmatches = (String -> [Maybe String] -> [Maybe String])
-> [Maybe String] -> [String] -> [Maybe String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([ParameterPattern] -> String -> [Maybe String] -> [Maybe String]
findPVMatch [ParameterPattern]
params) [] [String]
pathPart

  let freeParam :: Maybe String
freeParam = ParameterPattern -> String
forall a b. (a, b) -> a
fst (ParameterPattern -> String)
-> Maybe ParameterPattern -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParameterPattern -> Bool)
-> [ParameterPattern] -> Maybe ParameterPattern
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Maybe [String] -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe [String] -> Bool)
-> (ParameterPattern -> Maybe [String]) -> ParameterPattern -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParameterPattern -> Maybe [String]
forall a b. (a, b) -> b
snd) [ParameterPattern]
params

  let freeParts :: [Bool]
freeParts =
        let allpvals :: [String]
allpvals = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ [Maybe [String]] -> [[String]]
forall a. [Maybe a] -> [a]
catMaybes (ParameterPattern -> Maybe [String]
forall a b. (a, b) -> b
snd (ParameterPattern -> Maybe [String])
-> [ParameterPattern] -> [Maybe [String]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParameterPattern]
fullParams)
        in (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
allpvals)) (String -> Bool) -> [String] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
pathPart

  [NamedParamMatch]
dmatch <- ((String, String) -> NamedParamMatch)
-> [(String, String)] -> [NamedParamMatch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> ParamMatch) -> (String, String) -> NamedParamMatch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> ParamMatch
Explicit)
            ([(String, String)] -> [NamedParamMatch])
-> ([(Maybe String, String)] -> [(String, String)])
-> [(Maybe String, String)]
-> [NamedParamMatch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe String, String) -> (String, String))
-> [(Maybe String, String)] -> [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe String -> String)
-> (Maybe String, String) -> (String, String)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust)
            ([(Maybe String, String)] -> [(String, String)])
-> ([(Maybe String, String)] -> [(Maybe String, String)])
-> [(Maybe String, String)]
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe String, String) -> Bool)
-> [(Maybe String, String)] -> [(Maybe String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Maybe String, String) -> Bool)
-> (Maybe String, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe String -> Bool)
-> ((Maybe String, String) -> Maybe String)
-> (Maybe String, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String, String) -> Maybe String
forall a b. (a, b) -> a
fst)
            ([(Maybe String, String)] -> [NamedParamMatch])
-> LogicT Identity [(Maybe String, String)]
-> Logic [NamedParamMatch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([(Maybe String, String)]
-> LogicT Identity [(Maybe String, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe String] -> [String] -> [(Maybe String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe String]
pmatches [String]
pathPart))
                 LogicT Identity [(Maybe String, String)]
-> LogicT Identity [(Maybe String, String)]
-> LogicT Identity [(Maybe String, String)]
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                 (Maybe String
-> [(Maybe String, Bool, String)]
-> LogicT Identity [(Maybe String, String)]
forall a b. Maybe a -> [(Maybe a, Bool, b)] -> Logic [(Maybe a, b)]
inEachNothing Maybe String
freeParam ([(Maybe String, Bool, String)]
 -> LogicT Identity [(Maybe String, String)])
-> [(Maybe String, Bool, String)]
-> LogicT Identity [(Maybe String, String)]
forall a b. (a -> b) -> a -> b
$ [Maybe String]
-> [Bool] -> [String] -> [(Maybe String, Bool, String)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Maybe String]
pmatches [Bool]
freeParts [String]
pathPart))

  let drem :: [ParameterPattern]
drem = [ParameterPattern] -> [NamedParamMatch] -> [ParameterPattern]
forall a b. [(String, a)] -> [(String, b)] -> [(String, a)]
removePVals [ParameterPattern]
params [NamedParamMatch]
dmatch

  ([NamedParamMatch], [ParameterPattern])
-> Logic ([NamedParamMatch], [ParameterPattern])
forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedParamMatch]
dmatch, [ParameterPattern]
drem)


-- | Return each substitution of the first argument for each location in the
-- second list that has a Nothing label and a True parameter; leave non-Nothings
-- in the second list unchanged.

inEachNothing :: Maybe a -> [(Maybe a,Bool,b)] -> Logic [(Maybe a,b)]
inEachNothing :: Maybe a -> [(Maybe a, Bool, b)] -> Logic [(Maybe a, b)]
inEachNothing Maybe a
mark [(Maybe a, Bool, b)]
into = do
  let canSubst :: (Maybe a, Bool, c) -> Bool
canSubst (Maybe a
a,Bool
b,c
_) = Bool
b Bool -> Bool -> Bool
&& Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
a
  let spots :: [Int]
spots = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Int
i -> (Maybe a, Bool, b) -> Bool
forall a c. (Maybe a, Bool, c) -> Bool
canSubst ([(Maybe a, Bool, b)]
into [(Maybe a, Bool, b)] -> Int -> (Maybe a, Bool, b)
forall a. [a] -> Int -> a
!! Int
i)) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int
0..([(Maybe a, Bool, b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe a, Bool, b)]
into) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  Int
i <- [Int] -> Logic Int
forall a. [a] -> Logic a
eachFrom [Int]
spots
  let deBool :: (a, b, b) -> (a, b)
deBool (a
a,b
_,b
c) = (a
a,b
c)
  let thrd :: (a, b, c) -> c
thrd (a
_,b
_,c
c) = c
c
  [(Maybe a, b)] -> Logic [(Maybe a, b)]
forall (m :: * -> *) a. Monad m => a -> m a
return
    ([(Maybe a, b)] -> Logic [(Maybe a, b)])
-> [(Maybe a, b)] -> Logic [(Maybe a, b)]
forall a b. (a -> b) -> a -> b
$ ((Maybe a, Bool, b) -> (Maybe a, b)
forall a b b. (a, b, b) -> (a, b)
deBool ((Maybe a, Bool, b) -> (Maybe a, b))
-> [(Maybe a, Bool, b)] -> [(Maybe a, b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [(Maybe a, Bool, b)] -> [(Maybe a, Bool, b)]
forall a. Int -> [a] -> [a]
take Int
i [(Maybe a, Bool, b)]
into)
    [(Maybe a, b)] -> [(Maybe a, b)] -> [(Maybe a, b)]
forall a. Semigroup a => a -> a -> a
<> [ (Maybe a
mark, (Maybe a, Bool, b) -> b
forall a b c. (a, b, c) -> c
thrd ([(Maybe a, Bool, b)]
into [(Maybe a, Bool, b)] -> Int -> (Maybe a, Bool, b)
forall a. [a] -> Int -> a
!! Int
i)) ]
    [(Maybe a, b)] -> [(Maybe a, b)] -> [(Maybe a, b)]
forall a. Semigroup a => a -> a -> a
<> ((Maybe a, Bool, b) -> (Maybe a, b)
forall a b b. (a, b, b) -> (a, b)
deBool ((Maybe a, Bool, b) -> (Maybe a, b))
-> [(Maybe a, Bool, b)] -> [(Maybe a, b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [(Maybe a, Bool, b)] -> [(Maybe a, Bool, b)]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Maybe a, Bool, b)]
into)


-- | 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 :: Separators
             -> [ParameterPattern]
             -> [(String, Maybe String)]
             -> CandidateFile
             -> Bool
isCompatible :: String
-> [ParameterPattern]
-> [(String, Maybe String)]
-> CandidateFile
-> Bool
isCompatible String
seps [ParameterPattern]
params [(String, Maybe String)]
pvals CandidateFile
fname =
  let splitFName :: String -> [String]
splitFName String
n = let (String
p,String
r) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
seps) String
n
                     in String
p String -> [String] -> [String]
forall a. a -> [a] -> [a]
: if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
r then [] else String -> [String]
splitFName (String -> String
forall a. [a] -> [a]
tail String
r)
      parts :: [String]
parts = let n' :: [String]
n' = String -> [String]
splitFName (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ CandidateFile -> String
candidateFile CandidateFile
fname
              in CandidateFile -> [String]
candidateSubdirs CandidateFile
fname [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
n'
      noConflict :: t String -> (String, Maybe (t String)) -> Bool
noConflict t String
_ (String
_,Maybe (t String)
Nothing) = Bool
True
      noConflict t String
ps (String
pn,Just t String
vs) = (String -> Bool) -> t String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> t String -> String -> Bool
forall (t :: * -> *).
Foldable t =>
String -> t String -> String -> Bool
isConflict String
pn t String
vs) t String
ps
      isConflict :: String -> t String -> String -> Bool
isConflict String
pn t String
vs String
p = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ String
p String -> t String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t String
vs
                               , Bool -> (Maybe String -> Bool) -> Maybe (Maybe String) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (String -> Maybe String
forall a. a -> Maybe a
Just String
p Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/=) (Maybe (Maybe String) -> Bool) -> Maybe (Maybe String) -> Bool
forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe String)] -> Maybe (Maybe String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pn [(String, Maybe String)]
pvals
                               ]
  in (ParameterPattern -> Bool) -> [ParameterPattern] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([String] -> ParameterPattern -> Bool
forall (t :: * -> *) (t :: * -> *).
(Foldable t, Foldable t) =>
t String -> (String, Maybe (t String)) -> Bool
noConflict [String]
parts) [ParameterPattern]
params