content: {-# LANGUAGE CPP                #-}
  
  -- ------------------------------------------------------------
  
  {- |
     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
  
     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
      , xreadDoc
  
      , parseXmlContent
      , parseXmlDocEncodingSpec
      , parseXmlDocument
      , parseXmlDTDPart
      , parseXmlEncodingSpec
      , parseXmlEntityEncodingSpec
      , parseXmlEntityValueAsAttrValue
      , parseXmlEntityValueAsContent
  
      , parseXmlPart
      , parseXmlText
  
      , parseNMToken
      , parseName
  
      , removeEncodingSpec
      )
  where
  
  #if MIN_VERSION_base(4,8,2)
  #else
  import           Control.Applicative                   ((<$>))
  #endif
  
  import           Text.ParserCombinators.Parsec         (between, char, eof,
                                                          getInput, getPosition,
                                                          many, many1,
                                                          notFollowedBy, option,
                                                          runParser, sourceName,
                                                          string, try, unexpected,
                                                          (<?>), (<|>))
  
  import           Text.XML.HXT.DOM.Interface
  import           Text.XML.HXT.DOM.ShowXml              (xshow)
  import           Text.XML.HXT.DOM.XmlNode              (changeAttrl,
                                                          getAttrName, getAttrl,
                                                          getChildren, getText,
                                                          isRoot, isText,
                                                          mergeAttrl, mkAttr',
                                                          mkCdata', mkCmt',
                                                          mkDTDElem', mkElement',
                                                          mkError', mkPi',
                                                          mkRoot', mkText')
  import           Text.XML.HXT.Parser.XmlCharParser     (SimpleXParser, XPState,
                                                          XParser,
                                                          withNormNewline,
                                                          withoutNormNewline,
                                                          xmlChar)
  import qualified Text.XML.HXT.Parser.XmlDTDTokenParser as XD
  import qualified Text.XML.HXT.Parser.XmlTokenParser    as XT
  
  import           Control.FlatSeq
  
  import           Data.Char                             (toLower)
  import           Data.Maybe
  
  -- import Debug.Trace
  
  -- ------------------------------------------------------------
  --
  -- Character Data (2.4)
  
  charData                :: XParser s XmlTrees
  charData
      = many (charData' <|> XT.referenceT)
  
  charData'               :: XParser s XmlTree
  charData'
      =  do
         t <- XT.allBut1 many1 (\ c -> not (c `elem` "<&")) "]]>"
         return (mkText' t)
  
  -- ------------------------------------------------------------
  --
  -- Comments (2.5)
  
  comment         :: XParser s XmlTree
  comment
      = comment'' $ XT.checkString "<!--"
  
  -- the leading <! is already parsed
  
  comment'        :: XParser s XmlTree
  comment'
      = comment'' (string "--" >> return ())
  
  comment''       :: XParser s () -> XParser s XmlTree
  comment'' op
      = ( do
          c <- between op (string ("-->")) (XT.allBut many "--")
          return (mkCmt' c)
        ) <?> "comment"
  
  -- ------------------------------------------------------------
  --
  -- Processing Instructions
  
  pI             :: XParser s XmlTree
  pI = pI'' $ XT.checkString "<?"
  
  -- the leading < is already parsed
  
  pI'             :: XParser s XmlTree
  pI' = pI'' (char '?' >> return ())
  
  pI''             :: XParser s () -> XParser s XmlTree
  pI'' op
      = between op (string "?>")
        ( do
          n <- pITarget
          p <- option "" (XT.sPace
                          >>
                          XT.allBut many "?>"
                         )
          return (mkPi' (mkName n) [mkAttr' (mkName a_value) [mkText' p]])
        ) <?> "processing instruction"
        where
        pITarget  :: XParser s String
        pITarget = ( do
                     n <- XT.name
                     if map toLower n == t_xml
                        then unexpected n
                        else return n
                   )
  
  -- ------------------------------------------------------------
  --
  -- CDATA Sections (2.7)
  
  cDSect          :: XParser s XmlTree
  cDSect
      = cDSect'' $ XT.checkString "<![CDATA["
  
  -- the leading <! is already parsed, no try neccessary
  
  cDSect'         :: XParser s XmlTree
  cDSect'
      = cDSect'' (string "[CDATA[" >> return ())
  
  cDSect''        :: XParser s () -> XParser s XmlTree
  cDSect'' op
      = do
        t <- between op (string "]]>") (XT.allBut many "]]>")
        return (mkCdata' t)
        <?> "CDATA section"
  
  -- ------------------------------------------------------------
  --
  -- Document (2.1) and Prolog (2.8)
  
  document        :: XParser s 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'       :: XParser s XmlTrees
  document'
      = do
        pl <- prolog
        el <- element
        ml <- many misc
        eof
        return (pl ++ [el] ++ ml)
  
  prolog          :: XParser s XmlTrees
  prolog
      = do
        xml     <- option [] xMLDecl'
        misc1   <- many misc
        dtdPart <- option [] doctypedecl
        misc2   <- many misc
        return (xml ++ misc1 ++ dtdPart ++ misc2)
  
  xMLDecl         :: XParser s 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'        :: XParser s XmlTrees
  xMLDecl'
      = do
        al <- xMLDecl
        return [mkPi' (mkName t_xml) al]
  
  xMLDecl''       :: XParser s XmlTree
  xMLDecl''
      = do
        al     <- option [] (try xMLDecl)
        return (mkRoot' al [])
  
  versionInfo     :: XParser s XmlTrees
  versionInfo
      = ( do
          try ( XT.skipS
                >>
                XT.keyword a_version
                >>
                return ()
              )
          XT.eq
          vi <- XT.quoted XT.versionNum
          return [mkAttr' (mkName a_version) [mkText' vi]]
        )
        <?> "version info (with quoted version number)"
  
  misc            :: XParser s XmlTree
  misc
      = comment
        <|>
        pI
        <|>
        ( ( do
            ws <- XT.sPace
            return (mkText' ws)
          ) <?> ""
        )
  
  -- ------------------------------------------------------------
  --
  -- Document Type definition (2.8)
  
  doctypedecl     :: XParser s 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 :: XParser s XmlTrees
  markupOrDeclSep
      = ( do
          ll <- many ( markupdecl
                       <|>
                       declSep
                       <|>
                       XT.mkList conditionalSect
                     )
          return (concat ll)
        )
  
  declSep         :: XParser s XmlTrees
  declSep
      = XT.mkList XT.peReferenceT
        <|>
        ( do
          XT.skipS
          return []
        )
  
  markupdecl      :: XParser s XmlTrees
  markupdecl
      = XT.mkList
        ( pI
          <|>
          comment
          <|>
          XD.dtdDeclTokenizer
        )
  
  -- ------------------------------------------------------------
  --
  -- Standalone Document Declaration (2.9)
  
  sDDecl          :: XParser s XmlTrees
  sDDecl
      = do
        try ( XT.skipS
              >>
              XT.keyword a_standalone
              >>
              return ()
            )
        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         :: XParser s XmlTree
  element
      = char '<'
        >>
        element'
  
  element'         :: XParser s XmlTree
  element'
      = ( do
          e <- elementStart
          rwnf e `seq` elementRest e              -- evaluate name and attribute list before parsing contents
        ) <?> "element"
  
  
  elementStart            :: XParser s (QName, XmlTrees)
  elementStart
      = do
        n  <- XT.name
        al <- attrList
        XT.skipS0
        return (mkName n, al)
        where
        attrList
            = option [] ( do
                          XT.skipS
                          attrList'
                        )
        attrList'
            = option [] ( do
                          a1 <- attribute
                          al <- attrList
                          let n = fromJust . getAttrName $ a1
                          if n `elem` map (fromJust . getAttrName) al
                            then unexpected
                                 ( "attribute name " ++
                                   show (qualifiedName n) ++
                                   " occurs twice in attribute list"
                                 )
                            else return (a1 : al)
                        )
  
  elementRest     :: (QName, XmlTrees) -> XParser s XmlTree
  elementRest (n, al)
      = ( do
          XT.checkString "/>"
          return $ mkElement' n al []
        )
        <|>
        ( do
          XT.gt
          c <- content
          eTag n
          return $ mkElement' n al c
        )
        <?> "proper attribute list followed by \"/>\" or \">\""
  
  eTag            :: QName -> XParser s ()
  eTag n'
      = do
        XT.checkString "</" <?> ""
        n <- XT.name
        XT.skipS0
        XT.gt
        if n == qualifiedName n'
           then return ()
           else unexpected ("illegal end tag </" ++ n ++ "> found, </" ++ qualifiedName n' ++ "> expected")
  
  attribute       :: XParser s XmlTree
  attribute
      = do
        n <- XT.name
        XT.eq
        v <- XT.attrValueT
        return $ mkAttr' (mkName n) v
  
  {- this parser corresponds to the XML spec but it's inefficent because of more than 1 char lookahead
  
  content         :: XParser s XmlTrees
  content
      = do
        c1 <- charData
        cl <- many
              ( do
                l <- ( element
                       <|>
                       cDSect
                       <|>
                       pI
                       <|>
                       comment
                     )
                c <- charData
                return (l : c)
              )
        return (c1 ++ concat cl)
  -}
  
  -- this simpler content parser does not need more than a single lookahead
  -- so no try parsers (inefficient) are neccessary
  
  content         :: XParser s XmlTrees
  content
      = XT.mergeTextNodes <$>
        many
        ( ( do            -- parse markup but no closing tags
            try ( XT.lt
                  >>
                  notFollowedBy (char '/')
                  >>
                  return ()
                )
            markup
          )
          <|>
          charData'
          <|>
          XT.referenceT
        )
      where
      markup
          = element'
            <|>
            pI'
            <|>
            ( char '!'
              >>
              ( comment'
                <|>
                cDSect'
              )
            )
  
  contentWithTextDecl     :: XParser s XmlTrees
  contentWithTextDecl
      = 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         :: XParser s XmlTree
  conditionalSect
      = do
        XT.checkString "<!["
        cs <- many XD.dtdToken
        _ <- char '['
        sect <- condSectCont
        return (mkDTDElem' CONDSECT [(a_value, sect)] cs)
      where
  
      condSectCont        :: XParser s String
      condSectCont
          = ( XT.checkString "]]>"
              >>
              return ""
            )
            <|>
            ( do
              XT.checkString "<!["
              cs1 <- condSectCont
              cs2 <- condSectCont
              return ("<![" ++ cs1 ++ "]]>" ++ cs2)
            )
            <|>
            ( do
              c  <- xmlChar
              cs <- condSectCont
              return (c : cs)
            )
  
  -- ------------------------------------------------------------
  --
  -- External Entities (4.2.2)
  
  externalID      :: XParser s 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        :: XParser s XmlTrees
  textDecl
      = between (try $ string "<?xml") (string "?>")
        ( do
          vi <- option [] versionInfo
          ed <- encodingDecl
          XT.skipS0
          return (vi ++ ed)
        )
        <?> "text declaration"
  
  
  textDecl''      :: XParser s XmlTree
  textDecl''
      = do
        al    <- option [] (try textDecl)
        return (mkRoot' al [])
  
  -- ------------------------------------------------------------
  --
  -- Encoding Declaration (4.3.3)
  
  encodingDecl    :: XParser s XmlTrees
  encodingDecl
      = do
        try ( XT.skipS
              >>
              XT.keyword a_encoding
              >>
              return ()
            )
        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 here,
  -- but the XML parser can do this for the predefined XML or the char references for performance reasons
  --
  -- see also: 'parseXmlContent'
  
  xread                   :: String -> XmlTrees
  xread                   = xread' content         -- take the content parser for parsing the string
  
  xreadDoc                :: String -> XmlTrees
  xreadDoc                = xread' document'       -- take the document' parser for parsing the string
  
  xread'                   :: XParser () XmlTrees -> String -> XmlTrees
  xread' content' str
      = parseXmlFromString parser (withNormNewline ()) loc str
      where
      loc = "string: " ++ show (if length str > 40 then take 40 str ++ "..." else str)
      parser = do
               res <- content'
               eof                        -- 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            :: SimpleXParser XmlTrees -> XPState () -> String -> XmlTree -> XmlTrees
  parseXmlText p s0 loc   = parseXmlFromString p s0 loc . xshow . (:[])
  
  parseXmlDocument        :: String -> String -> XmlTrees
  parseXmlDocument        = parseXmlFromString document' (withNormNewline ())
  
  parseXmlFromString      :: SimpleXParser XmlTrees -> XPState () -> String -> String -> XmlTrees
  parseXmlFromString parser s0 loc
      = either ((:[]) . mkError' c_err . (++ "\n") . show) id
        . runParser parser s0 loc
  
  -- ------------------------------------------------------------
  --
  
  removeEncodingSpec      :: XmlTree -> XmlTrees
  removeEncodingSpec t
      | isText t
          = ( either ((:[]) . mkError' c_err . (++ "\n") . show) ((:[]) . mkText')
              . runParser parser (withNormNewline ()) "remove encoding spec"
              . fromMaybe ""
              . getText
            ) t
      | otherwise
          = [t]
      where
      parser :: XParser s String
      parser = option [] textDecl
               >>
               getInput
  
  -- ------------------------------------------------------------
  
  -- |
  -- general parser for parsing arbitray parts of a XML document
  
  parseXmlPart    :: SimpleXParser XmlTrees -> String -> String -> XmlTree -> XmlTrees
  parseXmlPart parser expected context t
      = parseXmlText
        ( do
          res <- parser
          eof <?> expected
          return res
        ) (withoutNormNewline ()) context
        $ t
  
  -- ------------------------------------------------------------
  
  -- |
  -- Parser for parts of a DTD
  
  parseXmlDTDPart :: String -> XmlTree -> XmlTrees
  parseXmlDTDPart
      = parseXmlPart markupOrDeclSep "markup declaration"
  
  -- ------------------------------------------------------------
  
  -- |
  -- Parser for general entites
  
  parseXmlEntityValueAsContent      :: String -> XmlTree -> XmlTrees
  parseXmlEntityValueAsContent
      = parseXmlPart content "general entity value"
  
  -- ------------------------------------------------------------
  
  -- |
  -- Parser for entity substitution within attribute values
  
  parseXmlEntityValueAsAttrValue       :: String -> XmlTree -> XmlTrees
  parseXmlEntityValueAsAttrValue
      = 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    :: SimpleXParser XmlTree -> XmlTree -> XmlTrees
  parseXmlEncodingSpec encDecl x
      = (:[]) .
        ( if isRoot x
          then parseEncSpec
          else id
        ) $ x
      where
      parseEncSpec r
          = case ( runParser encDecl (withNormNewline ()) 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''
  
  -- ------------------------------------------------------------
  