module Text.XML.WraXML.Tree.HXT
   (fromXmlTree, toXmlTree, lift, liftFilterToDocument,
    checkTagName, ) where

import qualified Text.XML.HXT.DOM.TypeDefs as HXT
import qualified Data.Tree.Class 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.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 as Name
import qualified Text.XML.Basic.ProcessingInstruction as PI

import qualified Text.XML.Basic.Character as XmlChar

-- needed for code copies from HXT at the of the file
import Text.XML.HXT.DOM.QualifiedName (QName)
import Text.XML.HXT.DOM.TypeDefs (XNode)
import Data.Tree.NTree.TypeDefs (NTree(NTree))


{- * conversion from our XML tree to HXT tree -}

fromXmlTree ::
   (Name.Tag name, Name.Attribute name) =>
   XmlTree.T i name XmlString.T -> HXT.XmlTree
fromXmlTree :: forall name i. (Tag name, Attribute name) => T i name T -> XmlTree
fromXmlTree T i name T
x =
   case forall name i.
(Tag name, Attribute name) =>
T i name T -> [XmlTree]
multiFromXmlTree T i name T
x of
      [XmlTree
y] -> XmlTree
y
      [XmlTree]
_   -> forall a. HasCallStack => String -> a
error String
"top branch can't be a string"


mkHXTName :: (Name.C name) => name -> QName
mkHXTName :: forall name. C name => name -> QName
mkHXTName = String -> QName
HXT.mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. C name => name -> String
Name.toString

mkHXTAttrs :: (Name.Attribute name) =>
   [Attr.T name XmlString.T] -> [NTree XNode]
mkHXTAttrs :: forall name. Attribute name => [T name T] -> [XmlTree]
mkHXTAttrs =
   forall a b. (a -> b) -> [a] -> [b]
map (\T name T
a ->
            forall (t :: * -> *) a. Tree t => a -> [t a] -> t a
HXTTree.mkTree
               (QName -> XNode
HXT.XAttr (forall name. C name => name -> QName
mkHXTName forall a b. (a -> b) -> a -> b
$ forall name string. T name string -> Name name
Attr.name_ T name T
a))
               (T -> [XmlTree]
HXTString.fromXmlString forall a b. (a -> b) -> a -> b
$ forall name string. T name string -> string
Attr.value_ T name T
a))

multiFromXmlTree ::
   (Name.Tag name, Name.Attribute name) =>
   XmlTree.T i name XmlString.T -> [HXT.XmlTree]
multiFromXmlTree :: forall name i.
(Tag name, Attribute name) =>
T i name T -> [XmlTree]
multiFromXmlTree =
   forall i a b branch leaf.
(i -> a -> b)
-> (branch -> [b] -> a) -> (leaf -> a) -> T i branch leaf -> b
Tree.fold
      (\i
i i -> [XmlTree]
f -> i -> [XmlTree]
f i
i)
      (\Branch name T
x [[XmlTree]]
subs i
_ ->
          case Branch name T
x of
             Tag (Elem.Cons Name name
name [T name T]
attrs) ->
                [forall (t :: * -> *) a. Tree t => a -> [t a] -> t a
HXTTree.mkTree
                    (QName -> [XmlTree] -> XNode
HXT.XTag (forall name. C name => name -> QName
mkHXTName Name name
name) (forall name. Attribute name => [T name T] -> [XmlTree]
mkHXTAttrs [T name T]
attrs))
                    (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[XmlTree]]
subs)])
      (\Leaf name T
x i
_ ->
          case Leaf name T
x of
             Text Bool
_ {- whitespace -} T
str -> T -> [XmlTree]
HXTString.fromXmlString T
str
             Comment String
str ->
                [forall (t :: * -> *) a. Tree t => a -> [t a] -> t a
HXTTree.mkTree (String -> XNode
HXT.XCmt String
str) []]
             CData String
str ->
                [forall (t :: * -> *) a. Tree t => a -> [t a] -> t a
HXTTree.mkTree (String -> XNode
HXT.XCdata String
str) []]
             PI Name name
target T name T
proc ->
                let ([XmlTree]
attrTree,[XmlTree]
subTrees) =
                       case T name T
proc of
                          PI.Known [T name T]
attrs -> (forall name. Attribute name => [T name T] -> [XmlTree]
mkHXTAttrs [T name T]
attrs, [])
                          PI.Unknown String
str -> ([], [forall (t :: * -> *) a. Tree t => a -> [t a] -> t a
HXTTree.mkTree (String -> XNode
HXT.XText String
str) []])
                in  [forall (t :: * -> *) a. Tree t => a -> [t a] -> t a
HXTTree.mkTree
                        (QName -> [XmlTree] -> XNode
HXT.XPi (forall name. C name => name -> QName
mkHXTName Name name
target) [XmlTree]
attrTree)
                        [XmlTree]
subTrees]
             Warning String
str ->
                [forall (t :: * -> *) a. Tree t => a -> [t a] -> t a
HXTTree.mkTree (Int -> String -> XNode
HXT.XError Int
0 String
str) []])
    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


