{-# LANGUAGE ViewPatterns, DeriveFunctor, BangPatterns, TupleSections, RecordWildCards #-}

-- | Applying a set of paths vs a set of patterns efficiently
module System.FilePattern.Step(
    step, step_, Step(..), StepNext(..)
    ) where

import System.FilePattern.Core
import System.FilePattern.Tree
import System.FilePattern.Wildcard

import Control.Monad.Extra
import Data.List.Extra
import Data.Semigroup
import Data.Tuple.Extra
import Data.Functor
import Data.Either
import qualified Data.List.NonEmpty as NE
import Prelude


-- | What we know about the next step values.
data StepNext
    =
      -- | All components not listed will result in dull 'Step' values from 'stepApply',
      --   with 'stepNext' being @'StepOnly' []@ and 'stepDone' being @[]@. The field is a set - their order
      --   is irrelevant but there will be no duplicates in values arising from 'step'.
      StepOnly [String]
    | -- | All calls to 'stepApply' will return 'stepNext' being 'StepEverything' with a non-empty 'stepDone'.
      StepEverything
    | -- | We have no additional information about the output from 'stepApply'.
      StepUnknown
      deriving (StepNext -> StepNext -> Bool
(StepNext -> StepNext -> Bool)
-> (StepNext -> StepNext -> Bool) -> Eq StepNext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StepNext -> StepNext -> Bool
$c/= :: StepNext -> StepNext -> Bool
== :: StepNext -> StepNext -> Bool
$c== :: StepNext -> StepNext -> Bool
Eq,Eq StepNext
Eq StepNext
-> (StepNext -> StepNext -> Ordering)
-> (StepNext -> StepNext -> Bool)
-> (StepNext -> StepNext -> Bool)
-> (StepNext -> StepNext -> Bool)
-> (StepNext -> StepNext -> Bool)
-> (StepNext -> StepNext -> StepNext)
-> (StepNext -> StepNext -> StepNext)
-> Ord StepNext
StepNext -> StepNext -> Bool
StepNext -> StepNext -> Ordering
StepNext -> StepNext -> StepNext
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: StepNext -> StepNext -> StepNext
$cmin :: StepNext -> StepNext -> StepNext
max :: StepNext -> StepNext -> StepNext
$cmax :: StepNext -> StepNext -> StepNext
>= :: StepNext -> StepNext -> Bool
$c>= :: StepNext -> StepNext -> Bool
> :: StepNext -> StepNext -> Bool
$c> :: StepNext -> StepNext -> Bool
<= :: StepNext -> StepNext -> Bool
$c<= :: StepNext -> StepNext -> Bool
< :: StepNext -> StepNext -> Bool
$c< :: StepNext -> StepNext -> Bool
compare :: StepNext -> StepNext -> Ordering
$ccompare :: StepNext -> StepNext -> Ordering
$cp1Ord :: Eq StepNext
Ord,Int -> StepNext -> ShowS
[StepNext] -> ShowS
StepNext -> String
(Int -> StepNext -> ShowS)
-> (StepNext -> String) -> ([StepNext] -> ShowS) -> Show StepNext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StepNext] -> ShowS
$cshowList :: [StepNext] -> ShowS
show :: StepNext -> String
$cshow :: StepNext -> String
showsPrec :: Int -> StepNext -> ShowS
$cshowsPrec :: Int -> StepNext -> ShowS
Show)


mergeStepNext :: [StepNext] -> StepNext
mergeStepNext :: [StepNext] -> StepNext
mergeStepNext = ([String] -> [String]) -> [StepNext] -> StepNext
f [String] -> [String]
forall a. a -> a
id
    where
        f :: ([String] -> [String]) -> [StepNext] -> StepNext
f [String] -> [String]
rest [] = [String] -> StepNext
StepOnly ([String] -> StepNext) -> [String] -> StepNext
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
rest []
        f [String] -> [String]
rest (StepNext
StepUnknown:[StepNext]
xs) = if StepNext
StepEverything StepNext -> [StepNext] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [StepNext]
xs then StepNext
StepEverything else StepNext
StepUnknown
        f [String] -> [String]
rest (StepNext
StepEverything:[StepNext]
xs) = StepNext
StepEverything
        f [String] -> [String]
rest (StepOnly [String]
x:[StepNext]
xs) = ([String] -> [String]) -> [StepNext] -> StepNext
f ([String] -> [String]
rest ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String]
x [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++)) [StepNext]
xs

normaliseStepNext :: StepNext -> StepNext
normaliseStepNext :: StepNext -> StepNext
normaliseStepNext (StepOnly [String]
xs) = [String] -> StepNext
StepOnly ([String] -> StepNext) -> [String] -> StepNext
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
xs
normaliseStepNext StepNext
x = StepNext
x


instance Semigroup StepNext where
    StepNext
