{-# LANGUAGE FlexibleContexts #-}

-- ------------------------------------------------------------

{- |
   Copyright  : Copyright (C) 2014- Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   csh style Glob Pattern Parser for Regular Expressions
-}

-- ------------------------------------------------------------

module Text.Regex.Glob.Generic.RegexParser
    ( parseRegex
    , parseRegexNoCase
    )
where

import           Data.Char                               (isLower, isUpper,
                                                          toLower, toUpper)

import           Text.ParserCombinators.Parsec
import           Text.Regex.XMLSchema.Generic.Regex
import           Text.Regex.XMLSchema.Generic.StringLike

-- ------------------------------------------------------------

-- | parse a glob pattern

parseRegex :: StringLike s => s -> GenRegex s
parseRegex :: s -> GenRegex s
parseRegex
    = (Char -> Char -> GenRegex s) -> String -> GenRegex s
forall s.
StringLike s =>
(Char -> Char -> GenRegex s) -> String -> GenRegex s
parseRegex' Char -> Char -> GenRegex s
forall s. StringLike s => Char -> Char -> GenRegex s
mkSymRng (String -> GenRegex s) -> (s -> String) -> s -> GenRegex s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> String
forall a. StringLike a => a -> String
toString

parseRegexNoCase :: StringLike s => s -> GenRegex s
parseRegexNoCase :: s -> GenRegex s
parseRegexNoCase
    = (Char -> Char -> GenRegex s) -> String -> GenRegex s
forall s.
StringLike s =>
(Char -> Char -> GenRegex s) -> String -> GenRegex s
parseRegex' Char -> Char -> GenRegex s
forall s. StringLike s => Char -> Char -> GenRegex s
mkNoCaseSymRng (String -> GenRegex s) -> (s -> String) -> s -> GenRegex s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> String
forall a. StringLike a => a -> String
toString

parseRegex' :: StringLike s => (Char -> Char -> GenRegex s) -> String -> GenRegex s
parseRegex' :: (Char -> Char -> GenRegex s) -> String -> GenRegex s
parseRegex' Char -> Char -> GenRegex s
mkS
    = (ParseError -> GenRegex s)
-> (GenRegex s -> GenRegex s)
-> Either ParseError (GenRegex s)
-> GenRegex s
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> GenRegex s
forall s. StringLike s => String -> GenRegex s
mkZero' (String -> GenRegex s)
-> (ParseError -> String) -> ParseError -> GenRegex s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"syntax error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (ParseError -> String) -> ParseError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show) GenRegex s -> GenRegex s
forall a. a -> a
id
      (Either ParseError (GenRegex s) -> GenRegex s)
-> (String -> Either ParseError (GenRegex s))
-> String
-> GenRegex s
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Parsec String () (GenRegex s)
-> String -> String -> Either ParseError (GenRegex s)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse ( do
              GenRegex s
r <- (Char -> Char -> GenRegex s) -> Parsec String () (GenRegex s)
forall s.
StringLike s =>
(Char -> Char -> GenRegex s) -> Parser (GenRegex s)
pattern Char -> Char -> GenRegex s
mkS
              ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
              GenRegex s -> Parsec String () (GenRegex s)
forall (m :: * -> *) a. Monad m => a -> m a
return GenRegex s
r
            ) String
""

-- ------------------------------------------------------------

pattern  :: StringLike s => (Char -> Char -> GenRegex s) -> Parser (GenRegex s)
pattern :: (Char -> Char -> GenRegex s) -> Parser (GenRegex s)
pattern Char -> Char -> GenRegex s
mkS
    = Parser (GenRegex s) -> ParsecT String () Identity [GenRegex s]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser (GenRegex s)
forall u. ParsecT String u Identity (GenRegex s)
part ParsecT String () Identity [GenRegex s]
-> ([GenRegex s] -> Parser (GenRegex s)) -> Parser (GenRegex s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GenRegex s -> Parser (GenRegex s)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenRegex s -> Parser (GenRegex s))
-> ([GenRegex s] -> GenRegex s)
-> [GenRegex s]
-> Parser (GenRegex s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenRegex s] -> GenRegex s
forall s. [GenRegex s] -> GenRegex s
mkSeqs
    where
      -- part :: Parser (GenRegex s)
      part :: ParsecT String u Identity (GenRegex s)
part
          = ( ParsecT String u Identity Char -> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\\?*[{") ParsecT String u Identity String
-> (String -> ParsecT String u Identity (GenRegex s))
-> ParsecT String u Identity (GenRegex s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GenRegex s -> ParsecT String u Identity (GenRegex s)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenRegex s -> ParsecT String u Identity (GenRegex s))
-> (String -> GenRegex s)
-> String
-> ParsecT String u Identity (GenRegex s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GenRegex s
mkWord' )
            ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
            ( Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'?' ParsecT String u Identity Char
-> ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenRegex s -> ParsecT String u Identity (GenRegex s)
forall (m :: * -> *) a. Monad m => a -> m a
return GenRegex s
forall s. GenRegex s
mkDot )
            ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
            ( Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'*' ParsecT String u Identity Char
-> ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenRegex s -> ParsecT String u Identity (GenRegex s)
forall (m :: * -> *) a. Monad m => a -> m a
return GenRegex s
forall s. StringLike s => GenRegex s
mkAll )
            ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
            ( ParsecT String u Identity Char
-> ParsecT String u Identity Char
-> ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{') (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}') ParsecT String u Identity (GenRegex s)
forall u. ParsecT String u Identity (GenRegex s)
wordList )
            ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
            ( ParsecT String u Identity Char
-> ParsecT String u Identity Char
-> ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[') (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']') ParsecT String u Identity (GenRegex s)
forall u. ParsecT String u Identity (GenRegex s)
charSet )
            ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity (GenRegex s)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
            ( do Char
c <- Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\' ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
                 GenRegex s -> ParsecT String u Identity (GenRegex s)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenRegex s -> ParsecT String u Identity (GenRegex s))
-> GenRegex s -> ParsecT String u Identity (GenRegex s)
forall a b. (a -> b) -> a -> b
$ Char -> Char -> GenRegex s
mkS Char
c Char
c
            )
      mkWord' :: String -> GenRegex s
mkWord'
          = [GenRegex s] -> GenRegex s
forall s. [GenRegex s] -> GenRegex s
mkSeqs ([GenRegex s] -> GenRegex s)
-> (String -> [GenRegex s]) -> String -> GenRegex s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> GenRegex s) -> String -> [GenRegex s]
forall a b. (a -> b) -> [a] -> [b]
map (\ Char
c -> Char -> Char -> GenRegex s
mkS Char
c Char
c)

      -- wordList :: Parser (GenRegex s)
      wordList :: ParsecT String u Identity (GenRegex s)
wordList
          = ParsecT String u Identity String
-> ParsecT String u Identity Char
-> ParsecT String u Identity [String]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy (ParsecT String u Identity Char -> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
",}")) (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',')
            ParsecT String u Identity [String]
-> ([String] -> ParsecT String u Identity (GenRegex s))
-> ParsecT String u Identity (GenRegex s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GenRegex s -> ParsecT String u Identity (GenRegex s)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenRegex s -> ParsecT String u Identity (GenRegex s))
-> ([String] -> GenRegex s)
-> [String]
-> ParsecT String u Identity (GenRegex s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenRegex s -> GenRegex s -> GenRegex s)
-> GenRegex s -> [GenRegex s] -> GenRegex s
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GenRegex s -> GenRegex s -> GenRegex s
forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkAlt (String -> GenRegex s
forall s. StringLike s => String -> GenRegex s
mkZero' String
"") ([GenRegex s] -> GenRegex s)
-> ([String] -> [GenRegex s]) -> [String] -> GenRegex s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> GenRegex s) -> [String] -> [GenRegex s]
forall a b. (a -> b) -> [a] -> [b]
map String -> GenRegex s
mkWord'

      -- charSet :: Parser (GenRegex s)
      charSet :: ParsecT String u Identity (GenRegex s)
charSet
          = ( do GenRegex s
p1 <- ParsecT String u Identity Char
-> ParsecT String u Identity (GenRegex s)
forall s (m :: * -> *) u.
Stream s m Char =>
ParsecT s u m Char -> ParsecT s u m (GenRegex s)
charSet' ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
                 [GenRegex s]
ps <- ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity [GenRegex s]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String u Identity (GenRegex s)
 -> ParsecT String u Identity [GenRegex s])
-> ParsecT String u Identity (GenRegex s)
-> ParsecT String u Identity [GenRegex s]
forall a b. (a -> b) -> a -> b
$ ParsecT String u Identity Char
-> ParsecT String u Identity (GenRegex s)
forall s (m :: * -> *) u.
Stream s m Char =>
ParsecT s u m Char -> ParsecT s u m (GenRegex s)
charSet' (String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"]")
                 GenRegex s -> ParsecT String u Identity (GenRegex s)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenRegex s -> ParsecT String u Identity (GenRegex s))
