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 qualified Data.List.Reverse.StrictElement as Rev
import           Data.Tuple.HT (mapFst, )
import           Control.Monad (liftM2, )
import           Data.Maybe (mapMaybe, fromMaybe, )



{- * Character decoding -}

findMetaEncoding ::
   (Name.Tag name, Name.Attribute name) =>
   XmlTree.T i name String -> Maybe String
findMetaEncoding :: forall name i.
(Tag name, Attribute name) =>
T i name String -> Maybe String
findMetaEncoding =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
Rev.takeWhile (Char
'='forall a. Eq a => a -> a -> Bool
/=)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"content-type" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall name i.
(Tag name, Attribute name) =>
T i name String -> [(String, String)]
getMetaHTTPHeaders

{- |
Extract META tags which contain HTTP-EQUIV attribute
and present these values like HTTP headers.
-}
getMetaHTTPHeaders ::
   (Name.Tag name, Name.Attribute name) =>
   XmlTree.T i name String -> [(String, String)]
getMetaHTTPHeaders :: forall name i.
(Tag name, Attribute name) =>
T i name String -> [(String, String)]
getMetaHTTPHeaders =
   forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\[T name String]
attrs ->
      forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)
         (forall name string.
Attribute name =>
String -> [T name string] -> Maybe string
Attr.lookupLit String
"http-equiv" [T name String]
attrs)
         (forall name string.
Attribute name =>
String -> [T name string] -> Maybe string
Attr.lookupLit String
"content" [T name String]
attrs)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a b. (a -> b) -> [a] -> [b]
map forall name str. T name str -> [T name str]
Elem.attributes_ forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a. (a -> Bool) -> [a] -> [a]
filter (forall name str. (Name name -> Bool) -> T name str -> Bool
Elem.checkName (forall name. C name => String -> name -> Bool
Name.match String
"meta")) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall i name str.
T i name str -> Maybe (T name str, [T i name str])
XmlTree.maybeTag forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall name str i.
(T name str -> Bool)
-> T i name str -> [(T name str, [T i name str])]
XmlTree.filterTagsFlatten (forall name str. (Name name -> Bool) -> T name str -> Bool
Elem.checkName (forall name. C name => String -> name -> Bool
Name.match String
"head"))


{- |
Decode strings in a HTML tree.
Switch decoding on every occurence of a content-type meta-tag.
This must operate on @HtmlString@s, that is before reference resolution,
since after reference resolution
Unicode characters may clash with encoded characters.
-}
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 :: forall name i.
(Attribute name, Tag name) =>
(String -> String -> String)
-> T i name [T] -> State (String -> String) (T i name String)
decodeAdaptive String -> String -> String
getDecoder =
   forall i a b name str.
(i -> a -> b)
-> (T name str -> [b] -> a)
-> (Leaf name str -> a)
-> T i name str
-> b
XmlTree.fold
      (forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i name str.
i -> Elem i (Branch name str) (Leaf name str) -> T i name str
XmlTree.wrap2)
      (\T name [T]
elm [State (String -> String) (T i name String)]
subTrees ->
         forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (forall i branch leaf.
branch -> [T i branch leaf] -> Elem i branch leaf
Tree.Branch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name str. T name str -> Branch name str
XmlTree.Tag)
            (forall name.
(Attribute name, Tag name) =>
(String -> String -> String)
-> T name [T] -> State (String -> String) (T name String)
Elem.decodeAdaptive String -> String -> String
getDecoder T name [T]
elm)
            (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall i name str.
T i name str -> T i (Branch name str) (Leaf name str)
XmlTree.unwrap) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [State (String -> String) (T i name String)]
subTrees))
      (forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA forall i branch leaf. leaf -> Elem i branch leaf
Tree.Leaf forall b c a. (b -> c) -> (a -> b) -> a -> c
.
       forall name.
(Attribute name, Tag name) =>
(String -> String -> String)
-> Leaf name [T] -> State (String -> String) (Leaf name String)
decodeLeafAdaptive String -> String -> String
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 :: forall name.
(Attribute name, Tag name) =>
(String -> String -> String)
-> Leaf name [T] -> State (String -> String) (Leaf name String)
decodeLeafAdaptive String -> String -> String
getDecoder Leaf name [T]
leaf0 =
   do String -> String
decoder <- forall (m :: * -> *) s. Monad m => StateT s m s
get
      let leaf1 :: Leaf name String
leaf1 =
             forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> String) -> [T] -> String
HtmlStringB.decode String -> String
decoder) Leaf name [T]
leaf0)
                (forall name str. String -> Leaf name str
XmlTree.CData forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
decoder)
                (forall name str. Leaf name str -> Maybe String
XmlTree.maybeCDataLeaf Leaf name [T]
leaf0)
      -- this should not happen in correct XML file
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe
         (forall (m :: * -> *) a. Monad m => a -> m a
return ())
         (forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
getDecoder) forall a b. (a -> b) -> a -> b
$
         forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall name string.
(Tag name, Attribute name) =>
Name name -> T name string -> Maybe string
TagX.maybeXMLEncoding forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
         forall name str. Leaf name str -> Maybe (Name name, T name str)
XmlTree.maybeProcessingLeaf Leaf name String
leaf1
      forall (m :: * -> *) a. Monad m => a -> m a
return Leaf name String
leaf1


