{-# LANGUAGE LambdaCase, OverloadedStrings #-}
module HMGit.Internal.Parser.Pathspecs.Glob (
    transpile
  , isLiteral
  , match
  , match'
) where

import           HMGit.Internal.Exceptions (MonadThrowable (..))

import           Control.Exception.Safe    (MonadThrow)
import           Data.Char                 (isAlpha, isAscii, isDigit)
import           Data.Void                 (Void)
import qualified Text.Megaparsec           as M
import           Text.Regex.Posix          ((=~))

escapeRegular :: String -> String
escapeRegular :: String -> String
escapeRegular = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escaper
    where
        escaper :: Char -> String
escaper Char
x
            | Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"\'`" :: String)
                Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
x
                Bool -> Bool -> Bool
|| (Char -> Bool
isAscii Char
x Bool -> Bool -> Bool
&& Char -> Bool
isAlpha Char
x)
                Bool -> Bool -> Bool
|| Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"<>" :: String) = [Char
x]
            | Bool
otherwise = [ Char
'\\', Char
x ]

type GlobIRParser = M.Parsec Void String

data GlobIRToken = GlobIRSymbol String
    | GlobIRLiteral String

instance Show GlobIRToken where
    show :: GlobIRToken -> String
show (GlobIRSymbol String
s)  = String
s
    show (GlobIRLiteral String
s) = String
s

type GlobIR = [GlobIRToken]

stringify :: (Foldable t, Show a) => t a -> String
stringify :: t a -> String
stringify = (a -> String) -> t a -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> String
forall a. Show a => a -> String
show

isLiteral :: GlobIR -> Bool
isLiteral :: [GlobIRToken] -> Bool
isLiteral = (GlobIRToken -> Bool) -> [GlobIRToken] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\case GlobIRLiteral String
_ -> Bool
True; GlobIRToken
_ -> Bool
False)

-- wildcard (glob) BNF
--
-- wildcard : expr
--          | expr wildcard
--
-- expr : br
--      | '*'
--      | '?'
--      | word
--
-- br : pos_bracket_expr
--    | neg_bracket_expr
--
-- pos_bracket_expr : '[' word ']'
--
-- neg_bracket_expr : '[' '!' word ']'
--
ast, que, lbr, rbr, exc, word, br, expr, wildcard :: GlobIRParser GlobIR

wildcard :: GlobIRParser [GlobIRToken]
wildcard = [GlobIRParser [GlobIRToken]] -> GlobIRParser [GlobIRToken]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
M.choice [
    [GlobIRToken]
forall a. Monoid a => a
mempty [GlobIRToken]
-> ParsecT Void String Identity () -> GlobIRParser [GlobIRToken]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
M.eof
  , [GlobIRToken] -> [GlobIRToken] -> [GlobIRToken]
forall a. Semigroup a => a -> a -> a
(<>) ([GlobIRToken] -> [GlobIRToken] -> [GlobIRToken])
-> GlobIRParser [GlobIRToken]
-> ParsecT Void String Identity ([GlobIRToken] -> [GlobIRToken])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GlobIRParser [GlobIRToken]
expr ParsecT Void String Identity ([GlobIRToken] -> [GlobIRToken])
-> GlobIRParser [GlobIRToken] -> GlobIRParser [GlobIRToken]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GlobIRParser [GlobIRToken]
wildcard
  ]

ast :: GlobIRParser [GlobIRToken]
ast = [String -> GlobIRToken
GlobIRSymbol String
".*"] [GlobIRToken]
-> ParsecT Void String Identity Char -> GlobIRParser [GlobIRToken]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
Token String
'*'

que :: GlobIRParser [GlobIRToken]
que = [String -> GlobIRToken
GlobIRSymbol String
"."] [GlobIRToken]
-> ParsecT Void String Identity Char -> GlobIRParser [GlobIRToken]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
Token String
'?'

lbr :: GlobIRParser [GlobIRToken]
lbr = (GlobIRToken -> [GlobIRToken] -> [GlobIRToken]
forall a. a -> [a] -> [a]
:[]) (GlobIRToken -> [GlobIRToken])
-> (Char -> GlobIRToken) -> Char -> [GlobIRToken]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GlobIRToken
GlobIRSymbol (String -> GlobIRToken) -> (Char -> String) -> Char -> GlobIRToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> String
forall a. a -> [a] -> [a]
:[]) (Char -> [GlobIRToken])
-> ParsecT Void String Identity Char -> GlobIRParser [GlobIRToken]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
Token String
'['

rbr :: GlobIRParser [GlobIRToken]
rbr = (GlobIRToken -> [GlobIRToken] -> [GlobIRToken]
forall a. a -> [a] -> [a]
:[]) (GlobIRToken -> [GlobIRToken])
-> (Char -> GlobIRToken) -> Char -> [GlobIRToken]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GlobIRToken
GlobIRSymbol (String -> GlobIRToken) -> (Char -> String) -> Char -> GlobIRToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> String
forall a. a -> [a] -> [a]
:[]) (Char -> [GlobIRToken])
-> ParsecT Void String Identity Char -> GlobIRParser [GlobIRToken]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
Token String
']'

exc :: GlobIRParser [GlobIRToken]
exc = [String -> GlobIRToken
GlobIRSymbol String
"^"] [GlobIRToken]
-> ParsecT Void String Identity Char -> GlobIRParser [GlobIRToken]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.single Char
Token String
'!'

