-- | 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 :: FilePath
         -> Separators
         -> [NamedParamMatch]
         -> [ (String, FileSuffix) ]
         -> [FilePath]
         -> Logic [(String, FilePath)]
getAssoc :: FilePath
-> FilePath
-> [NamedParamMatch]
-> [(FilePath, FilePath)]
-> [FilePath]
-> Logic [(FilePath, FilePath)]
getAssoc FilePath
rootPrefix FilePath
seps [NamedParamMatch]
pmatch [(FilePath, FilePath)]
assocNames [FilePath]
allNames = Logic [(FilePath, FilePath)]
assocSet
  where
    assocSet :: Logic [(FilePath, FilePath)]
assocSet = [[(FilePath, FilePath)]] -> [(FilePath, FilePath)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(FilePath, FilePath)]] -> [(FilePath, FilePath)])
-> LogicT Identity [[(FilePath, FilePath)]]
-> Logic [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FilePath, FilePath) -> Logic [(FilePath, FilePath)])
-> [(FilePath, FilePath)]
-> LogicT Identity [[(FilePath, FilePath)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath, FilePath) -> Logic [(FilePath, FilePath)]
fndBestAssoc [(FilePath, FilePath)]
assocNames

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

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

    fndAssoc :: (String, FileSuffix) -> Logic (Int, (String, FilePath))
    fndAssoc :: (FilePath, FilePath) -> LogicT Identity (Int, (FilePath, FilePath))
fndAssoc (FilePath, FilePath)
assoc =
      do [NamedParamMatch]
pseq <- [NamedParamMatch] -> Logic [NamedParamMatch]
forall a. [a] -> Logic [a]
npseq [NamedParamMatch]
pmatch
         (Int
rank, FilePath
assocPfx, FilePath
assocSfx) <- FilePath -> [ParamMatch] -> Logic (Int, FilePath, FilePath)
sepParams FilePath
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)
         if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
assocSfx
           then do let assocNm :: FilePath
assocNm = if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd (FilePath, FilePath)
assoc) Bool -> Bool -> Bool
&&
                                    FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
assocPfx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -- just a separator
                                 then FilePath
rootPrefix
                                 else FilePath
rootPrefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
assocPfx FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ((FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd (FilePath, FilePath)
assoc)
                   Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FilePath
assocNm FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
allNames)
                   (Int, (FilePath, FilePath))
-> LogicT Identity (Int, (FilePath, FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
rank, ((FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst (FilePath, FilePath)
assoc, FilePath
assocNm))
           else let assocStart :: FilePath
assocStart = FilePath
rootPrefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
assocPfx
                    assocEnd :: FilePath
assocEnd = FilePath
assocSfx FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd (FilePath, FilePath)
assoc
                    aSL :: Int
aSL = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
assocStart
                    aEL :: Int
aEL = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
assocEnd
                    possible :: FilePath -> Bool
possible FilePath
f =
                      [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ FilePath
assocStart FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` FilePath
f
                          , FilePath
assocEnd FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` FilePath
f
                          , FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
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 :: FilePath
mid = Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
aSL (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
f Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
aEL) FilePath
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) -> FilePath -> [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 -> FilePath -> Bool) -> FilePath -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem FilePath
mid) FilePath
seps
                          ]
                    fnd :: [FilePath]
fnd = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
possible [FilePath]
allNames
                in do FilePath
f <- [FilePath] -> Logic FilePath
forall a. [a] -> Logic a
eachFrom [FilePath]
fnd
                      (Int, (FilePath, FilePath))
-> LogicT Identity (Int, (FilePath, FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
rank, ((FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst (FilePath, FilePath)
assoc, FilePath
f))

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