-- | Function and associated helpers to determine the matching root
-- name.  The root name may contain zero or more parameter values.

{-# LANGUAGE LambdaCase #-}

module Test.Tasty.Sugar.RootCheck
  (
    rootMatch
  )
  where

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

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


-- | Determine which parts of the input name form the basePrefix and any
-- parameter values for searching for related files (expected and
-- associated)
rootMatch :: FilePath -> Separators -> [ParameterPattern] -> String
          -> Logic ([NamedParamMatch], FilePath, FilePath)
rootMatch :: FilePath
-> FilePath
-> [ParameterPattern]
-> FilePath
-> Logic ([NamedParamMatch], FilePath, FilePath)
rootMatch FilePath
origRootName FilePath
seps [ParameterPattern]
params FilePath
rootCmp =
  Logic ([NamedParamMatch], FilePath, FilePath)
-> (([NamedParamMatch], FilePath, FilePath)
    -> Logic ([NamedParamMatch], FilePath, FilePath))
-> Logic ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a b.
MonadLogic m =>
m a -> (a -> m b) -> m b -> m b
ifte
  (FilePath
-> FilePath
-> [ParameterPattern]
-> FilePath
-> Logic ([NamedParamMatch], FilePath, FilePath)
rootParamMatch FilePath
origRootName FilePath
seps [ParameterPattern]
params FilePath
rootCmp)
  ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return
  (FilePath
-> FilePath -> Logic ([NamedParamMatch], FilePath, FilePath)
noRootParamMatch FilePath
origRootName FilePath
seps)


data RootPart = RootSep String
              | RootParNm String String
              | RootText String
              | RootSuffix String
              deriving Int -> RootPart -> ShowS
[RootPart] -> ShowS
RootPart -> FilePath
(Int -> RootPart -> ShowS)
-> (RootPart -> FilePath) -> ([RootPart] -> ShowS) -> Show RootPart
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RootPart] -> ShowS
$cshowList :: [RootPart] -> ShowS
show :: RootPart -> FilePath
$cshow :: RootPart -> FilePath
showsPrec :: Int -> RootPart -> ShowS
$cshowsPrec :: Int -> RootPart -> ShowS
Show

isRootParNm :: RootPart -> Bool
isRootParNm :: RootPart -> Bool
isRootParNm (RootParNm FilePath
_ FilePath
_) = Bool
True
isRootParNm RootPart
_ = Bool
False

isRootSep :: RootPart -> Bool
isRootSep :: RootPart -> Bool
isRootSep (RootSep FilePath
_) = Bool
True
isRootSep RootPart
_ = Bool
False

isRootSuffix :: RootPart -> Bool
isRootSuffix :: RootPart -> Bool
isRootSuffix (RootSuffix FilePath
_) = Bool
True
isRootSuffix RootPart
_ = Bool
False

rpStr :: [RootPart] -> String
rpStr :: [RootPart] -> FilePath
rpStr = let s :: RootPart -> FilePath
s = \case
              RootSep FilePath
x -> FilePath
x
              RootParNm FilePath
_ FilePath
x -> FilePath
x
              RootText FilePath
x -> FilePath
x
              RootSuffix FilePath
x -> FilePath
x
            bld :: FilePath -> RootPart -> FilePath
bld FilePath
a RootPart
b = FilePath
a FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> RootPart -> FilePath
s RootPart
b
        in (FilePath -> RootPart -> FilePath)
-> FilePath -> [RootPart] -> FilePath
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl FilePath -> RootPart -> FilePath
bld FilePath
""

rpNPM :: [RootPart] -> [NamedParamMatch]
rpNPM :: [RootPart] -> [NamedParamMatch]
rpNPM = let bld :: RootPart -> Maybe [NamedParamMatch]
bld (RootParNm FilePath
n FilePath
v) = [NamedParamMatch] -> Maybe [NamedParamMatch]
forall a. a -> Maybe a
Just [(FilePath
n, FilePath -> ParamMatch
Explicit FilePath
v)]
            bld (RootSep FilePath
_) = Maybe [NamedParamMatch]
forall a. Maybe a
Nothing
            bld RootPart
