{- |
This module follows the convention found in <https://git-scm.com/docs/gitignore>
-}
module Cryptol.Project.WildMatch (wildmatch) where

import Data.Char
import System.FilePath

-- | `wildmatch p x` checks if file `x` matches pattern `p`.
wildmatch :: String -> FilePath -> Bool
wildmatch :: String -> String -> Bool
wildmatch String
mbNegP String
x
  -- When a pattern contains a path separator, it matches the whole path
  | Char
'/' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
p = Bool -> Bool
mbNeg (String -> String -> Bool
matchP (String -> String
ensureLeadingSlash String
p) (String -> String
ensureLeadingSlash String
x))
  -- When the pattern contains no path separator it only matches the filename
  | Bool
otherwise    = Bool -> Bool
mbNeg (String -> String -> Bool
matchP String
p (String -> String
takeFileName String
x))
  where
  (Bool -> Bool
mbNeg,String
p) =
    case String
mbNegP of
      Char
'!':String
rest -> (Bool -> Bool
not,String
rest)
      String
_        -> (Bool -> Bool
forall a. a -> a
id,String
mbNegP)


-- | Normalize a path pattern to start with a leading slash for consistency later
ensureLeadingSlash :: String -> String
ensureLeadingSlash :: String -> String
ensureLeadingSlash (Char
'/':String
p) = Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:String
p
ensureLeadingSlash String
p       = Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:String
p

------------------
-- Path processing
------------------

matchP :: String -> FilePath -> Bool

matchP :: String -> String -> Bool
matchP String
"/**" String
_ = Bool
True -- Accepts everything

matchP (Char
'/':Char
'*':Char
'*':Char
'/':String
p) (Char
'/':String
xs) =
  String -> String -> Bool
matchP (Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:String
p) (Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:String
xs) Bool -> Bool -> Bool
||
  String -> String -> Bool
matchP (Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'*'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'*'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:String
p) ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
'/'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) String
xs)

matchP (Char
'/':Char
'*':Char
'*':Char
'/':String
_p) String
_ = Bool
False

-- escaped characters match literally
matchP (Char
'\\':Char
a:String
p) (Char
x:String
xs) = Char
aChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
x Bool -> Bool -> Bool
&& String -> String -> Bool
matchP String
p String
xs
matchP (Char
'\\':String
_)   String
""     = Bool
False

-- match zero or more component characters
matchP (Char
'*':String
p) (Char
x:String
xs) = String -> String -> Bool
matchP String
p (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs) Bool -> Bool -> Bool
|| (Char
'/' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
x) Bool -> Bool -> Bool
&& String -> String -> Bool
matchP (Char
'*'Char -> String -> String
forall a. a -> [a] -> [a]
:String
p) String
xs
matchP (Char
'*':String
p) String
""     = String -> String -> Bool
matchP String
p String
""

-- match zero or one component characters
matchP (Char
'?':String
p) (Char
x : String
xs) = String -> String -> Bool
matchP String
p (Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs) Bool -> Bool -> Bool
|| (Char
'/' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
x) Bool -> Bool -> Bool
&& String -> String -> Bool
matchP String
p String
xs
matchP (Char
'?':String
p) String
""       = String -> String -> Bool
matchP String
p String
""

-- process a character class
matchP (Char
'[':String
p) (Char
x:String
xs)
  | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'                         = Bool
