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

{- |
   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 (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 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 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 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 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
                  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 XmlTrees
dtdPart 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 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 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 XmlTrees
dtdPart 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 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

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