diff --git a/Version.mk b/Version.mk
--- a/Version.mk
+++ b/Version.mk
@@ -2,6 +2,6 @@
# Version numbering for HXT
SOFTWARE = hxt
-VERSION = 8.3.1
-LASTVERSION = 8.3.0
+VERSION = 8.3.2
+LASTVERSION = 8.3.1
DIST_NAME = $(SOFTWARE)-$(VERSION)
diff --git a/doc/index.html b/doc/index.html
--- a/doc/index.html
+++ b/doc/index.html
@@ -1,12 +1,12 @@
- Haskell XML Toolbox 8.3.1
+ Haskell XML Toolbox 8.3.2
- Haskell XML Toolbox 8.3.1
+ Haskell XML Toolbox 8.3.2
Contents
@@ -185,8 +185,8 @@
Downloads
- Haskell XML Toolbox 8.3.1,
- released 2009-06-16:
+ Haskell XML Toolbox 8.3.2,
+ released 2009-10-29:
- This version works with ghc 6.10 with cabal 1.6.
@@ -225,7 +225,7 @@
Before installing this version, install the curl and tagsoup modules.
For a quick install with Cabal execute the following commands in
- .../HXT-8.3.1
+ .../HXT-8.3.2
cabal configure
@@ -251,7 +251,41 @@
Change History
+ - In Version 8.3.2
+ This is a bug fix release.
+
+ -
+ New output option a_output_xhtmlfor writing XHTML.
+
+ -
+ New output option a_no_empty_elem_for for precise
+ control, which empty elements shall not be emitted in
+ short form <name .../>.
+
+ - New output option a_add_default_dtd for easy
+ adding a Document Type Declaration.
+
+ -
+ writeDocumentToString changed, such that it is a pure
+ arrow and does not need to run in the IO monad.
+
+ -
+ Dealing with URIs containing unescaped chars changed.
+ When URIs can't be parsed (with Network.URI), then the
+ not allowed chars will be escaped in %XX format and
+ URI parsing is retried. This enables normal file names to contain blanks and
+ other chars without explicit escaping.
+
+
+
- In Version 8.3.1
+
+ - Additional input option "a_accept_mimetypes" for setting a list of allowed
+ mime types when using readDocument.
+
+
+
+ - In Version 8.3.1
This is only a bug fix release.
-
@@ -605,7 +639,7 @@
-
| Last modified: 2009-06-16 | |
+ | Last modified: 2009-10-29 | |
diff --git a/examples/arrows/RegexXMLSchema/REtest.hs b/examples/arrows/RegexXMLSchema/REtest.hs
--- a/examples/arrows/RegexXMLSchema/REtest.hs
+++ b/examples/arrows/RegexXMLSchema/REtest.hs
@@ -137,7 +137,7 @@
-- ----------------------------------------
-- output is done with low level ops to write the
--- document i a lasy manner
+-- document i a lazy manner
-- adding an xml pi and encoding is done "by hand"
-- latin1 decoding is the identity, so please generate the
-- docs with latin1 encoding. Here ist done even with ASCCI
diff --git a/examples/arrows/RelaxTestSuite/ReadDir.hs b/examples/arrows/RelaxTestSuite/ReadDir.hs
--- a/examples/arrows/RelaxTestSuite/ReadDir.hs
+++ b/examples/arrows/RelaxTestSuite/ReadDir.hs
@@ -19,6 +19,7 @@
)
import Data.List
( find
+ , sort
, isSuffixOf
)
import Maybe
@@ -46,7 +47,7 @@
readDir pre p
= do
dir <- getDirectoryContents $ pre ++ "/" ++ p
- entries <- getEntries $ clean [".", "..", "CVS"] dir
+ entries <- getEntries $ sort $ clean [".", "..", "CVS"] dir
return $ Dir entries
where
getEntries :: [FilePath] -> IO [Entry]
diff --git a/examples/arrows/hparser/Makefile b/examples/arrows/hparser/Makefile
--- a/examples/arrows/hparser/Makefile
+++ b/examples/arrows/hparser/Makefile
@@ -107,7 +107,7 @@
cat $(EX4)
@sleep 2 ; echo ; echo "===> parser accepts this document and tries to build a document tree" ; echo ; sleep 2
$(prog) --indent --preserve-comment --parse-html $(EX4)
- @sleep 2 ; echo ; echo "===> same with lasy parser with tagsoup" ; echo ; sleep 2
+ @sleep 2 ; echo ; echo "===> same with lazy parser with tagsoup" ; echo ; sleep 2
$(prog) -H -T -r --indent $(EX4)
@echo
@echo "===> the source of another lousy html document containing empty elements" ; echo ; sleep 2
diff --git a/examples/arrows/hrelaxng/valid2a.xml b/examples/arrows/hrelaxng/valid2a.xml
new file mode 100644
--- /dev/null
+++ b/examples/arrows/hrelaxng/valid2a.xml
diff --git a/examples/arrows/performance/GenDoc.hs b/examples/arrows/performance/GenDoc.hs
--- a/examples/arrows/performance/GenDoc.hs
+++ b/examples/arrows/performance/GenDoc.hs
@@ -70,7 +70,7 @@
-- ----------------------------------------
--- test on lasyness, is the whole tree read or only the first child of every child node?
+-- test on lazyness, is the whole tree read or only the first child of every child node?
main3 :: Bool -> Int -> IO ()
main3 l i
@@ -243,7 +243,7 @@
-- ----------------------------------------
-- output is done with low level ops to write the
--- document i a lasy manner
+-- document i a lazy manner
-- adding an xml pi and encoding is done "by hand"
-- latin1 decoding is the identity, so please generate the
-- docs with latin1 encoding. Here ist done even with ASCCI
diff --git a/hxt.cabal b/hxt.cabal
--- a/hxt.cabal
+++ b/hxt.cabal
@@ -1,6 +1,6 @@
-- arch-tag: Haskell XML Toolbox main description file
name: hxt
-version: 8.3.1
+version: 8.3.2
license: OtherLicense
license-file: LICENCE
maintainer: Uwe Schmidt
@@ -134,7 +134,7 @@
containers >= 0.1 && < 1,
directory >= 1 && < 2,
filepath >= 1 && < 2,
- parsec >= 2.1 && < 3,
+ parsec >= 2.1 && < 4,
HUnit >= 1.2 && < 2,
network >= 2.1 && < 3,
parallel >= 1.0 && < 2,
diff --git a/src/Control/Arrow/ArrowTree.hs b/src/Control/Arrow/ArrowTree.hs
--- a/src/Control/Arrow/ArrowTree.hs
+++ b/src/Control/Arrow/ArrowTree.hs
@@ -122,7 +122,7 @@
-- all \"h1\" elements in the \"body\" element of an \"html\" element, an expression, that
-- corresponds 1-1 to the XPath selection path \"html\/body\/h1\"
- (/>) :: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)
+ (/>) :: Tree t => a b (t c) -> a (t c) d -> a b d
f /> g = f >>> getChildren >>> g
-- |
@@ -138,7 +138,7 @@
-- to the XPath selection path \"html\/\/table\". The latter on matches all table elements
-- even nested ones, but @\/\/>@ gives in many cases the appropriate functionality.
- (//>) :: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)
+ (//>) :: Tree t => a b (t c) -> a (t c) d -> a b d
f //> g = f >>> getChildren >>> deep g
@@ -159,7 +159,7 @@
-- example: @ deep isHtmlTable @ selects all top level table elements in a document
-- (with an appropriate definition for isHtmlTable) but no tables occuring within a table cell.
- deep :: Tree t => a (t b) (t b) -> a (t b) (t b)
+ deep :: Tree t => a (t b) c -> a (t b) c
deep f = f -- success when applying f
`orElse`
(getChildren >>> deep f) -- seach children
@@ -171,7 +171,7 @@
-- example: @ deepest isHtmlTable @ selects all innermost table elements in a document
-- but no table elements containing tables. See 'deep' and 'multi' for other search strategies.
- deepest :: Tree t => a (t b) (t b) -> a (t b) (t b)
+ deepest :: Tree t => a (t b) c -> a (t b) c
deepest f = (getChildren >>> deepest f) -- seach children
`orElse`
f -- no success: apply f to root
diff --git a/src/Makefile b/src/Makefile
--- a/src/Makefile
+++ b/src/Makefile
@@ -268,7 +268,7 @@
install_packages :
runghc hxt-package.hs $(VERSION) "ghc" $(GHC_INSTALL_DIR) $(HXT_SRC) \
- | ghc-pkg --update-package
+ | ghc-pkg update -
uninstall_packages :
ghc-pkg --remove-package $(HXT_PACKAGE) || true
diff --git a/src/Text/XML/HXT/Arrow/DocumentInput.hs b/src/Text/XML/HXT/Arrow/DocumentInput.hs
--- a/src/Text/XML/HXT/Arrow/DocumentInput.hs
+++ b/src/Text/XML/HXT/Arrow/DocumentInput.hs
@@ -20,6 +20,7 @@
, getXmlContents
, getXmlEntityContents
, getEncoding
+ , getTextEncoding
, decodeDocument
)
where
diff --git a/src/Text/XML/HXT/Arrow/DocumentOutput.hs b/src/Text/XML/HXT/Arrow/DocumentOutput.hs
--- a/src/Text/XML/HXT/Arrow/DocumentOutput.hs
+++ b/src/Text/XML/HXT/Arrow/DocumentOutput.hs
@@ -16,7 +16,12 @@
-- ------------------------------------------------------------
module Text.XML.HXT.Arrow.DocumentOutput
- ( module Text.XML.HXT.Arrow.DocumentOutput )
+ ( putXmlDocument
+ , putXmlTree
+ , putXmlSource
+ , encodeDocument
+ , encodeDocument'
+ )
where
import Control.Arrow -- arrow classes
@@ -24,11 +29,13 @@
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowTree
import Control.Arrow.ArrowIO
+import Control.Arrow.ListArrow
import Text.XML.HXT.DOM.Unicode
( getOutputEncodingFct )
import Text.XML.HXT.DOM.Interface
+
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlIOStateArrow
@@ -125,8 +132,39 @@
-- ------------------------------------------------------------
+getEncodingParam :: IOStateArrow s XmlTree String
+getEncodingParam
+ = catA [ getParamString a_output_encoding -- 4. guess: take output encoding parameter from global state
+ , getParamString a_encoding -- 5. guess: take encoding parameter from global state
+ , constA utf8 -- default : utf8
+ ]
+ >. (head . filter (not . null))
+
getOutputEncoding :: String -> IOStateArrow s XmlTree String
getOutputEncoding defaultEnc
+ = getEC $< getEncodingParam
+ where
+ getEC enc' = fromLA $ getOutputEncoding' defaultEnc enc'
+
+encodeDocument :: Bool -> String -> IOStateArrow s XmlTree XmlTree
+encodeDocument supressXmlPi defaultEnc
+ = encode $< getOutputEncoding defaultEnc
+ where
+ encode enc
+ = traceMsg 2 ("encodeDocument: encoding is " ++ show enc)
+ >>>
+ ( encodeDocument' supressXmlPi enc
+ `orElse`
+ ( issueFatal ("encoding scheme not supported: " ++ show enc)
+ >>>
+ setDocumentStatusFromSystemState "encoding document"
+ )
+ )
+
+-- ------------------------------------------------------------
+
+getOutputEncoding' :: String -> String -> LA XmlTree String
+getOutputEncoding' defaultEnc defaultEnc2
= catA [ getChildren -- 1. guess: evaluate
>>>
( ( isPi >>> hasName t_xml )
@@ -135,45 +173,33 @@
)
, constA defaultEnc -- 2. guess: explicit parameter, may be ""
, getAttrValue a_output_encoding -- 3. guess: take output encoding parameter in root node
- , getParamString a_output_encoding -- 4. guess: take output encoding parameter in global state
- , getParamString a_encoding -- 5. guess: take encoding parameter in global state
- , constA utf8 -- default : utf8
+ , constA defaultEnc2 -- default : UNICODE or utf8
]
>. (head . filter (not . null)) -- make the filter deterministic: take 1. entry from list of guesses
-encodeDocument :: Bool -> String -> IOStateArrow s XmlTree XmlTree
-encodeDocument supressXmlPi defaultEnc
- = applyA ( getOutputEncoding defaultEnc
- >>>
- arr encArr
- )
- `when`
- isRoot
+encodeDocument' :: ArrowXml a => Bool -> String -> a XmlTree XmlTree
+encodeDocument' supressXmlPi defaultEnc
+ = fromLA (encode $< getOutputEncoding' defaultEnc utf8)
where
- encArr :: String -> IOStateArrow s XmlTree XmlTree
- encArr enc = maybe notFound found . getOutputEncodingFct $ enc
- where
- found ef = traceMsg 2 ("encodeDocument: encoding is " ++ show enc)
- >>>
- ( if supressXmlPi
- then processChildren (none `when` isXmlPi)
- else ( addXmlPi
- >>>
- addXmlPiEncoding enc
- )
- )
- >>>
- replaceChildren ( xshow getChildren
- >>>
- arr ef
- >>>
- mkText
- )
- >>>
- addAttr a_output_encoding enc
-
- notFound = issueFatal ("encoding scheme not supported: " ++ show enc)
- >>>
- setDocumentStatusFromSystemState "encoding document"
+ encode :: String -> LA XmlTree XmlTree
+ encode encodingScheme
+ = case getOutputEncodingFct encodingScheme of
+ Nothing -> none
+ Just ef -> ( if supressXmlPi
+ then processChildren (none `when` isXmlPi)
+ else ( addXmlPi
+ >>>
+ addXmlPiEncoding encodingScheme
+ )
+ )
+ >>>
+ replaceChildren ( xshow getChildren
+ >>>
+ arr ef
+ >>>
+ mkText
+ )
+ >>>
+ addAttr a_output_encoding encodingScheme
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Arrow/Edit.hs b/src/Text/XML/HXT/Arrow/Edit.hs
--- a/src/Text/XML/HXT/Arrow/Edit.hs
+++ b/src/Text/XML/HXT/Arrow/Edit.hs
@@ -46,6 +46,9 @@
, transfCharRef
, transfAllCharRef
+ , rememberDTDAttrl
+ , addDefaultDTDecl
+
, hasXmlPi
, addXmlPi
, addXmlPiEncoding
@@ -72,6 +75,7 @@
import Text.XML.HXT.Parser.XmlEntities ( xmlEntities )
import Text.XML.HXT.Parser.XhtmlEntities ( xhtmlEntities )
+import Data.List ( isPrefixOf )
import qualified Data.Map as M
import Data.Maybe
@@ -357,11 +361,12 @@
-- ------------------------------------------------------------
-preventEmptyElements :: ArrowList a => Bool -> a XmlTree XmlTree
-preventEmptyElements isHtml
+preventEmptyElements :: ArrowList a => [String] -> Bool -> a XmlTree XmlTree
+preventEmptyElements ns isHtml
= fromLA $ insertDummyElem
where
isNoneEmpty
+ | not (null ns) = hasNameWith (localPart >>> (`elem` ns))
| isHtml = hasNameWith (localPart >>> (`notElem` emptyHtmlTags))
| otherwise = this
@@ -704,6 +709,39 @@
transfAllCharRef :: ArrowXml a => a XmlTree XmlTree
transfAllCharRef = fromLA $
processBottomUp transfCharRef'
+
+-- ------------------------------------------------------------
+
+rememberDTDAttrl :: ArrowList a => a XmlTree XmlTree
+rememberDTDAttrl
+ = fromLA $
+ ( ( addDTDAttrl $< ( getChildren >>> isDTDDoctype >>> getDTDAttrl ) )
+ `orElse`
+ this
+ )
+ where
+ addDTDAttrl al
+ = seqA . map (uncurry addAttr) . map (first (dtdPrefix ++)) $ al
+
+addDefaultDTDecl :: ArrowList a => a XmlTree XmlTree
+addDefaultDTDecl
+ = fromLA $
+ ( addDTD $< listA (getAttrl >>> (getName &&& xshow getChildren) >>> hasDtdPrefix) )
+ where
+ hasDtdPrefix
+ = isA (fst >>> (dtdPrefix `isPrefixOf`))
+ >>>
+ arr (first (drop (length dtdPrefix)))
+ addDTD []
+ = this
+ addDTD al
+ = replaceChildren
+ ( mkDTDDoctype al none
+ <+>
+ txt "\n"
+ <+>
+ ( getChildren >>> (none `when` isDTDDoctype) ) -- remove old DTD stuff
+ )
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Arrow/ReadDocument.hs b/src/Text/XML/HXT/Arrow/ReadDocument.hs
--- a/src/Text/XML/HXT/Arrow/ReadDocument.hs
+++ b/src/Text/XML/HXT/Arrow/ReadDocument.hs
@@ -36,6 +36,7 @@
import Text.XML.HXT.Arrow.Edit ( canonicalizeAllNodes
, canonicalizeForXPath
, canonicalizeContents
+ , rememberDTDAttrl
, removeDocWhiteSpace
)
@@ -60,7 +61,7 @@
* 'a_parse_html': use HTML parser, else use XML parser (default)
-- 'a_tagsoup' : use light weight and lasy parser based on tagsoup lib
+- 'a_tagsoup' : use light weight and lazy parser based on tagsoup lib
- 'a_parse_by_mimetype' : select the parser by the mime type of the document
(pulled out of the HTTP header). When the mime type is set to \"text\/html\"
@@ -210,6 +211,7 @@
, ( a_parse_by_mimetype, v_0 )
, ( a_ignore_encoding_errors, v_0 )
, ( a_ignore_none_xml_contents, v_0 )
+ , ( a_accept_mimetypes, "" )
]
traceLevel
@@ -229,22 +231,54 @@
= getAttrValue transferMimeType >>^ stringToLower
processDoc mimeType
- = traceMsg 1 ("readDocument: " ++ show src ++ " (mime type: " ++ show mimeType ++ ") will be processed")
- >>>
- parse
+ = traceMsg 1 (unwords [ "readDocument:", show src
+ , "(mime type:", show mimeType, ") will be processed"])
>>>
- ( if isXmlOrHtml
- then ( checknamespaces
- >>>
- canonicalize
- >>>
- whitespace
+ ( if isAcceptedMimeType (lookup1 a_accept_mimetypes options) mimeType
+ then ( parse
>>>
- relax
+ ( if isXmlOrHtml
+ then ( checknamespaces
+ >>>
+ rememberDTDAttrl
+ >>>
+ canonicalize
+ >>>
+ whitespace
+ >>>
+ relax
+ )
+ else this
+ )
)
- else this
+ else ( traceMsg 1 (unwords [ "readDocument:", show src
+ , "mime type:", show mimeType, "not accepted"])
+ >>>
+ replaceChildren none
+ ) -- remove contents of not accepted mimetype
)
where
+ isAcceptedMimeType :: String -> String -> Bool
+ isAcceptedMimeType mts mt
+ | null mts
+ ||
+ null mt = True
+ | otherwise = foldr (matchMt mt') False $ mts'
+ where
+ mt' = parseMt mt
+ mts' = words
+ >>>
+ map parseMt
+ $
+ mts
+ parseMt = break (== '/')
+ >>>
+ second (drop 1)
+ matchMt (ma,mi) (mas,mis) r = ( (ma == mas || mas == "*")
+ &&
+ (mi == mis || mis == "*")
+ )
+ || r
parse
| isHtml
||
@@ -257,7 +291,7 @@
isHtml
| validateWithRelax = parseXmlDocument False -- for Relax NG use XML parser without validation
| isXml = parseXmlDocument validate -- parse as XML
- | removeNoneXml = replaceChildren none -- don't parse, if mime type is not XML nore HTML
+ | removeNoneXml = replaceChildren none -- don't parse, if mime type is not XML nor HTML
| otherwise = this -- but remove contents when option is set
checknamespaces
| (withNamespaces && not withTagSoup)
@@ -313,7 +347,7 @@
readFromDocument :: Attributes -> IOStateArrow s String XmlTree
readFromDocument userOptions
- = applyA ( arr $ \ s -> readDocument userOptions s )
+ = applyA ( arr $ readDocument userOptions )
-- ------------------------------------------------------------
@@ -336,7 +370,7 @@
readFromString :: Attributes -> IOStateArrow s String XmlTree
readFromString userOptions
- = applyA ( arr $ \ s -> readString userOptions s )
+ = applyA ( arr $ readString userOptions )
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Arrow/WriteDocument.hs b/src/Text/XML/HXT/Arrow/WriteDocument.hs
--- a/src/Text/XML/HXT/Arrow/WriteDocument.hs
+++ b/src/Text/XML/HXT/Arrow/WriteDocument.hs
@@ -35,6 +35,7 @@
, escapeXmlDoc
, haskellRepOfXmlDoc
, indentDoc
+ , addDefaultDTDecl
, preventEmptyElements
, removeDocWhiteSpace
, treeRepOfXmlDoc
@@ -42,6 +43,7 @@
import Text.XML.HXT.Arrow.DocumentOutput ( putXmlDocument
, encodeDocument
+ , encodeDocument'
)
-- ------------------------------------------------------------
@@ -76,6 +78,12 @@
Empty script elements, like \