{-# 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
    = parseRegex' mkSymRng . toString

parseRegexNoCase :: StringLike s => s -> GenRegex s
parseRegexNoCase
    = parseRegex' mkNoCaseSymRng . toString

parseRegex' :: StringLike s => (Char -> Char -> GenRegex s) -> String -> GenRegex s
parseRegex' mkS
    = either (mkZero' . ("syntax error: " ++) . show) id
      .
      parse ( do
              r <- pattern mkS
              eof
              return r
            ) ""

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

pattern  :: StringLike s => (Char -> Char -> GenRegex s) -> Parser (GenRegex s)
pattern mkS
    = many part >>= return . mkSeqs
    where
      -- part :: Parser (GenRegex s)
      part
          = ( many1 (noneOf "\\?*[{") >>= return . mkWord' )
            <|>
            ( char '?' >> return mkDot )
            <|>
            ( char '*' >> return mkAll )
            <|>
            ( between (char '{') (char '}') wordList )
            <|>
            ( between (char '[') (char ']') charSet )
            <|>
            ( do c <- char '\\' >> anyChar
                 return $ mkS c c
            )
      mkWord'
          = mkSeqs . map (\ c -> mkS c c)

      -- wordList :: Parser (GenRegex s)
      wordList
          = sepBy (many1 (noneOf ",}")) (char ',')
            >>= return . foldr mkAlt (mkZero' "") . map mkWord'

      -- charSet :: Parser (GenRegex s)
      charSet
          = ( do p1 <- charSet' anyChar
                 ps <- many $ charSet' (noneOf "]")
                 return $ foldr mkAlt (mkZero' "") (p1 : ps)
            )
          where
            charSet' cp
                = do c1 <- cp
                     c2 <- rest c1
                     return $ mkS c1 c2
            rest c1
                = option c1 (char '-' >> anyChar)

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

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

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