{-# 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 :: forall s. StringLike s => s -> GenRegex s
parseRegex              = forall s. StringLike s => String -> GenRegex s
parseRegex' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. StringLike a => a -> String
toString

parseRegex'             :: StringLike s => String -> GenRegex s
parseRegex' :: forall s. StringLike s => String -> GenRegex s
parseRegex'             = forall s.
StringLike s =>
Parser (GenRegex s) -> String -> GenRegex s
parseRegex'' forall s. StringLike s => Parser (GenRegex s)
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 :: forall s. StringLike s => s -> GenRegex s
parseRegexExt   = forall s. StringLike s => String -> GenRegex s
parseRegexExt' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. StringLike a => a -> String
toString

parseRegexExt'  :: StringLike s => String -> GenRegex s
parseRegexExt' :: forall s. StringLike s => String -> GenRegex s
parseRegexExt'  = forall s.
StringLike s =>
Parser (GenRegex s) -> String -> GenRegex s
parseRegex'' forall s. StringLike s => Parser (GenRegex s)
regExpExt

parseRegex'' :: StringLike s => Parser (GenRegex s) -> String -> GenRegex s
parseRegex'' :: forall s.
StringLike s =>
Parser (GenRegex s) -> String -> GenRegex s
parseRegex'' Parser (GenRegex s)
regExp'
  = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall s. StringLike s => String -> GenRegex s
mkZero' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"syntax error: " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a. a -> a
id
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse ( do
                 GenRegex s
r <- Parser (GenRegex s)
regExp'
                 forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
                 forall (m :: * -> *) a. Monad m => a -> m a
return GenRegex s
r
            ) String
""

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

-- | 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 :: forall s. StringLike s => (String -> GenRegex s) -> s -> GenRegex s
parseContextRegex String -> GenRegex s
parseRe s
re0
    = GenRegex s
re'
    where
      parseAW :: GenRegex s
parseAW = forall s. StringLike s => String -> GenRegex s
parseRegexExt' String
"(\\A\\W)?"
      parseWA :: GenRegex s
parseWA = forall s. StringLike s => String -> GenRegex s
parseRegexExt' String
"(\\W\\A)?"

      re :: String
re  = forall a. StringLike a => a -> String
toString s
re0
      re' :: GenRegex s
re' = forall s. [GenRegex s] -> GenRegex s
mkSeqs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [ [GenRegex s]
startContext
                              , (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GenRegex s
parseRe forall a b. (a -> b) -> a -> b
$ String
re2
                              , [GenRegex s]
endContext
                              ]
      ([GenRegex s]
startContext, String
re1)
          | String
"^"   forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
re   = ([],             forall a. [a] -> [a]
tail   String
re)
          | String
"\\<" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
re   = ([GenRegex s
parseAW],      forall a. Int -> [a] -> [a]
drop Int
2 String
re)
          | Bool
otherwise               = ([forall s. StringLike s => GenRegex s -> GenRegex s
mkStar forall s. GenRegex s
mkDot],        String
re)
      ([GenRegex s]
endContext, String
re2)
          | String
"$"   forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
re1  = ([],             forall a. [a] -> [a]
init          String
re1)
          | String
"\\>" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
re1  = ([GenRegex s
parseWA],      forall a. [a] -> [a]
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
init forall a b. (a -> b) -> a -> b
$ String
re1)
          | Bool
otherwise               = ([forall s. StringLike s => GenRegex s -> GenRegex s
mkStar forall s. GenRegex s
mkDot],               String
re1)

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

regExpExt  :: StringLike s => Parser (GenRegex s)
regExpExt :: forall s. StringLike s => Parser (GenRegex s)
regExpExt  = forall s.
StringLike s =>
Parser (GenRegex s) -> Parser (GenRegex s)
branchList forall s. StringLike s => Parser (GenRegex s)
orElseList

regExpStd  :: StringLike s => Parser (GenRegex s)
regExpStd :: forall s. StringLike s => Parser (GenRegex s)
regExpStd  = forall s.
StringLike s =>
Parser (GenRegex s) -> Parser (GenRegex s)
branchList forall s. StringLike s => Parser (GenRegex s)
seqListStd

branchList :: StringLike s => Parser (GenRegex s) -> Parser (GenRegex s)
branchList :: forall s.
StringLike s =>
Parser (GenRegex s) -> Parser (GenRegex s)
branchList Parser (GenRegex s)
exParser
    = do
      GenRegex s
r1 <- Parser (GenRegex s)
exParser
      [GenRegex s]
rs <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser (GenRegex s)
branchList1
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkAlt forall a b. (a -> b) -> a -> b
$ GenRegex s
r1forall a. a -> [a] -> [a]
:[GenRegex s]
rs)     -- union is associative, so we use right ass.
                                        -- as with seq, alt and exor
    where
    branchList1 :: Parser (GenRegex s)
branchList1
        = do
          Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'|'
          Parser (GenRegex s)
exParser

orElseList      :: StringLike s => Parser (GenRegex s)
orElseList :: forall s. StringLike s => Parser (GenRegex s)
orElseList
    = do
      GenRegex s
r1 <- forall s. StringLike s => Parser (GenRegex s)
interleaveList
      [GenRegex s]
rs <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser (GenRegex s)
orElseList1
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkElse forall a b. (a -> b) -> a -> b
$ GenRegex s
r1forall a. a -> [a] -> [a]
:[GenRegex s]
rs)    -- orElse is associative, so we choose right ass.
                                        -- as with seq and alt ops
    where
    orElseList1 :: Parser (GenRegex s)