a <> :: StepNext -> StepNext -> StepNext
<> StepNext
b = NonEmpty StepNext -> StepNext
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty StepNext -> StepNext) -> NonEmpty StepNext -> StepNext
forall a b. (a -> b) -> a -> b
$ [StepNext] -> NonEmpty StepNext
forall a. [a] -> NonEmpty a
NE.fromList [StepNext
a,StepNext
b]
    sconcat :: NonEmpty StepNext -> StepNext
sconcat = StepNext -> StepNext
normaliseStepNext (StepNext -> StepNext)
-> (NonEmpty StepNext -> StepNext) -> NonEmpty StepNext -> StepNext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StepNext] -> StepNext
mergeStepNext ([StepNext] -> StepNext)
-> (NonEmpty StepNext -> [StepNext])
-> NonEmpty StepNext
-> StepNext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty StepNext -> [StepNext]
forall a. NonEmpty a -> [a]
NE.toList

instance Monoid StepNext where
    mempty :: StepNext
mempty = [String] -> StepNext
StepOnly []
    mappend :: StepNext -> StepNext -> StepNext
mappend = StepNext -> StepNext -> StepNext
forall a. Semigroup a => a -> a -> a
(<>)
    mconcat :: [StepNext] -> StepNext
mconcat = StepNext
-> (NonEmpty StepNext -> StepNext)
-> Maybe (NonEmpty StepNext)
-> StepNext
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StepNext
forall a. Monoid a => a
mempty NonEmpty StepNext -> StepNext
forall a. Semigroup a => NonEmpty a -> a
sconcat (Maybe (NonEmpty StepNext) -> StepNext)
-> ([StepNext] -> Maybe (NonEmpty StepNext))
-> [StepNext]
-> StepNext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StepNext] -> Maybe (NonEmpty StepNext)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty -- important: use the fast sconcat


-- | The result of 'step', used to process successive path components of a set of 'FilePath's.
data Step a = Step
    {Step a -> [(a, [String])]
stepDone :: [(a, [String])]
        -- ^ The files that match at this step. Includes the list that would have been produced by 'System.FilePattern.match',
        --   along with the values passed to 'step'. These results are not necessarily in order.
    ,Step a -> StepNext
stepNext :: StepNext
        -- ^ Information about the results of calling 'stepApply'. See 'StepNext' for details.
    ,Step a -> String -> Step a
stepApply :: String -> Step a
        -- ^ Apply one component from a 'FilePath' to get a new 'Step'.
    }
    deriving a -> Step b -> Step a
(a -> b) -> Step a -> Step b
(forall a b. (a -> b) -> Step a -> Step b)
-> (forall a b. a -> Step b -> Step a) -> Functor Step
forall a b. a -> Step b -> Step a
forall a b. (a -> b) -> Step a -> Step b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Step b -> Step a
$c<$ :: forall a b. a -> Step b -> Step a
fmap :: (a -> b) -> Step a -> Step b
$cfmap :: forall a b. (a -> b) -> Step a -> Step b
Functor

mergeStep :: (StepNext -> StepNext) -> [Step a] -> Step a
mergeStep :: (StepNext -> StepNext) -> [Step a] -> Step a
mergeStep StepNext -> StepNext
f [] = Step a
forall a. Monoid a => a
mempty
mergeStep StepNext -> StepNext
f [Step a
x] = Step a
x
mergeStep StepNext -> StepNext
f [Step a]
xs = Step :: forall a.
[(a, [String])] -> StepNext -> (String -> Step a) -> Step a
Step
    {stepDone :: [(a, [String])]
stepDone = (Step a -> [(a, [String])]) -> [Step a] -> [(a, [String])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Step a -> [(a, [String])]
forall a. Step a -> [(a, [String])]
stepDone [Step a]
xs
    ,stepNext :: StepNext
stepNext = StepNext -> StepNext
f (StepNext -> StepNext) -> StepNext -> StepNext
forall a b. (a -> b) -> a -> b
$ [StepNext] -> StepNext
mergeStepNext ([StepNext] -> StepNext) -> [StepNext] -> StepNext
forall a b. (a -> b) -> a -> b
$ (Step a -> StepNext) -> [Step a] -> [StepNext]
forall a b. (a -> b) -> [a] -> [b]
map Step a -> StepNext
forall a. Step a -> StepNext
stepNext [Step a]
xs
    ,stepApply :: String -> Step a
stepApply = \String
x -> (StepNext -> StepNext) -> [Step a] -> Step a
forall a. (StepNext -> StepNext) -> [Step a] -> Step a
mergeStep StepNext -> StepNext
f ([Step a] -> Step a) -> [Step a] -> Step a
forall a b. (a -> b) -> a -> b
$ (Step a -> Step a) -> [Step a] -> [Step a]
forall a b. (a -> b) -> [a] -> [b]
map (Step a -> String -> Step a
forall a. Step a -> String -> Step a
`stepApply` String
x) [Step a]
xs
    }

instance Semigroup (Step a) where
    Step a
a <> :: Step a -> Step a -> Step a
<> Step a
b = NonEmpty (Step a) -> Step a
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty (Step a) -> Step a) -> NonEmpty (Step a) -> Step a
forall a b. (a -> b) -> a -> b
$ [Step a] -> NonEmpty (Step a)
forall a. [a] -> NonEmpty a
NE.fromList [Step a
a,Step a
b]
    sconcat :: NonEmpty (Step a) -> Step a
