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

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

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   UTF-8 character parser and simple XML token parsers
-}

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

module Text.XML.HXT.Parser.XmlCharParser
    ( XParser
    , SimpleXParser
    , XPState(..)
    , withNormNewline
    , withoutNormNewline

    , xmlChar                   -- xml char parsers
    , xmlNameChar
    , xmlNameStartChar
    , xmlNCNameChar
    , xmlNCNameStartChar
    , xmlLetter
    , xmlSpaceChar
    , xmlCRLFChar
    )
where

import           Data.Char.Properties.XMLCharProps (isXmlCharCR, isXmlLetter,
                                                    isXmlNCNameChar,
                                                    isXmlNCNameStartChar,
                                                    isXmlNameChar,
                                                    isXmlNameStartChar,
                                                    isXmlSpaceCharCR)

import           Data.String.Unicode

import           Text.ParserCombinators.Parsec

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

type XParser s a        = GenParser Char (XPState s) a
type SimpleXParser a    = XParser () a

data XPState s          = XPState
    { XPState s -> Bool
xps_normalizeNewline :: ! Bool
    , XPState s -> s
xps_userState        :: s
    }

withNormNewline         :: a -> XPState a
withNormNewline :: a -> XPState a
withNormNewline a
x       = Bool -> a -> XPState a
forall s. Bool -> s -> XPState s
XPState Bool
True a
x

withoutNormNewline      :: a -> XPState a
withoutNormNewline :: a -> XPState a
withoutNormNewline a
x    = Bool -> a -> XPState a
forall s. Bool -> s -> XPState s
XPState Bool
False a
x

-- ------------------------------------------------------------
--
-- Char (2.2)
--

-- |
-- parse a single Unicode character

xmlChar                 :: XParser s Unicode
xmlChar :: XParser s Unicode
xmlChar                 = ( (Unicode -> Bool) -> XParser s Unicode
forall s (m :: * -> *) u.
Stream s m Unicode =>
(Unicode -> Bool) -> ParsecT s u m Unicode
satisfy Unicode -> Bool
isXmlCharCR
                            XParser s Unicode -> XParser s Unicode -> XParser s Unicode
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                            XParser s Unicode
forall s. XParser s Unicode
xmlCRLFChar
                          )
                          XParser s Unicode -> String -> XParser s Unicode
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"legal XML character"
{-# INLINE xmlChar #-}

-- |
-- parse a XML name character

xmlNameChar             :: XParser s Unicode
xmlNameChar :: XParser s Unicode
xmlNameChar             = (Unicode -> Bool) -> XParser s Unicode
forall s (m :: * -> *) u.
Stream s m Unicode =>
(Unicode -> Bool) -> ParsecT s u m Unicode
satisfy Unicode -> Bool
isXmlNameChar XParser s Unicode -> String -> XParser s Unicode
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"legal XML name character"
{-# INLINE xmlNameChar #-}

-- |
-- parse a XML name start character

xmlNameStartChar        :: XParser s Unicode
xmlNameStartChar :: XParser s Unicode
xmlNameStartChar        = (Unicode -> Bool) -> XParser s Unicode
forall s (m :: * -> *) u.
Stream s m Unicode =>
(Unicode -> Bool) -> ParsecT s u m Unicode
satisfy Unicode -> Bool
isXmlNameStartChar XParser s Unicode -> String -> XParser s Unicode
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"legal XML name start character"
{-# INLINE xmlNameStartChar #-}

-- |
-- parse a XML NCName character

xmlNCNameChar           :: XParser s Unicode
xmlNCNameChar :: XParser s Unicode
xmlNCNameChar           = (Unicode -> Bool) -> XParser s Unicode
forall s (m :: * -> *) u.
Stream s m Unicode =>
(Unicode -> Bool) -> ParsecT s u m Unicode
satisfy Unicode -> Bool
isXmlNCNameChar XParser s Unicode -> String -> XParser s Unicode
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"legal XML NCName character"
{-# INLINE xmlNCNameChar #-}

-- |
-- parse a XML NCName start character

xmlNCNameStartChar      :: XParser s Unicode
xmlNCNameStartChar :: XParser s Unicode
xmlNCNameStartChar      = (Unicode -> Bool) -> XParser s Unicode
forall s (m :: * -> *) u.
Stream s m Unicode =>
(Unicode -> Bool) -> ParsecT s u m Unicode
satisfy Unicode -> Bool
isXmlNCNameStartChar XParser s Unicode -> String -> XParser s Unicode
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"legal XML NCName start character"
{-# INLINE xmlNCNameStartChar #-}

-- |
-- parse a XML letter character

xmlLetter               :: XParser s Unicode
xmlLetter :: XParser s Unicode
xmlLetter               = (Unicode -> Bool) -> XParser s Unicode
forall s (m :: * -> *) u.
Stream s m Unicode =>
(Unicode -> Bool) -> ParsecT s u m Unicode
satisfy Unicode -> Bool
isXmlLetter XParser s Unicode -> String -> XParser s Unicode
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"legal XML letter"
{-# INLINE xmlLetter #-}

-- |
-- White Space (2.3)
--
-- end of line handling (2.11) will be done before or with 'xmlCRLFChar' parser

xmlSpaceChar            :: XParser s Char
xmlSpaceChar :: XParser s Unicode
xmlSpaceChar            = ( (Unicode -> Bool) -> XParser s Unicode
forall s (m :: * -> *) u.
Stream s m Unicode =>
(Unicode -> Bool) -> ParsecT s u m Unicode
satisfy Unicode -> Bool
isXmlSpaceCharCR
                            XParser s Unicode -> XParser s Unicode -> XParser s Unicode
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                            XParser s Unicode
forall s. XParser s Unicode
xmlCRLFChar
                          )
                          XParser s Unicode -> String -> XParser s Unicode
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"white space"
{-# INLINE xmlSpaceChar #-}

-- |
-- White Space Normalization
--
-- end of line handling (2.11)
-- \#x0D and \#x0D\#x0A are mapped to \#x0A

xmlCRLFChar            :: XParser s Char
xmlCRLFChar :: XParser s Unicode
xmlCRLFChar            = ( do
                           Unicode
_ <- Unicode -> XParser s Unicode
forall s (m :: * -> *) u.
Stream s m Unicode =>
Unicode -> ParsecT s u m Unicode
char Unicode
'\r'
                           XPState s
s <- ParsecT String (XPState s) Identity (XPState s)
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
                           if XPState s -> Bool
forall s. XPState s -> Bool
xps_normalizeNewline XPState s
s
                              then Unicode -> XParser s Unicode -> XParser s Unicode
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Unicode
'\n' (Unicode -> XParser s Unicode
forall s (m :: * -> *) u.
Stream s m Unicode =>
Unicode -> ParsecT s u m Unicode
char Unicode
'\n')
                              else Unicode -> XParser s Unicode
forall (m :: * -> *) a. Monad m => a -> m a
return Unicode
'\r'
                         )
                         XParser s Unicode -> String -> XParser s Unicode
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"newline"

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