wraxml-0.3: src/Text/XML/WraXML/Tree/HXT.hs
module Text.XML.WraXML.Tree.HXT
(fromXmlTree, toXmlTree, lift, liftFilterToDocument,
tidyHTML, showHTML, 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 Text.XML.WraXML.Tree
(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
import qualified Text.XML.WraXML.String as XmlString
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.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) =>
XmlTree.T i name XmlString.T -> HXT.XmlTree
fromXmlTree x =
case multiFromXmlTree x of
[y] -> y
_ -> error "top branch can't be a string"
mkHXTName :: (Name.C name) => name -> QName
mkHXTName = HXT.mkName . Name.toString
mkHXTAttrs :: (Name.Attribute name) =>
[Attr.T name XmlString.T] -> [NTree XNode]
mkHXTAttrs =
map (\a ->
HXTTree.mkTree
(HXT.XAttr (mkHXTName $ Attr.name_ a))
(HXTString.fromXmlString $ Attr.value_ a))
multiFromXmlTree ::
(Name.Tag name, Name.Attribute name, Ord name) =>
XmlTree.T i name XmlString.T -> [HXT.XmlTree]
multiFromXmlTree =
Tree.fold
(\i f -> f i)
(\x subs _ ->
case x of
Tag (Elem.Cons name attrs) ->
[HXTTree.mkTree
(HXT.XTag (mkHXTName name) (mkHXTAttrs attrs))
(concat subs)])
(\x _ ->
case x of
Text _ {- whitespace -} str -> HXTString.fromXmlString str
Comment str ->
[HXTTree.mkTree (HXT.XCmt str) []]
CData str ->
[HXTTree.mkTree (HXT.XCdata str) []]
PI target proc ->
let (attrTree,subTrees) =
case proc of
PI.Known attrs -> (mkHXTAttrs attrs, [])
PI.Unknown str -> ([], [HXTTree.mkTree (HXT.XText str) []])
in [HXTTree.mkTree
(HXT.XPi (mkHXTName target) attrTree)
subTrees]
Warning str ->
[HXTTree.mkTree (HXT.XError 0 str) []])
. XmlTree.unwrap
{- * conversion from HXT tree to our XML tree -}
toXmlTree, toXmlTree' ::
(Name.Tag name, Name.Attribute name, Ord name) =>
HXT.XmlTree -> XmlTree.T () name XmlString.T
toXmlTree = XmlTree.mergeStrings . toXmlTree'
toXmlTree' (HXTTree.NTree label subTrees) = XmlTree.wrap $ (,) () $
let leaf x =
if null subTrees
then Tree.Leaf x
else error "HXT to WraXML: Leaf must not contain sub trees."
fromHXTName = Name.fromString . HXT.qualifiedName
convAttr (HXTTree.NTree x value) =
case x of
HXT.XAttr name ->
Attr.new (HXT.qualifiedName name) (HXTString.toXmlString value)
_ -> error "HXT.XAttr expected"
in case label of
HXT.XTag name attrs ->
Tree.Branch
(Tag (Elem.Cons
(fromHXTName name)
(map convAttr attrs)))
(map (XmlTree.unwrap . toXmlTree') subTrees)
HXT.XText str ->
leaf (Text True (XmlString.fromString str))
HXT.XCharRef ref ->
leaf (Text False [XMLChar.fromCharRef ref])
HXT.XEntityRef ref ->
leaf (Text False [XMLChar.fromEntityRef ref])
HXT.XCmt cmt ->
leaf (Comment cmt)
HXT.XPi target proc ->
Tree.Leaf $ PI (fromHXTName target) $
case subTrees of
[] -> PI.Known $ map convAttr proc
[HXTTree.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"
HXT.XDTD _ _ -> error "from HXT: document type descriptor not allowed in normal text"
HXT.XCdata x -> leaf (CData x)
HXT.XError lev x -> leaf (Warning ("Level: " ++ show lev ++ ": " ++ x))
{- * lift our XML filters to HXT filters -}
lift ::
(Name.Tag name, Name.Attribute name, Ord name) =>
XmlTree.Filter () name XmlString.T -> (HXT.XmlTree -> HXT.XmlTree)
lift f = fromXmlTree . f . toXmlTree
{- |
Lift our XML filters to HXT document processors.
-}
liftFilterToDocument ::
(Name.Tag name, Name.Attribute name, Ord 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
if it is missing or occurs more than once. -}
-> XmlTree.Filter () name XmlString.T
-> (HXT.XmlTree -> HXT.XmlTree)
liftFilterToDocument tagName f =
HXTTree.changeChildren $ \subTrees ->
let (pre,x:post) =
break (checkTagName tagName . HXTTree.getNode) subTrees
in pre ++ lift f x : post
checkTagName :: String -> HXT.XNode -> Bool
checkTagName tagName tree =
case tree of
(HXT.XTag name _) -> HXT.qualifiedName name == tagName
_ -> False
{-
The HTML parser of the Haskell XML toolbox HXT
is great in parsing lousy HTML.
However its API is extremely weakly typed.
Everything is a monadic function, even simple XML trees.
This design was done in order to reduce the combinators essentially to .>>
That's why I decided to use HXT as a parser and pretty printer,
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.
& -> &
< -> <
unquoted tag attribute values: size=-1 -> size="-1"
insert omitted closing tags
-}
tidyHTML :: String -> IO String
tidyHTML input =
-- escapeXmlDoc replaces < by < 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
-}