-- | 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
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).
-- Parameter values are taken from subdirectory paths or filename elements (in
-- that order).
rootMatch :: CandidateFile -> Separators -> [ParameterPattern] -> String
          -> Logic ([NamedParamMatch], CandidateFile, String)
rootMatch :: CandidateFile
-> Separators
-> [ParameterPattern]
-> Separators
-> Logic ([NamedParamMatch], CandidateFile, Separators)
rootMatch CandidateFile
origRoot Separators
seps [ParameterPattern]
params Separators
rootCmp = do
  ([NamedParamMatch]
dmatch, [ParameterPattern]
drem) <- CandidateFile
-> [ParameterPattern]
-> [ParameterPattern]
-> Logic ([NamedParamMatch], [ParameterPattern])
dirMatches CandidateFile
origRoot [ParameterPattern]
params [ParameterPattern]
params
  ([NamedParamMatch]
rpm, CandidateFile
p, Separators
s) <- Logic ([NamedParamMatch], CandidateFile, Separators)
-> (([NamedParamMatch], CandidateFile, Separators)
    -> Logic ([NamedParamMatch], CandidateFile, Separators))
-> Logic ([NamedParamMatch], CandidateFile, Separators)
-> Logic ([NamedParamMatch], CandidateFile, Separators)
forall (m :: * -> *) a b.
MonadLogic m =>
m a -> (a -> m b) -> m b -> m b
ifte
                 (CandidateFile
-> Separators
-> [ParameterPattern]
-> Separators
-> Logic ([NamedParamMatch], CandidateFile, Separators)
rootParamMatch CandidateFile
origRoot Separators
seps [ParameterPattern]
drem Separators
rootCmp)
                 ([NamedParamMatch], CandidateFile, Separators)
-> Logic ([NamedParamMatch], CandidateFile, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return
                 (CandidateFile
-> Separators
-> Logic ([NamedParamMatch], CandidateFile, Separators)
noRootParamMatch CandidateFile
origRoot Separators
seps)
  ([NamedParamMatch], CandidateFile, Separators)
-> Logic ([NamedParamMatch], CandidateFile, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedParamMatch]
dmatch [NamedParamMatch] -> [NamedParamMatch] -> [NamedParamMatch]
forall a. Semigroup a => a -> a -> a
<> [NamedParamMatch]
rpm, CandidateFile
p, Separators
s)


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

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

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

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

rpNPM :: [RootPart] -> [NamedParamMatch]
rpNPM :: [RootPart] -> [NamedParamMatch]
rpNPM = let bld :: RootPart -> Maybe [NamedParamMatch]
bld (RootParNm Separators
n Separators
v) = [NamedParamMatch] -> Maybe [NamedParamMatch]
forall a. a -> Maybe a
Just [(Separators
n, Separators -> ParamMatch
Explicit Separators
v)]
            bld (RootSep Separators
_) = Maybe [NamedParamMatch]
forall a. Maybe a
Nothing
            bld RootPart
