-- |
-- Module:      System.FilePath.GlobPattern
-- Copyright:   Bryan O'Sullivan
-- License:     BSD3
-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>
-- Stability:   unstable
-- Portability: everywhere
module System.FilePath.GlobPattern (
    -- * Glob patterns
    -- $syntax
      GlobPattern
    -- * Matching functions
    , (~~)
    , (/~)
    ) where

import Control.Arrow (second)
import Control.Monad (msum)
import Data.Ix (Ix, inRange)
import Data.List (nub)
import Data.Maybe (isJust)
import System.FilePath (pathSeparator)

-- $syntax
--
-- Basic glob pattern syntax is the same as for the Unix shell
-- environment.
-- 
-- * @*@ matches everything up to a directory separator or end of
-- string.
--
-- * @[/range/]@ matches any character in /range/.
-- 
-- * @[!/range/]@ matches any character /not/ in /range/.
-- 
-- There are three extensions to the traditional glob syntax, taken
-- from modern Unix shells.
--
-- * @\\@ escapes a character that might otherwise have special
-- meaning.  For a literal @\"\\\"@ character, use @\"\\\\\"@.
-- 
-- * @**@ matches everything, including a directory separator.
-- 
-- * @(/s1/|/s2/|/.../)@ matches any of the strings /s1/, /s2/, etc.

-- | Glob pattern type.
type GlobPattern = String

spanClass :: Char -> String -> (String, String)

spanClass :: Char -> String -> (String, String)
spanClass c :: Char
c = String -> String -> (String, String)
gs []
    where gs :: String -> String -> (String, String)
gs _ [] = String -> (String, String)
forall a. HasCallStack => String -> a
error "unterminated character class"
          gs acc :: String
acc (d :: Char
d:ds :: String
ds) | Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c = (String -> String
forall a. [a] -> [a]
reverse String
acc, String
ds)
                        | Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\\' = case String
ds of
                                     (e :: Char
e:es :: String
es) -> String -> String -> (String, String)
gs (Char
eChar -> String -> String
forall a. a -> [a] -> [a]
:'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:String
acc) String
es
                                     _ -> String -> (String, String)
forall a. HasCallStack => String -> a
error "unterminated escape"
                        | Bool
otherwise = String -> String -> (String, String)
gs (Char
dChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) String
ds

data Ix a => SRange a = SRange [a] [(a, a)]
                      deriving (Int -> SRange a -> String -> String
[SRange a] -> String -> String
SRange a -> String
(Int -> SRange a -> String -> String)
-> (SRange a -> String)
-> ([SRange a] -> String -> String)
-> Show (SRange a)
forall a. (Ix a, Show a) => Int -> SRange a -> String -> String
forall a. (Ix a, Show a) => [SRange a] -> String -> String
forall a. (Ix a, Show a) => SRange a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SRange a] -> String -> String
$cshowList :: forall a. (Ix a, Show a) => [SRange a] -> String -> String
show :: SRange a -> String
$cshow :: forall a. (Ix a, Show a) => SRange a -> String
showsPrec :: Int -> SRange a -> String -> String
$cshowsPrec :: forall a. (Ix a, Show a) => Int -> SRange a -> String -> String
Show)

inSRange :: Ix a => a -> SRange a -> Bool

inSRange :: a -> SRange a -> Bool
inSRange c :: a
c (SRange d :: [a]
d s :: [(a, a)]
s) = a
c a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
d Bool -> Bool -> Bool
|| ((a, a) -> Bool) -> [(a, a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (((a, a) -> a -> Bool) -> a -> (a, a) -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a, a) -> a -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange a
c) [(a, a)]
s

type CharClass = SRange Char

makeClass :: String -> CharClass

makeClass :: String -> CharClass
makeClass = [(Char, Char)] -> String -> String -> CharClass
makeClass' [] []
    where makeClass' :: [(Char, Char)] -> [Char] -> String -> CharClass
          makeClass' :: [(Char, Char)] -> String -> String -> CharClass
makeClass' dense :: [(Char, Char)]
dense sparse :: String
sparse [] = String -> [(Char, Char)] -> CharClass
forall a. [a] -> [(a, a)] -> SRange a
SRange String
sparse [(Char, Char)]
dense
          makeClass' dense :: [(Char, Char)]
dense sparse :: String
sparse (a :: Char
a:'-':b :: Char
b:cs :: String
cs) =
              [(Char, Char)] -> String -> String -> CharClass
makeClass' ((Char
a,Char
b)(Char, Char) -> [(Char, Char)] -> [(Char, Char)]
forall a. a -> [a] -> [a]
:[(Char, Char)]
dense) String
sparse String
cs
          makeClass' dense :: [(Char, Char)]
