-- | Function and implementation to find association files for an
-- identified test root file.

{-# LANGUAGE LambdaCase #-}

module Test.Tasty.Sugar.AssocCheck
  (
    getAssoc
  )
  where

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

import           Test.Tasty.Sugar.ParamCheck
import           Test.Tasty.Sugar.Types


-- | For a specific NamedParamMatch, find all associated files having
-- the rootMatch plus the named parameter values (in the same order
-- but with any combination of separators) and the specified suffix
-- match.
getAssoc :: CandidateFile
         -> Separators
         -> [NamedParamMatch]
         -> [ (String, FileSuffix) ]
         -> [CandidateFile]
         -> Logic [(String, CandidateFile)]
getAssoc :: CandidateFile
-> Separators
-> [NamedParamMatch]
-> [(Separators, Separators)]
-> [CandidateFile]
-> Logic [(Separators, CandidateFile)]
getAssoc CandidateFile
rootPrefix Separators
seps [NamedParamMatch]
pmatch [(Separators, Separators)]
assocNames [CandidateFile]
allNames = Logic [(Separators, CandidateFile)]
assocSet
  where
    assocSet :: Logic [(Separators, CandidateFile)]
assocSet = [[(Separators, CandidateFile)]] -> [(Separators, CandidateFile)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Separators, CandidateFile)]] -> [(Separators, CandidateFile)])
-> LogicT Identity [[(Separators, CandidateFile)]]
-> Logic [(Separators, CandidateFile)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Separators, Separators) -> Logic [(Separators, CandidateFile)])
-> [(Separators, Separators)]
-> LogicT Identity [[(Separators, CandidateFile)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Separators, Separators) -> Logic [(Separators, CandidateFile)]
fndBestAssoc [(Separators, Separators)]
assocNames

    fndBestAssoc :: (String, FileSuffix)
                 -> Logic [(String, CandidateFile)] -- usually just one
    fndBestAssoc :: (Separators, Separators) -> Logic [(Separators, CandidateFile)]
fndBestAssoc (Separators, Separators)
assoc =
      do let candidates :: [(Int, (Separators, CandidateFile))]
candidates = [(Int, (Separators, CandidateFile))]
-> [(Int, (Separators, CandidateFile))]
forall a. Eq a => [a] -> [a]
L.nub ([(Int, (Separators, CandidateFile))]
 -> [(Int, (Separators, CandidateFile))])
-> [(Int, (Separators, CandidateFile))]
-> [(Int, (Separators, CandidateFile))]
forall a b. (a -> b) -> a -> b
$ [Maybe (Int, (Separators, CandidateFile))]
-> [(Int, (Separators, CandidateFile))]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Int, (Separators, CandidateFile))]
 -> [(Int, (Separators, CandidateFile))])
-> [Maybe (Int, (Separators, CandidateFile))]
-> [(Int, (Separators, CandidateFile))]
forall a b. (a -> b) -> a -> b
$
                          Logic (Maybe (Int, (Separators, CandidateFile)))
-> [Maybe (Int, (Separators, CandidateFile))]
forall a. Logic a -> [a]
observeAll ((Separators, Separators)
-> Logic (Maybe (Int, (Separators, CandidateFile)))
fndAnAssoc (Separators, Separators)
assoc)
         let highestRank :: Int
highestRank = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Int, (Separators, CandidateFile)) -> Int
forall a b. (a, b) -> a
fst ((Int, (Separators, CandidateFile)) -> Int)
-> [(Int, (Separators, CandidateFile))] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, (Separators, CandidateFile))]
candidates)
             c :: [(Int, (Separators, CandidateFile))]
c = ((Int, (Separators, CandidateFile)) -> Bool)
-> [(Int, (Separators, CandidateFile))]
-> [(Int, (Separators, CandidateFile))]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
highestRank) (Int -> Bool)
-> ((Int, (Separators, CandidateFile)) -> Int)
-> (Int, (Separators, CandidateFile))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (Separators, CandidateFile)) -> Int
forall a b. (a, b) -> a
fst) [(Int, (Separators, CandidateFile))]
candidates
         if [(Int, (Separators, CandidateFile))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, (Separators, CandidateFile))]
candidates
           then [(Separators, CandidateFile)]
-> Logic [(Separators, CandidateFile)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
           else [(Separators, CandidateFile)]
-> Logic [(Separators, CandidateFile)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, (Separators, CandidateFile)) -> (Separators, CandidateFile)
forall a b. (a, b) -> b
snd ((Int, (Separators, CandidateFile)) -> (Separators, CandidateFile))
-> [(Int, (Separators, CandidateFile))]
-> [(Separators, CandidateFile)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, (Separators, CandidateFile))]
c)

    fndAnAssoc :: (String, FileSuffix)
               -> Logic (Maybe (Int, (String, CandidateFile)))
    fndAnAssoc :: (Separators, Separators)
