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

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

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

       This module provides functions for transforming XML documents represented as
       XmlTree with respect to its DTD.

       Transforming an XML document with respect to its DTD means:

        - add all attributes with default values

        - normalize all attribute values

        - sort all attributes in lexical order

       Note: Transformation should be started after validation.

       Before the document is validated, a lookup-table is build on the basis of
       the DTD which maps element names to their transformation functions.
       After this initialization phase the whole document is traversed in preorder
       and every element is transformed by the XmlFilter from the lookup-table.

    -}

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

    module Text.XML.HXT.DTDValidation.DocTransformation
        ( transform
        )
    where

    import Text.XML.HXT.DTDValidation.TypeDefs
    import Text.XML.HXT.DTDValidation.AttributeValueValidation

    import Data.Maybe
    import Data.List
    import Data.Ord
    import qualified Data.Map as M

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

    -- |
    -- Lookup-table which maps element names to their transformation functions. The
    -- transformation functions are XmlArrows.

    type TransEnvTable      = M.Map ElemName TransFct
    type ElemName           = String
    type TransFct           = XmlArrow

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

    -- |
    -- filter for transforming the document.
    --
    --    * 1.parameter dtdPart :  the DTD subset (Node @DOCTYPE@) of the XmlTree
    --
    --    - 2.parameter doc :  the document subset of the XmlTree
    --
    --    - returns : a list of errors

    transform :: XmlTree -> XmlArrow
    transform :: XmlTree -> XmlArrow
    transform dtdPart :: XmlTree
    dtdPart
        = TransEnvTable -> XmlArrow
    traverseTree TransEnvTable
    transTable
        where
        transTable :: TransEnvTable
    transTable = XmlTrees -> TransEnvTable
    buildAllTransformationFunctions (XmlArrow -> XmlTree -> XmlTrees
    forall a b. LA a b -> a -> [b]
    runLA XmlArrow
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren XmlTree
    dtdPart)

    -- |
    -- Traverse the XmlTree in preorder.
    --
    --    * 1.parameter transEnv :  lookup-table which maps element names to their transformation functions
    --
    --    - returns : the whole transformed document

    traverseTree :: TransEnvTable -> XmlArrow
    traverseTree :: TransEnvTable -> XmlArrow
    traverseTree transEnv :: TransEnvTable
    transEnv
        = XmlArrow -> XmlArrow
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b) -> a (t b) (t b)
    processTopDown ( (String -> XmlArrow
    transFct (String -> XmlArrow) -> LA XmlTree String -> XmlArrow
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getName)
                           XmlArrow -> XmlArrow -> XmlArrow
    forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
    `when`
                           XmlArrow
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isElem
                         )
        where
        transFct            :: String -> XmlArrow
        transFct :: String -> XmlArrow
    transFct name :: String
    name       = XmlArrow -> Maybe XmlArrow -> XmlArrow
    forall a. a -> Maybe a -> a
    fromMaybe XmlArrow
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this (Maybe XmlArrow -> XmlArrow)
    -> (TransEnvTable -> Maybe XmlArrow) -> TransEnvTable -> XmlArrow
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> TransEnvTable -> Maybe XmlArrow
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup String
    name (TransEnvTable -> XmlArrow) -> TransEnvTable -> XmlArrow
    forall a b. (a -> b) -> a -> b
    $ TransEnvTable
    transEnv

    -- |
    -- Build all transformation functions.
    --
    --    * 1.parameter dtdPart :  the DTD subset, root node should be of type @DOCTYPE@
    --
    --    - returns : lookup-table which maps element names to their transformation functions

    buildAllTransformationFunctions :: XmlTrees -> TransEnvTable
    buildAllTransformationFunctions :: XmlTrees -> TransEnvTable
    buildAllTransformationFunctions dtdNodes :: XmlTrees
    dtdNodes
        = [(String, XmlArrow)] -> TransEnvTable
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList ([(String, XmlArrow)] -> TransEnvTable)
    -> [(String, XmlArrow)] -> TransEnvTable
    forall a b. (a -> b) -> a -> b
    $
          (String
    t_root, XmlArrow
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this)
          (String, XmlArrow) -> [(String, XmlArrow)] -> [(String, XmlArrow)]
    forall a. a -> [a] -> [a]
    :
          (XmlTree -> [(String, XmlArrow)])
    -> XmlTrees -> [(String, XmlArrow)]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (XmlTrees -> XmlTree -> [(String, XmlArrow)]
    buildTransformationFunctions XmlTrees
    dtdNodes) XmlTrees
    dtdNodes

    -- |
    -- Build transformation functions for an element.
    --
    --    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
    --
    --    * 1.parameter nd :  element declaration for which the transformation functions are
    --                    created
    --
    --    - returns : entry for the lookup-table

    buildTransformationFunctions :: XmlTrees -> XmlTree -> [(ElemName, TransFct)]

    buildTransformationFunctions :: XmlTrees -> XmlTree -> [(String, XmlArrow)]
    buildTransformationFunctions dtdPart :: XmlTrees
    dtdPart dn :: XmlTree
    dn
        | XmlTree -> Bool
    isDTDElementNode XmlTree
    dn       = [(String
    name, XmlArrow
    transFct)]
        | Bool
    otherwise                 = []
        where
        al :: Attributes
    al          = XmlTree -> Attributes
    getDTDAttributes XmlTree
    dn
        name :: String
    name        = Attributes -> String
    dtd_name Attributes
    al
        transFct :: XmlArrow
    transFct    = XmlTrees -> XmlTree -> XmlArrow
    setDefaultAttributeValues XmlTrees
    dtdPart XmlTree
    dn
                      XmlArrow -> XmlArrow -> XmlArrow
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                      XmlTrees -> XmlTree -> XmlArrow
    normalizeAttributeValues XmlTrees
    dtdPart XmlTree
    dn
                      XmlArrow -> XmlArrow -> XmlArrow
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                      XmlArrow
    lexicographicAttributeOrder

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

    -- |
    -- Sort the attributes of an element in lexicographic order.
    --
    --    * returns : a function which takes an element (XTag), sorts its
    --                  attributes in lexicographic order and returns the changed element

    lexicographicAttributeOrder :: XmlArrow
    lexicographicAttributeOrder :: XmlArrow
    lexicographicAttributeOrder
        = XmlArrow -> XmlArrow
    forall (a :: * -> * -> *).
    ArrowXml a =>
    a XmlTree XmlTree -> a XmlTree XmlTree
    setAttrl (XmlArrow
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    getAttrl XmlArrow -> (XmlTrees -> XmlTrees) -> XmlArrow
    forall (a :: * -> * -> *) b c d.
    ArrowList a =>
    a b c -> ([c] -> [d]) -> a b d
    >>. XmlTrees -> XmlTrees
    sortAttrl)
          where
          sortAttrl         :: XmlTrees -> XmlTrees
          sortAttrl :: XmlTrees -> XmlTrees
    sortAttrl         = (XmlTree -> XmlTree -> Ordering) -> XmlTrees -> XmlTrees
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy ((XmlTree -> String) -> XmlTree -> XmlTree -> Ordering
    forall a b. Ord a => (b -> a) -> b -> b -> Ordering
    comparing XmlTree -> String
    nameOfAttr)

    -- |
    -- Normalize attribute values.
    --
    --    * returns : a function which takes an element (XTag), normalizes its
    --                  attribute values and returns the changed element

    normalizeAttributeValues :: XmlTrees -> XmlTree -> XmlArrow
    normalizeAttributeValues :: XmlTrees -> XmlTree -> XmlArrow
    normalizeAttributeValues dtdPart :: XmlTrees
    dtdPart dn :: XmlTree
    dn
        | XmlTree -> Bool
    isDTDElementNode XmlTree
    dn       = XmlArrow -> XmlArrow
    forall (a :: * -> * -> *).
    ArrowXml a =>
    a XmlTree XmlTree -> a XmlTree XmlTree
    processAttrl (String -> XmlArrow
    normalizeAttr (String -> XmlArrow) -> LA XmlTree String -> XmlArrow
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getName)
        | Bool
    otherwise                 = XmlArrow
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this
        where
        al :: Attributes
    al           = XmlTree -> Attributes
    getDTDAttributes XmlTree
    dn
        elemName :: String
    elemName     = Attributes -> String
    dtd_name Attributes
    al
        declaredAtts :: XmlTrees
    declaredAtts = String -> XmlArrow
    forall (a :: * -> * -> *).
    ArrowDTD a =>
    String -> a XmlTree XmlTree
    isAttlistOfElement String
    elemName XmlArrow -> XmlTrees -> XmlTrees
    $$ XmlTrees
    dtdPart

        normalizeAttr :: String -> XmlArrow
        normalizeAttr :: String -> XmlArrow
    normalizeAttr nameOfAtt :: String
    nameOfAtt
            = Maybe XmlTree -> XmlArrow
    normalizeAttrValue ( if XmlTrees -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null XmlTrees
    attDescr
                                   then Maybe XmlTree
    forall a. Maybe a
    Nothing
                                   else XmlTree -> Maybe XmlTree
    forall a. a -> Maybe a
    Just (XmlTrees -> XmlTree
    forall a. [a] -> a
    head XmlTrees
    attDescr)
                                 )
              where
              attDescr :: XmlTrees
    attDescr = (XmlTree -> Bool) -> XmlTrees -> XmlTrees
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    nameOfAtt) (String -> Bool) -> (XmlTree -> String) -> XmlTree -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> XmlTree -> String
    valueOfDTD String
    a_value) XmlTrees
    declaredAtts

        normalizeAttrValue :: Maybe XmlTree -> XmlArrow
        normalizeAttrValue :: Maybe XmlTree -> XmlArrow
    normalizeAttrValue descr :: Maybe XmlTree
    descr
            = XmlArrow -> XmlArrow
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b) -> a (t b) (t b)
    replaceChildren ((XmlArrow -> LA XmlTree String
    forall (a :: * -> * -> *) n.
    ArrowXml a =>
    a n XmlTree -> a n String
    xshow XmlArrow
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren LA XmlTree String -> (String -> String) -> LA XmlTree String
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> (c -> d) -> a b d
    >>^ Maybe XmlTree -> String -> String
    normalizeAttributeValue Maybe XmlTree
    descr) LA XmlTree String -> LA String XmlTree -> XmlArrow
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> LA String XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a String XmlTree
    mkText)

    -- |
    -- Set default attribute values if they are not set.
    --
    --    * returns : a function which takes an element (XTag), adds missing attribute
    --                  defaults and returns the changed element

    setDefaultAttributeValues :: XmlTrees -> XmlTree -> XmlArrow
    setDefaultAttributeValues :: XmlTrees -> XmlTree -> XmlArrow
    setDefaultAttributeValues dtdPart :: XmlTrees
    dtdPart dn :: XmlTree
    dn
        | XmlTree -> Bool
    isDTDElementNode XmlTree
    dn       = [XmlArrow] -> XmlArrow
    forall (a :: * -> * -> *) b. ArrowList a => [a b b] -> a b b
    seqA ((XmlTree -> XmlArrow) -> XmlTrees -> [XmlArrow]
    forall a b. (a -> b) -> [a] -> [b]
    map XmlTree -> XmlArrow
    setDefault XmlTrees
    defaultAtts)
        | Bool
    otherwise                 = XmlArrow
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this
        where
        elemName :: String
    elemName    = Attributes -> String
    dtd_name (Attributes -> String)
    -> (XmlTree -> Attributes) -> XmlTree -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XmlTree -> Attributes
    getDTDAttributes (XmlTree -> String) -> XmlTree -> String
    forall a b. (a -> b) -> a -> b
    $ XmlTree
    dn
        defaultAtts :: XmlTrees
    defaultAtts = ( String -> XmlArrow
    forall (a :: * -> * -> *).
    ArrowDTD a =>
    String -> a XmlTree XmlTree
    isAttlistOfElement String
    elemName
                        XmlArrow -> XmlArrow -> XmlArrow
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                        ( XmlArrow
    forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
    isFixedAttrKind           -- select attributes with default values
                          XmlArrow -> XmlArrow -> XmlArrow
    forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
    `orElse`
                          XmlArrow
    forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
    isDefaultAttrKind
                        )
                      ) XmlArrow -> XmlTrees -> XmlTrees
    $$ XmlTrees
    dtdPart

        setDefault  :: XmlTree -> XmlArrow
        setDefault :: XmlTree -> XmlArrow
    setDefault attrDescr :: XmlTree
    attrDescr                        -- add the default attributes
              = ( String -> String -> XmlArrow
    forall (a :: * -> * -> *).
    ArrowXml a =>
    String -> String -> a XmlTree XmlTree
    addAttr String
    attName String
    defaultValue      -- to tag nodes with missing attributes
                  XmlArrow -> XmlArrow -> XmlArrow
    forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
    `whenNot`
                  String -> XmlArrow
    forall (a :: * -> * -> *).
    ArrowXml a =>
    String -> a XmlTree XmlTree
    hasAttr String
    attName
                )
                XmlArrow -> XmlArrow -> XmlArrow
    forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
    `when`
                XmlArrow
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isElem
            where
            al :: Attributes
    al              = XmlTree -> Attributes
    getDTDAttributes XmlTree
    attrDescr
            attName :: String
    attName         = Attributes -> String
    dtd_value   Attributes
    al
            defaultValue :: String
    defaultValue    = Attributes -> String
    dtd_default Attributes
    al

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