packages feed

wraxml 0.4.4.4 → 0.5

raw patch · 6 files changed

+71/−168 lines, 6 filesdep +hxt-unicodedep −hxt-filterdep ~containersdep ~hxt

Dependencies added: hxt-unicode

Dependencies removed: hxt-filter

Dependency ranges changed: containers, hxt

Files

src/Text/HTML/WraXML/String.hs view
@@ -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
src/Text/HTML/WraXML/Tree/HXT.hs view
@@ -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 &lt; 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)   {-
src/Text/XML/WraXML/String.hs view
@@ -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)
src/Text/XML/WraXML/Tree.hs view
@@ -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
src/Text/XML/WraXML/Tree/HXT.hs view
@@ -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"
wraxml.cabal view
@@ -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 <haskell@henning-thielemann.de>@@ -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,