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

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

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

   XML tree conversion to external string representation

-}

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

module Text.XML.HXT.DOM.ShowXml
    ( xshow
    , showElemType
    )
where

import Data.Maybe
import Data.Tree.NTree.TypeDefs

import Text.XML.HXT.DOM.TypeDefs                -- XML Tree types
import Text.XML.HXT.DOM.XmlKeywords
import Text.XML.HXT.DOM.XmlNode                 ( mkDTDElem
                                                , getDTDAttrl
                                                )

-- -----------------------------------------------------------------------------
--
-- the toString conversion functions

-- |
-- convert the result of a filter into a string
--
-- see also : 'xmlTreesToText' for filter version, 'Text.XML.HXT.Parser.XmlParsec.xread' for the inverse operation

xshow   :: XmlTrees -> String
xshow [(NTree (XText s) _)]     = s                     -- special case optimisation
xshow ts                        = showXmlTrees ts ""

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

showXmlTree             :: XmlTree  -> String -> String

showXmlTree (NTree (XText s) _)
    = showString s

showXmlTree (NTree (XCharRef i) _)
    = showString "&#" . showString (show i) . showChar ';'

showXmlTree (NTree (XEntityRef r) _)
    = showString "&" . showString r . showChar ';'

showXmlTree (NTree (XCmt c) _)
    = showString "<!--" . showString c . showString "-->"

showXmlTree (NTree (XCdata d) _)
    = showString "<![CDATA[" . showString d . showString "]]>"

showXmlTree (NTree (XPi n al) _)
    = showString "<?"
      .
      showQName n
      .
      (foldr (.) id . map showPiAttr) al
      .
      showString "?>"
      where
      showPiAttr        :: XmlTree -> String -> String
      showPiAttr a@(NTree (XAttr an) cs)
          | qualifiedName an == a_value
              = showBlank . showXmlTrees cs
          | otherwise
              = showXmlTree a
      showPiAttr _
          = id

showXmlTree (NTree (XTag t al) [])
    = showLt . showQName t . showXmlTrees al . showSlash . showGt

showXmlTree (NTree (XTag t al) cs)
    = showLt . showQName t . showXmlTrees al . showGt
      . showXmlTrees cs
      . showLt . showSlash . showQName t . showGt

showXmlTree (NTree (XDTD de al) cs)
    = showXmlDTD de al cs

showXmlTree (NTree (XAttr an) cs)
    = showBlank . showQName an . showEq . showQuoteString (xshow cs)

showXmlTree (NTree (XError l e) _)
    = showString "<!-- ERROR (" . shows l . showString "):\n" . showString e . showString "\n-->"

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

showXmlTrees            :: XmlTrees -> String -> String
showXmlTrees            = foldr (.) id . map showXmlTree

showXmlTrees'           :: XmlTrees -> String -> String
showXmlTrees'           = foldr (\ x y -> x . showNL . y) id . map showXmlTree

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

showQName               :: QName -> String -> String
showQName
    = showString . qualifiedName

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

showQuoteString         :: String -> String -> String
showQuoteString s
    | '\"' `elem` s
        = showApos . showString s . showApos
    | otherwise
        = showQuot . showString s . showQuot


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

showAttr        :: String -> Attributes -> String -> String
showAttr k al
    = showString (fromMaybe "" . lookup k $ al)

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

showPEAttr      :: Attributes -> String -> String
showPEAttr al
    = showPE (lookup a_peref al)
      where
      showPE (Just pe) = showChar '%' . showString pe . showChar ';'
      showPE Nothing   = id

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

showExternalId  :: Attributes -> String -> String
showExternalId al
    = id2Str (lookup k_system al) (lookup k_public al)
      where
      id2Str Nothing  Nothing  = id
      id2Str (Just s) Nothing  = showBlank . showString k_system . showBlank . showQuoteString s
      id2Str Nothing  (Just p) = showBlank . showString k_public . showBlank . showQuoteString p
      id2Str (Just s) (Just p) = showBlank . showString k_public . showBlank . showQuoteString p . showBlank . showQuoteString s

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

showNData       :: Attributes -> String -> String
showNData al
    = nd2Str (lookup k_ndata al)
      where
      nd2Str Nothing    = id
      nd2Str (Just v)   = showBlank . showString k_ndata . showBlank . showString v

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

showXmlDTD              :: DTDElem -> Attributes -> XmlTrees -> String -> String

showXmlDTD DOCTYPE al cs
    = showString "<!DOCTYPE "
      .
      showAttr a_name al
      .
      showExternalId al
      .
      showInternalDTD cs
      .
      showString ">"
      where
      showInternalDTD [] = id
      showInternalDTD ds = showString " [\n" . showXmlTrees' ds . showChar ']'

showXmlDTD ELEMENT al cs
    = showString "<!ELEMENT "
      .
      showAttr a_name al
      .
      showBlank
      .
      showElemType (lookup1 a_type al) cs
      .
      showString " >"

