wraxml-0.4.3.1: src/Text/HTML/WraXML/Tree/HXT.hs
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 Control.Monad (msum, )
import Data.Maybe (fromMaybe, )
{- |
Tidy a piece of HTML code.
& -> &
< -> <
unquoted tag attribute values: size=-1 -> size="-1"
insert omitted closing tags
-}
tidy :: String -> IO String
tidy input =
-- escapeXmlDoc replaces < by < 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
-}