p = FilePath -> Maybe [NamedParamMatch]
forall a. HasCallStack => FilePath -> a
error (FilePath
"Invalid RootPart for NamedParamMatch: "
                           FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> RootPart -> FilePath
forall a. Show a => a -> FilePath
show RootPart
p)
        in [[NamedParamMatch]] -> [NamedParamMatch]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[NamedParamMatch]] -> [NamedParamMatch])
-> ([RootPart] -> [[NamedParamMatch]])
-> [RootPart]
-> [NamedParamMatch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [NamedParamMatch]] -> [[NamedParamMatch]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [NamedParamMatch]] -> [[NamedParamMatch]])
-> ([RootPart] -> [Maybe [NamedParamMatch]])
-> [RootPart]
-> [[NamedParamMatch]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RootPart -> Maybe [NamedParamMatch])
-> [RootPart] -> [Maybe [NamedParamMatch]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RootPart -> Maybe [NamedParamMatch]
bld


-- Return the prefix and suffix of the root name along with the
-- explicit parameter matches that comprise the central portion.
rootParamMatch :: FilePath -> Separators -> [ParameterPattern] -> String
               -> Logic ([NamedParamMatch], FilePath, FilePath)
rootParamMatch :: FilePath
-> FilePath
-> [ParameterPattern]
-> FilePath
-> Logic ([NamedParamMatch], FilePath, FilePath)
rootParamMatch FilePath
origRootName FilePath
seps [ParameterPattern]
params FilePath
rootCmp =
  if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
seps
  then FilePath
-> FilePath
-> [ParameterPattern]
-> Logic ([NamedParamMatch], FilePath, FilePath)
rootParamMatchNoSeps FilePath
origRootName FilePath
seps [ParameterPattern]
params
  else FilePath
-> FilePath
-> [ParameterPattern]
-> FilePath
-> Logic ([NamedParamMatch], FilePath, FilePath)
rootParamMatches FilePath
origRootName FilePath
seps [ParameterPattern]
params FilePath
rootCmp

rootParamMatches :: FilePath -> Separators -> [ParameterPattern] -> String
                 -> Logic ([NamedParamMatch], FilePath, FilePath)
rootParamMatches :: FilePath
-> FilePath
-> [ParameterPattern]
-> FilePath
-> Logic ([NamedParamMatch], FilePath, FilePath)
rootParamMatches FilePath
rootNm FilePath
seps [ParameterPattern]
parms FilePath
rMatch = do
  let rnSplit :: [FilePath]
rnSplit = FilePath -> [FilePath]
sepSplit FilePath
rootNm
      sepSplit :: FilePath -> [FilePath]
sepSplit = (Char -> Char -> Bool) -> FilePath -> [FilePath]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy Char -> Char -> Bool
sepPoint
      sepPoint :: Char -> Char -> Bool
sepPoint Char
a Char
b = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Char
a Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
seps, Char
b Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
seps ]
      rnPartIndices :: [Int]
rnPartIndices = [ Int
n | Int
n <- [Int
0 .. [RootPart] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RootPart]
rnParts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] , Int -> Bool
forall a. Integral a => a -> Bool
even Int
n ]
      freeValueParm :: Maybe ParameterPattern
freeValueParm = (ParameterPattern -> Bool)
-> [ParameterPattern] -> Maybe ParameterPattern
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Maybe [FilePath] -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe [FilePath] -> Bool)
-> (ParameterPattern -> Maybe [FilePath])
-> ParameterPattern
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParameterPattern -> Maybe [FilePath]
forall a b. (a, b) -> b
snd) [ParameterPattern]
parms

      txtRootSfx :: [FilePath]