orElseList1
        = do
          String
_ <- forall tok st a. GenParser tok st a -> GenParser tok st a
try (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"{|}")
          forall s. StringLike s => Parser (GenRegex s)
interleaveList

interleaveList  :: StringLike s => Parser (GenRegex s)
interleaveList :: forall s. StringLike s => Parser (GenRegex s)
interleaveList
    = do
      GenRegex s
r1 <- forall s. StringLike s => Parser (GenRegex s)
exorList
      [GenRegex s]
rs <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser (GenRegex s)
interleaveList1
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall s. GenRegex s -> GenRegex s -> GenRegex s
mkInterleave forall a b. (a -> b) -> a -> b
$ GenRegex s
r1forall a. a -> [a] -> [a]
:[GenRegex s]
rs)      -- interleave is associative, so we choose right ass.
                                                -- as with seq and alt ops
    where
    interleaveList1 :: Parser (GenRegex s)
interleaveList1
        = do
          String
_ <- forall tok st a. GenParser tok st a -> GenParser tok st a
try (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"{:}")
          forall s. StringLike s => Parser (GenRegex s)
exorList

exorList        :: StringLike s => Parser (GenRegex s)
exorList :: forall s. StringLike s => Parser (GenRegex s)
exorList
    = do
      GenRegex s
r1 <- forall s. StringLike s => Parser (GenRegex s)
diffList
      [GenRegex s]
rs <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser (GenRegex s)
exorList1
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkExor forall a b. (a -> b) -> a -> b
$ GenRegex s
r1forall a. a -> [a] -> [a]
:[GenRegex s]
rs)    -- exor is associative, so we choose right ass.
    where
    exorList1 :: Parser (GenRegex s)
exorList1
        = do
          String
_ <- forall tok st a. GenParser tok st a -> GenParser tok st a
try (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"{^}")
          forall s. StringLike s => Parser (GenRegex s)
diffList

diffList        :: StringLike s => Parser (GenRegex s)
diffList :: forall s. StringLike s => Parser (GenRegex s)
diffList
    = do
      GenRegex s
r1 <- forall s. StringLike s => Parser (GenRegex s)
intersectList
      [GenRegex s]
rs <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser (GenRegex s)
diffList1
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkDiff forall a b. (a -> b) -> a -> b
$ GenRegex s
r1forall a. a -> [a] -> [a]
:[GenRegex s]
rs)    -- diff is not associative, so we choose left ass.
    where
    diffList1 :: Parser (GenRegex s)
