{-# LANGUAGE FlexibleContexts #-}
module Text.Regex.Deriv.Parse (parsePat, parseEPat, parsePatPosix) where

{- By Kenny Zhuo Ming Lu and Martin Sulzmann, 2009. BSD3 -}

-- The parser that parse POSIX style regex syntax and translate it into our 
-- internal pattern representation.
-- This parser is largely adapted from Text.Regex.TDFA.ReadRegex

import Data.Char
import Text.ParserCombinators.Parsec((<|>),
                                     unexpected, try, runParser, many, getState, CharParser, ParseError,
                                     sepBy1, option, many1, lookAhead, eof, between,
                                     string, noneOf, digit, char, anyChar)
import Control.Monad(liftM, when, guard)
import Data.List (sort,nub)
import qualified Data.IntMap as IM

import Text.Regex.Deriv.ExtPattern (EPat(..))
import Text.Regex.Deriv.IntPattern (Pat(..))
import Text.Regex.Deriv.Translate (translate, translatePosix) 

type EState = ()
initEState :: EState
initEState = ()

-- | Return either a parse error or an external pattern
parseEPat :: String -> Either ParseError (EPat, EState)
parseEPat x = runParser (do { pat <- p_ere
                            ; eof
                            ; state <- getState
                            ; return (pat,state)
                            } ) initEState x x

parsePat :: String -> Either ParseError Pat
parsePat x = case parseEPat x of
             { Left err -> Left err
             ; Right (epat, _) -> Right (translate epat)
             }

-- posix pattern parsing: we need to add binders everywhere

parsePatPosix :: String -> Either ParseError (Pat,IM.IntMap ())
parsePatPosix x = case parseEPat x of
                  { Left err -> Left err
                  ; Right (epat, _) -> Right (translatePosix epat)
                  }


p_ere :: CharParser EState EPat
p_ere = liftM EOr $ sepBy1 p_branch (char '|')

p_branch :: CharParser EState EPat
p_branch = liftM EConcat $ many1 p_exp

p_exp :: CharParser EState EPat
p_exp = (p_anchor <|> p_atom) >>= p_post_anchor_or_atom

p_anchor :: CharParser EState EPat
p_anchor = ((char '^') >> (return ECarat))       -- '^'
           <|>
           ((char '$') >> (return EDollar))      -- '$'

-- todo '{'

p_atom :: CharParser EState EPat
p_atom = p_group <|>
         p_charclass <|>
         p_dot <|>
         p_esc_char <|>
         p_char

--  p_group = liftM EGroup $ between (char '(') (char ')') p_ere

p_group :: CharParser EState EPat
p_group = 
    between (char '(') (char ')') 
                ( try 
                  ( do  
                    { -- non marking group 
                    ; (char '?') 
                    ; (char ':')
                    ; x <- p_ere
                    ; return (EGroupNonMarking x)
                    } 
                  )
                 <|>
                 liftM EGroup p_ere
                )



-- parsing [ ... ] and [^ ... ]
p_charclass :: CharParser EState EPat
p_charclass = 
    (char '[') 
    >> ( do { char '^' 
            ; liftM ENoneOf $ p_enum -- enum ends with ']'
            } 
         <|>
         (liftM EAny $ p_enum)
       )

p_enum :: CharParser EState [Char]
p_enum = do { initial <- (option "" ((char ']' >> return "]") <|> (char '-' >> return "-"))) 
              -- todo : why do we need this here? 
              -- answer: if not, this string can't be parsed "[]f-z]", which is any char of  ']' and  between 'f' to 'z'
            ; chars <- many1 p_one_enum
            ; char ']'
            ; let chars_set = nub (sort (initial ++ (concat chars)))
            ; return chars_set
            }

-- todo: support the locale collating char class [: :] [= =] [. .]

p_one_enum :: CharParser EState [Char]
p_one_enum = p_range <|> p_char_set 

p_range :: CharParser EState [Char]
p_range = try $ do  
          { start <- (try p_esc_char_) <|> noneOf "]-"
          ; char '-'
          ; end <- (try p_esc_char_) <|> noneOf "]"
          ; return [ start .. end ] 
          }

p_char_set :: CharParser EState [Char]
p_char_set = do 
  { c <- (try p_esc_char_) <|> noneOf "]" -- <|> (char '\\' >> p_special_char)
  ; when (c == '-') $
    do -- when it is a dash, it must be at the end of the [..]
    { atEnd <- (lookAhead (char ']') >> return True) <|> (return False)
    ; when (not atEnd) (unexpected "A dash is in the wrong place in a bracket")
    }
  ; return [c]
  }

-- parse the dot (all characters)
p_dot :: CharParser EState EPat
p_dot = char '.' >> (return EDot)

-- parse the escaped chars
p_esc_char_ :: CharParser EState Char
p_esc_char_ = char '\\' >> ((try p_tab) <|> (try p_return) <|> (try p_newline) <|> (try p_oct_ascii) <|> anyChar)

p_esc_char :: CharParser EState EPat
p_esc_char = char '\\' >> ((try p_tab) <|> (try p_return) <|> (try p_newline) <|> (try p_oct_ascii) <|> anyChar) >>= \c -> return (EEscape c)

-- oct ascii, e.g. \000
p_return :: CharParser EState Char
p_return = do 
           { char 'r'
           ; return '\r'
           }

p_newline :: CharParser EState Char
p_newline = do 
            { char 'n'
            ; return '\n'
            }

p_tab :: CharParser EState Char
p_tab = do 
        { char 't'
        ; return '\t'
        }

p_oct_ascii :: CharParser EState Char
p_oct_ascii = do  
              { _ <- digit
              ; d2 <- digit
              ; d3 <- digit
              ; return (chr ((digitToInt d2)*8 + (digitToInt d3)))
              }


-- parse a single non-escaped char

specials :: [Char]
specials = "^.[$()|*+?{\\"

p_char :: CharParser EState EPat
p_char = noneOf specials >>= \c -> return (EChar c)

p_post_anchor_or_atom :: EPat -> CharParser EState EPat
p_post_anchor_or_atom atom = 
    (try (char '?' >> char '?' >> return (EOpt atom False)) <|> (char '?' >> return (EOpt atom True)))
    <|> (try (char '+' >> char '?' >> return (EPlus atom False)) <|> (char '+' >> return (EPlus atom True)))
    <|> (try (char '*' >> char '?' >> return (EStar atom False)) <|> (char '*' >> return (EStar atom True)))
    <|> p_bound_nongreedy atom
    <|> p_bound atom 
    <|> return atom


p_bound_nongreedy :: EPat -> CharParser EState EPat
p_bound_nongreedy atom = try $ between (string "{") (string "}?") (p_bound_spec atom False)

p_bound :: EPat -> CharParser EState EPat
p_bound atom = try $ between (char '{') (char '}') (p_bound_spec atom True)

p_bound_spec :: EPat -> Bool -> CharParser EState EPat
p_bound_spec atom b = do { lowS <- many1 digit
                        ; let lowI = read lowS
                        ; highMI <- option (Just lowI) $ try $ 
                          do { char ','
 -- parsec note: if 'many digits' fails below then the 'try' ensures
 -- that the ',' will not match the closing '}' in p_bound, same goes
 -- for any non '}' garbage after the 'many digits'.
                             ; highS <- many digit
                             ; if null highS then return Nothing -- no upper bound
                               else do { let highI = read highS
                                       ; guard (lowI <= highI)
                                       ; return (Just (read highS))
                                       }
                             }
                        ; return (EBound atom lowI highMI b)
                        }