dense sparse :: String
sparse (c :: Char
c:cs :: String
cs) = [(Char, Char)] -> String -> String -> CharClass
makeClass' [(Char, Char)]
dense (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
sparse) String
cs

data MatchTerm = MatchLiteral String
               | MatchAny
               | MatchDir
               | MatchChar
               | MatchClass Bool CharClass
               | MatchGroup [String]
                 deriving (Int -> MatchTerm -> String -> String
[MatchTerm] -> String -> String
MatchTerm -> String
(Int -> MatchTerm -> String -> String)
-> (MatchTerm -> String)
-> ([MatchTerm] -> String -> String)
-> Show MatchTerm
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [MatchTerm] -> String -> String
$cshowList :: [MatchTerm] -> String -> String
show :: MatchTerm -> String
$cshow :: MatchTerm -> String
showsPrec :: Int -> MatchTerm -> String -> String
$cshowsPrec :: Int -> MatchTerm -> String -> String
Show)

parseGlob :: GlobPattern -> [MatchTerm]
             
parseGlob :: String -> [MatchTerm]
parseGlob [] = []
parseGlob ('*':'*':cs :: String
cs) = MatchTerm
MatchAny MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: String -> [MatchTerm]
parseGlob String
cs
parseGlob ('*':cs :: String
cs) = MatchTerm
MatchDir MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: String -> [MatchTerm]
parseGlob String
cs
parseGlob ('?':cs :: String
cs) = MatchTerm
MatchChar MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: String -> [MatchTerm]
parseGlob String
cs
parseGlob ('[':cs :: String
cs) = let (cc :: String
cc, ccs :: String
ccs) = Char -> String -> (String, String)
spanClass ']' String
cs
                         cls :: MatchTerm