False
  | Just (Char -> Bool
f, String
p') <- String -> Maybe (Char -> Bool, String)
parseCharClass String
p = Char -> Bool
f Char
x Bool -> Bool -> Bool
&& String -> String -> Bool
matchP String
p' String
xs
matchP (Char
'[':String
_) String
_                     = Bool
False

-- literal match
matchP (Char
a:String
p) (Char
x:String
xs) = Char
aChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
x Bool -> Bool -> Bool
&& String -> String -> Bool
matchP String
p String
xs
matchP (Char
_a:String
_p) String
""   = Bool
False

matchP String
"" String
xs        = String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
xs

-----------------------------
-- Character class processing
-----------------------------

parseCharClass :: String -> Maybe (Char -> Bool, String)

-- leading ! negates a character class
parseCharClass :: String -> Maybe (Char -> Bool, String)
parseCharClass (Char
'!':String
p) =
 do (Char -> Bool
f, String
p') <- Bool -> String -> Maybe (Char -> Bool, String)
parseCharClass1 Bool
True String
p
    (Char -> Bool, String) -> Maybe (Char -> Bool, String)
forall a. a -> Maybe a
Just (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
f, String
p')
parseCharClass String
p = Bool -> String -> Maybe (Char -> Bool, String)
parseCharClass1 Bool
True String
p

-- A ] in the first position is a literal match
parseCharClass1 :: Bool -> [Char] -> Maybe (Char -> Bool, [Char])
parseCharClass1 :: Bool -> String -> Maybe (Char -> Bool, String)
parseCharClass1 Bool
False (Char
']':String
p) =
  (Char -> Bool, String) -> Maybe (Char -> Bool, String)
forall a. a -> Maybe a
Just (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
False, String
p)

parseCharClass1 Bool
first (Char
x:Char
'-':Char
y:String
p)
  | Bool
first Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']', Char
y Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']' = (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc (\Char
c -> Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
y) String
p

parseCharClass1 Bool
_ (Char
'[':Char
':':String
p) =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\Char
x -> Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
x Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z') String
p of
    (String
"alnum", Char
':':Char
']':String
p1) -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc Char -> Bool
isAlphaNum String
p1
    (String
"cntrl", Char
':':Char
']':String
p1) -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc Char -> Bool
isControl String
p1
    (String
"lower", Char
':':Char
']':String
p1) -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc Char -> Bool
isLower String
p1
    (String
"space", Char
':':Char
']':String
p1) -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc Char -> Bool
isSpace String
p1
    (String
"alpha", Char
':':Char
']':String
p1) -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc Char -> Bool
isAlpha String
p1
    (String
"digit", Char
':':Char
']':String
p1) -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc Char -> Bool
isDigit String
p1
    (String
"print", Char
':':Char
']':String
p1) -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc Char -> Bool
isPrint String
p1
    (String
"upper", Char
':':Char
']':String
p1) -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc Char -> Bool
isUpper String
p1
    (String
"blank", Char
':':Char
']':String
p1) -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
" \t") String
p1
    (String
"graph", Char
':':Char
']':String
p1) -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc (\Char
x -> Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
x) String
p1
    (String
"punct", Char
':':Char
']':String
p1) -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc Char -> Bool
isPunctuation String
p1
    (String
"xdigit", Char
':':Char
']':String
p1) -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc Char -> Bool
isHexDigit String
p1
    (String
_       , Char
':':Char
']':String
_) -> Maybe (Char -> Bool, String)
forall a. Maybe a
Nothing
    (String, String)
_ -> (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc (Char
'['Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) (Char
':'Char -> String -> String
forall a. a -> [a] -> [a]
:String
p)

parseCharClass1 Bool
_ (Char
x:String
p) = (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc (Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
p
parseCharClass1 Bool
_ String
""    = Maybe (Char -> Bool, String)
forall a. Maybe a
Nothing

-- Helper for continuing to build a character class matcher
cc :: (Char -> Bool) -> [Char] -> Maybe (Char -> Bool, [Char])
cc :: (Char -> Bool) -> String -> Maybe (Char -> Bool, String)
cc Char -> Bool
f String
p =
 do (Char -> Bool
g, String
p') <- Bool -> String -> Maybe (Char -> Bool, String)
parseCharClass1 Bool
False String
p
    (Char -> Bool, String) -> Maybe (Char -> Bool, String)
forall a. a -> Maybe a
Just (\Char
x -> Char -> Bool
f Char
x Bool -> Bool -> Bool
|| Char -> Bool
g Char
x, String
p')