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

    {- |
       Module     : Text.XML.HXT.Arrow.Edit
       Copyright  : Copyright (C) 2011 Uwe Schmidt
       License    : MIT

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

       common edit arrows

    -}

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

    module Text.XML.HXT.Arrow.Edit
        ( canonicalizeAllNodes
        , canonicalizeForXPath
        , canonicalizeContents
        , collapseAllXText
        , collapseXText

        , xshowEscapeXml

        , escapeXmlRefs
        , escapeHtmlRefs

        , haskellRepOfXmlDoc
        , treeRepOfXmlDoc
        , addHeadlineToXmlDoc

        , indentDoc
        , numberLinesInXmlDoc
        , preventEmptyElements

        , removeComment
        , removeAllComment
        , removeWhiteSpace
        , removeAllWhiteSpace
        , removeDocWhiteSpace

        , transfCdata
        , transfAllCdata
        , transfCharRef
        , transfAllCharRef

        , substAllXHTMLEntityRefs
        , substXHTMLEntityRef

        , rememberDTDAttrl
        , addDefaultDTDecl

        , hasXmlPi
        , addXmlPi
        , addXmlPiEncoding

        , addDoctypeDecl
        , addXHtmlDoctypeStrict
        , addXHtmlDoctypeTransitional
        , addXHtmlDoctypeFrameset
        )
    where

    import           Control.Arrow
    import           Control.Arrow.ArrowIf
    import           Control.Arrow.ArrowList
    import           Control.Arrow.ArrowTree
    import           Control.Arrow.ListArrow
    import           Control.Arrow.NTreeEdit

    import           Data.Char.Properties.XMLCharProps (isXmlSpaceChar)

    import           Text.XML.HXT.Arrow.XmlArrow
    import           Text.XML.HXT.DOM.FormatXmlTree    (formatXmlTree)
    import           Text.XML.HXT.DOM.Interface
    import qualified Text.XML.HXT.DOM.ShowXml          as XS
    import qualified Text.XML.HXT.DOM.XmlNode          as XN
    import           Text.XML.HXT.Parser.HtmlParsec    (emptyHtmlTags)
    import           Text.XML.HXT.Parser.XhtmlEntities (xhtmlEntities)
    import           Text.XML.HXT.Parser.XmlEntities   (xmlEntities)

    import           Data.List                         (isPrefixOf)
    import qualified Data.Map                          as M
    import           Data.Maybe

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

    -- |
    -- Applies some "Canonical XML" rules to a document tree.
    --
    -- The rules differ slightly for canonical XML and XPath in handling of comments
    --
    -- Note: This is not the whole canonicalization as it is specified by the W3C
    -- Recommendation. Adding attribute defaults or sorting attributes in lexicographic
    -- order is done by the @transform@ function of module @Text.XML.HXT.Validator.Validation@.
    -- Replacing entities or line feed normalization is done by the parser.
    --
    --
    -- Not implemented yet:
    --
    --  - Whitespace within start and end tags is normalized
    --
    --  - Special characters in attribute values and character content are replaced by character references
    --
    -- see 'canonicalizeAllNodes' and 'canonicalizeForXPath'

    canonicalizeTree'       :: LA XmlTree XmlTree -> LA XmlTree XmlTree
    canonicalizeTree' toBeRemoved
        = ( processChildren
            ( (none `when` (isText <+> isXmlPi))    -- remove XML PI and all text around XML root element
              >>>
              (deep isPi `when` isDTD)              -- remove DTD parts, except PIs whithin DTD
            )
            `when` isRoot
          )
          >>>
          canonicalizeNodes toBeRemoved

    canonicalizeNodes       :: LA XmlTree XmlTree -> LA XmlTree XmlTree
    canonicalizeNodes toBeRemoved
        = editNTreeA $
          [ toBeRemoved     :-> none
          , ( isElem >>> getAttrl >>> getChildren >>> isCharRef )   -- canonicalize attribute list
                            :-> ( processAttrl
                                  ( processChildren transfCharRef
                                    >>>
                                    collapseXText'                  -- combine text in attribute values
                                  )
                                  >>>
                                  ( collapseXText'                  -- and combine text in content
                                    `when`
                                    (getChildren >>. has2XText)
                                  )
                                )
          , ( isElem >>> (getChildren >>. has2XText) )
                            :-> collapseXText'                      -- combine text in content

          , isCharRef       :-> ( getCharRef
                                  >>>
                                  arr (\ i -> [toEnum i])
                                  >>>
                                  mkText
                                )
          , isCdata         :-> ( getCdata
                                  >>>
                                  mkText
                                )
          ]

    -- |
    -- Applies some "Canonical XML" rules to a document tree.
    --
    -- The rule differ slightly for canonical XML and XPath in handling of comments
    --
    -- Note: This is not the whole canonicalization as it is specified by the W3C
    -- Recommendation. Adding attribute defaults or sorting attributes in lexicographic
    -- order is done by the @transform@ function of module @Text.XML.HXT.Validator.Validation@.
    -- Replacing entities or line feed normalization is done by the parser.
    --
    -- Rules: remove DTD parts, processing instructions, comments and substitute char refs in attribute
    -- values and text
    --
    -- Not implemented yet:
    --
    --  - Whitespace within start and end tags is normalized
    --
    --  - Special characters in attribute values and character content are replaced by character references

    canonicalizeAllNodes    :: ArrowList a => a XmlTree XmlTree
    canonicalizeAllNodes    = fromLA $
                              canonicalizeTree' isCmt                       -- remove comment
    {-# INLINE canonicalizeAllNodes #-}

    -- |
    -- Canonicalize a tree for XPath
    -- Like 'canonicalizeAllNodes' but comment nodes are not removed
    --
    -- see 'canonicalizeAllNodes'

    canonicalizeForXPath    :: ArrowList a => a XmlTree XmlTree
    canonicalizeForXPath    = fromLA $ canonicalizeTree' none               -- comment remains there
    {-# INLINE canonicalizeForXPath #-}

    -- |
    -- Canonicalize the contents of a document
    --
    -- substitutes all char refs in text and attribute values,
    -- removes CDATA section and combines all sequences of resulting text
    -- nodes into a single text node
    --
    -- see 'canonicalizeAllNodes'

    canonicalizeContents    :: ArrowList a => a XmlTree XmlTree
    canonicalizeContents    = fromLA $
                              canonicalizeNodes none
    {-# INLINE canonicalizeContents #-}

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

    has2XText               :: XmlTrees -> XmlTrees
    has2XText ts0@(t1 : ts1@(t2 : ts2))
        | XN.isText t1      = if XN.isText t2
                              then ts0
                              else has2XText ts2
        | otherwise         = has2XText ts1
    has2XText _             = []

    collapseXText'          :: LA XmlTree XmlTree
    collapseXText'
        = replaceChildren ( listA getChildren >>> arrL (foldr mergeText' []) )
        where
        mergeText'  :: XmlTree -> XmlTrees -> XmlTrees
        mergeText' t1 (t2 : ts2)
            | XN.isText t1 && XN.isText t2
                = let
                  s1 = fromJust . XN.getText $ t1
                  s2 = fromJust . XN.getText $ t2
                  t  = XN.mkText (s1 ++ s2)
                  in
                  t : ts2
        mergeText' t1 ts
            = t1 : ts

    -- |
    -- Collects sequences of text nodes in the list of children of a node into one single text node.
    -- This is useful, e.g. after char and entity reference substitution

    collapseXText           :: ArrowList a => a XmlTree XmlTree
    collapseXText           = fromLA collapseXText'

    -- |
    -- Applies collapseXText recursively.
    --
    --
    -- see also : 'collapseXText'

    collapseAllXText        :: ArrowList a => a XmlTree XmlTree
    collapseAllXText        = fromLA $ processBottomUp collapseXText'

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

    -- | apply an arrow to the input and convert the resulting XML trees into an XML escaped string
    --
    -- This is a save variant for converting a tree into an XML string representation
    -- that is parsable with 'Text.XML.HXT.Arrow.ReadDocument'.
    -- It is implemented with 'Text.XML.HXT.Arrow.XmlArrow.xshow',
    -- but xshow does no XML escaping. The XML escaping is done with
    -- 'Text.XML.HXT.Arrow.Edit.escapeXmlDoc' before xshow is applied.
    --
    -- So the following law holds
    --
    -- > xshowEscapeXml f >>> xread == f

    xshowEscapeXml          :: ArrowXml a => a n XmlTree -> a n String
    xshowEscapeXml f        = f >. (uncurry XS.xshow'' escapeXmlRefs)

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

    -- |
    -- escape XmlText,
    -- transform all special XML chars into char- or entity- refs

    type EntityRefTable     = M.Map Int String

    xmlEntityRefTable
     , xhtmlEntityRefTable  :: EntityRefTable

    xmlEntityRefTable       = buildEntityRefTable $ xmlEntities
    xhtmlEntityRefTable     = buildEntityRefTable $ xhtmlEntities

    buildEntityRefTable     :: [(String, Int)] -> EntityRefTable
    buildEntityRefTable     = M.fromList . map (\ (x,y) -> (y,x) )

    type EntitySubstTable   = M.Map String String

    xhtmlEntitySubstTable   :: EntitySubstTable
    xhtmlEntitySubstTable   = M.fromList . map (second $ (:[]) . toEnum) $ xhtmlEntities

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

    substXHTMLEntityRef     :: LA XmlTree XmlTree
    substXHTMLEntityRef
        = ( getEntityRef
            >>>
            arrL subst
            >>>
            mkText
          )
          `orElse` this
        where
          subst name
              = maybe [] (:[]) $ M.lookup name xhtmlEntitySubstTable

    substAllXHTMLEntityRefs :: ArrowXml a => a XmlTree XmlTree
    substAllXHTMLEntityRefs
        = fromLA $
          processBottomUp substXHTMLEntityRef

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

    escapeXmlRefs           :: (Char -> String -> String, Char -> String -> String)
    escapeXmlRefs           = (cquote, aquote)
        where
        cquote c
            | c `elem` "<&" = ('&' :)
                              . ((lookupRef c xmlEntityRefTable) ++)
                              . (';' :)
            | otherwise     = (c :)
        aquote c
            | c `elem` "<>\"\'&\n\r\t"
                            = ('&' :)
                              . ((lookupRef c xmlEntityRefTable) ++)
                              . (';' :)
            | otherwise     = (c :)

    escapeHtmlRefs          :: (Char -> String -> String, Char -> String -> String)
    escapeHtmlRefs          = (cquote, aquote)
        where
        cquote c
            | isHtmlTextEsc c
                            = ('&' :)
                              . ((lookupRef c xhtmlEntityRefTable) ++)
                              . (';' :)
            | otherwise     = (c :)
        aquote c
            | isHtmlAttrEsc c
                            = ('&' :)
                              . ((lookupRef c xhtmlEntityRefTable) ++)
                              . (';' :)
            | otherwise     = (c :)

        isHtmlTextEsc c     = c >= toEnum(128) || ( c `elem` "<&" )
        isHtmlAttrEsc c     = c >= toEnum(128) || ( c `elem` "<>\"\'&\n\r\t" )

    lookupRef               :: Char -> EntityRefTable -> String
    lookupRef c             = fromMaybe ('#' : show (fromEnum c))
                              . M.lookup (fromEnum c)
    {-# INLINE lookupRef #-}

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

    preventEmptyElements    :: ArrowList a => [String] -> Bool -> a XmlTree XmlTree
    preventEmptyElements ns isHtml
        = fromLA $
          editNTreeA [ ( isElem
                         >>>
                         isNoneEmpty
                         >>>
                         neg getChildren
                       )
                       :-> replaceChildren (txt "")
                     ]
        where
        isNoneEmpty
            | not (null ns) = hasNameWith (localPart >>> (`elem` ns))
            | isHtml        = hasNameWith (localPart >>> (`notElem` emptyHtmlTags))
            | otherwise     = this

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

    -- |
    -- convert a document into a Haskell representation (with show).
    --
    -- Useful for debugging and trace output.
    -- see also : 'treeRepOfXmlDoc', 'numberLinesInXmlDoc'

    haskellRepOfXmlDoc      :: ArrowList a => a XmlTree XmlTree
    haskellRepOfXmlDoc
        = fromLA $
          root [getAttrl] [show ^>> mkText]

    -- |
    -- convert a document into a text and add line numbers to the text representation.
    --
    -- Result is a root node with a single text node as child.
    -- Useful for debugging and trace output.
    -- see also : 'haskellRepOfXmlDoc', 'treeRepOfXmlDoc'

    numberLinesInXmlDoc     :: ArrowList a => a XmlTree XmlTree
    numberLinesInXmlDoc
        = fromLA $
          processChildren (changeText numberLines)
        where
        numberLines :: String -> String
        numberLines str
            = concat $
              zipWith (\ n l -> lineNr n ++ l ++ "\n") [1..] (lines str)
            where
            lineNr   :: Int -> String
            lineNr n = (reverse (take 6 (reverse (show n) ++ replicate 6 ' '))) ++ "  "

    -- |
    -- convert a document into a text representation in tree form.
    --
    -- Useful for debugging and trace output.
    -- see also : 'haskellRepOfXmlDoc', 'numberLinesInXmlDoc'

    treeRepOfXmlDoc :: ArrowList a => a XmlTree XmlTree
    treeRepOfXmlDoc
        = fromLA $
          root [getAttrl] [formatXmlTree ^>> mkText]

    addHeadlineToXmlDoc     :: ArrowXml a => a XmlTree XmlTree
    addHeadlineToXmlDoc
        = fromLA $ ( addTitle $< (getAttrValue a_source >>^ formatTitle) )
        where
        addTitle str
            = replaceChildren ( txt str <+> getChildren <+> txt "\n" )
        formatTitle str
            = "\n" ++ headline ++ "\n" ++ underline ++ "\n\n"
            where
            headline  = "content of: " ++ str
            underline = map (const '=') headline

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

    -- |
    -- remove a Comment node

    removeComment           :: ArrowXml a => a XmlTree XmlTree
    removeComment           = none `when` isCmt

    -- |
    -- remove all comments in a tree recursively

    removeAllComment        :: ArrowXml a => a XmlTree XmlTree
    removeAllComment        = fromLA $ editNTreeA [isCmt :-> none]

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

    -- |
    -- simple filter for removing whitespace.
    --
    -- no check on sigificant whitespace, e.g. in HTML \<pre\>-elements, is done.
    --
    --
    -- see also : 'removeAllWhiteSpace', 'removeDocWhiteSpace'

    removeWhiteSpace        :: ArrowXml a => a XmlTree XmlTree
    removeWhiteSpace        = fromLA $ none `when` isWhiteSpace

    -- |
    -- simple recursive filter for removing all whitespace.
    --
    -- removes all text nodes in a tree that consist only of whitespace.
    --
    --
    -- see also : 'removeWhiteSpace', 'removeDocWhiteSpace'

    removeAllWhiteSpace     :: ArrowXml a => a XmlTree XmlTree
    removeAllWhiteSpace     = fromLA $ editNTreeA [isWhiteSpace :-> none]
                           -- fromLA $ processBottomUp removeWhiteSpace'    -- less efficient

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

    -- |
    -- filter for removing all not significant whitespace.
    --
    -- the tree traversed for removing whitespace between elements,
    -- that was inserted for indentation and readability.
    -- whitespace is only removed at places, where it's not significat
    -- preserving whitespace may be controlled in a document tree
    -- by a tag attribute @xml:space@
    --
    -- allowed values for this attribute are @default | preserve@
    --
    -- input is root node of the document to be cleaned up,
    -- output the semantically equivalent simplified tree
    --
    --
    -- see also : 'indentDoc', 'removeAllWhiteSpace'

    removeDocWhiteSpace     :: ArrowXml a => a XmlTree XmlTree
    removeDocWhiteSpace     = fromLA $ removeRootWhiteSpace

    removeRootWhiteSpace    :: LA XmlTree XmlTree
    removeRootWhiteSpace
        =  processChildren processRootElement
           `when`
           isRoot
        where
        processRootElement  :: LA XmlTree XmlTree
        processRootElement
            = removeWhiteSpace >>> processChild
            where
            processChild
                = choiceA [ isDTD
                            :-> removeAllWhiteSpace                 -- whitespace in DTD is redundant
                          , this
                            :-> replaceChildren ( getChildren
                                                  >>. indentTrees insertNothing False 1
                                                )
                          ]

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

    -- |
    -- filter for indenting a document tree for pretty printing.
    --
    -- the tree is traversed for inserting whitespace for tag indentation.
    --
    -- whitespace is only inserted or changed at places, where it isn't significant,
    -- is's not inserted between tags and text containing non whitespace chars.
    --
    -- whitespace is only inserted or changed at places, where it's not significant.
    -- preserving whitespace may be controlled in a document tree
    -- by a tag attribute @xml:space@
    --
    -- allowed values for this attribute are @default | preserve@.
    --
    -- input is a complete document tree or a document fragment
    -- result is the semantically equivalent formatted tree.
    --
    --
    -- see also : 'removeDocWhiteSpace'

    indentDoc               :: ArrowXml a => a XmlTree XmlTree
    indentDoc               = fromLA $
                              ( ( isRoot `guards` indentRoot )
                                `orElse`
                                (root [] [this] >>> indentRoot >>> getChildren)
                              )

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

    indentRoot              :: LA XmlTree XmlTree
    indentRoot              = processChildren indentRootChildren
        where
        indentRootChildren
            = removeText >>> indentChild >>> insertNL
            where
            removeText      = none `when` isText
            insertNL        = this <+> txt "\n"
            indentChild     = ( replaceChildren
                                ( getChildren
                                  >>.
                                  indentTrees (insertIndentation 2) False 1
                                )
                                `whenNot` isDTD
                              )

    -- ------------------------------------------------------------
    --
    -- copied from EditFilter and rewritten for arrows
    -- to remove dependency to the filter module

    indentTrees     :: (Int -> LA XmlTree XmlTree) -> Bool -> Int -> XmlTrees -> XmlTrees
    indentTrees _ _ _ []
        = []
    indentTrees indentFilter preserveSpace level ts
        = runLAs lsf ls
          ++
          indentRest rs
          where
          runLAs f l
              = runLA (constL l >>> f) undefined

          (ls, rs)
              = break XN.isElem ts

          isSignificant     :: Bool
          isSignificant
              = preserveSpace
                ||
                (not . null . runLAs isSignificantPart) ls

          isSignificantPart :: LA XmlTree XmlTree
          isSignificantPart
              = catA
                [ isText `guards` neg isWhiteSpace
                , isCdata
                , isCharRef
                , isEntityRef
                ]

          lsf       :: LA XmlTree XmlTree
          lsf
              | isSignificant
                  = this
              | otherwise
                  = (none `when` isWhiteSpace)
                    >>>
                    (indentFilter level <+> this)

          indentRest        :: XmlTrees -> XmlTrees
          indentRest []
              | isSignificant
                  = []
              | otherwise
                  = runLA (indentFilter (level - 1)) undefined

          indentRest (t':ts')
              = runLA ( ( indentElem
                          >>>
                          lsf
                        )
                        `when` isElem
                      ) t'
                ++
                ( if null ts'
                  then indentRest
                  else indentTrees indentFilter preserveSpace level
                ) ts'
              where
              indentElem
                  = replaceChildren ( getChildren
                                      >>.
                                      indentChildren
                                    )

              xmlSpaceAttrValue     :: String
              xmlSpaceAttrValue
                  = concat . runLA (getAttrValue "xml:space") $ t'

              preserveSpace'        :: Bool
              preserveSpace'
                  = ( fromMaybe preserveSpace
                      .
                      lookup xmlSpaceAttrValue
                    ) [ ("preserve", True)
                      , ("default",  False)
                      ]

              indentChildren        :: XmlTrees -> XmlTrees
              indentChildren cs'
                  | all (maybe False (all isXmlSpaceChar) . XN.getText) cs'
                      = []
                  | otherwise
                      = indentTrees indentFilter preserveSpace' (level + 1) cs'

    -- filter for indenting elements

    insertIndentation       :: Int -> Int -> LA a XmlTree
    insertIndentation indentWidth level
        = txt ('\n' : replicate (level * indentWidth) ' ')

    -- filter for removing all whitespace

    insertNothing           :: Int -> LA a XmlTree
    insertNothing _         = none

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

    -- |
    -- converts a CDATA section into normal text nodes

    transfCdata             :: ArrowXml a => a XmlTree XmlTree
    transfCdata             = fromLA $
                              (getCdata >>> mkText) `when` isCdata

    -- |
    -- converts CDATA sections in whole document tree into normal text nodes

    transfAllCdata          :: ArrowXml a => a XmlTree XmlTree
    transfAllCdata          = fromLA $ editNTreeA [isCdata :-> (getCdata >>> mkText)]

    -- |
    -- converts a character reference to normal text

    transfCharRef           :: ArrowXml a => a XmlTree XmlTree
    transfCharRef           = fromLA $
                              ( getCharRef >>> arr (\ i -> [toEnum i]) >>> mkText )
                              `when`
                              isCharRef

    -- |
    -- recursively converts all character references to normal text

    transfAllCharRef        :: ArrowXml a => a XmlTree XmlTree
    transfAllCharRef        = fromLA $ editNTreeA [isCharRef :-> (getCharRef >>> arr (\ i -> [toEnum i]) >>> mkText)]

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

    rememberDTDAttrl        :: ArrowList a => a XmlTree XmlTree
    rememberDTDAttrl
        = fromLA $
          ( ( addDTDAttrl $< ( getChildren >>> isDTDDoctype >>> getDTDAttrl ) )
            `orElse`
            this
          )
        where
        addDTDAttrl al
            = seqA . map (uncurry addAttr) . map (first (dtdPrefix ++)) $ al

    addDefaultDTDecl        :: ArrowList a => a XmlTree XmlTree
    addDefaultDTDecl
        = fromLA $
          ( addDTD $< listA (getAttrl >>> (getName &&& xshow getChildren) >>> hasDtdPrefix) )
        where
        hasDtdPrefix
            = isA (fst >>> (dtdPrefix `isPrefixOf`))
              >>>
              arr (first (drop (length dtdPrefix)))
        addDTD []
            = this
        addDTD al
            = replaceChildren
              ( mkDTDDoctype al none
                <+>
                txt "\n"
                <+>
                ( getChildren >>> (none `when` isDTDDoctype) )      -- remove old DTD decl
              )

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

    hasXmlPi                :: ArrowXml a => a XmlTree XmlTree
    hasXmlPi
        = fromLA
          ( getChildren
            >>>
            isPi
            >>>
            hasName t_xml
          )

    -- | add an \<?xml version=\"1.0\"?\> processing instruction
    -- if it's not already there

    addXmlPi                :: ArrowXml a => a XmlTree XmlTree
    addXmlPi
        = fromLA
          ( insertChildrenAt 0 ( ( mkPi (mkName t_xml) none
                                   >>>
                                   addAttr a_version "1.0"
                                 )
                                 <+>
                                 txt "\n"
                               )
            `whenNot`
            hasXmlPi
          )

    -- | add an encoding spec to the \<?xml version=\"1.0\"?\> processing instruction

    addXmlPiEncoding        :: ArrowXml a => String -> a XmlTree XmlTree
    addXmlPiEncoding enc
        = fromLA $
          processChildren ( addAttr a_encoding enc
                            `when`
                            ( isPi >>> hasName t_xml )
                          )

    -- | add an XHTML strict doctype declaration to a document

    addXHtmlDoctypeStrict
      , addXHtmlDoctypeTransitional
      , addXHtmlDoctypeFrameset     :: ArrowXml a => a XmlTree XmlTree

    -- | add an XHTML strict doctype declaration to a document

    addXHtmlDoctypeStrict
        = addDoctypeDecl "html" "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"

    -- | add an XHTML transitional doctype declaration to a document

    addXHtmlDoctypeTransitional
        = addDoctypeDecl "html" "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"

    -- | add an XHTML frameset doctype declaration to a document

    addXHtmlDoctypeFrameset
        = addDoctypeDecl "html" "-//W3C//DTD XHTML 1.0 Frameset//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd"

    -- | add a doctype declaration to a document
    --
    -- The arguments are the root element name, the PUBLIC id and the SYSTEM id

    addDoctypeDecl  :: ArrowXml a => String -> String -> String -> a XmlTree XmlTree
    addDoctypeDecl rootElem public system
        = fromLA $
          replaceChildren
          ( mkDTDDoctype ( ( if null public then id else ( (k_public, public) : ) )
                           .
                           ( if null system then id else ( (k_system, system) : ) )
                           $  [ (a_name, rootElem) ]
                         ) none
            <+>
            txt "\n"
            <+>
            getChildren
          )

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