{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-}

-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.DOM.XmlNode
   Copyright  : Copyright (C) 2008 Uwe Schmidt
   License    : MIT


   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   Interface for XmlArrow to basic data types NTree and XmlTree

   If this module must be used in code working with arrows,
   it should be imported qualified e.g. @as XN@, to prevent name clashes.

   For code working on the \"node and tree level\" this module
   is the interface for writing code without using the
   constructor functions of 'XNode' and 'NTree' directly

-}

-- ------------------------------------------------------------

module Text.XML.HXT.DOM.XmlNode
    ( module Text.XML.HXT.DOM.XmlNode
    , module Data.Tree.Class
    , module Data.Tree.NTree.TypeDefs
    )
where

import Control.Monad
import Control.FlatSeq

import Data.Function            ( on )
import Data.Maybe               ( fromMaybe
                                , fromJust
                                )
import Data.Tree.Class
import Data.Tree.NTree.TypeDefs


import Text.XML.HXT.DOM.Interface

class XmlNode a where
    -- discriminating predicates

    isText              :: a -> Bool
    isBlob              :: a -> Bool
    isCharRef           :: a -> Bool
    isEntityRef         :: a -> Bool
    isCmt               :: a -> Bool
    isCdata             :: a -> Bool
    isPi                :: a -> Bool
    isElem              :: a -> Bool
    isRoot              :: a -> Bool
    isDTD               :: a -> Bool
    isAttr              :: a -> Bool
    isError             :: a -> Bool

    -- constructor functions for leave nodes

    mkText              :: String -> a
    mkBlob              :: Blob   -> a
    mkCharRef           :: Int    -> a
    mkEntityRef         :: String -> a
    mkCmt               :: String -> a
    mkCdata             :: String -> a
    mkPi                :: QName  -> XmlTrees -> a
    mkError             :: Int    -> String   -> a

    -- selectors

    getText             :: a -> Maybe String
    getBlob             :: a -> Maybe Blob
    getCharRef          :: a -> Maybe Int
    getEntityRef        :: a -> Maybe String
    getCmt              :: a -> Maybe String
    getCdata            :: a -> Maybe String
    getPiName           :: a -> Maybe QName
    getPiContent        :: a -> Maybe XmlTrees
    getElemName         :: a -> Maybe QName
    getAttrl            :: a -> Maybe XmlTrees
    getDTDPart          :: a -> Maybe DTDElem
    getDTDAttrl         :: a -> Maybe Attributes
    getAttrName         :: a -> Maybe QName
    getErrorLevel       :: a -> Maybe Int
    getErrorMsg         :: a -> Maybe String

    -- derived selectors

    getName             :: a -> Maybe QName
    getQualifiedName    :: a -> Maybe String
    getUniversalName    :: a -> Maybe String
    getUniversalUri     :: a -> Maybe String
    getLocalPart        :: a -> Maybe String
    getNamePrefix       :: a -> Maybe String
    getNamespaceUri     :: a -> Maybe String

    -- "modifier" functions

    changeText          :: (String   -> String)   -> a -> a
    changeBlob          :: (Blob     -> Blob)     -> a -> a
    changeCmt           :: (String   -> String)   -> a -> a
    changeName          :: (QName    -> QName)    -> a -> a
    changeElemName      :: (QName    -> QName)    -> a -> a
    changeAttrl         :: (XmlTrees -> XmlTrees) -> a -> a
    changeAttrName      :: (QName    -> QName)    -> a -> a
    changePiName        :: (QName    -> QName)    -> a -> a
    changeDTDAttrl      :: (Attributes -> Attributes) -> a -> a

    setText             :: String   -> a -> a
    setBlob             :: Blob     -> a -> a
    setCmt              :: String   -> a -> a
    setName             :: QName    -> a -> a
    setElemName         :: QName    -> a -> a
    setElemAttrl        :: XmlTrees -> a -> a
    setAttrName         :: QName    -> a -> a
    setPiName           :: QName    -> a -> a
    setDTDAttrl         :: Attributes -> a -> a

    -- default implementations

    getName n           = getElemName n `mplus` getAttrName n `mplus` getPiName n
    getQualifiedName n  = getName n >>= return . qualifiedName
    getUniversalName n  = getName n >>= return . universalName
    getUniversalUri n   = getName n >>= return . universalUri
    getLocalPart n      = getName n >>= return . localPart
    getNamePrefix n     = getName n >>= return . namePrefix
    getNamespaceUri n   = getName n >>= return . namespaceUri

    setText             = changeText     . const
    setBlob             = changeBlob     . const
    setCmt              = changeCmt      . const
    setName             = changeName     . const
    setElemName         = changeElemName . const
    setElemAttrl        = changeAttrl    . const
    setAttrName         = changeAttrName . const
    setPiName           = changePiName   . const
    setDTDAttrl         = changeDTDAttrl . const

