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

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

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

       Xml Parsec parser with pure filter interface

    -}

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

    module Text.XML.HXT.Parser.XmlParsec
        ( charData
        , charData'
        , comment
        , pI
        , cDSect
        , document
        , document'
        , prolog
        , xMLDecl
        , xMLDecl'
        , versionInfo
        , misc
        , doctypedecl
        , markupdecl
        , sDDecl
        , element
        , content
        , contentWithTextDecl
        , textDecl
        , encodingDecl
        , xread

        , parseXmlAttrValue
        , parseXmlContent
        , parseXmlDocEncodingSpec
        , parseXmlDocument
        , parseXmlDTDPart
        , parseXmlEncodingSpec
        , parseXmlEntityEncodingSpec
        , parseXmlGeneralEntityValue
        , parseXmlPart
        , parseXmlText

        , parseNMToken
        , parseName

        , removeEncodingSpec
        )
    where

    import Text.ParserCombinators.Parsec
        ( GenParser
        , Parser
        , parse
        , (<?>), (<|>)
        , char
        , string
        , eof
        , between
        , many, many1
        , option
        , try
        , unexpected
        , getPosition
        , getInput
        , sourceName
        )

    import Text.XML.HXT.DOM.ShowXml
        ( xshow
        )

    import Text.XML.HXT.DOM.Interface

    import Text.XML.HXT.DOM.XmlNode
        ( mkElement
        , mkAttr
        , mkRoot
        , mkDTDElem
        , mkText
        , mkCmt
        , mkCdata
        , mkError
        , mkPi
        , isText
        , isRoot
        , getText
        , getChildren
        , getAttrl
        , getAttrName
        , changeAttrl
        , mergeAttrl
        )

    import Text.XML.HXT.Parser.XmlCharParser
        ( xmlChar
        )
    import qualified Text.XML.HXT.Parser.XmlTokenParser	as XT
    import qualified Text.XML.HXT.Parser.XmlDTDTokenParser	as XD

    import Data.Char	(toLower)
    import Data.Maybe

    -- ------------------------------------------------------------
    --
    -- Character Data (2.4)

    charData		:: GenParser Char state XmlTrees
    charData
        = many (charData' <|> XT.referenceT)

    charData'		:: GenParser Char state XmlTree
    charData'
        = try ( do
    	    t <- XT.allBut1 many1 (\ c -> not (c `elem` "<&")) "]]>"
    	    return (mkText $! t)
    	  )

    -- ------------------------------------------------------------
    --
    -- Comments (2.5)

    comment		:: GenParser Char state XmlTree

    comment
        = ( do
    	c <- between (try $ string "<!--") (string "-->") (XT.allBut many "--")
    	return (mkCmt $! c)
          ) <?> "comment"

    -- ------------------------------------------------------------
    --
    -- Processing Instructions

    pI		:: GenParser Char state XmlTree
    pI
        = between (try $ string "<?") (string "?>")
          ( do
    	n <- pITarget
    	p <- option "" (do
    			_ <- XT.sPace
    			XT.allBut many "?>"
    		       )
    	return $ mkPi (mkName n) [mkAttr (mkName a_value) [mkText p]]
          ) <?> "processing instruction"
          where
          pITarget	:: GenParser Char state String
          pITarget = ( do
    		   n <- XT.name
    		   if map toLower n == t_xml
    		      then unexpected n
    		      else return n
    		 )

    -- ------------------------------------------------------------
    --
    -- CDATA Sections (2.7)

    cDSect		:: GenParser Char state XmlTree

    cDSect
        = do
          t <- between ( try $ string "<![CDATA[") (string "]]>") (XT.allBut many "]]>")
          return (mkCdata $! t)
          <?> "CDATA section"

    -- ------------------------------------------------------------
    --
    -- Document (2.1) and Prolog (2.8)

    document	:: GenParser Char state XmlTree
    document
        = do
          pos <- getPosition
          dl <- document'
          return $ mkRoot [ mkAttr (mkName a_source) [mkText (sourceName pos)]
    		      , mkAttr (mkName a_status) [mkText (show c_ok)]
    		      ] dl

    document'	:: GenParser Char state XmlTrees
    document'
        = do
          pl <- prolog
          el <- element
          ml <- many misc
          eof
          return (pl ++ [el] ++ ml)

    prolog		:: GenParser Char state XmlTrees
    prolog
        = do
          xml     <- option [] xMLDecl'
          misc1   <- many misc
          dtdPart <- option [] doctypedecl
          misc2   <- many misc
          return (xml ++ misc1 ++ dtdPart ++ misc2)

    xMLDecl		:: GenParser Char state XmlTrees
    xMLDecl
        = between (try $ string "<?xml") (string "?>")
          ( do
    	vi <- versionInfo
    	ed <- option [] encodingDecl
    	sd <- option [] sDDecl
    	XT.skipS0
    	return (vi ++ ed ++ sd)
          )
          <?> "xml declaration"

    xMLDecl'	:: GenParser Char state XmlTrees
    xMLDecl'
        = do
          al <- xMLDecl
          return [mkPi (mkName t_xml) al]

    xMLDecl''	:: GenParser Char state XmlTree
    xMLDecl''
        = do
          al     <- option [] (try xMLDecl)
          return (mkRoot al [])

    versionInfo	:: GenParser Char state XmlTrees
    versionInfo
        = ( do
    	_ <- try ( do
    		   XT.skipS
    		   XT.keyword a_version
    		 )
    	XT.eq
    	vi <- XT.quoted XT.versionNum
    	return [mkAttr (mkName a_version) [mkText vi]]
          )
          <?> "version info (with quoted version number)"

    misc		:: GenParser Char state XmlTree
    misc
        = comment
          <|>
          pI
          <|>
          ( ( do
    	  ws <- XT.sPace
    	  return (mkText ws)
    	) <?> ""
          )

    -- ------------------------------------------------------------
    --
    -- Document Type definition (2.8)

    doctypedecl	:: GenParser Char state XmlTrees
    doctypedecl
        = between (try $ string "<!DOCTYPE") (char '>')
          ( do
    	XT.skipS
    	n <- XT.name
    	exId <- option [] ( try ( do
    				  XT.skipS
    				  externalID
    				)
    			  )
    	XT.skipS0
    	markup <- option []
    	          ( do
    		    m <- between (char '[' ) (char ']') markupOrDeclSep
    		    XT.skipS0
    		    return m
    		  )
    	return [mkDTDElem DOCTYPE ((a_name, n) : exId) markup]
          )

    markupOrDeclSep	:: GenParser Char state XmlTrees
    markupOrDeclSep
        = ( do
    	ll <- many ( markupdecl
    		     <|>
    		     declSep
    		     <|>
    		     XT.mkList conditionalSect
    		   )
    	return (concat ll)
          )

    declSep		:: GenParser Char state XmlTrees
    declSep
        = XT.mkList XT.peReferenceT
          <|>
          ( do
    	XT.skipS
    	return []
          )

    markupdecl	:: GenParser Char state XmlTrees
    markupdecl
        = XT.mkList
          ( pI
    	<|>
    	comment
    	<|>
    	XD.dtdDeclTokenizer
          )

    -- ------------------------------------------------------------
    --
    -- Standalone Document Declaration (2.9)

    sDDecl		:: GenParser Char state XmlTrees
    sDDecl
        = do
          _ <- try (do
    		XT.skipS
    		XT.keyword a_standalone
    	       )
          XT.eq
          sd <- XT.quoted (XT.keywords [v_yes, v_no])
          return [mkAttr (mkName a_standalone) [mkText sd]]

    -- ------------------------------------------------------------
    --
    -- element, tags and content (3, 3.1)

    element		:: GenParser Char state XmlTree
    element
        = ( do
    	e <- elementStart
    	elementRest e
          ) <?> "element"

    elementStart		:: GenParser Char state (String, [(String, XmlTrees)])
    elementStart
        = do
          n <- ( try ( do
    		   _ <- char '<'
    		   n <- XT.name
    		   return n
    		 )
    	     <?> "start tag"
    	   )
          ass <- attrList
          XT.skipS0
          return (n, ass)
          where
          attrList
    	  = option [] ( do
    			XT.skipS
    			attrList'
    		      )
          attrList'
    	  = option [] ( do
    			a1 <- attribute
    			al <- attrList
    			let (n, _v) = a1
    			if isJust . lookup n $ al
    			  then unexpected ("attribute name " ++ show n ++ " occurs twice in attribute list")
    			  else return (a1 : al)
    		      )

    elementRest	:: (String, [(String, XmlTrees)]) -> GenParser Char state XmlTree
    elementRest (n, al)
        = ( do
    	_ <- try $ string "/>"
    	return $! (mkElement (mkName n) (map (mkA $!) al) [])
          )
          <|>
          ( do
    	_ <- XT.gt
    	c <- content
    	eTag n
    	return $! (mkElement (mkName n) (map (mkA $!) al) $! c)
          )
          <?> "proper attribute list followed by \"/>\" or \">\""
        where
        mkA (n', ts') = mkAttr (mkName n') ts'

    eTag		:: String -> GenParser Char state ()
    eTag n'
        = do
          _ <- try ( string "</" ) <?> ""
          n <- XT.name
          XT.skipS0
          _ <- XT.gt
          if n == n'
    	 then return ()
    	 else unexpected ("illegal end tag </" ++ n ++ "> found, </" ++ n' ++ "> expected")

    attribute	:: GenParser Char state (String, XmlTrees)
    attribute
        = do
          n <- XT.name
          XT.eq
          v <- XT.attrValueT
          return (n, v)

    content		:: GenParser Char state XmlTrees
    content
        = do
          c1 <- charData
          cl <- many
    	    ( do
    	      l <- ( element
    		     <|>
    		     cDSect
    		     <|>
    		     pI
    		     <|>
    		     comment
    		   )
    	      c <- charData
    	      return (l : c)
    	    )
          return (c1 ++ concat cl)

    contentWithTextDecl	:: GenParser Char state XmlTrees
    contentWithTextDecl
        = do
          _ <- option [] textDecl
          content

    -- ------------------------------------------------------------
    --
    -- Conditional Sections (3.4)
    --
    -- conditional sections are parsed in two steps,
    -- first the whole content is detected,
    -- and then, after PE substitution include sections are parsed again

    conditionalSect		:: GenParser Char state XmlTree
    conditionalSect
        = do
          _ <- try $ string "<!["
          cs <- many XD.dtdToken
          _ <- char '['
          sect <- condSectCont
          return (mkDTDElem CONDSECT [(a_value, sect)] cs)
        where

        condSectCont	:: GenParser Char state String
        condSectCont
    	= ( do
    	    _ <- try $ string "]]>"
    	    return ""
    	  )
              <|>
    	  ( do
    	    _ <- try $ string "<!["
    	    cs1 <- condSectCont
    	    cs2 <- condSectCont
    	    return ("<![" ++ cs1 ++ "]]>" ++ cs2)
    	  )
    	  <|>
    	  ( do
    	    c  <- xmlChar
    	    cs <- condSectCont
    	    return (c : cs)
    	  )

    -- ------------------------------------------------------------
    --
    -- External Entities (4.2.2)

    externalID	:: GenParser Char state Attributes
    externalID
        = ( do
    	_ <- XT.keyword k_system
    	XT.skipS
    	lit <- XT.systemLiteral
    	return [(k_system, lit)]
          )
          <|>
          ( do
    	_ <- XT.keyword k_public
    	XT.skipS
    	pl <- XT.pubidLiteral
    	XT.skipS
    	sl <- XT.systemLiteral
    	return [ (k_system, sl)
    	       , (k_public, pl) ]
          )
          <?> "SYSTEM or PUBLIC declaration"

    -- ------------------------------------------------------------
    --
    -- Text Declaration (4.3.1)

    textDecl	:: GenParser Char state XmlTrees
    textDecl
        = between (try $ string "<?xml") (string "?>")
          ( do
    	vi <- option [] versionInfo
    	ed <- encodingDecl
    	XT.skipS0
    	return (vi ++ ed)
          )
          <?> "text declaration"

    textDecl''	:: GenParser Char state XmlTree
    textDecl''
        = do
          al    <- option [] (try textDecl)
          return (mkRoot al [])

    -- ------------------------------------------------------------
    --
    -- Encoding Declaration (4.3.3)

    encodingDecl	:: GenParser Char state XmlTrees
    encodingDecl
        = do
          _ <- try ( do
    		 XT.skipS
    		 XT.keyword a_encoding
    	       )
          XT.eq
          ed <- XT.quoted XT.encName
          return [mkAttr (mkName a_encoding) [mkText ed]]

    -- ------------------------------------------------------------
    --
    -- the main entry points:
    --	parsing the content of a text node
    --	or parsing the text children from a tag node

    -- |
    -- the inverse function to 'xshow', (for XML content).
    --
    -- the string parameter is parsed with the XML content parser.
    -- result is the list of trees or in case of an error a single element list with the
    -- error message as node. No entity or character subtitution is done.
    --
    -- see also: 'parseXmlContent'

    xread			:: String -> XmlTrees
    xread str
        = parseXmlFromString parser loc str
        where
        loc = "string: " ++ show (if length str > 40 then take 40 str ++ "..." else str)
        parser = do
    	     res <- content		-- take the content parser for parsing the string
    	     eof			-- and test on everything consumed
    	     return res

    -- |
    -- the filter version of 'xread'

    parseXmlContent		:: XmlTree -> XmlTrees
    parseXmlContent
        = xread . xshow . (:[])

    -- |
    -- a more general version of 'parseXmlContent'.
    -- The parser to be used and the context are extra parameter

    parseXmlText		:: Parser XmlTrees -> String -> XmlTree -> XmlTrees
    parseXmlText p loc	= parseXmlFromString p loc . xshow . (:[])

    parseXmlDocument	:: String -> String -> XmlTrees
    parseXmlDocument	= parseXmlFromString document'

    parseXmlFromString	:: Parser XmlTrees -> String -> String -> XmlTrees
    parseXmlFromString parser loc
        = either ((:[]) . mkError c_err . (++ "\n") . show) id . parse parser loc

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

    removeEncodingSpec	:: XmlTree -> XmlTrees
    removeEncodingSpec t
        | isText t
    	= ( either ((:[]) . mkError c_err . (++ "\n") . show) ((:[]) . mkText)
    	    . parse parser "remove encoding spec"
    	    . fromMaybe ""
    	    . getText
    	  ) t
        | otherwise
    	= [t]
        where
        parser :: Parser String
        parser = do
    	     _ <- option [] textDecl
    	     getInput

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

    -- |
    -- general parser for parsing arbitray parts of a XML document

    parseXmlPart	:: Parser XmlTrees -> String -> String -> XmlTree -> XmlTrees
    parseXmlPart parser expected context t
        = parseXmlText ( do
    		     res <- parser
    		     eof <?> expected
    		     return res
    		   ) context
          $ t

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

    -- |
    -- Parser for parts of a DTD

    parseXmlDTDPart	:: String -> XmlTree -> XmlTrees
    parseXmlDTDPart
        = parseXmlPart markupOrDeclSep "markup declaration"

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

    -- |
    -- Parser for general entites

    parseXmlGeneralEntityValue	:: String -> XmlTree -> XmlTrees
    parseXmlGeneralEntityValue
        = parseXmlPart content "general entity value"

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

    -- |
    -- Parser for attribute values

    parseXmlAttrValue	:: String -> XmlTree -> XmlTrees
    parseXmlAttrValue
        = parseXmlPart (XT.attrValueT' "<&") "attribute value"

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

    -- |
    -- Parser for NMTOKENs

    parseNMToken		:: String -> XmlTree -> XmlTrees
    parseNMToken
        = parseXmlPart (many1 XT.nmtokenT) "nmtoken"

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

    -- |
    -- Parser for XML names

    parseName		:: String -> XmlTree -> XmlTrees
    parseName
        = parseXmlPart (many1 XT.nameT) "name"

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

    -- |
    -- try to parse a xml encoding spec.
    --
    --
    --    * 1.parameter encParse :  the parser for the encoding decl
    --
    --    - 2.parameter root :  a document root
    --
    --    - returns : the same tree, but with an additional
    --			  attribute \"encoding\" in the root node
    --			  in case of a valid encoding spec
    --			  else the unchanged tree

    parseXmlEncodingSpec	:: Parser XmlTree -> XmlTree -> XmlTrees
    parseXmlEncodingSpec encDecl x
        = (:[]) .
          ( if isRoot x
    	then parseEncSpec
    	else id
          ) $ x
        where
        parseEncSpec r
    	= case ( parse encDecl source . xshow . getChildren $ r ) of
    	  Right t
    	      -> changeAttrl (mergeAttrl . fromMaybe [] . getAttrl $ t) r
    	  Left _
    	      -> r
    	where
    	-- arrow \"getAttrValue a_source\" programmed on the tree level (oops!)
    	source = xshow . concat . map getChildren . filter ((== a_source) . maybe "" qualifiedName . getAttrName) . fromMaybe [] . getAttrl $ r

    parseXmlEntityEncodingSpec	:: XmlTree -> XmlTrees
    parseXmlEntityEncodingSpec	= parseXmlEncodingSpec textDecl''

    parseXmlDocEncodingSpec		:: XmlTree -> XmlTrees
    parseXmlDocEncodingSpec		= parseXmlEncodingSpec xMLDecl''

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