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

{- |
   Module     : Text.XML.HXT.RelaxNG.XmlSchema.RegexParser
   Copyright  : Copyright (C) 2005 Uwe Schmidt
   License    : MIT

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

   W3C XML Schema Regular Expression Parser

   This parser supports the full W3C standard, the
   complete grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>

-}

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

module Text.XML.HXT.RelaxNG.XmlSchema.RegexParser
    ( parseRegex )
where

import Data.Maybe

import Text.ParserCombinators.Parsec

import Text.XML.HXT.DOM.Unicode

import Text.XML.HXT.RelaxNG.Unicode.Blocks
import Text.XML.HXT.RelaxNG.Unicode.CharProps
import Text.XML.HXT.RelaxNG.XmlSchema.Regex

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

parseRegex :: String -> Either String Regex
parseRegex
    = either (Left . show) Right
      .
      parse ( do
              r <- regExp
              eof
              return r
            ) ""

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

regExp  :: Parser Regex
regExp
    = do
      r1 <- branch
      rs <- many branch1
      return (foldr1 mkAlt $ r1:rs)
    where
    branch1
        = do
          _ <- char '|'
          branch

branch  :: Parser Regex
branch
    = do
      rs <- many piece
      return $ foldr mkSeq mkUnit rs

piece   :: Parser Regex
piece
    = do
      r <- atom
      quantifier r

quantifier      :: Regex -> Parser Regex
quantifier r
    = ( do
        _ <- char '?'
        return $ mkOpt r )
      <|>
      ( do
        _ <- char '*'
        return $ mkStar r )
      <|>
      ( do
        _ <- char '+'
        return $ mkRep 1 r )
      <|>
      ( do
        _ <- char '{'
        res <- quantity r
        _ <- char '}'
        return res
      )
      <|>
      ( return r )

quantity        :: Regex -> Parser Regex
quantity r
    = do
      lb <- many1 digit
      quantityRest r (read lb)

quantityRest    :: Regex -> Int -> Parser Regex
quantityRest r lb
    = ( do
        _ <- char ','
        ub <- many digit
        return ( if null ub
                 then mkRep lb r
                 else mkRng lb (read ub) r
               )
      )
      <|>
      ( return $ mkRng lb lb r)

atom    :: Parser Regex
atom
    = char1
      <|>
      charClass
      <|>
      between (char '(') (char ')') regExp

char1   :: Parser Regex
char1
    = do
      c <- satisfy $ (`notElem` ".\\?*+{}()|[]")
      return $ mkSym1 c

charClass       :: Parser Regex
charClass
    = charClassEsc
      <|>
      charClassExpr
      <|>
      wildCardEsc

charClassEsc    :: Parser Regex
charClassEsc
    = do
      _ <- char '\\'
      ( singleCharEsc
        <|>
        multiCharEsc
        <|>
        catEsc
        <|>
        complEsc )

singleCharEsc   :: Parser Regex
singleCharEsc
    = do
      c <- singleCharEsc'
      return $ mkSym1 c

singleCharEsc'  :: Parser Char
singleCharEsc'
    = do
      c <- satisfy (`elem` "nrt\\|.?*+(){}-[]^")
      return $ maybe c id . lookup c . zip "ntr" $ "\n\r\t"

multiCharEsc    :: Parser Regex
multiCharEsc
    = do
      c <- satisfy (`elem` es)
      return $ mkSym . fromJust . lookup c $ pm
    where
    es = map fst pm
    pm = [ ('s',       isXmlSpaceChar           )
         , ('S', not . isXmlSpaceChar           )
         , ('i',       isXmlNameStartChar       )
         , ('I', not . isXmlNameStartChar       )
         , ('c',       isXmlNameChar            )
         , ('C', not . isXmlNameChar            )
         , ('d',       isDigit                  )
         , ('D', not . isDigit                  )
         , ('w', not . isNotWord                )
         , ('W',       isNotWord                )
         ]
    isDigit   = ('0' <=) <&&> (<= '9')
    isNotWord = isUnicodeP <||>
                isUnicodeZ <||>
                isUnicodeC

catEsc  :: Parser Regex
catEsc
    = do
      _ <- char 'p'
      s <- between (char '{') (char '}') charProp
      return $ mkSym s

charProp        :: Parser (Char -> Bool)
charProp
    = isCategory
      <|>
      isBlock

