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

    {- |
       Module     : Text.XML.HXT.Parser.XmlTokenParser
       Copyright  : Copyright (C) 2005 Uwe Schmidt
       License    : MIT

       Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
       Stability  : experimental
       Portability: portable
       Version    : $Id: XmlTokenParser.hs,v 1.3 2005/09/02 17:09:39 hxml Exp $

       Parsec parser for XML tokens

    -}

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

    module Text.XML.HXT.Parser.XmlTokenParser
        ( allBut
        , allBut1
        , asciiLetter
        , attrValue
        , bar
        , charRef
        , comma
        , dq
        , encName
        , entityRef
        , entityValue
        , eq
        , gt
        , keyword
        , keywords
        , lpar
        , lt
        , name
        , names
        , ncName
        , nmtoken
        , nmtokens
        , peReference
        , pubidLiteral
        , qName
        , quoted
        , reference
        , rpar
        , semi
        , separator
        , singleChar
        , singleChars
        , skipS
        , skipS0
        , sPace
        , sPace0
        , sq
        , systemLiteral
        , versionNum

        , concRes
        , mkList

        , nameT
        , nmtokenT

        , entityValueT
        , entityTokensT
        , entityCharT

        , attrValueT
        , attrValueT'

        , referenceT
        , charRefT
        , entityRefT
        , peReferenceT

        , singleCharsT
        )
    where

    import Text.ParserCombinators.Parsec

    import Text.XML.HXT.DOM.Interface

    import Text.XML.HXT.DOM.XmlNode
        ( mkDTDElem
        , mkText
        , mkCharRef
        , mkEntityRef
        )

    import Text.XML.HXT.DOM.Unicode
        ( isXmlChar
        , intToCharRef
        , intToCharRefHex
        )

    import Text.XML.HXT.Parser.XmlCharParser
        ( xmlNameChar
        , xmlNameStartChar
        , xmlNCNameChar
        , xmlNCNameStartChar
        , xmlSpaceChar
        )

    -- ------------------------------------------------------------
    --
    -- Character (2.2) and White Space (2.3)
    --
    -- Unicode parsers in module XmlCharParser

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

    sPace           :: GenParser Char state String
    sPace
        = many1 xmlSpaceChar

    sPace0          :: GenParser Char state String
    sPace0
        = many xmlSpaceChar

    skipS           :: GenParser Char state ()
    skipS
        = skipMany1 xmlSpaceChar

    skipS0          :: GenParser Char state ()
    skipS0
        = skipMany xmlSpaceChar

    -- ------------------------------------------------------------
    --
    -- Names and Tokens (2.3)

    asciiLetter             :: GenParser Char state Char
    asciiLetter
        = satisfy (\ c -> ( c >= 'A' && c <= 'Z' ||
                            c >= 'a' && c <= 'z' )
                  )
          <?> "ASCII letter"

    name            :: GenParser Char state String
    name
        = try ( do
                s1 <- xmlNameStartChar
                sl <- many xmlNameChar
                return (s1 : sl)
              )
          <?> "Name"

    -- Namespaces in XML: Rules [4-5] NCName:

    ncName          :: GenParser Char state String
    ncName
        = try ( do
                s1 <- xmlNCNameStartChar
                sl <- many xmlNCNameChar
                return (s1 : sl)
              )
          <?> "NCName"

    -- Namespaces in XML: Rules [6-8] QName:

    qName           :: GenParser Char state (String, String)
    qName
        = do
          s1 <- ncName
          s2 <- option "" ( do
                            _ <- char ':'
                            ncName
                          )
          return ( if null s2 then (s2, s1) else (s1, s2) )

    nmtoken         :: GenParser Char state String
    nmtoken
        = try (many1 xmlNameChar)
          <?> "Nmtoken"

    names           :: GenParser Char state [String]
    names
        = sepBy1 name sPace

    nmtokens        :: GenParser Char state [String]
    nmtokens
        = sepBy1 nmtoken sPace

    -- ------------------------------------------------------------
    --
    -- Literals (2.3)

    singleChar              :: String -> GenParser Char state Char
    singleChar notAllowed
        = satisfy (\ c -> isXmlChar c && not (c `elem` notAllowed))

    singleChars             :: String -> GenParser Char state String
    singleChars notAllowed
        = many1 (singleChar notAllowed)

    entityValue     :: GenParser Char state String
    entityValue
        = attrValue

    attrValueDQ     :: GenParser Char state String
    attrValueDQ
        = between dq dq (concRes $ many $ attrChar "<&\"")

    attrValueSQ     :: GenParser Char state String
    attrValueSQ
        = between sq sq (concRes $ many $ attrChar "<&\'")

    attrValue       :: GenParser Char state String
    attrValue
        = ( do
            v <- attrValueDQ
            return ("\"" ++ v ++ "\"")
          )
          <|>
          ( do
            v <- attrValueSQ
            return ("'" ++ v ++ "'")
          )
          <?> "attribute value (in quotes)"

    attrChar        :: String -> GenParser Char state String
    attrChar notAllowed
        = reference
          <|>
          mkList (singleChar notAllowed)
          <?> "legal attribute character or reference"

    systemLiteral           :: GenParser Char state String
    systemLiteral
        = between dq dq (many $ noneOf "\"")
          <|>
          between sq sq (many $ noneOf "\'")
          <?> "system literal (in quotes)"

    pubidLiteral            :: GenParser Char state String
    pubidLiteral
        = between dq dq (many $ pubidChar "\'")
          <|>
          between sq sq (many $ pubidChar "")
          <?> "pubid literal (in quotes)"
          where
          pubidChar         :: String -> GenParser Char state Char
          pubidChar quoteChars
              = asciiLetter
                <|>
                digit
                <|>
                oneOf " \r\n"               -- no "\t" allowed, so xmlSpaceChar parser not used
                <|>
                oneOf "-()+,./:=?;!*#@$_%"
                <|>
                oneOf quoteChars

    -- ------------------------------------------------------------
    --
    -- Character and Entity References (4.1)

    reference       :: GenParser Char state String
    reference
        = ( do
            i <- charRef
            return ("&#" ++ show i ++ ";")
          )
          <|>
          ( do
            n <- entityRef
            return ("&" ++ n ++ ";")
          )

    checkCharRef    :: Int -> GenParser Char state Int
    checkCharRef i
        = if ( i <= fromEnum (maxBound::Char)
               && isXmlChar (toEnum i)
             )
            then return i
            else unexpected ("illegal value in character reference: " ++ intToCharRef i ++ " , in hex: " ++ intToCharRefHex i)

    charRef         :: GenParser Char state Int
    charRef
        = do
          _ <- try (string "&#x")
          d <- many1 hexDigit
          _ <- semi
          checkCharRef (hexStringToInt d)
          <|>
          do
          _ <- try (string "&#")
          d <- many1 digit
          _ <- semi
          checkCharRef (decimalStringToInt d)
          <?> "character reference"

    entityRef       :: GenParser Char state String
    entityRef
        = do
          _ <- char '&'
          n <- name
          _ <- semi
          return n
          <?> "entity reference"

    peReference     :: GenParser Char state String
    peReference
        = try ( do
                _ <- char '%'
                n <- name
                _ <- semi
                return n
              )
          <?> "parameter-entity reference"

    -- ------------------------------------------------------------
    --
    -- 4.3

    encName         :: GenParser Char state String
    encName
        = do
          c <- asciiLetter
          r <- many (asciiLetter <|> digit <|> oneOf "._-")
          return (c:r)

    versionNum      :: GenParser Char state String
    versionNum
        = many1 xmlNameChar

    -- ------------------------------------------------------------
    --
    -- keywords

    keyword         :: String -> GenParser Char state String
    keyword kw
        = try ( do
                n <- name
                if n == kw
                  then return n
                  else unexpected n
              )
          <?> kw

    keywords        :: [String] -> GenParser Char state String
    keywords
        = foldr1 (<|>) . map keyword

    -- ------------------------------------------------------------
    --
    -- parser for quoted attribute values

    quoted          :: GenParser Char state a -> GenParser Char state a
    quoted p
        = between dq dq p
          <|>
          between sq sq p

    -- ------------------------------------------------------------
    --
    -- simple char parsers

    dq, sq, lt, gt, semi    :: GenParser Char state Char

    dq      = char '\"'
    sq      = char '\''
    lt      = char '<'
    gt      = char '>'
    semi    = char ';'

    separator       :: Char -> GenParser Char state ()
    separator c
        = do
          _ <- try ( do
                     skipS0
                     char c
                   )
          skipS0
          <?> [c]

    bar, comma, eq, lpar, rpar      :: GenParser Char state ()

    bar     = separator '|'
    comma   = separator ','
    eq      = separator '='

    lpar
        = do
          _ <- char '('
          skipS0

    rpar
        = do
          skipS0
          _ <- char ')'
          return ()

    -- ------------------------------------------------------------
    --
    -- all chars but not a special substring

    allBut          :: (GenParser Char state Char -> GenParser Char state String) -> String -> GenParser Char state String
    allBut p str
        = allBut1 p (const True) str

    allBut1         :: (GenParser Char state Char -> GenParser Char state String) -> (Char -> Bool) -> String -> GenParser Char state String
    allBut1 p prd (c:rest)
        = p ( satisfy (\ x -> isXmlChar x && prd x && not (x == c) )
              <|>
              try ( do
                    _ <- char c
                    notFollowedBy ( do
                                    _ <- try (string rest)
                                    return c
                                  )
                    return c
                  )
            )

    allBut1 _p _prd str
        = error ("allBut1 _ _ " ++ show str ++ " is undefined")

    -- ------------------------------------------------------------
    --
    -- concatenate parse results

    concRes         :: GenParser Char state [[a]] -> GenParser Char state [a]
    concRes p
        = do
          sl <- p
          return (concat sl)

    mkList          :: GenParser Char state a -> GenParser Char state [a]
    mkList p
        = do
          r <- p
          return [r]

    -- ------------------------------------------------------------
    --
    -- token parsers returning XmlTrees
    --
    -- ------------------------------------------------------------
    --
    -- Literals (2.3)

    nameT           :: GenParser Char state XmlTree
    nameT
        = do
          n <- name
          return (mkDTDElem NAME [(a_name, n)] [])

    nmtokenT        :: GenParser Char state XmlTree
    nmtokenT
        = do
          n <- nmtoken
          return (mkDTDElem NAME [(a_name, n)] [])

    entityValueT    :: GenParser Char state XmlTrees
    entityValueT
        =  do
           sl <- between dq dq (entityTokensT "%&\"")
           return sl
           <|>
           do
           sl <- between sq sq (entityTokensT "%&\'")
           return sl
           <?> "entity value (in quotes)"

    entityTokensT   :: String -> GenParser Char state XmlTrees
    entityTokensT notAllowed
        = many (entityCharT notAllowed)

    entityCharT     :: String -> GenParser Char state XmlTree
    entityCharT notAllowed
        = peReferenceT
          <|>
          charRefT
          <|>
          bypassedEntityRefT
          <|>
          ( do
            cs <- many1 (singleChar notAllowed)
            return (mkText cs)
          )

    attrValueT      :: GenParser Char state XmlTrees
    attrValueT
        = between dq dq (attrValueT' "<&\"")
          <|>
          between sq sq (attrValueT' "<&\'")
          <?> "attribute value (in quotes)"

    attrValueT'     :: String -> GenParser Char state XmlTrees
    attrValueT' notAllowed
        = many ( referenceT <|> singleCharsT notAllowed)

    singleCharsT    :: String -> GenParser Char state XmlTree
    singleCharsT notAllowed
        = do
          cs <- singleChars notAllowed
          return (mkText cs)

    -- ------------------------------------------------------------
    --
    -- Character and Entity References (4.1)

    referenceT      :: GenParser Char state XmlTree
    referenceT
        = charRefT
          <|>
          entityRefT

    charRefT        :: GenParser Char state XmlTree
    charRefT
        = do
          i <- charRef
          return $! (mkCharRef $! i)

    entityRefT      :: GenParser Char state XmlTree
    entityRefT
        = do
          n <- entityRef
          return $! (mkEntityRef $! n)

    bypassedEntityRefT      :: GenParser Char state XmlTree
    bypassedEntityRefT
        = do
          n <- entityRef
          return $! (mkText ("&" ++ n ++ ";"))

    peReferenceT    :: GenParser Char state XmlTree
    peReferenceT
        = do
          r <- peReference
          return $! (mkDTDElem PEREF [(a_peref, r)] [])

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