p = Separators -> Maybe [NamedParamMatch]
forall a. HasCallStack => Separators -> a
error (Separators
"Invalid RootPart for NamedParamMatch: " Separators -> ShowS
forall a. Semigroup a => a -> a -> a
<> RootPart -> Separators
forall a. Show a => a -> Separators
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 :: CandidateFile
               -> Separators -> [ParameterPattern] -> String
               -> Logic ([NamedParamMatch], CandidateFile, String)
rootParamMatch :: CandidateFile
-> Separators
-> [ParameterPattern]
-> Separators
-> Logic ([NamedParamMatch], CandidateFile, Separators)
rootParamMatch CandidateFile
origRoot Separators
seps [ParameterPattern]
params Separators
rootCmp =
  if Separators -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Separators
seps
  then CandidateFile
-> Separators
-> [ParameterPattern]
-> Logic ([NamedParamMatch], CandidateFile, Separators)
rootParamMatchNoSeps CandidateFile
origRoot Separators
seps [ParameterPattern]
params
  else CandidateFile
-> Separators
-> [ParameterPattern]
-> Separators
-> Logic ([NamedParamMatch], CandidateFile, Separators)
rootParamFileMatches CandidateFile
origRoot Separators
seps [ParameterPattern]
params Separators
rootCmp


rootParamFileMatches :: CandidateFile
                     -> Separators -> [ParameterPattern] -> String
                     -> Logic ([NamedParamMatch], CandidateFile, String)
rootParamFileMatches :: CandidateFile
-> Separators
-> [ParameterPattern]
-> Separators
-> Logic ([NamedParamMatch], CandidateFile, Separators)
rootParamFileMatches CandidateFile
rootF Separators
seps [ParameterPattern]
parms Separators
rMatch = do
  let rnSplit :: [Separators]
rnSplit = Separators -> [Separators]
sepSplit (Separators -> [Separators]) -> Separators -> [Separators]
forall a b. (a -> b) -> a -> b
$ CandidateFile -> Separators
candidateFile CandidateFile
rootF
      sepSplit :: Separators -> [Separators]
sepSplit = (Char -> Char -> Bool) -> Separators -> [Separators]
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 -> Separators -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Separators
seps, Char
b Char -> Separators -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Separators
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 [Separators] -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe [Separators] -> Bool)
-> (ParameterPattern -> Maybe [Separators])
-> ParameterPattern
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParameterPattern -> Maybe [Separators]
forall a b. (a, b) -> b
snd) [ParameterPattern]
parms

      txtRootSfx :: [Separators]
txtRootSfx = Separators -> [Separators]
sepSplit (Separators -> [Separators]) -> Separators -> [Separators]
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 character 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 -> 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
"[*]\\(|)") ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse Separators
rMatch

      -- if a part of the root filename 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 :: (Separators, Int) -> RootPart
assignPart (Separators
ptxt,Int
pidx) =
              let matchesParmValue :: (a, Maybe (t Separators)) -> Bool
matchesParmValue (a
_, Maybe (t Separators)
Nothing) = Bool
False
                  matchesParmValue (a
_, Just t Separators
vl) = Separators
ptxt Separators -> t Separators -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Separators
vl
              in if Int
pidx Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
rnPartIndices
                 then
                   if [Separators] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Separators]
rnSplit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pidx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Separators] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Separators]
txtRootSfx
                   then Separators -> RootPart
RootSuffix Separators
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 Separators)) -> Bool
matchesParmValue [ParameterPattern]
parms of
                          Just (Separators
pn,Maybe [Separators]
_) -> Separators -> Separators -> RootPart
RootParNm Separators
pn Separators
ptxt
                          Maybe ParameterPattern
Nothing -> Separators -> RootPart
RootText Separators
ptxt
                 else Separators -> RootPart
RootSep Separators
ptxt
        in ((Separators, Int) -> RootPart)
-> [(Separators, Int)] -> [RootPart]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Separators, Int) -> RootPart
assignPart ([(Separators, Int)] -> [RootPart])
-> [(Separators, Int)] -> [RootPart]
forall a b. (a -> b) -> a -> b
$ [Separators] -> [Int] -> [(Separators, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Separators]
rnSplit [Int
0..]

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

  let hasDupParNm :: Bool
hasDupParNm =
        let getParNm :: RootPart -> Maybe Separators
getParNm = \case
              RootParNm Separators
pn Separators
_ -> Separators -> Maybe Separators
forall a. a -> Maybe a
Just Separators
pn
              RootPart
_ -> Maybe Separators
forall a. Maybe a
Nothing
            parNms :: [Separators]
parNms = [Maybe Separators] -> [Separators]
forall a. [Maybe a] -> [a]
catMaybes (RootPart -> Maybe Separators
getParNm (RootPart -> Maybe Separators) -> [RootPart] -> [Maybe Separators]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RootPart]
rnParts)
        in Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Separators] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Separators]
parNms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Separators] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Separators] -> [Separators]
forall a. Eq a => [a] -> [a]
L.nub [Separators]
parNms)

  Bool -> LogicT Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
hasDupParNm)

  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)
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
freeFirst Maybe (Either ([RootPart], [RootPart], [RootPart]) b)
Nothing = LogicT Identity ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      freeFirst (Just (Right b
_)) = LogicT Identity ([NamedParamMatch], Separators, Separators)
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 LogicT Identity ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        else case Maybe ParameterPattern
freeValueParm of
               Maybe ParameterPattern