{-# DEPRECATED decodeSpecialCharsMetaEncoding "This calls findMetaEncoding which is a potential space leak. Better use decodeAdaptive." #-}

{- |
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) =>
   XmlTree.T i name XmlString.T -> [XmlTree.T i name String]
decodeSpecialCharsMetaEncoding :: forall name i.
(Tag name, Attribute name) =>
T i name [T] -> [T i name String]
decodeSpecialCharsMetaEncoding T i name [T]
tree =
   let unicodeTree :: T i name String
unicodeTree = forall i name. T i name [T] -> T i name String
XmlTree.unescape T i name [T]
tree
   in  forall a. a -> Maybe a -> a
fromMaybe
          [T i name String
unicodeTree]
          (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall name i.
(Tag name, Attribute name) =>
String -> T i name [T] -> Maybe [T i name String]
XmlTree.maybeDecodeSpecialChars T i name [T]
tree
               forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall name i.
(Tag name, Attribute name) =>
T i name String -> Maybe String
findMetaEncoding T i name String
unicodeTree)



{- * Formatting -}


{-
show ::
   (Name.Tag name, Name.Attribute name) =>
   XmlTree.T i name XmlString.T -> String
show leaf = shows leaf ""
-}

formatMany ::
   (Name.Tag name, Name.Attribute name, Format.C string) =>
   [XmlTree.T i name string] -> ShowS
formatMany :: forall name string i.
(Tag name, Attribute name, C string) =>
[T i name string] -> String -> String
formatMany = forall a. (a -> String -> String) -> [a] -> String -> String
Format.many forall name string i.
(Tag name, Attribute name, C string) =>
T i name string -> String -> String
format

-- 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 :: forall name string i.
(Tag name, Attribute name, C string) =>
T i name string -> String -> String
format =
   forall i a b branch leaf.
(i -> a -> b)
-> (branch -> [b] -> a) -> (leaf -> a) -> T i branch leaf -> b
Tree.fold (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. a -> b -> a
const) forall name string.
(Tag name, Attribute name, C string) =>
Branch name string -> [String -> String] -> String -> String
formatBranch forall name string.
(Tag name, Attribute name, C string) =>
Leaf name string -> String -> String
formatLeaf forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall i name str.
T i name str -> T i (Branch name str) (Leaf name str)
XmlTree.unwrap

formatBranch ::
   (Name.Tag name, Name.Attribute name, Format.C string) =>
   XmlTree.Branch name string -> [ShowS] -> ShowS
formatBranch :: forall name string.
(Tag name, Attribute name, C string) =>
Branch name string -> [String -> String] -> String -> String
formatBranch = forall name string.
(Tag name, Attribute name, C string) =>
Bool
-> Branch name string -> [String -> String] -> String -> String
formatBranchGen Bool
False


formatManyXHTML ::
   (Name.Tag name, Name.Attribute name, Format.C string) =>
   [XmlTree.T i name string] -> ShowS
formatManyXHTML :: forall name string i.
(Tag name, Attribute name, C string) =>
[T i name string] -> String -> String
formatManyXHTML = forall a. (a -> String -> String) -> [a] -> String -> String
Format.many forall name string i.
(Tag name, Attribute name, C string) =>
T i name string -> String -> String
formatXHTML

-- cf. src/Text/XML/HXT/DOM/XmlTreeFunctions.hs
formatXHTML ::
   (Name.Tag name, Name.Attribute name, Format.C string) =>
   XmlTree.T i name string -> ShowS
formatXHTML :: forall name string i.
(Tag name, Attribute name, C string) =>
T i name string -> String -> String
formatXHTML =
   forall i a b branch leaf.
(i -> a -> b)
-> (branch -> [b] -> a) -> (leaf -> a) -> T i branch leaf -> b
Tree.fold (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. a -> b -> a
const) forall name string.
(Tag name, Attribute name, C string) =>
Branch name string -> [String -> String] -> String -> String
formatBranchXHTML forall name string.
(Tag name, Attribute name, C string) =>
Leaf name string -> String -> String
formatLeaf forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall i name str.
T i name str -> T i (Branch name str) (Leaf name str)
XmlTree.unwrap

formatBranchXHTML ::
   (Name.Tag name, Name.Attribute name, Format.C string) =>
   XmlTree.Branch name string -> [ShowS] -> ShowS
formatBranchXHTML :: forall name string.
(Tag name, Attribute name, C string) =>
Branch name string -> [String -> String] -> String -> String
formatBranchXHTML = forall name string.
(Tag name, Attribute name, C string) =>
Bool
-> Branch name string -> [String -> String] -> String -> String
formatBranchGen Bool
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>@.
-}
formatBranchGen ::
   (Name.Tag name, Name.Attribute name, Format.C string) =>
   Bool -> XmlTree.Branch name string -> [ShowS] -> ShowS
formatBranchGen :: forall name string.
(Tag name, Attribute name, C string) =>
Bool
-> Branch name string -> [String -> String] -> String -> String
formatBranchGen Bool
xhtml Branch name string
branch [String -> String]
formatSubTrees =
   case Branch name string
branch of
      XmlTree.Tag T name string
elm ->
         forall name string.
(Tag name, Attribute name, C string) =>
(Name name -> Bool)
-> (String -> String)
-> T name string
-> [String -> String]
-> String
-> String
Elem.format
            (\Name name
tagName -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String -> String]
formatSubTrees Bool -> Bool -> Bool
&& forall name. Tag name => Name name -> Bool
Tag.isEmpty Name name
tagName)
            (if Bool
xhtml then String -> String
Format.slash else forall a. a -> a
id)
            T name string
elm [String -> String]
formatSubTrees