sconcat (NonEmpty (Step a) -> [Step a]
forall a. NonEmpty a -> [a]
NE.toList -> [Step a]
ss)
        | [Step a
s] <- [Step a]
ss = Step a
s
        | Bool
otherwise = Step :: forall a.
[(a, [String])] -> StepNext -> (String -> Step a) -> Step a
Step
            {stepDone :: [(a, [String])]
stepDone = (Step a -> [(a, [String])]) -> [Step a] -> [(a, [String])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Step a -> [(a, [String])]
forall a. Step a -> [(a, [String])]
stepDone [Step a]
ss
            ,stepNext :: StepNext
stepNext = (Step a -> StepNext) -> [Step a] -> StepNext
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap Step a -> StepNext
forall a. Step a -> StepNext
stepNext [Step a]
ss
            ,stepApply :: String -> Step a
stepApply = \String
x -> (Step a -> Step a) -> [Step a] -> Step a
forall b a. Monoid b => (a -> b) -> [a] -> b
fastFoldMap (Step a -> String -> Step a
forall a. Step a -> String -> Step a
`stepApply` String
x) [Step a]
ss
            }

instance Monoid (Step a) where
    mempty :: Step a
mempty = [(a, [String])] -> StepNext -> (String -> Step a) -> Step a
forall a.
[(a, [String])] -> StepNext -> (String -> Step a) -> Step a
Step [] StepNext
forall a. Monoid a => a
mempty ((String -> Step a) -> Step a) -> (String -> Step a) -> Step a
forall a b. (a -> b) -> a -> b
$ Step a -> String -> Step a
forall a b. a -> b -> a
const Step a
forall a. Monoid a => a
mempty
    mappend :: Step a -> Step a -> Step a
mappend = Step a -> Step a -> Step a
forall a. Semigroup a => a -> a -> a
(<>)
    mconcat :: [Step a] -> Step a
mconcat = Step a
-> (NonEmpty (Step a) -> Step a)
-> Maybe (NonEmpty (Step a))
-> Step a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Step a
forall a. Monoid a => a
mempty NonEmpty (Step a) -> Step a
forall a. Semigroup a => NonEmpty a -> a
sconcat (Maybe (NonEmpty (Step a)) -> Step a)
-> ([Step a] -> Maybe (NonEmpty (Step a))) -> [Step a] -> Step a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Step a] -> Maybe (NonEmpty (Step a))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty -- important: use the fast sconcat

fastFoldMap :: Monoid m => (a -> m) -> [a] -> m
{- HLINT ignore fastFoldMap -}
fastFoldMap :: (a -> m) -> [a] -> m
fastFoldMap a -> m
f = [m] -> m
forall a. Monoid a => [a] -> a
mconcat ([m] -> m) -> ([a] -> [m]) -> [a] -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m) -> [a] -> [m]
forall a b. (a -> b) -> [a] -> [b]
map a -> m
f -- important: use the fast mconcat


-- Invariant: No two adjacent Lits
-- Invariant: No empty Lits
data Pat = Lits [Wildcard String]
         | StarStar
         | End
           deriving (Int -> Pat -> ShowS
[Pat] -> ShowS
Pat -> String
(Int -> Pat -> ShowS)
-> (Pat -> String) -> ([Pat] -> ShowS) -> Show Pat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pat] -> ShowS
$cshowList :: [Pat] -> ShowS
show :: Pat -> String
$cshow :: Pat -> String
showsPrec :: Int -> Pat -> ShowS
$cshowsPrec :: Int -> Pat -> ShowS
Show,Pat -> Pat -> Bool
(Pat -> Pat -> Bool) -> (Pat -> Pat -> Bool) -> Eq Pat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pat -> Pat -> Bool
$c/= :: Pat -> Pat -> Bool
== :: Pat -> Pat -> Bool
$c== :: Pat -> Pat -> Bool
Eq,Eq Pat
Eq Pat
-> (Pat -> Pat -> Ordering)
-> (Pat -> Pat -> Bool)
-> (Pat -> Pat -> Bool)
-> (Pat -> Pat -> Bool)
-> (Pat -> Pat -> Bool)
-> (Pat -> Pat -> Pat)
-> (Pat -> Pat -> Pat)
-> Ord Pat
Pat -> Pat -> Bool
Pat -> Pat -> Ordering
Pat -> Pat -> Pat
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Pat -> Pat -> Pat
$cmin :: Pat -> Pat -> Pat
max :: Pat -> Pat -> Pat
$cmax :: Pat -> Pat -> Pat
>= :: Pat -> Pat -> Bool
$c>= :: Pat -> Pat -> Bool
> :: Pat -> Pat -> Bool
$c> :: Pat -> Pat -> Bool
<= :: Pat -> Pat -> Bool
$c<= :: Pat -> Pat -> Bool
< :: Pat -> Pat -> Bool
$c< :: Pat -> Pat -> Bool
compare :: Pat -> Pat -> Ordering
$ccompare :: Pat -> Pat -> Ordering
$cp1Ord :: Eq Pat
Ord)