Nothing -> LogicT Identity ([NamedParamMatch], Separators, Separators)
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]
                    case Int -> [RootPart] -> [RootPart]
forall a. Int -> [a] -> [a]
drop Int
idx [RootPart]
allRP of
                      (RootText Separators
idxv:[RootPart]
_) -> do
                        let free :: RootPart
free = Separators -> Separators -> RootPart
RootParNm (ParameterPattern -> Separators
forall a b. (a, b) -> a
fst ParameterPattern
p) Separators
idxv
                            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
                        ([NamedParamMatch], Separators, Separators)
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [RootPart] -> [NamedParamMatch]
rpNPM [RootPart
free]
                               , [RootPart] -> Separators
rpStr ([RootPart] -> Separators) -> [RootPart] -> Separators
forall a b. (a -> b) -> a -> b
$ [RootPart]
start
                               , [RootPart] -> Separators
rpStr ([RootPart] -> Separators) -> [RootPart] -> Separators
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 )
                      [RootPart]
_ -> LogicT Identity ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      freeFirst (Just (Left ([RootPart]
pfx, [RootPart]
pl1, [RootPart]
sfx))) =
        case Maybe ParameterPattern
freeValueParm of
          Maybe ParameterPattern
Nothing ->
            -- No wildcard param, so just try the observed
            -- pattern
            ([NamedParamMatch], Separators, Separators)
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [RootPart] -> [NamedParamMatch]
rpNPM [RootPart]
pl1, [RootPart] -> Separators
rpStr ([RootPart] -> Separators) -> [RootPart] -> Separators
forall a b. (a -> b) -> a -> b
$ [RootPart] -> [RootPart]
forall a. [a] -> [a]
init [RootPart]
pfx, [RootPart] -> Separators
rpStr [RootPart]
sfx )
          Just ParameterPattern
p ->
            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
              -- not enough elements of pfx to support a wildcard, so there must
              -- be no expression of the wildcard and just the observed pattern.
              -- Also remove any separator from the prefix.
              ([NamedParamMatch], Separators, Separators)
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [RootPart] -> [NamedParamMatch]
rpNPM [RootPart]
pl1, [RootPart] -> Separators
rpStr ([RootPart] -> Separators) -> [RootPart] -> Separators
forall a b. (a -> b) -> a -> b
$ Int -> [RootPart] -> [RootPart]
forall a. Int -> [a] -> [a]
take Int
1 [RootPart]
pfx, [RootPart] -> Separators
rpStr [RootPart]
sfx )
            else
              -- There is a wildcard parameter, try it at the end
              -- of pfx and before pl1
              case [RootPart] -> [RootPart]
forall a. [a] -> [a]
reverse [RootPart]
pfx of
                (RootPart
_:RootText Separators
lpv:[RootPart]
_) ->
                  ([NamedParamMatch], Separators, Separators)
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [RootPart] -> [NamedParamMatch]
rpNPM ([RootPart] -> [NamedParamMatch])
-> [RootPart] -> [NamedParamMatch]
forall a b. (a -> b) -> a -> b
$ Separators -> Separators -> RootPart
RootParNm (ParameterPattern -> Separators
forall a b. (a, b) -> a
fst ParameterPattern
p) Separators
lpv RootPart -> [RootPart] -> [RootPart]
forall a. a -> [a] -> [a]
: [RootPart]
pl1
                         , [RootPart] -> Separators
rpStr ([RootPart] -> Separators) -> [RootPart] -> Separators
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] -> Separators
rpStr [RootPart]
sfx )
                [RootPart]
_ -> LogicT Identity ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero

      freeLast :: Maybe (Either ([RootPart], [RootPart], [RootPart]) b)
-> m ([NamedParamMatch], Separators, Separators)
freeLast Maybe (Either ([RootPart], [RootPart], [RootPart]) b)
Nothing = m ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      freeLast (Just (Right b
_)) = m ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      freeLast (Just (Left ([RootPart]
_, [], []))) = m ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero -- handled by freeFirst
      freeLast (Just (Left ([RootPart]
_, [RootPart]
_, []))) = m ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      freeLast (Just (Left ([RootPart]
pfx, [RootPart]
parms1, [RootPart]
sfx))) =
        case Maybe ParameterPattern
