{-# 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 :: forall s. StringLike s => s -> GenRegex s
parseRegex
    = forall s.
StringLike s =>
(Char -> Char -> GenRegex s) -> String -> GenRegex s
parseRegex' forall s. StringLike s => Char -> Char -> GenRegex s
mkSymRng forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. StringLike a => a -> String
toString

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

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

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

pattern  :: StringLike s => (Char -> Char -> GenRegex s) -> Parser (GenRegex s)
pattern :: forall s.
StringLike s =>
(Char -> Char -> GenRegex s) -> Parser (GenRegex s)
pattern Char -> Char -> GenRegex s
mkS
    = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall {u}. ParsecT String u Identity (GenRegex s)
part forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. [GenRegex s] -> GenRegex s
mkSeqs
    where
      -- part :: Parser (GenRegex s)
      part :: ParsecT String u Identity (GenRegex s)
part
          = ( forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\\?*[{") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GenRegex s
mkWord' )
            forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
            ( forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'?' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall s. GenRegex s
mkDot )
            forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
            ( forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'*' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall s. StringLike s => GenRegex s
mkAll )
            forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
            ( 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 (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{') (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}') forall {u}. ParsecT String u Identity (GenRegex s)
wordList )
            forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
            ( 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 (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[') (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']') forall {u}. ParsecT String u Identity (GenRegex s)
charSet )
            forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
            ( do Char
c <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Char -> Char -> GenRegex s
mkS Char
c Char
c
            )
      mkWord' :: String -> GenRegex s
mkWord'
          = forall s. [GenRegex s] -> GenRegex s
mkSeqs forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
          = 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 (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
",}")) (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',')
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkAlt (forall s. StringLike s => String -> GenRegex s
mkZero' String
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall {s} {m :: * -> *} {u}.
Stream s m Char =>
ParsecT s u m Char -> ParsecT s u m (GenRegex s)
charSet' forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
                 [GenRegex s]
ps <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall a b. (a -> b) -> a -> b
$ forall {s} {m :: * -> *} {u}.
Stream s m Char =>
ParsecT s u m Char -> ParsecT s u m (GenRegex s)
charSet' (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"]")
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkAlt (forall s. StringLike s => String -> GenRegex s
mkZero' String
"") (GenRegex s
p1 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 <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
rest Char
c1
                     forall (m :: * -> *) a. Monad m => a -> m a
return 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
                = forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Char
c1 (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar)

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

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

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