toPat :: Pattern -> [Pat]
toPat :: Pattern -> [Pat]
toPat (Pattern (Literal [Wildcard String]
xs)) = [[Wildcard String] -> Pat
Lits [Wildcard String]
xs]
toPat (Pattern (Wildcard [Wildcard String]
pre [[Wildcard String]]
mid [Wildcard String]
post)) = [Pat] -> [[Pat]] -> [Pat]
forall a. [a] -> [[a]] -> [a]
intercalate [Pat
StarStar] ([[Pat]] -> [Pat]) -> [[Pat]] -> [Pat]
forall a b. (a -> b) -> a -> b
$ ([Wildcard String] -> [Pat]) -> [[Wildcard String]] -> [[Pat]]
forall a b. (a -> b) -> [a] -> [b]
map [Wildcard String] -> [Pat]
lit ([[Wildcard String]] -> [[Pat]]) -> [[Wildcard String]] -> [[Pat]]
forall a b. (a -> b) -> a -> b
$ [Wildcard String]
pre [Wildcard String] -> [[Wildcard String]] -> [[Wildcard String]]
forall a. a -> [a] -> [a]
: [[Wildcard String]]
mid [[Wildcard String]] -> [[Wildcard String]] -> [[Wildcard String]]
forall a. [a] -> [a] -> [a]
++ [[Wildcard String]
post]
    where lit :: [Wildcard String] -> [Pat]
lit [Wildcard String]
xs = [[Wildcard String] -> Pat
Lits [Wildcard String]
xs | [Wildcard String]
xs [Wildcard String] -> [Wildcard String] -> Bool
forall a. Eq a => a -> a -> Bool
/= []]


-- | Efficient matching of a set of 'FilePattern's against a set of 'FilePath's.
--   First call 'step' passing in all the 'FilePattern's, with a tag for each one.
--   Next call the methods of 'Step', providing the components of the 'FilePath's in turn.
--
--   Useful for efficient bulk searching, particularly directory scanning, where you can
--   avoid descending into directories which cannot match.
step :: [(a, FilePattern)] -> Step a
step :: [(a, String)] -> Step a
step = Step [a] -> Step a
forall a. Step [a] -> Step a
restore (Step [a] -> Step a)
-> ([(a, String)] -> Step [a]) -> [(a, String)] -> Step a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((([String] -> [String]) -> Step [a])
-> ([String] -> [String]) -> Step [a]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. a -> a
id) ((([String] -> [String]) -> Step [a]) -> Step [a])
-> ([(a, String)] -> ([String] -> [String]) -> Step [a])
-> [(a, String)]
-> Step [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> Tree Pat a -> ([String] -> [String]) -> Step [a]
forall a. [Pat] -> Tree Pat a -> ([String] -> [String]) -> Step [a]
f [] (Tree Pat a -> ([String] -> [String]) -> Step [a])
-> ([(a, String)] -> Tree Pat a)
-> [(a, String)]
-> ([String] -> [String])
-> Step [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, [Pat])] -> Tree Pat a
forall k v. Ord k => [(v, [k])] -> Tree k v
makeTree ([(a, [Pat])] -> Tree Pat a)
-> ([(a, String)] -> [(a, [Pat])]) -> [(a, String)] -> Tree Pat a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, String) -> (a, [Pat])) -> [(a, String)] -> [(a, [Pat])]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> [Pat]) -> (a, String) -> (a, [Pat])
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second ((String -> [Pat]) -> (a, String) -> (a, [Pat]))
-> (String -> [Pat]) -> (a, String) -> (a, [Pat])
forall a b. (a -> b) -> a -> b
$ Pattern -> [Pat]
toPat (Pattern -> [Pat]) -> (String -> Pattern) -> String -> [Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Pattern
parsePattern)
    where
        f :: [Pat] -> Tree Pat a -> (Parts -> Step [a])
        f :: [Pat] -> Tree Pat a -> ([String] -> [String]) -> Step [a]