diffList1
        = do
          String
_ <- forall tok st a. GenParser tok st a -> GenParser tok st a
try (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"{\\}")
          forall s. StringLike s => Parser (GenRegex s)
intersectList

intersectList   :: StringLike s => Parser (GenRegex s)
intersectList :: forall s. StringLike s => Parser (GenRegex s)
intersectList
    = do
      GenRegex s
r1 <- forall s. StringLike s => Parser (GenRegex s)
seqListExt
      [GenRegex s]
rs <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser (GenRegex s)
intersectList1
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkIsect forall a b. (a -> b) -> a -> b
$ GenRegex s
r1forall a. a -> [a] -> [a]
:[GenRegex s]
rs)
    where
    intersectList1 :: Parser (GenRegex s)
intersectList1
        = do
          String
_ <- forall tok st a. GenParser tok st a -> GenParser tok st a
try (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"{&}")
          forall s. StringLike s => Parser (GenRegex s)
seqListExt

seqListExt      :: StringLike s => Parser (GenRegex s)
seqListExt :: forall s. StringLike s => Parser (GenRegex s)
seqListExt      = forall s.
StringLike s =>
Parser (GenRegex s) -> Parser (GenRegex s) -> Parser (GenRegex s)
seqList' forall s. StringLike s => Parser (GenRegex s)
regExpLabel forall s. StringLike s => Parser (GenRegex s)
multiCharEscExt

seqListStd      :: StringLike s => Parser (GenRegex s)
seqListStd :: forall s. StringLike s => Parser (GenRegex s)
seqListStd      = forall s.
StringLike s =>
Parser (GenRegex s) -> Parser (GenRegex s) -> Parser (GenRegex s)
seqList' forall s. StringLike s => Parser (GenRegex s)
regExpStd forall s. StringLike s => Parser (GenRegex s)
multiCharEsc

seqList'        :: StringLike s => Parser (GenRegex s) -> Parser (GenRegex s) -> Parser (GenRegex s)
seqList' :: forall s.
StringLike s =>
Parser (GenRegex s) -> Parser (GenRegex s) -> Parser (GenRegex s)
seqList' Parser (GenRegex s)
regExp' Parser (GenRegex s)
multiCharEsc'
    = do
      [GenRegex s]
rs <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser (GenRegex s)
piece
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. [GenRegex s] -> GenRegex s
mkSeqs [GenRegex s]
rs
    where
    -- piece :: StringLike s => Parser (GenRegex s)
    piece :: Parser (GenRegex s)
piece
        = do
          GenRegex s
r <- Parser (GenRegex s)
atom
          forall s. StringLike s => GenRegex s -> Parser (GenRegex s)
quantifier GenRegex s
r

    -- atom :: StringLike s => Parser (GenRegex s)
    atom :: Parser (GenRegex s)
atom
        = forall s. StringLike s => Parser (GenRegex s)
char1
          forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
          Parser (GenRegex s)
charClass
          forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
          forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'(') (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')') Parser (GenRegex s)
regExp'

    -- charClass :: StringLike s => Parser (GenRegex s)
    charClass :: Parser (GenRegex s)
charClass
        = forall s.
StringLike s =>
Parser (GenRegex s) -> Parser (GenRegex s)
charClassEsc Parser (GenRegex s)
multiCharEsc'
          forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
          forall s.
StringLike s =>
Parser (GenRegex s) -> Parser (GenRegex s)
charClassExpr Parser (GenRegex s)
multiCharEsc'
          forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
          forall s. StringLike s => Parser (GenRegex s)
wildCardEsc



