diff --git a/src/Text/HTML/WraXML/String.hs b/src/Text/HTML/WraXML/String.hs
--- a/src/Text/HTML/WraXML/String.hs
+++ b/src/Text/HTML/WraXML/String.hs
@@ -2,9 +2,9 @@
import qualified Text.HTML.Basic.Character as HtmlChar
import qualified Text.XML.WraXML.String as XmlString
-import qualified Text.XML.HXT.DOM.Unicode as Unicode
import Text.XML.WraXML.Utility (compose)
+import qualified Data.String.Unicode as Unicode
import qualified Data.Char as Char
import qualified Control.Monad.Exception.Synchronous as Exc
diff --git a/src/Text/HTML/WraXML/Tree/HXT.hs b/src/Text/HTML/WraXML/Tree/HXT.hs
--- a/src/Text/HTML/WraXML/Tree/HXT.hs
+++ b/src/Text/HTML/WraXML/Tree/HXT.hs
@@ -4,10 +4,20 @@
errorAnnFromHTMLStringOpt, ErrorMsg,
getMetaHTTPHeaders, ) where
-import qualified Text.XML.HXT.DOM.TypeDefs as HXT
--- import qualified Text.XML.HXT.DOM.XmlTreeFunctions as HXTTreeFunc
-import qualified Data.Tree.NTree.TypeDefs as HXTTree
+import qualified Text.XML.HXT.DOM.XmlNode as XmlNode
+import qualified Text.XML.HXT.Arrow.XmlState.ErrorHandling as HXTError
+import qualified Text.XML.HXT.Core as HXT
+import Text.XML.HXT.Core (withInputEncoding, isoLatin1, yes)
+import Text.XML.HXT.Arrow.XmlState (runX)
+
+import Text.XML.HXT.DOM.QualifiedName (QName, qualifiedName)
+import Text.XML.HXT.DOM.TypeDefs (XNode(..))
+import Text.XML.HXT.DOM.ShowXml (xshow)
+
+import qualified Data.Tree.Class as HXTTree
+import Data.Tree.NTree.TypeDefs (NTree(NTree))
+
import qualified Text.XML.WraXML.Tree.HXT as WraHXT
import qualified Text.HTML.WraXML.Tree as HtmlTree
@@ -18,21 +28,11 @@
import qualified Text.XML.Basic.Format as Format
--- needed for code copies from HXT at the of the file
-import Text.XML.HXT.DOM.XmlTree hiding (cmt, formatTree, )
-import Text.XML.HXT.DOM.XmlState
- (XmlStateFilter, liftF, run',
- setSystemParams, setSysErrorHandler, getErrorMsg,
- errorMsgLogging, errorMsgToStderr, )
-import Text.XML.HXT.Parser.XmlParser (parseXmlDocEncodingSpec, )
-import Text.XML.HXT.Parser.XmlInput (guessDocEncoding, )
-import Text.XML.HXT.Parser.XmlOutput (traceTree, traceSource, traceMsg, )
-import Text.XML.HXT.Parser.HtmlParser (parseHtmlDoc, )
-import Text.XML.HXT.Parser.HtmlParsec (isEmptyHtmlTag, )
-import Text.XML.HXT.DOM.EditFilters (escapeXmlDoc, )
+import Text.XML.HXT.Parser.HtmlParsec (isEmptyHtmlTag)
-import Control.Monad (msum, )
-import Data.Maybe (fromMaybe, )
+import Control.Category ((>>>))
+import Control.Monad (msum)
+import Data.Maybe (fromMaybe)
@@ -45,12 +45,16 @@
-}
tidy :: String -> IO String
tidy input =
- -- escapeXmlDoc replaces < by < and so on
- -- XmlParsec.substXmlEntities similar to escapeXmlDoc ?
- fmap (($"") . formatTrees . (escapeXmlDoc .> getChildren))
- (fromHTMLString input)
+ fmap (\[str] -> str) $
+ runX $
+ ioSLAFromIO (fromHTMLString input)
+ >>>
+ HXT.writeDocumentToString [HXT.withOutputHTML]
+ioSLAFromIO :: IO b -> HXT.IOSLA s a b
+ioSLAFromIO act = HXT.IOSLA $ \s _ -> fmap (\b -> (s,[b])) act
+
-- * formatting
{- |
@@ -82,7 +86,7 @@
where
showPiAttr :: HXT.XmlTree -> String -> String
showPiAttr a@(NTree (XAttr an) cs) =
- if qualifiedName an == a_value
+ if qualifiedName an == HXT.a_value
then Format.blank . formatTrees cs
else formatTree a
showPiAttr _ = id
@@ -141,7 +145,7 @@
fromHTMLStringMetaEncoding :: String -> IO HXT.XmlTree
fromHTMLStringMetaEncoding str =
do enc <- findMetaEncoding str
- fromHTMLStringOpt [(a_encoding, fromMaybe isoLatin1 enc)] str
+ fromHTMLStringOpt [withInputEncoding $ fromMaybe isoLatin1 enc] str
{-
With no encoding option given,
@@ -149,152 +153,51 @@
to interpret ISO-Latin characters as UTF-8 characters.
-}
fromHTMLString :: String -> IO HXT.XmlTree
-fromHTMLString = fromHTMLStringOpt [(a_encoding, isoLatin1)]
+fromHTMLString = fromHTMLStringOpt [withInputEncoding isoLatin1]
-fromHTMLStringOpt :: Attributes -> String -> IO HXT.XmlTree
+fromHTMLStringOpt :: HXT.SysConfigList -> String -> IO HXT.XmlTree
fromHTMLStringOpt options input =
do (tree,_,_) <- errorAnnFromHTMLStringOpt options input
return tree
type ErrorMsg = (Int,String)
+{-# WARNING errorAnnFromHTMLStringMetaEncoding
+ "error collection does not work currently" #-}
errorAnnFromHTMLStringMetaEncoding ::
- String -> IO (HXT.XmlTree, [ErrorMsg], Int)
-errorAnnFromHTMLStringMetaEncoding str =
- do enc <- findMetaEncoding str
- errorAnnFromHTMLStringOpt [(a_encoding, fromMaybe isoLatin1 enc)] str
-
-{- |
-Adaption of Text.XML.HXT.Parser.MainFunctions.getXmlDocument
--}
-errorAnnFromHTMLStringOpt ::
- Attributes -> String -> IO (HXT.XmlTree, [ErrorMsg], Int)
-errorAnnFromHTMLStringOpt options contents =
- 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
- (root:errs) <- run' $ parseDocument options' contents emptyRoot
- let elvl = intValueOf a_status root
- let errMsgs = map ((\(XError level msg) -> (level, msg)) . getNode) errs
- return (root, errMsgs, elvl)
-
-
-
-
-{- |
-An input handler alternative
-to Text.XML.HXT.Parser.ProtocolHandlerFile.
-It returns the argument string as something
-that can be further processed by HXT functions.
--}
-getStringContents :: String -> XmlStateFilter a
-getStringContents contents =
- return . replaceChildren (xtext contents)
- .>>
- {- We must attach some encoding info to the tree
- which is processed by the HTML parser.
- Using this encoding information
- the HTML parser converts e.g. UTF-8 characters to Unicode characters.
- Cf. Parser.XmlInput.getXmlContents -}
- liftF parseXmlDocEncodingSpec
- .>>
- guessDocEncoding
-
-
-{- |
-Adaption of Text.XML.HXT.Parser.MainFunctions.parseDocument
--}
-parseDocument :: Attributes -> String -> XmlStateFilter state
-parseDocument userOptions contents
- = processDocument userOptions defaultOptions
- ( traceMsg 1 "parseDocument: options added, start processing"
- .>>
- traceTree
- .>>
- getStringContents contents -- get the content as text
- .>>
- parseHtmlDoc -- parse everything as HTML
- .>>
--- liftMf canonicalizeForXPath
--- .>>
- traceMsg 1 "parseDocument: document processed" -- trace output
- .>>
- traceSource
- .>>
- traceTree
- )
- where
- defaultOptions
- = [ ( a_parse_html, v_1 )
- , ( 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 )
- ]
+ String -> IO (HXT.XmlTree, [ErrorMsg], Maybe Int)
+errorAnnFromHTMLStringMetaEncoding str = do
+ enc <- findMetaEncoding str
+ errorAnnFromHTMLStringOpt [withInputEncoding $ fromMaybe isoLatin1 enc] str
{- |
-Copy of Text.XML.HXT.Parser.MainFunctions.addOptions add addDefaultOptions
+In earlier version I managed to obtain the error messages.
+This does not work anymore and do not know how to achieve this.
-}
-addOptions :: Attributes -> XmlFilter
-addOptions
- = seqF . map (uncurry addAttr)
-
-addDefaultOptions :: Attributes -> XmlFilter
-addDefaultOptions
- = seqF . map (\ (n,v) -> addAttr n v `whenNot` hasAttr n)
-
+{-# WARNING errorAnnFromHTMLStringOpt
+ "error collection does not work currently" #-}
+errorAnnFromHTMLStringOpt ::
+ HXT.SysConfigList -> String -> IO (HXT.XmlTree, [ErrorMsg], Maybe Int)
+errorAnnFromHTMLStringOpt = errorAnnFromHTMLStringInternal
{- |
-Copy of Text.XML.HXT.Parser.MainFunctions.processDocument
+Adaption of Text.XML.HXT.Parser.MainFunctions.getXmlDocument
-}
-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
- )
- )
+errorAnnFromHTMLStringInternal ::
+ HXT.SysConfigList -> String -> IO (HXT.XmlTree, [ErrorMsg], Maybe Int)
+errorAnnFromHTMLStringInternal options contents = do
+ (root_:errs) <-
+ runX $
+ HXT.errorMsgCollect
+ >>>
+ HXT.readString (HXT.withParseHTML yes : options) contents
+ >>>
+ HXTError.filterErrorMsg
+ let elvl = XmlNode.getErrorLevel root_
+ let errMsgs =
+ map ((\(XError level msg) -> (level, msg)) . HXTTree.getNode) errs
+ return (root_, errMsgs, elvl)
{-
diff --git a/src/Text/XML/WraXML/String.hs b/src/Text/XML/WraXML/String.hs
--- a/src/Text/XML/WraXML/String.hs
+++ b/src/Text/XML/WraXML/String.hs
@@ -1,10 +1,9 @@
module Text.XML.WraXML.String where
-import qualified Text.XML.HXT.DOM.Unicode as Unicode
-
import qualified Text.XML.Basic.Character as XmlChar
import Text.XML.WraXML.Utility (compose)
+import qualified Data.String.Unicode as Unicode
import qualified Data.Char as Char
import Data.Tuple.HT (mapFst)
diff --git a/src/Text/XML/WraXML/Tree.hs b/src/Text/XML/WraXML/Tree.hs
--- a/src/Text/XML/WraXML/Tree.hs
+++ b/src/Text/XML/WraXML/Tree.hs
@@ -11,7 +11,7 @@
import qualified Text.XML.Basic.Format as Format
import qualified Data.Tree.BranchLeafLabel as Tree
-import qualified Text.XML.HXT.DOM.Unicode as Unicode
+import qualified Data.String.Unicode as Unicode
import qualified Data.Char as Char
import qualified Control.Monad.Exception.Synchronous as Exc
diff --git a/src/Text/XML/WraXML/Tree/HXT.hs b/src/Text/XML/WraXML/Tree/HXT.hs
--- a/src/Text/XML/WraXML/Tree/HXT.hs
+++ b/src/Text/XML/WraXML/Tree/HXT.hs
@@ -3,8 +3,7 @@
checkTagName, ) where
import qualified Text.XML.HXT.DOM.TypeDefs as HXT
--- import qualified Text.XML.HXT.DOM.XmlTreeFunctions as HXTTreeFunc
-import qualified Data.Tree.NTree.TypeDefs as HXTTree
+import qualified Data.Tree.Class as HXTTree
import Text.XML.WraXML.Tree
(Branch(Tag), Leaf(Text, PI, Comment, Warning, CData), )
@@ -23,7 +22,9 @@
import qualified Text.XML.Basic.Character as XmlChar
-- needed for code copies from HXT at the of the file
-import Text.XML.HXT.DOM.XmlTree (QName, NTree, XNode, )
+import Text.XML.HXT.DOM.QualifiedName (QName)
+import Text.XML.HXT.DOM.TypeDefs (XNode)
+import Data.Tree.NTree.TypeDefs (NTree(NTree))
{- * conversion from our XML tree to HXT tree -}
@@ -88,7 +89,7 @@
toXmlTree = XmlTree.mergeStrings . toXmlTree'
-toXmlTree' (HXTTree.NTree label subTrees) = XmlTree.wrap $ (,) () $
+toXmlTree' (NTree label subTrees) = XmlTree.wrap $ (,) () $
let leaf x =
if null subTrees
then Tree.Leaf x
@@ -96,7 +97,7 @@
fromHXTName = Name.fromString . HXT.qualifiedName
- convAttr (HXTTree.NTree x value) =
+ convAttr (NTree x value) =
case x of
HXT.XAttr name ->
Attr.new (HXT.qualifiedName name) (HXTString.toXmlString value)
@@ -121,7 +122,7 @@
Tree.Leaf $ PI (fromHXTName target) $
case subTrees of
[] -> PI.Known $ map convAttr proc
- [HXTTree.NTree (HXT.XText str) []] ->
+ [NTree (HXT.XText str) []] ->
PI.Unknown str
_ -> error "from HXT: processing instruction - there must be no children or a single text child"
HXT.XAttr _ -> error "from HXT: attribute not allowed in normal text"
diff --git a/wraxml.cabal b/wraxml.cabal
--- a/wraxml.cabal
+++ b/wraxml.cabal
@@ -1,6 +1,6 @@
Cabal-Version: 2.2
Name: wraxml
-Version: 0.4.4.4
+Version: 0.5
License: GPL-3.0-only
License-File: LICENSE
Author: Henning Thielemann
@@ -51,7 +51,7 @@
Source-Repository this
Type: darcs
Location: http://code.haskell.org/~thielema/wraxml/
- Tag: 0.4.4.4
+ Tag: 0.5
Flag buildExamples
description: Build example executables
@@ -64,8 +64,8 @@
tagchup >=0.4 && <0.5,
xml-basic >=0.1 && <0.2,
HaXml >=1.23 && <1.26,
- hxt >=8.5.0 && <8.6,
- hxt-filter >=8.1.1 && <9,
+ hxt >=9.3 && <9.4,
+ hxt-unicode >=9.0.1 && <9.1,
explicit-exception >=0.1.3 && <0.3,
transformers >=0.2 && <0.7,
data-accessor >=0.2 && <0.3,