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

{- |
   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 XmlTree
dtdPart
    = TransEnvTable -> XmlArrow
traverseTree TransEnvTable
transTable
    where
    transTable :: TransEnvTable
transTable = XmlTrees -> TransEnvTable
buildAllTransformationFunctions (forall a b. LA a b -> a -> [b]
runLA 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 TransEnvTable
transEnv
    = forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
processTopDown ( (String -> XmlArrow
transFct forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName)
                       forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
                       forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
                     )
    where
    transFct            :: String -> XmlArrow
    transFct :: String -> XmlArrow
transFct String
name       = forall a. a -> Maybe a -> a
fromMaybe forall (a :: * -> * -> *) b. ArrowList a => a b b
this forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name 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 XmlTrees
dtdNodes
    = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
      (String
t_root, forall (a :: * -> * -> *) b. ArrowList a => a b b
this)
      forall a. a -> [a] -> [a]
:
      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 XmlTrees
dtdPart 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
                  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
                  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
    = forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
setAttrl (forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl 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         = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (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 XmlTrees
dtdPart XmlTree
dn
    | XmlTree -> Bool
isDTDElementNode XmlTree
dn       = forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
processAttrl (String -> XmlArrow
normalizeAttr forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName)
    | Bool
otherwise                 = 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 = forall (a :: * -> * -> *).
ArrowDTD a =>
String -> a XmlTree XmlTree
isAttlistOfElement String
elemName XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
dtdPart

    normalizeAttr :: String -> XmlArrow
    normalizeAttr :: String -> XmlArrow
normalizeAttr String
nameOfAtt
        = Maybe XmlTree -> XmlArrow
normalizeAttrValue ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null XmlTrees
attDescr
                               then forall a. Maybe a
Nothing
                               else forall a. a -> Maybe a
Just (forall a. [a] -> a
head XmlTrees
attDescr)
                             )
          where
          attDescr :: XmlTrees
attDescr = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== String
nameOfAtt) 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 Maybe XmlTree
descr
        = forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren ((forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ Maybe XmlTree -> String -> String
normalizeAttributeValue Maybe XmlTree
descr) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> 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 XmlTrees
dtdPart XmlTree
dn
    | XmlTree -> Bool
isDTDElementNode XmlTree
dn       = forall (a :: * -> * -> *) b. ArrowList a => [a b b] -> a b b
seqA (forall a b. (a -> b) -> [a] -> [b]
map XmlTree -> XmlArrow
setDefault XmlTrees
defaultAtts)
    | Bool
otherwise                 = forall (a :: * -> * -> *) b. ArrowList a => a b b
this
    where
    elemName :: String
elemName    = Attributes -> String
dtd_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes forall a b. (a -> b) -> a -> b
$ XmlTree
dn
    defaultAtts :: XmlTrees
defaultAtts = ( forall (a :: * -> * -> *).
ArrowDTD a =>
String -> a XmlTree XmlTree
isAttlistOfElement String
elemName
                    forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                    ( forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isFixedAttrKind           -- select attributes with default values
                      forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse`
                      forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDefaultAttrKind
                    )
                  ) XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
dtdPart

    setDefault  :: XmlTree -> XmlArrow
    setDefault :: XmlTree -> XmlArrow
setDefault XmlTree
attrDescr                        -- add the default attributes
          = ( forall (a :: * -> * -> *).
ArrowXml a =>
String -> String -> a XmlTree XmlTree
addAttr String
attName String
defaultValue      -- to tag nodes with missing attributes
              forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`whenNot`
              forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasAttr String
attName
            )
            forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
            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

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