quantifier      :: StringLike s => GenRegex s -> Parser (GenRegex s)
quantifier :: forall s. StringLike s => GenRegex s -> Parser (GenRegex s)
quantifier GenRegex s
r
    = ( do
        Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'?'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => GenRegex s -> GenRegex s
mkOpt GenRegex s
r )
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
      ( do
        Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'*'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => GenRegex s -> GenRegex s
mkStar GenRegex s
r )
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
      ( do
        Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'+'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => Int -> GenRegex s -> GenRegex s
mkRep Int
1 GenRegex s
r )
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
      forall tok st a. GenParser tok st a -> GenParser tok st a
try ( do
            Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{'
            GenRegex s
res <- forall s. StringLike s => GenRegex s -> Parser (GenRegex s)
quantity GenRegex s
r
            Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}'
            forall (m :: * -> *) a. Monad m => a -> m a
return GenRegex s
res
          )
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
      ( forall (m :: * -> *) a. Monad m => a -> m a
return GenRegex s
r )

quantity        :: StringLike s => GenRegex s -> Parser (GenRegex s)
quantity :: forall s. StringLike s => GenRegex s -> Parser (GenRegex s)
quantity GenRegex s
r
    = do
      String
lb <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
      forall s. StringLike s => GenRegex s -> Int -> Parser (GenRegex s)
quantityRest GenRegex s
r (forall a. Read a => String -> a
read String
lb)

quantityRest    :: StringLike s => GenRegex s -> Int -> Parser (GenRegex s)
quantityRest :: forall s. StringLike s => GenRegex s -> Int -> Parser (GenRegex s)
quantityRest GenRegex s
r Int
lb
    = ( do
        Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
','
        String
ub <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
        forall (m :: * -> *) a. Monad m => a -> m a
return ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ub
                 then forall s. StringLike s => Int -> GenRegex s -> GenRegex s
mkRep Int
lb GenRegex s
r
                 else forall s. StringLike s => Int -> Int -> GenRegex s -> GenRegex s
mkRng Int
lb (forall a. Read a => String -> a
read String
ub) GenRegex s
r
               )
      )
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
      ( forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => Int -> Int -> GenRegex s -> GenRegex s
mkRng Int
lb Int
lb GenRegex s
r)

regExpLabel :: StringLike s => Parser (GenRegex s)
regExpLabel :: forall s. StringLike s => Parser (GenRegex s)
regExpLabel
    = do
      GenRegex s -> GenRegex s
lab <- forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option forall a. a -> a
id (forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{') (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}') forall {u}. ParsecT String u Identity (GenRegex s -> GenRegex s)
label')
      GenRegex s
r    <- forall s. StringLike s => Parser (GenRegex s)
regExpExt
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GenRegex s -> GenRegex s
lab GenRegex s
r
    where
    label' :: ParsecT String u Identity (GenRegex s -> GenRegex s)
label'
        = do
          String
l <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isXmlNameChar)
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => String -> GenRegex s -> GenRegex s
mkBr' String
l

char1   :: StringLike s => Parser (GenRegex s)
char1 :: forall s. StringLike s => Parser (GenRegex s)
char1
    = do
      Char
c <- forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
".\\?*+{}()|[]")
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => Char -> GenRegex s
mkSym1 Char
c

charClassEsc    :: StringLike s => Parser (GenRegex s) -> Parser (GenRegex s)
charClassEsc :: forall s.
StringLike s =>
Parser (GenRegex s) -> Parser (GenRegex s)
charClassEsc Parser (GenRegex s)
multiCharEsc'
    = do
      Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\'
      ( forall s. StringLike s => Parser (GenRegex s)
singleCharEsc
        forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
        Parser (GenRegex s)
multiCharEsc'
        forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
        forall s. StringLike s => Parser (GenRegex s)
catEsc
        forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
        forall s. StringLike s => Parser (GenRegex s)
complEsc )

singleCharEsc   :: StringLike s => Parser (GenRegex s)
singleCharEsc :: forall s. StringLike s => Parser (GenRegex s)
singleCharEsc
    = do
      Char
c <- Parser Char
singleCharEsc'
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => Char -> GenRegex s
mkSym1 Char
c

