content: {-# LANGUAGE FlexibleContexts #-}
  
  -- ------------------------------------------------------------
  
  {- |
     Module     : Text.Regex.XMLSchema.RegexParser
     Copyright  : Copyright (C) 2014- Uwe Schmidt
     License    : MIT
  
     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
     Stability  : stable
     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>
     and extensions for all missing set operations, intersection,
     difference, exclusive or, interleave, complement
  
  -}
  
  -- ------------------------------------------------------------
  
  module Text.Regex.XMLSchema.Generic.RegexParser
      ( parseRegex
      , parseRegexExt
      , parseRegex'
      , parseRegexExt'
      , parseContextRegex
      )
  where
  
  import           Data.Char.Properties.UnicodeBlocks
  import           Data.Char.Properties.UnicodeCharProps
  import           Data.Char.Properties.XMLCharProps
  
  import           Data.List                               (isPrefixOf,
                                                            isSuffixOf)
  import           Data.Maybe
  import           Data.Set.CharSet
  
  import           Text.ParserCombinators.Parsec
  import           Text.Regex.XMLSchema.Generic.Regex
  import           Text.Regex.XMLSchema.Generic.StringLike
  
  -- ------------------------------------------------------------
  
  -- | parse a standard W3C XML Schema regular expression
  
  parseRegex              :: StringLike s => s -> GenRegex s
  parseRegex              = parseRegex' . toString
  
  parseRegex'             :: StringLike s => String -> GenRegex s
  parseRegex'             = parseRegex'' regExpStd
  
  -- | parse an extended syntax W3C XML Schema regular expression
  --
  -- The Syntax of the W3C XML Schema spec is extended by
  -- further useful set operations, like intersection, difference, exor.
  -- Subexpression match becomes possible with \"named\" pairs of parentheses.
  -- The multi char escape sequence \\a represents any Unicode char,
  -- The multi char escape sequence \\A represents any Unicode word, (\\A = \\a*).
  -- All syntactically wrong inputs are mapped to the Zero expression representing the
  -- empty set of words. Zero contains as data field a string for an error message.
  -- So error checking after parsing becomes possible by checking against Zero ('isZero' predicate)
  
  parseRegexExt   :: StringLike s => s -> GenRegex s
  parseRegexExt   = parseRegexExt' . toString
  
  parseRegexExt'  :: StringLike s => String -> GenRegex s
  parseRegexExt'  = parseRegex'' regExpExt
  
  parseRegex'' :: StringLike s => Parser (GenRegex s) -> String -> GenRegex s
  parseRegex'' regExp'
    = either (mkZero' . ("syntax error: " ++) . show) id
      . parse ( do
                   r <- regExp'
                   eof
                   return r
              ) ""
  
  -- ------------------------------------------------------------
  
  -- | parse a regular expression surrounded by contenxt spec
  --
  -- a leading @^@ denotes start of text,
  -- a trailing @$@ denotes end of text,
  -- a leading @\\<@ denotes word start,
  -- a trailing @\\>@ denotes word end.
  --
  -- The 1. param ist the regex parser ('parseRegex' or 'parseRegexExt')
  
  parseContextRegex :: StringLike s => (String -> GenRegex s) -> s -> GenRegex s
  parseContextRegex parseRe re0
      = re'
      where
        parseAW = parseRegexExt' "(\\A\\W)?"
        parseWA = parseRegexExt' "(\\W\\A)?"
  
        re  = toString re0
        re' = mkSeqs . concat $ [ startContext
                                , (:[]) . parseRe $ re2
                                , endContext
                                ]
        (startContext, re1)
            | "^"   `isPrefixOf` re   = ([],             tail   re)
            | "\\<" `isPrefixOf` re   = ([parseAW],      drop 2 re)
            | otherwise               = ([mkStar mkDot],        re)
        (endContext, re2)
            | "$"   `isSuffixOf` re1  = ([],             init          re1)
            | "\\>" `isSuffixOf` re1  = ([parseWA],      init . init $ re1)
            | otherwise               = ([mkStar mkDot],               re1)
  
  -- ------------------------------------------------------------
  
  regExpExt  :: StringLike s => Parser (GenRegex s)
  regExpExt  = branchList orElseList
  
  regExpStd  :: StringLike s => Parser (GenRegex s)
  regExpStd  = branchList seqListStd
  
  branchList :: StringLike s => Parser (GenRegex s) -> Parser (GenRegex s)
  branchList exParser
      = do
        r1 <- exParser
        rs <- many branchList1
        return (foldr1 mkAlt $ r1:rs)     -- union is associative, so we use right ass.
                                          -- as with seq, alt and exor
      where
      branchList1
          = do
            _ <- char '|'
            exParser
  
  orElseList      :: StringLike s => Parser (GenRegex s)
  orElseList
      = do
        r1 <- interleaveList
        rs <- many orElseList1
        return (foldr1 mkElse $ r1:rs)    -- orElse is associative, so we choose right ass.
                                          -- as with seq and alt ops
      where
      orElseList1
          = do
            _ <- try (string "{|}")
            interleaveList
  
  interleaveList  :: StringLike s => Parser (GenRegex s)
  interleaveList
      = do
        r1 <- exorList
        rs <- many interleaveList1
        return (foldr1 mkInterleave $ r1:rs)      -- interleave is associative, so we choose right ass.
                                                  -- as with seq and alt ops
      where
      interleaveList1
          = do
            _ <- try (string "{:}")
            exorList
  
  exorList        :: StringLike s => Parser (GenRegex s)
  exorList
      = do
        r1 <- diffList
        rs <- many exorList1
        return (foldr1 mkExor $ r1:rs)    -- exor is associative, so we choose right ass.
      where
      exorList1
          = do
            _ <- try (string "{^}")
            diffList
  
  diffList        :: StringLike s => Parser (GenRegex s)
  diffList
      = do
        r1 <- intersectList
        rs <- many diffList1
        return (foldl1 mkDiff $ r1:rs)    -- diff is not associative, so we choose left ass.
      where
      diffList1
          = do
            _ <- try (string "{\\}")
            intersectList
  
  intersectList   :: StringLike s => Parser (GenRegex s)
  intersectList
      = do
        r1 <- seqListExt
        rs <- many intersectList1
        return (foldr1 mkIsect $ r1:rs)
      where
      intersectList1
          = do
            _ <- try (string "{&}")
            seqListExt
  
  seqListExt      :: StringLike s => Parser (GenRegex s)
  seqListExt      = seqList' regExpLabel multiCharEscExt
  
  seqListStd      :: StringLike s => Parser (GenRegex s)
  seqListStd      = seqList' regExpStd multiCharEsc
  
  seqList'        :: StringLike s => Parser (GenRegex s) -> Parser (GenRegex s) -> Parser (GenRegex s)
  seqList' regExp' multiCharEsc'
      = do
        rs <- many piece
        return $ mkSeqs rs
      where
      -- piece :: StringLike s => Parser (GenRegex s)
      piece
          = do
            r <- atom
            quantifier r
  
      -- atom :: StringLike s => Parser (GenRegex s)
      atom
          = char1
            <|>
            charClass
            <|>
            between (char '(') (char ')') regExp'
  
      -- charClass :: StringLike s => Parser (GenRegex s)
      charClass
          = charClassEsc multiCharEsc'
            <|>
            charClassExpr multiCharEsc'
            <|>
            wildCardEsc
  
  
  
  quantifier      :: StringLike s => GenRegex s -> Parser (GenRegex s)
  quantifier r
      = ( do
          _ <- char '?'
          return $ mkOpt r )
        <|>
        ( do
          _ <- char '*'
          return $ mkStar r )
        <|>
        ( do
          _ <- char '+'
          return $ mkRep 1 r )
        <|>
        try ( do
              _ <- char '{'
              res <- quantity r
              _ <- char '}'
              return res
            )
        <|>
        ( return r )
  
  quantity        :: StringLike s => GenRegex s -> Parser (GenRegex s)
  quantity r
      = do
        lb <- many1 digit
        quantityRest r (read lb)
  
  quantityRest    :: StringLike s => GenRegex s -> Int -> Parser (GenRegex s)
  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)
  
  regExpLabel :: StringLike s => Parser (GenRegex s)
  regExpLabel
      = do
        lab <- option id (between (char '{') (char '}') label')
        r    <- regExpExt
        return $ lab r
      where
      label'
          = do
            l <- many1 (satisfy isXmlNameChar)
            return $ mkBr' l
  
  char1   :: StringLike s => Parser (GenRegex s)
  char1
      = do
        c <- satisfy (`notElem` ".\\?*+{}()|[]")
        return $ mkSym1 c
  
  charClassEsc    :: StringLike s => Parser (GenRegex s) -> Parser (GenRegex s)
  charClassEsc multiCharEsc'
      = do
        _ <- char '\\'
        ( singleCharEsc
          <|>
          multiCharEsc'
          <|>
          catEsc
          <|>
          complEsc )
  
  singleCharEsc   :: StringLike s => Parser (GenRegex s)
  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\t\r"
  
  multiCharEscExt    :: StringLike s => Parser (GenRegex s)
  multiCharEscExt
      = multiCharEsc
        <|>
        ( do                      -- extension: \a represents the whole alphabet inclusive newline chars: \a == .|\n|\r
          _ <- char 'a'
          return mkDot )
        <|>
        ( do                      -- extension: \A represents all words: \A == \a* or \A == (.|\n|\r)*
          _ <- char 'A'
          return mkAll )
  
  multiCharEsc    :: StringLike s => Parser (GenRegex s)
  multiCharEsc
      = ( do
          c <- satisfy (`elem` es)
          return $ mkSym . fromJust . lookup c $ pm )
      where
      es = map fst pm
      pm = [ ('s',        charPropXmlSpaceChar          )
           , ('S', compCS charPropXmlSpaceChar          )
           , ('i',        charPropXmlNameStartChar      )
           , ('I', compCS charPropXmlNameStartChar      )
           , ('c',        charPropXmlNameChar           )
           , ('C', compCS charPropXmlNameChar           )
           , ('d',        charPropDigit                 )
           , ('D', compCS charPropDigit                 )
           , ('w', compCS charPropNotWord               )
           , ('W',        charPropNotWord               )
           ]
      charPropDigit   = rangeCS '0' '9'
      charPropNotWord = charPropUnicodeP
                        `unionCS`
                        charPropUnicodeZ
                        `unionCS`
                        charPropUnicodeC
  
  catEsc  :: StringLike s => Parser (GenRegex s)
  catEsc
      = do
        _ <- char 'p'
        s <- between (char '{') (char '}') charProp
        return $ mkSym s
  
  charProp        :: Parser CharSet
  charProp
      = isCategory
        <|>
        isBlock
  
  isBlock         :: Parser CharSet
  isBlock
      = do
        _ <- string "Is"
        name <- many1 (satisfy legalChar)
        case lookup name codeBlocks of
          Just b  -> return $ uncurry rangeCS b
          Nothing -> 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 CharSet
  isCategory
      = do
        pr <- isCategory'
        return $ fromJust (lookup pr categories)
  
  categories      :: [(String, CharSet)]
  categories
      = [ ("C",  charPropUnicodeC )
        , ("Cc", charPropUnicodeCc)
        , ("Cf", charPropUnicodeCf)
        , ("Co", charPropUnicodeCo)
        , ("Cs", charPropUnicodeCs)
        , ("L",  charPropUnicodeL )
        , ("Ll", charPropUnicodeLl)
        , ("Lm", charPropUnicodeLm)
        , ("Lo", charPropUnicodeLo)
        , ("Lt", charPropUnicodeLt)
        , ("Lu", charPropUnicodeLu)
        , ("M",  charPropUnicodeM )
        , ("Mc", charPropUnicodeMc)
        , ("Me", charPropUnicodeMe)
        , ("Mn", charPropUnicodeMn)
        , ("N",  charPropUnicodeN )
        , ("Nd", charPropUnicodeNd)
        , ("Nl", charPropUnicodeNl)
        , ("No", charPropUnicodeNo)
        , ("P",  charPropUnicodeP )
        , ("Pc", charPropUnicodePc)
        , ("Pd", charPropUnicodePd)
        , ("Pe", charPropUnicodePe)
        , ("Pf", charPropUnicodePf)
        , ("Pi", charPropUnicodePi)
        , ("Po", charPropUnicodePo)
        , ("Ps", charPropUnicodePs)
        , ("S",  charPropUnicodeS )
        , ("Sc", charPropUnicodeSc)
        , ("Sk", charPropUnicodeSk)
        , ("Sm", charPropUnicodeSm)
        , ("So", charPropUnicodeSo)
        , ("Z",  charPropUnicodeZ )
        , ("Zl", charPropUnicodeZl)
        , ("Zp", charPropUnicodeZp)
        , ("Zs", charPropUnicodeZs)
        ]
  
  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        :: StringLike s => Parser (GenRegex s)
  complEsc
      = do
        _ <- char 'P'
        s <- between (char '{') (char '}') charProp
        return $ mkSym $ compCS s
  
  charClassExpr   :: StringLike s => Parser (GenRegex s) -> Parser (GenRegex s)
  charClassExpr multiCharEsc'
      = between (char '[') (char ']') charGroup
      where
  
      -- charGroup       :: StringLike s => Parser (GenRegex s)
      charGroup
          = do
            r <- ( negCharGroup       -- a ^ at beginning denotes negation, not start of posCharGroup
                   <|>
                   posCharGroup
                 )
            s <- option (mkZero' "")   -- charClassSub
                 ( do
                   _ <- char '-'
                   charClassExpr multiCharEsc'
                 )
            return $ mkDiff r s
  
      -- posCharGroup    :: StringLike s => Parser (GenRegex s)
      posCharGroup
          = do
            rs <- many1 (charRange <|> charClassEsc multiCharEsc')
            return $ foldr1 mkAlt rs
  
      -- negCharGroup    :: StringLike s => Parser (GenRegex s)
      negCharGroup
          = do
            _ <- char '^'
            r <- posCharGroup
            return $ mkDiff mkDot r
  
  charRange       :: StringLike s => Parser (GenRegex s)
  charRange
      = try seRange
        <|>
        xmlCharIncDash
  
  seRange :: StringLike s => Parser (GenRegex s)
  seRange
      = do
        c1 <- charOrEsc'
        _ <- char '-'
        c2 <- charOrEsc'
        return $ mkSymRng c1 c2
  
  charOrEsc'      :: Parser Char
  charOrEsc'
      = ( do
          _ <- char '\\'
          singleCharEsc'
        )
        <|>
        satisfy (`notElem` "\\-[]")
  
  xmlCharIncDash  :: StringLike s => Parser (GenRegex s)
  xmlCharIncDash
      = try ( do                          -- dash is only allowed if not followed by a [, else charGroup differences do not parse correctly
              _ <- char '-'
              notFollowedBy (char '[')
              return $ mkSym1 '-'
            )
        <|>
        ( do
          c <- satisfy (`notElem` "-\\[]")
          return $ mkSym1 c
        )
  
  wildCardEsc     :: StringLike s => Parser (GenRegex s)
  wildCardEsc
      = do
        _ <- char '.'
        return . mkSym . compCS $ stringCS "\n\r"
  
  
  -- ------------------------------------------------------------
  