f [Pat]
seen (Tree [a]
ends [(Pat, Tree Pat a)]
nxts) = \[String] -> [String]
parts -> (StepNext -> StepNext) -> [Step [a]] -> Step [a]
forall a. (StepNext -> StepNext) -> [Step a] -> Step a
mergeStep StepNext -> StepNext
forall a. a -> a
id ([Step [a]] -> Step [a]) -> [Step [a]] -> Step [a]
forall a b. (a -> b) -> a -> b
$ ((([String] -> [String]) -> Step [a]) -> Step [a])
-> [([String] -> [String]) -> Step [a]] -> [Step [a]]
forall a b. (a -> b) -> [a] -> [b]
map ((([String] -> [String]) -> Step [a])
-> ([String] -> [String]) -> Step [a]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
parts) ([([String] -> [String]) -> Step [a]] -> [Step [a]])
-> [([String] -> [String]) -> Step [a]] -> [Step [a]]
forall a b. (a -> b) -> a -> b
$ [([String] -> [String]) -> Step [a]]
sEnds [([String] -> [String]) -> Step [a]]
-> [([String] -> [String]) -> Step [a]]
-> [([String] -> [String]) -> Step [a]]
forall a. [a] -> [a] -> [a]
++ [([String] -> [String]) -> Step [a]]
sNxts
            where
                sEnds :: [([String] -> [String]) -> Step [a]]
sEnds = case [a]
-> [Pat]
-> Maybe
     ([Pat],
      (([String] -> [String]) -> Step [a])
      -> ([String] -> [String]) -> Step [a])
forall a.
a
-> [Pat]
-> Maybe
     ([Pat],
      (([String] -> [String]) -> Step a)
      -> ([String] -> [String]) -> Step a)
unroll [a]
ends ([Pat]
seen [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Pat
End]) of
                    Maybe
  ([Pat],
   (([String] -> [String]) -> Step [a])
   -> ([String] -> [String]) -> Step [a])
_ | [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ends -> []
                    Just ([], (([String] -> [String]) -> Step [a])
-> ([String] -> [String]) -> Step [a]
c) -> [(([String] -> [String]) -> Step [a])
-> ([String] -> [String]) -> Step [a]
c (String -> ([String] -> [String]) -> Step [a]
forall a. HasCallStack => String -> a
error String
"step invariant violated (1)")]
                    Maybe
  ([Pat],
   (([String] -> [String]) -> Step [a])
   -> ([String] -> [String]) -> Step [a])
_ -> String -> [([String] -> [String]) -> Step [a]]
forall a. HasCallStack => String -> a
error (String -> [([String] -> [String]) -> Step [a]])
-> String -> [([String] -> [String]) -> Step [a]]
forall a b. (a -> b) -> a -> b
$ String
"step invariant violated (2), " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Pat] -> String
forall a. Show a => a -> String
show [Pat]
seen

                sNxts :: [([String] -> [String]) -> Step [a]]
sNxts = (((Pat, Tree Pat a) -> ([String] -> [String]) -> Step [a])
 -> [(Pat, Tree Pat a)] -> [([String] -> [String]) -> Step [a]])
-> [(Pat, Tree Pat a)]
-> ((Pat, Tree Pat a) -> ([String] -> [String]) -> Step [a])
-> [([String] -> [String]) -> Step [a]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Pat, Tree Pat a) -> ([String] -> [String]) -> Step [a])
-> [(Pat, Tree Pat a)] -> [([String] -> [String]) -> Step [a]]
forall a b. (a -> b) -> [a] -> [b]
map [(Pat, Tree Pat a)]
nxts (((Pat, Tree Pat a) -> ([String] -> [String]) -> Step [a])
 -> [([String] -> [String]) -> Step [a]])
-> ((Pat, Tree Pat a) -> ([String] -> [String]) -> Step [a])
-> [([String] -> [String]) -> Step [a]]
forall a b. (a -> b) -> a -> b
$ \(Pat
p,Tree Pat a
ps) ->
                    let seen2 :: [Pat]
seen2 = [Pat]
seen [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Pat
p] in
                    case [a]
-> [Pat]
-> Maybe
     ([Pat],
      (([String] -> [String]) -> Step [a])
      -> ([String] -> [String]) -> Step [a])
forall a.
a
-> [Pat]
-> Maybe
     ([Pat],
      (([String] -> [String]) -> Step a)
      -> ([String] -> [String]) -> Step a)
unroll (String -> [a]
forall a. HasCallStack => String -> a
error String
"step invariant violated (3)") [Pat]
seen2 of
                        Maybe
  ([Pat],
   (([String] -> [String]) -> Step [a])
   -> ([String] -> [String]) -> Step [a])