singleCharEsc'  :: Parser Char
singleCharEsc' :: Parser Char
singleCharEsc'
    = do
      Char
c <- forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"nrt\\|.?*+(){}-[]^")
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Char
c forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip String
"ntr" forall a b. (a -> b) -> a -> b
$ String
"\n\r\t"

multiCharEscExt    :: StringLike s => Parser (GenRegex s)
multiCharEscExt :: forall s. StringLike s => Parser (GenRegex s)
multiCharEscExt
    = forall s. StringLike s => Parser (GenRegex s)
multiCharEsc
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
      ( do                      -- extension: \a represents the whole alphabet inclusive newline chars: \a == .|\n|\r
        Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'a'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall s. GenRegex s
mkDot )
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
      ( do                      -- extension: \A represents all words: \A == \a* or \A == (.|\n|\r)*
        Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'A'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall s. StringLike s => GenRegex s
mkAll )

multiCharEsc    :: StringLike s => Parser (GenRegex s)
multiCharEsc :: forall s. StringLike s => Parser (GenRegex s)
multiCharEsc
    = ( do
        Char
c <- forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
es)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => CharSet -> GenRegex s
mkSym forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
c forall a b. (a -> b) -> a -> b
$ [(Char, CharSet)]
pm )
    where
    es :: String
es = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Char, CharSet)]
pm
    pm :: [(Char, CharSet)]
pm = [ (Char
's',        CharSet
charPropXmlSpaceChar          )
         , (Char
'S', CharSet -> CharSet
compCS CharSet
charPropXmlSpaceChar          )
         , (Char
'i',        CharSet
charPropXmlNameStartChar      )
         , (Char
'I', CharSet -> CharSet
compCS CharSet
charPropXmlNameStartChar      )
         , (Char
'c',        CharSet
charPropXmlNameChar           )
         , (Char
'C', CharSet -> CharSet
compCS CharSet
charPropXmlNameChar           )
         , (Char
'd',        CharSet
charPropDigit                 )
         , (Char
'D', CharSet -> CharSet
compCS CharSet
charPropDigit                 )
         , (Char
'w', CharSet -> CharSet
compCS CharSet
charPropNotWord               )
         , (Char
'W',        CharSet
charPropNotWord               )
         ]
    charPropDigit :: CharSet
charPropDigit   = Char -> Char -> CharSet
rangeCS Char
'0' Char
'9'
    charPropNotWord :: CharSet
charPropNotWord = CharSet
charPropUnicodeP
                      CharSet -> CharSet -> CharSet
`unionCS`
                      CharSet
charPropUnicodeZ
                      CharSet -> CharSet -> CharSet
`unionCS`
                      CharSet
charPropUnicodeC

catEsc  :: StringLike s => Parser (GenRegex s)
catEsc :: forall s. StringLike s => Parser (GenRegex s)
catEsc
    = do
      Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'p'
      CharSet
s <- forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{') (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}') Parser CharSet
charProp
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => CharSet -> GenRegex s
mkSym CharSet
s

charProp        :: Parser CharSet
charProp :: Parser CharSet
charProp
    = Parser CharSet
isCategory
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
      Parser CharSet
isBlock

isBlock         :: Parser CharSet
isBlock :: Parser CharSet
isBlock
    = do
      String
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"Is"
      String
name <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
legalChar)
      case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, (Char, Char))]
codeBlocks of
        Just (Char, Char)
b  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Char -> Char -> CharSet
rangeCS (Char, Char)
b
        Maybe (Char, Char)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unknown Unicode code block " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
name
    where
    legalChar :: Char -> Bool
legalChar Char
c  = Char
'A' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'Z' Bool -> Bool -> Bool
||
                   Char
'a' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'z' Bool -> Bool -> Bool
||
                   Char
'0' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9' Bool -> Bool -> Bool
||
                   Char
'-' forall a. Eq a => a -> a -> Bool
== Char
c

isCategory      :: Parser CharSet
isCategory :: Parser CharSet
isCategory
    = do
      String