txtRootSfx = FilePath -> [FilePath]
sepSplit (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
                   -- Find the concrete extension in the
                   -- rootName. Somewhat crude, but basically stops at
                   -- any charcter that could be part of a filemanip
                   -- GlobPattern.
                   (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (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
"[*]\\(|)") ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse FilePath
rMatch

      -- if a part of the rootNm matches a known parameter value,
      -- that is the only way that part can be interpreted, and
      -- that anchors it.

      rnParts :: [RootPart]
      rnParts :: [RootPart]
rnParts =
        let assignPart :: (FilePath, Int) -> RootPart
assignPart (FilePath
ptxt,Int
pidx) =
              let matchesParmValue :: (a, Maybe (t FilePath)) -> Bool
matchesParmValue (a
_, Maybe (t FilePath)
Nothing) = Bool
False
                  matchesParmValue (a
_, Just t FilePath
vl) = FilePath
ptxt FilePath -> t FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t FilePath
vl
              in if Int
pidx Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
rnPartIndices
                 then
                   if [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
rnSplit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pidx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
txtRootSfx
                   then FilePath -> RootPart
RootSuffix FilePath
ptxt
                   else case (ParameterPattern -> Bool)
-> [ParameterPattern] -> Maybe ParameterPattern
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ParameterPattern -> Bool
forall (t :: * -> *) a.
Foldable t =>
(a, Maybe (t FilePath)) -> Bool
matchesParmValue [ParameterPattern]
parms of
                          Just (FilePath
pn,Maybe [FilePath]
_) -> FilePath -> FilePath -> RootPart
RootParNm FilePath
pn FilePath
ptxt
                          Maybe ParameterPattern
Nothing -> FilePath -> RootPart
RootText FilePath
ptxt
                 else FilePath -> RootPart
RootSep FilePath
ptxt

        in ((FilePath, Int) -> RootPart) -> [(FilePath, Int)] -> [RootPart]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath, Int) -> RootPart
assignPart ([(FilePath, Int)] -> [RootPart])
-> [(FilePath, Int)] -> [RootPart]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [Int] -> [(FilePath, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
rnSplit [Int
0..]

  -- want [prefix, sep, MATCHES, [suffix]]
  Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
rnSplit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
txtRootSfx)

  Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RootPart -> Bool
isRootParNm (RootPart -> Bool) -> RootPart -> Bool
forall a b. (a -> b) -> a -> b
$ [RootPart] -> RootPart
forall a. [a] -> a
head [RootPart]
rnParts) -- must have a prefix

  let rnChunks :: Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
rnChunks =
        --  pfx parms1 mid parms2 sfx
        --      r1-------------------
        --             r2------------
        --                 r3--------
        let ([RootPart]
pfx,[RootPart]
r1)     = (RootPart -> Bool) -> [RootPart] -> ([RootPart], [RootPart])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.span (Bool -> Bool
not (Bool -> Bool) -> (RootPart -> Bool) -> RootPart -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RootPart -> Bool
isRootParNm) [RootPart]
rnParts
            ([RootPart]
parms1,[RootPart]
r2)  = (RootPart -> Bool) -> [RootPart] -> ([RootPart], [RootPart])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.span RootPart -> Bool
paramPart [RootPart]
r1
            ([RootPart]
mid,[RootPart]
r3)     = (RootPart -> Bool) -> [RootPart] -> ([RootPart], [RootPart])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.span (Bool -> Bool
not (Bool -> Bool) -> (RootPart -> Bool) -> RootPart -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RootPart -> Bool
isRootParNm) [RootPart]
r2
            ([RootPart]
parms2,[RootPart]
sfx) = (RootPart -> Bool) -> [RootPart] -> ([RootPart], [RootPart])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.span RootPart -> Bool
paramPart [RootPart]
r3
            ([RootPart]
_,[RootPart]
extraprm) = (RootPart -> Bool) -> [RootPart] -> ([RootPart], [RootPart])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.span (Bool -> Bool
not (Bool -> Bool) -> (RootPart -> Bool) -> RootPart -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RootPart -> Bool
isRootParNm) [RootPart]
sfx
            paramPart :: RootPart -> Bool
paramPart RootPart
x = RootPart -> Bool
isRootParNm RootPart
x Bool -> Bool -> Bool
|| RootPart -> Bool
isRootSep RootPart
x
        in if [RootPart] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RootPart]
r3
           then Either
  ([RootPart], [RootPart], [RootPart])
  ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart])