freeValueParm of
          Maybe ParameterPattern
Nothing -> m ([NamedParamMatch], Separators, Separators)
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
            case [RootPart]
sfx of
              (RootText Separators
fsv:[RootPart]
_) ->
                ([NamedParamMatch], Separators, Separators)
-> m ([NamedParamMatch], Separators, Separators)
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
<> [Separators -> Separators -> RootPart
RootParNm (ParameterPattern -> Separators
forall a b. (a, b) -> a
fst ParameterPattern
p) Separators
fsv]
                       , [RootPart] -> Separators
rpStr ([RootPart] -> Separators) -> [RootPart] -> Separators
forall a b. (a -> b) -> a -> b
$ [RootPart] -> [RootPart]
forall a. [a] -> [a]
init [RootPart]
pfx
                       , [RootPart] -> Separators
rpStr ([RootPart] -> Separators) -> [RootPart] -> Separators
forall a b. (a -> b) -> a -> b
$ [RootPart] -> [RootPart]
forall a. [a] -> [a]
tail [RootPart]
sfx )
              [RootPart]
_ -> m ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero

      freeMid :: Maybe
  (Either
     a ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
-> m ([NamedParamMatch], Separators, Separators)
freeMid Maybe
  (Either
     a ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
Nothing = m ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      freeMid (Just (Left a
_)) = m ([NamedParamMatch], Separators, Separators)
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], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        else case Maybe ParameterPattern
freeValueParm of
               Maybe ParameterPattern
Nothing -> m ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
               Just ParameterPattern
p ->
                 case [RootPart]
mid of
                   (RootPart
ms1:RootText Separators
mv:RootPart
ms2:[]) ->
                     ([NamedParamMatch], Separators, Separators)
-> m ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [RootPart] -> [NamedParamMatch]
rpNPM ( [RootPart]
parms1 [RootPart] -> [RootPart] -> [RootPart]
forall a. Semigroup a => a -> a -> a
<> [Separators -> Separators -> RootPart
RootParNm (ParameterPattern -> Separators
forall a b. (a, b) -> a
fst ParameterPattern
p) Separators
mv] [RootPart] -> [RootPart] -> [RootPart]
forall a. Semigroup a => a -> a -> a
<>
                                      [RootPart]
parms2 )
                            , [RootPart] -> Separators
rpStr ([RootPart] -> Separators) -> [RootPart] -> Separators
forall a b. (a -> b) -> a -> b
$ [RootPart]
pfx [RootPart] -> [RootPart] -> [RootPart]
forall a. Semigroup a => a -> a -> a
<> [RootPart
ms1]
                            , [RootPart] -> Separators
rpStr ([RootPart] -> Separators) -> [RootPart] -> Separators
forall a b. (a -> b) -> a -> b
$ RootPart
ms2 RootPart -> [RootPart] -> [RootPart]
forall a. a -> [a] -> [a]
: [RootPart]
sfx )
                   [RootPart]