-- XNode and XmlTree are instances of XmlNode

instance XmlNode XNode where
    isText (XText _)            = True
    isText (XBlob _)            = True
    isText _                    = False
    {-# INLINE isText #-}

    isBlob (XBlob _)            = True
    isBlob _                    = False
    {-# INLINE isBlob #-}

    isCharRef (XCharRef _)      = True
    isCharRef _                 = False
    {-# INLINE isCharRef #-}

    isEntityRef (XEntityRef _)  = True
    isEntityRef _               = False
    {-# INLINE isEntityRef #-}

    isCmt (XCmt _)              = True
    isCmt _                     = False
    {-# INLINE isCmt #-}

    isCdata (XCdata _)          = True
    isCdata _                   = False
    {-# INLINE isCdata #-}

    isPi (XPi _ _)              = True
    isPi _                      = False
    {-# INLINE isPi #-}

    isElem (XTag _ _)           = True
    isElem _                    = False
    {-# INLINE isElem #-}

    isRoot t                    = isElem t
                                  &&
                                  fromMaybe "" (getQualifiedName t) == t_root

    isDTD (XDTD _ _)            = True
    isDTD _                     = False
    {-# INLINE isDTD #-}

    isAttr (XAttr _)            = True
    isAttr _                    = False
    {-# INLINE isAttr #-}

    isError (XError _ _)        = True
    isError _                   = False
    {-# INLINE isError #-}


    mkText                      = XText
    {-# INLINE mkText #-}
    mkBlob                      = XBlob
    {-# INLINE mkBlob #-}
    mkCharRef                   = XCharRef
    {-# INLINE mkCharRef #-}
    mkEntityRef                 = XEntityRef
    {-# INLINE mkEntityRef #-}
    mkCmt                       = XCmt
    {-# INLINE mkCmt #-}
    mkCdata                     = XCdata
    {-# INLINE mkCdata #-}
    mkPi                        = XPi
    {-# INLINE mkPi #-}

    mkError                     = XError
    {-# INLINE mkError #-}


    getText (XText t)           = Just   t
    getText (XBlob b)           = Just . blobToString $ b
    getText _                   = Nothing
    {-# INLINE getText #-}

    getBlob (XBlob b)           = Just b
    getBlob _                   = Nothing
    {-# INLINE getBlob #-}

    getCharRef (XCharRef c)     = Just c
    getCharRef _                = Nothing
    {-# INLINE getCharRef #-}

    getEntityRef (XEntityRef e) = Just e
    getEntityRef _              = Nothing
    {-# INLINE getEntityRef #-}

    getCmt (XCmt c)             = Just c
    getCmt _                    = Nothing
    {-# INLINE getCmt #-}

    getCdata (XCdata d)         = Just d
    getCdata _                  = Nothing
    {-# INLINE getCdata #-}

    getPiName (XPi n _)         = Just n
    getPiName _                 = Nothing
    {-# INLINE getPiName #-}

    getPiContent (XPi _ c)      = Just c
    getPiContent _              = Nothing
    {-# INLINE getPiContent #-}

    getElemName (XTag n _)      = Just n
    getElemName _               = Nothing
    {-# INLINE getElemName #-}

    getAttrl (XTag _ al)        = Just al
    getAttrl (XPi  _ al)        = Just al
    getAttrl _                  = Nothing
    {-# INLINE getAttrl #-}

    getDTDPart (XDTD p _)       = Just p
    getDTDPart _                = Nothing
    {-# INLINE getDTDPart #-}

    getDTDAttrl (XDTD _ al)     = Just al
    getDTDAttrl _               = Nothing
    {-# INLINE getDTDAttrl #-}

    getAttrName (XAttr n)       = Just n
    getAttrName _               = Nothing
    {-# INLINE getAttrName #-}

    getErrorLevel (XError l _)  = Just l
    getErrorLevel _             = Nothing
    {-# INLINE getErrorLevel #-}

    getErrorMsg (XError _ m)    = Just m
    getErrorMsg _               = Nothing
    {-# INLINE getErrorMsg #-}

    changeText cf (XText t)             = XText . cf $ t
    changeText cf (XBlob b)             = XText . cf . blobToString $ b
    changeText _ _                      = error "changeText undefined"
    {-# INLINE changeText #-}

    changeBlob cf (XBlob b)             = XBlob . cf $ b
    changeBlob _ _                      = error "changeBlob undefined"
    {-# INLINE changeBlob #-}

    changeCmt cf (XCmt c)               = XCmt  . cf $ c
    changeCmt _ _                       = error "changeCmt undefined"
    {-# INLINE changeCmt #-}

    changeName cf (XTag n al)           = XTag   (cf n) al
    changeName cf (XAttr n)             = XAttr . cf $ n
    changeName cf (XPi n al)            = XPi    (cf n) al
    changeName _ _                      = error "changeName undefined"
    {-# INLINE changeName #-}

    changeElemName cf (XTag n al)       = XTag   (cf n) al
    changeElemName _ _                  = error "changeElemName undefined"
    {-# INLINE changeElemName #-}

    changeAttrl cf (XTag n al)          = XTag n (cf al)
    changeAttrl cf (XPi  n al)          = XPi  n (cf al)
    changeAttrl _ _                     = error "changeAttrl undefined"
    {-# INLINE changeAttrl #-}

    changeAttrName cf (XAttr n)         = XAttr . cf $ n
    changeAttrName _ _                  = error "changeAttrName undefined"
    {-# INLINE changeAttrName #-}

    changePiName cf (XPi n al)          = XPi    (cf n) al
    changePiName _ _                    = error "changePiName undefined"
    {-# INLINE changePiName #-}

    changeDTDAttrl cf (XDTD p al)       = XDTD p (cf al)
    changeDTDAttrl _ _                  = error "changeDTDAttrl undefined"
    {-# INLINE changeDTDAttrl #-}

mkElementNode   :: QName -> XmlTrees -> XNode
mkElementNode   = XTag
{-# INLINE mkElementNode #-}

mkAttrNode      :: QName -> XNode
mkAttrNode      = XAttr
{-# INLINE mkAttrNode #-}

mkDTDNode       :: DTDElem -> Attributes -> XNode
mkDTDNode       = XDTD
{-# INLINE mkDTDNode #-}

instance (XmlNode a, Tree t) => XmlNode (t a) where
    isText              = isText      . getNode
    {-# INLINE isText #-}
    isBlob              = isBlob      . getNode
    {-# INLINE isBlob #-}
    isCharRef           = isCharRef   . getNode
    {-# INLINE isCharRef #-}
    isEntityRef         = isEntityRef . getNode
    {-# INLINE isEntityRef #-}
    isCmt               = isCmt       . getNode
    {-# INLINE isCmt #-}
    isCdata             = isCdata     . getNode
    {-# INLINE isCdata #-}
    isPi                = isPi        . getNode
    {-# INLINE isPi #-}
    isElem              = isElem      . getNode
    {-# INLINE isElem #-}
    isRoot              = isRoot      . getNode
    {-# INLINE isRoot #-}
    isDTD               = isDTD       . getNode
    {-# INLINE isDTD #-}
    isAttr              = isAttr      . getNode
    {-# INLINE isAttr #-}
    isError             = isError     . getNode
    {-# INLINE isError #-}

    mkText              = mkLeaf . mkText
    {-# INLINE mkText #-}
    mkBlob              = mkLeaf . mkBlob
    {-# INLINE mkBlob #-}
    mkCharRef           = mkLeaf . mkCharRef
    {-# INLINE mkCharRef #-}
    mkEntityRef         = mkLeaf . mkEntityRef
    {-# INLINE mkEntityRef #-}
    mkCmt               = mkLeaf . mkCmt
    {-# INLINE mkCmt #-}
    mkCdata             = mkLeaf . mkCdata
    {-# INLINE mkCdata #-}
    mkPi n              = mkLeaf . mkPi n
    {-# INLINE mkPi #-}
    mkError l           = mkLeaf . mkError l
    {-# INLINE mkError #-}

    getText             = getText       . getNode
    {-# INLINE getText #-}
    getBlob             = getBlob       . getNode
    {-# INLINE getBlob #-}
    getCharRef          = getCharRef    . getNode
    {-# INLINE getCharRef #-}
    getEntityRef        = getEntityRef  . getNode
    {-# INLINE getEntityRef #-}
    getCmt              = getCmt        . getNode
    {-# INLINE getCmt #-}
    getCdata            = getCdata      . getNode
    {-# INLINE getCdata #-}
    getPiName           = getPiName     . getNode
    {-# INLINE getPiName #-}
    getPiContent        = getPiContent  . getNode
    {-# INLINE getPiContent #-}
    getElemName         = getElemName   . getNode
    {-# INLINE getElemName #-}
    getAttrl            = getAttrl      . getNode
    {-# INLINE getAttrl #-}
    getDTDPart          = getDTDPart    . getNode
    {-# INLINE getDTDPart #-}
    getDTDAttrl         = getDTDAttrl   . getNode
    {-# INLINE getDTDAttrl #-}
    getAttrName         = getAttrName   . getNode
    {-# INLINE getAttrName #-}
    getErrorLevel       = getErrorLevel . getNode
    {-# INLINE getErrorLevel #-}
    getErrorMsg         = getErrorMsg   . getNode
    {-# INLINE getErrorMsg #-}

    changeText          = changeNode . changeText
    {-# INLINE changeText #-}
    changeBlob          = changeNode . changeBlob
    {-# INLINE changeBlob #-}
    changeCmt           = changeNode . changeCmt
    {-# INLINE changeCmt #-}
    changeName          = changeNode . changeName
    {-# INLINE changeName #-}
    changeElemName      = changeNode . changeElemName
    {-# INLINE changeElemName #-}
    changeAttrl         = changeNode . changeAttrl
    {-# INLINE changeAttrl #-}
    changeAttrName      = changeNode . changeAttrName
    {-# INLINE changeAttrName #-}
    changePiName        = changeNode . changePiName
    {-# INLINE changePiName #-}
    changeDTDAttrl      = changeNode . changeDTDAttrl
    {-# INLINE changeDTDAttrl #-}

mkElement       :: QName -> XmlTrees -> XmlTrees -> XmlTree
mkElement n al  = mkTree (mkElementNode n al)
{-# INLINE mkElement #-}

mkRoot          :: XmlTrees -> XmlTrees -> XmlTree
mkRoot al       = mkTree (mkElementNode (mkName t_root) al)

mkAttr          :: QName -> XmlTrees -> XmlTree
mkAttr n        = mkTree (mkAttrNode n)
{-# INLINE mkAttr #-}

mkDTDElem       :: DTDElem -> Attributes -> XmlTrees -> XmlTree
mkDTDElem e al  = mkTree (mkDTDNode e al)

addAttr         :: XmlTree -> XmlTrees -> XmlTrees
addAttr a al
    | isAttr a  = add al
    | otherwise = al
    where
    an = (qualifiedName . fromJust . getAttrName) a
    add []
        = [a]
    add (a1:al1)
        | isAttr a1
          &&
          (qualifiedName . fromJust . getAttrName) a1 == an
            = a : al1
        | otherwise
            = a1 : add al1

mergeAttrl      :: XmlTrees -> XmlTrees -> XmlTrees
mergeAttrl      = foldr addAttr

-- ------------------------------------------------------------

-- | weak normalform versions of constructors

mkElement'              :: QName -> XmlTrees -> XmlTrees -> XmlTree
mkElement' n al cl      = id $!! mkElement n al cl
{-# INLINE mkElement' #-}

mkRoot'                 :: XmlTrees -> XmlTrees -> XmlTree
mkRoot' al cl           = id $!! mkRoot al cl
{-# INLINE mkRoot' #-}

mkAttr'                 :: QName -> XmlTrees -> XmlTree
mkAttr' n av            = id $!! mkAttr n av
{-# INLINE mkAttr' #-}

mkText'                 :: String -> XmlTree
mkText' t               = id $!! mkText t
{-# INLINE mkText' #-}

mkCharRef'              :: Int    -> XmlTree
mkCharRef' i            = id $!! mkCharRef i
{-# INLINE mkCharRef' #-}

mkEntityRef'            :: String -> XmlTree
mkEntityRef' n          = id $!! mkEntityRef n
{-# INLINE mkEntityRef' #-}

mkCmt'                  :: String -> XmlTree
mkCmt' c                = id $!! mkCmt c
{-# INLINE mkCmt' #-}

mkCdata'                :: String -> XmlTree
mkCdata' d              = id $!! mkCdata d
{-# INLINE mkCdata' #-}

mkPi'                   :: QName  -> XmlTrees -> XmlTree
mkPi' n v               = id $!! mkPi n v
{-# INLINE mkPi' #-}

mkError'                :: Int -> String   -> XmlTree
mkError' l m            = id $!! mkError l m
{-# INLINE mkError' #-}

mkDTDElem'              :: DTDElem -> Attributes -> XmlTrees -> XmlTree
mkDTDElem' e al cl      = id $!! mkDTDElem e al cl
{-# INLINE mkDTDElem' #-}

-- ------------------------------------------------------------

toText :: XmlTree -> XmlTree
toText t
    | isCharRef t
        = mkText
          . (:[]) . toEnum
          . fromJust
          . getCharRef
          $ t
    | isCdata t
        = mkText
          . fromJust
          . getCdata
          $ t
    | otherwise
        = t

concText :: XmlTree -> XmlTree -> XmlTrees
concText t1 t2
    | isText t1 && isText t2
        = (:[]) . mkText $ fromJust (getText t1) ++ fromJust (getText t2)
    | otherwise
        = [t1, t2]

mergeText :: XmlTree -> XmlTree -> XmlTrees
mergeText
    = concText `on` toText

-- ------------------------------------------------------------