-> Maybe
     (Either
        ([RootPart], [RootPart], [RootPart])
        ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
forall a. a -> Maybe a
Just (Either
   ([RootPart], [RootPart], [RootPart])
   ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart])
 -> Maybe
      (Either
         ([RootPart], [RootPart], [RootPart])
         ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart])))
-> Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart])
-> Maybe
     (Either
        ([RootPart], [RootPart], [RootPart])
        ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
forall a b. (a -> b) -> a -> b
$ ([RootPart], [RootPart], [RootPart])
-> Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart])
forall a b. a -> Either a b
Left ([RootPart]
pfx, [RootPart]
parms1, [RootPart]
mid)
           else if [RootPart] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RootPart]
extraprm
                then Either
  ([RootPart], [RootPart], [RootPart])
  ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart])
-> Maybe
     (Either
        ([RootPart], [RootPart], [RootPart])
        ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
forall a. a -> Maybe a
Just (Either
   ([RootPart], [RootPart], [RootPart])
   ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart])
 -> Maybe
      (Either
         ([RootPart], [RootPart], [RootPart])
         ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart])))
-> Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart])
-> Maybe
     (Either
        ([RootPart], [RootPart], [RootPart])
        ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
forall a b. (a -> b) -> a -> b
$ ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart])
-> Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart])
forall a b. b -> Either a b
Right ([RootPart]
pfx, [RootPart]
parms1, [RootPart]
mid, [RootPart]
parms2, [RootPart]
sfx)
                else Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
forall a. Maybe a
Nothing

      freeFirst :: Maybe (Either ([RootPart], [RootPart], [RootPart]) b)
-> Logic ([NamedParamMatch], FilePath, FilePath)
freeFirst Maybe (Either ([RootPart], [RootPart], [RootPart]) b)
Nothing = Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      freeFirst (Just (Right b
_)) = Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      freeFirst (Just (Left ([RootPart]
allRP, [], []))) =
        -- There were no parameter value matches.  If there is
        -- a wildcard parameter, try it in all the possible
        -- positions.
        if [RootPart] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RootPart]
allRP Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3
        then Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        else case Maybe ParameterPattern
freeValueParm of
               Maybe ParameterPattern
Nothing -> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
               Just ParameterPattern
p ->
                 do Int
idx <- [Int] -> Logic Int
forall a. [a] -> Logic a
eachFrom [Int
i | Int
i <- [Int
2..[RootPart] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RootPart]
allRP], Int -> Bool
forall a. Integral a => a -> Bool
even Int
i]
                    let free :: RootPart
free = FilePath -> FilePath -> RootPart
RootParNm (ParameterPattern -> FilePath
forall a b. (a, b) -> a
fst ParameterPattern
p) FilePath
idxv
                        RootText FilePath
idxv = [RootPart] -> RootPart
forall a. [a] -> a
head ([RootPart] -> RootPart) -> [RootPart] -> RootPart
forall a b. (a -> b) -> a -> b
$ Int -> [RootPart] -> [RootPart]
forall a. Int -> [a] -> [a]
drop Int
idx [RootPart]
allRP
                        start :: [RootPart]
start = Int -> [RootPart] -> [RootPart]
forall a. Int -> [a] -> [a]
take (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [RootPart]
allRP
                    Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RootPart -> Bool
isRootSuffix (RootPart -> Bool) -> RootPart -> Bool
forall a b. (a -> b) -> a -> b
$ [RootPart] -> RootPart
forall a. [a] -> a
head ([RootPart] -> RootPart) -> [RootPart] -> RootPart
forall a b. (a -> b) -> a -> b
$ Int -> [RootPart] -> [RootPart]
forall a. Int -> [a] -> [a]
drop Int
idx [RootPart]
allRP)
                    ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [RootPart] -> [NamedParamMatch]
rpNPM [RootPart
free]
                           , [RootPart] -> FilePath
rpStr ([RootPart] -> FilePath) -> [RootPart] -> FilePath
forall a b. (a -> b) -> a -> b
$ [RootPart]
start
                           , [RootPart] -> FilePath