word :: GlobIRParser [GlobIRToken]
word = (GlobIRToken -> [GlobIRToken] -> [GlobIRToken]
forall a. a -> [a] -> [a]
:[]) (GlobIRToken -> [GlobIRToken])
-> (String -> GlobIRToken) -> String -> [GlobIRToken]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GlobIRToken
GlobIRLiteral (String -> GlobIRToken)
-> (String -> String) -> String -> GlobIRToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
escapeRegular
    (String -> [GlobIRToken])
-> ParsecT Void String Identity String
-> GlobIRParser [GlobIRToken]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
M.some ([Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
M.noneOf [ Char
'*', Char
'?', Char
'[', Char
']', Char
'!' ])

br :: GlobIRParser [GlobIRToken]
br = (\[GlobIRToken]
x [GlobIRToken]
y [GlobIRToken]
z -> [GlobIRToken]
x [GlobIRToken] -> [GlobIRToken] -> [GlobIRToken]
forall a. Semigroup a => a -> a -> a
<> [GlobIRToken]
y [GlobIRToken] -> [GlobIRToken] -> [GlobIRToken]
forall a. Semigroup a => a -> a -> a
<> [GlobIRToken]
z)
    ([GlobIRToken] -> [GlobIRToken] -> [GlobIRToken] -> [GlobIRToken])
-> GlobIRParser [GlobIRToken]
-> ParsecT
     Void
     String
     Identity
     ([GlobIRToken] -> [GlobIRToken] -> [GlobIRToken])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GlobIRParser [GlobIRToken]
lbr
    ParsecT
  Void
  String
  Identity
  ([GlobIRToken] -> [GlobIRToken] -> [GlobIRToken])
-> GlobIRParser [GlobIRToken]
-> ParsecT Void String Identity ([GlobIRToken] -> [GlobIRToken])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [GlobIRParser [GlobIRToken]] -> GlobIRParser [GlobIRToken]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
M.choice [ [GlobIRToken] -> [GlobIRToken] -> [GlobIRToken]
forall a. Monoid a => a -> a -> a
mappend ([GlobIRToken] -> [GlobIRToken] -> [GlobIRToken])
-> GlobIRParser [GlobIRToken]
-> ParsecT Void String Identity ([GlobIRToken] -> [GlobIRToken])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GlobIRParser [GlobIRToken]
exc ParsecT Void String Identity ([GlobIRToken] -> [GlobIRToken])
-> GlobIRParser [GlobIRToken] -> GlobIRParser [GlobIRToken]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GlobIRParser [GlobIRToken]
word, GlobIRParser [GlobIRToken]
word ]
    ParsecT Void String Identity ([GlobIRToken] -> [GlobIRToken])
-> GlobIRParser [GlobIRToken] -> GlobIRParser [GlobIRToken]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GlobIRParser [GlobIRToken]
rbr

expr :: GlobIRParser [GlobIRToken]
expr = [GlobIRParser [GlobIRToken]] -> GlobIRParser [GlobIRToken]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
M.choice [
    GlobIRParser [GlobIRToken]
br
  , GlobIRParser [GlobIRToken]
ast
  , GlobIRParser [GlobIRToken]
que
  , GlobIRParser [GlobIRToken]
word
  ]

transpile :: MonadThrow m => String -> m GlobIR
transpile :: String -> m [GlobIRToken]
transpile = Maybe Void -> Either (ParseErrorBundle String Void) ~> m
forall (m :: * -> *) (n :: * -> *) e.
(MonadThrowable m, MonadThrow n, Exception e) =>
Maybe e -> m ~> n
fromMonad (Maybe Void
forall a. Maybe a
Nothing :: Maybe Void)
    (Either (ParseErrorBundle String Void) [GlobIRToken]
 -> m [GlobIRToken])
-> (String -> Either (ParseErrorBundle String Void) [GlobIRToken])
-> String
-> m [GlobIRToken]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobIRParser [GlobIRToken]
-> String
-> String
-> Either (ParseErrorBundle String Void) [GlobIRToken]
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
M.runParser GlobIRParser [GlobIRToken]
wildcard String
forall a. Monoid a => a
mempty

match :: String -> GlobIR -> Bool
match :: String -> [GlobIRToken] -> Bool
match String
s = (String
s String -> String -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~)
    (String -> Bool)
-> ([GlobIRToken] -> String) -> [GlobIRToken] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GlobIRToken] -> String
forall (t :: * -> *) a. (Foldable t, Show a) => t a -> String
stringify
    ([GlobIRToken] -> String)
-> ([GlobIRToken] -> [GlobIRToken]) -> [GlobIRToken] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String -> GlobIRToken
GlobIRSymbol String
"^"] [GlobIRToken] -> [GlobIRToken] -> [GlobIRToken]
forall a. Semigroup a => a -> a -> a
<>) ([GlobIRToken] -> [GlobIRToken])
-> ([GlobIRToken] -> [GlobIRToken])
-> [GlobIRToken]
-> [GlobIRToken]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([GlobIRToken] -> [GlobIRToken] -> [GlobIRToken]
forall a. Semigroup a => a -> a -> a
<> [String -> GlobIRToken
GlobIRSymbol String
"$"])

match' :: String -> String -> Bool
match' :: String -> String -> Bool
match' String
s = Bool -> ([GlobIRToken] -> Bool) -> Maybe [GlobIRToken] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (String -> [GlobIRToken] -> Bool
match String
s)
    (Maybe [GlobIRToken] -> Bool)
-> (String -> Maybe [GlobIRToken]) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe [GlobIRToken]
forall (m :: * -> *). MonadThrow m => String -> m [GlobIRToken]
transpile