pr <- Parser String
isCategory'
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
pr [(String, CharSet)]
categories)

categories      :: [(String, CharSet)]
categories :: [(String, CharSet)]
categories
    = [ (String
"C",  CharSet
charPropUnicodeC )
      , (String
"Cc", CharSet
charPropUnicodeCc)
      , (String
"Cf", CharSet
charPropUnicodeCf)
      , (String
"Co", CharSet
charPropUnicodeCo)
      , (String
"Cs", CharSet
charPropUnicodeCs)
      , (String
"L",  CharSet
charPropUnicodeL )
      , (String
"Ll", CharSet
charPropUnicodeLl)
      , (String
"Lm", CharSet
charPropUnicodeLm)
      , (String
"Lo", CharSet
charPropUnicodeLo)
      , (String
"Lt", CharSet
charPropUnicodeLt)
      , (String
"Lu", CharSet
charPropUnicodeLu)
      , (String
"M",  CharSet
charPropUnicodeM )
      , (String
"Mc", CharSet
charPropUnicodeMc)
      , (String
"Me", CharSet
charPropUnicodeMe)
      , (String
"Mn", CharSet
charPropUnicodeMn)
      , (String
"N",  CharSet
charPropUnicodeN )
      , (String
"Nd", CharSet
charPropUnicodeNd)
      , (String
"Nl", CharSet
charPropUnicodeNl)
      , (String
"No", CharSet
charPropUnicodeNo)
      , (String
"P",  CharSet
charPropUnicodeP )
      , (String
"Pc", CharSet
charPropUnicodePc)
      , (String
"Pd", CharSet
charPropUnicodePd)
      , (String
"Pe", CharSet
charPropUnicodePe)
      , (String
"Pf", CharSet
charPropUnicodePf)
      , (String
"Pi", CharSet
charPropUnicodePi)
      , (String
"Po", CharSet
charPropUnicodePo)
      , (String
"Ps", CharSet
charPropUnicodePs)
      , (String
"S",  CharSet
charPropUnicodeS )
      , (String
"Sc", CharSet
charPropUnicodeSc)
      , (String
"Sk", CharSet
charPropUnicodeSk)
      , (String
"Sm", CharSet
charPropUnicodeSm)
      , (String
"So", CharSet
charPropUnicodeSo)
      , (String
"Z",  CharSet
charPropUnicodeZ )
      , (String
"Zl", CharSet
charPropUnicodeZl)
      , (String
"Zp", CharSet
charPropUnicodeZp)
      , (String
"Zs", CharSet
charPropUnicodeZs)
      ]

isCategory'     :: Parser String
isCategory' :: Parser String
isCategory'
    = ( forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
(<|>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {s} {m :: * -> *} {t :: * -> *} {u}.
(Stream s m Char, Foldable t) =>
Char -> t Char -> ParsecT s u m String
prop) forall a b. (a -> b) -> a -> b
$
        [ (Char
'L', String
"ultmo")
        , (Char
'M', String
"nce")
        , (Char
'N', String
"dlo")
        , (Char
'P', String
"cdseifo")
        , (Char
'Z', String
"slp")
        , (Char
'S', String
"mcko")
        , (Char
'C', String
"cfon")
        ]
      ) forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"illegal Unicode character property"
    where
    prop :: Char -> t Char -> ParsecT s u m String
prop Char
c1 t Char
cs2
        = do
          Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
c1
          String
s2 <- forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option String
""
                ( do
                  Char
c2 <- forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Char
cs2)
                  forall (m :: * -> *) a. Monad m => a -> m a
return [Char
c2] )
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Char
c1forall a. a -> [a] -> [a]
:String
s2

complEsc        :: StringLike s => Parser (GenRegex s)
complEsc :: forall s. StringLike s => Parser (GenRegex s)
complEsc
    = do
      Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'P'
      CharSet
s <- forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{') (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}') Parser CharSet
charProp
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => CharSet -> GenRegex s
mkSym forall a b. (a -> b) -> a -> b
$ CharSet -> CharSet
compCS CharSet
s