-> Logic (Maybe (Int, (Separators, CandidateFile)))
fndAnAssoc (Separators, Separators)
assoc = LogicT Identity (Int, (Separators, CandidateFile))
-> ((Int, (Separators, CandidateFile))
    -> Logic (Maybe (Int, (Separators, CandidateFile))))
-> Logic (Maybe (Int, (Separators, CandidateFile)))
-> Logic (Maybe (Int, (Separators, CandidateFile)))
forall (m :: * -> *) a b.
MonadLogic m =>
m a -> (a -> m b) -> m b -> m b
ifte ((Separators, Separators)
-> LogicT Identity (Int, (Separators, CandidateFile))
fndAssoc (Separators, Separators)
assoc)
                       (Maybe (Int, (Separators, CandidateFile))
-> Logic (Maybe (Int, (Separators, CandidateFile)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Int, (Separators, CandidateFile))
 -> Logic (Maybe (Int, (Separators, CandidateFile))))
-> ((Int, (Separators, CandidateFile))
    -> Maybe (Int, (Separators, CandidateFile)))
-> (Int, (Separators, CandidateFile))
-> Logic (Maybe (Int, (Separators, CandidateFile)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (Separators, CandidateFile))
-> Maybe (Int, (Separators, CandidateFile))
forall a. a -> Maybe a
Just)
                       (Maybe (Int, (Separators, CandidateFile))
-> Logic (Maybe (Int, (Separators, CandidateFile)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, (Separators, CandidateFile))
forall a. Maybe a
Nothing)

    fndAssoc :: (String, FileSuffix) -> Logic (Int, (String, CandidateFile))
    fndAssoc :: (Separators, Separators)
-> LogicT Identity (Int, (Separators, CandidateFile))
fndAssoc (Separators, Separators)
assoc =
      do [NamedParamMatch]
pseq <- [NamedParamMatch] -> Logic [NamedParamMatch]
forall a. [a] -> Logic [a]
npseq [NamedParamMatch]
pmatch
         (Int
rank, Separators
assocPfx, Separators
assocSfx) <- Separators -> [ParamMatch] -> Logic (Int, Separators, Separators)
sepParams Separators
seps ((NamedParamMatch -> ParamMatch)
-> [NamedParamMatch] -> [ParamMatch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedParamMatch -> ParamMatch
forall a b. (a, b) -> b
snd [NamedParamMatch]
pseq)
         let possible :: Separators -> Bool
possible =
               if Separators -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Separators
assocSfx
               then let justSep :: Bool
justSep = Separators -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((Separators, Separators) -> Separators
forall a b. (a, b) -> b
snd (Separators, Separators)
assoc) Bool -> Bool -> Bool
&& Separators -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Separators
assocPfx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
                        rootNm :: Separators
rootNm = CandidateFile -> Separators
candidateFile CandidateFile
rootPrefix
                        assocFName :: Separators
assocFName = if Bool
justSep
                                     then Separators
rootNm
                                     else Separators
rootNm Separators -> Separators -> Separators
forall a. Semigroup a => a -> a -> a
<> Separators
assocPfx Separators -> Separators -> Separators
forall a. Semigroup a => a -> a -> a
<> ((Separators, Separators) -> Separators
forall a b. (a, b) -> b
snd (Separators, Separators)
assoc)
                    in (Separators
assocFName Separators -> Separators -> Bool
forall a. Eq a => a -> a -> Bool
==)
               else let assocStart :: Separators
assocStart = CandidateFile -> Separators
candidateFile CandidateFile
rootPrefix Separators -> Separators -> Separators
forall a. Semigroup a => a -> a -> a
<> Separators
assocPfx
                        assocEnd :: Separators
assocEnd = Separators
assocSfx Separators -> Separators -> Separators
forall a. Semigroup a => a -> a -> a
<> (Separators, Separators) -> Separators
forall a b. (a, b) -> b
snd (Separators, Separators)
assoc
                        aSL :: Int
aSL = Separators -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Separators
assocStart
                        aEL :: Int
aEL = Separators -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Separators
assocEnd
                        chk :: Separators -> Bool
chk Separators
f =
                          [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Separators
assocStart Separators -> Separators -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` Separators
f
                              , Separators
assocEnd Separators -> Separators -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` Separators
f
                              , Separators -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Separators
f Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (Int
aSL Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
aEL)
                              , let mid :: Separators
mid = Int -> Separators -> Separators
forall a. Int -> [a] -> [a]
drop Int
aSL (Int -> Separators -> Separators
forall a. Int -> [a] -> [a]
take (Separators -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Separators
f Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
aEL) Separators
f)
                                in [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Separators -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Separators -> Bool) -> Separators -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> Separators -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Separators
mid) Separators
seps
                              ]
                    in Separators -> Bool
chk
         CandidateFile
f <- [CandidateFile] -> Logic CandidateFile
forall a. [a] -> Logic a
eachFrom ([CandidateFile] -> Logic CandidateFile)
-> [CandidateFile] -> Logic CandidateFile
forall a b. (a -> b) -> a -> b
$ (CandidateFile -> Bool) -> [CandidateFile] -> [CandidateFile]
forall a. (a -> Bool) -> [a] -> [a]
filter (Separators -> Bool
possible (Separators -> Bool)
-> (CandidateFile -> Separators) -> CandidateFile -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CandidateFile -> Separators
candidateFile) [CandidateFile]
allNames
         (Int, (Separators, CandidateFile))
-> LogicT Identity (Int, (Separators, CandidateFile))
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
rank, ((Separators, Separators) -> Separators
forall a b. (a, b) -> a
fst (Separators, Separators)
assoc, CandidateFile
f))

    sepParams :: Separators -> [ParamMatch] -> Logic (Int, String, String)
    sepParams :: Separators -> [ParamMatch] -> Logic (Int, Separators, Separators)
sepParams Separators
sl =
      let rank :: (a, b, c) -> a
rank (a
n,b
_,c
_) = a
n
          pfx :: (a, b, c) -> b
pfx (a
_,b
l,c
_) = b
l
      in \case
        [] -> if Separators -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Separators
sl
              then (Int, Separators, Separators)
-> Logic (Int, Separators, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, [], [])
              else do Char
s <- Separators -> Logic Char
forall a. [a] -> Logic a
eachFrom Separators
sl
                      (Int, Separators, Separators)
-> Logic (Int, Separators, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, [Char
s], [])
        (ParamMatch
NotSpecified:[ParamMatch]
ps) -> do (Int, Separators, Separators)
r <- Separators -> [ParamMatch] -> Logic (Int, Separators, Separators)
sepParams Separators
sl [ParamMatch]
ps
                                (Int, Separators, Separators)
-> Logic (Int, Separators, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Separators, Separators) -> Int
forall a b c. (a, b, c) -> a
rank (Int, Separators, Separators)
r, [], (Int, Separators, Separators) -> Separators
forall a b c. (a, b, c) -> b
pfx (Int, Separators, Separators)
r)
        ((Explicit Separators
v):[ParamMatch]
ps) -> do (Int
n,Separators
l,Separators
r) <- Separators -> [ParamMatch] -> Logic (Int, Separators, Separators)
sepParams Separators
sl [ParamMatch]
ps
                                if Separators -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Separators
