{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards, ViewPatterns, TupleSections #-}
module Development.Shake.Internal.FilePattern(
FilePattern, (?==), (<//>),
filePattern,
simple, (?==*),
compatible, extract, substitute,
Walk(..), walk,
internalTest, isRelativePath, isRelativePattern
) where
import Development.Shake.Internal.Errors
import System.FilePath(isPathSeparator)
import Data.List.Extra
import Control.Monad
import Data.Char
import Data.Maybe
import System.Info.Extra
type FilePattern = String
infixr 5 <//>
(<//>) :: FilePattern -> FilePattern -> FilePattern
String
a <//> :: String -> String -> String
<//> String
b = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isPathSeparator String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"//" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isPathSeparator String
b
data Pat = Lit String
| Star
| Skip
| Skip1
| Stars String [String] String
deriving (Int -> Pat -> String -> String
[Pat] -> String -> String
Pat -> String
(Int -> Pat -> String -> String)
-> (Pat -> String) -> ([Pat] -> String -> String) -> Show Pat
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Pat -> String -> String
showsPrec :: Int -> Pat -> String -> String
$cshow :: Pat -> String
show :: Pat -> String
$cshowList :: [Pat] -> String -> String
showList :: [Pat] -> String -> String
Show,Pat -> Pat -> Bool
(Pat -> Pat -> Bool) -> (Pat -> Pat -> Bool) -> Eq Pat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pat -> Pat -> Bool
== :: Pat -> Pat -> Bool
$c/= :: Pat -> Pat -> Bool
/= :: 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
$ccompare :: Pat -> Pat -> Ordering
compare :: Pat -> Pat -> Ordering
$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
>= :: Pat -> Pat -> Bool
$cmax :: Pat -> Pat -> Pat
max :: Pat -> Pat -> Pat
$cmin :: Pat -> Pat -> Pat
min :: Pat -> Pat -> Pat
Ord)
fromLit :: Pat -> Maybe String
fromLit :: Pat -> Maybe String
fromLit (Lit String
x) = String -> Maybe String
forall a. a -> Maybe a
Just String
x
fromLit Pat
_ = Maybe String
forall a. Maybe a
Nothing
data Lexeme = Str String | Slash | SlashSlash
lexer :: FilePattern -> [Lexeme]
lexer :: String -> [Lexeme]
lexer String
"" = []
lexer (Char
x1:Char
x2:String
xs) | Char -> Bool
isPathSeparator Char
x1, Char -> Bool
isPathSeparator Char
x2 = Lexeme
SlashSlash Lexeme -> [Lexeme] -> [Lexeme]
forall a. a -> [a] -> [a]
: String -> [Lexeme]
lexer String
xs
lexer (Char
x1:String
xs) | Char -> Bool
isPathSeparator Char
x1 = Lexeme
Slash Lexeme -> [Lexeme] -> [Lexeme]
forall a. a -> [a] -> [a]
: String -> [Lexeme]
lexer String
xs
lexer String
xs = String -> Lexeme
Str String
a Lexeme -> [Lexeme] -> [Lexeme]
forall a. a -> [a] -> [a]
: String -> [Lexeme]
lexer String
b
where (String
a,String
b) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isPathSeparator String
xs
parse :: FilePattern -> [Pat]
parse :: String -> [Pat]
parse = Bool -> Bool -> [Lexeme] -> [Pat]
f Bool
False Bool
True ([Lexeme] -> [Pat]) -> (String -> [Lexeme]) -> String -> [Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Lexeme]
lexer
where
f :: Bool -> Bool -> [Lexeme] -> [Pat]
f Bool
str Bool
slash = \case
[] -> [String -> Pat
Lit String
"" | Bool
slash]
Str String
"**":[Lexeme]
xs -> Pat
Skip Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
: Bool -> Bool -> [Lexeme] -> [Pat]
f Bool
True Bool
False [Lexeme]
xs
Str String
x:[Lexeme]
xs -> String -> Pat
parseLit String
x Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
: Bool -> Bool -> [Lexeme] -> [Pat]
f Bool
True Bool
False [Lexeme]
xs
Lexeme
SlashSlash:Lexeme
Slash:[Lexeme]
xs | Bool -> Bool
not Bool
str -> Pat
Skip1 Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
: Bool -> Bool -> [Lexeme] -> [Pat]
f Bool
str Bool
True [Lexeme]
xs
Lexeme
SlashSlash:[Lexeme]
xs -> Pat
Skip Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
: Bool -> Bool -> [Lexeme] -> [Pat]
f Bool
str Bool
False [Lexeme]
xs
Lexeme
Slash:[Lexeme]
xs -> [String -> Pat
Lit String
"" | Bool -> Bool
not Bool
str] [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ Bool -> Bool -> [Lexeme] -> [Pat]
f Bool
str Bool
True [Lexeme]
xs
parseLit :: String -> Pat
parseLit :: String -> Pat
parseLit String
"*" = Pat
Star
parseLit String
x = case (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*') String
x of
[String
x] -> String -> Pat
Lit String
x
String
pre:[String]
xs | Just ([String]
mid,String
post) <- [String] -> Maybe ([String], String)
forall a. [a] -> Maybe ([a], a)
unsnoc [String]
xs -> String -> [String] -> String -> Pat
Stars String
pre [String]
mid String
post
[String]
_ -> String -> Pat
Lit String
""
internalTest :: IO ()
internalTest :: IO ()
internalTest = do
let String
x # :: String -> [Pat] -> f ()
# [Pat]
y =
let p :: [Pat]
p = String -> [Pat]
parse String
x
in Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Pat]
p [Pat] -> [Pat] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Pat]
y) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ String -> f ()
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f ()) -> String -> f ()
forall a b. (a -> b) -> a -> b
$ (String, String, [Pat], [Pat]) -> String
forall a. Show a => a -> String
show (String
"FilePattern.internalTest",String
x,[Pat]
p,[Pat]
y)
String
"" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
""]
String
"x" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x"]
String
"/" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"",String -> Pat
Lit String
""]
String
"x/" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x",String -> Pat
Lit String
""]
String
"/x" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"",String -> Pat
Lit String
"x"]
String
"x/y" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x",String -> Pat
Lit String
"y"]
String
"//" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip]
String
"**" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip]
String
"//x" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip, String -> Pat
Lit String
"x"]
String
"**/x" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip, String -> Pat
Lit String
"x"]
String
"x//" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x", Pat
Skip]
String
"x/**" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x", Pat
Skip]
String
"x//y" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x",Pat
Skip, String -> Pat
Lit String
"y"]
String
"x/**/y" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x",Pat
Skip, String -> Pat
Lit String
"y"]
String
"///" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip1, String -> Pat
Lit String
""]
String
"**/**" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip,Pat
Skip]
String
"**/**/" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip, Pat
Skip, String -> Pat
Lit String
""]
String
"///x" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip1, String -> Pat
Lit String
"x"]
String
"**/x" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip, String -> Pat
Lit String
"x"]
String
"x///" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x", Pat
Skip, String -> Pat
Lit String
""]
String
"x/**/" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x", Pat
Skip, String -> Pat
Lit String
""]
String
"x///y" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x",Pat
Skip, String -> Pat
Lit String
"y"]
String
"x/**/y" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x",Pat
Skip, String -> Pat
Lit String
"y"]
String
"////" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip, Pat
Skip]
String
"**/**/**" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip, Pat
Skip, Pat
Skip]
String
"////x" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip, Pat
Skip, String -> Pat
Lit String
"x"]
String
"x////" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x", Pat
Skip, Pat
Skip]
String
"x////y" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [String -> Pat
Lit String
"x",Pat
Skip, Pat
Skip, String -> Pat
Lit String
"y"]
String
"**//x" String -> [Pat] -> IO ()
forall {f :: * -> *}. MonadFail f => String -> [Pat] -> f ()
# [Pat
Skip, Pat
Skip, String -> Pat
Lit String
"x"]
optimise :: [Pat] -> [Pat]
optimise :: [Pat] -> [Pat]
optimise (Pat
Skip:Pat
Skip:[Pat]
xs) = [Pat] -> [Pat]
optimise ([Pat] -> [Pat]) -> [Pat] -> [Pat]
forall a b. (a -> b) -> a -> b
$ Pat
SkipPat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:[Pat]
xs
optimise (Pat
Skip:Pat
Star:[Pat]
xs) = [Pat] -> [Pat]
optimise ([Pat] -> [Pat]) -> [Pat] -> [Pat]
forall a b. (a -> b) -> a -> b
$ Pat
Skip1Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:[Pat]
xs
optimise (Pat
Star:Pat
Skip:[Pat]
xs) = [Pat] -> [Pat]
optimise ([Pat] -> [Pat]) -> [Pat] -> [Pat]
forall a b. (a -> b) -> a -> b
$ Pat
Skip1Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:[Pat]
xs
optimise (Pat
x:[Pat]
xs) = Pat
x Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
: [Pat] -> [Pat]
optimise [Pat]
xs
optimise [] =[]
isRelativePattern :: FilePattern -> Bool
isRelativePattern :: String -> Bool
isRelativePattern (Char
'*':Char
'*':String
xs)
| [] <- String
xs = Bool
True
| Char
x:String
_ <- String
xs, Char -> Bool
isPathSeparator Char
x = Bool
True
isRelativePattern String
_ = Bool
False
isRelativePath :: FilePath -> Bool
isRelativePath :: String -> Bool
isRelativePath (Char
x:String
_) | Char -> Bool
isPathSeparator Char
x = Bool
False
isRelativePath (Char
x:Char
':':String
_) | Bool
isWindows, Char -> Bool
isAlpha Char
x = Bool
False
isRelativePath String
_ = Bool
True
match :: [Pat] -> [String] -> [[String]]
match :: [Pat] -> [String] -> [[String]]
match (Pat
Skip:[Pat]
xs) (String
y:[String]
ys) = ([String] -> [String]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (String
""String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([Pat] -> [String] -> [[String]]
match [Pat]
xs (String
yString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ys)) [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ [Pat] -> [String] -> [[String]]
match (Pat
Skip1Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:[Pat]
xs) (String
yString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ys)
match (Pat
Skip1:[Pat]
xs) (String
y:[String]
ys) = [(String
yString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"/"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
r)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rs | String
r:[String]
rs <- [Pat] -> [String] -> [[String]]
match (Pat
SkipPat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:[Pat]
xs) [String]
ys]
match (Pat
Skip:[Pat]
xs) [] = ([String] -> [String]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (String
""String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([[String]] -> [[String]]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> a -> b
$ [Pat] -> [String] -> [[String]]
match [Pat]
xs []
match (Pat
Star:[Pat]
xs) (String
y:[String]
ys) = ([String] -> [String]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (String
yString -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([[String]] -> [[String]]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> a -> b
$ [Pat] -> [String] -> [[String]]
match [Pat]
xs [String]
ys
match (Lit String
x:[Pat]
xs) (String
y:[String]
ys) = [[[String]]] -> [[String]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[String]]] -> [[String]]) -> [[[String]]] -> [[String]]
forall a b. (a -> b) -> a -> b
$ [[Pat] -> [String] -> [[String]]
match [Pat]
xs [String]
ys | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y] [[[String]]] -> [[[String]]] -> [[[String]]]
forall a. [a] -> [a] -> [a]
++ [[Pat] -> [String] -> [[String]]
match [Pat]
xs (String
yString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ys) | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"."]
match (x :: Pat
x@Stars{}:[Pat]
xs) (String
y:[String]
ys) | Just [String]
rs <- Pat -> String -> Maybe [String]
matchStars Pat
x String
y = ([String] -> [String]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ([String]
rs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++) ([[String]] -> [[String]]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> a -> b
$ [Pat] -> [String] -> [[String]]
match [Pat]
xs [String]
ys
match [] [] = [[]]
match [Pat]
_ [String]
_ = []
matchOne :: Pat -> String -> Bool
matchOne :: Pat -> String -> Bool
matchOne (Lit String
x) String
y = String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y
matchOne x :: Pat
x@Stars{} String
y = Maybe [String] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [String] -> Bool) -> Maybe [String] -> Bool
forall a b. (a -> b) -> a -> b
$ Pat -> String -> Maybe [String]
matchStars Pat
x String
y
matchOne Pat
Star String
_ = Bool
True
matchOne Pat
p String
_ = SomeException -> Bool
forall a. SomeException -> a
throwImpure (SomeException -> Bool) -> SomeException -> Bool
forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
String -> SomeException
errorInternal (String -> SomeException) -> String -> SomeException
forall a b. (a -> b) -> a -> b
$ String
"unreachablePattern, matchOne " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pat -> String
forall a. Show a => a -> String
show Pat
p
matchStars :: Pat -> String -> Maybe [String]
matchStars :: Pat -> String -> Maybe [String]
matchStars (Stars String
pre [String]
mid String
post) String
x = do
String
x <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
pre String
x
String
x <- if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
post then String -> Maybe String
forall a. a -> Maybe a
Just String
x else String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
post String
x
[String] -> String -> Maybe [String]
forall {a}. Eq a => [[a]] -> [a] -> Maybe [[a]]
stripInfixes [String]
mid String
x
where
stripInfixes :: [[a]] -> [a] -> Maybe [[a]]
stripInfixes [] [a]
x = [[a]] -> Maybe [[a]]
forall a. a -> Maybe a
Just [[a]
x]
stripInfixes ([a]
m:[[a]]
ms) [a]
x = do
([a]
a,[a]
x) <- [a] -> [a] -> Maybe ([a], [a])
forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
stripInfix [a]
m [a]
x
([a]
a[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:) ([[a]] -> [[a]]) -> Maybe [[a]] -> Maybe [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[a]] -> [a] -> Maybe [[a]]
stripInfixes [[a]]
ms [a]
x
matchStars Pat
p String
_ = SomeException -> Maybe [String]
forall a. SomeException -> a
throwImpure (SomeException -> Maybe [String])
-> SomeException -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
String -> SomeException
errorInternal (String -> SomeException) -> String -> SomeException
forall a b. (a -> b) -> a -> b
$ String
"unreachablePattern, matchStars " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pat -> String
forall a. Show a => a -> String
show Pat
p
(?==) :: FilePattern -> FilePath -> Bool
?== :: String -> String -> Bool
(?==) String
p = case [Pat] -> [Pat]
optimise ([Pat] -> [Pat]) -> [Pat] -> [Pat]
forall a b. (a -> b) -> a -> b
$ String -> [Pat]
parse String
p of
[Pat
x] | Pat
x Pat -> Pat -> Bool
forall a. Eq a => a -> a -> Bool
== Pat
Skip Bool -> Bool -> Bool
|| Pat
x Pat -> Pat -> Bool
forall a. Eq a => a -> a -> Bool
== Pat
Skip1 -> if Bool
rp then String -> Bool
isRelativePath else Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
True
[Pat]
p -> let f :: String -> Bool
f = Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[String]] -> Bool) -> (String -> [[String]]) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> [String] -> [[String]]
match [Pat]
p ([String] -> [[String]])
-> (String -> [String]) -> String -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
split Char -> Bool
isPathSeparator
in if Bool
rp then (\String
x -> String -> Bool
isRelativePath String
x Bool -> Bool -> Bool
&& String -> Bool
f String
x) else String -> Bool
f
where rp :: Bool
rp = String -> Bool
isRelativePattern String
p
(?==*) :: [FilePattern] -> FilePath -> Bool
?==* :: [String] -> String -> Bool
(?==*) [String]
ps = \String
x -> ((String -> Bool) -> Bool) -> [String -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
x) [String -> Bool]
vs
where vs :: [String -> Bool]
vs = (String -> String -> Bool) -> [String] -> [String -> Bool]
forall a b. (a -> b) -> [a] -> [b]
map String -> String -> Bool
(?==) [String]
ps
filePattern :: FilePattern -> FilePath -> Maybe [String]
filePattern :: String -> String -> Maybe [String]
filePattern String
p = \String
x -> if String -> Bool
eq String
x then [String] -> Maybe [String]
forall a. a -> Maybe a
Just ([String] -> Maybe [String]) -> [String] -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
ex String
x else Maybe [String]
forall a. Maybe a
Nothing
where eq :: String -> Bool
eq = String -> String -> Bool
(?==) String
p
ex :: String -> [String]
ex = String -> String -> [String]
extract String
p
specials :: FilePattern -> [Pat]
specials :: String -> [Pat]
specials = (Pat -> [Pat]) -> [Pat] -> [Pat]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pat -> [Pat]
f ([Pat] -> [Pat]) -> (String -> [Pat]) -> String -> [Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Pat]
parse
where
f :: Pat -> [Pat]
f Lit{} = []
f Pat
Star = [Pat
Star]
f Pat
Skip = [Pat
Skip]
f Pat
Skip1 = [Pat
Skip]
f (Stars String
_ [String]
xs String
_) = Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Pat
Star
simple :: FilePattern -> Bool
simple :: String -> Bool
simple = [Pat] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Pat] -> Bool) -> (String -> [Pat]) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Pat]
specials
compatible :: [FilePattern] -> Bool
compatible :: [String] -> Bool
compatible [] = Bool
True
compatible (String
x:[String]
xs) = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Pat] -> [Pat] -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> [Pat]
specials String
x) ([Pat] -> Bool) -> (String -> [Pat]) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Pat]
specials) [String]
xs
extract :: FilePattern -> FilePath -> [String]
String
p = let pat :: [Pat]
pat = String -> [Pat]
parse String
p in \String
x ->
case [Pat] -> [String] -> [[String]]
match [Pat]
pat ((Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
split Char -> Bool
isPathSeparator String
x) of
[] | String
p String -> String -> Bool
?== String
x -> SomeException -> [String]
forall a. SomeException -> a
throwImpure (SomeException -> [String]) -> SomeException -> [String]
forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
String -> SomeException
errorInternal (String -> SomeException) -> String -> SomeException
forall a b. (a -> b) -> a -> b
$ String
"extract with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
x
| Bool
otherwise -> String -> [String]
forall a. Partial => String -> a
error (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
"Pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not match " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", when trying to extract the FilePattern matches"
[String]
ms:[[String]]
_ -> [String]
ms
substitute :: [String] -> FilePattern -> FilePath
substitute :: [String] -> String -> String
substitute [String]
oms String
oxs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String], [[String]]) -> [[String]]
forall a b. (a, b) -> b
snd (([String], [[String]]) -> [[String]])
-> ([String], [[String]]) -> [[String]]
forall a b. (a -> b) -> a -> b
$ ([String] -> Pat -> ([String], [String]))
-> [String] -> [Pat] -> ([String], [[String]])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL [String] -> Pat -> ([String], [String])
f [String]
oms (String -> [Pat]
parse String
oxs)
where
f :: [String] -> Pat -> ([String], [String])
f [String]
ms (Lit String
x) = ([String]
ms, [String
x])
f (String
m:[String]
ms) Pat
Star = ([String]
ms, [String
m])
f (String
m:[String]
ms) Pat
Skip = ([String]
ms, String -> [String]
split String
m)
f (String
m:[String]
ms) Pat
Skip1 = ([String]
ms, String -> [String]
split String
m)
f [String]
ms (Stars String
pre [String]
mid String
post) = ([String]
ms2, [[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
pre String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> String
forall a. [a] -> [a] -> [a]
(++) [String]
ms1 ([String]
mid[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String
post])])
where ([String]
ms1,[String]
ms2) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
mid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [String]
ms
f [String]
_ Pat
_ = String -> ([String], [String])
forall a. Partial => String -> a
error (String -> ([String], [String])) -> String -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ String
"Substitution failed into pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
oxs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
oms) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" matches, namely " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
oms
split :: String -> [String]
split = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
linesBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')
data Walk = Walk ([String] -> ([String],[(String,Walk)]))
| WalkTo ([String],[(String,Walk)])
walk :: [FilePattern] -> (Bool, Walk)
walk :: [String] -> (Bool, Walk)
walk [String]
ps = (([Pat] -> Bool) -> [[Pat]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\[Pat]
p -> [Pat] -> Bool
isEmpty [Pat]
p Bool -> Bool -> Bool
|| Bool -> Bool
not ([[String]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[String]] -> Bool) -> [[String]] -> Bool
forall a b. (a -> b) -> a -> b
$ [Pat] -> [String] -> [[String]]
match [Pat]
p [String
""])) [[Pat]]
ps2, [[Pat]] -> Walk
f [[Pat]]
ps2)
where
ps2 :: [[Pat]]
ps2 = (String -> [Pat]) -> [String] -> [[Pat]]
forall a b. (a -> b) -> [a] -> [b]
map ((Pat -> Bool) -> [Pat] -> [Pat]
forall a. (a -> Bool) -> [a] -> [a]
filter (Pat -> Pat -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> Pat
Lit String
".") ([Pat] -> [Pat]) -> (String -> [Pat]) -> String -> [Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> [Pat]
optimise ([Pat] -> [Pat]) -> (String -> [Pat]) -> String -> [Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Pat]
parse) [String]
ps
f :: [[Pat]] -> Walk
f ([[Pat]] -> [[Pat]]
forall a. Ord a => [a] -> [a]
nubOrd -> [[Pat]]
ps)
| Just [String]
fin <- (Pat -> Maybe String) -> [Pat] -> Maybe [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pat -> Maybe String
fromLit [Pat]
fin
, Just [(String, Walk)]
nxt <- ((Pat, [[Pat]]) -> Maybe (String, Walk))
-> [(Pat, [[Pat]])] -> Maybe [(String, Walk)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Pat
a,[[Pat]]
b) -> (,[[Pat]] -> Walk
f [[Pat]]
b) (String -> (String, Walk)) -> Maybe String -> Maybe (String, Walk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> Maybe String
fromLit Pat
a) [(Pat, [[Pat]])]
nxt
= ([String], [(String, Walk)]) -> Walk
WalkTo ([String]
fin, [(String, Walk)]
nxt)
| Bool
otherwise = ([String] -> ([String], [(String, Walk)])) -> Walk
Walk (([String] -> ([String], [(String, Walk)])) -> Walk)
-> ([String] -> ([String], [(String, Walk)])) -> Walk
forall a b. (a -> b) -> a -> b
$ \[String]
xs ->
(if Bool
finStar then [String]
xs else (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
x -> (Pat -> Bool) -> [Pat] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Pat -> String -> Bool
`matchOne` String
x) [Pat]
fin) [String]
xs
,[(String
x, [[Pat]] -> Walk
f [[Pat]]
ys) | String
x <- [String]
xs, let ys :: [[Pat]]
ys = [[[Pat]]] -> [[Pat]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Pat]]
b | (Pat
a,[[Pat]]
b) <- [(Pat, [[Pat]])]
nxt, Pat -> String -> Bool
matchOne Pat
a String
x], Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [[Pat]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Pat]]
ys])
where
finStar :: Bool
finStar = Pat
Star Pat -> [Pat] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Pat]
fin
fin :: [Pat]
fin = [Pat] -> [Pat]
forall a. Ord a => [a] -> [a]
nubOrd ([Pat] -> [Pat]) -> [Pat] -> [Pat]
forall a b. (a -> b) -> a -> b
$ ([Pat] -> Maybe Pat) -> [[Pat]] -> [Pat]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Pat] -> Maybe Pat
final [[Pat]]
ps
nxt :: [(Pat, [[Pat]])]
nxt = [(Pat, [Pat])] -> [(Pat, [[Pat]])]
forall k v. Ord k => [(k, v)] -> [(k, [v])]
groupSort ([(Pat, [Pat])] -> [(Pat, [[Pat]])])
-> [(Pat, [Pat])] -> [(Pat, [[Pat]])]
forall a b. (a -> b) -> a -> b
$ ([Pat] -> [(Pat, [Pat])]) -> [[Pat]] -> [(Pat, [Pat])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Pat] -> [(Pat, [Pat])]
next [[Pat]]
ps
next :: [Pat] -> [(Pat, [Pat])]
next :: [Pat] -> [(Pat, [Pat])]
next (Pat
Skip1:[Pat]
xs) = [(Pat
Star,Pat
SkipPat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:[Pat]
xs)]
next (Pat
Skip:[Pat]
xs) = (Pat
Star,Pat
SkipPat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:[Pat]
xs) (Pat, [Pat]) -> [(Pat, [Pat])] -> [(Pat, [Pat])]
forall a. a -> [a] -> [a]
: [Pat] -> [(Pat, [Pat])]
next [Pat]
xs
next (Pat
x:[Pat]
xs) = [(Pat
x,[Pat]
xs) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Pat] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pat]
xs]
next [] = []
final :: [Pat] -> Maybe Pat
final :: [Pat] -> Maybe Pat
final (Pat
Skip:[Pat]
xs) = if [Pat] -> Bool
isEmpty [Pat]
xs then Pat -> Maybe Pat
forall a. a -> Maybe a
Just Pat
Star else [Pat] -> Maybe Pat
final [Pat]
xs
final (Pat
Skip1:[Pat]
xs) = if [Pat] -> Bool
isEmpty [Pat]
xs then Pat -> Maybe Pat
forall a. a -> Maybe a
Just Pat
Star else Maybe Pat
forall a. Maybe a
Nothing
final (Pat
x:[Pat]
xs) = if [Pat] -> Bool
isEmpty [Pat]
xs then Pat -> Maybe Pat
forall a. a -> Maybe a
Just Pat
x else Maybe Pat
forall a. Maybe a
Nothing
final [] = Maybe Pat
forall a. Maybe a
Nothing
isEmpty :: [Pat] -> Bool
isEmpty = (Pat -> Bool) -> [Pat] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Pat -> Pat -> Bool
forall a. Eq a => a -> a -> Bool
== Pat
Skip)