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

{- |
   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)] [])

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