Tree.hs

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.HTML.Basic.Tag as Tag
import qualified Text.XML.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 (showLeaf, )
import qualified Text.XML.Basic.Format as ShowXML

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) =>
   XmlTree.T i name String -> Maybe String
findMetaEncoding =
   fmap (map Char.toLower . takeWhileRev ('='/=)) .
   lookup "content-type" .
   map (mapFst (map Char.toLower)) .
   getMetaHTTPHeaders

{- |
Extract META tags which contain HTTP-EQUIV attribute
and present these values like HTTP headers.
-}
getMetaHTTPHeaders ::
   (Name.Tag name, Name.Attribute name, Eq 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"))


{-# DEPRECATED decodeSpecialCharsMetaEncoding "XMLChar.Unicode constructors must contain unicode characters and not encoded ones. Decode characters before parsing!" #-}

{- |
Convert special characters of XmlString into Unicode
according to the encoding given in a META HTTP-EQUIV tag.
-}
decodeSpecialCharsMetaEncoding ::
   (Name.Tag name, Name.Attribute name, Eq 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)



{- * Formatting -}


show ::
   (Name.Tag name, Name.Attribute name, Ord 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

-- 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 .
   XmlTree.unwrap

showBranch ::
   (Name.Tag name, Name.Attribute name, Ord name) =>
   XmlTree.Branch name XmlString.T -> [ShowS] -> ShowS
showBranch = showBranchGen False


showsManyXHTML ::
   (Name.Tag name, Name.Attribute name, Ord name) =>
   [XmlTree.T i name XmlString.T] -> ShowS
showsManyXHTML = ShowXML.many showsXHTML

-- 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 .
   XmlTree.unwrap

showBranchXHTML ::
   (Name.Tag name, Name.Attribute name, Ord name) =>
   XmlTree.Branch name XmlString.T -> [ShowS] -> ShowS
showBranchXHTML = showBranchGen True


{- |
@not xhtml@: show @<br>@
@xhtml@: show @<br/>@
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 =
   case branch of
      XmlTree.Tag elm ->
         Elem.format
            (\tagName -> null showSubTrees && Tag.isEmpty tagName)
            (if xhtml then ShowXML.slash else id)
            elm showSubTrees