{- * conversion from HXT tree to our XML tree -}

toXmlTree, toXmlTree' ::
   (Name.Tag name, Name.Attribute name) =>
   HXT.XmlTree -> XmlTree.T () name XmlString.T
toXmlTree :: forall name. (Tag name, Attribute name) => XmlTree -> T () name T
toXmlTree = forall str i name. Monoid str => Filter i name str
XmlTree.mergeStrings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. (Tag name, Attribute name) => XmlTree -> T () name T
toXmlTree'


toXmlTree' :: forall name. (Tag name, Attribute name) => XmlTree -> T () name T
toXmlTree' (NTree XNode
label [XmlTree]
subTrees) = forall i name str.
T i (Branch name str) (Leaf name str) -> T i name str
XmlTree.wrap forall a b. (a -> b) -> a -> b
$ (,) () forall a b. (a -> b) -> a -> b
$
   let leaf :: leaf -> Elem i branch leaf
leaf leaf
x =
          if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [XmlTree]
subTrees
            then forall i branch leaf. leaf -> Elem i branch leaf
Tree.Leaf leaf
x
            else forall a. HasCallStack => String -> a
error String
"HXT to WraXML: Leaf must not contain sub trees."

       fromHXTName :: QName -> Name name
fromHXTName = forall name. C name => String -> name
Name.fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
HXT.qualifiedName

       convAttr :: XmlTree -> T name T
convAttr (NTree XNode
x [XmlTree]
value) =
          case XNode
x of
             HXT.XAttr QName
name ->
                forall name string.
Attribute name =>
String -> string -> T name string
Attr.new (QName -> String
HXT.qualifiedName QName
name) ([XmlTree] -> T
HXTString.toXmlString [XmlTree]
value)
             XNode
_ -> forall a. HasCallStack => String -> a
error String
"HXT.XAttr expected"

   in  case XNode
label of
          HXT.XTag QName
name [XmlTree]
attrs ->
             forall i branch leaf.
branch -> [T i branch leaf] -> Elem i branch leaf
Tree.Branch
                (forall name str. T name str -> Branch name str
Tag (forall name str. Name name -> [T name str] -> T name str
Elem.Cons
                          (QName -> Name name
fromHXTName QName
name)
                          (forall a b. (a -> b) -> [a] -> [b]
map forall {name}. Attribute name => XmlTree -> T name T
convAttr [XmlTree]
attrs)))
                (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 b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. (Tag name, Attribute name) => XmlTree -> T () name T
toXmlTree') [XmlTree]
subTrees)
          HXT.XText String
str ->
             forall {leaf} {i} {branch}. leaf -> Elem i branch leaf
leaf (forall name str. Bool -> str -> Leaf name str
Text Bool
True (String -> T
XmlString.fromString String
str))
          HXT.XCharRef Int
ref ->
             forall {leaf} {i} {branch}. leaf -> Elem i branch leaf
leaf (forall name str. Bool -> str -> Leaf name str
Text Bool
False [Int -> T
XmlChar.fromCharRef Int
ref])
          HXT.XEntityRef String