rpStr ([RootPart] -> FilePath) -> [RootPart] -> FilePath
forall a b. (a -> b) -> a -> b
$ Int -> [RootPart] -> [RootPart]
forall a. Int -> [a] -> [a]
drop (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) [RootPart]
allRP )
      freeFirst (Just (Left ([RootPart]
pfx, [RootPart]
pl1, [RootPart]
sfx))) =
        if [RootPart] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RootPart]
pfx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3
        then Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        else case Maybe ParameterPattern
freeValueParm of
               Maybe ParameterPattern
Nothing ->
                 -- No wildcard param, so just try the observed
                 -- pattern
                 ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [RootPart] -> [NamedParamMatch]
rpNPM [RootPart]
pl1, [RootPart] -> FilePath
rpStr [RootPart]
pfx, [RootPart] -> FilePath
rpStr [RootPart]
sfx )
               Just ParameterPattern
p ->
                 -- There is a wildcard parameter, try it at the end
                 -- of pfx and before pl1
                 let free :: RootPart
free = FilePath -> FilePath -> RootPart
RootParNm (ParameterPattern -> FilePath
forall a b. (a, b) -> a
fst ParameterPattern
p) FilePath
lpv
                     RootText FilePath
lpv = [RootPart] -> RootPart
forall a. [a] -> a
last [RootPart]
start
                     start :: [RootPart]
start = [RootPart] -> [RootPart]
forall a. [a] -> [a]
init [RootPart]
pfx
                 in do Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> (RootPart -> Bool) -> RootPart -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RootPart -> Bool
isRootSuffix (RootPart -> Bool) -> RootPart -> Bool
forall a b. (a -> b) -> a -> b
$ [RootPart] -> RootPart
forall a. [a] -> a
last [RootPart]
start)
                       ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [RootPart] -> [NamedParamMatch]
rpNPM ([RootPart] -> [NamedParamMatch])
-> [RootPart] -> [NamedParamMatch]
forall a b. (a -> b) -> a -> b
$ RootPart
free RootPart -> [RootPart] -> [RootPart]
forall a. a -> [a] -> [a]
: [RootPart]
pl1
                              , [RootPart] -> FilePath
rpStr ([RootPart] -> FilePath) -> [RootPart] -> FilePath
forall a b. (a -> b) -> a -> b
$ [RootPart] -> [RootPart]
forall a. [a] -> [a]
reverse ([RootPart] -> [RootPart]) -> [RootPart] -> [RootPart]
forall a b. (a -> b) -> a -> b
$ Int -> [RootPart] -> [RootPart]
forall a. Int -> [a] -> [a]
drop Int
3 ([RootPart] -> [RootPart]) -> [RootPart] -> [RootPart]
forall a b. (a -> b) -> a -> b
$ [RootPart] -> [RootPart]
forall a. [a] -> [a]
reverse [RootPart]
pfx
                              , [RootPart] -> FilePath
rpStr [RootPart]
sfx )

      freeLast :: Maybe (Either ([RootPart], [RootPart], [RootPart]) b)
-> m ([NamedParamMatch], FilePath, FilePath)
freeLast Maybe (Either ([RootPart], [RootPart], [RootPart]) b)
Nothing = m ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      freeLast (Just (Right b
_)) = m ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      freeLast (Just (Left ([RootPart]
_, [], []))) = m ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero -- handled by freeFirst
      freeLast (Just (Left ([RootPart]
pfx, [RootPart]
parms1, [RootPart]
sfx))) =
        if [RootPart] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RootPart]
sfx
        then m ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        else case Maybe ParameterPattern
freeValueParm of
               Maybe ParameterPattern
Nothing -> m ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero  -- handled by freeFirst
               Just ParameterPattern
p ->
                 -- There is a wildcard parameter, try it at the end
                 -- of pfx and before pl1
                 let free :: [RootPart]
free = [FilePath -> FilePath -> RootPart
RootParNm (ParameterPattern -> FilePath
forall a b. (a, b) -> a
fst ParameterPattern
p) FilePath
fsv]
                     RootText FilePath
fsv = [RootPart] -> RootPart
forall a. [a] -> a
head [RootPart]
sfx
                 in do Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RootPart -> Bool