isBlock         :: Parser (Char -> Bool)
isBlock
    = do
      _ <- string "Is"
      name <- many1 (satisfy legalChar)
      let b = lookup name codeBlocks
      if isJust b
         then return $ let
                       (lb, ub) = fromJust b
                       in
                       (lb <=) <&&> (<= ub)
         else fail   $ "unknown Unicode code block " ++ show name
    where
    legalChar c  = 'A' <= c && c <= 'Z' ||
                   'a' <= c && c <= 'z' ||
                   '0' <= c && c <= '9' ||
                   '-' == c

isCategory      :: Parser (Char -> Bool)
isCategory
    = do
      pr <- isCategory'
      return $ fromJust (lookup pr categories)

categories      :: [(String, Char -> Bool)]
categories
    = [ ("C",  isUnicodeC )
      , ("Cc", isUnicodeCc)
      , ("Cf", isUnicodeCf)
      , ("Co", isUnicodeCo)
      , ("Cs", isUnicodeCs)
      , ("L",  isUnicodeL )
      , ("Ll", isUnicodeLl)
      , ("Lm", isUnicodeLm)
      , ("Lo", isUnicodeLo)
      , ("Lt", isUnicodeLt)
      , ("Lu", isUnicodeLu)
      , ("M",  isUnicodeM )
      , ("Mc", isUnicodeMc)
      , ("Me", isUnicodeMe)
      , ("Mn", isUnicodeMn)
      , ("N",  isUnicodeN )
      , ("Nd", isUnicodeNd)
      , ("Nl", isUnicodeNl)
      , ("No", isUnicodeNo)
      , ("P",  isUnicodeP )
      , ("Pc", isUnicodePc)
      , ("Pd", isUnicodePd)
      , ("Pe", isUnicodePe)
      , ("Pf", isUnicodePf)
      , ("Pi", isUnicodePi)
      , ("Po", isUnicodePo)
      , ("Ps", isUnicodePs)
      , ("S",  isUnicodeS )
      , ("Sc", isUnicodeSc)
      , ("Sk", isUnicodeSk)
      , ("Sm", isUnicodeSm)
      , ("So", isUnicodeSo)
      , ("Z",  isUnicodeZ )
      , ("Zl", isUnicodeZl)
      , ("Zp", isUnicodeZp)
      , ("Zs", isUnicodeZs)
      ]

isCategory'     :: Parser String
isCategory'
    = ( foldr1 (<|>) . map (uncurry prop) $
        [ ('L', "ultmo")
        , ('M', "nce")
        , ('N', "dlo")
        , ('P', "cdseifo")
        , ('Z', "slp")
        , ('S', "mcko")
        , ('C', "cfon")
        ]
      ) <?> "illegal Unicode character property"
    where
    prop c1 cs2
        = do
          _ <- char c1
          s2 <- option ""
                ( do
                  c2 <- satisfy (`elem` cs2)
                  return [c2] )
          return $ c1:s2

complEsc        :: Parser Regex
complEsc
    = do
      _ <- char 'P'
      s <- between (char '{') (char '}') charProp
      return $ mkSym (not . s)

charClassExpr   :: Parser Regex
charClassExpr
    = between (char '[') (char ']') charGroup

charGroup       :: Parser Regex
charGroup
    = do
      r <- ( negCharGroup       -- a ^ at beginning denotes negation, not start of posCharGroup
             <|>
             posCharGroup
           )
      s <- option (mkZero "")   -- charClassSub
           ( do
             _ <- char '-'
             charClassExpr
           )
      return $ mkDif r s

posCharGroup    :: Parser Regex
posCharGroup
    = do
      rs <- many1 (charRange <|> charClassEsc)
      return $ foldr1 mkAlt rs

charRange       :: Parser Regex
charRange
    = try seRange
      <|>
      xmlCharIncDash

seRange :: Parser Regex
seRange
    = do
      c1 <- charOrEsc'
      _ <- char '-'
      c2 <- charOrEsc'
      return $ mkSymRng c1 c2

charOrEsc'      :: Parser Char
charOrEsc'
    = satisfy (`notElem` "\\-[]")
      <|>
      singleCharEsc'

xmlCharIncDash  :: Parser Regex
xmlCharIncDash
    = do
      c <- satisfy (`notElem` "\\[]")
      return $ mkSym1 c

negCharGroup    :: Parser Regex
negCharGroup
    = do
      _ <- char '^'
      r <- posCharGroup
      return $ mkCompl r

wildCardEsc     :: Parser Regex
wildCardEsc
    = do
      _ <- char '.'
      return $ mkSym (`notElem` "\n\r")


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