packages feed

wraxml 0.3 → 0.4

raw patch · 16 files changed

+847/−807 lines, 16 filesdep +tagchupdep −tagsoup-htdep ~xml-basic

Dependencies added: tagchup

Dependencies removed: tagsoup-ht

Dependency ranges changed: xml-basic

Files

src/Text/HTML/WraXML/Document.hs view
@@ -1,26 +1,23 @@ module Text.HTML.WraXML.Document (-   XMLDoc.T(..), XMLDoc.lift, show,+   XMLDoc.T(..), XMLDoc.lift, format,    ) where  import qualified Text.HTML.WraXML.Tree    as HTMLTree import qualified Text.XML.WraXML.Document as XMLDoc-import qualified Text.XML.WraXML.String   as XMLString import qualified Text.XML.Basic.Name as Name--import Prelude hiding (show)+import qualified Text.XML.Basic.Format as Format  -show ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   XMLDoc.T i name XMLString.T -> String-show (XMLDoc.Cons xml dtd trees) =-   let (showHTML, showXMLDecl) =+format ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   XMLDoc.T i name string -> ShowS+format (XMLDoc.Cons xml dtd trees) =+   let (formatHTML, formatXMLDecl) =           maybe-             (HTMLTree.showsMany, id)+             (HTMLTree.formatMany, id)              (\xmlDecl ->-                 (HTMLTree.showsManyXHTML,-                  XMLDoc.showXMLDeclaration xmlDecl)) xml-   in  showXMLDecl .-       maybe id XMLDoc.showDocType dtd .-       showHTML trees $-       ""+                 (HTMLTree.formatManyXHTML,+                  XMLDoc.formatXMLDeclaration xmlDecl)) xml+   in  formatXMLDecl .+       maybe id XMLDoc.formatDocType dtd .+       formatHTML trees
src/Text/HTML/WraXML/Table.hs view
@@ -15,7 +15,7 @@ Ignores all non-table-row-tags and all non-table-cell-tags. -} simpleFromRows ::-   (Name.Tag name, Eq name) =>+   (Name.Tag name) =>    [XMLTree.T i name str] ->  T i name str simpleFromRows =    map (simpleFromRow . snd) .@@ -23,7 +23,7 @@    mapMaybe XMLTree.maybeTag  simpleFromRow ::-   (Name.Tag name, Eq name) =>+   (Name.Tag name) =>    [XMLTree.T i name str] ->  [[XMLTree.T i name str]] simpleFromRow =    map snd .
src/Text/HTML/WraXML/Tree.hs view
@@ -10,24 +10,20 @@ import qualified Text.XML.Basic.Attribute as Attr import qualified Text.XML.Basic.Name  as Name -import Text.XML.WraXML.Tree (showLeaf, )-import qualified Text.XML.Basic.Format as ShowXML+import Text.XML.WraXML.Tree (formatLeaf, )+import qualified Text.XML.Basic.Format as Format  import           Data.List.HT (takeWhileRev, ) import           Data.Tuple.HT (mapFst, ) import           Control.Monad (liftM2, ) import           Data.Maybe (mapMaybe, fromMaybe, ) --- import qualified Text.Show as Show -import Prelude hiding (show, shows, ) -- {- * Character decoding -}  findMetaEncoding ::-   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Name.Tag name, Name.Attribute name) =>    XmlTree.T i name String -> Maybe String findMetaEncoding =    fmap (map Char.toLower . takeWhileRev ('='/=)) .@@ -40,7 +36,7 @@ and present these values like HTTP headers. -} getMetaHTTPHeaders ::-   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Name.Tag name, Name.Attribute name) =>    XmlTree.T i name String -> [(String, String)] getMetaHTTPHeaders =    mapMaybe (\attrs ->@@ -62,7 +58,7 @@ according to the encoding given in a META HTTP-EQUIV tag. -} decodeSpecialCharsMetaEncoding ::-   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Name.Tag name, Name.Attribute name) =>    XmlTree.T i name XmlString.T -> [XmlTree.T i name String] decodeSpecialCharsMetaEncoding tree =    let unicodeTree = XmlTree.unescape tree@@ -76,47 +72,49 @@ {- * Formatting -}  +{- show ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    XmlTree.T i name XmlString.T -> String show leaf = shows leaf ""+-} -showsMany ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   [XmlTree.T i name XmlString.T] -> ShowS-showsMany = ShowXML.many shows+formatMany ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   [XmlTree.T i name string] -> ShowS+formatMany = Format.many format --- cf. src/Text/XML/HXT/DOM/XmlTreeFunctions.hs-shows ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   XmlTree.T i name XmlString.T -> ShowS-shows =-   Tree.fold (flip const) showBranch showLeaf .+-- cf. src/Text/ML/HXT/DOM/XmlTreeFunctions.hs+format ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   XmlTree.T i name string -> ShowS+format =+   Tree.fold (flip const) formatBranch formatLeaf .    XmlTree.unwrap -showBranch ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   XmlTree.Branch name XmlString.T -> [ShowS] -> ShowS-showBranch = showBranchGen False+formatBranch ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   XmlTree.Branch name string -> [ShowS] -> ShowS+formatBranch = formatBranchGen False  -showsManyXHTML ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   [XmlTree.T i name XmlString.T] -> ShowS-showsManyXHTML = ShowXML.many showsXHTML+formatManyXHTML ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   [XmlTree.T i name string] -> ShowS+formatManyXHTML = Format.many formatXHTML  -- cf. src/Text/XML/HXT/DOM/XmlTreeFunctions.hs-showsXHTML ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   XmlTree.T i name XmlString.T -> ShowS-showsXHTML =-   Tree.fold (flip const) showBranchXHTML showLeaf .+formatXHTML ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   XmlTree.T i name string -> ShowS+formatXHTML =+   Tree.fold (flip const) formatBranchXHTML formatLeaf .    XmlTree.unwrap -showBranchXHTML ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   XmlTree.Branch name XmlString.T -> [ShowS] -> ShowS-showBranchXHTML = showBranchGen True+formatBranchXHTML ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   XmlTree.Branch name string -> [ShowS] -> ShowS+formatBranchXHTML = formatBranchGen True   {- |@@ -125,13 +123,13 @@ Unfortunately we cannot generally merge @<tag></tag>@ to @<tag/>@ since browsers expect e.g. separated @<div></div>@. -}-showBranchGen ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   Bool -> XmlTree.Branch name XmlString.T -> [ShowS] -> ShowS-showBranchGen xhtml branch showSubTrees =+formatBranchGen ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   Bool -> XmlTree.Branch name string -> [ShowS] -> ShowS+formatBranchGen xhtml branch formatSubTrees =    case branch of       XmlTree.Tag elm ->          Elem.format-            (\tagName -> null showSubTrees && Tag.isEmpty tagName)-            (if xhtml then ShowXML.slash else id)-            elm showSubTrees+            (\tagName -> null formatSubTrees && Tag.isEmpty tagName)+            (if xhtml then Format.slash else id)+            elm formatSubTrees
+ src/Text/HTML/WraXML/Tree/HXT.hs view
@@ -0,0 +1,303 @@+module Text.HTML.WraXML.Tree.HXT+   (tidy, format, fromHTMLString, fromHTMLStringMetaEncoding,+    errorAnnFromHTMLStringMetaEncoding,+    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.WraXML.Tree.HXT as WraHXT++import qualified Text.HTML.WraXML.Tree   as HTMLTree+import qualified Text.XML.WraXML.Tree    as XmlTree++import qualified Text.XML.Basic.Name.LowerCase as NameLC+import qualified Text.XML.Basic.Name as Name++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.DOM.ShowXml       (xshow, {- showXmlTree, showQName, -})+import Text.XML.HXT.DOM.QualifiedName (qualifiedName, )+import Data.Tree.NTree.Filter         (liftMf, )++import Control.Monad (msum, )+import Data.Maybe (fromMaybe, )++++{- |+Tidy a piece of HTML code.+&   ->   &amp;+<   ->   &lt;+unquoted tag attribute values: size=-1   ->   size="-1"+insert omitted closing tags+-}+tidy :: String -> IO String+tidy input =+   -- escapeXmlDoc replaces < by &lt; and so on+   -- XmlParsec.substXmlEntities similar to escapeXmlDoc ?+   fmap (($"") . formatTrees . (escapeXmlDoc .> getChildren))+        (fromHTMLString input)+++-- * formatting++{- |+Like 'Text.XML.HXT.DOM.XmlTreeFunctions.xshow'+but it shows empty tags the HTML way.+E.g. it emits @<br>@ instead of @<br\/>@,+@<noscript><\/noscript>@ instead of @<noscript\/>@.+Many browsers prefer that.+-}+format :: HXT.XmlTree -> String+format leaf = formatTrees (HXTTree.getChildren leaf) ""++formatTrees	:: HXT.XmlTrees -> ShowS+formatTrees	= foldr (.) id . map formatTree+++-- cf. src/Text/XML/HXT/DOM/XmlTreeFunctions.hs+formatTree	:: HXT.XmlTree -> ShowS+formatTree leaf =+   case leaf of+      (NTree (XPi n al) _) ->+         showString "<?"+         .+         formatQName n+         .+         (foldr (.) id . map showPiAttr) al+         .+         showString "?>"+           where+             showPiAttr :: HXT.XmlTree -> String -> String+             showPiAttr a@(NTree (XAttr an) cs) =+	         if aName an == a_value+	           then Format.blank . formatTrees cs+	           else formatTree a+             showPiAttr _ = id+      (NTree (XTag t al) cs) ->+         if null cs && isEmptyHtmlTag (HXT.qualifiedName t)+           then Format.lt . formatQName t . formatTrees al . Format.gt+           else Format.lt . formatQName t . formatTrees al . Format.gt+                 . formatTrees cs+                 . Format.lt . Format.slash . formatQName t . Format.gt+      (NTree (XAttr an) cs) ->+         Format.blank . formatQName an . Format.eq . Format.stringQuoted (formatTrees cs "")+      (NTree (XError l e) _) ->+         showString "<!-- ERROR (" . showString (show l) . showString "):\n"+          . showString e . showString "\n-->"+      _ -> (xshow [leaf] ++) -- showXmlTree leaf+++formatQName :: QName -> ShowS+formatQName = showString . qualifiedName+++-- * parsing and encoding++{- |+Search for a META tag for the encoding of the HTML text.+-}+findMetaEncoding :: String -> IO (Maybe String)+findMetaEncoding str =+   do htmlTrees <- xmlTreesFromHTMLString str+      return (msum (map HTMLTree.findMetaEncoding (htmlTrees :: [XmlTree.T () NameLC.T String])))++getMetaHTTPHeaders :: String -> IO [(String, String)]+getMetaHTTPHeaders str =+   do htmlTrees <- xmlTreesFromHTMLString str+      return (concatMap HTMLTree.getMetaHTTPHeaders (htmlTrees :: [XmlTree.T () NameLC.T String]))++xmlTreesFromHTMLString ::+   (Name.Tag name, Name.Attribute name) =>+   String -> IO [XmlTree.T () name String]+xmlTreesFromHTMLString str =+   do hxtTree <- fromHTMLString str+      -- it will hopefully be only one HTML tree+      return $+         map (XmlTree.unescape . WraHXT.toXmlTree)+             (filter (WraHXT.checkTagName "html" . HXTTree.getNode)+                     (HXTTree.getChildren hxtTree))+++{- |+Guess the encoding from the META-HTTP-EQUIV attribute, if available.+Otherwise fall back to ISO-Latin-1.+-}+fromHTMLStringMetaEncoding :: String -> IO HXT.XmlTree+fromHTMLStringMetaEncoding str =+   do enc <- findMetaEncoding str+      fromHTMLStringOpt [(a_encoding, fromMaybe isoLatin1 enc)] str++{-+With no encoding option given,+utf8ToUnicode fails when trying to interpret ISO-Latin characters as UTF-8 characters+-}+fromHTMLString :: String -> IO HXT.XmlTree+fromHTMLString = fromHTMLStringOpt [(a_encoding, isoLatin1)]++fromHTMLStringOpt :: Attributes -> String -> IO HXT.XmlTree+fromHTMLStringOpt options input =+   do (tree,_,_) <- errorAnnFromHTMLStringOpt options input+      return tree++type ErrorMsg = (Int,String)++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 )+	  ]+++{- |+Copy of Text.XML.HXT.Parser.MainFunctions.addOptions add addDefaultOptions+-}+addOptions	  :: Attributes -> XmlFilter+addOptions+    = seqF . map (uncurry addAttr)++addDefaultOptions :: Attributes -> XmlFilter+addDefaultOptions+    = seqF . map (\ (n,v) -> addAttr n v `whenNot` hasAttr n)+++{- |+Copy of Text.XML.HXT.Parser.MainFunctions.processDocument+-}+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+	)+      )+++{-+putStr . xshow =<< run' (Text.XML.HXT.Parser.MainFunctions.parseDocument [(a_source,"lousy.html"), (a_parse_html,v_1)] emptyRoot)++readFile "lousy.html" >>= tidy >>= putStr+-}
src/Text/XML/WraXML/Document.hs view
@@ -1,10 +1,9 @@ module Text.XML.WraXML.Document where -import qualified Text.XML.WraXML.Tree    as XmlTree-import qualified Text.XML.WraXML.String  as XmlString+import qualified Text.XML.WraXML.Tree as XmlTree import qualified Text.XML.Basic.Attribute as Attr import qualified Text.XML.Basic.Name as Name-import qualified Text.XML.Basic.Format as ShowXML+import qualified Text.XML.Basic.Format as Format   @@ -15,12 +14,12 @@      deriving Show  instance-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>       Functor (T i name) where    fmap f = lift f (map (fmap f))  lift ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    (str0 -> str1) ->    ([XmlTree.T i name str0] -> [XmlTree.T i name str1]) ->    T i name str0 -> T i name str1@@ -28,23 +27,27 @@    Cons (fmap (map (fmap g)) xml) dtd $ f trees  -showXMLDeclaration ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   [Attr.T name XmlString.T] -> ShowS-showXMLDeclaration attrs =+formatXMLDeclaration ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   [Attr.T name string] -> ShowS+formatXMLDeclaration attrs =    showString "<?xml" . Attr.formatListBlankHead attrs . showString "?>" .-   ShowXML.nl+   Format.nl -showDocType :: String -> ShowS-showDocType dtdStr =-   showString "<!DOCTYPE " . showString dtdStr . showString ">" .-   ShowXML.nl+formatDocType :: String -> ShowS+formatDocType dtdStr =+   Format.angle (showString "!DOCTYPE " . showString dtdStr) .+   Format.nl -show ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   T i name XmlString.T -> String-show (Cons xml dtd trees) =-   maybe id showXMLDeclaration xml .-   maybe id showDocType dtd .-   XmlTree.showsMany trees $-   ""+format ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   T i name string -> ShowS+format (Cons xml dtd trees) =+   maybe id formatXMLDeclaration xml .+   maybe id formatDocType dtd .+   XmlTree.formatMany trees++instance+   (Name.Tag name, Name.Attribute name, Format.C string) =>+      Format.C (T i name string) where+   run = format
src/Text/XML/WraXML/Document/TagSoup.hs view
@@ -38,7 +38,7 @@    modify dropSpace >> state f  toXmlDocument ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    [Tag] -> XmlDoc.T Position.T name String toXmlDocument ts =    flip evalState@@ -66,7 +66,7 @@ -}  toXmlDocumentString ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    [Tag] -> XmlDoc.T Position.T name String toXmlDocumentString =    toXmlDocument
− src/Text/XML/WraXML/Document/TagSoupHT.hs 
@@ -1,91 +0,0 @@-module Text.XML.WraXML.Document.TagSoupHT where--import qualified Text.XML.WraXML.Tree.TagSoupHT as TreeTagSoup-import qualified Text.XML.WraXML.Document as XmlDoc--- import qualified Text.XML.WraXML.Tree     as XmlTree--import qualified Text.HTML.TagSoup.HT.Parser      as TagParser-import qualified Text.HTML.TagSoup.HT.Tag         as Tag-import qualified Text.HTML.TagSoup.HT.PositionTag as PosTag-import qualified Text.XML.Basic.Position    as Position-import qualified Text.HTML.Basic.Tag as TagH-import qualified Text.HTML.Basic.Character    as HTMLChar--import qualified Text.XML.Basic.Name.LowerCase as NameLC-import qualified Text.XML.Basic.Name           as Name-import qualified Text.XML.Basic.ProcessingInstruction as PI--import Data.List.HT (viewL, )-import Data.Maybe (fromMaybe, )-import Control.Monad (guard, )--import Control.Monad.Trans.State (State, state, evalState, modify, gets, )--import qualified Data.Char as Char----type XmlDoc = XmlDoc.T Position.T---class TagParser.CharType char => CharSpace char where-   isSpace :: char -> Bool--instance CharSpace Char where-   isSpace = Char.isSpace--instance CharSpace HTMLChar.T where-   isSpace c =-      case c of-         HTMLChar.Unicode chr -> Char.isSpace chr-         HTMLChar.EntityRef "nbsp" -> True-         _ -> False--class StringSpace string where-   isAllSpace :: string -> Bool--instance CharSpace char => StringSpace [char] where-   isAllSpace = all isSpace---dropSpace :: StringSpace string =>-   [PosTag.T name string] -> [PosTag.T name string]-dropSpace =-   dropWhile-      (\tag ->-          case PosTag.tag_ tag of-             Tag.Text text -> isAllSpace text-             _ -> False)--withoutLeadingSpace :: (StringSpace string) =>-   ([PosTag.T name string] -> (a, [PosTag.T name string])) ->-   State [PosTag.T name string] a-withoutLeadingSpace f =-   modify dropSpace >> state f--toXmlDocument ::-   (Name.Tag name, Name.Attribute name, Ord name, StringSpace string) =>-   [PosTag.T name string] -> XmlDoc name string-toXmlDocument ts =-   flip evalState ts $-   do xml <- withoutLeadingSpace $ \ts0 ->-         fromMaybe (Nothing, ts0) $-         do (t,ts1) <- viewL ts0-            (name, PI.Known attrs) <- Tag.maybeProcessing (PosTag.tag_ t)-            guard (Name.match "xml" name)-            return (Just attrs, ts1)-      docType <- withoutLeadingSpace $ \ts0 ->-         fromMaybe (Nothing, ts0) $-         do (t,ts1) <- viewL ts0-            (name, dtd) <- Tag.maybeSpecial (PosTag.tag_ t)-            guard (Name.match TagH.doctypeString name)-            return (Just dtd, ts1)-      gets (XmlDoc.Cons xml docType . TreeTagSoup.toXmlTrees)---example :: IO ()-example =-  print .-  (toXmlDocument :: [PosTag.T NameLC.T String] -> XmlDoc NameLC.T String) .-  TagParser.runSoupWithPositions-    =<< readFile "/home/thielema/public_html/index.html"
+ src/Text/XML/WraXML/Document/Tagchup.hs view
@@ -0,0 +1,91 @@+module Text.XML.WraXML.Document.Tagchup where++import qualified Text.XML.WraXML.Tree.Tagchup as TreeTagchup+import qualified Text.XML.WraXML.Document as XmlDoc+-- import qualified Text.XML.WraXML.Tree     as XmlTree++import qualified Text.HTML.Tagchup.Parser      as TagParser+import qualified Text.HTML.Tagchup.Tag         as Tag+import qualified Text.HTML.Tagchup.PositionTag as PosTag+import qualified Text.XML.Basic.Position    as Position+import qualified Text.HTML.Basic.Tag as TagH+import qualified Text.HTML.Basic.Character    as HTMLChar++import qualified Text.XML.Basic.Name.LowerCase as NameLC+import qualified Text.XML.Basic.Name           as Name+import qualified Text.XML.Basic.ProcessingInstruction as PI++import Data.List.HT (viewL, )+import Data.Maybe (fromMaybe, )+import Control.Monad (guard, )++import Control.Monad.Trans.State (State, state, evalState, modify, gets, )++import qualified Data.Char as Char++++type XmlDoc = XmlDoc.T Position.T+++class TagParser.CharType char => CharSpace char where+   isSpace :: char -> Bool++instance CharSpace Char where+   isSpace = Char.isSpace++instance CharSpace HTMLChar.T where+   isSpace c =+      case c of+         HTMLChar.Unicode chr -> Char.isSpace chr+         HTMLChar.EntityRef "nbsp" -> True+         _ -> False++class StringSpace string where+   isAllSpace :: string -> Bool++instance CharSpace char => StringSpace [char] where+   isAllSpace = all isSpace+++dropSpace :: StringSpace string =>+   [PosTag.T name string] -> [PosTag.T name string]+dropSpace =+   dropWhile+      (\tag ->+          case PosTag.tag_ tag of+             Tag.Text text -> isAllSpace text+             _ -> False)++withoutLeadingSpace :: (StringSpace string) =>+   ([PosTag.T name string] -> (a, [PosTag.T name string])) ->+   State [PosTag.T name string] a+withoutLeadingSpace f =+   modify dropSpace >> state f++toXmlDocument ::+   (Name.Tag name, Name.Attribute name, StringSpace string) =>+   [PosTag.T name string] -> XmlDoc name string+toXmlDocument ts =+   flip evalState ts $+   do xml <- withoutLeadingSpace $ \ts0 ->+         fromMaybe (Nothing, ts0) $+         do (t,ts1) <- viewL ts0+            (name, PI.Known attrs) <- Tag.maybeProcessing (PosTag.tag_ t)+            guard (Name.match "xml" name)+            return (Just attrs, ts1)+      docType <- withoutLeadingSpace $ \ts0 ->+         fromMaybe (Nothing, ts0) $+         do (t,ts1) <- viewL ts0+            (name, dtd) <- Tag.maybeSpecial (PosTag.tag_ t)+            guard (Name.match TagH.doctypeString name)+            return (Just dtd, ts1)+      gets (XmlDoc.Cons xml docType . TreeTagchup.toXmlTrees)+++example :: IO ()+example =+  print .+  (toXmlDocument :: [PosTag.T NameLC.T String] -> XmlDoc NameLC.T String) .+  TagParser.runSoupWithPositions+    =<< readFile "/home/thielema/public_html/index.html"
src/Text/XML/WraXML/Element.hs view
@@ -1,7 +1,5 @@ module Text.XML.WraXML.Element where -import qualified Text.XML.WraXML.String  as XmlString- import qualified Text.XML.Basic.Tag as Tag import qualified Text.XML.Basic.Attribute as Attr import qualified Text.XML.Basic.Name as Name@@ -14,7 +12,7 @@ import qualified Control.Applicative as App import           Data.Monoid (mconcat, ) -import qualified Text.XML.Basic.Format as ShowXML+import qualified Text.XML.Basic.Format as Format import qualified Text.Show as Show  @@ -24,8 +22,14 @@       attributes_ :: [Attr.T name str]    } deriving (Show) +type Filter name str = T name str -> T name str  +cons ::+   (Name.Tag name, Name.Attribute name) =>+   Tag.Name name -> [Attr.T name str] -> T name str+cons = Cons+ name :: Accessor.T (T name str) (Tag.Name name) name = Accessor.fromSetGet (\n p -> p{name_ = n}) name_ @@ -51,7 +55,7 @@  lift ::    (Tag.Name name -> [Attr.T name str] -> (Tag.Name name, [Attr.T name str])) ->-   (T name str -> T name str)+   (Filter name str) lift f (Cons tagName attrs) =    uncurry Cons (f tagName attrs) @@ -61,26 +65,26 @@    (Name.Tag name, Name.Attribute name) =>    (Tag.Name name -> Bool) ->    ([Attr.T name str] -> [Attr.T name str]) ->-   (T name str -> T name str)+   (Filter name str) processAttrs p f =    lift (\tagName ->       (,) tagName . if p tagName then f else id)  processAttrValue ::-   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Name.Tag name, Name.Attribute name) =>    (Tag.Name name, Attr.Name name) ->    (str -> str) ->-   (T name str -> T name str)+   (Filter name str) processAttrValue (tagName,attrName) f =    processAttrs (tagName ==)       (Attr.adjustOn (attrName ==) f)  processAttrValueCond ::-   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Name.Tag name, Name.Attribute name) =>    (Tag.Name name, Attr.Name name) ->    ([Attr.T name str] -> Bool) ->    (str -> str) ->-   (T name str -> T name str)+   (Filter name str) processAttrValueCond (tagName,attrName) cond f =    processAttrs (tagName ==)       (\attrs -> Attr.adjustOn (attrName ==)@@ -103,7 +107,7 @@  -- | process the attribute list of a specific tag processAttrsA ::-   (Name.Tag name, Name.Attribute name, Eq name, Applicative m) =>+   (Name.Tag name, Name.Attribute name, Applicative m) =>    (Tag.Name name -> Bool) ->    ([Attr.T name str] -> m [Attr.T name str]) ->    (T name str -> m (T name str))@@ -113,7 +117,7 @@       if p tagName then f else App.pure)  processAttrValueA ::-   (Name.Tag name, Name.Attribute name, Eq name, Applicative m) =>+   (Name.Tag name, Name.Attribute name, Applicative m) =>    (Tag.Name name, Attr.Name name) ->    (str -> m str) ->    (T name str -> m (T name str))@@ -122,7 +126,7 @@       (Attr.adjustOnA (attrName==) f)  processAttrValueCondA ::-   (Name.Tag name, Name.Attribute name, Eq name, Applicative m) =>+   (Name.Tag name, Name.Attribute name, Applicative m) =>    (Tag.Name name, Attr.Name name) ->    ([Attr.T name str] -> Bool) ->    (str -> m str) ->@@ -134,7 +138,7 @@          attrs)  liftA ::-   (Name.Tag name, Name.Attribute name, Eq name, Applicative m) =>+   (Name.Tag name, Name.Attribute name, Applicative m) =>    (Tag.Name name -> [Attr.T name str] ->       m (Tag.Name name, [Attr.T name str])) ->    (T name str -> m (T name str))@@ -146,15 +150,15 @@ -- * format  format ::-   (Name.Tag name, Name.Attribute name, Eq name) =>-   (Tag.Name name -> Bool) -> ShowS -> T name XmlString.T -> [ShowS] -> ShowS-format isCondensed trailingSlash (Cons tagName attrs) showSubTrees =+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   (Tag.Name name -> Bool) -> ShowS -> T name string -> [ShowS] -> ShowS+format isCondensed trailingSlash (Cons tagName attrs) formatSubTrees =    let t = Name.toString tagName    in  if isCondensed tagName-         then ShowXML.angle+         then Format.angle                (showString t . Attr.formatListBlankHead attrs                  . trailingSlash)-         else ShowXML.angle+         else Format.angle                (showString t . Attr.formatListBlankHead attrs)-               . foldr (.) id showSubTrees-               . ShowXML.angle (ShowXML.slash . showString t)+               . foldr (.) id formatSubTrees+               . Format.angle (Format.slash . showString t)
src/Text/XML/WraXML/Tree.hs view
@@ -27,10 +27,7 @@ import           Data.Maybe (mapMaybe, fromMaybe, ) import           Data.Monoid (Monoid, mempty, mappend, mconcat, ) -import qualified Text.XML.Basic.Format as ShowXML-import qualified Text.Show as Show--import Prelude hiding (show, shows)+import qualified Text.XML.Basic.Format as Format   {- * data structures -}@@ -69,23 +66,23 @@    showsPrec prec x =       showParen (prec>=10) $       case x of-         Text   _ str -> Show.showString "Text "    . Show.showsPrec 11 str-         Comment  str -> Show.showString "Comment " . Show.showsPrec 11 str-         CData    str -> Show.showString "CData "   . Show.showsPrec 11 str+         Text   _ str -> showString "Text "    . showsPrec 11 str+         Comment  str -> showString "Comment " . showsPrec 11 str+         CData    str -> showString "CData "   . showsPrec 11 str          PI target p  ->---            Show.showString "ProcessingInstruction " .-            Show.showString "PI " .-            Show.showsPrec 11 target . Show.showString " " .-            Show.showsPrec 11 p+--            showString "ProcessingInstruction " .+            showString "PI " .+            showsPrec 11 target . showString " " .+            showsPrec 11 p          {- Maybe it is better to attach warnings to malicious tags             instead of throwing them into the tag soup.             But how to tell the position of the error then? -}-         Warning  str -> Show.showString "Warning " . Show.showsPrec 11 str+         Warning  str -> showString "Warning " . showsPrec 11 str  -{- * Name data type -}- {-+-- * Name data type+ A name can only consist of (7-bit) ASCII characters. It is used both for tag names and for attribute names. newtype Name = Name String@@ -182,25 +179,6 @@  {- * Conversions -} -maybeTag :: T i name str -> Maybe (Elem.T name str, [T i name str])-maybeTag (Cons (_,t)) =-   case t of-      Tree.Branch (Tag elm) subTrees ->-           Just (elm, map wrap subTrees)-      _ -> Nothing--maybeText :: T i name str -> Maybe str-maybeText (Cons (_,t)) =-   case t of-      Tree.Leaf l -> maybeTextLeaf l-      _           -> Nothing--maybeTextLeaf :: Leaf name str -> Maybe str-maybeTextLeaf t =-   case t of-      Text _ s -> Just s-      _        -> Nothing- liftTrans :: (a -> b) -> (a -> [b]) liftTrans f = (:[]) . f @@ -262,13 +240,32 @@ If the Tree is a Leaf, then return False. Otherwise return the result of the predicate. -}-checkTreeTag :: (Elem.T name str -> Bool) -> (T i name str -> Bool)-checkTreeTag p =+checkTag :: (Elem.T name str -> Bool) -> (T i name str -> Bool)+checkTag p =    Tree.switch (flip const) (const . p . getElement) (const False)     . unwrap +maybeTag :: T i name str -> Maybe (Elem.T name str, [T i name str])+maybeTag (Cons (_,t)) =+   case t of+      Tree.Branch (Tag elm) subTrees ->+           Just (elm, map wrap subTrees)+      _ -> Nothing +maybeText :: T i name str -> Maybe str+maybeText (Cons (_,t)) =+   case t of+      Tree.Leaf l -> maybeTextLeaf l+      _           -> Nothing +maybeTextLeaf :: Leaf name str -> Maybe str+maybeTextLeaf t =+   case t of+      Text _ s -> Just s+      _        -> Nothing+++ {- * types of processors -}  type Filter i name str = T i name str -> T i name str@@ -303,7 +300,7 @@   mapTag ::-   (Elem.T name str -> Elem.T name str) ->+   (Elem.Filter name str) ->    (Filter i name str) mapTag f =    lift $@@ -324,7 +321,7 @@  mapCond ::    (Elem.T name str -> Bool) ->-   (Elem.T name str -> Elem.T name str) ->+   (Elem.Filter name str) ->    (Leaf name str -> Leaf name str) ->    (Filter i name str) mapCond descend elemF txtF =@@ -422,7 +419,7 @@   -{- * monadic tree processors -}+{- * applicative functor tree processors -}  instance Foldable (T i name) where    foldMap f =@@ -475,6 +472,11 @@ unescape :: T i name XmlString.T -> T i name String unescape = fmap XmlString.toUnicodeString +{- |+Use ASCII characters, XML entity references and character references+for representing strings.+That's not human readable, but portable.+-} escape :: T i name String -> T i name XmlString.T escape = fmap XmlString.fromUnicodeString @@ -484,7 +486,7 @@ Decode characters like those from UTF-8 scheme. -} decodeSpecialChars ::-   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Name.Tag name, Name.Attribute name) =>    String -> T i name XmlString.T -> [T i name String] decodeSpecialChars enc tree =    fromMaybe@@ -492,7 +494,7 @@       (maybeDecodeSpecialChars enc tree)  maybeDecodeSpecialChars ::-   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Name.Tag name, Name.Attribute name) =>    String -> T i name XmlString.T -> Maybe [T i name String] maybeDecodeSpecialChars enc tree =    fmap (flip decodeSpecialCharsDecoder tree) $@@ -508,7 +510,7 @@ Conversion errors are appended as warnings to the tree. -} decodeSpecialCharsDecoder ::-   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Name.Tag name, Name.Attribute name) =>    Unicode.DecodingFctEmbedErrors -> T i name XmlString.T -> [T i name String] decodeSpecialCharsDecoder decode =    let xmlDecode =@@ -541,7 +543,7 @@        unwrap  decodeAttrs ::-   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Name.Tag name, Name.Attribute name) =>    (XmlString.T -> XmlString.EmbeddedExceptions) ->    [Attr.T name XmlString.T] -> Writer [String] [Attr.T name String] decodeAttrs xmlDecode =@@ -550,7 +552,7 @@          traverse  (decodeAttr xmlDecode (Attr.name_ attr)) attr)  decodeAttr ::-   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Name.Tag name, Name.Attribute name) =>    (XmlString.T -> XmlString.EmbeddedExceptions) ->    Attr.Name name -> XmlString.T -> Writer [String] String decodeAttr decode name =@@ -567,41 +569,42 @@  {- * Formatting -} -+{- show ::-   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Name.Tag name, Name.Attribute name) =>    T i name XmlString.T -> String show leaf = shows leaf ""+-} -showsMany ::-   (Name.Tag name, Name.Attribute name, Eq name) =>-   [T i name XmlString.T] -> ShowS-showsMany = ShowXML.many shows+formatMany ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   [T i name string] -> ShowS+formatMany = Format.many format  -- cf. src/Text/XML/HXT/DOM/XmlTreeFunctions.hs-shows ::-   (Name.Tag name, Name.Attribute name, Eq name) =>-   T i name XmlString.T -> ShowS-shows =-   Tree.fold (flip const) showBranch showLeaf . unwrap+format ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   T i name string -> ShowS+format =+   Tree.fold (flip const) formatBranch formatLeaf . unwrap -showBranch ::-   (Name.Tag name, Name.Attribute name, Eq name) =>-   Branch name XmlString.T -> [ShowS] -> ShowS-showBranch branch showSubTrees =+formatBranch ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   Branch name string -> [ShowS] -> ShowS+formatBranch branch formatSubTrees =    case branch of       Tag elm ->          Elem.format-            (\_tagName -> null showSubTrees)-            ShowXML.slash-            elm showSubTrees+            (\_tagName -> null formatSubTrees)+            Format.slash+            elm formatSubTrees -showLeaf ::-   (Name.Tag name, Name.Attribute name, Eq name) =>-   Leaf name XmlString.T -> ShowS-showLeaf leaf =+formatLeaf ::+   (Name.Tag name, Name.Attribute name, Format.C string) =>+   Leaf name string -> ShowS+formatLeaf leaf =    case leaf of-      Text _ str -> ShowXML.run str+      Text _ str -> Format.run str       Comment c ->          showString "<!--" . showString c . showString "-->"       Warning e ->@@ -609,8 +612,18 @@       CData str ->          showString "<![CDATA[" . showString str . showString "]]>"       PI target p ->-         ShowXML.angle $-         ShowXML.quest .-         ShowXML.name target .-         ShowXML.run p .-         ShowXML.quest+         Format.angle $+         Format.quest .+         Format.name target .+         Format.run p .+         Format.quest++instance+   (Name.Tag name, Name.Attribute name, Format.C string) =>+      Format.C (T i name string) where+   run = format++instance+   (Name.Tag name, Name.Attribute name, Format.C string) =>+      Format.C (Leaf name string) where+   run = formatLeaf
src/Text/XML/WraXML/Tree/HXT.hs view
@@ -1,9 +1,6 @@ module Text.XML.WraXML.Tree.HXT    (fromXmlTree, toXmlTree, lift, liftFilterToDocument,-    tidyHTML, showHTML, fromHTMLString, fromHTMLStringMetaEncoding,-    errorAnnFromHTMLStringMetaEncoding,-    errorAnnFromHTMLStringOpt, ErrorMsg,-    getMetaHTTPHeaders) where+    checkTagName, ) where  import qualified Text.XML.HXT.DOM.TypeDefs as HXT -- import qualified Text.XML.HXT.DOM.XmlTreeFunctions as HXTTreeFunc@@ -13,7 +10,6 @@    (Branch(Tag), Leaf(Text, PI, Comment, Warning, CData), ) import qualified Text.XML.WraXML.Element as Elem -import qualified Text.HTML.WraXML.Tree   as HTMLTree import qualified Text.XML.WraXML.Tree    as XmlTree import qualified Data.Tree.BranchLeafLabel as Tree @@ -21,34 +17,20 @@ import qualified Text.XML.WraXML.String.HXT as HXTString  import qualified Text.XML.Basic.Attribute as Attr-import qualified Text.XML.Basic.Name.LowerCase as NameLC import qualified Text.XML.Basic.Name as Name import qualified Text.XML.Basic.ProcessingInstruction as PI  import qualified Text.XML.Basic.Character as XMLChar-import qualified Text.XML.Basic.Format    as ShowXML  -- needed for code copies from HXT at the of the file-import Text.XML.HXT.DOM.XmlTree hiding (cmt)-import Text.XML.HXT.DOM.XmlState-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.DOM.ShowXml       (xshow, {- showXmlTree, showQName, -})+import Text.XML.HXT.DOM.XmlTree (QName, NTree, XNode, ) import Text.XML.HXT.DOM.QualifiedName (qualifiedName)-import Data.Tree.NTree.Filter         (liftMf) -import Control.Monad (msum, )-import Data.Maybe (fromMaybe, ) - {- * conversion from our XML tree to HXT tree -}  fromXmlTree ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    XmlTree.T i name XmlString.T -> HXT.XmlTree fromXmlTree x =    case multiFromXmlTree x of@@ -68,7 +50,7 @@                (HXTString.fromXmlString $ Attr.value_ a))  multiFromXmlTree ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    XmlTree.T i name XmlString.T -> [HXT.XmlTree] multiFromXmlTree =    Tree.fold@@ -102,7 +84,7 @@ {- * conversion from HXT tree to our XML tree -}  toXmlTree, toXmlTree' ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    HXT.XmlTree -> XmlTree.T () name XmlString.T toXmlTree = XmlTree.mergeStrings . toXmlTree' @@ -153,7 +135,7 @@ {- * lift our XML filters to HXT filters -}  lift ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    XmlTree.Filter () name XmlString.T -> (HXT.XmlTree -> HXT.XmlTree) lift f = fromXmlTree . f . toXmlTree @@ -162,7 +144,7 @@ Lift our XML filters to HXT document processors. -} liftFilterToDocument ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>       String  {- ^ Name of root tag for processing, e.g. "html".                    That tag must be in the first level.                    It is an unchecked run-time error@@ -193,265 +175,4 @@ but not using its XML tree structure for manipulations. This way I hope I can keep in sync with the main development path while not interfering with HXT's typing style.--}----{- |-Tidy a piece of HTML code.-&   ->   &amp;-<   ->   &lt;-unquoted tag attribute values: size=-1   ->   size="-1"-insert omitted closing tags--}-tidyHTML :: String -> IO String-tidyHTML input =-   -- escapeXmlDoc replaces < by &lt; and so on-   -- XmlParsec.substXmlEntities similar to escapeXmlDoc ?-   fmap (($"") . showHTMLTrees . (escapeXmlDoc .> getChildren))-        (fromHTMLString input)---{- |-Like 'Text.XML.HXT.DOM.XmlTreeFunctions.xshow'-but it shows empty tags the HTML way.-E.g. it emits @<br>@ instead of @<br\/>@,-@<noscript><\/noscript>@ instead of @<noscript\/>@.-Many browsers prefer that.--}-showHTML :: HXT.XmlTree -> String-showHTML leaf = showHTMLTrees (HXTTree.getChildren leaf) ""--showHTMLTrees	:: HXT.XmlTrees -> ShowS-showHTMLTrees	= foldr (.) id . map showHTMLTree----- cf. src/Text/XML/HXT/DOM/XmlTreeFunctions.hs-showHTMLTree	:: HXT.XmlTree -> ShowS-showHTMLTree leaf =-   case leaf of-      (NTree (XPi n al) _) ->-         showString "<?"-         .-         showQName n-         .-         (foldr (.) id . map showPiAttr) al-         .-         showString "?>"-           where-             showPiAttr :: HXT.XmlTree -> String -> String-             showPiAttr a@(NTree (XAttr an) cs) =-	         if aName an == a_value-	           then ShowXML.blank . showHTMLTrees cs-	           else showHTMLTree a-             showPiAttr _ = id-      (NTree (XTag t al) cs) ->-         if null cs && isEmptyHtmlTag (HXT.qualifiedName t)-           then ShowXML.lt . showQName t . showHTMLTrees al . ShowXML.gt-           else ShowXML.lt . showQName t . showHTMLTrees al . ShowXML.gt-                 . showHTMLTrees cs-                 . ShowXML.lt . ShowXML.slash . showQName t . ShowXML.gt-      (NTree (XAttr an) cs) ->-         ShowXML.blank . showQName an . ShowXML.eq . ShowXML.stringQuoted (showHTMLTrees cs "")-      (NTree (XError l e) _) ->-         showString "<!-- ERROR (" . showString (show l) . showString "):\n"-          . showString e . showString "\n-->"-      _ -> (xshow [leaf] ++) -- showXmlTree leaf---showQName :: QName -> ShowS-showQName = showString . qualifiedName----{- |-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---{- |-Search for a META tag for the encoding of the HTML text.--}-findMetaEncoding :: String -> IO (Maybe String)-findMetaEncoding str =-   do htmlTrees <- xmlTreesFromHTMLString str-      return (msum (map HTMLTree.findMetaEncoding (htmlTrees :: [XmlTree.T () NameLC.T String])))--getMetaHTTPHeaders :: String -> IO [(String, String)]-getMetaHTTPHeaders str =-   do htmlTrees <- xmlTreesFromHTMLString str-      return (concatMap HTMLTree.getMetaHTTPHeaders (htmlTrees :: [XmlTree.T () NameLC.T String]))--xmlTreesFromHTMLString ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   String -> IO [XmlTree.T () name String]-xmlTreesFromHTMLString str =-   do hxtTree <- fromHTMLString str-      -- it will hopefully be only one HTML tree-      return $-         map (XmlTree.unescape . toXmlTree)-             (filter (checkTagName "html" . HXTTree.getNode)-                     (HXTTree.getChildren hxtTree))---{- |-Guess the encoding from the META-HTTP-EQUIV attribute, if available.-Otherwise fall back to ISO-Latin-1.--}-fromHTMLStringMetaEncoding :: String -> IO HXT.XmlTree-fromHTMLStringMetaEncoding str =-   do enc <- findMetaEncoding str-      fromHTMLStringOpt [(a_encoding, fromMaybe isoLatin1 enc)] str--{--With no encoding option given,-utf8ToUnicode fails when trying to interpret ISO-Latin characters as UTF-8 characters--}-fromHTMLString :: String -> IO HXT.XmlTree-fromHTMLString = fromHTMLStringOpt [(a_encoding, isoLatin1)]--fromHTMLStringOpt :: Attributes -> String -> IO HXT.XmlTree-fromHTMLStringOpt options input =-   do (tree,_,_) <- errorAnnFromHTMLStringOpt options input-      return tree--type ErrorMsg = (Int,String)--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)----{- |-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 )-	  ]---{- |-Copy of Text.XML.HXT.Parser.MainFunctions.addOptions add addDefaultOptions--}-addOptions	  :: Attributes -> XmlFilter-addOptions-    = seqF . map (uncurry addAttr)--addDefaultOptions :: Attributes -> XmlFilter-addDefaultOptions-    = seqF . map (\ (n,v) -> addAttr n v `whenNot` hasAttr n)---{- |-Copy of Text.XML.HXT.Parser.MainFunctions.processDocument--}-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-	)-      )---{--putStr . xshow =<< run' (Text.XML.HXT.Parser.MainFunctions.parseDocument [(a_source,"lousy.html"), (a_parse_html,v_1)] emptyRoot)--readFile "lousy.html" >>= tidy >>= putStr -}
src/Text/XML/WraXML/Tree/HaXml.hs view
@@ -26,7 +26,7 @@ {- * conversion from our XML tree to HaXml tree -}  fromXmlTree ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    XmlTree.T i name XmlString.T -> HaXml.Content i fromXmlTree x =    case multiFromXmlTree x of@@ -34,7 +34,7 @@       _   -> error "top branch can't be a string"  multiFromXmlTree ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    XmlTree.T i name XmlString.T -> [HaXml.Content i] multiFromXmlTree =    Tree.fold@@ -70,7 +70,7 @@ {- * conversion from HaXml tree to our XML tree -}  toXmlTree, toXmlTree' ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    HaXml.Content i -> XmlTree.T i name XmlString.T toXmlTree = XmlTree.mergeStrings . toXmlTree' @@ -98,7 +98,7 @@ {- * lift our XML filters to HaXml filters -}  lift ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    XmlTree.Filter i name XmlString.T -> (HaXml.Content i -> HaXml.Content i) lift f = fromXmlTree . f . toXmlTree @@ -118,7 +118,7 @@         _                -> error "produced wrong output"  liftFilterToDocument ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    FilePath -> XmlTree.Filter Posn name XmlString.T ->       (HaXml.Document Posn -> HaXml.Document Posn) liftFilterToDocument file =@@ -127,6 +127,6 @@   processWith ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    XmlTree.Filter Posn name XmlString.T -> IO () processWith = HaXml.processXmlWith . XmlTree.liftTrans . lift
src/Text/XML/WraXML/Tree/TagSoup.hs view
@@ -72,7 +72,7 @@ -}  toXmlTreesString ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    [Tag] -> [XmlTree name String] toXmlTreesString =    toXmlTreesAux .@@ -83,7 +83,7 @@   toXmlTreesAux ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    [PosTag] -> [XmlTree name String] toXmlTreesAux =    fst . Parser.runParser (ParserU.manyLazy parseBranch)@@ -94,7 +94,7 @@   parseBranch ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    Parser i (XmlTree.T i name String) parseBranch =    do (ti,t) <- Parser.next@@ -119,7 +119,7 @@                       "unexpected end of file") (Name.fromString name))          TagClose name ->             let makeWarning ::-                   (Name.Tag name, Ord name) =>+                   (Name.Tag name) =>                    i -> TagH.Name name -> XmlTree.T i name String                 makeWarning i n =                    XmlTree.warningIndex i $@@ -141,7 +141,7 @@   parseSubTrees ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    XmlTree.T i name String -> TagH.Name name -> Parser i [XmlTree.T i name String] parseSubTrees warn name =    ParserU.force $@@ -156,7 +156,7 @@   parseTerminator ::-   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Name.Tag name, Name.Attribute name) =>    TagH.Name name -> Parser i [XmlTree.T i name String] parseTerminator name =    do c@(ci,ct) <- Parser.next
− src/Text/XML/WraXML/Tree/TagSoupHT.hs 
@@ -1,236 +0,0 @@-{- |-Very lazy HTML tree parser using TagSoup as lexer.--}-module Text.XML.WraXML.Tree.TagSoupHT (-   toXmlTrees,-   fromXmlTree,-   fromElement, fromLeaf,-   liftElementFilter, liftElementCheck,-   example,-   ) where--import qualified Text.HTML.TagSoup.HT.Parser      as TagParser-import qualified Text.HTML.TagSoup.HT.Tag         as Tag-import qualified Text.HTML.TagSoup.HT.PositionTag as PosTag-import qualified Text.HTML.TagSoup.HT.Tag.Match   as MatchTag--import qualified Text.XML.WraXML.Element          as Elem-import qualified Text.XML.WraXML.Tree             as XmlTree-import qualified Data.Tree.BranchLeafLabel        as Tree--import qualified Text.HTML.Basic.Tag as TagH--import qualified Text.XML.Basic.Position    as Position-import qualified Text.XML.Basic.Name.LowerCase as NameLC-import qualified Text.XML.Basic.Name           as Name---- import Control.Monad.Trans.State (evalState, put, get, gets, )-import Control.Monad.Trans.Writer (runWriter, writer, )--import Data.Monoid (Last(Last, getLast), )-import Data.Maybe (fromMaybe, )-import Data.Bool.HT (select, )--import qualified Text.XML.WraXML.Tree.LazyParser as ParserU-import qualified Text.ParserCombinators.PolyLazy as Parser--import Control.Monad (liftM, )----- we don't use XmlTree synonym in the exported functions for documentation purposes-type XmlTree name string = XmlTree.T Position.T name string---{---- FIXME: how to get rid of 'error' ?-fromXmlTree' ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   XmlTree.T Position.T name string -> [PosTag.T name string]-fromXmlTree' =-   flip evalState (error "position not initialised, yet") .-   Tree.fold-      (\pos x -> put pos >> x)-      (\branch subTreesM ->-          do pos <- get-             subTrees <- sequence subTreesM-             lastPos <- get-             -             let elm = XmlTree.getElement branch-                 openTag =-                    PosTag.cons pos $ fromElement elm-                 closeTag =-                    PosTag.cons lastPos $-                    Tag.Close $ Elem.name_ elm-             return $ openTag : concat subTrees ++ [closeTag])--      (\leaf ->-          gets (\pos -> [PosTag.cons pos $ fromLeaf leaf]))-   .-   XmlTree.unwrap--}--fromXmlTree ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   XmlTree.T Position.T name string -> [PosTag.T name string]-fromXmlTree =-   fst . runWriter .-   Tree.foldLabel-      (\pos branch subTreesM ->-          let (subTrees, lastSubPos) = runWriter $ sequence subTreesM-              lastPos = fromMaybe pos $ getLast lastSubPos-              elm = XmlTree.getElement branch-              openTag =-                 PosTag.cons pos $ fromElement elm-              closeTag =-                 PosTag.cons lastPos $-                 Tag.Close $ Elem.name_ elm-          in  writer (openTag : concat subTrees ++ [closeTag],-                      Last $ Just lastPos))-      (\pos leaf ->-          writer $ flip (,) (Last $ Just pos) $-          [PosTag.cons pos $ fromLeaf leaf])-   .-   XmlTree.unwrap--fromElement ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   Elem.T name string -> Tag.T name string-fromElement elm =-   Tag.Open (Elem.name_ elm) (Elem.attributes_ elm)--fromLeaf ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   XmlTree.Leaf name string -> Tag.T name string-fromLeaf leaf =-   case leaf of-      XmlTree.Text  _ text -> Tag.Text text-      XmlTree.Comment text -> Tag.Comment text-      XmlTree.CData   text -> Tag.Special TagH.cdata text-      XmlTree.PI      name instr -> Tag.Processing name instr-      XmlTree.Warning text -> Tag.Warning text---liftElementFilter ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   (Elem.T name str -> Elem.T name str) ->-   Tag.T name str -> Tag.T name str-liftElementFilter f tag =-   flip (maybe tag) (Tag.maybeOpen tag) $-   fromElement . f . uncurry Elem.Cons--liftElementCheck :: (Elem.T name string -> Bool) -> (Tag.T name string -> Bool)-liftElementCheck f tag =-   flip (maybe False) (Tag.maybeOpen tag) $-   f . uncurry Elem.Cons----{- |-A TagSoup could represent multiple HTML trees,-e.g. with some introducing comments.--}-toXmlTrees ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   [PosTag.T name string] -> [XmlTree.T Position.T name string]-toXmlTrees =-   fst . Parser.runParser (ParserU.manyLazy parseBranch)---type Parser name string a = Parser.Parser (PosTag.T name string) a---parseBranch ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   Parser name string (XmlTree name string)-parseBranch =-   do nt <- Parser.next-      let ti = PosTag.position_ nt-      case PosTag.tag_ nt of-         Tag.Text text -> return (XmlTree.literalIndex ti text)-         Tag.Open name attrs ->-            liftM-               (XmlTree.tagIndexAttr ti name attrs)-               (parseSubTrees-                  (XmlTree.warningIndex ti-                      "unexpected end of file") name)-         Tag.Close name ->-            return $ XmlTree.warningIndex ti $-            if TagH.isSloppy name-              then "misplaced sloppy closing tag </" ++ Name.toString name ++ ">"-              else "isolated closing tag </" ++ Name.toString name ++ ">"-         Tag.Comment cmt ->-            return (XmlTree.commentIndex ti cmt)-         Tag.Warning msg ->-            return (XmlTree.warningIndex ti msg)-         Tag.Processing target p ->-            return (XmlTree.processingIndex ti target p)-         Tag.Special name str ->-            return $-            if Name.match TagH.cdataString name-              then XmlTree.cdataIndex ti str-              else XmlTree.warningIndex ti $-                      "Special tag " ++ Name.toString name ++-                      " not allowed within a HTML document"---parseSubTrees ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   XmlTree name string -> TagH.Name name ->-   Parser name string [XmlTree name string]-parseSubTrees warn name =-   ParserU.force $-   if TagH.isEmpty name-     then-       (Parser.satisfy (MatchTag.close (name==) . PosTag.tag_) >> return [])-         `Parser.onFail` return []-     else-       ParserU.manyFinallyAppend-          (parseTerminator name)-          warn parseBranch---parseTerminator ::-   (Name.Tag name, Name.Attribute name, Ord name) =>-   TagH.Name name -> Parser name string [XmlTree name string]-parseTerminator name =-   do c <- Parser.next-      let ci = PosTag.position_ c-          retry warns = Parser.reparse [c] >> return warns-      case PosTag.tag_ c of-         Tag.Close closeName ->-            flip select-               ((TagH.isEmpty closeName,-                    fail $ "the tag <" ++ Name.toString closeName ++ "> closes nothing.") :-                (name `TagH.isInnerOf` closeName, retry []) :-                (name==closeName, return []) :-                (TagH.isSloppy name,-                 retry [XmlTree.warningIndex ci $-                           "sloppy tag <"-                           ++ Name.toString name ++ "> closed by </"-                           ++ Name.toString closeName ++ ">"]) :-                (TagH.isSloppy closeName,-                 fail $ "ignore sloppy closing tag </" ++ Name.toString name ++ ">") :-                [])-               (return [XmlTree.warningIndex ci $-                            "open tag <" ++ Name.toString name ++-                            "> and close tag </" ++ Name.toString closeName ++-                            "> do not match"])-         Tag.Open openName _ ->-            if openName `TagH.closes` name-              then retry []-              else fail $-                      "open tag <" ++ Name.toString openName ++-                      "> does not close tag <" ++ Name.toString name ++ ">"-         _ -> fail $ "not a termination of a tag"---example ::-   [XmlTree NameLC.T String]-example =-   toXmlTrees $-   TagParser.runSoupWithPositions $---   "<html><head>blub<meta/></head><br><body>bla</body></html>"---   "<html><head>blub<meta/></head><br><body>bla<UL><li>1.<li>2.</OL><TABLE border=1></TABLE></body></html>"---   "<html><head><meta>too much</meta>blub<meta/></head><br><body>bla<UL><li>1.<li>2.</UL><TABLE border=1></TABLE></bo"++undefined++"dy></html>"---    "<b><font>test</b></font>"-    "<html><b><font>test</b></font></html>"
+ src/Text/XML/WraXML/Tree/Tagchup.hs view
@@ -0,0 +1,236 @@+{- |+Very lazy HTML tree parser using TagSoup as lexer.+-}+module Text.XML.WraXML.Tree.Tagchup (+   toXmlTrees,+   fromXmlTree,+   fromElement, fromLeaf,+   liftElementFilter, liftElementCheck,+   example,+   ) where++import qualified Text.HTML.Tagchup.Parser      as TagParser+import qualified Text.HTML.Tagchup.Tag         as Tag+import qualified Text.HTML.Tagchup.PositionTag as PosTag+import qualified Text.HTML.Tagchup.Tag.Match   as MatchTag++import qualified Text.XML.WraXML.Element          as Elem+import qualified Text.XML.WraXML.Tree             as XmlTree+import qualified Data.Tree.BranchLeafLabel        as Tree++import qualified Text.HTML.Basic.Tag as TagH++import qualified Text.XML.Basic.Position    as Position+import qualified Text.XML.Basic.Name.LowerCase as NameLC+import qualified Text.XML.Basic.Name           as Name++-- import Control.Monad.Trans.State (evalState, put, get, gets, )+import Control.Monad.Trans.Writer (runWriter, writer, )++import Data.Monoid (Last(Last, getLast), )+import Data.Maybe (fromMaybe, )+import Data.Bool.HT (select, )++import qualified Text.XML.WraXML.Tree.LazyParser as ParserU+import qualified Text.ParserCombinators.PolyLazy as Parser++import Control.Monad (liftM, )+++-- we don't use XmlTree synonym in the exported functions for documentation purposes+type XmlTree name string = XmlTree.T Position.T name string+++{-+-- FIXME: how to get rid of 'error' ?+fromXmlTree' ::+   (Name.Tag name, Name.Attribute name) =>+   XmlTree.T Position.T name string -> [PosTag.T name string]+fromXmlTree' =+   flip evalState (error "position not initialised, yet") .+   Tree.fold+      (\pos x -> put pos >> x)+      (\branch subTreesM ->+          do pos <- get+             subTrees <- sequence subTreesM+             lastPos <- get+             +             let elm = XmlTree.getElement branch+                 openTag =+                    PosTag.cons pos $ fromElement elm+                 closeTag =+                    PosTag.cons lastPos $+                    Tag.Close $ Elem.name_ elm+             return $ openTag : concat subTrees ++ [closeTag])++      (\leaf ->+          gets (\pos -> [PosTag.cons pos $ fromLeaf leaf]))+   .+   XmlTree.unwrap+-}++fromXmlTree ::+   (Name.Tag name, Name.Attribute name) =>+   XmlTree.T Position.T name string -> [PosTag.T name string]+fromXmlTree =+   fst . runWriter .+   Tree.foldLabel+      (\pos branch subTreesM ->+          let (subTrees, lastSubPos) = runWriter $ sequence subTreesM+              lastPos = fromMaybe pos $ getLast lastSubPos+              elm = XmlTree.getElement branch+              openTag =+                 PosTag.cons pos $ fromElement elm+              closeTag =+                 PosTag.cons lastPos $+                 Tag.Close $ Elem.name_ elm+          in  writer (openTag : concat subTrees ++ [closeTag],+                      Last $ Just lastPos))+      (\pos leaf ->+          writer $ flip (,) (Last $ Just pos) $+          [PosTag.cons pos $ fromLeaf leaf])+   .+   XmlTree.unwrap++fromElement ::+   (Name.Tag name, Name.Attribute name) =>+   Elem.T name string -> Tag.T name string+fromElement elm =+   Tag.Open (Elem.name_ elm) (Elem.attributes_ elm)++fromLeaf ::+   (Name.Tag name, Name.Attribute name) =>+   XmlTree.Leaf name string -> Tag.T name string+fromLeaf leaf =+   case leaf of+      XmlTree.Text  _ text -> Tag.Text text+      XmlTree.Comment text -> Tag.Comment text+      XmlTree.CData   text -> Tag.Special TagH.cdata text+      XmlTree.PI      name instr -> Tag.Processing name instr+      XmlTree.Warning text -> Tag.Warning text+++liftElementFilter ::+   (Name.Tag name, Name.Attribute name) =>+   (Elem.T name str -> Elem.T name str) ->+   Tag.T name str -> Tag.T name str+liftElementFilter f tag =+   flip (maybe tag) (Tag.maybeOpen tag) $+   fromElement . f . uncurry Elem.Cons++liftElementCheck :: (Elem.T name string -> Bool) -> (Tag.T name string -> Bool)+liftElementCheck f tag =+   flip (maybe False) (Tag.maybeOpen tag) $+   f . uncurry Elem.Cons++++{- |+A TagSoup could represent multiple HTML trees,+e.g. with some introducing comments.+-}+toXmlTrees ::+   (Name.Tag name, Name.Attribute name) =>+   [PosTag.T name string] -> [XmlTree.T Position.T name string]+toXmlTrees =+   fst . Parser.runParser (ParserU.manyLazy parseBranch)+++type Parser name string a = Parser.Parser (PosTag.T name string) a+++parseBranch ::+   (Name.Tag name, Name.Attribute name) =>+   Parser name string (XmlTree name string)+parseBranch =+   do nt <- Parser.next+      let ti = PosTag.position_ nt+      case PosTag.tag_ nt of+         Tag.Text text -> return (XmlTree.literalIndex ti text)+         Tag.Open name attrs ->+            liftM+               (XmlTree.tagIndexAttr ti name attrs)+               (parseSubTrees+                  (XmlTree.warningIndex ti+                      "unexpected end of file") name)+         Tag.Close name ->+            return $ XmlTree.warningIndex ti $+            if TagH.isSloppy name+              then "misplaced sloppy closing tag </" ++ Name.toString name ++ ">"+              else "isolated closing tag </" ++ Name.toString name ++ ">"+         Tag.Comment cmt ->+            return (XmlTree.commentIndex ti cmt)+         Tag.Warning msg ->+            return (XmlTree.warningIndex ti msg)+         Tag.Processing target p ->+            return (XmlTree.processingIndex ti target p)+         Tag.Special name str ->+            return $+            if Name.match TagH.cdataString name+              then XmlTree.cdataIndex ti str+              else XmlTree.warningIndex ti $+                      "Special tag " ++ Name.toString name +++                      " not allowed within a HTML document"+++parseSubTrees ::+   (Name.Tag name, Name.Attribute name) =>+   XmlTree name string -> TagH.Name name ->+   Parser name string [XmlTree name string]+parseSubTrees warn name =+   ParserU.force $+   if TagH.isEmpty name+     then+       (Parser.satisfy (MatchTag.close (name==) . PosTag.tag_) >> return [])+         `Parser.onFail` return []+     else+       ParserU.manyFinallyAppend+          (parseTerminator name)+          warn parseBranch+++parseTerminator ::+   (Name.Tag name, Name.Attribute name) =>+   TagH.Name name -> Parser name string [XmlTree name string]+parseTerminator name =+   do c <- Parser.next+      let ci = PosTag.position_ c+          retry warns = Parser.reparse [c] >> return warns+      case PosTag.tag_ c of+         Tag.Close closeName ->+            flip select+               ((TagH.isEmpty closeName,+                    fail $ "the tag <" ++ Name.toString closeName ++ "> closes nothing.") :+                (name `TagH.isInnerOf` closeName, retry []) :+                (name==closeName, return []) :+                (TagH.isSloppy name,+                 retry [XmlTree.warningIndex ci $+                           "sloppy tag <"+                           ++ Name.toString name ++ "> closed by </"+                           ++ Name.toString closeName ++ ">"]) :+                (TagH.isSloppy closeName,+                 fail $ "ignore sloppy closing tag </" ++ Name.toString name ++ ">") :+                [])+               (return [XmlTree.warningIndex ci $+                            "open tag <" ++ Name.toString name +++                            "> and close tag </" ++ Name.toString closeName +++                            "> do not match"])+         Tag.Open openName _ ->+            if openName `TagH.closes` name+              then retry []+              else fail $+                      "open tag <" ++ Name.toString openName +++                      "> does not close tag <" ++ Name.toString name ++ ">"+         _ -> fail $ "not a termination of a tag"+++example ::+   [XmlTree NameLC.T String]+example =+   toXmlTrees $+   TagParser.runSoupWithPositions $+--   "<html><head>blub<meta/></head><br><body>bla</body></html>"+--   "<html><head>blub<meta/></head><br><body>bla<UL><li>1.<li>2.</OL><TABLE border=1></TABLE></body></html>"+--   "<html><head><meta>too much</meta>blub<meta/></head><br><body>bla<UL><li>1.<li>2.</UL><TABLE border=1></TABLE></bo"++undefined++"dy></html>"+--    "<b><font>test</b></font>"+    "<html><b><font>test</b></font></html>"
wraxml.cabal view
@@ -1,5 +1,5 @@ Name:           wraxml-Version:        0.3+Version:        0.4 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -9,8 +9,8 @@ Build-Depends:   polyparse >=1.1,   tagsoup >=0.6 && <0.7,-  tagsoup-ht >=0.3 && <0.4,-  xml-basic >=0.0.1 && <0.1,+  tagchup >=0.3 && <0.4,+  xml-basic >=0.1 && <0.2,   HaXml >=1.19.4, hxt >=8.1.0 && <9,   hxt-filter >=8.1.1 && <9,   transformers >=0.1 && <0.2,@@ -63,6 +63,7 @@   Text.HTML.WraXML.Document   Text.HTML.WraXML.Table   Text.HTML.WraXML.Tree+  Text.HTML.WraXML.Tree.HXT   Text.HTML.WraXML.String   Text.HTML.WraXML.Entity   Text.XML.WraXML.Position.HaXml@@ -74,11 +75,11 @@   Text.XML.WraXML.Tree.HaXml   Text.XML.WraXML.Tree.HXT   Text.XML.WraXML.Tree.TagSoup-  Text.XML.WraXML.Tree.TagSoupHT+  Text.XML.WraXML.Tree.Tagchup   Text.XML.WraXML.Tree.Literal   Text.XML.WraXML.Document   Text.XML.WraXML.Document.TagSoup-  Text.XML.WraXML.Document.TagSoupHT+  Text.XML.WraXML.Document.Tagchup Other-Modules:   Text.XML.WraXML.Utility   Text.XML.WraXML.Tree.LazyParser