Nothing -> [Pat] -> Tree Pat a -> ([String] -> [String]) -> Step [a]
forall a. [Pat] -> Tree Pat a -> ([String] -> [String]) -> Step [a]
f [Pat]
seen2 Tree Pat a
ps
                        Just ([Pat]
nxt, (([String] -> [String]) -> Step [a])
-> ([String] -> [String]) -> Step [a]
c) -> (([String] -> [String]) -> Step [a])
-> ([String] -> [String]) -> Step [a]
c ([Pat] -> Tree Pat a -> ([String] -> [String]) -> Step [a]
forall a. [Pat] -> Tree Pat a -> ([String] -> [String]) -> Step [a]
f [] (Tree Pat a -> ([String] -> [String]) -> Step [a])
-> Tree Pat a -> ([String] -> [String]) -> Step [a]
forall a b. (a -> b) -> a -> b
$ [Pat] -> Tree Pat a -> Tree Pat a
forall k v. [k] -> Tree k v -> Tree k v
retree [Pat]
nxt Tree Pat a
ps)

        retree :: [k] -> Tree k v -> Tree k v
retree [] Tree k v
t = Tree k v
t
        retree (k
p:[k]
ps) Tree k v
t = [v] -> [(k, Tree k v)] -> Tree k v
forall k v. [v] -> [(k, Tree k v)] -> Tree k v
Tree [] [(k
p, [k] -> Tree k v -> Tree k v
retree [k]
ps Tree k v
t)]

        restore :: Step [a] -> Step a -- and restore the stepNext invariant
        restore :: Step [a] -> Step a
restore Step{[([a], [String])]
StepNext
String -> Step [a]
stepApply :: String -> Step [a]
stepNext :: StepNext
stepDone :: [([a], [String])]
stepApply :: forall a. Step a -> String -> Step a
stepNext :: forall a. Step a -> StepNext
stepDone :: forall a. Step a -> [(a, [String])]
..} = Step :: forall a.
[(a, [String])] -> StepNext -> (String -> Step a) -> Step a
Step
            {stepDone :: [(a, [String])]
stepDone = [(a
a, [String]
b) | ([a]
as,[String]
b) <- [([a], [String])]
stepDone, a
a <- [a]
as]
            ,stepNext :: StepNext
stepNext = StepNext -> StepNext
normaliseStepNext StepNext
stepNext
            ,stepApply :: String -> Step a
stepApply = Step [a] -> Step a
forall a. Step [a] -> Step a
restore (Step [a] -> Step a) -> (String -> Step [a]) -> String -> Step a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Step [a]
stepApply
            }

-- | Like 'step' but using @()@ as the tag for each 'FilePattern'.
step_ :: [FilePattern] -> Step ()
step_ :: [String] -> Step ()
step_ = [((), String)] -> Step ()
forall a. [(a, String)] -> Step a
step ([((), String)] -> Step ())
-> ([String] -> [((), String)]) -> [String] -> Step ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ((), String)) -> [String] -> [((), String)]
forall a b. (a -> b) -> [a] -> [b]
map ((),)


match1 :: Wildcard String -> String -> Maybe [String]
match1 :: Wildcard String -> String -> Maybe [String]
match1 Wildcard String
w String
x = [Either [()] String] -> [String]
forall a b. [Either a b] -> [b]
rights ([Either [()] String] -> [String])
-> Maybe [Either [()] String] -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Char -> Maybe ())
-> Wildcard String -> String -> Maybe [Either [()] String]
forall a b c.
(a -> b -> Maybe c)
-> Wildcard [a] -> [b] -> Maybe [Either [c] [b]]
wildcardMatch Char -> Char -> Maybe ()
forall a. Eq a => a -> a -> Maybe ()
equals Wildcard String
w String
x


type Parts = [String] -> [String]

-- Given a prefix of the pattern, if you can deal with it, return
-- the rest of the pattern in the prefix you didn't match, and something that given
-- a matcher for the rest of the pattern, returns a matcher for the whole pattern.
unroll :: a -> [Pat] -> Maybe ([Pat], (Parts -> Step a) -> Parts -> Step a)
-- normal path, dispatch on what you find next
unroll :: a
-> [Pat]
-> Maybe
     ([Pat],
      (([String] -> [String]) -> Step a)
      -> ([String] -> [String]) -> Step a)
unroll a
val [Pat
End] = ([Pat],
 (([String] -> [String]) -> Step a)
 -> ([String] -> [String]) -> Step a)
-> Maybe
     ([Pat],
      (([String] -> [String]) -> Step a)
      -> ([String] -> [String]) -> Step a)
forall a. a -> Maybe a
Just ([], \([String] -> [String]) -> Step a
_ [String] -> [String]
parts -> Step a
forall a. Monoid a => a
mempty{stepDone :: [(a, [String])]
stepDone = [(a
val, [String] -> [String]
parts [])]})

-- two stars in a row, the first will match nothing, the second everything
unroll a
val [Pat
StarStar,Pat
StarStar] = ([Pat],
 (([String] -> [String]) -> Step a)
 -> ([String] -> [String]) -> Step a)
-> Maybe
     ([Pat],
      (([String] -> [String]) -> Step a)
      -> ([String] -> [String]) -> Step a)