cls = case String
cc of
                               ('!':ccs' :: String
ccs') -> Bool -> CharClass -> MatchTerm
MatchClass Bool
False (CharClass -> MatchTerm) -> CharClass -> MatchTerm
forall a b. (a -> b) -> a -> b
$ String -> CharClass
makeClass String
ccs'
                               _ -> Bool -> CharClass -> MatchTerm
MatchClass Bool
True (CharClass -> MatchTerm) -> CharClass -> MatchTerm
forall a b. (a -> b) -> a -> b
$ String -> CharClass
makeClass String
cc
                     in MatchTerm
cls MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: String -> [MatchTerm]
parseGlob String
ccs
parseGlob ('(':cs :: String
cs) = let (gg :: String
gg, ggs :: String
ggs) = Char -> String -> (String, String)
spanClass ')' String
cs
                     in [String] -> MatchTerm
MatchGroup (String -> String -> [String]
breakGroup [] String
gg) MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: String -> [MatchTerm]
parseGlob String
ggs
    where breakGroup :: String -> String -> [String]
          breakGroup :: String -> String -> [String]
breakGroup acc :: String
acc [] = [String -> String
forall a. [a] -> [a]
reverse String
acc]
          breakGroup _ ['\\'] = String -> [String]
forall a. HasCallStack => String -> a
error "group: unterminated escape"
          breakGroup acc :: String
acc ('\\':c :: Char
c:cs' :: String
cs') = String -> String -> [String]
breakGroup (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) String
cs'
          breakGroup acc :: String
acc ('|':cs' :: String
cs') = String -> String
forall a. [a] -> [a]
reverse String
acc String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> String -> [String]
breakGroup [] String
cs'
          breakGroup acc :: String
acc (c :: Char
c:cs' :: String
cs') = String -> String -> [String]
breakGroup (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) String
cs'
parseGlob ['\\'] = String -> [MatchTerm]
forall a. HasCallStack => String -> a
error "glob: unterminated escape"
parseGlob ('\\':c :: Char
c:cs :: String
cs) = String -> MatchTerm
MatchLiteral [Char
c] MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: String -> [MatchTerm]
parseGlob String
cs
parseGlob (c :: Char
c:cs :: String
cs) = String -> MatchTerm
MatchLiteral [Char
c] MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: String -> [MatchTerm]
parseGlob String
cs

simplifyTerms :: [MatchTerm] -> [MatchTerm]
simplifyTerms :: [MatchTerm] -> [MatchTerm]
simplifyTerms [] = []
simplifyTerms (MatchLiteral []:as :: [MatchTerm]
as) = [MatchTerm] -> [MatchTerm]
simplifyTerms [MatchTerm]
as
simplifyTerms (m :: MatchTerm
m@(MatchLiteral a :: String
a):as :: [MatchTerm]
as) =
    case [MatchTerm] -> [MatchTerm]
simplifyTerms [MatchTerm]
as of
    (MatchLiteral b :: String
b:bs :: [MatchTerm]
bs) -> String -> MatchTerm
MatchLiteral (String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b) MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: [MatchTerm]
bs
    bs :: [MatchTerm]
bs -> MatchTerm
m MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: [MatchTerm]
bs
simplifyTerms (MatchClass True (SRange [] []):as :: [MatchTerm]
as) = [MatchTerm] -> [MatchTerm]
simplifyTerms [MatchTerm]
as
simplifyTerms (MatchClass True (SRange a :: String
a@[_] []):as :: [MatchTerm]
as) =
    [MatchTerm] -> [MatchTerm]
simplifyTerms ([MatchTerm] -> [MatchTerm]) -> [MatchTerm] -> [MatchTerm]
forall a b. (a -> b) -> a -> b
$ String -> MatchTerm
MatchLiteral String
a MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: [MatchTerm]
as
simplifyTerms (MatchGroup []:as :: [MatchTerm]
as) = [MatchTerm] -> [MatchTerm]
simplifyTerms [MatchTerm]
as
simplifyTerms (MatchGroup gs :: [String]
gs:as :: [MatchTerm]
as) =
    case [String] -> (String, [String])
commonPrefix [String]
gs of
    (p :: String
p ,[]) -> [MatchTerm] -> [MatchTerm]
simplifyTerms (String -> MatchTerm
MatchLiteral String
p MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: [MatchTerm]
as)
    ("",ss :: [String]
ss) -> [String] -> MatchTerm
MatchGroup [String]
ss MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: [MatchTerm] -> [MatchTerm]
simplifyTerms [MatchTerm]
as
    (p :: String
p ,ss :: [String]
ss) -> [MatchTerm] -> [MatchTerm]
simplifyTerms (String -> MatchTerm
MatchLiteral String
p MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: [String] -> MatchTerm
MatchGroup [String]
ss MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: [MatchTerm]
as)
simplifyTerms (a :: MatchTerm
a:as :: [MatchTerm]
as) = MatchTerm
aMatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
:[MatchTerm] -> [MatchTerm]
simplifyTerms [MatchTerm]
as

commonPrefix :: [String] -> (String, [String])
commonPrefix :: [String] -> (String, [String])
commonPrefix = ([String] -> [String]) -> (String, [String]) -> (String, [String])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ((String, [String]) -> (String, [String]))
-> ([String] -> (String, [String]))
-> [String]
-> (String, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> (String, [String])
pfx ""
    where pfx :: String -> [String] -> (String, [String])
pfx _ [] = ("", [])
          pfx acc :: String
acc ss :: [String]
ss | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ss = (String -> String
forall a. [a] -> [a]
reverse String
acc, [String]
ss)
                     | Bool
otherwise = let hs :: String
hs = (String -> Char) -> [String] -> String
forall a b. (a -> b) -> [a] -> [b]
map String -> Char
forall a. [a] -> a
head [String]
ss
                                       h :: Char
h = String -> Char
forall a. [a] -> a
head String
hs
                                   in if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char
hChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail String
hs
                                      then String -> [String] -> (String, [String])
pfx (Char
hChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) ([String] -> (String, [String])) -> [String] -> (String, [String])
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. [a] -> [a]
tail [String]
ss
                                      else (String -> String
forall a. [a] -> [a]
reverse String
acc, [String]
ss)

matchTerms :: [MatchTerm] -> String -> Maybe ()

matchTerms :: [MatchTerm] -> String -> Maybe ()
matchTerms [] [] = () -> Maybe ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
matchTerms [] _ = String -> Maybe ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "residual string"
matchTerms (MatchLiteral m :: String
m:ts :: [MatchTerm]
ts) cs :: String
cs = String -> String -> Maybe String
forall a (m :: * -> *). (Eq a, MonadFail m) => [a] -> [a] -> m [a]
matchLiteral String
m String
cs Maybe String -> (String -> Maybe ()) -> Maybe ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [MatchTerm] -> String -> Maybe ()
matchTerms [MatchTerm]
ts
    where matchLiteral :: [a] -> [a] -> m [a]
matchLiteral (a :: a
a:as :: [a]
as) (b :: a
b:bs :: [a]
bs) | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b = [a] -> [a] -> m [a]
matchLiteral [a]
as [a]
bs
          matchLiteral [] as :: [a]
as = [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
as
          matchLiteral _ _ = String -> m [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "not a prefix"
matchTerms (MatchClass k :: Bool
k c :: CharClass
c:ts :: [MatchTerm]
ts) cs :: String
cs = String -> Maybe String
forall (m :: * -> *). MonadFail m => String -> m String
matchClass String
cs Maybe String -> (String -> Maybe ()) -> Maybe ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [MatchTerm] -> String -> Maybe ()
matchTerms [MatchTerm]
ts
    where matchClass :: String -> m String
matchClass (b :: Char
b:bs :: String
bs) | (Bool
inClass Bool -> Bool -> Bool
&& Bool
k) Bool -> Bool -> Bool
|| Bool -> Bool
not (Bool
inClass Bool -> Bool -> Bool
|| Bool
k) = String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
bs
                            where inClass :: Bool
inClass = Char
b Char -> CharClass -> Bool
forall a. Ix a => a -> SRange a -> Bool
`inSRange` CharClass
c
          matchClass _ = String -> m String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "no match"
matchTerms (MatchGroup g :: [String]
g:ts :: [MatchTerm]
ts) cs :: String
cs = [Maybe ()] -> Maybe ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((String -> Maybe ()) -> [String] -> [Maybe ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe ()
matchGroup [String]
g)
    where matchGroup :: String -> Maybe ()
matchGroup g :: String
g = [MatchTerm] -> String -> Maybe ()
matchTerms (String -> MatchTerm
MatchLiteral String
g MatchTerm -> [MatchTerm] -> [MatchTerm]
forall a. a -> [a] -> [a]
: [MatchTerm]
ts) String
cs
matchTerms [MatchAny] _ = () -> Maybe ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
matchTerms (MatchAny:ts :: [MatchTerm]
ts) cs :: String
cs = String -> Maybe String
forall (m :: * -> *). MonadFail m => String -> m String
matchAny String
cs Maybe String -> (String -> Maybe ()) -> Maybe ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [MatchTerm] -> String -> Maybe ()
matchTerms [MatchTerm]
ts
    where matchAny :: String -> m String
matchAny [] = String -> m String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "no match"
          matchAny cs' :: String
cs' = case [MatchTerm] -> String -> Maybe ()
matchTerms [MatchTerm]
ts String
cs' of
                          Nothing -> String -> m String
matchAny (String -> String
forall a. [a] -> [a]
tail String
cs')
                          _ -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
cs'
matchTerms [MatchDir] cs :: String
cs | Char
pathSeparator Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
cs = String -> Maybe ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "path separator"
                         | Bool
otherwise = () -> Maybe ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
matchTerms (MatchDir:ts :: [MatchTerm]
ts) cs :: String
cs = String -> Maybe String
forall (m :: * -> *). MonadFail m => String -> m String
matchDir String
cs Maybe String -> (String -> Maybe ()) -> Maybe ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [MatchTerm] -> String -> Maybe ()
matchTerms [MatchTerm]
ts
    where matchDir :: String -> m String
matchDir [] = String -> m String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "no match"
          matchDir (c :: Char
c:_) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
pathSeparator = String -> m String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "path separator"
          matchDir cs' :: String
cs' = case [MatchTerm] -> String -> Maybe ()
matchTerms [MatchTerm]
ts String
cs' of
                         Nothing -> String -> m String
matchDir (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail String
cs'
                         _ -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
cs'
matchTerms (MatchChar:_) [] = String -> Maybe ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "end of input"
matchTerms (MatchChar:ts :: [MatchTerm]
ts) (_:cs :: String
cs) = [MatchTerm] -> String -> Maybe ()
matchTerms [MatchTerm]
ts String
cs

-- | Match a file name against a glob pattern.
(~~) :: FilePath -> GlobPattern -> Bool

name :: String
name ~~ :: String -> String -> Bool
~~ pat :: String
pat = let terms :: [MatchTerm]
terms = [MatchTerm] -> [MatchTerm]
simplifyTerms (String -> [MatchTerm]
parseGlob String
pat)
              in (Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool) -> (String -> Maybe ()) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MatchTerm] -> String -> Maybe ()
matchTerms [MatchTerm]
terms) String
name

-- | Match a file name against a glob pattern, but return 'True' if
-- the match /fail/s.
(/~) :: FilePath -> GlobPattern -> Bool

/~ :: String -> String -> Bool
(/~) = (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ) ((String -> Bool) -> String -> Bool)
-> (String -> String -> Bool) -> String -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
(~~)