sl
                                  then (Int, Separators, Separators)
-> Logic (Int, Separators, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Separators
v Separators -> Separators -> Separators
forall a. Semigroup a => a -> a -> a
<> Separators
l, Separators
r)
                                  else do Char
s <- Separators -> Logic Char
forall a. [a] -> Logic a
eachFrom Separators
sl
                                          (Int, Separators, Separators)
-> Logic (Int, Separators, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, [Char
s] Separators -> Separators -> Separators
forall a. Semigroup a => a -> a -> a
<> Separators
v Separators -> Separators -> Separators
forall a. Semigroup a => a -> a -> a
<> Separators
l, Separators
r)
        ((Assumed  Separators
v):[ParamMatch]
ps) -> do (Int
n,Separators
l,Separators
r) <- Separators -> [ParamMatch] -> Logic (Int, Separators, Separators)
sepParams Separators
sl [ParamMatch]
ps
                                if Separators -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Separators
sl
                                  then (Int, Separators, Separators)
-> Logic (Int, Separators, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Separators
v Separators -> Separators -> Separators
forall a. Semigroup a => a -> a -> a
<> Separators
l, Separators
r)
                                  else do Char
s <- Separators -> Logic Char
forall a. [a] -> Logic a
eachFrom Separators
sl
                                          (Int, Separators, Separators)
-> Logic (Int, Separators, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, [Char
s] Separators -> Separators -> Separators
forall a. Semigroup a => a -> a -> a
<> Separators
v Separators -> Separators -> Separators
forall a. Semigroup a => a -> a -> a
<> Separators
l, Separators
r)

    npseq :: [a] -> Logic [a]
npseq = [[a]] -> Logic [a]
forall a. [a] -> Logic a
eachFrom
            ([[a]] -> Logic [a]) -> ([a] -> [[a]]) -> [a] -> Logic [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([][a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:)                -- consider no parameters just once
            ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)  -- excluding multiple blanks in
            ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [[a]]) -> [[a]] -> [[a]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [a] -> [[a]]
forall a. [a] -> [[a]]
L.inits    -- any number of the
            ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
forall a. [a] -> [[a]]
L.permutations       -- parameters in each possible order