forall a. a -> Maybe a
Just ([Pat
StarStar], \([String] -> [String]) -> Step a
cont [String] -> [String]
parts -> ([String] -> [String]) -> Step a
cont ([String] -> [String]
parts ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([]String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)))

-- if you have literals next, match them
unroll a
val [Lits (Wildcard String
l:[Wildcard String]
ls)] = ([Pat],
 (([String] -> [String]) -> Step a)
 -> ([String] -> [String]) -> Step a)
-> Maybe
     ([Pat],
      (([String] -> [String]) -> Step a)
      -> ([String] -> [String]) -> Step a)
forall a. a -> Maybe a
Just ([[Wildcard String] -> Pat
Lits [Wildcard String]
ls | [Wildcard String]
ls [Wildcard String] -> [Wildcard String] -> Bool
forall a. Eq a => a -> a -> Bool
/= []], \([String] -> [String]) -> Step a
cont [String] -> [String]
parts -> Step :: forall a.
[(a, [String])] -> StepNext -> (String -> Step a) -> Step a
Step
    {stepDone :: [(a, [String])]
stepDone = []
    ,stepNext :: StepNext
stepNext = case Wildcard String
l of Literal String
v -> [String] -> StepNext
StepOnly [String
v]; Wildcard{} -> StepNext
StepUnknown
    ,stepApply :: String -> Step a
stepApply = \String
s -> case Wildcard String -> String -> Maybe [String]
match1 Wildcard String
l String
s of
        Just [String]
xs -> ([String] -> [String]) -> Step a
cont ([String] -> [String]
parts ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String]
xs[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++))
        Maybe [String]
Nothing -> Step a
forall a. Monoid a => a
mempty
    })

-- if anything else is allowed, just quickly allow it
unroll a
val [Pat
StarStar,Pat
End] = ([Pat],
 (([String] -> [String]) -> Step a)
 -> ([String] -> [String]) -> Step a)
-> Maybe
     ([Pat],
      (([String] -> [String]) -> Step a)
      -> ([String] -> [String]) -> Step a)
forall a. a -> Maybe a
Just ([], \([String] -> [String]) -> Step a
_ [String] -> [String]
parts -> ([String] -> [String]) -> [String] -> Step a
g [String] -> [String]
parts [])
    where
        g :: ([String] -> [String]) -> [String] -> Step a
g [String] -> [String]
parts [String]
rseen = Step :: forall a.
[(a, [String])] -> StepNext -> (String -> Step a) -> Step a
Step
            {stepDone :: [(a, [String])]
stepDone = [(a
val, [String] -> [String]
parts [[String] -> String
mkParts ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse [String]
rseen])]
            ,stepNext :: StepNext
stepNext = StepNext
StepEverything
            ,stepApply :: String -> Step a
stepApply = \String
s -> ([String] -> [String]) -> [String] -> Step a
g [String] -> [String]
parts (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rseen)
            }

