module Text.XML.HXT.DTDValidation.DocValidation
( validateDoc
)
where
import Text.XML.HXT.DTDValidation.TypeDefs
import Text.XML.HXT.DTDValidation.AttributeValueValidation
import Text.XML.HXT.DTDValidation.XmlRE
type ValiEnvTable = [ValiEnv]
type ValiEnv = (ElemName, ValFct)
type ElemName = String
type ValFct = XmlArrow
validateDoc :: XmlTree -> XmlArrow
validateDoc :: XmlTree -> XmlArrow
validateDoc XmlTree
dtdPart
= ValiEnvTable -> XmlArrow
traverseTree ValiEnvTable
valTable
where
valTable :: ValiEnvTable
valTable = XmlTree -> ValiEnvTable
buildAllValidationFunctions XmlTree
dtdPart
traverseTree :: ValiEnvTable -> XmlArrow
traverseTree :: ValiEnvTable -> XmlArrow
traverseTree ValiEnvTable
valiEnv
= forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA [ forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall a b. a -> b -> IfThen a b
:-> (QName -> XmlArrow
valFct forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName)
, forall (a :: * -> * -> *) b. ArrowList a => a b b
this forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
]
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
( forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ValiEnvTable -> XmlArrow
traverseTree ValiEnvTable
valiEnv )
where
valFct :: QName -> XmlArrow
valFct :: QName -> XmlArrow
valFct QName
name = case (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (QName -> String
qualifiedName QName
name) ValiEnvTable
valiEnv) of
Maybe XmlArrow
Nothing -> forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err (String
"Element " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (QName -> String
qualifiedName QName
name) forall a. [a] -> [a] -> [a]
++ String
" not declared in DTD.")
Just XmlArrow
f -> XmlArrow
f
buildAllValidationFunctions :: XmlTree -> ValiEnvTable
buildAllValidationFunctions :: XmlTree -> ValiEnvTable
buildAllValidationFunctions XmlTree
dtdPart
= forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
XmlTree -> ValiEnvTable
buildValidateRoot XmlTree
dtdPart forall a. a -> [a] -> [a]
:
forall a b. (a -> b) -> [a] -> [b]
map (XmlTrees -> XmlTree -> ValiEnvTable
buildValidateFunctions XmlTrees
dtdNodes) XmlTrees
dtdNodes
where
dtdNodes :: XmlTrees
dtdNodes = 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
buildValidateRoot :: XmlTree -> [ValiEnv]
buildValidateRoot :: XmlTree -> ValiEnvTable
buildValidateRoot XmlTree
dn
| XmlTree -> Bool
isDTDDoctypeNode XmlTree
dn = [(String
t_root, XmlArrow
valFct)]
| Bool
otherwise = []
where
name :: String
name = 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
valFct :: XmlArrow
valFct :: XmlArrow
valFct = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
( RE String -> LA XmlTree String
checkRegex (forall a. a -> RE a
re_sym String
name)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(String -> String) -> LA String XmlTree
msgToErr ((String
"Root Element must be " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++ String
". ") forall a. [a] -> [a] -> [a]
++)
)
checkRegex :: RE String -> LA XmlTree String
checkRegex :: RE String -> LA XmlTree String
checkRegex RE String
re = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\ XmlTrees
cs -> forall a. (Eq a, Show a) => RE a -> String
checkRE (RE String -> XmlTrees -> RE String
matches RE String
re XmlTrees
cs))
buildValidateFunctions :: XmlTrees -> XmlTree -> [ValiEnv]
buildValidateFunctions :: XmlTrees -> XmlTree -> ValiEnvTable
buildValidateFunctions XmlTrees
dtdPart XmlTree
dn
| XmlTree -> Bool
isDTDElementNode XmlTree
dn = [(String
elemName, XmlArrow
valFct)]
| Bool
otherwise = []
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
valFct :: XmlArrow
valFct :: XmlArrow
valFct = XmlTree -> XmlArrow
buildContentValidation XmlTree
dn
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
XmlTrees -> XmlTree -> XmlArrow
buildAttributeValidation XmlTrees
dtdPart XmlTree
dn
buildContentValidation :: XmlTree -> XmlArrow
buildContentValidation :: XmlTree -> XmlArrow
buildContentValidation XmlTree
nd
= String -> XmlTree -> XmlArrow
contentValidation String
attrType XmlTree
nd
where
attrType :: String
attrType = Attributes -> String
dtd_type forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes forall a b. (a -> b) -> a -> b
$ XmlTree
nd
contentValidation :: String -> XmlTree -> XmlArrow
contentValidation :: String -> XmlTree -> XmlArrow
contentValidation String
typ XmlTree
dn
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_pcdata = XmlArrow
contentValidationPcdata
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_empty = XmlArrow
contentValidationEmpty
| String
typ forall a. Eq a => a -> a -> Bool
== String
k_any = XmlArrow
contentValidationAny
| String
typ forall a. Eq a => a -> a -> Bool
== String
v_children = XmlTrees -> XmlArrow
contentValidationChildren XmlTrees
cs
| String
typ forall a. Eq a => a -> a -> Bool
== String
v_mixed = XmlTrees -> XmlArrow
contentValidationMixed XmlTrees
cs
| Bool
otherwise = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
cs :: XmlTrees
cs = forall a b. LA a b -> a -> [b]
runLA forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren XmlTree
dn
contentValidationPcdata :: XmlArrow
contentValidationPcdata :: XmlArrow
contentValidationPcdata
= forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (QName -> XmlArrow
contentVal forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName)
where
contentVal :: QName -> XmlArrow
contentVal QName
name
= RE String -> LA XmlTree String
checkRegex (forall a. RE a -> RE a
re_rep (forall a. a -> RE a
re_sym String
k_pcdata))
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(String -> String) -> LA String XmlTree
msgToErr ( ( String
"The content of element " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show (QName -> String
qualifiedName QName
name) forall a. [a] -> [a] -> [a]
++
String
" must match (#PCDATA). "
) forall a. [a] -> [a] -> [a]
++
)
contentValidationEmpty :: XmlArrow
contentValidationEmpty :: XmlArrow
contentValidationEmpty
= forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (QName -> XmlArrow
contentVal forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName)
where
contentVal :: QName -> XmlArrow
contentVal QName
name
= RE String -> LA XmlTree String
checkRegex forall a. RE a
re_unit
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(String -> String) -> LA String XmlTree
msgToErr ( ( String
"The content of element " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show (QName -> String
qualifiedName QName
name) forall a. [a] -> [a] -> [a]
++
String
" must match EMPTY. "
) forall a. [a] -> [a] -> [a]
++
)
contentValidationAny :: XmlArrow
contentValidationAny :: XmlArrow
contentValidationAny
= forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (forall {a}. Show a => a -> XmlArrow
contentVal 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)
where
contentVal :: a -> XmlArrow
contentVal a
name
= RE String -> LA XmlTree String
checkRegex (forall a. RE a -> RE a
re_rep (forall a. RE a
re_dot))
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(String -> String) -> LA String XmlTree
msgToErr ( ( String
"The content of element " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show a
name forall a. [a] -> [a] -> [a]
++
String
" must match ANY. "
) forall a. [a] -> [a] -> [a]
++
)
contentValidationChildren :: XmlTrees -> XmlArrow
contentValidationChildren :: XmlTrees -> XmlArrow
contentValidationChildren XmlTrees
cm
= forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (forall {a}. Show a => a -> XmlArrow
contentVal 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)
where
contentVal :: a -> XmlArrow
contentVal a
name
= RE String -> LA XmlTree String
checkRegex RE String
re
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(String -> String) -> LA String XmlTree
msgToErr ( ( String
"The content of element " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show a
name forall a. [a] -> [a] -> [a]
++
String
" must match " forall a. [a] -> [a] -> [a]
++ forall a. (Eq a, Show a) => RE a -> String
printRE RE String
re forall a. [a] -> [a] -> [a]
++ String
". "
) forall a. [a] -> [a] -> [a]
++
)
re :: RE String
re = XmlTree -> RE String
createRE (forall a. [a] -> a
head XmlTrees
cm)
contentValidationMixed :: XmlTrees -> XmlArrow
contentValidationMixed :: XmlTrees -> XmlArrow
contentValidationMixed XmlTrees
cm
= forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (forall {a}. Show a => a -> XmlArrow
contentVal 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)
where
contentVal :: a -> XmlArrow
contentVal a
name
= RE String -> LA XmlTree String
checkRegex RE String
re
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(String -> String) -> LA String XmlTree
msgToErr ( ( String
"The content of element " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show a
name forall a. [a] -> [a] -> [a]
++
String
" must match " forall a. [a] -> [a] -> [a]
++ forall a. (Eq a, Show a) => RE a -> String
printRE RE String
re forall a. [a] -> [a] -> [a]
++ String
". "
) forall a. [a] -> [a] -> [a]
++
)
re :: RE String
re = forall a. RE a -> RE a
re_rep (forall a. Ord a => RE a -> RE a -> RE a
re_alt (forall a. a -> RE a
re_sym String
k_pcdata) (XmlTree -> RE String
createRE (forall a. [a] -> a
head XmlTrees
cm)))
createRE :: XmlTree -> RE String
createRE :: XmlTree -> RE String
createRE XmlTree
dn
| XmlTree -> Bool
isDTDContentNode XmlTree
dn
= String -> RE String
processModifier String
modifier
| XmlTree -> Bool
isDTDNameNode XmlTree
dn
= forall a. a -> RE a
re_sym String
name
| Bool
otherwise
= forall a. HasCallStack => String -> a
error (String
"createRE: illegeal parameter:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show XmlTree
dn)
where
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
dn
name :: String
name = Attributes -> String
dtd_name Attributes
al
modifier :: String
modifier = Attributes -> String
dtd_modifier Attributes
al
kind :: String
kind = Attributes -> String
dtd_kind Attributes
al
cs :: XmlTrees
cs = forall a b. LA a b -> a -> [b]
runLA forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren XmlTree
dn
processModifier :: String -> RE String
processModifier :: String -> RE String
processModifier String
m
| String
m forall a. Eq a => a -> a -> Bool
== String
v_plus = forall a. RE a -> RE a
re_plus (String -> RE String
processKind String
kind)
| String
m forall a. Eq a => a -> a -> Bool
== String
v_star = forall a. RE a -> RE a
re_rep (String -> RE String
processKind String
kind)
| String
m forall a. Eq a => a -> a -> Bool
== String
v_option = forall a. Ord a => RE a -> RE a
re_opt (String -> RE String
processKind String
kind)
| String
m forall a. Eq a => a -> a -> Bool
== String
v_null = String -> RE String
processKind String
kind
| Bool
otherwise = forall a. HasCallStack => String -> a
error (String
"Unknown modifier: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
m)
processKind :: String -> RE String
processKind :: String -> RE String
processKind String
k
| String
k forall a. Eq a => a -> a -> Bool
== String
v_seq = XmlTrees -> RE String
makeSequence XmlTrees
cs
| String
k forall a. Eq a => a -> a -> Bool
== String
v_choice = XmlTrees -> RE String
makeChoice XmlTrees
cs
| Bool
otherwise = forall a. HasCallStack => String -> a
error (String
"Unknown kind: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
k)
makeSequence :: XmlTrees -> RE String
makeSequence :: XmlTrees -> RE String
makeSequence [] = forall a. RE a
re_unit
makeSequence (XmlTree
x:XmlTrees
xs) = forall a. RE a -> RE a -> RE a
re_seq (XmlTree -> RE String
createRE XmlTree
x) (XmlTrees -> RE String
makeSequence XmlTrees
xs)
makeChoice :: XmlTrees -> RE String
makeChoice :: XmlTrees -> RE String
makeChoice [] = forall a. String -> RE a
re_zero String
""
makeChoice (XmlTree
x:XmlTrees
xs) = forall a. Ord a => RE a -> RE a -> RE a
re_alt (XmlTree -> RE String
createRE XmlTree
x) (XmlTrees -> RE String
makeChoice XmlTrees
xs)
buildAttributeValidation :: XmlTrees -> XmlTree -> XmlArrow
buildAttributeValidation :: XmlTrees -> XmlTree -> XmlArrow
buildAttributeValidation XmlTrees
dtdPart XmlTree
nd =
XmlArrow
noDoublicateAttributes
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
XmlTrees -> XmlTree -> XmlArrow
checkNotDeclardAttributes XmlTrees
attrDecls XmlTree
nd
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
XmlTrees -> XmlTree -> XmlArrow
checkRequiredAttributes XmlTrees
attrDecls XmlTree
nd
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
XmlTrees -> XmlTree -> XmlArrow
checkFixedAttributes XmlTrees
attrDecls XmlTree
nd
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
XmlTrees -> XmlTrees -> XmlTree -> XmlArrow
checkValuesOfAttributes XmlTrees
attrDecls XmlTrees
dtdPart XmlTree
nd
where
attrDecls :: XmlTrees
attrDecls = forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
dtdPart
noDoublicateAttributes :: XmlArrow
noDoublicateAttributes :: XmlArrow
noDoublicateAttributes
= forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
( forall {cat :: * -> * -> *} {p}.
(ArrowXml cat, Show p) =>
p -> cat XmlTree XmlTree
noDoubles' 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 )
where
noDoubles' :: p -> cat XmlTree XmlTree
noDoubles' p
elemName
= forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl 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 XmlTree String
getName)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. ArrowList a => a b (a b c) -> a b c
applyA (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a :: * -> * -> *} {a} {n}.
(ArrowXml a, Show a) =>
a -> a n XmlTree
toErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
doubles forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse))
where
toErr :: a -> a n XmlTree
toErr a
n1 = forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n1 forall a. [a] -> [a] -> [a]
++
String
" was already specified for element " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show p
elemName forall a. [a] -> [a] -> [a]
++ String
"."
)
checkRequiredAttributes :: XmlTrees -> XmlTree -> XmlArrow
checkRequiredAttributes :: XmlTrees -> XmlTree -> XmlArrow
checkRequiredAttributes XmlTrees
attrDecls XmlTree
dn
| XmlTree -> Bool
isDTDElementNode XmlTree
dn
= forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
( String -> XmlArrow
checkRequired 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 c. ArrowList a => a b c
none
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
requiredAtts :: XmlTrees
requiredAtts = (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
isRequiredAttrKind) XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
attrDecls
checkRequired :: String -> XmlArrow
checkRequired :: String -> XmlArrow
checkRequired String
name
= forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map XmlTree -> XmlArrow
checkReq forall a b. (a -> b) -> a -> b
$ XmlTrees
requiredAtts
where
checkReq :: XmlTree -> XmlArrow
checkReq :: XmlTree -> XmlArrow
checkReq XmlTree
attrDecl
= forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b b
neg (forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasAttr String
attName)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attName forall a. [a] -> [a] -> [a]
++ String
" must be declared for element type " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++ String
"." )
where
attName :: String
attName = Attributes -> String
dtd_value forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes forall a b. (a -> b) -> a -> b
$ XmlTree
attrDecl
checkFixedAttributes :: XmlTrees -> XmlTree -> XmlArrow
checkFixedAttributes :: XmlTrees -> XmlTree -> XmlArrow
checkFixedAttributes XmlTrees
attrDecls XmlTree
dn
| XmlTree -> Bool
isDTDElementNode XmlTree
dn
= forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
( String -> XmlArrow
checkFixed 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 c. ArrowList a => a b c
none
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
fixedAtts :: XmlTrees
fixedAtts = (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) XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
attrDecls
checkFixed :: String -> XmlArrow
checkFixed :: String -> XmlArrow
checkFixed String
name
= forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map XmlTree -> XmlArrow
checkFix forall a b. (a -> b) -> a -> b
$ XmlTrees
fixedAtts
where
checkFix :: XmlTree -> XmlArrow
checkFix :: XmlTree -> XmlArrow
checkFix XmlTree
an
| XmlTree -> Bool
isDTDAttlistNode XmlTree
an
= String -> XmlArrow
checkFixedVal forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
attName
| Bool
otherwise
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
al' :: Attributes
al' = XmlTree -> Attributes
getDTDAttributes XmlTree
an
attName :: String
attName = Attributes -> String
dtd_value Attributes
al'
defa :: String
defa = Attributes -> String
dtd_default Attributes
al'
fixedValue :: String
fixedValue = Maybe XmlTree -> String -> String
normalizeAttributeValue (forall a. a -> Maybe a
Just XmlTree
an) String
defa
checkFixedVal :: String -> XmlArrow
checkFixedVal :: String -> XmlArrow
checkFixedVal String
val
= ( ( forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasAttr String
attName
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (forall a b. a -> b -> a
const (String
attValue forall a. Eq a => a -> a -> Bool
/= String
fixedValue))
)
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attName forall a. [a] -> [a] -> [a]
++ String
" of element " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++
String
" with value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attValue forall a. [a] -> [a] -> [a]
++ String
" must have a value of " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show String
fixedValue forall a. [a] -> [a] -> [a]
++ String
"." )
)
where
attValue :: String
attValue = Maybe XmlTree -> String -> String
normalizeAttributeValue (forall a. a -> Maybe a
Just XmlTree
an) String
val
checkNotDeclardAttributes :: XmlTrees -> XmlTree -> XmlArrow
checkNotDeclardAttributes :: XmlTrees -> XmlTree -> XmlArrow
checkNotDeclardAttributes XmlTrees
attrDecls XmlTree
elemDescr
= XmlArrow
checkNotDeclared
where
elemName :: String
elemName = String -> XmlTree -> String
valueOfDTD String
a_name XmlTree
elemDescr
decls :: XmlTrees
decls = forall (a :: * -> * -> *).
ArrowDTD a =>
String -> a XmlTree XmlTree
isAttlistOfElement String
elemName XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
attrDecls
checkNotDeclared :: XmlArrow
checkNotDeclared :: XmlArrow
checkNotDeclared
= forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
( forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> String -> XmlTrees -> XmlArrow
searchForDeclaredAtt String
elemName XmlTrees
decls )
searchForDeclaredAtt :: String -> XmlTrees -> XmlArrow
searchForDeclaredAtt :: String -> XmlTrees -> XmlArrow
searchForDeclaredAtt String
name (XmlTree
dn : XmlTrees
xs)
| XmlTree -> Bool
isDTDAttlistNode XmlTree
dn
= ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ( (Attributes -> String
dtd_value forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes forall a b. (a -> b) -> a -> b
$ XmlTree
dn) forall a. Eq a => a -> a -> Bool
/= ) )
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
String -> XmlTrees -> XmlArrow
searchForDeclaredAtt String
name XmlTrees
xs
| Bool
otherwise
= String -> XmlTrees -> XmlArrow
searchForDeclaredAtt String
name XmlTrees
xs
searchForDeclaredAtt String
name []
= forall {a :: * -> * -> *} {a} {n}.
(ArrowXml a, Show a) =>
a -> a n XmlTree
mkErr 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
where
mkErr :: a -> a n XmlTree
mkErr a
n = forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ String
" of element " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++ String
" is not declared in DTD." )
checkValuesOfAttributes :: XmlTrees -> XmlTrees -> XmlTree -> XmlArrow
checkValuesOfAttributes :: XmlTrees -> XmlTrees -> XmlTree -> XmlArrow
checkValuesOfAttributes XmlTrees
attrDecls XmlTrees
dtdPart XmlTree
elemDescr
= XmlArrow
checkValues
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
elemDescr
decls :: XmlTrees
decls = forall (a :: * -> * -> *).
ArrowDTD a =>
String -> a XmlTree XmlTree
isAttlistOfElement String
elemName XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
attrDecls
checkValues :: XmlArrow
checkValues :: XmlArrow
checkValues
= forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
( XmlTree -> XmlArrow
checkValue forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl )
checkValue :: XmlTree -> XmlArrow
checkValue XmlTree
att
= forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map XmlTree -> XmlArrow
checkVal forall a b. (a -> b) -> a -> b
$ XmlTrees
decls
where
checkVal :: XmlTree -> XmlArrow
checkVal :: XmlTree -> XmlArrow
checkVal XmlTree
attrDecl
| XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
Bool -> Bool -> Bool
&&
XmlTree -> String
nameOfAttr XmlTree
att forall a. Eq a => a -> a -> Bool
== Attributes -> String
dtd_value Attributes
al'
= XmlTrees -> XmlTree -> XmlArrow
checkAttributeValue XmlTrees
dtdPart XmlTree
attrDecl
| Bool
otherwise
= forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
al' :: Attributes
al' = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl