module Text.HTML.WraXML.Tree where
import qualified Data.Tree.BranchLeafLabel as Tree
import qualified Text.XML.WraXML.Tree as XmlTree
import qualified Text.XML.WraXML.String as XmlString
import qualified Data.Char as Char
import qualified Text.XML.Basic.Tag as TagX
import qualified Text.HTML.Basic.Tag as Tag
import qualified Text.HTML.Basic.Character as HtmlChar
import qualified Text.HTML.Basic.String as HtmlStringB
import qualified Text.HTML.WraXML.Element as Elem
import qualified Text.XML.Basic.Attribute as Attr
import qualified Text.XML.Basic.Name as Name
import Text.XML.WraXML.Tree (formatLeaf, )
import qualified Text.XML.Basic.Format as Format
import Control.Monad.Trans.State (State, put, get, )
import Control.Applicative (liftA, liftA2, )
import Data.List.HT (takeWhileRev, )
import Data.Tuple.HT (mapFst, )
import Control.Monad (liftM2, )
import Data.Maybe (mapMaybe, fromMaybe, )
findMetaEncoding ::
(Name.Tag name, Name.Attribute name) =>
XmlTree.T i name String -> Maybe String
findMetaEncoding =
fmap (map Char.toLower . takeWhileRev ('='/=)) .
lookup "content-type" .
map (mapFst (map Char.toLower)) .
getMetaHTTPHeaders
getMetaHTTPHeaders ::
(Name.Tag name, Name.Attribute name) =>
XmlTree.T i name String -> [(String, String)]
getMetaHTTPHeaders =
mapMaybe (\attrs ->
liftM2 (,)
(Attr.lookupLit "http-equiv" attrs)
(Attr.lookupLit "content" attrs)) .
map Elem.attributes_ .
filter (Elem.checkName (Name.match "meta")) .
map fst .
mapMaybe XmlTree.maybeTag .
concatMap snd .
XmlTree.filterTagsFlatten (Elem.checkName (Name.match "head"))
decodeAdaptive ::
(Name.Attribute name, Name.Tag name) =>
(XmlString.Encoding -> XmlString.Encoded -> String) ->
XmlTree.T i name [HtmlChar.T] ->
State (XmlString.Encoded -> String) (XmlTree.T i name String)
decodeAdaptive getDecoder =
XmlTree.fold
(liftA . XmlTree.wrap2)
(\elm subTrees ->
liftA2 (Tree.Branch . XmlTree.Tag)
(Elem.decodeAdaptive getDecoder elm)
(fmap (map XmlTree.unwrap) $ sequence subTrees))
(liftA Tree.Leaf .
decodeLeafAdaptive getDecoder)
decodeLeafAdaptive ::
(Name.Attribute name, Name.Tag name) =>
(XmlString.Encoding -> XmlString.Encoded -> String) ->
XmlTree.Leaf name [HtmlChar.T] ->
State (XmlString.Encoded -> String) (XmlTree.Leaf name String)
decodeLeafAdaptive getDecoder leaf0 =
do decoder <- get
let leaf1 =
maybe
(fmap (HtmlStringB.decode decoder) leaf0)
(XmlTree.CData . decoder)
(XmlTree.maybeCDataLeaf leaf0)
maybe
(return ())
(put . getDecoder) $
uncurry TagX.maybeXMLEncoding =<<
XmlTree.maybeProcessingLeaf leaf1
return leaf1
{-# DEPRECATED decodeSpecialCharsMetaEncoding "This calls findMetaEncoding which is a potential space leak. Better use decodeAdaptive." #-}
decodeSpecialCharsMetaEncoding ::
(Name.Tag name, Name.Attribute name) =>
XmlTree.T i name XmlString.T -> [XmlTree.T i name String]
decodeSpecialCharsMetaEncoding tree =
let unicodeTree = XmlTree.unescape tree
in fromMaybe
[unicodeTree]
(flip XmlTree.maybeDecodeSpecialChars tree
=<< findMetaEncoding unicodeTree)
formatMany ::
(Name.Tag name, Name.Attribute name, Format.C string) =>
[XmlTree.T i name string] -> ShowS
formatMany = Format.many format
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
formatBranch ::
(Name.Tag name, Name.Attribute name, Format.C string) =>
XmlTree.Branch name string -> [ShowS] -> ShowS
formatBranch = formatBranchGen False
formatManyXHTML ::
(Name.Tag name, Name.Attribute name, Format.C string) =>
[XmlTree.T i name string] -> ShowS
formatManyXHTML = Format.many formatXHTML
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
formatBranchXHTML ::
(Name.Tag name, Name.Attribute name, Format.C string) =>
XmlTree.Branch name string -> [ShowS] -> ShowS
formatBranchXHTML = formatBranchGen True
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 formatSubTrees && Tag.isEmpty tagName)
(if xhtml then Format.slash else id)
elm formatSubTrees