module Development.Shake.FilePattern(
FilePattern, (?==),
compatible, simple, extract, substitute,
directories, directories1
) where
import System.FilePath(pathSeparators)
import Data.List
import Control.Arrow
import General.Base
type FilePattern = String
data Lexeme = Star | SlashSlash | Char Char deriving (Show, Eq)
isChar (Char _) = True; isChar _ = False
isDull (Char x) = x /= '/'; isDull _ = False
fromChar (Char x) = x
data Regex = Lit [Char] | Not [Char] | Any
| Start | End
| Bracket Regex
| Or Regex Regex | Concat Regex Regex
| Repeat Regex | Empty
deriving Show
type SString = (Bool, String)
lexer :: FilePattern -> [Lexeme]
lexer ('*':xs) = Star : lexer xs
lexer ('/':'/':xs) = SlashSlash : lexer xs
lexer (x:xs) = Char x : lexer xs
lexer [] = []
pattern :: [Lexeme] -> Regex
pattern = Concat Start . foldr Concat End . map f
where
f Star = Bracket $ Repeat $ Not pathSeparators
f SlashSlash = let s = Start `Or` End `Or` Lit pathSeparators in Bracket $
Or (s `Concat` Repeat Any `Concat` s) (Lit pathSeparators)
f (Char x) = Lit $ if x == '/' then pathSeparators else [x]
match :: Regex -> SString -> [([String], String, SString)]
match (Lit l) (_, x:xs) | x `elem` l = [([], [x], (False, xs))]
match (Not l) (_, x:xs) | x `notElem` l = [([], [x], (False, xs))]
match Any (_, x:xs) = [([], [x], (False, xs))]
match Start (True, xs) = [([], [], (True, xs))]
match End (s, []) = [([], [], (s, []))]
match (Bracket r) xs = [(a ++ [b], b, c) | (a,b,c) <- match r xs]
match (Or r1 r2) xs = match r1 xs ++ match r2 xs
match (Concat r1 r2) xs = [(a1++a2,b1++b2,c2) | (a1,b1,c1) <- match r1 xs, (a2,b2,c2) <- match r2 c1]
match (Repeat r) xs = match (Empty `Or` Concat r (Repeat r)) xs
match Empty xs = [([], "", xs)]
match _ _ = []
(?==) :: FilePattern -> FilePath -> Bool
(?==) "//*" = const True
(?==) p = \x -> not $ null $ match pat (True, x)
where pat = pattern $ lexer p
directories1 :: FilePattern -> (FilePath, Bool)
directories1 = first (intercalate "/") . f . lexer
where
f xs | (a@(_:_),b:bs) <- span isDull xs, b `elem` [Char '/',SlashSlash] =
if b == SlashSlash then ([map fromChar a],True) else first (map fromChar a:) $ f bs
| all (\x -> isDull x || x == Star) xs = ([],False)
| otherwise = ([], True)
directories :: [FilePattern] -> [(FilePath,Bool)]
directories ps = foldl f xs xs
where
xs = fastNub $ map directories1 ps
f xs (x,True) = filter (\y -> not $ (x,False) == y || (x ++ "/") `isPrefixOf` fst y) xs
f xs _ = xs
simple :: FilePattern -> Bool
simple = all isChar . lexer
compatible :: [FilePattern] -> Bool
compatible [] = True
compatible (x:xs) = all ((==) (f x) . f) xs
where f = filter (not . isChar) . lexer
extract :: FilePattern -> FilePath -> [String]
extract p x = ms
where (ms,_,_):_ = match (pattern $ lexer p) (True,x)
substitute :: [String] -> FilePattern -> FilePath
substitute ms p = f ms (lexer p)
where
f ms (Char p:ps) = p : f ms ps
f (m:ms) (_:ps) = m ++ f ms ps
f [] [] = []
f _ _ = error $ "Substitution failed into pattern " ++ show p ++ " with " ++ show (length ms) ++ " matches, namely " ++ show ms