-> GenRegex s -> ParsecT String u Identity (GenRegex s)
forall a b. (a -> b) -> a -> b
$ (GenRegex s -> GenRegex s -> GenRegex s)
-> GenRegex s -> [GenRegex s] -> GenRegex s
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GenRegex s -> GenRegex s -> GenRegex s
forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkAlt (String -> GenRegex s
forall s. StringLike s => String -> GenRegex s
mkZero' String
"") (GenRegex s
p1 GenRegex s -> [GenRegex s] -> [GenRegex s]
forall a. a -> [a] -> [a]
: [GenRegex s]
ps)
            )
          where
            charSet' :: ParsecT s u m Char -> ParsecT s u m (GenRegex s)
charSet' ParsecT s u m Char
cp
                = do Char
c1 <- ParsecT s u m Char
cp
                     Char
c2 <- Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
rest Char
c1
                     GenRegex s -> ParsecT s u m (GenRegex s)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenRegex s -> ParsecT s u m (GenRegex s))
-> GenRegex s -> ParsecT s u m (GenRegex s)
forall a b. (a -> b) -> a -> b
$ Char -> Char -> GenRegex s
mkS Char
c1 Char
c2
            rest :: Char -> ParsecT s u m Char
rest Char
c1
                = Char -> ParsecT s u m Char -> ParsecT s u m Char
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Char
c1 (Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' ParsecT s u m Char -> ParsecT s u m Char -> ParsecT s u m Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s u m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar)

-- ------------------------------------------------------------

mkNoCaseSymRng :: StringLike s => Char -> Char -> GenRegex s
mkNoCaseSymRng :: Char -> Char -> GenRegex s
mkNoCaseSymRng Char
c1 Char
c2
    | Char -> Bool
isLower Char
c1
      Bool -> Bool -> Bool
&&
      Char -> Bool
isLower Char
c2
          = GenRegex s -> GenRegex s -> GenRegex s
forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkAlt (Char -> Char -> GenRegex s
forall s. StringLike s => Char -> Char -> GenRegex s
mkSymRng (Char -> Char
toUpper Char
c1) (Char -> Char
toUpper Char
c2)) (Char -> Char -> GenRegex s
forall s. StringLike s => Char -> Char -> GenRegex s
mkSymRng Char
c1 Char
c2)
    | Char -> Bool
isUpper Char
c1
      Bool -> Bool -> Bool
&&
      Char -> Bool
isUpper Char
c2
          = GenRegex s -> GenRegex s -> GenRegex s
forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkAlt (Char -> Char -> GenRegex s
forall s. StringLike s => Char -> Char -> GenRegex s
mkSymRng (Char -> Char
toLower Char
c1) (Char -> Char
toLower Char
c2)) (Char -> Char -> GenRegex s
forall s. StringLike s => Char -> Char -> GenRegex s
mkSymRng Char
c1 Char
c2)
    | Bool
otherwise
        = Char -> Char -> GenRegex s
forall s. StringLike s => Char -> Char -> GenRegex s
mkSymRng Char
c1 Char
c2

-- ------------------------------------------------------------