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

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

       Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
       Stability  : experimental
       Portability: portable
       Version    : $Id: ProcessDocument.hs,v 1.3 2006/08/30 16:20:52 hxml Exp $

       Compound arrows for reading, parsing, validating and writing XML documents

       All arrows use IO and a global state for options, errorhandling, ...
    -}

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

    module Text.XML.HXT.Arrow.ProcessDocument
        ( parseXmlDocument
        , parseHtmlDocument
        , validateDocument
        , propagateAndValidateNamespaces
        , getDocumentContents
        )
    where

    import Control.Arrow                            -- arrow classes
    import Control.Arrow.ArrowList
    import Control.Arrow.ArrowIf
    import Control.Arrow.ArrowTree

    import Text.XML.HXT.DOM.Interface
    import Text.XML.HXT.Arrow.XmlArrow
    import Text.XML.HXT.Arrow.XmlIOStateArrow

    import Text.XML.HXT.Arrow.ParserInterface
        ( parseXmlDoc
        , parseHtmlDoc
        , parseHtmlTagSoup
        , substHtmlEntityRefs
        , validateDoc
        , transformDoc
        )

    import Text.XML.HXT.Arrow.Edit
        ( transfAllCharRef
        )

    import Text.XML.HXT.Arrow.GeneralEntitySubstitution
        ( processGeneralEntities
        )

    import Text.XML.HXT.Arrow.DTDProcessing
        ( processDTD
        )

    import Text.XML.HXT.Arrow.DocumentInput
        ( getXmlContents
        )

    import Text.XML.HXT.Arrow.Namespace
        ( propagateNamespaces
        , validateNamespaces
        )

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

    {- |
    XML parser

    Input tree must be a root tree with a text tree as child containing the document to be parsed.
    The parser generates from the input string a tree of a wellformed XML document,
    processes the DTD (parameter substitution, conditional DTD parts, ...) and
    substitutes all general entity references. Next step is character reference substitution.
    Last step is the document validation.
    Validation can be controlled by an extra parameter.

    Example:

    > parseXmlDocument True    -- parse and validate document
    >
    > parseXmlDocument False   -- only parse document, don't validate

    This parser is useful for applications processing correct XML documents.
    -}

    parseXmlDocument        :: Bool -> IOStateArrow s XmlTree XmlTree
    parseXmlDocument validate
        = ( replaceChildren ( ( getAttrValue a_source
                                &&&
                                xshow getChildren
                              )
                              >>>
                              parseXmlDoc
                              >>>
                              filterErrorMsg
                            )
            >>>
            setDocumentStatusFromSystemState "parse XML document"
            >>>
            processDTD
            >>>
            processGeneralEntities
            >>>
            transfAllCharRef
            >>>
            ( if validate
              then validateDocument
              else this
            )
          )
          `when` documentStatusOk

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

    {- |
    HTML parser

    Input tree must be a root tree with a text tree as child containing the document to be parsed.
    The parser tries to parse everything as HTML, if the HTML document is not wellformed XML or if
    errors occur, warnings are generated. The warnings can be issued, or suppressed.

    Example: @ parseHtmlDocument True @ : parse document and issue warnings

    This parser is useful for applications like web crawlers, where the pages may contain
    arbitray errors, but the application is only interested in parts of the document, e.g. the plain text.

    -}

    parseHtmlDocument       :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IOStateArrow s XmlTree XmlTree
    parseHtmlDocument withTagSoup withNamespaces warnings preserveCmt removeWhitespace asHtml
        = ( perform ( getAttrValue a_source >>> traceValue 1 (("parseHtmlDoc: parse HTML document " ++) . show) )
            >>>
            replaceChildren ( ( getAttrValue a_source               -- get source name
                                &&&
                                xshow getChildren
                              )                                     -- get string to be parsed
                              >>>
                              parseHtml
                            )
            >>>
            removeWarnings
            >>>
            setDocumentStatusFromSystemState "parse HTML document"
            >>>
            traceTree
            >>>
            traceSource
            >>>
            perform ( getAttrValue a_source
                      >>>
                      traceValue 1 (\ src -> "parse HTML document " ++ show src ++ " finished")
                    )
          )
          `when` documentStatusOk
        where
        parseHtml
            | withTagSoup   = traceMsg 1 ("parse document with tagsoup " ++
                                          ( if asHtml then "HT" else "X" ) ++ "ML parser"
                                         )
                              >>>
                              parseHtmlTagSoup withNamespaces warnings preserveCmt removeWhitespace asHtml

            | otherwise     = traceMsg 1 ("parse document with parsec HTML parser")
                              >>>
                              parseHtmlDoc                          -- run parser
                              >>>
                              substHtmlEntityRefs                   -- substitute entity refs
        removeWarnings
            | withTagSoup
              &&
              not warnings  = this
            | otherwise     = processTopDownWithAttrl
                              ( if warnings                         -- remove warnings inserted by parser and entity subst
                                then filterErrorMsg
                                else ( none
                                       `when`
                                       isError
                                     )
                              )

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

    {- | Document validation

    Input must be a complete document tree. The document
    is validated with respect to the DTD spec.
    Only useful for XML documents containing a DTD.

    If the document is valid, it is transformed with respect to the DTD,
    normalization of attribute values, adding default values, sorting attributes by name,...

    If no error was found, result is the normalized tree,
    else the error status is set in the list of attributes
    of the root node \"\/\" and the document content is removed from the tree.

    -}

    validateDocument        :: IOStateArrow s XmlTree XmlTree
    validateDocument
        = ( traceMsg 1 "validating document"
            >>>
            perform ( validateDoc
                      >>>
                      filterErrorMsg
                    )
            >>>
            setDocumentStatusFromSystemState "document validation"
            >>>
            transformDoc
            >>>
            traceMsg 1 "document validated"
            >>>
            traceSource
            >>>
            traceTree
          )
          `when`
          documentStatusOk

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

    {- | Namespace propagation

    Input must be a complete document tree. The namespace declarations
    are evaluated and all element and attribute names are processed by
    splitting the name into prefix, local part and namespace URI.

    Naames are checked with respect to the XML namespace definition

    If no error was found, result is the unchanged input tree,
    else the error status is set in the list of attributes
    of the root node \"\/\" and the document content is removed from the tree.

    -}

    propagateAndValidateNamespaces  :: IOStateArrow s XmlTree XmlTree
    propagateAndValidateNamespaces
        = ( traceMsg 1 "propagating namespaces"
            >>>
            propagateNamespaces
            >>>
            traceDoc "propagating namespaces done"
            >>>
            traceMsg 1 "validating namespaces"
            >>>
            ( setDocumentStatusFromSystemState "namespace propagation"
              `when`
              ( validateNamespaces >>> perform filterErrorMsg )
            )
            >>>
            traceMsg 1 "namespace validation finished"
          )
          `when`
          documentStatusOk

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

    {- |
       creates a new document root, adds all options
       as attributes to the document root and calls 'getXmlContents'.

       If the document name is the empty string, the document will be read
       from standard input.

       For supported protocols see 'Text.XML.HXT.Arrow.DocumentInput.getXmlContents'
    -}

    getDocumentContents     :: Attributes -> String -> IOStateArrow s b XmlTree
    getDocumentContents options src
        = root [] []
          >>>
          addAttr a_source src
          >>>
          seqA (map (uncurry addAttr) options)                                      -- add all options to doc root
          >>>                                                                       -- e.g. getXmlContents needs some of these
          traceMsg 1 ("readDocument: start processing document " ++ show src)
          >>>
          getXmlContents

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