module Text.XML.HXT.DTDValidation.IdValidation
( validateIds
)
where
import Data.Maybe
import Text.XML.HXT.DTDValidation.TypeDefs
import Text.XML.HXT.DTDValidation.AttributeValueValidation
type IdEnvTable = [IdEnv]
type IdEnv = (ElemName, IdFct)
type ElemName = String
type IdFct = XmlArrow
validateIds :: XmlTree -> XmlArrow
validateIds :: XmlTree -> XmlArrow
validateIds XmlTree
dtdPart
= XmlTrees -> XmlArrow
validateIds' forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (IdEnvTable -> XmlArrow
traverseTree IdEnvTable
idEnv)
where
idAttrTypes :: XmlTrees
idAttrTypes = forall a b. LA a b -> a -> [b]
runLA (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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isIdAttrType) XmlTree
dtdPart
elements :: XmlTrees
elements = forall a b. LA a b -> a -> [b]
runLA (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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDElement) XmlTree
dtdPart
atts :: XmlTrees
atts = forall a b. LA a b -> a -> [b]
runLA (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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist) XmlTree
dtdPart
idEnv :: IdEnvTable
idEnv = XmlTrees -> IdEnvTable
buildIdCollectorFcts XmlTrees
idAttrTypes
validateIds' :: XmlTrees -> XmlArrow
validateIds' :: XmlTrees -> XmlArrow
validateIds' XmlTrees
idNodeList
= ( forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA XmlTrees
idNodeList forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> XmlTrees -> LA XmlTrees XmlTree
checkForUniqueIds XmlTrees
idAttrTypes )
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
IdEnvTable -> XmlArrow
checkIdReferences IdEnvTable
idRefEnv
where
idRefEnv :: IdEnvTable
idRefEnv = XmlTrees -> XmlTrees -> XmlTrees -> XmlTrees -> IdEnvTable
buildIdrefValidationFcts XmlTrees
idAttrTypes XmlTrees
elements XmlTrees
atts XmlTrees
idNodeList
traverseTree :: IdEnvTable -> XmlArrow
traverseTree :: IdEnvTable -> XmlArrow
traverseTree IdEnvTable
idEnv
= forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi (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
idFct 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
idFct :: String -> XmlArrow
idFct :: String -> XmlArrow
idFct String
name = forall a. a -> Maybe a -> a
fromMaybe forall (a :: * -> * -> *) b c. ArrowList a => a b c
none forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name forall a b. (a -> b) -> a -> b
$ IdEnvTable
idEnv
getIdValue :: XmlTrees -> XmlTree -> String
getIdValue :: XmlTrees -> XmlTree -> String
getIdValue XmlTrees
dns
= forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. LA a b -> a -> [b]
runLA (forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b c
single LA XmlTree String
getIdValue')
where
getIdValue' :: LA XmlTree String
getIdValue' :: LA XmlTree String
getIdValue'
= 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 :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA (forall a b. (a -> b) -> [a] -> [b]
map forall {a :: * -> * -> *}.
ArrowXml a =>
XmlTree -> a XmlTree String
getIdVal XmlTrees
dns)
where
getIdVal :: XmlTree -> a XmlTree String
getIdVal XmlTree
dn
| XmlTree -> Bool
isDTDAttlistNode XmlTree
dn = forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasName String
elemName
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
( forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue0 String
attrName
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 (Maybe XmlTree -> String -> String
normalizeAttributeValue (forall a. a -> Maybe a
Just XmlTree
dn))
)
| Bool
otherwise = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
where
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
dn
elemName :: String
elemName = Attributes -> String
dtd_name Attributes
al
attrName :: String
attrName = Attributes -> String
dtd_value Attributes
al
buildIdCollectorFcts :: XmlTrees -> IdEnvTable
buildIdCollectorFcts :: XmlTrees -> IdEnvTable
buildIdCollectorFcts XmlTrees
idAttrTypes
= forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlTree -> IdEnvTable
buildIdCollectorFct XmlTrees
idAttrTypes
where
buildIdCollectorFct :: XmlTree -> [IdEnv]
buildIdCollectorFct :: XmlTree -> IdEnvTable
buildIdCollectorFct XmlTree
dn
| XmlTree -> Bool
isDTDAttlistNode XmlTree
dn = [(String
elemName, forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasAttr String
attrName)]
| Bool
otherwise = []
where
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
dn
elemName :: String
elemName = Attributes -> String
dtd_name Attributes
al
attrName :: String
attrName = Attributes -> String
dtd_value Attributes
al
buildIdrefValidationFcts :: XmlTrees -> XmlTrees -> XmlTrees -> XmlTrees -> IdEnvTable
buildIdrefValidationFcts :: XmlTrees -> XmlTrees -> XmlTrees -> XmlTrees -> IdEnvTable
buildIdrefValidationFcts XmlTrees
idAttrTypes XmlTrees
elements XmlTrees
atts XmlTrees
idNodeList
= forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlTree -> IdEnvTable
buildElemValidationFct XmlTrees
elements
where
idValueList :: [String]
idValueList = forall a b. (a -> b) -> [a] -> [b]
map (XmlTrees -> XmlTree -> String
getIdValue XmlTrees
idAttrTypes) XmlTrees
idNodeList
buildElemValidationFct :: XmlTree -> [IdEnv]
buildElemValidationFct :: XmlTree -> IdEnvTable
buildElemValidationFct XmlTree
dn
| XmlTree -> Bool
isDTDElementNode XmlTree
dn = [(String
elemName, XmlTrees -> XmlArrow
buildIdrefValidationFct XmlTrees
idRefAttrTypes)]
| Bool
otherwise = []
where
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
dn
elemName :: String
elemName = Attributes -> String
dtd_name Attributes
al
idRefAttrTypes :: XmlTrees
idRefAttrTypes = (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
isIdRefAttrType) XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
atts
buildIdrefValidationFct :: XmlTrees -> XmlArrow
buildIdrefValidationFct :: XmlTrees -> XmlArrow
buildIdrefValidationFct
= 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
buildIdref
buildIdref :: XmlTree -> XmlArrow
buildIdref :: XmlTree -> XmlArrow
buildIdref XmlTree
dn
| XmlTree -> Bool
isDTDAttlistNode XmlTree
dn = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (String -> XmlArrow
checkIdref 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
al :: Attributes
al = XmlTree -> Attributes
getDTDAttributes XmlTree
dn
attrName :: String
attrName = Attributes -> String
dtd_value Attributes
al
attrType :: String
attrType = Attributes -> String
dtd_type Attributes
al
checkIdref :: String -> XmlArrow
checkIdref :: String -> XmlArrow
checkIdref String
name
= forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasAttr String
attrName
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
( String -> XmlArrow
checkIdVal 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
attrName )
where
checkIdVal :: String -> XmlArrow
checkIdVal :: String -> XmlArrow
checkIdVal String
av
| String
attrType forall a. Eq a => a -> a -> Bool
== String
k_idref
= String -> XmlArrow
checkValueDeclared String
attrValue
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
valueList
= 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
attrName 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
" must have at least one name."
)
| Bool
otherwise
= 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 String -> XmlArrow
checkValueDeclared forall a b. (a -> b) -> a -> b
$ [String]
valueList
where
valueList :: [String]
valueList = String -> [String]
words String
attrValue
attrValue :: String
attrValue = Maybe XmlTree -> String -> String
normalizeAttributeValue (forall a. a -> Maybe a
Just XmlTree
dn) String
av
checkValueDeclared :: String -> XmlArrow
checkValueDeclared :: String -> XmlArrow
checkValueDeclared String
attrValue
= if String
attrValue forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
idValueList
then forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
else forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"An Element with identifier " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attrValue forall a. [a] -> [a] -> [a]
++
String
" must appear in the document."
)
checkForUniqueIds :: XmlTrees -> LA XmlTrees XmlTree
checkForUniqueIds :: XmlTrees -> LA XmlTrees XmlTree
checkForUniqueIds XmlTrees
idAttrTypes
= forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA
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 XmlTree
isElem
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(String -> XmlTree -> SLA [String] XmlTree XmlTree
checkForUniqueId forall (a :: * -> * -> *) c1 c2 b d.
ArrowList a =>
(c1 -> c2 -> a b d) -> a b (c1, c2) -> a b d
$<< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (a :: * -> * -> *) b. ArrowList a => a b b
this)
)
where
checkForUniqueId :: String -> XmlTree -> SLA [String] XmlTree XmlTree
checkForUniqueId :: String -> XmlTree -> SLA [String] XmlTree XmlTree
checkForUniqueId String
name XmlTree
x
= forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA ( forall s (a :: * -> * -> *) b. ArrowState s a => a b s
getState
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 (String
attrValue forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`)
)
(forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attrValue forall a. [a] -> [a] -> [a]
++ String
" of type ID for element " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++ String
" must be unique within the document." ))
(forall s (a :: * -> * -> *) b. ArrowState s a => (s -> s) -> a b s
nextState (String
attrValueforall a. a -> [a] -> [a]
:) 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 c
none)
where
attrValue :: String
attrValue = XmlTrees -> XmlTree -> String
getIdValue (forall (a :: * -> * -> *).
ArrowDTD a =>
String -> a XmlTree XmlTree
isAttlistOfElement String
name XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
idAttrTypes) XmlTree
x
checkIdReferences :: IdEnvTable -> LA XmlTree XmlTree
checkIdReferences :: IdEnvTable -> XmlArrow
checkIdReferences IdEnvTable
idRefEnv
= IdEnvTable -> XmlArrow
traverseTree IdEnvTable
idRefEnv