-- | -- Simple parse functions. -- -- the main building blocks for an application. -- this module exports complex filters and functions for -- common tasks for input and parsing, output and option handling. -- module Text.XML.HXT.Parser.MainFunctions ( getXmlDocument , putXmlDocument , parseDocument , writeDocument ) where import Text.XML.HXT.DOM.XmlTree import Text.XML.HXT.DOM.XmlState import Text.XML.HXT.Parser.HtmlParser import Text.XML.HXT.Parser.XmlInput import Text.XML.HXT.Parser.XmlOutput import Text.XML.HXT.Parser.DTDProcessing import Text.XML.HXT.Validator.Validation import Text.XML.HXT.DOM.EditFilters import Text.XML.HXT.DOM.Namespace import System.IO -- ------------------------------------------------------------ -- | -- convenient function for reading a XML document without -- dealing with state monads, error messages collection and other details -- -- getXmlDocument calls 'parseDocument' with the list of parsing options -- and an url or filename as document source. -- -- result is a triple -- -- * the resulting document tree with a root node containing all -- meta info about the document (options, status info, http header, ...) -- -- - the list of errors and warnings -- -- - the error level: one of 'c_ok', 'c_warn', 'c_err', 'c_fatal' -- -- example for input (see also example in 'putXmlDocument' and example in 'writeDocument') -- -- > main :: IO () -- > main -- > = do -- > (res, errs, rc) <- getXmlDocument [] "test.xml" -- > if rc >= c_err -- > then issueErrors errs -- > else processTree res -- > -- > issueErrors :: XmlTrees -> IO () -- > -- > processTree :: XmlTree -> IO () -- -- for options see 'parseDocument', 'a_collect_errors' is set implicitly getXmlDocument :: Attributes -> String -> IO (XmlTree, XmlTrees, Int) getXmlDocument options url = do let options' = [ (a_collect_errors, v_1) -- collect errors , (a_issue_errors, v_0) -- but don't issue ] -- can be overwritten by supporting other values in options ++ options ++ [ (a_source, url) -- set the source url ] res <- run' $ parseDocument options' emptyRoot let root = head res let errs = tail res let elvl = intValueOf a_status root return (root, errs, elvl) -- | -- the inverse operation to 'getXmlDocument' -- -- writes a complete document tree to a file, writing can be -- controlled by options, the real work is done with filter 'writeDocument'. -- useful options are the options of 'writeDocument'. -- -- result is a pair: 1.part is a list of error messages, 2. part is the return code, -- the status info of the write filter -- -- this filter is useful, when processing XML in an arbitray context in the IO monad -- -- an example main program for such an application is: -- -- > main :: IO () -- > main -- > = do -- > (input, readErrs, rc) <- getXmlDocument [...] "test.xml" -- > if rc >= c_err -- > then issueErrors readErrs -- > else processTree input -- > -- > processTree :: XmlTree -> IO () -- > processTree t -- > = let res = computeNewTree input -- > in do -- > (writeErrs, rc2) <- putXmlDocument [...] "out.xml" res -- > if rc2 >= c_err -- > then issueErrors writeErrs -- > else return () -- > -- > issueErrors :: XmlTrees -> IO () -- > -- > computeNewTree :: XmlTree -> XmlTree putXmlDocument :: Attributes -> String -> XmlTree -> IO (XmlTrees, Int) putXmlDocument options fileName t = do let options' = [ (a_collect_errors, v_1) -- collect errors , (a_issue_errors, v_0) -- but don't issue ] -- can be overwritten by supporting other values in options ++ options ++ [ (a_output_file, fileName) -- set the source url ] res <- run' $ writeDocument options' t let root = head res let errs = tail res let elvl = intValueOf a_status root return (errs, elvl) -- ------------------------------------------------------------ -- | -- the main parsing filter -- -- this filter can be configured by an option list, a list of -- option name, option value pairs. -- the input tree must be a possibly empty document root tree. -- all the options are stored as attributes in this root node to control processing. -- -- available options: -- -- * 'a_parse_html': use HTML parser, else use XML parser (default) -- -- - 'a_validate' : validate document (default), else skip validation -- -- - 'a_check_namespaces' : check namespaces, else skip namespace processing (default) -- -- - 'a_canonicalize' : canonicalize document (default), else skip canonicalization -- -- - 'a_preserve_comment' : preserve comments during canonicalization, else remove comments (default) -- -- - 'a_remove_whitespace' : remove all whitespace, used for document indentation, else skip this step (default) -- -- - 'a_indent' : indent document by inserting whitespace, else skip this step (default) -- -- - 'a_issue_warnings' : issue warnings, when parsing HTML (default), else ignore HTML parser warnings -- -- - 'a_issue_errors' : issue all error messages on stderr (default), or ignore all error messages -- -- - 'a_collect_errors' : all error messages are collected during processing and appended to the result document -- for further processing within the calling modules -- -- - 'a_trace' : trace level: values: 0 -4 -- -- - 'a_proxy' : proxy for http access, e.g. www-cache:3128 -- -- - 'a_use_curl' : for http access via external programm curl, default is native HTTP access -- -- - 'a_options_curl' : more options for external program curl -- -- - 'a_source' : the document source url -- -- - 'a_encoding' : default document encoding ('utf8', 'isoLatin1', 'usAscii', ...) -- -- examples: -- -- > parseDocument [ (a_source, "test.xml") -- > , (a_validate, "0") -- > , (a_encoding, isoLatin1) -- > ] emptyRoot -- -- reads document \"test.xml\" without validation and default encoding 'isoLatin1' -- -- > parseDocument [ (a_source, "http://www.haskell.org/") -- > , (a_parse_html, "1") -- > , (a_proxy, "www-cache:3128") -- > , (a_curl, "1") -- > , (a_issue_warnings, "0") -- > ] emptyRoot -- -- reads Haskell homepage with HTML parser ignoring any warnings and with http access via external program curl and proxy \"www-cache\" at port 3128 -- -- > parseDocument [ (a_source, "http://www.w3c.org/") -- > , (a_parse_html, "0") -- default -- > , (a_validate, "1") -- default -- > , (a_check_namespace, "1") -- > , (a_remove_whitespace, "1") -- > , (a_trace, "2") -- > ] emptyRoot -- -- read w3c home page, validate and chech namespaces, remove whitespace between tags, trace activities with level 2 -- -- > parseDocument [ (a_source, "test.xml") -- > , (a_validate, "1") -- > , (a_check_namespace, "1") -- > , (a_collect_errors, "1") -- > , (a_issue_errors, "0") -- > ] emptyRoot -- -- reads file \"test.xml\", validates it, checks namespaces, does not issue any erros -- but collects errors and appends the list of errors to the single element list for the document. -- this enables the calling application to define own error handlers. parseDocument :: Attributes -> XmlStateFilter state parseDocument userOptions = processDocument userOptions defaultOptions ( traceMsg 1 "parseDocument: options added, start processing" .>> traceTree .>> getXmlContents -- get the content as text .>> choiceM -- select parser [ hasOption a_parse_html :-> parseHtmlDoc -- parse everything as HTML , this :-> checkWellformedDoc -- parse XML and process entities .>> ( getValidatedDoc -- validate `whenM` hasOption a_validate ) ] .>> ( propagateAndValidateNamespaces -- namespace processing `whenM` hasOption a_check_namespaces ) .>> liftMf -- canonicalization ( choice [ hasOption a_preserve_comment -- don't remove comments (in XPath required) :-> canonicalizeForXPath , this :-> canonicalizeAllNodes -- do normal canonicaliazion ] `when` hasOption a_canonicalize -- caconicalization can be switched off ) .>> liftMf ( removeDocWhiteSpace -- remove all whitespace between tags `when` hasOption a_remove_whitespace ) .>> traceMsg 1 "parseDocument: document processed" -- trace output .>> traceSource .>> traceTree ) where defaultOptions = [ ( a_parse_html, v_0 ) , ( a_validate, v_1 ) , ( a_issue_errors, v_1 ) , ( a_issue_warnings, v_1 ) , ( a_check_namespaces, v_0 ) , ( a_canonicalize, v_1 ) , ( a_preserve_comment, v_0 ) , ( a_remove_whitespace, v_0 ) ] -- ------------------------------------------------------------ addOptions :: Attributes -> XmlFilter addOptions = seqF . map (\ (n,v) -> addAttr n v ) addDefaultOptions :: Attributes -> XmlFilter addDefaultOptions = seqF . map (\ (n,v) -> addAttr n v `whenNot` hasAttr n) -- ------------------------------------------------------------ -- | -- the main filter for writing documents -- -- this filter can be configured by an option list like 'getXmlDocument' -- -- available options are -- -- * 'a_indent' : indent document for readability, (default: no indentation) -- -- - 'a_remove_whitespace' : remove all redundant whitespace for shorten text (default: no removal) -- -- - 'a_output_file' : destination file for document, default is \"-\" for stdout -- -- - 'a_output_encoding' : encoding of document, default is 'a_encoding' or 'utf8' -- -- - 'a_output_xml' : (default) issue XML: quote special XML chars \>,\<,\",\',& -- add XML processing instruction -- and encode document with respect to 'a_output_encoding', -- if explizitly switched of, the plain text is issued, this is useful -- for non XML output, e.g. generated Haskell code, LaTex, Java, ... -- -- - 'a_show_tree' : show tree representation of document (for debugging) -- -- - 'a_show_haskell' : show Haskell representaion of document (for debugging) -- -- - 'a_issue_errors', 'a_collect_errors' : see 'parseDocument' -- -- a typical main program running in the XmlState monad -- has the following structure: -- -- > -- > main :: IO () -- > main -- > = do -- > argv <- getArgs -- get the commandline arguments -- > (inp, outp, options) <- cmdlineOpts argv -- and evaluate them, return a key-value list -- > -- and input and output -- > res <- run' $ application inp outp options $ emptyRoot -- run the application -- > -- > exitWith (if null res -- > then ExitFailure (-1) -- > else exitSuccess -- > ) -- > -- > application :: String -> String -> Attributes -> XmlStateFilter () -- > application inp outp al -- > = parseDocument (al ++ [(a_source, inp)]) -- set options and source -- > .>> -- and parse document -- > processDocument -- the hard work -- > .>> -- > writeDocument [(a_output_file, outp)] -- issue results -- > .>> -- > checkStatus -- check errors -- > writeDocument :: Attributes -> XmlStateFilter state writeDocument userOptions = processDocument userOptions defaultOptions ( traceMsg 1 "writeDocument: options added, start processing" .>> liftMf ( choice [ hasOption a_indent :-> indentDoc -- document indentation , hasOption a_remove_whitespace :-> removeDocWhiteSpace -- remove all whitespace between tags , this :-> this ] ) .>> liftMf ( choice [ hasOption a_show_tree :-> treeRepOfXmlDoc , hasOption a_show_haskell :-> haskellRepOfXmlDoc , hasOption a_output_xml :-> ( escapeXmlDoc -- escape lt, gt, amp, quot, .> addXmlPiToDoc -- add <?xml ... > pi .> unparseXmlDoc -- convert doc into text with respect to output encoding ) , this :-> this ] ) .>> writeXmlDoc .>> traceMsg 1 "writeDocument: finished" ) where defaultOptions = [ ( a_output_file, "-" ) , ( a_indent, v_0 ) , ( a_remove_whitespace, v_0 ) , ( a_output_xml, v_1 ) , ( a_output_encoding, utf8 ) , ( a_show_tree, v_0 ) , ( a_show_haskell, v_0 ) ] writeXmlDoc :: XmlStateFilter state writeXmlDoc t' = put t' where put | null fn || fn == "-" = putXmlDoc | otherwise = putXmlDocToFile fn fn = xshow . getValue a_output_file $ t' -- ------------------------------------------------------------ -- -- | -- wrapper filter for running a monadic filter -- controlled by common options -- -- input tree must be a complete document -- parameters and default parameters can be used to contol -- the filer and common tasks like error message handling processDocument :: Attributes -> Attributes -> XmlStateFilter state -> XmlStateFilter state processDocument userOptions defaultOptions processFilter = liftMf isRoot .>> liftMf (addOptions userOptions .> addOptions [(a_status, show c_ok)] ) .>> liftMf (addDefaultOptions defaultOptions) .>> setSystemParams -- store options in system state .>> choiceM [ hasOption a_propagate_errors -- error handling is set by calling environment :-> thisM , hasOption a_collect_errors .> hasOption a_issue_errors :-> performAction (\ _ -> setSysErrorHandler (errorMsgLogging.>> errorMsgToStderr) ) , hasOption a_collect_errors :-> performAction (\ _ -> setSysErrorHandler errorMsgLogging ) , hasOption a_issue_errors :-> performAction (\ _ -> setSysErrorHandler errorMsgToStderr ) , this :-> performAction (\ _ -> setSysErrorHandler noneM ) ] .>> processFilter .>> ( thisM +++>> ( hasOption a_collect_errors `guardsM` getErrorMsg ) ) -- ------------------------------------------------------------