showXmlDTD ATTLIST al cs
    = showString "<!ATTLIST "
      .
      ( if isNothing . lookup a_name $ al
        then
        showXmlTrees cs
        else
        showAttr a_name al
        .
        showBlank
        .
        ( case lookup a_value al of
          Nothing -> ( showPEAttr
                       . fromMaybe [] . getDTDAttrl
                       . head
                     ) cs
          Just a  -> ( showString a
                       .
                       showAttrType (lookup1 a_type al)
                       .
                       showAttrKind (lookup1 a_kind al)
                     )
        )
      )
      .
      showString " >"
      where
      showAttrType t
          | t == k_peref
              = showBlank . showPEAttr al
          | t == k_enumeration
              = showAttrEnum
          | t == k_notation
              = showBlank . showString k_notation . showAttrEnum
          | otherwise
              = showBlank . showString t

      showAttrEnum
          = showString " ("
            .
            foldr1 (\ s1 s2 -> s1 . showString " | " .  s2) (map (getEnum . fromMaybe [] . getDTDAttrl) cs)
            .
            showString ")"
            where
            getEnum     :: Attributes -> String -> String
            getEnum l = showAttr a_name l . showPEAttr l

      showAttrKind k
          | k == k_default
              = showBlank . showQuoteString (lookup1 a_default al)
          | k == k_fixed
              = showBlank . showString k_fixed
                .
                showBlank . showQuoteString (lookup1 a_default al)
          | k == ""
              = id
          | otherwise
              = showBlank . showString k

showXmlDTD NOTATION al _cs
    = showString "<!NOTATION "
      .
      showAttr a_name al
      .
      showExternalId al
      .
      showString " >"

showXmlDTD PENTITY al cs
    = showEntity "% " al cs

showXmlDTD ENTITY al cs
    = showEntity "" al cs

showXmlDTD PEREF al _cs
    = showPEAttr al

showXmlDTD CONDSECT _ (c1 : cs)
    = showString "<![ "
      .
      showXmlTree c1
      .
      showString " [\n"
      .
      showXmlTrees cs
      .
      showString "]]>"

showXmlDTD CONTENT al cs
    = showContent (mkDTDElem CONTENT al cs)

showXmlDTD NAME al _cs
    = showAttr a_name al

showXmlDTD de al _cs
    = showString "NOT YET IMPLEMETED: " . showString (show de) . showBlank . showString (show al) . showString " [...]\n"

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

showElemType    :: String -> XmlTrees -> String -> String
showElemType t cs
    | t == v_pcdata
        = showLpar . showString v_pcdata . showRpar

    | t == v_mixed && (not . null) cs
        = showLpar
          .
          showString v_pcdata
          .
          ( foldr (.) id . map (mixedContent . selAttrl . getNode) ) cs1
          .
          showRpar
          .
          showAttr a_modifier al1
    | t == v_mixed                              -- incorrect tree, e.g. after erronius pe substitution
        = showLpar
          .
          showRpar
    | t == v_children && (not . null) cs
        = showContent (head cs)
    | t == v_children
        = showLpar
          . showRpar
    | t == k_peref
        = foldr (.) id . map showContent $ cs
    | otherwise
        = showString t
    where
    [(NTree (XDTD CONTENT al1) cs1)] = cs

    mixedContent :: Attributes -> String -> String
    mixedContent l
        = showString " | " . showAttr a_name l . showPEAttr l

    selAttrl (XDTD _ as) = as
    selAttrl (XText tex) = [(a_name, tex)]
    selAttrl _           = []

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

showContent     :: XmlTree -> String -> String
showContent (NTree (XDTD de al) cs)
    = cont2String de
      where
      cont2String       :: DTDElem -> String -> String
      cont2String NAME
          = showAttr a_name al
      cont2String PEREF
          = showPEAttr al
      cont2String CONTENT
          = showLpar
            .
            foldr1 (combine (lookup1 a_kind al)) (map showContent cs)
            .
            showRpar
            .
            showAttr a_modifier al
      cont2String n
          = error ("cont2string " ++ show n ++ " is undefined")
      combine k s1 s2
          = s1
            .
            showString ( if k == v_seq
                         then ", "
                         else " | "
                       )
            .
            s2

showContent n
    = showXmlTree n

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

showEntity      :: String -> Attributes -> XmlTrees -> String -> String

showEntity kind al cs
    = showString "<!ENTITY "
      .
      showString kind
      .
      showAttr a_name al
      .
      showExternalId al
      .
      showNData al
      .
      showEntityValue cs
      .
      showString " >"

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

showEntityValue :: XmlTrees -> String -> String

showEntityValue []
    = id

showEntityValue cs
    = showBlank . showQuoteString (xshow cs)

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

showBlank,
  showEq, showLt, showGt, showSlash, showApos, showQuot, showLpar, showRpar, showNL :: String -> String

showBlank       = showChar ' '
showEq          = showChar '='
showLt          = showChar '<'
showGt          = showChar '>'
showSlash       = showChar '/'
showApos        = showChar '\''
showQuot        = showChar '\"'
showLpar        = showChar '('
showRpar        = showChar ')'
showNL          = showChar '\n'

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