ref ->
             forall {leaf} {i} {branch}. leaf -> Elem i branch leaf
leaf (forall name str. Bool -> str -> Leaf name str
Text Bool
False [String -> T
XmlChar.fromEntityRef String
ref])
          HXT.XCmt String
cmt ->
             forall {leaf} {i} {branch}. leaf -> Elem i branch leaf
leaf (forall name str. String -> Leaf name str
Comment String
cmt)
          HXT.XPi QName
target [XmlTree]
proc ->
             forall i branch leaf. leaf -> Elem i branch leaf
Tree.Leaf forall a b. (a -> b) -> a -> b
$ forall name str. Name name -> T name str -> Leaf name str
PI (QName -> Name name
fromHXTName QName
target) forall a b. (a -> b) -> a -> b
$
             case [XmlTree]
subTrees of
                [] -> forall name string. [T name string] -> T name string
PI.Known forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {name}. Attribute name => XmlTree -> T name T
convAttr [XmlTree]
proc
                [NTree (HXT.XText String
str) []] ->
                      forall name string. String -> T name string
PI.Unknown String
str
                [XmlTree]
_ ->  forall a. HasCallStack => String -> a
error String
"from HXT: processing instruction - there must be no children or a single text child"
          HXT.XAttr QName
_    -> forall a. HasCallStack => String -> a
error String
"from HXT: attribute not allowed in normal text"
          HXT.XDTD DTDElem
_ Attributes
_   -> forall a. HasCallStack => String -> a
error String
"from HXT: document type descriptor not allowed in normal text"
          HXT.XCdata String
x   -> forall {leaf} {i} {branch}. leaf -> Elem i branch leaf
leaf (forall name str. String -> Leaf name str
CData String
x)
          HXT.XError Int
lev String
x -> forall {leaf} {i} {branch}. leaf -> Elem i branch leaf
leaf (forall name str. String -> Leaf name str
Warning (String
"Level: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
lev forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
x))



{- * lift our XML filters to HXT filters -}

lift ::
   (Name.Tag name, Name.Attribute name) =>
   XmlTree.Filter () name XmlString.T -> (HXT.XmlTree -> HXT.XmlTree)
lift :: forall name.
(Tag name, Attribute name) =>
Filter () name T -> XmlTree -> XmlTree
lift Filter () name T
f = forall name i. (Tag name, Attribute name) => T i name T -> XmlTree
fromXmlTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. Filter () name T
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. (Tag name, Attribute name) => XmlTree -> T () name T
toXmlTree


{- |
Lift our XML filters to HXT document processors.
-}
liftFilterToDocument ::
   (Name.Tag name, Name.Attribute 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 :: forall name.
(Tag name, Attribute name) =>
String -> Filter () name T -> XmlTree -> XmlTree
liftFilterToDocument String
tagName Filter () name T
f =
   forall (t :: * -> *) a. Tree t => ([t a] -> [t a]) -> t a -> t a
HXTTree.changeChildren forall a b. (a -> b) -> a -> b
$ \[XmlTree]
subTrees ->
      let ([XmlTree]
pre,XmlTree
x:[XmlTree]
post) =
              forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> XNode -> Bool
checkTagName String
tagName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Tree t => t a -> a
HXTTree.getNode) [XmlTree]
subTrees
      in  [XmlTree]
pre forall a. [a] -> [a] -> [a]
++ forall name.
(Tag name, Attribute name) =>
Filter () name T -> XmlTree -> XmlTree
lift Filter () name T
f XmlTree
x forall a. a -> [a] -> [a]
: [XmlTree]
post

checkTagName :: String -> HXT.XNode -> Bool
checkTagName :: String -> XNode -> Bool
checkTagName String
tagName XNode
tree =
   case XNode
tree of
      (HXT.XTag QName
name [XmlTree]
_)  ->  QName -> String
HXT.qualifiedName QName
name forall a. Eq a => a -> a -> Bool
== String
tagName
      XNode
_  ->  Bool
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.
-}