isRootSuffix (RootPart -> Bool) -> RootPart -> Bool
forall a b. (a -> b) -> a -> b
$ [RootPart] -> RootPart
forall a. [a] -> a
head [RootPart]
sfx)
                       ([NamedParamMatch], FilePath, FilePath)
-> m ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [RootPart] -> [NamedParamMatch]
rpNPM ([RootPart] -> [NamedParamMatch])
-> [RootPart] -> [NamedParamMatch]
forall a b. (a -> b) -> a -> b
$ [RootPart]
parms1 [RootPart] -> [RootPart] -> [RootPart]
forall a. Semigroup a => a -> a -> a
<> [RootPart]
free
                              , [RootPart] -> FilePath
rpStr [RootPart]
pfx
                              , [RootPart] -> FilePath
rpStr ([RootPart] -> FilePath) -> [RootPart] -> FilePath
forall a b. (a -> b) -> a -> b
$ [RootPart] -> [RootPart]
forall a. [a] -> [a]
tail [RootPart]
sfx )

      freeMid :: Maybe
  (Either
     a ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
-> m ([NamedParamMatch], FilePath, FilePath)
freeMid Maybe
  (Either
     a ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
Nothing = m ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      freeMid (Just (Left a
_)) = m ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      freeMid (Just (Right ([RootPart]
pfx, [RootPart]
parms1, [RootPart]
mid, [RootPart]
parms2, [RootPart]
sfx))) =
        -- If there is a wildcard param and mid is a single
        -- element, then try converting the mid to the
        -- wildcard, otherwise this is an invalid name.
        if [RootPart] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RootPart]
mid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
3
        then m ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        else case Maybe ParameterPattern
freeValueParm of
               Maybe ParameterPattern
Nothing -> m ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
               Just ParameterPattern
p ->
                 let free :: [RootPart]
free = [FilePath -> FilePath -> RootPart
RootParNm (ParameterPattern -> FilePath
forall a b. (a, b) -> a
fst ParameterPattern
p) FilePath
mv]
                     (RootPart
ms1:RootText FilePath
mv:RootPart
ms2:[]) = [RootPart]
mid
                 in ([NamedParamMatch], FilePath, FilePath)
-> m ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [RootPart] -> [NamedParamMatch]
rpNPM ([RootPart] -> [NamedParamMatch])
-> [RootPart] -> [NamedParamMatch]
forall a b. (a -> b) -> a -> b
$ [RootPart]
parms1 [RootPart] -> [RootPart] -> [RootPart]
forall a. Semigroup a => a -> a -> a
<> [RootPart]
free [RootPart] -> [RootPart] -> [RootPart]
forall a. Semigroup a => a -> a -> a
<> [RootPart]
parms2
                           , [RootPart] -> FilePath
rpStr ([RootPart] -> FilePath) -> [RootPart] -> FilePath
forall a b. (a -> b) -> a -> b
$ [RootPart]
pfx [RootPart] -> [RootPart] -> [RootPart]
forall a. Semigroup a => a -> a -> a
<> [RootPart
ms1]
                           , [RootPart] -> FilePath
rpStr ([RootPart] -> FilePath) -> [RootPart] -> FilePath
forall a b. (a -> b) -> a -> b
$ RootPart
ms2 RootPart -> [RootPart] -> [RootPart]
forall a. a -> [a] -> [a]
: [RootPart]
sfx )

  (Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall b.
Maybe (Either ([RootPart], [RootPart], [RootPart]) b)
-> Logic ([NamedParamMatch], FilePath, FilePath)
freeFirst Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
rnChunks)
    Logic ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) b.
MonadPlus m =>
Maybe (Either ([RootPart], [RootPart], [RootPart]) b)
-> m ([NamedParamMatch], FilePath, FilePath)
freeLast Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
rnChunks)
    Logic ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a.
MonadPlus m =>
Maybe
  (Either
     a ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
-> m ([NamedParamMatch], FilePath, FilePath)
freeMid Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
rnChunks)


-- If no separators, there are no "rnParts" identifiable, so fall
-- back on a cruder algorithm that simply attempts to find a
-- sequence of paramvals in the middle of the string and extract
-- the prefix and suffix (if any) around those paramvals.
rootParamMatchNoSeps :: FilePath -> Separators -> [ParameterPattern]
                     -> Logic ([NamedParamMatch], FilePath, FilePath)