-- if you have a specific tail prefix, find it
unroll a
val [Pat
StarStar,Lits ([Wildcard String] -> [Wildcard String]
forall a. [a] -> [a]
reverse ([Wildcard String] -> [Wildcard String])
-> ([Wildcard String] -> Int)
-> [Wildcard String]
-> ([Wildcard String], Int)
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& [Wildcard String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length -> ([Wildcard String]
rls,Int
nls)),Pat
End] = ([Pat],
 (([String] -> [String]) -> Step a)
 -> ([String] -> [String]) -> Step a)
-> Maybe
     ([Pat],
      (([String] -> [String]) -> Step a)
      -> ([String] -> [String]) -> Step a)
forall a. a -> Maybe a
Just ([], \([String] -> [String]) -> Step a
_ [String] -> [String]
parts -> ([String] -> [String]) -> Int -> [String] -> Step a
g [String] -> [String]
parts Int
0 [])
    where
        g :: ([String] -> [String]) -> Int -> [String] -> Step a
g [String] -> [String]
parts !Int
nseen [String]
rseen = Step :: forall a.
[(a, [String])] -> StepNext -> (String -> Step a) -> Step a
Step
            {stepDone :: [(a, [String])]
stepDone = case (Wildcard String -> String -> Maybe [String])
-> [Wildcard String] -> [String] -> Maybe [[String]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Wildcard String -> String -> Maybe [String]
match1 [Wildcard String]
rls [String]
rseen of
                Maybe [[String]]
_ | Int
nseen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nls -> [] -- fast path
                Just [[String]]
xss -> [(a
val, [String] -> [String]
parts ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> String
mkParts ([String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
nls [String]
rseen) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [[String]]
forall a. [a] -> [a]
reverse [[String]]
xss))]
                Maybe [[String]]
Nothing -> []
            ,stepNext :: StepNext
stepNext = StepNext
StepUnknown
            ,stepApply :: String -> Step a
stepApply = \String
s -> ([String] -> [String]) -> Int -> [String] -> Step a
g [String] -> [String]
parts (Int
nseenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rseen)
            }

-- we know the next literal, and it doesn't have any constraints immediately after
unroll a
val [Pat
StarStar,Lits [Wildcard String
l],Pat
StarStar] = ([Pat],
 (([String] -> [String]) -> Step a)
 -> ([String] -> [String]) -> Step a)
-> Maybe
     ([Pat],
      (([String] -> [String]) -> Step a)
      -> ([String] -> [String]) -> Step a)
forall a. a -> Maybe a
Just ([Pat
StarStar], \([String] -> [String]) -> Step a
cont [String] -> [String]
parts -> (([String] -> [String]) -> Step a)
-> ([String] -> [String]) -> [String] -> Step a
forall c a.
(([String] -> c) -> Step a)
-> ([String] -> c) -> [String] -> Step a
g ([String] -> [String]) -> Step a
cont [String] -> [String]
parts [])
    where
        g :: (([String] -> c) -> Step a)
-> ([String] -> c) -> [String] -> Step a
g ([String] -> c) -> Step a
cont [String] -> c
parts [String]
rseen = Step :: forall a.
[(a, [String])] -> StepNext -> (String -> Step a) -> Step a
Step
            {stepDone :: [(a, [String])]
stepDone = []
            ,stepNext :: StepNext
stepNext = StepNext
StepUnknown
            ,stepApply :: String -> Step a
stepApply = \String
s -> case Wildcard String -> String -> Maybe [String]
match1 Wildcard String
l String
s of
                Just [String]
xs -> ([String] -> c) -> Step a
cont ([String] -> c
parts ([String] -> c) -> ([String] -> [String]) -> [String] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
(++) ([String] -> String
mkParts ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
rseen) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs))
                Maybe [String]
Nothing -> (([String] -> c) -> Step a)
-> ([String] -> c) -> [String] -> Step a
g ([String] -> c) -> Step a
cont [String] -> c
parts (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rseen)
            }

-- the hard case, a floating substring, accumulate at least N, then star testing in reverse
unroll a
val [Pat
StarStar,Lits ([Wildcard String] -> [Wildcard String]
forall a. [a] -> [a]
reverse ([Wildcard String] -> [Wildcard String])
-> ([Wildcard String] -> Int)
-> [Wildcard String]
-> ([Wildcard String], Int)
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& [Wildcard String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length -> ([Wildcard String]
rls,Int
nls)),Pat
StarStar] = ([Pat],
 (([String] -> [String]) -> Step a)
 -> ([String] -> [String]) -> Step a)
-> Maybe
     ([Pat],
      (([String] -> [String]) -> Step a)
      -> ([String] -> [String]) -> Step a)
forall a. a -> Maybe a
Just ([Pat
StarStar], \([String] -> [String]) -> Step a
cont [String] -> [String]
parts -> (([String] -> [String]) -> Step a)
-> ([String] -> [String]) -> Int -> [String] -> Step a
forall c a.
(([String] -> c) -> Step a)
-> ([String] -> c) -> Int -> [String] -> Step a
g ([String] -> [String]) -> Step a
cont [String] -> [String]
parts Int
0 [])
    where
        g :: (([String] -> c) -> Step a)
-> ([String] -> c) -> Int -> [String] -> Step a
g ([String] -> c) -> Step a
cont [String] -> c
parts !Int
nseen [String]
rseen = Step :: forall a.
[(a, [String])] -> StepNext -> (String -> Step a) -> Step a
Step
            {stepDone :: [(a, [String])]
stepDone = []
            ,stepNext :: StepNext
stepNext = StepNext
StepUnknown
            ,stepApply :: String -> Step a
stepApply = \String
s -> case (Wildcard String -> String -> Maybe [String])
-> [Wildcard String] -> [String] -> Maybe [[String]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Wildcard String -> String -> Maybe [String]
match1 [Wildcard String]
rls (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rseen) of
                Maybe [[String]]
_ | Int
nseenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nls -> (([String] -> c) -> Step a)
-> ([String] -> c) -> Int -> [String] -> Step a
g ([String] -> c) -> Step a
cont [String] -> c
parts (Int
nseenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rseen) -- not enough accumulated yet
                Maybe [[String]]
Nothing -> (([String] -> c) -> Step a)
-> ([String] -> c) -> Int -> [String] -> Step a
g ([String] -> c) -> Step a
cont [String] -> c
parts (Int
nseenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rseen)
                Just [[String]]
xss -> ([String] -> c) -> Step a
cont ([String] -> c
parts ([String] -> c) -> ([String] -> [String]) -> [String] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
(++) ([String] -> String
mkParts ([String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
nls ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rseen) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [[String]]
forall a. [a] -> [a]
reverse [[String]]
xss)))
            }

unroll a
_ [Pat]
_ = Maybe
  ([Pat],
   (([String] -> [String]) -> Step a)
   -> ([String] -> [String]) -> Step a)
forall a. Maybe a
Nothing