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

    {- |
       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")

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