rootParamMatchNoSeps :: FilePath
-> FilePath
-> [ParameterPattern]
-> Logic ([NamedParamMatch], FilePath, FilePath)
rootParamMatchNoSeps FilePath
rootNm FilePath
seps' [ParameterPattern]
parms = do
  [ParameterPattern]
pseq <- [[ParameterPattern]] -> Logic [ParameterPattern]
forall a. [a] -> Logic a
eachFrom ([[ParameterPattern]] -> Logic [ParameterPattern])
-> [[ParameterPattern]] -> Logic [ParameterPattern]
forall a b. (a -> b) -> a -> b
$ ([ParameterPattern] -> Bool)
-> [[ParameterPattern]] -> [[ParameterPattern]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ([ParameterPattern] -> Bool) -> [ParameterPattern] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParameterPattern] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[ParameterPattern]] -> [[ParameterPattern]])
-> [[ParameterPattern]] -> [[ParameterPattern]]
forall a b. (a -> b) -> a -> b
$ [ParameterPattern] -> [[ParameterPattern]]
forall a. [a] -> [[a]]
L.permutations [ParameterPattern]
parms
  [(FilePath, Maybe FilePath)]
pvals <- [ParameterPattern] -> Logic [(FilePath, Maybe FilePath)]
getPVals [ParameterPattern]
pseq
  ([NamedParamMatch]
pvset, Int
_pvcnt, FilePath
pvstr) <- FilePath
-> [NamedParamMatch]
-> [(FilePath, Maybe FilePath)]
-> Logic ([NamedParamMatch], Int, FilePath)
pvalMatch FilePath
seps' [] [(FilePath, Maybe FilePath)]
pvals
  -- _pvcnt can be ignored because each is a different root
  let explicit :: [NamedParamMatch]
explicit = (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) [NamedParamMatch]
pvset
  Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [NamedParamMatch] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NamedParamMatch]
explicit
             , FilePath
pvstr FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` FilePath
rootNm
             , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath
pvstr FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` FilePath
rootNm
             ])
  let (FilePath
basename, FilePath
suffix) =
        let l1 :: Int
l1 = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
rootNm
            l2 :: Int
l2 = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
pvstr
            bslen :: Int
bslen = Int
l1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l2
            matches :: Int -> Bool
matches Int
n = FilePath
pvstr FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
n FilePath
rootNm)
            Just Int
pfxlen = (Int -> Bool) -> [Int] -> Maybe Int
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find Int -> Bool
matches ([Int] -> Maybe Int) -> [Int] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
1..Int
bslen]
        in (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
pfxlen FilePath
rootNm, Int -> ShowS
forall a. Int -> [a] -> [a]
drop (Int
pfxlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l2) FilePath
rootNm)
  ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedParamMatch]
explicit, FilePath
basename, FilePath
suffix)

-- Return origRootName up to each sep-indicated point.
noRootParamMatch :: FilePath -> Separators
                 -> Logic ([NamedParamMatch], FilePath, FilePath)
noRootParamMatch :: FilePath
-> FilePath -> Logic ([NamedParamMatch], FilePath, FilePath)
noRootParamMatch FilePath
origRootName FilePath
seps =
  ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], FilePath
origRootName, FilePath
"") Logic ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
  do Char
s <- FilePath -> Logic Char
forall a. [a] -> Logic a
eachFrom FilePath
seps
     Int
i <- [Int] -> Logic Int
forall a. [a] -> Logic a
eachFrom [Int
1..FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
origRootName Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
     let a :: FilePath
a = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
i FilePath
origRootName
     let b :: FilePath
b = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
i FilePath
origRootName
     if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
b
       then do ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], FilePath
a, FilePath
"")
       else do Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
b, FilePath -> Char
forall a. [a] -> a
head FilePath
b Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
s ])
               ([NamedParamMatch], FilePath, FilePath)
-> Logic ([NamedParamMatch], FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], FilePath
a, ShowS
forall a. [a] -> [a]
tail FilePath
b)