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
type TransEnvTable = M.Map ElemName TransFct
type ElemName = String
type TransFct = XmlArrow
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)
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
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
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
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)
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)
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
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
= ( forall (a :: * -> * -> *).
ArrowXml a =>
String -> String -> a XmlTree XmlTree
addAttr String
attName String
defaultValue
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