_ -> m ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero

  (\([NamedParamMatch]
a,Separators
fn,Separators
b) -> ([NamedParamMatch]
a, CandidateFile
rootF { candidateFile :: Separators
candidateFile = Separators
fn }, Separators
b))
    (([NamedParamMatch], Separators, Separators)
 -> ([NamedParamMatch], CandidateFile, Separators))
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
-> Logic ([NamedParamMatch], CandidateFile, Separators)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
forall b.
Maybe (Either ([RootPart], [RootPart], [RootPart]) b)
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
freeFirst Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
rnChunks)
         LogicT Identity ([NamedParamMatch], Separators, Separators)
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) b.
MonadPlus m =>
Maybe (Either ([RootPart], [RootPart], [RootPart]) b)
-> m ([NamedParamMatch], Separators, Separators)
freeLast Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
rnChunks)
         LogicT Identity ([NamedParamMatch], Separators, Separators)
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Maybe
  (Either
     ([RootPart], [RootPart], [RootPart])
     ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
-> LogicT Identity ([NamedParamMatch], Separators, Separators)
forall (m :: * -> *) a.
MonadPlus m =>
Maybe
  (Either
     a ([RootPart], [RootPart], [RootPart], [RootPart], [RootPart]))
-> m ([NamedParamMatch], Separators, Separators)
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 :: CandidateFile -> Separators -> [ParameterPattern]
                     -> Logic ([NamedParamMatch], CandidateFile, String)
rootParamMatchNoSeps :: CandidateFile
-> Separators
-> [ParameterPattern]
-> Logic ([NamedParamMatch], CandidateFile, Separators)
rootParamMatchNoSeps CandidateFile
rootF Separators
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
  [(Separators, Maybe Separators)]
pvals <- [ParameterPattern] -> Logic [(Separators, Maybe Separators)]
getPVals [ParameterPattern]
pseq
  ([NamedParamMatch]
pvset, Int
_pvcnt, Separators
pvstr) <- Separators
-> [NamedParamMatch]
-> [(Separators, Maybe Separators)]
-> Logic ([NamedParamMatch], Int, Separators)
pvalMatch Separators
seps' [] [(Separators, Maybe Separators)]
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
  let rootNm :: Separators
rootNm = CandidateFile -> Separators
candidateFile CandidateFile
rootF
  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
             , Separators
pvstr Separators -> Separators -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` Separators
rootNm
             , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Separators
pvstr Separators -> Separators -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` Separators
rootNm
             ])
  let l1 :: Int
l1 = Separators -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Separators
rootNm
      l2 :: Int
l2 = Separators -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Separators
pvstr
      bslen :: Int
bslen = Int
l1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l2
      matches :: Int -> Bool
matches Int
n = Separators
pvstr Separators -> Separators -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
n Separators
rootNm)
  case (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] of
    Just Int
pfxlen ->
      let basefname :: Separators
basefname = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
pfxlen Separators
rootNm
          basename :: CandidateFile
basename = CandidateFile
rootF { candidateFile :: Separators
candidateFile = Separators
basefname }
          suffix :: Separators
suffix = Int -> ShowS
forall a. Int -> [a] -> [a]
drop (Int
pfxlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l2) Separators
rootNm
      in ([NamedParamMatch], CandidateFile, Separators)
-> Logic ([NamedParamMatch], CandidateFile, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedParamMatch]
explicit, CandidateFile
basename, Separators
suffix)
    Maybe Int
_ -> Logic ([NamedParamMatch], CandidateFile, Separators)
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- Return origRootName up to each sep-indicated point.
noRootParamMatch :: CandidateFile -> Separators
                 -> Logic ([NamedParamMatch], CandidateFile, String)
noRootParamMatch :: CandidateFile
-> Separators
-> Logic ([NamedParamMatch], CandidateFile, Separators)
noRootParamMatch CandidateFile
origRoot Separators
seps =
  ([NamedParamMatch], CandidateFile, Separators)
-> Logic ([NamedParamMatch], CandidateFile, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CandidateFile
origRoot, Separators
"") Logic ([NamedParamMatch], CandidateFile, Separators)
-> Logic ([NamedParamMatch], CandidateFile, Separators)
-> Logic ([NamedParamMatch], CandidateFile, Separators)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
  do Char
s <- Separators -> Logic Char
forall a. [a] -> Logic a
eachFrom Separators
seps
     let origRootName :: Separators
origRootName = CandidateFile -> Separators
candidateFile CandidateFile
origRoot
     Int
i <- [Int] -> Logic Int
forall a. [a] -> Logic a
eachFrom [Int
1..Separators -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Separators
origRootName Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
     let a :: CandidateFile
a = CandidateFile
origRoot { candidateFile :: Separators
candidateFile = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
i Separators
origRootName }
     let b :: Separators
b = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
i Separators
origRootName
     if Separators -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Separators
b
       then do ([NamedParamMatch], CandidateFile, Separators)
-> Logic ([NamedParamMatch], CandidateFile, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CandidateFile
a, Separators
"")
       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
$ Separators -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Separators
b, Separators -> Char
forall a. [a] -> a
head Separators
b Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
s ])
               ([NamedParamMatch], CandidateFile, Separators)
-> Logic ([NamedParamMatch], CandidateFile, Separators)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CandidateFile
a, ShowS
forall a. [a] -> [a]
tail Separators
b)