charClassExpr   :: StringLike s => Parser (GenRegex s) -> Parser (GenRegex s)
charClassExpr :: forall s.
StringLike s =>
Parser (GenRegex s) -> Parser (GenRegex s)
charClassExpr Parser (GenRegex s)
multiCharEsc'
    = forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[') (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']') Parser (GenRegex s)
charGroup
    where

    -- charGroup       :: StringLike s => Parser (GenRegex s)
    charGroup :: Parser (GenRegex s)
charGroup
        = do
          GenRegex s
r <- ( Parser (GenRegex s)
negCharGroup       -- a ^ at beginning denotes negation, not start of posCharGroup
                 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                 Parser (GenRegex s)
posCharGroup
               )
          GenRegex s
s <- forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option (forall s. StringLike s => String -> GenRegex s
mkZero' String
"")   -- charClassSub
               ( do
                 Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-'
                 forall s.
StringLike s =>
Parser (GenRegex s) -> Parser (GenRegex s)
charClassExpr Parser (GenRegex s)
multiCharEsc'
               )
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkDiff GenRegex s
r GenRegex s
s

    -- posCharGroup    :: StringLike s => Parser (GenRegex s)
    posCharGroup :: Parser (GenRegex s)
posCharGroup
        = do
          [GenRegex s]
rs <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s. StringLike s => Parser (GenRegex s)
charRange forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s.
StringLike s =>
Parser (GenRegex s) -> Parser (GenRegex s)
charClassEsc Parser (GenRegex s)
multiCharEsc')
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkAlt [GenRegex s]
rs

    -- negCharGroup    :: StringLike s => Parser (GenRegex s)
    negCharGroup :: Parser (GenRegex s)
negCharGroup
        = do
          Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'^'
          GenRegex s
r <- Parser (GenRegex s)
posCharGroup
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => GenRegex s -> GenRegex s -> GenRegex s
mkDiff forall s. GenRegex s
mkDot GenRegex s
r

charRange       :: StringLike s => Parser (GenRegex s)
charRange :: forall s. StringLike s => Parser (GenRegex s)
charRange
    = forall tok st a. GenParser tok st a -> GenParser tok st a
try forall s. StringLike s => Parser (GenRegex s)
seRange
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
      forall s. StringLike s => Parser (GenRegex s)
xmlCharIncDash

seRange :: StringLike s => Parser (GenRegex s)
seRange :: forall s. StringLike s => Parser (GenRegex s)
seRange
    = do
      Char
c1 <- Parser Char
charOrEsc'
      Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-'
      Char
c2 <- Parser Char
charOrEsc'
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => Char -> Char -> GenRegex s
mkSymRng Char
c1 Char
c2

charOrEsc'      :: Parser Char
charOrEsc' :: Parser Char
charOrEsc'
    = ( do
        Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\'
        Parser Char
singleCharEsc'
      )
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
      forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"\\-[]")

xmlCharIncDash  :: StringLike s => Parser (GenRegex s)
xmlCharIncDash :: forall s. StringLike s => Parser (GenRegex s)
xmlCharIncDash
    = forall tok st a. GenParser tok st a -> GenParser tok st a
try ( do                          -- dash is only allowed if not followed by a [, else charGroup differences do not parse correctly
            Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-'
            forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[')
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => Char -> GenRegex s
mkSym1 Char
'-'
          )
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
      ( do
        Char
c <- forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"-\\[]")
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. StringLike s => Char -> GenRegex s
mkSym1 Char
c
      )

wildCardEsc     :: StringLike s => Parser (GenRegex s)
wildCardEsc :: forall s. StringLike s => Parser (GenRegex s)
wildCardEsc
    = do
      Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. StringLike s => CharSet -> GenRegex s
mkSym forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharSet -> CharSet
compCS forall a b. (a -> b) -> a -> b
$ String -> CharSet
stringCS String
"\n\r"


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